From 570a3c044fb12cb3c2978baedb5c37d8f8850202 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Thu, 6 Mar 2025 13:57:12 +0100 Subject: [PATCH] feat(users/Profpatsch/whatcd-resolver): conduitToHtmx w/ counter ex Experiment: can we convert any Html-producing conduit into a self-updating htmx snippet? Yes! Add the resulting handler and initial snippet, and it will poll the handler every second or so until the conduit stops emitting values. Change-Id: I0bed17a5db8691a19df6c334ae1268dd6a3d3123 Reviewed-on: https://cl.tvl.fyi/c/depot/+/13209 Tested-by: BuildkiteCI Reviewed-by: Profpatsch --- .../whatcd-resolver/src/WhatcdResolver.hs | 93 +++++++++++++++++-- .../whatcd-resolver/whatcd-resolver.cabal | 3 + 2 files changed, 87 insertions(+), 9 deletions(-) diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index 040aa5340..ab4e2a4d9 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -7,6 +7,8 @@ import AppT import Arg import Builder import Comparison +import Conduit (ConduitT) +import Conduit qualified import Control.Category qualified as Cat import Control.Monad.Catch.Pure (runCatch) import Control.Monad.Logger.CallStack @@ -15,6 +17,7 @@ import Data.Aeson qualified as Json import Data.Aeson.BetterErrors qualified as Json import Data.Aeson.KeyMap qualified as KeyMap import Data.CaseInsensitive (CI) +import Data.Conduit ((.|)) import Data.Error.Tree import Data.HashMap.Strict qualified as HashMap import Data.List qualified as List @@ -68,6 +71,8 @@ import Text.Blaze.Html5 qualified as Html import Tool (readTool, readTools) import Transmission import UnliftIO hiding (Handler) +import UnliftIO.Async qualified as Async +import UnliftIO.Concurrent (threadDelay) import Prelude hiding (span) main :: IO () @@ -93,6 +98,8 @@ htmlUi = do () (Dec.fromField @Text) + (counterHtmlM, counterHandler, _counterAsync) <- testCounter (label @"endpoint" "counter") + withRunInIO $ \runInIO -> Warp.run 9093 $ \req respondOrig -> do let catchAppException act = try act >>= \case @@ -123,7 +130,11 @@ htmlUi = do let handlers :: Handlers (AppT IO) handlers = Map.fromList - [ ("", Html (mainHtml uniqueRunId)), + [ ( "", + Html $ \span -> do + counterHtml <- counterHtmlM + mainHtml counterHtml uniqueRunId span + ), ( "snips/redacted/search", Html $ \span -> do @@ -237,6 +248,7 @@ htmlUi = do pure $ renderJsonld jsonld ) ), + ("counter", counterHandler), ( "settings", PostAndRedirect ( do @@ -301,7 +313,10 @@ htmlUi = do ] runInIO $ runHandlers - (Html $ mainHtml uniqueRunId) + ( Html $ \span -> do + counterHtml <- counterHtmlM + mainHtml counterHtml uniqueRunId span + ) handlers req respondOrig @@ -309,8 +324,8 @@ htmlUi = do everySecond :: Text -> Enc -> Html -> Html everySecond call extraData innerHtml = [hsx|
{innerHtml}
|] - mainHtml :: Text -> Otel.Span -> AppT IO Html - mainHtml uniqueRunId _span = runTransaction $ do + mainHtml :: Html -> Text -> Otel.Span -> AppT IO Html + mainHtml counterHtml uniqueRunId _span = runTransaction $ do -- jsonld <- -- httpGetJsonLd -- ( URI.parseURI "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" & annotate "not an URI" & unwrapError, @@ -326,8 +341,11 @@ htmlUi = do pure $ htmlPageChrome "whatcd-resolver" - [hsx| + ( [hsx| + {counterHtml} {settingButtons returnUrl settings} + |] + <> [hsx|
@@ -353,7 +371,8 @@ htmlUi = do hx-trigger="every 5s" hx-swap="none" /> - |] + |] + ) -- | Run two actions concurrently, and add them to the current Otel trace concurrentlyTraced :: (MonadUnliftIO m) => m a -> m b -> m (a, b) @@ -755,10 +774,12 @@ mkBestTorrentsTable opts fresh = do |] InTransmission info -> [hsx|{info.transmissionInfo.percentDone.unPercentage}% done|] NotInTransmissionYet -> [hsx||] - let bestRows rowData = + let bestRows :: NonEmpty (TorrentData (Label "percentDone" Percentage)) -> Html + bestRows rowData = rowData & foldMap ( \b -> do + let torrentPosition :: Text = [fmt|torrent-{b.torrentId}|] let artists = b.artists <&> ( \a -> @@ -769,7 +790,7 @@ mkBestTorrentsTable opts fresh = do & mkLinkList [hsx| - + {localTorrent b} {Html.toHtml @Int b.groupId} @@ -788,7 +809,8 @@ mkBestTorrentsTable opts fresh = do |] ) - let section rows = do + let section :: NonEmpty (TorrentData (Label "percentDone" Percentage)) -> Html + section rows = do let releaseType = rows & NonEmpty.head & (.releaseType.unReleaseType) [hsx|

{releaseType}s

@@ -1167,3 +1189,56 @@ writeSettings settings = inSpan' "Write Settings" $ \span -> do ON CONFLICT (key) DO UPDATE SET value = EXCLUDED.value |] (settings & unzipPGArray @"key" @Text @"val" @Json.Value) + +-- | Given a conduit that produces Html, +-- return a htmx html snippet which will regularly poll for new results in the conduit, +-- and a handler endpoint that returns the newest output when it happens. +conduitToHtmx :: + (HasField "endpoint" opts Text, MonadUnliftIO m) => + opts -> + -- | initial inner html + Html -> + ConduitT () Html m () -> + m (m Html, HandlerResponse m, Async.Async ()) +conduitToHtmx opts init' conduit = do + let htmlPolling inner = + [hsx| +
+ {inner :: Html} +
+ |] + currentHtml <- newIORef $! htmlPolling init' + collectorHandle <- Async.async $ do + liftIO $ putStderrLn "spawned async collector" + lastVal <- + conduit + .| Conduit.mapMC + ( \html -> do + atomicWriteIORef currentHtml $! (htmlPolling html) + pure html + ) + .| Conduit.lastDefC init' + & Conduit.runConduit + -- when the original conduit finishes, we stop polling for updates. + atomicWriteIORef currentHtml $! [hsx|
{lastVal}
|] + + let handler = Html $ \_span -> do + -- TODO: can we use Etags here and return 304 instead? + readIORef currentHtml + + pure (readIORef currentHtml, handler, collectorHandle) + +testCounter :: + (HasField "endpoint" opts Text, MonadUnliftIO m) => + opts -> + m (m Html, HandlerResponse m, Async ()) +testCounter opts = conduitToHtmx opts [hsx|

0

|] counterConduit + +counterConduit :: (MonadIO m) => ConduitT i Html m () +counterConduit = + Conduit.yieldMany [0 .. 100] + .| Conduit.awaitForever + ( \(i :: Int) -> do + threadDelay 300_000 + Conduit.yield [hsx|

{i}

|] + ) diff --git a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal index de89a339b..b551de543 100644 --- a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal +++ b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal @@ -87,6 +87,7 @@ library blaze-html, bytestring, case-insensitive, + conduit, containers, unordered-containers, directory, @@ -101,7 +102,9 @@ library monad-logger, mtl, network-uri, + random, resource-pool, + template-haskell, postgresql-simple, punycode, tmp-postgres,