feat(users/Profpatsch): init openlab-tools
Back at my bullshit. Mostly copied the setup from whatcd-resolver. Change-Id: I9edd4387ee73c18816b1692d5338735536cce70f Reviewed-on: https://cl.tvl.fyi/c/depot/+/9803 Reviewed-by: Profpatsch <mail@profpatsch.de> Tested-by: BuildkiteCI Autosubmit: Profpatsch <mail@profpatsch.de>
This commit is contained in:
parent
42d3c1a748
commit
efbffcd12d
4 changed files with 484 additions and 0 deletions
6
users/Profpatsch/openlab-tools/Main.hs
Normal file
6
users/Profpatsch/openlab-tools/Main.hs
Normal file
|
@ -0,0 +1,6 @@
|
|||
module Main where
|
||||
|
||||
import OpenlabTools qualified
|
||||
|
||||
main :: IO ()
|
||||
main = OpenlabTools.main
|
67
users/Profpatsch/openlab-tools/default.nix
Normal file
67
users/Profpatsch/openlab-tools/default.nix
Normal file
|
@ -0,0 +1,67 @@
|
|||
{ depot, pkgs, lib, ... }:
|
||||
|
||||
let
|
||||
# bins = depot.nix.getBins pkgs.sqlite ["sqlite3"];
|
||||
|
||||
openlab-tools = pkgs.haskellPackages.mkDerivation {
|
||||
pname = "openlab-tools";
|
||||
version = "0.1.0";
|
||||
|
||||
src = depot.users.Profpatsch.exactSource ./. [
|
||||
./openlab-tools.cabal
|
||||
./Main.hs
|
||||
./src/OpenlabTools.hs
|
||||
];
|
||||
|
||||
libraryHaskellDepends = [
|
||||
depot.users.Profpatsch.my-prelude
|
||||
depot.users.Profpatsch.my-webstuff
|
||||
pkgs.haskellPackages.pa-prelude
|
||||
pkgs.haskellPackages.pa-label
|
||||
pkgs.haskellPackages.pa-json
|
||||
pkgs.haskellPackages.pa-error-tree
|
||||
pkgs.haskellPackages.pa-field-parser
|
||||
pkgs.haskellPackages.pa-pretty
|
||||
pkgs.haskellPackages.pa-run-command
|
||||
pkgs.haskellPackages.aeson-better-errors
|
||||
pkgs.haskellPackages.blaze-html
|
||||
pkgs.haskellPackages.hs-opentelemetry-sdk
|
||||
pkgs.haskellPackages.http-conduit
|
||||
pkgs.haskellPackages.http-types
|
||||
pkgs.haskellPackages.monad-logger
|
||||
pkgs.haskellPackages.selective
|
||||
pkgs.haskellPackages.unliftio
|
||||
pkgs.haskellPackages.wai-extra
|
||||
pkgs.haskellPackages.warp
|
||||
pkgs.haskellPackages.tagsoup
|
||||
pkgs.haskellPackages.time
|
||||
];
|
||||
|
||||
isExecutable = true;
|
||||
isLibrary = false;
|
||||
license = lib.licenses.mit;
|
||||
};
|
||||
|
||||
bins = depot.nix.getBins openlab-tools [ "openlab-tools" ];
|
||||
|
||||
in
|
||||
|
||||
depot.nix.writeExecline "openlab-tools-wrapped" { } [
|
||||
"importas"
|
||||
"-i"
|
||||
"PATH"
|
||||
"PATH"
|
||||
"export"
|
||||
"PATH"
|
||||
"${pkgs.postgresql}/bin:$${PATH}"
|
||||
"export"
|
||||
"OPENLAB_TOOLS_TOOLS"
|
||||
(pkgs.linkFarm "openlab-tools-tools" [
|
||||
{
|
||||
name = "pg_format";
|
||||
path = "${pkgs.pgformatter}/bin/pg_format";
|
||||
}
|
||||
])
|
||||
bins.openlab-tools
|
||||
]
|
||||
|
108
users/Profpatsch/openlab-tools/openlab-tools.cabal
Normal file
108
users/Profpatsch/openlab-tools/openlab-tools.cabal
Normal file
|
@ -0,0 +1,108 @@
|
|||
cabal-version: 3.0
|
||||
name: openlab-tools
|
||||
version: 0.1.0.0
|
||||
author: Profpatsch
|
||||
maintainer: mail@profpatsch.de
|
||||
|
||||
common common-options
|
||||
ghc-options:
|
||||
-Wall
|
||||
-Wno-type-defaults
|
||||
-Wunused-packages
|
||||
-Wredundant-constraints
|
||||
-fwarn-missing-deriving-strategies
|
||||
|
||||
-- See https://downloads.haskell.org/ghc/latest/docs/users_guide/exts.html
|
||||
-- for a description of all these extensions
|
||||
default-extensions:
|
||||
-- Infer Applicative instead of Monad where possible
|
||||
ApplicativeDo
|
||||
|
||||
-- Allow literal strings to be Text
|
||||
OverloadedStrings
|
||||
|
||||
-- Syntactic sugar improvements
|
||||
LambdaCase
|
||||
MultiWayIf
|
||||
|
||||
-- Makes the (deprecated) usage of * instead of Data.Kind.Type an error
|
||||
NoStarIsType
|
||||
|
||||
-- Convenient and crucial to deal with ambiguous field names, commonly
|
||||
-- known as RecordDotSyntax
|
||||
OverloadedRecordDot
|
||||
|
||||
-- does not export record fields as functions, use OverloadedRecordDot to access instead
|
||||
NoFieldSelectors
|
||||
|
||||
-- Record punning
|
||||
RecordWildCards
|
||||
|
||||
-- Improved Deriving
|
||||
DerivingStrategies
|
||||
DerivingVia
|
||||
|
||||
-- Type-level strings
|
||||
DataKinds
|
||||
|
||||
-- to enable the `type` keyword in import lists (ormolu uses this automatically)
|
||||
ExplicitNamespaces
|
||||
|
||||
default-language: GHC2021
|
||||
|
||||
|
||||
library
|
||||
import: common-options
|
||||
|
||||
hs-source-dirs: src
|
||||
|
||||
exposed-modules:
|
||||
OpenlabTools
|
||||
|
||||
build-depends:
|
||||
base >=4.15 && <5,
|
||||
text,
|
||||
my-prelude,
|
||||
my-webstuff,
|
||||
pa-prelude,
|
||||
pa-error-tree,
|
||||
pa-label,
|
||||
pa-json,
|
||||
pa-field-parser,
|
||||
pa-pretty,
|
||||
pa-run-command,
|
||||
aeson-better-errors,
|
||||
aeson,
|
||||
blaze-html,
|
||||
bytestring,
|
||||
containers,
|
||||
unordered-containers,
|
||||
exceptions,
|
||||
filepath,
|
||||
hs-opentelemetry-sdk,
|
||||
hs-opentelemetry-api,
|
||||
http-conduit,
|
||||
http-types,
|
||||
monad-logger,
|
||||
mtl,
|
||||
network-uri,
|
||||
scientific,
|
||||
selective,
|
||||
unliftio,
|
||||
wai-extra,
|
||||
wai,
|
||||
warp,
|
||||
tagsoup,
|
||||
time
|
||||
|
||||
executable openlab-tools
|
||||
import: common-options
|
||||
|
||||
main-is: Main.hs
|
||||
|
||||
ghc-options:
|
||||
-threaded
|
||||
|
||||
build-depends:
|
||||
base >=4.15 && <5,
|
||||
openlab-tools
|
303
users/Profpatsch/openlab-tools/src/OpenlabTools.hs
Normal file
303
users/Profpatsch/openlab-tools/src/OpenlabTools.hs
Normal file
|
@ -0,0 +1,303 @@
|
|||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module OpenlabTools where
|
||||
|
||||
import Control.Monad.Logger qualified as Logger
|
||||
import Control.Monad.Logger.CallStack
|
||||
import Control.Monad.Reader
|
||||
import Data.Aeson.BetterErrors qualified as Json
|
||||
import Data.Error.Tree
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
import Data.List qualified as List
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Data.Text qualified as Text
|
||||
import Data.Time (UTCTime, getCurrentTime)
|
||||
import Data.Time.Clock (addUTCTime)
|
||||
import Debug.Trace
|
||||
import GHC.Records (HasField (..))
|
||||
import GHC.Stack qualified
|
||||
import Json qualified
|
||||
import Label
|
||||
import Network.HTTP.Client.Conduit qualified as Http
|
||||
import Network.HTTP.Simple qualified as Http
|
||||
import Network.HTTP.Types
|
||||
import Network.HTTP.Types qualified as Http
|
||||
import Network.Wai qualified as Wai
|
||||
import Network.Wai.Handler.Warp qualified as Warp
|
||||
import Network.Wai.Parse qualified as Wai
|
||||
import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan')
|
||||
import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan')
|
||||
import OpenTelemetry.Trace.Monad qualified as Otel
|
||||
import PossehlAnalyticsPrelude
|
||||
import Pretty
|
||||
import System.Environment qualified as Env
|
||||
import System.IO qualified as IO
|
||||
import Text.HTML.TagSoup qualified as Soup
|
||||
import UnliftIO
|
||||
import Prelude hiding (span, until)
|
||||
|
||||
heatmap :: AppT IO ByteString
|
||||
heatmap = do
|
||||
Http.httpBS [fmt|GET https://mapall.space/heatmap/show.php?id=OpenLab+Augsburg|]
|
||||
<&> (.responseBody)
|
||||
<&> Soup.parseTags
|
||||
<&> Soup.canonicalizeTags
|
||||
<&> findHeatmap
|
||||
<&> fromMaybe ""
|
||||
where
|
||||
firstSection f t = t & Soup.sections f & listToMaybe
|
||||
match :: Soup.Tag ByteString -> Soup.Tag ByteString -> Bool
|
||||
match x (t :: Soup.Tag ByteString) = (Soup.~==) @ByteString t x
|
||||
findHeatmap t =
|
||||
t
|
||||
& firstSection (match (Soup.TagOpen ("") [("class", "heatmap")]))
|
||||
>>= firstSection (match (Soup.TagOpen "table" []))
|
||||
<&> getTable
|
||||
<&> Soup.renderTags
|
||||
|
||||
-- get the table from opening tag to closing tag (allowing nested tables)
|
||||
getTable = go 0
|
||||
where
|
||||
go _ [] = []
|
||||
go d (el : els)
|
||||
| match (Soup.TagOpen "table" []) el = el : go (traceShowId $ d + 1) els
|
||||
| match (Soup.TagClose "table") el = if d <= 1 then [el] else el : go (traceShowId $ d - 1) els
|
||||
| otherwise = el : go d els
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
runApp
|
||||
|
||||
-- ( do
|
||||
-- -- todo: trace that to the init functions as well
|
||||
-- Otel.inSpan "whatcd-resolver main function" Otel.defaultSpanArguments $ do
|
||||
-- _ <- runTransaction migrate
|
||||
-- htmlUi
|
||||
-- )
|
||||
|
||||
inSpan :: (MonadUnliftIO m, Otel.MonadTracer m) => Text -> m a -> m a
|
||||
inSpan name = Otel.inSpan name Otel.defaultSpanArguments
|
||||
|
||||
inSpan' :: (MonadUnliftIO m, Otel.MonadTracer m) => Text -> (Otel.Span -> m a) -> m a
|
||||
inSpan' name = Otel.inSpan' name Otel.defaultSpanArguments
|
||||
|
||||
zipT2 ::
|
||||
forall l1 l2 t1 t2.
|
||||
( HasField l1 (T2 l1 [t1] l2 [t2]) [t1],
|
||||
HasField l2 (T2 l1 [t1] l2 [t2]) [t2]
|
||||
) =>
|
||||
T2 l1 [t1] l2 [t2] ->
|
||||
[T2 l1 t1 l2 t2]
|
||||
zipT2 xs =
|
||||
zipWith
|
||||
(\t1 t2 -> T2 (label @l1 t1) (label @l2 t2))
|
||||
(getField @l1 xs)
|
||||
(getField @l2 xs)
|
||||
|
||||
unzipT2 :: forall l1 t1 l2 t2. [T2 l1 t1 l2 t2] -> T2 l1 [t1] l2 [t2]
|
||||
unzipT2 xs = xs <&> toTup & unzip & fromTup
|
||||
where
|
||||
toTup :: forall a b. T2 a t1 b t2 -> (t1, t2)
|
||||
toTup (T2 a b) = (getField @a a, getField @b b)
|
||||
fromTup :: (a, b) -> T2 l1 a l2 b
|
||||
fromTup (t1, t2) = T2 (label @l1 t1) (label @l2 t2)
|
||||
|
||||
unzipT3 :: forall l1 t1 l2 t2 l3 t3. [T3 l1 t1 l2 t2 l3 t3] -> T3 l1 [t1] l2 [t2] l3 [t3]
|
||||
unzipT3 xs = xs <&> toTup & unzip3 & fromTup
|
||||
where
|
||||
toTup :: forall a b c. T3 a t1 b t2 c t3 -> (t1, t2, t3)
|
||||
toTup (T3 a b c) = (getField @a a, getField @b b, getField @c c)
|
||||
fromTup :: (a, b, c) -> T3 l1 a l2 b l3 c
|
||||
fromTup (t1, t2, t3) = T3 (label @l1 t1) (label @l2 t2) (label @l3 t3)
|
||||
|
||||
newtype Optional a = OptionalInternal (Maybe a)
|
||||
|
||||
mkOptional :: a -> Optional a
|
||||
mkOptional defaultValue = OptionalInternal $ Just defaultValue
|
||||
|
||||
defaults :: Optional a
|
||||
defaults = OptionalInternal Nothing
|
||||
|
||||
instance HasField "withDefault" (Optional a) (a -> a) where
|
||||
getField (OptionalInternal m) defaultValue = case m of
|
||||
Nothing -> defaultValue
|
||||
Just a -> a
|
||||
|
||||
httpJson ::
|
||||
( MonadIO m,
|
||||
MonadThrow m
|
||||
) =>
|
||||
(Optional (Label "contentType" ByteString)) ->
|
||||
Otel.Span ->
|
||||
Json.Parse ErrorTree b ->
|
||||
Http.Request ->
|
||||
m b
|
||||
httpJson opts span parser req = do
|
||||
let opts' = opts.withDefault (label @"contentType" "application/json")
|
||||
Http.httpBS req
|
||||
>>= assertM
|
||||
span
|
||||
( \resp -> do
|
||||
let statusCode = resp & Http.responseStatus & (.statusCode)
|
||||
contentType =
|
||||
resp
|
||||
& Http.responseHeaders
|
||||
& List.lookup "content-type"
|
||||
<&> Wai.parseContentType
|
||||
<&> (\(ct, _mimeAttributes) -> ct)
|
||||
if
|
||||
| statusCode == 200,
|
||||
Just ct <- contentType,
|
||||
ct == opts'.contentType ->
|
||||
Right $ (resp & Http.responseBody)
|
||||
| statusCode == 200,
|
||||
Just otherType <- contentType ->
|
||||
Left [fmt|Server returned a non-json body, with content-type "{otherType}"|]
|
||||
| statusCode == 200,
|
||||
Nothing <- contentType ->
|
||||
Left [fmt|Server returned a body with unspecified content type|]
|
||||
| code <- statusCode -> Left [fmt|Server returned an non-200 error code, code {code}: {resp & showPretty}|]
|
||||
)
|
||||
>>= assertM
|
||||
span
|
||||
( \body ->
|
||||
Json.parseStrict parser body
|
||||
& first (Json.parseErrorTree "could not parse redacted response")
|
||||
)
|
||||
|
||||
assertM :: (MonadThrow f, MonadIO f) => Otel.Span -> (t -> Either ErrorTree a) -> t -> f a
|
||||
assertM span f v = case f v of
|
||||
Right a -> pure a
|
||||
Left err -> appThrowTree span err
|
||||
|
||||
data Cache a = Cache
|
||||
{ until :: UTCTime,
|
||||
result :: a
|
||||
}
|
||||
|
||||
newCache result = do
|
||||
until <- getCurrentTime
|
||||
newIORef Cache {..}
|
||||
|
||||
updateCache cache result = do
|
||||
until <- getCurrentTime <&> ((5 * 60) `addUTCTime`)
|
||||
_ <- writeIORef cache Cache {..}
|
||||
pure ()
|
||||
|
||||
updateCacheIfNewer :: (MonadUnliftIO m) => IORef (Cache b) -> m b -> m b
|
||||
updateCacheIfNewer cache act = withRunInIO $ \runInIO -> do
|
||||
old <- readIORef cache
|
||||
now <- getCurrentTime
|
||||
if old.until < now
|
||||
then do
|
||||
res <- runInIO act
|
||||
updateCache cache res
|
||||
pure res
|
||||
else pure old.result
|
||||
|
||||
runApp :: IO ()
|
||||
runApp = withTracer $ \tracer -> do
|
||||
cache <- newCache ""
|
||||
let appT = withRunInIO $ \runInIO -> Warp.run 9099 $ \req respond -> do
|
||||
new <- runInIO $ updateCacheIfNewer cache heatmap
|
||||
|
||||
respond $ Wai.responseLBS Http.status200 [] (new & toLazyBytes)
|
||||
|
||||
runReaderT appT.unAppT Context {..}
|
||||
|
||||
-- pgFormat <- readTools (label @"toolsEnvVar" "OPENLAB_TOOLS_TOOLS") (readTool "pg_format")
|
||||
-- let config = label @"logDatabaseQueries" LogDatabaseQueries
|
||||
-- pgConnPool <-
|
||||
-- Pool.newPool $
|
||||
-- Pool.defaultPoolConfig
|
||||
-- {- resource init action -} (Postgres.connectPostgreSQL (db & TmpPg.toConnectionString))
|
||||
-- {- resource destruction -} Postgres.close
|
||||
-- {- unusedResourceOpenTime -} 10
|
||||
-- {- max resources across all stripes -} 20
|
||||
-- transmissionSessionId <- newEmptyMVar
|
||||
-- let newAppT = do
|
||||
-- logInfo [fmt|Running with config: {showPretty config}|]
|
||||
-- logInfo [fmt|Connected to database at {db & TmpPg.toDataDirectory} on socket {db & TmpPg.toConnectionString}|]
|
||||
-- appT
|
||||
-- runReaderT newAppT.unAppT Context {..}
|
||||
|
||||
withTracer :: (Otel.Tracer -> IO c) -> IO c
|
||||
withTracer f = do
|
||||
setDefaultEnv "OTEL_SERVICE_NAME" "whatcd-resolver"
|
||||
bracket
|
||||
-- Install the SDK, pulling configuration from the environment
|
||||
Otel.initializeGlobalTracerProvider
|
||||
-- Ensure that any spans that haven't been exported yet are flushed
|
||||
Otel.shutdownTracerProvider
|
||||
-- Get a tracer so you can create spans
|
||||
(\tracerProvider -> f $ Otel.makeTracer tracerProvider "whatcd-resolver" Otel.tracerOptions)
|
||||
|
||||
setDefaultEnv :: String -> String -> IO ()
|
||||
setDefaultEnv envName defaultValue = do
|
||||
Env.lookupEnv envName >>= \case
|
||||
Just _env -> pure ()
|
||||
Nothing -> Env.setEnv envName defaultValue
|
||||
|
||||
data Context = Context
|
||||
{ tracer :: Otel.Tracer
|
||||
}
|
||||
|
||||
newtype AppT m a = AppT {unAppT :: ReaderT Context m a}
|
||||
deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadThrow)
|
||||
|
||||
data AppException = AppException Text
|
||||
deriving stock (Show)
|
||||
deriving anyclass (Exception)
|
||||
|
||||
-- | A specialized variant of @addEvent@ that records attributes conforming to
|
||||
-- the OpenTelemetry specification's
|
||||
-- <https://github.com/open-telemetry/opentelemetry-specification/blob/49c2f56f3c0468ceb2b69518bcadadd96e0a5a8b/specification/trace/semantic_conventions/exceptions.md semantic conventions>
|
||||
--
|
||||
-- @since 0.0.1.0
|
||||
recordException ::
|
||||
( MonadIO m,
|
||||
HasField "message" r Text,
|
||||
HasField "type_" r Text
|
||||
) =>
|
||||
Otel.Span ->
|
||||
r ->
|
||||
m ()
|
||||
recordException span dat = liftIO $ do
|
||||
callStack <- GHC.Stack.whoCreated dat.message
|
||||
newEventTimestamp <- Just <$> Otel.getTimestamp
|
||||
Otel.addEvent span $
|
||||
Otel.NewEvent
|
||||
{ newEventName = "exception",
|
||||
newEventAttributes =
|
||||
HashMap.fromList
|
||||
[ ("exception.type", Otel.toAttribute @Text dat.type_),
|
||||
("exception.message", Otel.toAttribute @Text dat.message),
|
||||
("exception.stacktrace", Otel.toAttribute @Text $ Text.unlines $ map stringToText callStack)
|
||||
],
|
||||
..
|
||||
}
|
||||
|
||||
appThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> ErrorTree -> m a
|
||||
appThrowTree span exc = do
|
||||
let msg = prettyErrorTree exc
|
||||
recordException
|
||||
span
|
||||
( T2
|
||||
(label @"type_" "AppException")
|
||||
(label @"message" msg)
|
||||
)
|
||||
throwM $ AppException msg
|
||||
|
||||
orAppThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> Either ErrorTree a -> m a
|
||||
orAppThrowTree span = \case
|
||||
Left err -> appThrowTree span err
|
||||
Right a -> pure a
|
||||
|
||||
instance (MonadIO m) => MonadLogger (AppT m) where
|
||||
monadLoggerLog loc src lvl msg = liftIO $ Logger.defaultOutput IO.stderr loc src lvl (Logger.toLogStr msg)
|
||||
|
||||
instance (Monad m) => Otel.MonadTracer (AppT m) where
|
||||
getTracer = AppT $ asks (.tracer)
|
Loading…
Reference in a new issue