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

373
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 (FieldParser' (..))
import FieldParser qualified as Field import FieldParser qualified as Field
import GHC.Records (HasField (..)) import GHC.Records (HasField (..))
import GHC.Stack qualified
import IHP.HSX.QQ (hsx) import IHP.HSX.QQ (hsx)
import Json qualified import Json qualified
import Json.Enc (Enc) import Json.Enc (Enc)
@ -41,7 +42,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 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 OpenTelemetry.Trace.Monad qualified as Otel
import PossehlAnalyticsPrelude import PossehlAnalyticsPrelude
import Postgres.Decoder qualified as Dec 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 Text.Blaze.Html5 qualified as Html
import Tool (Tool, readTool, readTools) import Tool (Tool, readTool, readTools)
import UnliftIO import UnliftIO
import Prelude hiding (span)
main :: IO () main :: IO ()
main = main =
@ -88,37 +92,51 @@ htmlUi = do
if debug if debug
then Html.Pretty.renderHtml >>> stringToText >>> textToBytesUtf8 >>> toLazyBytes then Html.Pretty.renderHtml >>> stringToText >>> textToBytesUtf8 >>> toLazyBytes
else Html.renderHtml else Html.renderHtml
let h act = do let h route act =
res <- runInIO act runInIO $
respond . Wai.responseLBS Http.ok200 [("Content-Type", "text/html")] . renderHtml $ res 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 Multipart.parseMultipartOrThrow
appThrowTree (appThrowTree span)
parser parser
req req
let torrentIdMp = let torrentIdMp span =
mp mp
span
( do ( do
label @"torrentId" <$> Multipart.field "torrent-id" ((Field.utf8 >>> Field.signedDecimal >>> Field.bounded @Int "int")) label @"torrentId" <$> Multipart.field "torrent-id" ((Field.utf8 >>> Field.signedDecimal >>> Field.bounded @Int "int"))
) )
case req & Wai.pathInfo & Text.intercalate "/" of case req & Wai.pathInfo & Text.intercalate "/" of
"" -> h mainHtml "" -> h "/" (\_span -> mainHtml)
"snips/redacted/search" -> do "snips/redacted/search" -> do
h $ do h "/snips/redacted/search" $ \span -> do
dat <- dat <-
mp mp
span
( do ( do
label @"searchstr" <$> Multipart.field "redacted-search" Cat.id label @"searchstr" <$> Multipart.field "redacted-search" Cat.id
) )
snipsRedactedSearch dat snipsRedactedSearch dat
"snips/redacted/torrentDataJson" -> h $ do "snips/redacted/torrentDataJson" -> h "/snips/redacted/torrentDataJson" $ \span -> do
dat <- torrentIdMp dat <- torrentIdMp span
mkVal <$> (runTransaction $ getTorrentById dat) mkVal <$> (runTransaction $ getTorrentById dat)
"snips/redacted/getTorrentFile" -> h $ do "snips/redacted/getTorrentFile" -> h "/snips/redacted/getTorrentFile" $ \span -> do
dat <- torrentIdMp dat <- torrentIdMp span
runTransaction $ do runTransaction $ do
inserted <- redactedGetTorrentFileAndInsert dat inserted <- redactedGetTorrentFileAndInsert dat
running <- running <-
@ -135,13 +153,13 @@ htmlUi = do
(Enc.object [("torrent-hash", Enc.text running.torrentHash)]) (Enc.object [("torrent-hash", Enc.text running.torrentHash)])
"Starting" "Starting"
-- TODO: this is bad duplication?? -- TODO: this is bad duplication??
"snips/redacted/startTorrentFile" -> h $ do "snips/redacted/startTorrentFile" -> h "/snips/redacted/startTorrentFile" $ \span -> do
dat <- torrentIdMp dat <- torrentIdMp span
runTransaction $ do runTransaction $ do
file <- file <-
getTorrentFileById dat getTorrentFileById dat
<&> annotate [fmt|No torrent file for torrentId "{dat.torrentId}"|] <&> annotate [fmt|No torrent file for torrentId "{dat.torrentId}"|]
>>= orAppThrowTree >>= orAppThrowTree span
running <- running <-
lift @Transaction $ lift @Transaction $
@ -156,8 +174,8 @@ htmlUi = do
"snips/transmission/getTorrentState" "snips/transmission/getTorrentState"
(Enc.object [("torrent-hash", Enc.text running.torrentHash)]) (Enc.object [("torrent-hash", Enc.text running.torrentHash)])
"Starting" "Starting"
"snips/transmission/getTorrentState" -> h $ do "snips/transmission/getTorrentState" -> h "/snips/transmission/getTorrentState" $ \span -> do
dat <- mp $ label @"torrentHash" <$> Multipart.field "torrent-hash" Field.utf8 dat <- mp span $ label @"torrentHash" <$> Multipart.field "torrent-hash" Field.utf8
status <- status <-
doTransmissionRequest' doTransmissionRequest'
( transmissionRequestListOnlyTorrents ( transmissionRequestListOnlyTorrents
@ -173,7 +191,7 @@ htmlUi = do
case status of case status of
Nothing -> [hsx|ERROR unknown|] Nothing -> [hsx|ERROR unknown|]
Just _torrent -> [hsx|Running|] Just _torrent -> [hsx|Running|]
_ -> h mainHtml otherRoute -> h [fmt|/{otherRoute}|] (\_span -> mainHtml)
where where
everySecond :: Text -> Enc -> Html -> Html 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>|] 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 :: snipsRedactedSearch ::
( MonadLogger m, ( MonadLogger m,
MonadIO m,
MonadPostgres m, MonadPostgres m,
HasField "searchstr" r ByteString, HasField "searchstr" r ByteString,
MonadThrow m, MonadThrow m,
MonadTransmission m MonadTransmission m,
Otel.MonadTracer m,
MonadUnliftIO m
) => ) =>
r -> r ->
m Html m Html
@ -232,11 +251,12 @@ snipsRedactedSearch dat = do
getBestTorrentsTable getBestTorrentsTable
getBestTorrentsTable :: getBestTorrentsTable ::
( MonadIO m, ( MonadTransmission m,
MonadTransmission m,
MonadThrow m, MonadThrow m,
MonadLogger m, MonadLogger m,
MonadPostgres m MonadPostgres m,
Otel.MonadTracer m,
MonadUnliftIO m
) => ) =>
Transaction m Html Transaction m Html
getBestTorrentsTable = do getBestTorrentsTable = do
@ -323,11 +343,12 @@ scientificPercentage =
-- | Fetch the current status from transmission, and remove the tranmission hash from our database -- | Fetch the current status from transmission, and remove the tranmission hash from our database
-- iff it does not exist in transmission anymore -- iff it does not exist in transmission anymore
getAndUpdateTransmissionTorrentsStatus :: getAndUpdateTransmissionTorrentsStatus ::
( MonadIO m, ( MonadTransmission m,
MonadTransmission m,
MonadThrow m, MonadThrow m,
MonadLogger m, MonadLogger m,
MonadPostgres m MonadPostgres m,
Otel.MonadTracer m,
MonadUnliftIO m
) => ) =>
Map (Label "torrentHash" Text) () -> Map (Label "torrentHash" Text) () ->
(Transaction m (Map (Label "torrentHash" Text) (Label "percentDone" Percentage))) (Transaction m (Map (Label "torrentHash" Text) (Label "percentDone" Percentage)))
@ -358,8 +379,7 @@ getAndUpdateTransmissionTorrentsStatus knownTorrents = do
pure actualTorrents pure actualTorrents
getTransmissionTorrentsTable :: getTransmissionTorrentsTable ::
(MonadIO m, MonadTransmission m, MonadThrow m, MonadLogger m) => (MonadTransmission m, MonadThrow m, MonadLogger m, Otel.MonadTracer m, MonadUnliftIO m) => m Html
m Html
getTransmissionTorrentsTable = do getTransmissionTorrentsTable = do
let fields = let fields =
[ "hashString", [ "hashString",
@ -431,7 +451,12 @@ data TransmissionRequest = TransmissionRequest
deriving stock (Show) deriving stock (Show)
testTransmission :: (Show out) => (TransmissionRequest, Json.Parse Error out) -> IO (Either TmpPg.StartError ()) 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 "host" Text "port" Text
transmissionConnectionConfig = (T2 (label @"host" "localhost") (label @"port" "9091")) transmissionConnectionConfig = (T2 (label @"host" "localhost") (label @"port" "9091"))
@ -507,52 +532,66 @@ data TransmissionResponseStatus
deriving stock (Show) deriving stock (Show)
doTransmissionRequest' :: doTransmissionRequest' ::
( MonadIO m, ( MonadTransmission m,
MonadTransmission m,
MonadThrow m, MonadThrow m,
MonadLogger m MonadLogger m,
Otel.MonadTracer m,
MonadUnliftIO m
) => ) =>
(TransmissionRequest, Json.Parse Error output) -> (TransmissionRequest, Json.Parse Error output) ->
m output m output
doTransmissionRequest' req = do doTransmissionRequest' req = inSpan' "Transmission Request" $ \span -> do
resp <- resp <-
doTransmissionRequest doTransmissionRequest
span
transmissionConnectionConfig transmissionConnectionConfig
req req
case resp.result of 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 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 Just out -> pure out
-- | Contact the transmission RPC, and do the CSRF protection dance. -- | Contact the transmission RPC, and do the CSRF protection dance.
-- --
-- Spec: https://github.com/transmission/transmission/blob/main/docs/rpc-spec.md -- Spec: https://github.com/transmission/transmission/blob/main/docs/rpc-spec.md
doTransmissionRequest :: doTransmissionRequest ::
( MonadIO m, ( MonadTransmission m,
MonadTransmission m,
HasField "host" t1 Text, HasField "host" t1 Text,
HasField "port" t1 Text, HasField "port" t1 Text,
MonadThrow m, MonadThrow m,
MonadLogger m MonadLogger m,
Otel.MonadTracer m,
MonadUnliftIO m
) => ) =>
Otel.Span ->
t1 -> t1 ->
(TransmissionRequest, Json.Parse Error output) -> (TransmissionRequest, Json.Parse Error output) ->
m (TransmissionResponse output) m (TransmissionResponse output)
doTransmissionRequest dat (req, parser) = do doTransmissionRequest span dat (req, parser) = do
sessionId <- getTransmissionId sessionId <- getTransmissionId
let body = let textArg t = (Enc.text t, Otel.toAttribute @Text t)
Enc.object let encArg enc = (enc, Otel.toAttribute @Text $ enc & Enc.encToTextPretty)
( [ ("method", req.method & Enc.text), let intArg i = (Enc.int i, Otel.toAttribute @Int i)
("arguments", Enc.map id req.arguments)
] let body :: [(Text, (Enc, Otel.Attribute))] =
<> (req.tag & maybe [] (\t -> [("tag", t & Enc.int)])) ( [ ("method", req.method & textArg),
) ("arguments", encArg $ Enc.map id req.arguments)
logDebug [fmt|transmission request: {Pretty.showPrettyJsonEncoding body.unEnc}|] ]
<> (req.tag & foldMap (\t -> [("tag", t & intArg)]))
)
Otel.addAttributes
span
( HashMap.fromList $
body
<&> bimap
(\k -> [fmt|transmission.{k}|])
(\(_, attr) -> attr)
)
let httpReq = let httpReq =
[fmt|http://{dat.host}:{dat.port}/transmission/rpc|] [fmt|http://{dat.host}:{dat.port}/transmission/rpc|]
& Http.setRequestMethod "POST" & 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" . (: []))) & (sessionId & maybe id (Http.setRequestHeader "X-Transmission-Session-Id" . (: [])))
resp <- Http.httpBS httpReq resp <- Http.httpBS httpReq
-- Implement the CSRF protection thingy -- Implement the CSRF protection thingy
@ -567,7 +606,7 @@ doTransmissionRequest dat (req, parser) = do
& liftIO & liftIO
<&> NonEmpty.head <&> NonEmpty.head
setTransmissionId tid setTransmissionId tid
doTransmissionRequest dat (req, parser) doTransmissionRequest span dat (req, parser)
200 -> 200 ->
resp resp
& Http.getResponseBody & Http.getResponseBody
@ -592,42 +631,47 @@ doTransmissionRequest dat (req, parser) = do
case Json.eitherDecodeStrict' @Json.Value (resp & Http.getResponseBody) of case Json.eitherDecodeStrict' @Json.Value (resp & Http.getResponseBody) of
Left _err -> pure () Left _err -> pure ()
Right val -> logInfo [fmt|failing transmission response: {showPrettyJson val}|] Right val -> logInfo [fmt|failing transmission response: {showPrettyJson val}|]
appThrowTree err appThrowTree span err
_ -> liftIO $ unwrapIOError $ Left [fmt|Non-200 response: {showPretty resp}|] _ -> liftIO $ unwrapIOError $ Left [fmt|Non-200 response: {showPretty resp}|]
redactedSearch :: redactedSearch ::
(MonadLogger m, MonadIO m, MonadThrow m) => (MonadLogger m, MonadThrow m, Otel.MonadTracer m, MonadUnliftIO m) =>
[(ByteString, ByteString)] -> [(ByteString, ByteString)] ->
Json.Parse ErrorTree a -> Json.Parse ErrorTree a ->
m a m a
redactedSearch advanced = redactedSearch advanced parser = inSpan' "Redacted API Search" $ \span ->
redactedApiRequestJson redactedApiRequestJson
span
( T2 ( T2
(label @"action" "browse") (label @"action" "browse")
(label @"actionArgs" ((advanced <&> second Just))) (label @"actionArgs" ((advanced <&> second Just)))
) )
parser
redactedGetTorrentFile :: redactedGetTorrentFile ::
( MonadLogger m, ( MonadLogger m,
MonadIO m,
MonadThrow m, MonadThrow m,
HasField "torrentId" dat Int HasField "torrentId" dat Int,
MonadUnliftIO m,
Otel.MonadTracer m
) => ) =>
dat -> dat ->
m ByteString m ByteString
redactedGetTorrentFile dat = redactedGetTorrentFile dat = inSpan' "Redacted Get Torrent File" $ \span -> do
redactedApiRequest req <-
( T2 mkRedactedApiRequest
(label @"action" "download") ( T2
( label @"actionArgs" (label @"action" "download")
[ ("id", Just (dat.torrentId & showToText @Int & textToBytesUtf8)) ( label @"actionArgs"
-- try using tokens as long as we have them (TODO: what if there’s no tokens left? [ ("id", Just (dat.torrentId & showToText @Int & textToBytesUtf8))
-- ANSWER: it breaks: -- try using tokens as long as we have them (TODO: what if there’s no tokens left?
-- responseBody = "{\"status\":\"failure\",\"error\":\"You do not have any freeleech tokens left. Please use the regular DL link.\"}", -- ANSWER: it breaks:
-- ("usetoken", Just "1") -- responseBody = "{\"status\":\"failure\",\"error\":\"You do not have any freeleech tokens left. Please use the regular DL link.\"}",
] -- ("usetoken", Just "1")
) ]
) )
)
httpTorrent span req
-- fix -- fix
-- ( \io -> do -- ( \io -> do
@ -636,7 +680,7 @@ redactedGetTorrentFile dat =
-- io -- 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 exampleSearch = do
t1 <- t1 <-
redactedSearchAndInsert redactedSearchAndInsert
@ -671,9 +715,10 @@ exampleSearch = do
redactedSearchAndInsert :: redactedSearchAndInsert ::
forall m. forall m.
( MonadLogger m, ( MonadLogger m,
MonadIO m,
MonadPostgres m, MonadPostgres m,
MonadThrow m MonadThrow m,
Otel.MonadTracer m,
MonadUnliftIO m
) => ) =>
[(ByteString, ByteString)] -> [(ByteString, ByteString)] ->
m (Transaction m ()) m (Transaction m ())
@ -701,7 +746,10 @@ redactedSearchAndInsert extraArguments = do
when (status /= "success") $ do when (status /= "success") $ do
Json.throwCustomError [fmt|Status was not "success", but {status}|] Json.throwCustomError [fmt|Status was not "success", but {status}|]
Json.key "response" $ do 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 Json.key "results" $ do
tourGroups <- tourGroups <-
label @"tourGroups" label @"tourGroups"
@ -848,12 +896,13 @@ redactedGetTorrentFileAndInsert ::
( HasField "torrentId" r Int, ( HasField "torrentId" r Int,
MonadPostgres m, MonadPostgres m,
MonadThrow m, MonadThrow m,
MonadIO m, MonadLogger m,
MonadLogger m Otel.MonadTracer m,
MonadUnliftIO m
) => ) =>
r -> r ->
Transaction m (Label "torrentFile" ByteString) Transaction m (Label "torrentFile" ByteString)
redactedGetTorrentFileAndInsert dat = do redactedGetTorrentFileAndInsert dat = inSpan' "Redacted Get Torrent File and Insert" $ \span -> do
bytes <- redactedGetTorrentFile dat bytes <- redactedGetTorrentFile dat
execute execute
[sql| [sql|
@ -864,7 +913,7 @@ redactedGetTorrentFileAndInsert dat = do
( (Binary bytes :: Binary ByteString), ( (Binary bytes :: Binary ByteString),
dat.torrentId dat.torrentId
) )
>>= assertOneUpdated "redactedGetTorrentFileAndInsert" >>= assertOneUpdated span "redactedGetTorrentFileAndInsert"
>>= \() -> pure (label @"torrentFile" bytes) >>= \() -> pure (label @"torrentFile" bytes)
getTorrentFileById :: getTorrentFileById ::
@ -904,13 +953,14 @@ updateTransmissionTorrentHashById dat = do
) )
assertOneUpdated :: assertOneUpdated ::
(HasField "numberOfRowsAffected" r Natural, MonadThrow m) => (HasField "numberOfRowsAffected" r Natural, MonadThrow m, MonadIO m) =>
Otel.Span ->
Text -> Text ->
r -> r ->
m () m ()
assertOneUpdated name x = case x.numberOfRowsAffected of assertOneUpdated span 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 span ([fmt|{name :: Text}: Expected to update exactly one row, but updated {n :: Natural} row(s)|])
migrate :: migrate ::
( MonadPostgres m, ( MonadPostgres m,
@ -1048,6 +1098,9 @@ getBestTorrents = do
inSpan :: (MonadUnliftIO m, Otel.MonadTracer m) => Text -> m a -> m a inSpan :: (MonadUnliftIO m, Otel.MonadTracer m) => Text -> m a -> m a
inSpan name = Otel.inSpan name Otel.defaultSpanArguments 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 :: Either a1 a2 -> Maybe a2
hush (Left _) = Nothing hush (Left _) = Nothing
hush (Right a) = Just a 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) 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. -- | 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, ( MonadThrow m,
MonadIO m, MonadIO m,
MonadLogger m, MonadLogger m,
@ -1090,19 +1143,84 @@ redactedApiRequest ::
HasField "actionArgs" p [(ByteString, Maybe ByteString)] HasField "actionArgs" p [(ByteString, Maybe ByteString)]
) => ) =>
p -> p ->
m ByteString m Http.Request
redactedApiRequest dat = do mkRedactedApiRequest dat = do
authKey <- runCommandExpect0 "pass" ["internet/redacted/api-keys/whatcd-resolver"] authKey <- runCommandExpect0 "pass" ["internet/redacted/api-keys/whatcd-resolver"]
let req = pure $
[fmt|https://redacted.ch/ajax.php|] [fmt|https://redacted.ch/ajax.php|]
& Http.setRequestMethod "GET" & Http.setRequestMethod "GET"
& Http.setQueryString (("action", Just dat.action) : dat.actionArgs) & Http.setQueryString (("action", Just dat.action) : dat.actionArgs)
& Http.setRequestHeader "Authorization" [authKey] & Http.setRequestHeader "Authorization" [authKey]
httpTorrent ::
( MonadIO m,
MonadThrow m
) =>
Otel.Span ->
Http.Request ->
m ByteString
httpTorrent span req =
Http.httpBS req Http.httpBS req
>>= assertM >>= assertM
( \resp -> case resp & Http.responseStatus & (.statusCode) of span
200 -> Right $ resp & Http.responseBody ( \resp -> do
_ -> Left [fmt|Redacted returned an non-200 error code: {resp & showPretty}|] 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 :: redactedApiRequestJson ::
@ -1112,32 +1230,31 @@ redactedApiRequestJson ::
HasField "action" p ByteString, HasField "action" p ByteString,
HasField "actionArgs" p [(ByteString, Maybe ByteString)] HasField "actionArgs" p [(ByteString, Maybe ByteString)]
) => ) =>
Otel.Span ->
p -> p ->
Json.Parse ErrorTree a -> Json.Parse ErrorTree a ->
m a m a
redactedApiRequestJson dat parse = do redactedApiRequestJson span dat parser =
redactedApiRequest dat do
>>= ( Json.parseStrict parse mkRedactedApiRequest dat
>>> first (Json.parseErrorTree "could not parse redacted response") >>= httpJson span parser
>>> assertM id
)
assertM :: (MonadThrow f) => (t -> Either ErrorTree a) -> t -> f a assertM :: (MonadThrow f, MonadIO f) => Otel.Span -> (t -> Either ErrorTree a) -> t -> f a
assertM f v = case f v of assertM span f v = case f v of
Right a -> pure a Right a -> pure a
Left err -> appThrowTree err Left err -> appThrowTree span err
runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a) runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a)
runAppWith appT = withTracer $ \tracer -> 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 <-
Pool.createPool Pool.newPool $
(Postgres.connectPostgreSQL (db & TmpPg.toConnectionString)) Pool.defaultPoolConfig
Postgres.close {- resource init action -} (Postgres.connectPostgreSQL (db & TmpPg.toConnectionString))
{- number of stripes -} 5 {- resource destruction -} Postgres.close
{- unusedResourceOpenTime -} 10 {- unusedResourceOpenTime -} 10
{- max resources per stripe -} 10 {- max resources across all stripes -} 20
transmissionSessionId <- newEmptyMVar transmissionSessionId <- newEmptyMVar
let newAppT = do let newAppT = do
logInfo [fmt|Running with config: {showPretty config}|] logInfo [fmt|Running with config: {showPretty config}|]
@ -1204,12 +1321,48 @@ data AppException = AppException Text
deriving stock (Show) deriving stock (Show)
deriving anyclass (Exception) deriving anyclass (Exception)
appThrowTree :: (MonadThrow m) => ErrorTree -> m a -- | A specialized variant of @addEvent@ that records attributes conforming to
appThrowTree exc = throwM $ AppException $ prettyErrorTree exc -- 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 appThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> ErrorTree -> m a
orAppThrowTree = \case appThrowTree span exc = do
Left err -> appThrowTree err 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 Right a -> pure a
instance (MonadIO m) => MonadLogger (AppT m) where instance (MonadIO m) => MonadLogger (AppT m) where

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

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