mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

feat(users/Profpatsch/whatcd-resolver): more otel traces

Browse source 
Change-Id: I5094b64f202eeedb57510a25850bba2edd9ec36f
Reviewed-on: https://cl.tvl.fyi/c/depot/+/9725
Reviewed-by: Profpatsch <mail@profpatsch.de>
Autosubmit: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI
This commit is contained in:
Profpatsch 2023-10-14 19:53:43 +02:00 committed by clbot
parent cc040a5ad3
commit 8e811fe625
3 changed files with 273 additions and 117 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs
View file

@ -194,7 +194,7 @@ data PoolingInfo = PoolingInfo
unusedResourceOpenTime :: Seconds,
-- | Max number of resources that can be
-- in the Pool at any time
maxOpenResourcesPerStripe :: AtLeast 1 Int
maxOpenResourcesAcrossAllStripes :: AtLeast 1 Int
}
deriving stock (Generic, Eq, Show)
deriving anyclass (FromJSON)
@ -218,12 +218,14 @@ initMonadPostgres logInfoFn connectInfo poolingInfo = do
createPGConnPool ::
IO (Pool Postgres.Connection)
createPGConnPool =
Pool.createPool
poolCreateResource
poolfreeResource
poolingInfo.numberOfStripes.unAtLeast
(poolingInfo.unusedResourceOpenTime & secondsToNominalDiffTime)
(poolingInfo.maxOpenResourcesPerStripe.unAtLeast)
Pool.newPool $
Pool.defaultPoolConfig
{- resource init action -} poolCreateResource
{- resource destruction -} poolfreeResource
( poolingInfo.unusedResourceOpenTime.unSeconds
& fromIntegral @Natural @Double
)
(poolingInfo.maxOpenResourcesAcrossAllStripes.unAtLeast)
where
poolCreateResource = Postgres.connect connectInfo
poolfreeResource = Postgres.close

335
users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
View file

@ -29,6 +29,7 @@ import Database.Postgres.Temp qualified as TmpPg
import FieldParser (FieldParser' (..))
import FieldParser qualified as Field
import GHC.Records (HasField (..))
import GHC.Stack qualified
import IHP.HSX.QQ (hsx)
import Json qualified
import Json.Enc (Enc)
@ -41,7 +42,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 Network.Wai.Parse qualified as Wai
import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan')
import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan')
import OpenTelemetry.Trace.Monad qualified as Otel
import PossehlAnalyticsPrelude
import Postgres.Decoder qualified as Dec
@ -59,6 +62,7 @@ import Text.Blaze.Html.Renderer.Utf8 qualified as Html
import Text.Blaze.Html5 qualified as Html
import Tool (Tool, readTool, readTools)
import UnliftIO
import Prelude hiding (span)
main :: IO ()
main =
@ -88,37 +92,51 @@ htmlUi = do
if debug
then Html.Pretty.renderHtml >>> stringToText >>> textToBytesUtf8 >>> toLazyBytes
else Html.renderHtml
let h act = do
res <- runInIO act
let h route act =
runInIO $
Otel.inSpan'
[fmt|Route {route }|]
( Otel.defaultSpanArguments
{ Otel.attributes =
HashMap.fromList
[ ("server.path", Otel.toAttribute @Text route)
]
}
)
( \span -> withRunInIO $ \runInIO' -> do
res <- runInIO' $ act span
respond . Wai.responseLBS Http.ok200 [("Content-Type", "text/html")] . renderHtml $ res
)
let mp parser =
let mp span parser =
Multipart.parseMultipartOrThrow
appThrowTree
(appThrowTree span)
parser
req
let torrentIdMp =
let torrentIdMp span =
mp
span
( do
label @"torrentId" <$> Multipart.field "torrent-id" ((Field.utf8 >>> Field.signedDecimal >>> Field.bounded @Int "int"))
)
case req & Wai.pathInfo & Text.intercalate "/" of
"" -> h mainHtml
"" -> h "/" (\_span -> mainHtml)
"snips/redacted/search" -> do
h $ do
h "/snips/redacted/search" $ \span -> do
dat <-
mp
span
( do
label @"searchstr" <$> Multipart.field "redacted-search" Cat.id
)
snipsRedactedSearch dat
"snips/redacted/torrentDataJson" -> h $ do
dat <- torrentIdMp
"snips/redacted/torrentDataJson" -> h "/snips/redacted/torrentDataJson" $ \span -> do
dat <- torrentIdMp span
mkVal <$> (runTransaction $ getTorrentById dat)
"snips/redacted/getTorrentFile" -> h $ do
dat <- torrentIdMp
"snips/redacted/getTorrentFile" -> h "/snips/redacted/getTorrentFile" $ \span -> do
dat <- torrentIdMp span
runTransaction $ do
inserted <- redactedGetTorrentFileAndInsert dat
running <-
@ -135,13 +153,13 @@ htmlUi = do
(Enc.object [("torrent-hash", Enc.text running.torrentHash)])
"Starting"
-- TODO: this is bad duplication??
"snips/redacted/startTorrentFile" -> h $ do
dat <- torrentIdMp
"snips/redacted/startTorrentFile" -> h "/snips/redacted/startTorrentFile" $ \span -> do
dat <- torrentIdMp span
runTransaction $ do
file <-
getTorrentFileById dat
<&> annotate [fmt|No torrent file for torrentId "{dat.torrentId}"|]
>>= orAppThrowTree
>>= orAppThrowTree span
running <-
lift @Transaction $
@ -156,8 +174,8 @@ htmlUi = do
"snips/transmission/getTorrentState"
(Enc.object [("torrent-hash", Enc.text running.torrentHash)])
"Starting"
"snips/transmission/getTorrentState" -> h $ do
dat <- mp $ label @"torrentHash" <$> Multipart.field "torrent-hash" Field.utf8
"snips/transmission/getTorrentState" -> h "/snips/transmission/getTorrentState" $ \span -> do
dat <- mp span $ label @"torrentHash" <$> Multipart.field "torrent-hash" Field.utf8
status <-
doTransmissionRequest'
( transmissionRequestListOnlyTorrents
@ -173,7 +191,7 @@ htmlUi = do
case status of
Nothing -> [hsx|ERROR unknown|]
Just _torrent -> [hsx|Running|]
_ -> h mainHtml
otherRoute -> h [fmt|/{otherRoute}|] (\_span -> mainHtml)
where
everySecond :: Text -> Enc -> Html -> Html
everySecond call extraData innerHtml = [hsx|<div hx-trigger="every 1s" hx-swap="outerHTML" hx-post={call} hx-vals={Enc.encToBytesUtf8 extraData}>{innerHtml}</div>|]
@ -213,11 +231,12 @@ htmlUi = do
snipsRedactedSearch ::
( MonadLogger m,
MonadIO m,
MonadPostgres m,
HasField "searchstr" r ByteString,
MonadThrow m,
MonadTransmission m
MonadTransmission m,
Otel.MonadTracer m,
MonadUnliftIO m
) =>
r ->
m Html
@ -232,11 +251,12 @@ snipsRedactedSearch dat = do
getBestTorrentsTable
getBestTorrentsTable ::
( MonadIO m,
MonadTransmission m,
( MonadTransmission m,
MonadThrow m,
MonadLogger m,
MonadPostgres m
MonadPostgres m,
Otel.MonadTracer m,
MonadUnliftIO m
) =>
Transaction m Html
getBestTorrentsTable = do
@ -323,11 +343,12 @@ scientificPercentage =
-- | Fetch the current status from transmission, and remove the tranmission hash from our database
-- iff it does not exist in transmission anymore
getAndUpdateTransmissionTorrentsStatus ::
( MonadIO m,
MonadTransmission m,
( MonadTransmission m,
MonadThrow m,
MonadLogger m,
MonadPostgres m
MonadPostgres m,
Otel.MonadTracer m,
MonadUnliftIO m
) =>
Map (Label "torrentHash" Text) () ->
(Transaction m (Map (Label "torrentHash" Text) (Label "percentDone" Percentage)))
@ -358,8 +379,7 @@ getAndUpdateTransmissionTorrentsStatus knownTorrents = do
pure actualTorrents
getTransmissionTorrentsTable ::
(MonadIO m, MonadTransmission m, MonadThrow m, MonadLogger m) =>
m Html
(MonadTransmission m, MonadThrow m, MonadLogger m, Otel.MonadTracer m, MonadUnliftIO m) => m Html
getTransmissionTorrentsTable = do
let fields =
[ "hashString",
@ -431,7 +451,12 @@ data TransmissionRequest = TransmissionRequest
deriving stock (Show)
testTransmission :: (Show out) => (TransmissionRequest, Json.Parse Error out) -> IO (Either TmpPg.StartError ())
testTransmission req = runAppWith $ doTransmissionRequest transmissionConnectionConfig req >>= liftIO . printPretty
testTransmission req = runAppWith $ inSpan' "Test Transmission" $ \span ->
doTransmissionRequest
span
transmissionConnectionConfig
req
>>= liftIO . printPretty
transmissionConnectionConfig :: T2 "host" Text "port" Text
transmissionConnectionConfig = (T2 (label @"host" "localhost") (label @"port" "9091"))
@ -507,52 +532,66 @@ data TransmissionResponseStatus
deriving stock (Show)
doTransmissionRequest' ::
( MonadIO m,
MonadTransmission m,
( MonadTransmission m,
MonadThrow m,
MonadLogger m
MonadLogger m,
Otel.MonadTracer m,
MonadUnliftIO m
) =>
(TransmissionRequest, Json.Parse Error output) ->
m output
doTransmissionRequest' req = do
doTransmissionRequest' req = inSpan' "Transmission Request" $ \span -> do
resp <-
doTransmissionRequest
span
transmissionConnectionConfig
req
case resp.result of
TransmissionResponseFailure err -> appThrowTree (nestedError "Transmission RPC error" $ singleError $ newError err)
TransmissionResponseFailure err -> appThrowTree span (nestedError "Transmission RPC error" $ singleError $ newError err)
TransmissionResponseSuccess -> case resp.arguments of
Nothing -> appThrowTree "Transmission RPC error: No `arguments` field in response"
Nothing -> appThrowTree span "Transmission RPC error: No `arguments` field in response"
Just out -> pure out
-- | Contact the transmission RPC, and do the CSRF protection dance.
--
-- Spec: https://github.com/transmission/transmission/blob/main/docs/rpc-spec.md
doTransmissionRequest ::
( MonadIO m,
MonadTransmission m,
( MonadTransmission m,
HasField "host" t1 Text,
HasField "port" t1 Text,
MonadThrow m,
MonadLogger m
MonadLogger m,
Otel.MonadTracer m,
MonadUnliftIO m
) =>
Otel.Span ->
t1 ->
(TransmissionRequest, Json.Parse Error output) ->
m (TransmissionResponse output)
doTransmissionRequest dat (req, parser) = do
doTransmissionRequest span dat (req, parser) = do
sessionId <- getTransmissionId
let body =
Enc.object
( [ ("method", req.method & Enc.text),
("arguments", Enc.map id req.arguments)
let textArg t = (Enc.text t, Otel.toAttribute @Text t)
let encArg enc = (enc, Otel.toAttribute @Text $ enc & Enc.encToTextPretty)
let intArg i = (Enc.int i, Otel.toAttribute @Int i)
let body :: [(Text, (Enc, Otel.Attribute))] =
( [ ("method", req.method & textArg),
("arguments", encArg $ Enc.map id req.arguments)
]
<> (req.tag & maybe [] (\t -> [("tag", t & Enc.int)]))
<> (req.tag & foldMap (\t -> [("tag", t & intArg)]))
)
Otel.addAttributes
span
( HashMap.fromList $
body
<&> bimap
(\k -> [fmt|transmission.{k}|])
(\(_, attr) -> attr)
)
logDebug [fmt|transmission request: {Pretty.showPrettyJsonEncoding body.unEnc}|]
let httpReq =
[fmt|http://{dat.host}:{dat.port}/transmission/rpc|]
& Http.setRequestMethod "POST"
& Http.setRequestBodyLBS (Enc.encToBytesUtf8Lazy body)
& Http.setRequestBodyLBS (Enc.encToBytesUtf8Lazy (body <&> second fst & Enc.object))
& (sessionId & maybe id (Http.setRequestHeader "X-Transmission-Session-Id" . (: [])))
resp <- Http.httpBS httpReq
-- Implement the CSRF protection thingy
@ -567,7 +606,7 @@ doTransmissionRequest dat (req, parser) = do
& liftIO
<&> NonEmpty.head
setTransmissionId tid
doTransmissionRequest dat (req, parser)
doTransmissionRequest span dat (req, parser)
200 ->
resp
& Http.getResponseBody
@ -592,31 +631,35 @@ doTransmissionRequest dat (req, parser) = do
case Json.eitherDecodeStrict' @Json.Value (resp & Http.getResponseBody) of
Left _err -> pure ()
Right val -> logInfo [fmt|failing transmission response: {showPrettyJson val}|]
appThrowTree err
appThrowTree span err
_ -> liftIO $ unwrapIOError $ Left [fmt|Non-200 response: {showPretty resp}|]
redactedSearch ::
(MonadLogger m, MonadIO m, MonadThrow m) =>
(MonadLogger m, MonadThrow m, Otel.MonadTracer m, MonadUnliftIO m) =>
[(ByteString, ByteString)] ->
Json.Parse ErrorTree a ->
m a
redactedSearch advanced =
redactedSearch advanced parser = inSpan' "Redacted API Search" $ \span ->
redactedApiRequestJson
span
( T2
(label @"action" "browse")
(label @"actionArgs" ((advanced <&> second Just)))
)
parser
redactedGetTorrentFile ::
( MonadLogger m,
MonadIO m,
MonadThrow m,
HasField "torrentId" dat Int
HasField "torrentId" dat Int,
MonadUnliftIO m,
Otel.MonadTracer m
) =>
dat ->
m ByteString
redactedGetTorrentFile dat =
redactedApiRequest
redactedGetTorrentFile dat = inSpan' "Redacted Get Torrent File" $ \span -> do
req <-
mkRedactedApiRequest
( T2
(label @"action" "download")
( label @"actionArgs"
@ -628,6 +671,7 @@ redactedGetTorrentFile dat =
]
)
)
httpTorrent span req
-- fix
-- ( \io -> do
@ -636,7 +680,7 @@ redactedGetTorrentFile dat =
-- io
-- )
exampleSearch :: (MonadThrow m, MonadIO m, MonadLogger m, MonadPostgres m) => m (Transaction m ())
exampleSearch :: (MonadThrow m, MonadLogger m, MonadPostgres m, Otel.MonadTracer m, MonadUnliftIO m) => m (Transaction m ())
exampleSearch = do
t1 <-
redactedSearchAndInsert
@ -671,9 +715,10 @@ exampleSearch = do
redactedSearchAndInsert ::
forall m.
( MonadLogger m,
MonadIO m,
MonadPostgres m,
MonadThrow m
MonadThrow m,
Otel.MonadTracer m,
MonadUnliftIO m
) =>
[(ByteString, ByteString)] ->
m (Transaction m ())
@ -701,7 +746,10 @@ redactedSearchAndInsert extraArguments = do
when (status /= "success") $ do
Json.throwCustomError [fmt|Status was not "success", but {status}|]
Json.key "response" $ do
pages <- Json.key "pages" (Field.jsonParser (Field.mapError singleError $ Field.jsonNumber >>> Field.boundedScientificIntegral @Int "not an Integer" >>> Field.integralToNatural))
pages <-
Json.keyMay "pages" (Field.jsonParser (Field.mapError singleError $ Field.jsonNumber >>> Field.boundedScientificIntegral @Int "not an Integer" >>> Field.integralToNatural))
-- in case the field is missing, let’s assume there is only one page
<&> fromMaybe 1
Json.key "results" $ do
tourGroups <-
label @"tourGroups"
@ -848,12 +896,13 @@ redactedGetTorrentFileAndInsert ::
( HasField "torrentId" r Int,
MonadPostgres m,
MonadThrow m,
MonadIO m,
MonadLogger m
MonadLogger m,
Otel.MonadTracer m,
MonadUnliftIO m
) =>
r ->
Transaction m (Label "torrentFile" ByteString)
redactedGetTorrentFileAndInsert dat = do
redactedGetTorrentFileAndInsert dat = inSpan' "Redacted Get Torrent File and Insert" $ \span -> do
bytes <- redactedGetTorrentFile dat
execute
[sql|
@ -864,7 +913,7 @@ redactedGetTorrentFileAndInsert dat = do
( (Binary bytes :: Binary ByteString),
dat.torrentId
)
>>= assertOneUpdated "redactedGetTorrentFileAndInsert"
>>= assertOneUpdated span "redactedGetTorrentFileAndInsert"
>>= \() -> pure (label @"torrentFile" bytes)
getTorrentFileById ::
@ -904,13 +953,14 @@ updateTransmissionTorrentHashById dat = do
)
assertOneUpdated ::
(HasField "numberOfRowsAffected" r Natural, MonadThrow m) =>
(HasField "numberOfRowsAffected" r Natural, MonadThrow m, MonadIO m) =>
Otel.Span ->
Text ->
r ->
m ()
assertOneUpdated name x = case x.numberOfRowsAffected of
assertOneUpdated span 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)|])
n -> appThrowTree span ([fmt|{name :: Text}: Expected to update exactly one row, but updated {n :: Natural} row(s)|])
migrate ::
( MonadPostgres m,
@ -1048,6 +1098,9 @@ getBestTorrents = do
inSpan :: (MonadUnliftIO m, Otel.MonadTracer 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' name = Otel.inSpan' name Otel.defaultSpanArguments
hush :: Either a1 a2 -> Maybe a2
hush (Left _) = Nothing
hush (Right a) = Just a
@ -1082,7 +1135,7 @@ unzipT3 xs = xs <&> toTup & unzip3 & fromTup
fromTup (t1, t2, t3) = T3 (label @l1 t1) (label @l2 t2) (label @l3 t3)
-- | Do a request to the redacted API. If you know what that is, you know how to find the API docs.
redactedApiRequest ::
mkRedactedApiRequest ::
( MonadThrow m,
MonadIO m,
MonadLogger m,
@ -1090,19 +1143,84 @@ redactedApiRequest ::
HasField "actionArgs" p [(ByteString, Maybe ByteString)]
) =>
p ->
m ByteString
redactedApiRequest dat = do
m Http.Request
mkRedactedApiRequest dat = do
authKey <- runCommandExpect0 "pass" ["internet/redacted/api-keys/whatcd-resolver"]
let req =
pure $
[fmt|https://redacted.ch/ajax.php|]
& Http.setRequestMethod "GET"
& Http.setQueryString (("action", Just dat.action) : dat.actionArgs)
& Http.setRequestHeader "Authorization" [authKey]
httpTorrent ::
( MonadIO m,
MonadThrow m
) =>
Otel.Span ->
Http.Request ->
m ByteString
httpTorrent span req =
Http.httpBS req
>>= assertM
( \resp -> case resp & Http.responseStatus & (.statusCode) of
200 -> Right $ resp & Http.responseBody
_ -> Left [fmt|Redacted returned an non-200 error code: {resp & showPretty}|]
span
( \resp -> do
let statusCode = resp & Http.responseStatus & (.statusCode)
contentType =
resp
& Http.responseHeaders
& List.lookup "content-type"
<&> Wai.parseContentType
<&> (\(ct, _mimeAttributes) -> ct)
if
| statusCode == 200,
Just "application/x-bittorrent" <- contentType ->
Right $ (resp & Http.responseBody)
| statusCode == 200,
Just otherType <- contentType ->
Left [fmt|Redacted returned a non-torrent body, with content-type "{otherType}"|]
| statusCode == 200,
Nothing <- contentType ->
Left [fmt|Redacted returned a body with unspecified content type|]
| code <- statusCode -> Left [fmt|Redacted returned an non-200 error code, code {code}: {resp & showPretty}|]
)
httpJson ::
( MonadIO m,
MonadThrow m
) =>
Otel.Span ->
Json.Parse ErrorTree b ->
Http.Request ->
m b
httpJson span parser req =
Http.httpBS req
>>= assertM
span
( \resp -> do
let statusCode = resp & Http.responseStatus & (.statusCode)
contentType =
resp
& Http.responseHeaders
& List.lookup "content-type"
<&> Wai.parseContentType
<&> (\(ct, _mimeAttributes) -> ct)
if
| statusCode == 200,
Just "application/json" <- contentType ->
Right $ (resp & Http.responseBody)
| statusCode == 200,
Just otherType <- contentType ->
Left [fmt|Redacted returned a non-json body, with content-type "{otherType}"|]
| statusCode == 200,
Nothing <- contentType ->
Left [fmt|Redacted returned a body with unspecified content type|]
| code <- statusCode -> Left [fmt|Redacted returned an non-200 error code, code {code}: {resp & showPretty}|]
)
>>= assertM
span
( \body ->
Json.parseStrict parser body
& first (Json.parseErrorTree "could not parse redacted response")
)
redactedApiRequestJson ::
@ -1112,32 +1230,31 @@ redactedApiRequestJson ::
HasField "action" p ByteString,
HasField "actionArgs" p [(ByteString, Maybe ByteString)]
) =>
Otel.Span ->
p ->
Json.Parse ErrorTree a ->
m a
redactedApiRequestJson dat parse = do
redactedApiRequest dat
>>= ( Json.parseStrict parse
>>> first (Json.parseErrorTree "could not parse redacted response")
>>> assertM id
)
redactedApiRequestJson span dat parser =
do
mkRedactedApiRequest dat
>>= httpJson span parser
assertM :: (MonadThrow f) => (t -> Either ErrorTree a) -> t -> f a
assertM f v = case f v of
assertM :: (MonadThrow f, MonadIO f) => Otel.Span -> (t -> Either ErrorTree a) -> t -> f a
assertM span f v = case f v of
Right a -> pure a
Left err -> appThrowTree err
Left err -> appThrowTree span err
runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a)
runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do
pgFormat <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format")
let config = label @"logDatabaseQueries" LogDatabaseQueries
pgConnPool <-
Pool.createPool
(Postgres.connectPostgreSQL (db & TmpPg.toConnectionString))
Postgres.close
{- number of stripes -} 5
Pool.newPool $
Pool.defaultPoolConfig
{- resource init action -} (Postgres.connectPostgreSQL (db & TmpPg.toConnectionString))
{- resource destruction -} Postgres.close
{- unusedResourceOpenTime -} 10
{- max resources per stripe -} 10
{- max resources across all stripes -} 20
transmissionSessionId <- newEmptyMVar
let newAppT = do
logInfo [fmt|Running with config: {showPretty config}|]
@ -1204,12 +1321,48 @@ data AppException = AppException Text
deriving stock (Show)
deriving anyclass (Exception)
appThrowTree :: (MonadThrow m) => ErrorTree -> m a
appThrowTree exc = throwM $ AppException $ prettyErrorTree exc
-- | A specialized variant of @addEvent@ that records attributes conforming to
-- the OpenTelemetry specification's
-- <https://github.com/open-telemetry/opentelemetry-specification/blob/49c2f56f3c0468ceb2b69518bcadadd96e0a5a8b/specification/trace/semantic_conventions/exceptions.md semantic conventions>
--
-- @since 0.0.1.0
recordException ::
( MonadIO m,
HasField "message" r Text,
HasField "type_" r Text
) =>
Otel.Span ->
r ->
m ()
recordException span dat = liftIO $ do
callStack <- GHC.Stack.whoCreated dat.message
newEventTimestamp <- Just <$> Otel.getTimestamp
Otel.addEvent span $
Otel.NewEvent
{ newEventName = "exception",
newEventAttributes =
HashMap.fromList
[ ("exception.type", Otel.toAttribute @Text dat.type_),
("exception.message", Otel.toAttribute @Text dat.message),
("exception.stacktrace", Otel.toAttribute @Text $ Text.unlines $ map stringToText callStack)
],
..
}
orAppThrowTree :: (MonadThrow m) => Either ErrorTree a -> m a
orAppThrowTree = \case
Left err -> appThrowTree err
appThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> ErrorTree -> m a
appThrowTree span exc = do
let msg = prettyErrorTree exc
recordException
span
( T2
(label @"type_" "AppException")
(label @"message" msg)
)
throwM $ AppException msg
orAppThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> Either ErrorTree a -> m a
orAppThrowTree span = \case
Left err -> appThrowTree span err
Right a -> pure a
instance (MonadIO m) => MonadLogger (AppT m) where

1
users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal
View file

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