fix(users/Profpatsch/whatcd-resolver): show query error as html

We want the user thingy to see which error happened; it also gets
logged in the traces as before.

There’s another function which we should replace as well at one point.

Change-Id: I3d49edccd0e2088a45ac0138af9536b40dfa6848
Reviewed-on: https://cl.tvl.fyi/c/depot/+/11660
Tested-by: BuildkiteCI
Autosubmit: Profpatsch <mail@profpatsch.de>
Reviewed-by: Profpatsch <mail@profpatsch.de>
This commit is contained in:
Profpatsch 2024-05-13 19:12:21 +02:00 committed by clbot
parent c2f649f62e
commit 5c709131de
2 changed files with 60 additions and 38 deletions

View file

@ -500,7 +500,6 @@ runPgFormat pool sqlStatement = do
Pool.putResource localPool new
)
( \(pgFmt, _localPool) -> do
putStderrLn "Running with warm pgformatter"
ByteString.hPut pgFmt.stdinHdl sqlStatement
-- close stdin to make pg_formatter format (it exits …)
-- issue: https://github.com/darold/pgFormatter/issues/333

View file

@ -10,6 +10,7 @@ import Control.Monad.Reader
import Data.Aeson qualified as Json
import Data.Aeson.BetterErrors qualified as Json
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Error.Tree (prettyErrorTree)
import Data.HashMap.Strict qualified as HashMap
import Data.List qualified as List
import Data.Map.Strict qualified as Map
@ -105,9 +106,6 @@ htmlUi = do
( do
label @"torrentId" <$> Multipart.field "torrent-id" ((Field.utf8 >>> Field.signedDecimal >>> Field.bounded @Int "int"))
)
let parseQueryArgs span parser =
Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) req
& assertM span id
let parseQueryArgsNewSpan spanName parser =
Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) req
@ -196,26 +194,28 @@ htmlUi = do
Just _torrent -> [hsx|Running|]
),
( "snips/jsonld/render",
respond.html $ \span -> do
qry <-
parseQueryArgs
span
do
let HandlerResponses {htmlWithQueryArgs} = respond
htmlWithQueryArgs
( label @"target"
<$> ( (singleQueryArgument "target" Field.utf8 >>> textToURI)
& Parse.andParse uriToHttpClientRequest
)
)
( \qry _span -> do
jsonld <- httpGetJsonLd (qry.target)
pure $ renderJsonld jsonld
)
),
( "artist",
respond.html $ \span -> do
qry <-
parseQueryArgs
span
do
let HandlerResponses {htmlWithQueryArgs} = respond
htmlWithQueryArgs
( label @"dbId"
<$> (singleQueryArgument "db_id" Field.utf8)
)
$ \qry _span -> do
artistPage qry
),
( "autorefresh",
@ -316,7 +316,9 @@ type Handlers m = HandlerResponses m -> Map Text (m ResponseReceived)
data HandlerResponses m = HandlerResponses
{ -- | render html
html :: ((Otel.Span -> m Html) -> m ResponseReceived),
html :: (Otel.Span -> m Html) -> m ResponseReceived,
-- | render html after parsing some query arguments
htmlWithQueryArgs :: forall a. (Parse Query a -> (a -> Otel.Span -> m Html) -> m ResponseReceived),
-- | render a plain wai response
plain :: (m Wai.Response -> m ResponseReceived)
}
@ -330,10 +332,7 @@ runHandlers ::
m ResponseReceived
runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do
let path = req & Wai.pathInfo & Text.intercalate "/"
let handlerResponses =
( HandlerResponses
{ plain = (\m -> liftIO $ runInIO m >>= respond),
html = \act ->
let html act =
Otel.inSpan'
[fmt|Route /{path}|]
( Otel.defaultSpanArguments
@ -344,9 +343,33 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do
}
)
( \span -> do
res <- act span <&> (\html -> T2 (label @"html" html) (label @"extraHeaders" []))
res <- act span <&> (\h -> T2 (label @"html" h) (label @"extraHeaders" []))
liftIO $ respond . Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . Html.renderHtml $ res.html
)
let handlerResponses =
( HandlerResponses
{ plain = (\m -> liftIO $ runInIO m >>= respond),
html,
htmlWithQueryArgs = \parser act ->
case req & Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) of
Right a -> html (act a)
Left err ->
html
( \span -> do
recordException
span
( T2
(label @"type_" "Query Parse Exception")
(label @"message" (prettyErrorTree err))
)
pure
[hsx|
<h1>Error:</h1>
<pre>{err & prettyErrorTree}</pre>
|]
)
}
)
let handler =