diff options
Diffstat (limited to 'users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs')
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs | 322 |
1 files changed, 215 insertions, 107 deletions
diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index 1ec23e1fc7..73a9dccb12 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -3,6 +3,7 @@ module WhatcdResolver where import AppT +import Arg import Control.Category qualified as Cat import Control.Monad.Catch.Pure (runCatch) import Control.Monad.Logger.CallStack @@ -10,6 +11,7 @@ import Control.Monad.Reader import Data.Aeson qualified as Json import Data.Aeson.BetterErrors qualified as Json import Data.Aeson.KeyMap qualified as KeyMap +import Data.Error.Tree (prettyErrorTree) import Data.HashMap.Strict qualified as HashMap import Data.List qualified as List import Data.Map.Strict qualified as Map @@ -23,6 +25,7 @@ import FieldParser (FieldParser, FieldParser' (..)) import FieldParser qualified as Field import Html qualified import IHP.HSX.QQ (hsx) +import IHP.HSX.ToHtml (ToHtml) import Json qualified import Json.Enc (Enc) import Json.Enc qualified as Enc @@ -105,9 +108,6 @@ htmlUi = do ( do label @"torrentId" <$> Multipart.field "torrent-id" ((Field.utf8 >>> Field.signedDecimal >>> Field.bounded @Int "int")) ) - let parseQueryArgs span parser = - 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 @@ -196,27 +196,29 @@ htmlUi = do Just _torrent -> [hsx|Running|] ), ( "snips/jsonld/render", - respond.html $ \span -> do - qry <- - parseQueryArgs - span - ( label @"target" - <$> ( (singleQueryArgument "target" Field.utf8 >>> textToURI) - & Parse.andParse uriToHttpClientRequest - ) - ) - jsonld <- httpGetJsonLd (qry.target) - pure $ renderJsonld jsonld + do + let HandlerResponses {htmlWithQueryArgs} = respond + htmlWithQueryArgs + ( label @"target" + <$> ( (singleQueryArgument "target" Field.utf8 >>> textToURI) + & Parse.andParse uriToHttpClientRequest + ) + ) + ( \qry _span -> do + jsonld <- httpGetJsonLd (qry.target) + pure $ renderJsonld jsonld + ) ), ( "artist", - respond.html $ \span -> do - qry <- - parseQueryArgs - span - ( label @"dbId" - <$> (singleQueryArgument "db_id" Field.utf8) - ) - artistPage qry + do + let HandlerResponses {htmlWithQueryArgs} = respond + + htmlWithQueryArgs + ( label @"artistRedactedId" + <$> (singleQueryArgument "redacted_id" (Field.utf8 >>> Field.decimalNatural)) + ) + $ \qry _span -> do + artistPage qry ), ( "autorefresh", respond.plain $ do @@ -256,13 +258,46 @@ htmlUi = do -- "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" -- ) -- <&> renderJsonld - bestTorrentsTable <- getBestTorrentsTable + bestTorrentsTable <- getBestTorrentsTable Nothing -- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable pure $ - Html.docTypeHtml + htmlPageChrome + "whatcd-resolver" [hsx| + <form + hx-post="/snips/redacted/search" + hx-target="#redacted-search-results"> + <label for="redacted-search">Redacted Search</label> + <input + id="redacted-search" + type="text" + name="redacted-search" /> + <button type="submit" hx-disabled-elt="this">Search</button> + <div class="htmx-indicator">Search running!</div> + </form> + <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" + /> + |] + +htmlPageChrome :: (ToHtml a) => Text -> a -> Html +htmlPageChrome title body = + Html.docTypeHtml $ + [hsx| <head> - <title>whatcd-resolver</title> + <!-- TODO: set nice page title for each page --> + <title>{title}</title> <meta charset="utf-8"> <meta name="viewport" content="width=device-width, initial-scale=1"> <link href="https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/css/bootstrap.min.css" rel="stylesheet" integrity="sha384-9ndCyUaIbzAi2FUVXJi0CjmCapSmO7SnpJef0486qhLnuZ2cdeRhO02iuK6FUUVM" crossorigin="anonymous"> @@ -277,46 +312,43 @@ htmlUi = do </style> </head> <body> - <form - hx-post="/snips/redacted/search" - hx-target="#redacted-search-results"> - <label for="redacted-search">Redacted Search</label> - <input - id="redacted-search" - type="text" - name="redacted-search" /> - <button type="submit" hx-disabled-elt="this">Search</button> - <div class="htmx-indicator">Search running!</div> - </form> - <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} </body> |] -artistPage :: (HasField "dbId" dat Text, Applicative m) => dat -> m Html -artistPage dat = do - pure - [hsx| - Artist ID: {dat.dbId} - |] +artistPage :: + ( HasField "artistRedactedId" dat Natural, + MonadPostgres m, + MonadOtel m, + MonadLogger m, + MonadThrow m, + MonadTransmission m + ) => + dat -> + m Html +artistPage dat = runTransaction $ do + fresh <- getBestTorrentsData (Just $ getLabel @"artistRedactedId" dat) + 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 fresh + pure $ + htmlPageChrome + ( case artistName of + Nothing -> "whatcd-resolver" + Just a -> [fmt|{a} - Artist Page - whatcd-resolver|] + ) + [hsx| + Artist ID: {dat.artistRedactedId} + + {torrents} + |] type Handlers m = HandlerResponses m -> Map Text (m ResponseReceived) data HandlerResponses m = HandlerResponses { -- | render html - html :: ((Otel.Span -> m Html) -> m ResponseReceived), + html :: (Otel.Span -> m Html) -> m ResponseReceived, + -- | render html after parsing some query arguments + htmlWithQueryArgs :: forall a. (Parse Query a -> (a -> Otel.Span -> m Html) -> m ResponseReceived), -- | render a plain wai response plain :: (m Wai.Response -> m ResponseReceived) } @@ -330,23 +362,45 @@ runHandlers :: m ResponseReceived runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do let path = req & Wai.pathInfo & Text.intercalate "/" + let html act = + Otel.inSpan' + [fmt|Route /{path}|] + ( Otel.defaultSpanArguments + { Otel.attributes = + HashMap.fromList + [ ("_.server.path", Otel.toAttribute @Text path), + ("_.server.query_args", Otel.toAttribute @Text (req.rawQueryString & bytesToTextUtf8Lenient)) + ] + } + ) + ( \span -> do + res <- act span <&> (\h -> T2 (label @"html" h) (label @"extraHeaders" [])) + liftIO $ respond . Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . Html.renderHtml $ res.html + ) + let handlerResponses = ( HandlerResponses { plain = (\m -> liftIO $ runInIO m >>= respond), - html = \act -> - Otel.inSpan' - [fmt|Route /{path}|] - ( Otel.defaultSpanArguments - { Otel.attributes = - HashMap.fromList - [ ("server.path", Otel.toAttribute @Text path) - ] - } - ) - ( \span -> do - res <- act span <&> (\html -> T2 (label @"html" html) (label @"extraHeaders" [])) - liftIO $ respond . Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . Html.renderHtml $ res.html - ) + html, + htmlWithQueryArgs = \parser act -> + case req & Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) of + Right a -> html (act a) + Left err -> + html + ( \span -> do + recordException + span + ( T2 + (label @"type_" "Query Parse Exception") + (label @"message" (prettyErrorTree err)) + ) + + pure + [hsx| + <h1>Error:</h1> + <pre>{err & prettyErrorTree}</pre> + |] + ) } ) let handler = @@ -427,7 +481,11 @@ snipsRedactedSearch dat = do ] runTransaction $ do t - getBestTorrentsTable + getBestTorrentsTable (Nothing :: Maybe (Label "artistRedactedId" Natural)) + +data ArtistFilter = ArtistFilter + { onlyArtist :: Maybe (Label "artistId" Text) + } getBestTorrentsTable :: ( MonadTransmission m, @@ -436,9 +494,23 @@ getBestTorrentsTable :: MonadPostgres m, MonadOtel m ) => + Maybe (Label "artistRedactedId" Natural) -> Transaction m Html -getBestTorrentsTable = do - bestStale :: [TorrentData ()] <- getBestTorrents (label @"onlyDownloaded" False) +getBestTorrentsTable dat = do + fresh <- getBestTorrentsData dat + pure $ mkBestTorrentsTable fresh + +getBestTorrentsData :: + ( MonadTransmission m, + MonadThrow m, + MonadLogger m, + MonadPostgres m, + MonadOtel m + ) => + Maybe (Label "artistRedactedId" Natural) -> + Transaction m [TorrentData (Label "percentDone" Percentage)] +getBestTorrentsData artistFilter = do + bestStale :: [TorrentData ()] <- getBestTorrents GetBestTorrentsFilter {onlyArtist = artistFilter, onlyDownloaded = False} actual <- getAndUpdateTransmissionTorrentsStatus ( bestStale @@ -450,20 +522,23 @@ getBestTorrentsTable = do <&> (\t -> (getLabel @"torrentHash" t, t.transmissionInfo)) & Map.fromList ) - let fresh = - bestStale - -- we have to update the status of every torrent that’s not in tranmission anymore - -- TODO I feel like it’s easier (& more correct?) to just do the database request again … - <&> ( \td -> case td.torrentStatus of - InTransmission info -> - case actual & Map.lookup (getLabel @"torrentHash" info) of - -- TODO this is also pretty dumb, cause it assumes that we have the torrent file if it was in transmission before, - -- which is an internal factum that is established in getBestTorrents (and might change later) - Nothing -> td {torrentStatus = NotInTransmissionYet} - Just transmissionInfo -> td {torrentStatus = InTransmission (T2 (getLabel @"torrentHash" info) (label @"transmissionInfo" transmissionInfo))} - NotInTransmissionYet -> td {torrentStatus = NotInTransmissionYet} - NoTorrentFileYet -> td {torrentStatus = NoTorrentFileYet} - ) + pure $ + bestStale + -- we have to update the status of every torrent that’s not in tranmission anymore + -- TODO I feel like it’s easier (& more correct?) to just do the database request again … + <&> ( \td -> case td.torrentStatus of + InTransmission info -> + case actual & Map.lookup (getLabel @"torrentHash" info) of + -- TODO this is also pretty dumb, cause it assumes that we have the torrent file if it was in transmission before, + -- which is an internal factum that is established in getBestTorrents (and might change later) + Nothing -> td {torrentStatus = NotInTransmissionYet} + Just transmissionInfo -> td {torrentStatus = InTransmission (T2 (getLabel @"torrentHash" info) (label @"transmissionInfo" transmissionInfo))} + NotInTransmissionYet -> td {torrentStatus = NotInTransmissionYet} + NoTorrentFileYet -> td {torrentStatus = NoTorrentFileYet} + ) + +mkBestTorrentsTable :: [TorrentData (Label "percentDone" Percentage)] -> Html +mkBestTorrentsTable fresh = do let localTorrent b = case b.torrentStatus of NoTorrentFileYet -> [hsx|<button hx-post="snips/redacted/getTorrentFile" hx-swap="outerHTML" hx-vals={Enc.encToBytesUtf8 $ Enc.object [("torrent-id", Enc.int b.torrentId)]}>Upload Torrent</button>|] InTransmission info -> [hsx|{info.transmissionInfo.percentDone.unPercentage}% done|] @@ -472,24 +547,34 @@ getBestTorrentsTable = do fresh & foldMap ( \b -> do - let artistLink :: Text = [fmt|/artist?db_id={b.groupId}|] + let artists = + b.artists + <&> ( \a -> + T2 + (label @"url" [fmt|/artist?redacted_id={a.artistId}|]) + (label @"content" $ Html.toHtml @Text a.artistName) + ) + & mkLinkList + [hsx| <tr> <td>{localTorrent b}</td> <td>{Html.toHtml @Int b.groupId}</td> <td> - <a href={artistLink}> - {Html.toHtml @Text b.torrentGroupJson.artist} + {artists} + </td> + <td> + <a href={mkRedactedTorrentLink (Arg b.groupId)} target="_blank"> + {Html.toHtml @Text b.torrentGroupJson.groupName} </a> </td> - <td>{Html.toHtml @Text b.torrentGroupJson.groupName}</td> + <td>{Html.toHtml @Int b.torrentGroupJson.groupYear}</td> <td>{Html.toHtml @Int b.seedingWeight}</td> <td><details hx-trigger="toggle once" hx-post="snips/redacted/torrentDataJson" hx-vals={Enc.encToBytesUtf8 $ Enc.object [("torrent-id", Enc.int b.torrentId)]}></details></td> </tr> |] ) - pure $ - [hsx| + [hsx| <table class="table"> <thead> <tr> @@ -497,6 +582,7 @@ getBestTorrentsTable = do <th>Group ID</th> <th>Artist</th> <th>Name</th> + <th>Year</th> <th>Weight</th> <th>Torrent</th> <th>Torrent Group</th> @@ -508,6 +594,15 @@ getBestTorrentsTable = do </table> |] +mkLinkList :: [T2 "url" Text "content" Html] -> Html +mkLinkList xs = + xs + <&> ( \x -> do + [hsx|<a href={x.url}>{x.content}</a>|] + ) + & List.intersperse ", " + & mconcat + getTransmissionTorrentsTable :: (MonadTransmission m, MonadThrow m, MonadLogger m, MonadOtel m) => m Html getTransmissionTorrentsTable = do @@ -571,35 +666,48 @@ migrate = inSpan "Database Migration" $ do UNIQUE(torrent_id) ); + CREATE INDEX IF NOT EXISTS redacted_torrents_json_torrent_group_fk ON redacted.torrents_json (torrent_group); + + ALTER TABLE redacted.torrents_json ADD COLUMN IF NOT EXISTS torrent_file bytea NULL; ALTER TABLE redacted.torrents_json ADD COLUMN IF NOT EXISTS transmission_torrent_hash text NULL; - -- inflect out values of the full json + -- the seeding weight is used to find the best torrent in a group. + CREATE OR REPLACE FUNCTION calc_seeding_weight(full_json_result jsonb) RETURNS int AS $$ + BEGIN + RETURN + ((full_json_result->'seeders')::integer*3 + + (full_json_result->'snatches')::integer + ) + -- prefer remasters by multiplying them with 3 + * (CASE + WHEN full_json_result->>'remasterTitle' ILIKE '%remaster%' + THEN 3 + ELSE 1 + END); + END; + $$ LANGUAGE plpgsql IMMUTABLE; + + ALTER TABLE redacted.torrents_json + ADD COLUMN IF NOT EXISTS seeding_weight int GENERATED ALWAYS AS (calc_seeding_weight(full_json_result)) STORED; + + -- inflect out values of the full json CREATE OR REPLACE VIEW redacted.torrents AS SELECT t.id, t.torrent_id, t.torrent_group, -- the seeding weight is used to find the best torrent in a group. - ( ((full_json_result->'seeders')::integer*3 - + (full_json_result->'snatches')::integer - ) - -- prefer remasters by multiplying them with 3 - * (CASE - WHEN full_json_result->>'remasterTitle' ILIKE '%remaster%' - THEN 3 - ELSE 1 - END) - ) - AS seeding_weight, + t.seeding_weight, t.full_json_result, t.torrent_file, t.transmission_torrent_hash FROM redacted.torrents_json t; + CREATE INDEX IF NOT EXISTS torrents_json_seeding ON redacted.torrents_json(((full_json_result->'seeding')::integer)); CREATE INDEX IF NOT EXISTS torrents_json_snatches ON redacted.torrents_json(((full_json_result->'snatches')::integer)); |] @@ -649,7 +757,7 @@ runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do {- resource destruction -} Postgres.close {- unusedResourceOpenTime -} 10 {- max resources across all stripes -} 20 - transmissionSessionId <- newEmptyMVar + transmissionSessionId <- newIORef Nothing let newAppT = do logInfo [fmt|Running with config: {showPretty config}|] logInfo [fmt|Connected to database at {db & TmpPg.toDataDirectory} on socket {db & TmpPg.toConnectionString}|] |