diff options
| -rw-r--r-- | users/Profpatsch/.hlint.yaml | 4 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs | 15 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/AppT.hs | 16 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs | 56 |
4 files changed, 82 insertions, 9 deletions
diff --git a/users/Profpatsch/.hlint.yaml b/users/Profpatsch/.hlint.yaml index 1e7e083bba93..f00f78c5259d 100644 --- a/users/Profpatsch/.hlint.yaml +++ b/users/Profpatsch/.hlint.yaml @@ -125,11 +125,11 @@ message: "`void` leads to bugs. Use an explicit `_ <- …` instead" - name: Data.Foldable.length - within: [] + within: ["MyPrelude"] message: "`Data.Foldable.length` is dangerous to use, because it also works on types you wouldn’t expect, like `length (3,4) == 1` and `length (Just 2) == 1`. Use the `length` function for your specific type instead, for example `List.length` or `Map.length`." - name: Prelude.length - within: [MyPrelude] + within: ["MyPrelude"] message: "`Prelude.length` is dangerous to use, because it also works on types you wouldn’t expect, like `length (3,4) == 1` and `length (Just 2) == 1`. Use the `length` function for your specific type instead, for example `List.length` or `Map.length`." # Using an explicit lambda with its argument “underscored” diff --git a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs index bd8ddd12f775..2585f6637c41 100644 --- a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs +++ b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs @@ -165,6 +165,21 @@ querySingleRow qry params = do query qry params >>= ensureSingleRow -- TODO: implement via fold, so that the result doesn’t have to be realized in memory +querySingleRowWith :: + ( MonadPostgres m, + ToRow qParams, + Typeable qParams, + Typeable a, + MonadThrow m + ) => + Query -> + qParams -> + Decoder a -> + Transaction m a +querySingleRowWith qry params decoder = do + queryWith qry params decoder >>= ensureSingleRow + +-- TODO: implement via fold, so that the result doesn’t have to be realized in memory querySingleRowMaybe :: ( MonadPostgres m, ToRow qParams, diff --git a/users/Profpatsch/whatcd-resolver/src/AppT.hs b/users/Profpatsch/whatcd-resolver/src/AppT.hs index 7bd38a733e53..7afd430745f6 100644 --- a/users/Profpatsch/whatcd-resolver/src/AppT.hs +++ b/users/Profpatsch/whatcd-resolver/src/AppT.hs @@ -66,6 +66,17 @@ addAttribute span key a = Otel.addAttribute span ("_." <> key) a addAttributes :: (MonadIO m) => Otel.Span -> HashMap Text Otel.Attribute -> m () addAttributes span attrs = Otel.addAttributes span $ attrs & HashMap.mapKeys ("_." <>) +appThrowTreeNewSpan :: (MonadThrow m, MonadOtel m) => Text -> ErrorTree -> m a +appThrowTreeNewSpan spanName exc = inSpan' spanName $ \span -> do + let msg = prettyErrorTree exc + recordException + span + ( T2 + (label @"type_" "AppException") + (label @"message" msg) + ) + throwM $ AppException msg + appThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> ErrorTree -> m a appThrowTree span exc = do let msg = prettyErrorTree exc @@ -87,6 +98,11 @@ assertM span f v = case f v of Right a -> pure a Left err -> appThrowTree span err +assertMNewSpan :: (MonadThrow f, MonadOtel f) => Text -> (t -> Either ErrorTree a) -> t -> f a +assertMNewSpan spanName f v = case f v of + Right a -> pure a + Left err -> appThrowTreeNewSpan spanName err + -- | 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> diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index fe0952a5ffab..7f2c4ec7e83c 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -82,7 +82,16 @@ main = htmlUi :: AppT IO () htmlUi = do let debug = True - withRunInIO $ \runInIO -> Warp.run 9092 $ \req respond -> do + uniqueRunId <- + runTransaction $ + querySingleRowWith + [sql| + SELECT gen_random_uuid()::text + |] + () + (Dec.fromField @Text) + + withRunInIO $ \runInIO -> Warp.run 9093 $ \req respond -> do let catchAppException act = try act >>= \case Right a -> pure a @@ -95,7 +104,7 @@ htmlUi = do if debug then Html.Pretty.renderHtml >>> stringToText >>> textToBytesUtf8 >>> toLazyBytes else Html.renderHtml - let h route act = + let hh route act = runInIO $ Otel.inSpan' [fmt|Route {route }|] @@ -108,9 +117,9 @@ htmlUi = do ) ( \span -> withRunInIO $ \runInIO' -> do res <- runInIO' $ act span - respond . Wai.responseLBS Http.ok200 [("Content-Type", "text/html")] . renderHtml $ res + respond . Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . renderHtml $ res.html ) - + let h route act = hh route (\span -> act span <&> (\html -> T2 (label @"html" html) (label @"extraHeaders" []))) let mp span parser = Multipart.parseMultipartOrThrow (appThrowTree span) @@ -127,8 +136,12 @@ htmlUi = do 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 + & assertMNewSpan spanName id + case req & Wai.pathInfo & Text.intercalate "/" of - "" -> h "/" mainHtml + "" -> h "/" (mainHtml uniqueRunId) "snips/redacted/search" -> do h "/snips/redacted/search" $ \span -> do dat <- @@ -209,12 +222,30 @@ htmlUi = do ) jsonld <- httpGetJsonLd (qry.target) pure $ renderJsonld jsonld - otherRoute -> h [fmt|/{otherRoute}|] mainHtml + "autorefresh" -> do + qry <- + runInIO $ + parseQueryArgsNewSpan + "Autorefresh Query Parse" + ( label @"hasItBeenRestarted" + <$> singleQueryArgument "hasItBeenRestarted" Field.utf8 + ) + respond $ + Wai.responseLBS + Http.ok200 + ( [("Content-Type", "text/html")] + <> if uniqueRunId /= qry.hasItBeenRestarted + then -- cause the client side to refresh + [("HX-Refresh", "true")] + else [] + ) + "" + otherRoute -> h [fmt|/{otherRoute}|] (mainHtml uniqueRunId) 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>|] - mainHtml _span = runTransaction $ do + mainHtml uniqueRunId _span = runTransaction $ do jsonld <- httpGetJsonLd ( URI.parseURI "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" & annotate "not an URI" & unwrapError, @@ -257,6 +288,17 @@ htmlUi = do <div id="redacted-search-results"> {bestTorrentsTable} </div> + <!-- refresh the page if the uniqueRunId is different --> + <input + hidden + type="text" + id="autorefresh" + name="hasItBeenRestarted" + value={uniqueRunId} + hx-get="/autorefresh" + hx-trigger="every 5s" + hx-swap="none" + /> </body> |] |