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>

1 files changed, 303 insertions, 0 deletions

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)