feat(users/Profpatsch/whatcd-resolver): add basic otel tracing r/6673

For it to work, you need otel (e.g. jaeger) to run on port 4317.

Change-Id: I36f0493b9be26af256769ae5af8916029036a76e
Reviewed-on: https://cl.tvl.fyi/c/depot/+/9488
Tested-by: BuildkiteCI
Autosubmit: Profpatsch <mail@profpatsch.de>
Reviewed-by: Profpatsch <mail@profpatsch.de>

3 files changed, 54 insertions, 5 deletions

diff --git a/users/Profpatsch/whatcd-resolver/default.nix b/users/Profpatsch/whatcd-resolver/default.nix
index d5de63c497aa..e2800f95c14c 100644
--- a/users/Profpatsch/whatcd-resolver/default.nix
+++ b/users/Profpatsch/whatcd-resolver/default.nix
@@ -26,6 +26,7 @@ let
       pkgs.haskellPackages.aeson-better-errors
       pkgs.haskellPackages.blaze-html
       pkgs.haskellPackages.dlist
+      pkgs.haskellPackages.hs-opentelemetry-sdk
       pkgs.haskellPackages.http-conduit
       pkgs.haskellPackages.http-types
       pkgs.haskellPackages.ihp-hsx
diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
index 64d4edbf8b51..c105de9affe7 100644
--- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
+++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
@@ -40,6 +40,9 @@ 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 OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan)
+import OpenTelemetry.Trace qualified as OtelTrace
+import OpenTelemetry.Trace.Monad qualified as Otel
 import PossehlAnalyticsPrelude
 import Postgres.Decoder qualified as Dec
 import Postgres.MonadPostgres
@@ -47,6 +50,7 @@ import Pretty
 import RunCommand (runCommandExpect0)
 import System.Directory qualified as Dir
 import System.Directory qualified as Xdg
+import System.Environment qualified as Env
 import System.FilePath ((</>))
 import System.IO qualified as IO
 import Text.Blaze.Html (Html)
@@ -60,8 +64,10 @@ main :: IO ()
 main =
   runAppWith
     ( do
-        _ <- runTransaction migrate
-        htmlUi
+        -- todo: trace that to the init functions as well
+        Otel.inSpan "whatcd-resolver main function" Otel.defaultSpanArguments $ do
+          _ <- runTransaction migrate
+          htmlUi
     )
     <&> first showToError
     >>= expectIOError "could not start whatcd-resolver"
@@ -906,8 +912,13 @@ assertOneUpdated name x = case x.numberOfRowsAffected of
   1 -> pure ()
   n -> appThrowTree ([fmt|{name :: Text}: Expected to update exactly one row, but updated {n :: Natural} row(s)|])
 
-migrate :: (MonadPostgres m) => Transaction m (Label "numberOfRowsAffected" Natural)
-migrate = do
+migrate ::
+  ( MonadPostgres m,
+    MonadUnliftIO m,
+    Otel.MonadTracer m
+  ) =>
+  Transaction m (Label "numberOfRowsAffected" Natural)
+migrate = inSpanT "Database Migration" $ do
   execute_
     [sql|
     CREATE SCHEMA IF NOT EXISTS redacted;
@@ -1034,6 +1045,21 @@ getBestTorrents = do
             }
     )
 
+inSpan :: (MonadUnliftIO m, Otel.MonadTracer m) => Text -> m a -> m a
+inSpan name = Otel.inSpan name Otel.defaultSpanArguments
+
+inSpanT :: (Otel.MonadTracer m, MonadUnliftIO m) => Text -> Transaction m b -> Transaction m b
+inSpanT name transaction = do
+  tracer <- lift @Transaction $ Otel.getTracer
+  -- I don’t want to implement MonadTracer for Transaction,
+  -- so I’m unlifting it via IO, that should work :P
+  withRunInIO $ \runInIO -> do
+    OtelTrace.inSpan
+      tracer
+      name
+      Otel.defaultSpanArguments
+      (runInIO transaction)
+
 hush :: Either a1 a2 -> Maybe a2
 hush (Left _) = Nothing
 hush (Right a) = Just a
@@ -1114,7 +1140,7 @@ assertM f v = case f v of
   Left err -> appThrowTree err
 
 runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a)
-runAppWith appT = withDb $ \db -> do
+runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do
   pgFormat <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format")
   let config = label @"logDatabaseQueries" LogDatabaseQueries
   pgConnPool <-
@@ -1131,6 +1157,23 @@ runAppWith appT = withDb $ \db -> do
         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
+
 withDb :: (TmpPg.DB -> IO a) -> IO (Either TmpPg.StartError a)
 withDb act = do
   dataDir <- Xdg.getXdgDirectory Xdg.XdgData "whatcd-resolver"
@@ -1158,6 +1201,7 @@ withDb act = do
 
 data Context = Context
   { config :: Label "logDatabaseQueries" DebugLogDatabaseQueries,
+    tracer :: Otel.Tracer,
     pgFormat :: Tool,
     pgConnPool :: Pool Postgres.Connection,
     transmissionSessionId :: MVar ByteString
@@ -1183,6 +1227,9 @@ orAppThrowTree = \case
 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)
+
 class MonadTransmission m where
   getTransmissionId :: m (Maybe ByteString)
   setTransmissionId :: ByteString -> m ()
diff --git a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal
index c605cd4f026e..caa068acd169 100644
--- a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal
+++ b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal
@@ -79,6 +79,7 @@ library
         directory,
         dlist,
         filepath,
+        hs-opentelemetry-sdk,
         http-conduit,
         http-types,
         ihp-hsx,