feat(users/Profpatsch/whatcd-resolver): add autorefresh

Adds a little polling mechanism that compares against an ID that is
generated anew every time the server is restarted.

Works well together with shortcuttable.

Change-Id: Icc6745b599e43881c14349794feaf5794cfe6777
Reviewed-on: https://cl.tvl.fyi/c/depot/+/11172
Autosubmit: Profpatsch <mail@profpatsch.de>
Reviewed-by: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI
This commit is contained in:
Profpatsch 2024-03-17 02:26:47 +01:00 committed by clbot
parent efa5fe1239
commit 3b9fb1aa60
4 changed files with 82 additions and 9 deletions

View file

@ -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 wouldnt 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 wouldnt 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”

View file

@ -164,6 +164,21 @@ querySingleRow ::
querySingleRow qry params = do
query qry params >>= ensureSingleRow
-- TODO: implement via fold, so that the result doesnt 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 doesnt have to be realized in memory
querySingleRowMaybe ::
( MonadPostgres m,

View file

@ -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>

View file

@ -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>
|]