diff options
Diffstat (limited to 'users')
| -rw-r--r-- | users/Profpatsch/shell.nix | 1 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/default.nix | 1 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs | 57 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal | 1 |
4 files changed, 55 insertions, 5 deletions
diff --git a/users/Profpatsch/shell.nix b/users/Profpatsch/shell.nix index b27b47b2b939..367ab01e1d80 100644 --- a/users/Profpatsch/shell.nix +++ b/users/Profpatsch/shell.nix @@ -54,6 +54,7 @@ pkgs.mkShell { h.postgresql-simple h.resource-pool h.xmonad-contrib + h.hs-opentelemetry-sdk ])) pkgs.rustup 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, |