maurice/snix
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

feat(users/Profpatsch/whatcd-resolver): add html streaming & maps

Browse source 
For all big page reloads, we want the `<head>` 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 `<head>`, we start streaming that, meanwhile
it calculates the `<body>` 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 `</html>`.

Sweet.

The `<title>` 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
This commit is contained in:
Profpatsch 2025-03-08 13:34:47 +01:00
parent b32a95c206
commit b1403a5e94
3 changed files with 320 additions and 173 deletions
Download patch file Download diff file Expand all files Collapse all files

16
users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs
View file

@ -195,6 +195,22 @@ querySingleRowWith ::
querySingleRowWith qry params decoder = do querySingleRowWith qry params decoder = do
queryWith qry params decoder >>= ensureSingleRow 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 -- TODO: implement via fold, so that the result doesn’t have to be realized in memory
querySingleRowMaybe :: querySingleRowMaybe ::
( MonadPostgres m, ( MonadPostgres m,

40
users/Profpatsch/whatcd-resolver/src/Redacted.hs
View file

@ -71,7 +71,7 @@ redactedGetArtist ::
( MonadOtel m, ( MonadOtel m,
MonadThrow m, MonadThrow m,
MonadRedacted m, MonadRedacted m,
HasField "artistId" r Text, HasField "artistId" r Int,
HasField "page" r (Maybe Natural) HasField "page" r (Maybe Natural)
) => ) =>
r -> r ->
@ -83,7 +83,7 @@ redactedGetArtist dat parser =
span span
( T3 ( T3
(label @"action" "artist") (label @"action" "artist")
(label @"actionArgs" [("id", buildBytes utf8B dat.artistId)]) (label @"actionArgs" [("id", buildBytes intDecimalB dat.artistId)])
(getLabel @"page" dat) (getLabel @"page" dat)
) )
parser parser
@ -184,7 +184,7 @@ redactedRefreshArtist ::
MonadThrow m, MonadThrow m,
MonadOtel m, MonadOtel m,
MonadRedacted m, MonadRedacted m,
HasField "artistId" dat Text HasField "artistId" dat Int
) => ) =>
dat -> dat ->
m (Transaction m (Label "newTorrents" [Label "torrentId" Int])) m (Transaction m (Label "newTorrents" [Label "torrentId" Int]))
@ -610,8 +610,9 @@ getTorrentById dat = do
data GetBestTorrentsFilter = GetBestTorrentsFilter data GetBestTorrentsFilter = GetBestTorrentsFilter
{ onlyDownloaded :: Bool, { onlyDownloaded :: Bool,
onlyArtist :: Maybe (Label "artistRedactedId" Natural), onlyArtist :: Maybe (Label "artistRedactedId" Int),
onlyTheseTorrents :: Maybe ([Label "torrentId" Int]) onlyTheseTorrents :: Maybe ([Label "torrentId" Int]),
limitResults :: Maybe Natural
} }
-- | Find the best torrent for each torrent group (based on the seeding_weight) -- | 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.torrents t ON t.id = f.id
JOIN redacted.torrent_groups tg ON tg.id = t.torrent_group JOIN redacted.torrent_groups tg ON tg.id = t.torrent_group
ORDER BY seeding_weight DESC ORDER BY seeding_weight DESC
LIMIT ?::int
|] |]
( do ( do
let (onlyArtistB, onlyArtistId) = case opts.onlyArtist of let (onlyArtistB, onlyArtistId) = case opts.onlyArtist of
@ -672,9 +674,10 @@ getBestTorrents opts = do
Just a -> (False, a <&> (.torrentId) & PGArray) Just a -> (False, a <&> (.torrentId) & PGArray)
( opts.onlyDownloaded :: Bool, ( opts.onlyDownloaded :: Bool,
onlyArtistB :: Bool, onlyArtistB :: Bool,
onlyArtistId & fromIntegral @Natural @Int, onlyArtistId :: Int,
onlyTheseTorrentsB :: Bool, onlyTheseTorrentsB :: Bool,
onlyTheseTorrents onlyTheseTorrents,
opts.limitResults <&> naturalToInteger :: Maybe Integer
) )
) )
( do ( 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. -- | Do a request to the redacted API. If you know what that is, you know how to find the API docs.
mkRedactedApiRequest :: mkRedactedApiRequest ::
( MonadThrow m, ( MonadThrow m,

437
users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
View file

@ -72,9 +72,7 @@ import System.Environment qualified as Env
import System.FilePath ((</>)) import System.FilePath ((</>))
import Text.Blaze.Html (Html) import Text.Blaze.Html (Html)
import Text.Blaze.Html.Renderer.Utf8 qualified as 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 qualified as Html
import Text.Blaze.Html5.Attributes qualified as HtmlA
import Tool (readTool, readTools) import Tool (readTool, readTools)
import Transmission import Transmission
import UnliftIO hiding (Handler) import UnliftIO hiding (Handler)
@ -141,48 +139,52 @@ htmlUi = do
Map.fromList $ Map.fromList $
ourHtmlIntegrities.handlers ourHtmlIntegrities.handlers
<> [ ( "", <> [ ( "",
Html $ \span -> do HtmlStream (pure ()) $ \_dat span ->
counterHtml <- counterHtmlM ( pure $ htmlPageChrome ourHtmlIntegrities "whatcd-resolver",
mainHtml ourHtmlIntegrities counterHtml uniqueRunId span do
counterHtml <- counterHtmlM
mainHtml counterHtml uniqueRunId span
)
), ),
( "redacted-search", ( "redacted-search",
HtmlWithQueryArgs (label @"searchstr" <$> singleQueryArgument "searchstr" Cat.id) $ HtmlStream (label @"searchstr" <$> singleQueryArgument "searchstr" Cat.id) $
\dat _span -> do \dat _span ->
t <- redactedSearchAndInsert [("searchstr", dat.queryArgs.searchstr)] ( pure $ htmlPageChrome ourHtmlIntegrities [fmt|whatcd-resolver – Search – {dat.queryArgs.searchstr & bytesToTextUtf8Lenient}|],
runTransaction $ do do
res <- t t <- redactedSearchAndInsert [("searchstr", dat.queryArgs.searchstr)]
(table, settings) <- runTransaction $ do
concurrentlyTraced res <- t
( getBestTorrentsTable (table, settings) <-
(label @"groupByReleaseType" True) concurrentlyTraced
( Just ( getBestTorrentsTable
( E21 (t2 #groupByReleaseType True #limitResults Nothing)
(label @"onlyTheseTorrents" res.newTorrents) ( Just
) :: ( E21
Maybe (label @"onlyTheseTorrents" res.newTorrents)
( E2 ) ::
"onlyTheseTorrents" Maybe
[Label "torrentId" Int] ( E2
"artistRedactedId" "onlyTheseTorrents"
Natural [Label "torrentId" Int]
) "artistRedactedId"
Int
)
)
) )
) (getSettings)
(getSettings) pure $
pure $ mainHtml'
mainHtml' ( MainHtml
ourHtmlIntegrities { returnUrl = dat.returnUrl,
( MainHtml counterHtml = "",
{ pageTitle = [fmt|whatcd-resolver – Search – {dat.queryArgs.searchstr & bytesToTextUtf8Lenient}|], mainContent =
returnUrl = dat.returnUrl, [hsx|<h1>Search results for <pre>{dat.queryArgs.searchstr}</pre></h1>{table}|],
counterHtml = "", uniqueRunId,
mainContent = searchFieldContent = dat.queryArgs.searchstr & bytesToTextUtf8Lenient,
[hsx|<h1>Search results for <pre>{dat.queryArgs.searchstr}</pre></h1>{table}|], settings
uniqueRunId, }
searchFieldContent = dat.queryArgs.searchstr & bytesToTextUtf8Lenient, )
settings )
}
)
), ),
( "snips/redacted/torrentDataJson", ( "snips/redacted/torrentDataJson",
Html $ \span -> do Html $ \span -> do
@ -288,12 +290,28 @@ htmlUi = do
), ),
( "artist", ( "artist",
do do
HtmlWithQueryArgs HtmlStream
( label @"artistRedactedId" ( label @"artistRedactedId"
<$> (singleQueryArgument "redacted_id" (Field.utf8 >>> Field.decimalNatural)) <$> ( singleQueryArgument
"redacted_id"
( Field.utf8
>>> (Field.decimalNatural <&> toInteger)
>>> (Field.bounded @Int "Int")
)
)
) )
$ \dat _span -> do $ \dat _span ->
artistPage ourHtmlIntegrities (T2 dat.queryArgs (label @"uniqueRunId" uniqueRunId)) ( 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", ( "artist/refresh",
HtmlOrRedirect $ HtmlOrRedirect $
@ -302,11 +320,18 @@ htmlUi = do
parseMultipartOrThrow parseMultipartOrThrow
span span
req 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 t <- redactedRefreshArtist dat
runTransaction $ do runTransaction $ do
t t
pure $ E22 (label @"redirectTo" [fmt|/artist?redacted_id={dat.artistId}|]) pure $ E22 (label @"redirectTo" $ textToBytesUtf8 $ mkArtistLink dat)
), ),
( "autorefresh", ( "autorefresh",
Plain $ do Plain $ do
@ -332,7 +357,7 @@ htmlUi = do
runHandlers runHandlers
( Html $ \span -> do ( Html $ \span -> do
counterHtml <- counterHtmlM counterHtml <- counterHtmlM
mainHtml ourHtmlIntegrities counterHtml uniqueRunId span mainHtml counterHtml uniqueRunId span
) )
handlers handlers
req req
@ -341,8 +366,8 @@ htmlUi = do
everySecond :: Text -> Enc -> Html -> Html 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>|] 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 :: Html -> Text -> Otel.Span -> AppT IO Html
mainHtml ourHtmlIntegrities counterHtml uniqueRunId _span = runTransaction $ do mainHtml counterHtml uniqueRunId _span = runTransaction $ do
-- jsonld <- -- jsonld <-
-- httpGetJsonLd -- httpGetJsonLd
-- ( URI.parseURI "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" & annotate "not an URI" & unwrapError, -- ( URI.parseURI "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" & annotate "not an URI" & unwrapError,
@ -351,15 +376,13 @@ htmlUi = do
-- <&> renderJsonld -- <&> renderJsonld
(bestTorrentsTable, settings) <- (bestTorrentsTable, settings) <-
concurrentlyTraced concurrentlyTraced
(getBestTorrentsTable (label @"groupByReleaseType" False) Nothing) (getBestTorrentsTable (t2 #groupByReleaseType False #limitResults (Just 1000)) Nothing)
(getSettings) (getSettings)
-- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable -- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable
pure $ pure $
mainHtml' mainHtml'
ourHtmlIntegrities
( MainHtml ( MainHtml
{ pageTitle = "whatcd-resolver", { returnUrl = "/",
returnUrl = "/",
counterHtml, counterHtml,
mainContent = bestTorrentsTable, mainContent = bestTorrentsTable,
uniqueRunId, uniqueRunId,
@ -369,8 +392,7 @@ htmlUi = do
) )
data MainHtml = MainHtml data MainHtml = MainHtml
{ pageTitle :: Text, { returnUrl :: ByteString,
returnUrl :: ByteString,
counterHtml :: Html, counterHtml :: Html,
mainContent :: Html, mainContent :: Html,
searchFieldContent :: Text, searchFieldContent :: Text,
@ -378,17 +400,12 @@ data MainHtml = MainHtml
settings :: Settings settings :: Settings
} }
mainHtml' :: OurHtmlIntegrities m -> MainHtml -> Html mainHtml' :: MainHtml -> Html
mainHtml' integrities dat = do mainHtml' dat = do
-- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable [hsx|
htmlPageChrome
integrities
dat.pageTitle
( [hsx|
{dat.counterHtml} {dat.counterHtml}
{settingButtons dat dat.settings} {settingButtons dat}
|]
<> [hsx|
<form action="redacted-search"> <form action="redacted-search">
<label for="redacted-search-input">Redacted Search</label> <label for="redacted-search-input">Redacted Search</label>
<input <input
@ -414,7 +431,16 @@ mainHtml' integrities dat = do
hx-swap="none" 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 -- | Run two actions concurrently, and add them to the current Otel trace
concurrentlyTraced :: (MonadUnliftIO m) => m a -> m b -> m (a, b) concurrentlyTraced :: (MonadUnliftIO m) => m a -> m b -> m (a, b)
@ -430,6 +456,16 @@ concurrentlyTraced act1 act2 = do
act2 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 :: (MonadLogger m, MonadIO m, MonadThrow m) => Otel.Span -> Wai.Request -> Multipart.MultipartParseT m a -> m a
parseMultipartOrThrow span req parser = parseMultipartOrThrow span req parser =
Multipart.parseMultipartOrThrow Multipart.parseMultipartOrThrow
@ -456,13 +492,12 @@ redirectOrFallback target responseFn req = do
Just _ -> responseFn Http.ok200 ("Hx-Redirect", target) Just _ -> responseFn Http.ok200 ("Hx-Redirect", target)
Nothing -> responseFn Http.seeOther303 ("Location", target) Nothing -> responseFn Http.seeOther303 ("Location", target)
htmlPageChrome :: (ToHtml a) => OurHtmlIntegrities m -> Text -> a -> Html htmlPageChrome :: OurHtmlIntegrities m -> Text -> HtmlHead
htmlPageChrome integrities title body = htmlPageChrome integrities title =
Html.docTypeHtml $ HtmlHead
[hsx| { title,
<head> headContent =
<!-- TODO: set nice page title for each page --> [hsx|
<title>{title}</title>
<meta charset="utf-8"> <meta charset="utf-8">
<meta name="viewport" content="width=device-width, initial-scale=1"> <meta name="viewport" content="width=device-width, initial-scale=1">
<!-- <!--
@ -479,11 +514,8 @@ htmlPageChrome integrities title body =
border: thin solid; border: thin solid;
} }
</style> </style>
</head>
<body>
{body}
</body>
|] |]
}
data OurHtmlIntegrities m = OurHtmlIntegrities data OurHtmlIntegrities m = OurHtmlIntegrities
{ html :: Html, { html :: Html,
@ -498,6 +530,7 @@ prefetchHtmlIntegrities = do
integrityUrl = "https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/css/bootstrap.min.css", integrityUrl = "https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/css/bootstrap.min.css",
integrityHash = "sha384-9ndCyUaIbzAi2FUVXJi0CjmCapSmO7SnpJef0486qhLnuZ2cdeRhO02iuK6FUUVM", integrityHash = "sha384-9ndCyUaIbzAi2FUVXJi0CjmCapSmO7SnpJef0486qhLnuZ2cdeRhO02iuK6FUUVM",
localPath = "resources/bootstrap.min.css", localPath = "resources/bootstrap.min.css",
provideSourceMap = True,
isTag = E21 (label @"link" ()) isTag = E21 (label @"link" ())
}, },
HtmlIntegrity HtmlIntegrity
@ -505,6 +538,7 @@ prefetchHtmlIntegrities = do
integrityUrl = "https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/js/bootstrap.bundle.min.js", integrityUrl = "https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/js/bootstrap.bundle.min.js",
integrityHash = "sha384-geWF76RCwLtnZ8qwWowPQNguL3RmwHVBC9FhGdlKrxdiJJigb/j/68SIy3Te4Bkz", integrityHash = "sha384-geWF76RCwLtnZ8qwWowPQNguL3RmwHVBC9FhGdlKrxdiJJigb/j/68SIy3Te4Bkz",
localPath = "resources/bootstrap.bundle.min.js", localPath = "resources/bootstrap.bundle.min.js",
provideSourceMap = True,
isTag = E22 (label @"script" ()) isTag = E22 (label @"script" ())
}, },
HtmlIntegrity HtmlIntegrity
@ -512,22 +546,27 @@ prefetchHtmlIntegrities = do
integrityUrl = "https://unpkg.com/htmx.org@1.9.2", integrityUrl = "https://unpkg.com/htmx.org@1.9.2",
integrityHash = "sha384-L6OqL9pRWyyFU3+/bjdSri+iIphTN/bvYyM37tICVyOJkWZLpP2vGn6VUEXgzg6h", integrityHash = "sha384-L6OqL9pRWyyFU3+/bjdSri+iIphTN/bvYyM37tICVyOJkWZLpP2vGn6VUEXgzg6h",
localPath = "resources/htmx.js", localPath = "resources/htmx.js",
provideSourceMap = False,
isTag = E22 (label @"script" ()) isTag = E22 (label @"script" ())
} }
] ]
resources resources
& traverse & mapConcurrentlyTraced
( \r -> ( \r ->
prefetchResourceIntegrity r <&> \(html, handler) -> prefetchResourceIntegrity r <&> \(html, handler) ->
( html, ( html,
[(r.localPath, handler)] [(r.localPath, handler (Arg @"giveSourceMap" False))]
-- a little hacky, we provide an extra handler if there is a source map
<> ifTrue
(r.provideSourceMap)
[(r.localPath <> ".map", handler (Arg @"giveSourceMap" True))]
) )
) )
<&> fold <&> fold
<&> \(html, handlers) -> OurHtmlIntegrities {..} <&> \(html, handlers) -> OurHtmlIntegrities {..}
artistPage :: artistPage ::
( HasField "artistRedactedId" dat Natural, ( HasField "artistRedactedId" dat Int,
HasField "uniqueRunId" dat Text, HasField "uniqueRunId" dat Text,
MonadPostgres m, MonadPostgres m,
MonadOtel m, MonadOtel m,
@ -535,25 +574,22 @@ artistPage ::
MonadThrow m, MonadThrow m,
MonadTransmission m MonadTransmission m
) => ) =>
OurHtmlIntegrities m ->
dat -> dat ->
m Html m Html
artistPage ourHtmlIntegrities dat = runTransaction $ do artistPage dat = runTransaction $ do
(fresh, settings) <- (fresh, settings) <-
concurrentlyTraced concurrentlyTraced
( getBestTorrentsData ( getBestTorrentsData
(label @"limitResults" Nothing)
(Just $ E22 (getLabel @"artistRedactedId" dat)) (Just $ E22 (getLabel @"artistRedactedId" dat))
) )
(getSettings) (getSettings)
let artistName = fresh & findMaybe (\t -> t.artists & findMaybe (\a -> if a.artistId == (dat.artistRedactedId & fromIntegral @Natural @Int) then Just a.artistName else Nothing))
let torrents = mkBestTorrentsTable (label @"groupByReleaseType" True) fresh let torrents = mkBestTorrentsTable (label @"groupByReleaseType" True) fresh
let returnUrl = let returnUrl =
textToBytesUtf8 $ textToBytesUtf8 $
mkArtistLink (label @"artistId" (dat.artistRedactedId & fromIntegral @Natural @Int)) mkArtistLink (label @"artistId" (dat.artistRedactedId))
let pageTitle = case artistName of
Nothing -> "whatcd-resolver"
Just a -> [fmt|{a} - Artist Page - whatcd-resolver|]
let mainContent = let mainContent =
[hsx| [hsx|
<div id="artist-torrents"> <div id="artist-torrents">
@ -565,7 +601,7 @@ artistPage ourHtmlIntegrities dat = runTransaction $ do
hidden hidden
type="text" type="text"
name="artist-id" name="artist-id"
value={dat.artistRedactedId & buildText naturalDecimalT} value={dat.artistRedactedId & buildText intDecimalT}
/> />
<button type="submit" hx-disabled-elt="this">Refresh Artist Page</button> <button type="submit" hx-disabled-elt="this">Refresh Artist Page</button>
<div class="htmx-indicator">Refreshing!</div> <div class="htmx-indicator">Refreshing!</div>
@ -573,9 +609,8 @@ artistPage ourHtmlIntegrities dat = runTransaction $ do
|] |]
pure $ pure $
mainHtml' mainHtml'
ourHtmlIntegrities
( MainHtml ( MainHtml
{ pageTitle, { -- pageTitle,
returnUrl, returnUrl,
counterHtml = "", counterHtml = "",
mainContent, mainContent,
@ -592,6 +627,11 @@ data QueryArgsDat a = QueryArgsDat
returnUrl :: ByteString returnUrl :: ByteString
} }
data HtmlHead = HtmlHead
{ title :: Text,
headContent :: Html
}
data HandlerResponse m where data HandlerResponse m where
-- | render html -- | render html
Html :: (Otel.Span -> m Html) -> HandlerResponse m Html :: (Otel.Span -> m Html) -> HandlerResponse m
@ -601,6 +641,8 @@ data HandlerResponse m where
HtmlWithQueryArgs :: Parse Query a -> (QueryArgsDat a -> Otel.Span -> m Html) -> HandlerResponse m HtmlWithQueryArgs :: Parse Query a -> (QueryArgsDat a -> Otel.Span -> m Html) -> HandlerResponse m
-- | render html or reload the page via the Referer header if no htmx -- | render html or reload the page via the Referer header if no htmx
HtmlOrReferer :: (Otel.Span -> m Html) -> HandlerResponse m HtmlOrReferer :: (Otel.Span -> m Html) -> HandlerResponse m
-- | render html and stream the head before even doing any work in the handler
HtmlStream :: Parse Query a -> (QueryArgsDat a -> Otel.Span -> (m HtmlHead, m Html)) -> HandlerResponse m
-- | parse the request as POST submission, then redirect to the given endpoint -- | parse the request as POST submission, then redirect to the given endpoint
PostAndRedirect :: PostAndRedirect ::
m (MultipartParseT m dat) -> m (MultipartParseT m dat) ->
@ -660,11 +702,11 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do
liftIO $ respond (Wai.responseLBS Http.seeOther303 [("Location", res.redirectTo)] "") liftIO $ respond (Wai.responseLBS Http.seeOther303 [("Location", res.redirectTo)] "")
else do else do
liftIO $ respond (Wai.responseLBS Http.methodNotAllowed405 [] "") liftIO $ respond (Wai.responseLBS Http.methodNotAllowed405 [] "")
let htmlWithQueryArgs parser act = let htmlWithQueryArgs' parser =
case req & Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) of case req & Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) of
Right queryArgs -> html (act $ QueryArgsDat {queryArgs, returnUrl = (req & Wai.rawPathInfo) <> (req & Wai.rawQueryString)}) Right queryArgs -> Right $ QueryArgsDat {queryArgs, returnUrl = (req & Wai.rawPathInfo) <> (req & Wai.rawQueryString)}
Left err -> Left err ->
html Left
( \span -> do ( \span -> do
recordException recordException
span span
@ -679,6 +721,39 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do
<pre>{err & prettyErrorTree}</pre> <pre>{err & prettyErrorTree}</pre>
|] |]
) )
let htmlWithQueryArgs parser act = case htmlWithQueryArgs' parser of
Right dat -> html (act dat)
Left act' -> html act'
let htmlStream :: Parse Query a -> (QueryArgsDat a -> Otel.Span -> (m HtmlHead, m Html)) -> m ResponseReceived
htmlStream parser act = inRouteSpan $ \span -> do
case htmlWithQueryArgs' parser of
Left act' -> html act'
Right dat -> do
let (mkHead, mkBody) = act dat span
-- start the body work (heh) immediately, but stream the head first
withAsyncTraced mkBody $ \bodyAsync -> do
withRunInIO $ \runInIO' -> respond $ Wai.responseStream Http.ok200 [("Content-Type", "text/html")] $ \send flush -> do
runInIO' $ inSpan "sending <head>" $ do
htmlHead <- mkHead
liftIO $ do
send "<!DOCTYPE html>\n"
send "<html>\n"
send $
Html.renderHtmlBuilder $
[hsx|
<head>
<title>{htmlHead.title}</title>
{htmlHead.headContent}
</head>
|]
flush
htmlBody <- liftIO $ wait bodyAsync
send "<body>\n"
send $ Html.renderHtmlBuilder htmlBody
send "</body>\n"
send "</html>\n"
flush
let handler = let handler =
handlers handlers
@ -689,6 +764,7 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do
HtmlOrRedirect act -> htmlOrRedirect act HtmlOrRedirect act -> htmlOrRedirect act
HtmlWithQueryArgs parser act -> htmlWithQueryArgs parser act HtmlWithQueryArgs parser act -> htmlWithQueryArgs parser act
HtmlOrReferer act -> htmlOrReferer act HtmlOrReferer act -> htmlOrReferer act
HtmlStream parser act -> htmlStream parser act
PostAndRedirect mParser act -> mParser >>= \parser -> postAndRedirect parser act PostAndRedirect mParser act -> mParser >>= \parser -> postAndRedirect parser act
Plain act -> liftIO $ runInIO act >>= respond Plain act -> liftIO $ runInIO act >>= respond
runInIO handler runInIO handler
@ -739,13 +815,14 @@ getBestTorrentsTable ::
MonadLogger m, MonadLogger m,
MonadPostgres m, MonadPostgres m,
MonadOtel m, MonadOtel m,
HasField "groupByReleaseType" opts Bool HasField "groupByReleaseType" opts Bool,
HasField "limitResults" opts (Maybe Natural)
) => ) =>
opts -> opts ->
Maybe (E2 "onlyTheseTorrents" [Label "torrentId" Int] "artistRedactedId" Natural) -> Maybe (E2 "onlyTheseTorrents" [Label "torrentId" Int] "artistRedactedId" Int) ->
Transaction m Html Transaction m Html
getBestTorrentsTable opts dat = do getBestTorrentsTable opts dat = do
fresh <- getBestTorrentsData dat fresh <- getBestTorrentsData opts dat
pure $ mkBestTorrentsTable opts fresh pure $ mkBestTorrentsTable opts fresh
doIfJust :: (Applicative f) => (a -> f ()) -> Maybe a -> f () doIfJust :: (Applicative f) => (a -> f ()) -> Maybe a -> f ()
@ -756,15 +833,18 @@ getBestTorrentsData ::
MonadThrow m, MonadThrow m,
MonadLogger m, MonadLogger m,
MonadPostgres m, MonadPostgres m,
MonadOtel m MonadOtel m,
HasField "limitResults" opts (Maybe Natural)
) => ) =>
Maybe (E2 "onlyTheseTorrents" [Label "torrentId" Int] "artistRedactedId" Natural) -> opts ->
Maybe (E2 "onlyTheseTorrents" [Label "torrentId" Int] "artistRedactedId" Int) ->
Transaction m [TorrentData (Label "percentDone" Percentage)] Transaction m [TorrentData (Label "percentDone" Percentage)]
getBestTorrentsData filters = inSpan' "get torrents table data" $ \span -> do getBestTorrentsData opts filters = inSpan' "get torrents table data" $ \span -> do
let onlyArtist = label @"artistRedactedId" <$> (filters >>= getE22 @"artistRedactedId") let onlyArtist = label @"artistRedactedId" <$> (filters >>= getE22 @"artistRedactedId")
onlyArtist & doIfJust (\a -> addAttribute span "artist-filter.redacted-id" (a.artistRedactedId, naturalDecimalT)) onlyArtist & doIfJust (\a -> addAttribute span "artist-filter.redacted-id" (a.artistRedactedId, intDecimalT))
let onlyTheseTorrents = filters >>= getE21 @"onlyTheseTorrents" let onlyTheseTorrents = filters >>= getE21 @"onlyTheseTorrents"
onlyTheseTorrents & doIfJust (\a -> addAttribute span "torrent-filter.ids" (a <&> (getLabel @"torrentId") & showToText & Otel.toAttribute)) onlyTheseTorrents & doIfJust (\a -> addAttribute span "torrent-filter.ids" (a <&> (getLabel @"torrentId") & showToText & Otel.toAttribute))
let limitResults = getField @"limitResults" opts
let getBest = getBestTorrents GetBestTorrentsFilter {onlyDownloaded = False, ..} let getBest = getBestTorrents GetBestTorrentsFilter {onlyDownloaded = False, ..}
bestStale :: [TorrentData ()] <- getBest bestStale :: [TorrentData ()] <- getBest
@ -1182,9 +1262,9 @@ submitSettingForm opts inputs =
</form> </form>
|] |]
settingButtons :: (HasField "returnUrl" opts ByteString) => opts -> Settings -> Html settingButtons :: (HasField "returnUrl" opts ByteString, HasField "settings" opts Settings) => opts -> Html
settingButtons opts s = settingButtons opts =
if s.useFreeleechTokens if opts.settings.useFreeleechTokens
then then
submitSettingForm submitSettingForm
opts opts
@ -1312,81 +1392,102 @@ data HtmlIntegrity = HtmlIntegrity
integrityHash :: Text, integrityHash :: Text,
-- | The local url path to fetch the cached resource from the frontend -- | The local url path to fetch the cached resource from the frontend
localPath :: Text, localPath :: Text,
-- | Whether there is a resource map at the URL + `.map`
provideSourceMap :: Bool,
-- | is @<link>@ or @<script>@ tag? -- | is @<link>@ or @<script>@ tag?
isTag :: E2 "link" () "script" () isTag :: E2 "link" () "script" ()
} }
-- | Fetch a resource, calculate its integrity hash, and return a html @<link>@ snippet and a handler to return the resource. -- | Fetch a resource, calculate its integrity hash, and return a html @<link>@ snippet and a handler to return the resource.
prefetchResourceIntegrity :: (MonadOtel m, MonadThrow m) => HtmlIntegrity -> m (Html, HandlerResponse m) prefetchResourceIntegrity :: forall m. (MonadOtel m, MonadThrow m) => HtmlIntegrity -> m (Html, (Arg "giveSourceMap" Bool) -> HandlerResponse m)
prefetchResourceIntegrity dat = inSpan' [fmt|prefetching resource {dat.integrityName}|] $ \span -> do prefetchResourceIntegrity dat = inSpan' [fmt|prefetching resource {dat.integrityName}|] $ \span -> do
let x = let x =
dat.integrityUrl dat.integrityUrl
& Parse.runParse "Failed to parse URI" (textToURI >>> uriToHttpClientRequest) & Parse.runParse "Failed to parse URI" (textToURI >>> uriToHttpClientRequest)
& unwrapErrorTree & unwrapErrorTree
Http.httpBS x resp <- Http.httpBS x
>>= ( \resp -> do let !statusCode = resp & Http.responseStatus & (.statusCode)
let !statusCode = resp & Http.responseStatus & (.statusCode) let !mContentType =
let !mContentType = resp
resp & Http.responseHeaders
& Http.responseHeaders & List.lookup "content-type"
& List.lookup "content-type" <&> parseContentType
<&> parseContentType <&> (\(!ct, _mimeAttributes) -> ct)
<&> (\(!ct, _mimeAttributes) -> ct)
let !bodyStrict = resp & Http.responseBody let !bodyStrict = resp & Http.responseBody
let !bodyLength = bodyStrict & ByteString.length let !bodyLength = bodyStrict & ByteString.length
if if
| statusCode == 200 -> do | statusCode == 200 -> do
let tagMatch prx1 val1 prx2 val2 = let tagMatch prx1 val1 prx2 val2 =
dat.isTag dat.isTag
& caseE2 & caseE2
( t2 ( t2
prx1 prx1
(\() -> val1) (\() -> val1)
prx2 prx2
(\() -> val2) (\() -> val2)
) )
pure mSourceMap <-
( -- hsx does not understand the `as` attr if
( Html.link | dat.provideSourceMap -> do
! HtmlA.rel "preload" inSpan' [fmt|Get Source Map for {dat.integrityName}|] $ \span' -> do
! HtmlA.href (Html.textValue dat.localPath) let sourceMapUrl = dat.integrityUrl <> ".map"
! Html.customAttribute let x' =
"as" sourceMapUrl
( tagMatch & Parse.runParse "Failed to parse URI" (textToURI >>> uriToHttpClientRequest)
#link & unwrapErrorTree
"style" resp' <- Http.httpBS x'
#script let !statusCode' = resp' & Http.responseStatus & (.statusCode)
"script" if
) | statusCode' == 200 -> do
) pure $ Just <$> resp' & Http.responseBody
<> ( tagMatch -- if it does not exist, let’s 404 as well
#link | statusCode' == 404 -> do
[hsx|<link rel="stylesheet" href={dat.localPath} integrity={dat.integrityHash} crossorigin="anonymous">|] pure Nothing
#script | otherwise -> do
[hsx|<script src={dat.localPath} integrity={dat.integrityHash} crossorigin="anonymous"></script>|] appThrow span' $ AppExceptionPretty [[fmt|Failed to fetch source map, got status code {statusCode'}|]]
), | otherwise -> pure Nothing
Plain $ pure
pure $ ( tagMatch
Wai.responseLBS #link
Http.ok200 [hsx|<link rel="stylesheet" href={dat.localPath} integrity={dat.integrityHash} crossorigin="anonymous">|]
[ ( "Content-Type", #script
mContentType [hsx|<script src={dat.localPath} integrity={dat.integrityHash} crossorigin="anonymous"></script>|],
& fromMaybe \(Arg giveSourceMap) -> Plain $ do
( tagMatch if
#script | giveSourceMap,
"text/javascript; charset=UTF-8" Just sourceMap <- mSourceMap -> do
#link pure $
"text/css; charset=UTF-8" Wai.responseLBS
) Http.ok200
), [ ( "Content-Type",
("Content-Length", buildBytes intDecimalB bodyLength) "application/json"
] ),
(toLazyBytes $ bodyStrict) ("Content-Length", buildBytes intDecimalB (ByteString.length sourceMap))
) ]
| code <- statusCode -> appThrow span $ AppExceptionPretty [[fmt|Server returned an non-200 error code, code {code}:|], pretty resp] (toLazyBytes sourceMap)
) | giveSourceMap -> do
pure $ Wai.responseLBS Http.notFound404 [] ""
| otherwise -> do
pure $
Wai.responseLBS
Http.ok200
[ ( "Content-Type",
mContentType
& fromMaybe
( tagMatch
#script
"text/javascript; charset=UTF-8"
#link
"text/css; charset=UTF-8"
)
),
("Content-Length", buildBytes intDecimalB bodyLength)
]
(toLazyBytes $ bodyStrict)
)
| code <- statusCode -> appThrow span $ AppExceptionPretty [[fmt|Server returned an non-200 error code, code {code}:|], pretty resp]
-- case-match on an e2 with a t2 that provides the relevant functions -- case-match on an e2 with a t2 that provides the relevant functions
caseE2 :: caseE2 ::
@ -1409,6 +1510,10 @@ t2 :: forall l1 t1 l2 t2. LabelPrx l1 -> t1 -> LabelPrx l2 -> t2 -> T2 l1 t1 l2
{-# INLINE t2 #-} {-# INLINE t2 #-}
t2 LabelPrx a LabelPrx b = T2 (label @l1 a) (label @l2 b) t2 LabelPrx a LabelPrx b = T2 (label @l1 a) (label @l2 b)
lbl :: forall l t. LabelPrx l -> t -> Label l t
{-# INLINE lbl #-}
lbl LabelPrx a = label @l a
data LabelPrx (l :: Symbol) = LabelPrx data LabelPrx (l :: Symbol) = LabelPrx
instance (l ~ l') => IsLabel l (LabelPrx l') where instance (l ~ l') => IsLabel l (LabelPrx l') where