From b1403a5e94445418c3996c685832dc7426292023 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sat, 8 Mar 2025 13:34:47 +0100 Subject: [PATCH] feat(users/Profpatsch/whatcd-resolver): add html streaming & maps MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit For all big page reloads, we want the `` of the page to start being transmitted even while doing database requests. So let’s use the `Wai.ResponseStream` to do exactly that. The handler provides the contents of ``, we start streaming that, meanwhile it calculates the `` and once that is ready transmits it. This means we can load all our static resources before the page even starts sending any body data, meaning the css and html is already there when we reach ``. Sweet. The `` in `artistPage` was depending on the table data, so I moved it into a separate SELECT. We can do all of it in parallel as well. Sweet. ~~~ This also adds static file prefetching of source maps if provided. Change-Id: Ib824430594733b4c8e86ee1096c8afba2df1a66d Reviewed-on: https://cl.tvl.fyi/c/depot/+/13221 Reviewed-by: Profpatsch <mail@profpatsch.de> Tested-by: BuildkiteCI --- .../my-prelude/src/Postgres/MonadPostgres.hs | 16 + .../whatcd-resolver/src/Redacted.hs | 40 +- .../whatcd-resolver/src/WhatcdResolver.hs | 437 +++++++++++------- 3 files changed, 320 insertions(+), 173 deletions(-) diff --git a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs index 39f087725..2f653bcf2 100644 --- a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs +++ b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs @@ -195,6 +195,22 @@ querySingleRowWith :: querySingleRowWith qry params decoder = do queryWith qry params decoder >>= ensureSingleRow +-- | Return the first row, if any. +queryFirstRowWithMaybe :: + ( MonadPostgres m, + ToRow qParams, + Typeable qParams, + Typeable a + ) => + Query -> + qParams -> + Decoder a -> + Transaction m (Maybe a) +queryFirstRowWithMaybe qry params decoder = do + queryWith qry params decoder >>= \case + [] -> pure Nothing + (one : _) -> pure $ Just one + -- TODO: implement via fold, so that the result doesn’t have to be realized in memory querySingleRowMaybe :: ( MonadPostgres m, diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index 7ee64e85d..7f7b1b335 100644 --- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs +++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs @@ -71,7 +71,7 @@ redactedGetArtist :: ( MonadOtel m, MonadThrow m, MonadRedacted m, - HasField "artistId" r Text, + HasField "artistId" r Int, HasField "page" r (Maybe Natural) ) => r -> @@ -83,7 +83,7 @@ redactedGetArtist dat parser = span ( T3 (label @"action" "artist") - (label @"actionArgs" [("id", buildBytes utf8B dat.artistId)]) + (label @"actionArgs" [("id", buildBytes intDecimalB dat.artistId)]) (getLabel @"page" dat) ) parser @@ -184,7 +184,7 @@ redactedRefreshArtist :: MonadThrow m, MonadOtel m, MonadRedacted m, - HasField "artistId" dat Text + HasField "artistId" dat Int ) => dat -> m (Transaction m (Label "newTorrents" [Label "torrentId" Int])) @@ -610,8 +610,9 @@ getTorrentById dat = do data GetBestTorrentsFilter = GetBestTorrentsFilter { onlyDownloaded :: Bool, - onlyArtist :: Maybe (Label "artistRedactedId" Natural), - onlyTheseTorrents :: Maybe ([Label "torrentId" Int]) + onlyArtist :: Maybe (Label "artistRedactedId" Int), + onlyTheseTorrents :: Maybe ([Label "torrentId" Int]), + limitResults :: Maybe Natural } -- | Find the best torrent for each torrent group (based on the seeding_weight) @@ -662,6 +663,7 @@ getBestTorrents opts = do JOIN redacted.torrents t ON t.id = f.id JOIN redacted.torrent_groups tg ON tg.id = t.torrent_group ORDER BY seeding_weight DESC + LIMIT ?::int |] ( do let (onlyArtistB, onlyArtistId) = case opts.onlyArtist of @@ -672,9 +674,10 @@ getBestTorrents opts = do Just a -> (False, a <&> (.torrentId) & PGArray) ( opts.onlyDownloaded :: Bool, onlyArtistB :: Bool, - onlyArtistId & fromIntegral @Natural @Int, + onlyArtistId :: Int, onlyTheseTorrentsB :: Bool, - onlyTheseTorrents + onlyTheseTorrents, + opts.limitResults <&> naturalToInteger :: Maybe Integer ) ) ( do @@ -714,6 +717,29 @@ getBestTorrents opts = do } ) +getArtistNameById :: (MonadPostgres m, HasField "artistId" r Int) => r -> Transaction m (Maybe Text) +getArtistNameById dat = do + queryFirstRowWithMaybe + [sql| + WITH json as ( + SELECT + -- TODO: different endpoints handle this differently (e.g. action=search and action=artist), we should unify this while parsing + COALESCE( + t.full_json_result->'artists', + tg.full_json_result->'artists', + '[]'::jsonb + ) as artists + FROM redacted.torrents t + JOIN redacted.torrent_groups tg ON tg.id = t.torrent_group + ) + select name from json + join lateral jsonb_to_recordset(artists) as x(id int, name text) on true + where id = ?::int + limit 1 + |] + (getLabel @"artistId" dat) + (Dec.fromField @Text) + -- | Do a request to the redacted API. If you know what that is, you know how to find the API docs. mkRedactedApiRequest :: ( MonadThrow m, diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index 99fda5ac4..0ba147468 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -72,9 +72,7 @@ import System.Environment qualified as Env import System.FilePath ((</>)) import Text.Blaze.Html (Html) import Text.Blaze.Html.Renderer.Utf8 qualified as Html -import Text.Blaze.Html5 ((!)) import Text.Blaze.Html5 qualified as Html -import Text.Blaze.Html5.Attributes qualified as HtmlA import Tool (readTool, readTools) import Transmission import UnliftIO hiding (Handler) @@ -141,48 +139,52 @@ htmlUi = do Map.fromList $ ourHtmlIntegrities.handlers <> [ ( "", - Html $ \span -> do - counterHtml <- counterHtmlM - mainHtml ourHtmlIntegrities counterHtml uniqueRunId span + HtmlStream (pure ()) $ \_dat span -> + ( pure $ htmlPageChrome ourHtmlIntegrities "whatcd-resolver", + do + counterHtml <- counterHtmlM + mainHtml counterHtml uniqueRunId span + ) ), ( "redacted-search", - HtmlWithQueryArgs (label @"searchstr" <$> singleQueryArgument "searchstr" Cat.id) $ - \dat _span -> do - t <- redactedSearchAndInsert [("searchstr", dat.queryArgs.searchstr)] - runTransaction $ do - res <- t - (table, settings) <- - concurrentlyTraced - ( getBestTorrentsTable - (label @"groupByReleaseType" True) - ( Just - ( E21 - (label @"onlyTheseTorrents" res.newTorrents) - ) :: - Maybe - ( E2 - "onlyTheseTorrents" - [Label "torrentId" Int] - "artistRedactedId" - Natural - ) + HtmlStream (label @"searchstr" <$> singleQueryArgument "searchstr" Cat.id) $ + \dat _span -> + ( pure $ htmlPageChrome ourHtmlIntegrities [fmt|whatcd-resolver – Search – {dat.queryArgs.searchstr & bytesToTextUtf8Lenient}|], + do + t <- redactedSearchAndInsert [("searchstr", dat.queryArgs.searchstr)] + runTransaction $ do + res <- t + (table, settings) <- + concurrentlyTraced + ( getBestTorrentsTable + (t2 #groupByReleaseType True #limitResults Nothing) + ( Just + ( E21 + (label @"onlyTheseTorrents" res.newTorrents) + ) :: + Maybe + ( E2 + "onlyTheseTorrents" + [Label "torrentId" Int] + "artistRedactedId" + Int + ) + ) ) - ) - (getSettings) - pure $ - mainHtml' - ourHtmlIntegrities - ( MainHtml - { pageTitle = [fmt|whatcd-resolver – Search – {dat.queryArgs.searchstr & bytesToTextUtf8Lenient}|], - returnUrl = dat.returnUrl, - counterHtml = "", - mainContent = - [hsx|<h1>Search results for <pre>{dat.queryArgs.searchstr}</pre></h1>{table}|], - uniqueRunId, - searchFieldContent = dat.queryArgs.searchstr & bytesToTextUtf8Lenient, - settings - } - ) + (getSettings) + pure $ + mainHtml' + ( MainHtml + { returnUrl = dat.returnUrl, + counterHtml = "", + mainContent = + [hsx|<h1>Search results for <pre>{dat.queryArgs.searchstr}</pre></h1>{table}|], + uniqueRunId, + searchFieldContent = dat.queryArgs.searchstr & bytesToTextUtf8Lenient, + settings + } + ) + ) ), ( "snips/redacted/torrentDataJson", Html $ \span -> do @@ -288,12 +290,28 @@ htmlUi = do ), ( "artist", do - HtmlWithQueryArgs + HtmlStream ( label @"artistRedactedId" - <$> (singleQueryArgument "redacted_id" (Field.utf8 >>> Field.decimalNatural)) + <$> ( singleQueryArgument + "redacted_id" + ( Field.utf8 + >>> (Field.decimalNatural <&> toInteger) + >>> (Field.bounded @Int "Int") + ) + ) ) - $ \dat _span -> do - artistPage ourHtmlIntegrities (T2 dat.queryArgs (label @"uniqueRunId" uniqueRunId)) + $ \dat _span -> + ( do + runTransaction $ inSpan' "finding artist name" $ \span -> do + addAttribute span "artist-redacted-id" (dat.queryArgs.artistRedactedId, intDecimalT) + mArtistName <- getArtistNameById (lbl #artistId dat.queryArgs.artistRedactedId) + let pageTitle = case mArtistName of + Nothing -> "whatcd-resolver" + Just a -> [fmt|{a} - Artist Page - whatcd-resolver|] + pure $ htmlPageChrome ourHtmlIntegrities pageTitle, + do + artistPage (T2 dat.queryArgs (label @"uniqueRunId" uniqueRunId)) + ) ), ( "artist/refresh", HtmlOrRedirect $ @@ -302,11 +320,18 @@ htmlUi = do parseMultipartOrThrow span req - (label @"artistId" <$> Multipart.field "artist-id" Field.utf8) + ( label @"artistId" + <$> Multipart.field + "artist-id" + ( Field.utf8 + >>> (Field.decimalNatural <&> toInteger) + >>> (Field.bounded @Int "Int") + ) + ) t <- redactedRefreshArtist dat runTransaction $ do t - pure $ E22 (label @"redirectTo" [fmt|/artist?redacted_id={dat.artistId}|]) + pure $ E22 (label @"redirectTo" $ textToBytesUtf8 $ mkArtistLink dat) ), ( "autorefresh", Plain $ do @@ -332,7 +357,7 @@ htmlUi = do runHandlers ( Html $ \span -> do counterHtml <- counterHtmlM - mainHtml ourHtmlIntegrities counterHtml uniqueRunId span + mainHtml counterHtml uniqueRunId span ) handlers req @@ -341,8 +366,8 @@ htmlUi = do 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 :: OurHtmlIntegrities (AppT IO) -> Html -> Text -> Otel.Span -> AppT IO Html - mainHtml ourHtmlIntegrities counterHtml 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, @@ -351,15 +376,13 @@ htmlUi = do -- <&> renderJsonld (bestTorrentsTable, settings) <- concurrentlyTraced - (getBestTorrentsTable (label @"groupByReleaseType" False) Nothing) + (getBestTorrentsTable (t2 #groupByReleaseType False #limitResults (Just 1000)) Nothing) (getSettings) -- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable pure $ mainHtml' - ourHtmlIntegrities ( MainHtml - { pageTitle = "whatcd-resolver", - returnUrl = "/", + { returnUrl = "/", counterHtml, mainContent = bestTorrentsTable, uniqueRunId, @@ -369,8 +392,7 @@ htmlUi = do ) data MainHtml = MainHtml - { pageTitle :: Text, - returnUrl :: ByteString, + { returnUrl :: ByteString, counterHtml :: Html, mainContent :: Html, searchFieldContent :: Text, @@ -378,17 +400,12 @@ data MainHtml = MainHtml settings :: Settings } -mainHtml' :: OurHtmlIntegrities m -> MainHtml -> Html -mainHtml' integrities dat = do - -- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable - htmlPageChrome - integrities - dat.pageTitle - ( [hsx| +mainHtml' :: MainHtml -> Html +mainHtml' dat = do + [hsx| {dat.counterHtml} - {settingButtons dat dat.settings} - |] - <> [hsx| + {settingButtons dat} + <form action="redacted-search"> <label for="redacted-search-input">Redacted Search</label> <input @@ -414,7 +431,16 @@ mainHtml' integrities dat = do hx-swap="none" /> |] + +withAsyncTraced :: (MonadUnliftIO m) => m a -> (Async a -> m b) -> m b +withAsyncTraced act f = do + ctx <- Otel.getContext + withAsync + ( do + _old <- Otel.attachContext ctx + act ) + f -- | Run two actions concurrently, and add them to the current Otel trace concurrentlyTraced :: (MonadUnliftIO m) => m a -> m b -> m (a, b) @@ -430,6 +456,16 @@ concurrentlyTraced act1 act2 = do act2 ) +mapConcurrentlyTraced :: (MonadUnliftIO m, Traversable t) => (a -> m b) -> t a -> m (t b) +mapConcurrentlyTraced f t = do + ctx <- Otel.getContext + mapConcurrently + ( \a -> do + _old <- Otel.attachContext ctx + f a + ) + t + parseMultipartOrThrow :: (MonadLogger m, MonadIO m, MonadThrow m) => Otel.Span -> Wai.Request -> Multipart.MultipartParseT m a -> m a parseMultipartOrThrow span req parser = Multipart.parseMultipartOrThrow @@ -456,13 +492,12 @@ redirectOrFallback target responseFn req = do Just _ -> responseFn Http.ok200 ("Hx-Redirect", target) Nothing -> responseFn Http.seeOther303 ("Location", target) -htmlPageChrome :: (ToHtml a) => OurHtmlIntegrities m -> Text -> a -> Html -htmlPageChrome integrities title body = - Html.docTypeHtml $ - [hsx| - <head> - <!-- TODO: set nice page title for each page --> - <title>{title} +htmlPageChrome :: OurHtmlIntegrities m -> Text -> HtmlHead +htmlPageChrome integrities title = + HtmlHead + { title, + headContent = + [hsx|