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

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>
This commit is contained in:
Profpatsch 2023-09-29 18:04:32 +02:00 committed by clbot
parent cd47d188ae
commit 0dcc72a31c
4 changed files with 55 additions and 5 deletions

View file

@ -54,6 +54,7 @@ pkgs.mkShell {
h.postgresql-simple h.postgresql-simple
h.resource-pool h.resource-pool
h.xmonad-contrib h.xmonad-contrib
h.hs-opentelemetry-sdk
])) ]))
pkgs.rustup pkgs.rustup

View file

@ -26,6 +26,7 @@ let
pkgs.haskellPackages.aeson-better-errors pkgs.haskellPackages.aeson-better-errors
pkgs.haskellPackages.blaze-html pkgs.haskellPackages.blaze-html
pkgs.haskellPackages.dlist pkgs.haskellPackages.dlist
pkgs.haskellPackages.hs-opentelemetry-sdk
pkgs.haskellPackages.http-conduit pkgs.haskellPackages.http-conduit
pkgs.haskellPackages.http-types pkgs.haskellPackages.http-types
pkgs.haskellPackages.ihp-hsx pkgs.haskellPackages.ihp-hsx

View file

@ -40,6 +40,9 @@ import Network.HTTP.Types
import Network.HTTP.Types qualified as Http import Network.HTTP.Types qualified as Http
import Network.Wai qualified as Wai import Network.Wai qualified as Wai
import Network.Wai.Handler.Warp qualified as Warp 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 PossehlAnalyticsPrelude
import Postgres.Decoder qualified as Dec import Postgres.Decoder qualified as Dec
import Postgres.MonadPostgres import Postgres.MonadPostgres
@ -47,6 +50,7 @@ import Pretty
import RunCommand (runCommandExpect0) import RunCommand (runCommandExpect0)
import System.Directory qualified as Dir import System.Directory qualified as Dir
import System.Directory qualified as Xdg import System.Directory qualified as Xdg
import System.Environment qualified as Env
import System.FilePath ((</>)) import System.FilePath ((</>))
import System.IO qualified as IO import System.IO qualified as IO
import Text.Blaze.Html (Html) import Text.Blaze.Html (Html)
@ -60,6 +64,8 @@ main :: IO ()
main = main =
runAppWith runAppWith
( do ( do
-- todo: trace that to the init functions as well
Otel.inSpan "whatcd-resolver main function" Otel.defaultSpanArguments $ do
_ <- runTransaction migrate _ <- runTransaction migrate
htmlUi htmlUi
) )
@ -906,8 +912,13 @@ assertOneUpdated name x = case x.numberOfRowsAffected of
1 -> pure () 1 -> pure ()
n -> appThrowTree ([fmt|{name :: Text}: Expected to update exactly one row, but updated {n :: Natural} row(s)|]) 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 ::
migrate = do ( MonadPostgres m,
MonadUnliftIO m,
Otel.MonadTracer m
) =>
Transaction m (Label "numberOfRowsAffected" Natural)
migrate = inSpanT "Database Migration" $ do
execute_ execute_
[sql| [sql|
CREATE SCHEMA IF NOT EXISTS redacted; 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 dont want to implement MonadTracer for Transaction,
-- so Im 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 :: Either a1 a2 -> Maybe a2
hush (Left _) = Nothing hush (Left _) = Nothing
hush (Right a) = Just a hush (Right a) = Just a
@ -1114,7 +1140,7 @@ assertM f v = case f v of
Left err -> appThrowTree err Left err -> appThrowTree err
runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a) 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") pgFormat <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format")
let config = label @"logDatabaseQueries" LogDatabaseQueries let config = label @"logDatabaseQueries" LogDatabaseQueries
pgConnPool <- pgConnPool <-
@ -1131,6 +1157,23 @@ runAppWith appT = withDb $ \db -> do
appT appT
runReaderT newAppT.unAppT Context {..} 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 :: (TmpPg.DB -> IO a) -> IO (Either TmpPg.StartError a)
withDb act = do withDb act = do
dataDir <- Xdg.getXdgDirectory Xdg.XdgData "whatcd-resolver" dataDir <- Xdg.getXdgDirectory Xdg.XdgData "whatcd-resolver"
@ -1158,6 +1201,7 @@ withDb act = do
data Context = Context data Context = Context
{ config :: Label "logDatabaseQueries" DebugLogDatabaseQueries, { config :: Label "logDatabaseQueries" DebugLogDatabaseQueries,
tracer :: Otel.Tracer,
pgFormat :: Tool, pgFormat :: Tool,
pgConnPool :: Pool Postgres.Connection, pgConnPool :: Pool Postgres.Connection,
transmissionSessionId :: MVar ByteString transmissionSessionId :: MVar ByteString
@ -1183,6 +1227,9 @@ orAppThrowTree = \case
instance (MonadIO m) => MonadLogger (AppT m) where instance (MonadIO m) => MonadLogger (AppT m) where
monadLoggerLog loc src lvl msg = liftIO $ Logger.defaultOutput IO.stderr loc src lvl (Logger.toLogStr msg) 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 class MonadTransmission m where
getTransmissionId :: m (Maybe ByteString) getTransmissionId :: m (Maybe ByteString)
setTransmissionId :: ByteString -> m () setTransmissionId :: ByteString -> m ()

View file

@ -79,6 +79,7 @@ library
directory, directory,
dlist, dlist,
filepath, filepath,
hs-opentelemetry-sdk,
http-conduit, http-conduit,
http-types, http-types,
ihp-hsx, ihp-hsx,