feat(users/Profpatsch): init openlab-tools r/6858

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>

4 files changed, 484 insertions, 0 deletions

diff --git a/users/Profpatsch/openlab-tools/Main.hs b/users/Profpatsch/openlab-tools/Main.hs
new file mode 100644
index 000000000000..d5f958a38a6a
--- /dev/null
+++ b/users/Profpatsch/openlab-tools/Main.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import OpenlabTools qualified
+
+main :: IO ()
+main = OpenlabTools.main
diff --git a/users/Profpatsch/openlab-tools/default.nix b/users/Profpatsch/openlab-tools/default.nix
new file mode 100644
index 000000000000..168917f1b491
--- /dev/null
+++ b/users/Profpatsch/openlab-tools/default.nix
@@ -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
+]
+
diff --git a/users/Profpatsch/openlab-tools/openlab-tools.cabal b/users/Profpatsch/openlab-tools/openlab-tools.cabal
new file mode 100644
index 000000000000..590f2deb2aaa
--- /dev/null
+++ b/users/Profpatsch/openlab-tools/openlab-tools.cabal
@@ -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
diff --git a/users/Profpatsch/openlab-tools/src/OpenlabTools.hs b/users/Profpatsch/openlab-tools/src/OpenlabTools.hs
new file mode 100644
index 000000000000..e6a9dd1feff1
--- /dev/null
+++ b/users/Profpatsch/openlab-tools/src/OpenlabTools.hs
@@ -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)