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:
parent
cd47d188ae
commit
0dcc72a31c
4 changed files with 55 additions and 5 deletions
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 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 :: 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 ()
|
||||||
|
|
|
@ -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,
|
||||||
|
|
Loading…
Reference in a new issue