feat(users/Profpatsch/whatcd-resolver): log json+ld fetching

This traces the target of a json+ld fetch.

We also simplify the telemetry stuff by using a pseudo-class
`MonadOtel` everywhere.

I wonder if we can get rid of passing the span to `assertM`, because
it’s kind of an antipattern to be honest.

Change-Id: I1448d643c909a29684fa1ae54037177ba2c20639
Reviewed-on: https://cl.tvl.fyi/c/depot/+/11166
Tested-by: BuildkiteCI
Autosubmit: Profpatsch <mail@profpatsch.de>
Reviewed-by: Profpatsch <mail@profpatsch.de>
This commit is contained in:
Profpatsch 2024-03-16 17:17:38 +01:00 committed by clbot
parent 0b06dda9a6
commit 981c7fef0e
4 changed files with 98 additions and 71 deletions

View file

@ -6,6 +6,7 @@ import Control.Monad.Logger qualified as Logger
import Control.Monad.Logger.CallStack
import Control.Monad.Reader
import Data.Error.Tree
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.Pool (Pool)
import Data.Text qualified as Text
@ -45,12 +46,26 @@ instance (MonadIO m) => MonadLogger (AppT m) where
instance (Monad m) => Otel.MonadTracer (AppT m) where
getTracer = AppT $ asks (.tracer)
inSpan :: (MonadUnliftIO m, Otel.MonadTracer m) => Text -> m a -> m a
class (MonadUnliftIO m, Otel.MonadTracer m) => MonadOtel m
instance (MonadUnliftIO m) => MonadOtel (AppT m)
instance (MonadOtel m) => MonadOtel (Transaction m)
inSpan :: (MonadOtel 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' :: (MonadOtel m) => Text -> (Otel.Span -> m a) -> m a
inSpan' name = Otel.inSpan' name Otel.defaultSpanArguments
-- | Add the attribute to the span, prefixing it with the `_` namespace (to easier distinguish our applications tags from standard tags)
addAttribute :: (MonadIO m, Otel.ToAttribute a) => Otel.Span -> Text -> a -> m ()
addAttribute span key a = Otel.addAttribute span ("_." <> key) a
-- | Add the attributes to the span, prefixing each key with the `_` namespace (to easier distinguish our applications tags from standard tags)
addAttributes :: (MonadIO m) => Otel.Span -> HashMap Text Otel.Attribute -> m ()
addAttributes span attrs = Otel.addAttributes span $ attrs & HashMap.mapKeys ("_." <>)
appThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> ErrorTree -> m a
appThrowTree span exc = do
let msg = prettyErrorTree exc