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

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

4 files changed, 82 insertions, 9 deletions

diff --git a/users/Profpatsch/.hlint.yaml b/users/Profpatsch/.hlint.yaml
index 1e7e083bba..f00f78c525 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 bd8ddd12f7..2585f6637c 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 7bd38a733e..7afd430745 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 fe0952a5ff..7f2c4ec7e8 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>
     |]