diff options
Diffstat (limited to 'users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs')
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs | 298 |
1 files changed, 200 insertions, 98 deletions
diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index f1902bac8c..7b890fdd8f 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 @@ -36,7 +39,6 @@ import Network.HTTP.Types import Network.HTTP.Types qualified as Http import Network.URI (URI) import Network.URI qualified -import Network.URI qualified as URI import Network.Wai (ResponseReceived) import Network.Wai qualified as Wai import Network.Wai.Handler.Warp qualified as Warp @@ -55,7 +57,6 @@ import System.Directory qualified as Xdg import System.Environment qualified as Env import System.FilePath ((</>)) import Text.Blaze.Html (Html) -import Text.Blaze.Html.Renderer.Pretty qualified as Html.Pretty import Text.Blaze.Html.Renderer.Utf8 qualified as Html import Text.Blaze.Html5 qualified as Html import Tool (readTool, readTools) @@ -77,7 +78,6 @@ main = htmlUi :: AppT IO () htmlUi = do - let debug = True uniqueRunId <- runTransaction $ querySingleRowWith @@ -87,13 +87,13 @@ htmlUi = do () (Dec.fromField @Text) - withRunInIO $ \runInIO -> Warp.run 9093 $ \req respond -> do + withRunInIO $ \runInIO -> Warp.run 9093 $ \req respondOrig -> do let catchAppException act = try act >>= \case Right a -> pure a Left (AppException err) -> do runInIO (logError err) - respond (Wai.responseLBS Http.status500 [] "") + respondOrig (Wai.responseLBS Http.status500 [] "") catchAppException $ do let mp span parser = @@ -108,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 @@ -119,9 +116,9 @@ htmlUi = do let handlers :: Handlers (AppT IO) handlers respond = Map.fromList - [ ("", respond.h (mainHtml uniqueRunId)), + [ ("", respond.html (mainHtml uniqueRunId)), ( "snips/redacted/search", - respond.h $ + respond.html $ \span -> do dat <- mp @@ -132,12 +129,12 @@ htmlUi = do snipsRedactedSearch dat ), ( "snips/redacted/torrentDataJson", - respond.h $ \span -> do + respond.html $ \span -> do dat <- torrentIdMp span Html.mkVal <$> (runTransaction $ getTorrentById dat) ), ( "snips/redacted/getTorrentFile", - respond.h $ \span -> do + respond.html $ \span -> do dat <- torrentIdMp span runTransaction $ do inserted <- redactedGetTorrentFileAndInsert dat @@ -157,7 +154,7 @@ htmlUi = do ), -- TODO: this is bad duplication?? ( "snips/redacted/startTorrentFile", - respond.h $ \span -> do + respond.html $ \span -> do dat <- torrentIdMp span runTransaction $ do file <- @@ -180,7 +177,7 @@ htmlUi = do "Starting" ), ( "snips/transmission/getTorrentState", - respond.h $ \span -> do + respond.html $ \span -> do dat <- mp span $ label @"torrentHash" <$> Multipart.field "torrent-hash" Field.utf8 status <- doTransmissionRequest' @@ -199,17 +196,29 @@ htmlUi = do Just _torrent -> [hsx|Running|] ), ( "snips/jsonld/render", - respond.h $ \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", + do + let HandlerResponses {htmlWithQueryArgs} = respond + + htmlWithQueryArgs + ( label @"redactedId" + <$> (singleQueryArgument "redacted_id" (Field.utf8 >>> Field.decimalNatural)) + ) + $ \qry _span -> do + artistPage qry ), ( "autorefresh", respond.plain $ do @@ -233,29 +242,60 @@ htmlUi = do ] runInIO $ runHandlers - debug - (\respond -> respond.h $ (mainHtml uniqueRunId)) + (\respond -> respond.html $ (mainHtml uniqueRunId)) handlers req - respond + respondOrig 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 :: Text -> Otel.Span -> AppT IO Html mainHtml uniqueRunId _span = runTransaction $ do - jsonld <- - httpGetJsonLd - ( URI.parseURI "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" & annotate "not an URI" & unwrapError, - "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" - ) - <&> renderJsonld - bestTorrentsTable <- getBestTorrentsTable + -- jsonld <- + -- httpGetJsonLd + -- ( URI.parseURI "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" & annotate "not an URI" & unwrapError, + -- "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" + -- ) + -- <&> renderJsonld + bestTorrentsTable <- getBestTorrentsTable Nothing -- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable pure $ - Html.docTypeHtml + htmlPageChrome [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) => a -> Html +htmlPageChrome body = + Html.docTypeHtml $ + [hsx| <head> + <!-- TODO: set nice page title for each page --> <title>whatcd-resolver</title> <meta charset="utf-8"> <meta name="viewport" content="width=device-width, initial-scale=1"> @@ -271,73 +311,90 @@ htmlUi = do </style> </head> <body> - {jsonld} - <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 "redactedId" dat Natural, + MonadPostgres m, + MonadOtel m, + MonadLogger m, + MonadThrow m, + MonadTransmission m + ) => + dat -> + m Html +artistPage dat = runTransaction $ do + torrents <- getBestTorrentsTable (Just $ getLabel @"redactedId" dat) + pure $ + htmlPageChrome + [hsx| + Artist ID: {dat.redactedId} + + {torrents} + |] + type Handlers m = HandlerResponses m -> Map Text (m ResponseReceived) -type HandlerResponses m = T2 "h" ((Otel.Span -> m Html) -> m ResponseReceived) "plain" (m Wai.Response -> m ResponseReceived) +data HandlerResponses m = HandlerResponses + { -- | render html + 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) + } runHandlers :: (MonadOtel m) => - Bool -> (HandlerResponses m -> m ResponseReceived) -> (HandlerResponses m -> Map Text (m ResponseReceived)) -> Wai.Request -> (Wai.Response -> IO ResponseReceived) -> m ResponseReceived -runHandlers debug defaultHandler handlers req respond = withRunInIO $ \runInIO -> do - let renderHtml = - if debug - then Html.Pretty.renderHtml >>> stringToText >>> textToBytesUtf8 >>> toLazyBytes - else Html.renderHtml - let hh route act = +runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do + let path = req & Wai.pathInfo & Text.intercalate "/" + let html act = Otel.inSpan' - [fmt|Route {route }|] + [fmt|Route /{path}|] ( Otel.defaultSpanArguments { Otel.attributes = HashMap.fromList - [ ("server.path", Otel.toAttribute @Text route) + [ ("_.server.path", Otel.toAttribute @Text path), + ("_.server.query_args", Otel.toAttribute @Text (req.rawQueryString & bytesToTextUtf8Lenient)) ] } ) ( \span -> do - res <- act span - liftIO $ respond . Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . renderHtml $ res.html + 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 h route act = hh route (\span -> act span <&> (\html -> T2 (label @"html" html) (label @"extraHeaders" []))) - let path = (req & Wai.pathInfo & Text.intercalate "/") let handlerResponses = - ( T2 - (label @"h" (h path)) - (label @"plain" (\m -> liftIO $ runInIO m >>= respond)) + ( HandlerResponses + { plain = (\m -> liftIO $ runInIO m >>= respond), + 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 = (handlers handlerResponses) @@ -417,7 +474,11 @@ snipsRedactedSearch dat = do ] runTransaction $ do t - getBestTorrentsTable + getBestTorrentsTable (Nothing :: Maybe (Label "redactedId" Natural)) + +data ArtistFilter = ArtistFilter + { onlyArtist :: Maybe (Label "artistId" Text) + } getBestTorrentsTable :: ( MonadTransmission m, @@ -426,9 +487,10 @@ getBestTorrentsTable :: MonadPostgres m, MonadOtel m ) => + Maybe (Label "redactedId" Natural) -> Transaction m Html -getBestTorrentsTable = do - bestStale :: [TorrentData ()] <- getBestTorrents +getBestTorrentsTable artistFilter = do + bestStale :: [TorrentData ()] <- getBestTorrents GetBestTorrentsFilter {onlyArtist = artistFilter, onlyDownloaded = False} actual <- getAndUpdateTransmissionTorrentsStatus ( bestStale @@ -462,12 +524,28 @@ getBestTorrentsTable = do fresh & foldMap ( \b -> do + 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>{Html.toHtml @Text b.torrentGroupJson.artist}</td> - <td>{Html.toHtml @Text b.torrentGroupJson.groupName}</td> + <td> + {artists} + </td> + <td> + <a href={mkRedactedTorrentLink (Arg b.groupId)} target="_blank"> + {Html.toHtml @Text b.torrentGroupJson.groupName} + </a> + </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> @@ -482,6 +560,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> @@ -493,6 +572,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 @@ -556,35 +644,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)); |] @@ -624,7 +725,8 @@ httpTorrent span req = runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a) runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do - pgFormat <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format") + tool <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format") + pgFormat <- initPgFormatPool (label @"pgFormat" tool) let config = label @"logDatabaseQueries" LogDatabaseQueries pgConnPool <- Pool.newPool $ @@ -633,7 +735,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}|] |