diff options
Diffstat (limited to 'users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs')
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs | 207 |
1 files changed, 146 insertions, 61 deletions
diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index 73a9dccb12ac..c8850e70a121 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE QuasiQuotes #-} module WhatcdResolver where @@ -11,14 +12,13 @@ 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.Error.Tree import Data.HashMap.Strict qualified as HashMap import Data.List qualified as List import Data.Map.Strict qualified as Map import Data.Pool qualified as Pool import Data.Text qualified as Text import Database.PostgreSQL.Simple qualified as Postgres -import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple.Types (PGArray (PGArray)) import Database.Postgres.Temp qualified as TmpPg import FieldParser (FieldParser, FieldParser' (..)) @@ -42,7 +42,6 @@ import Network.URI qualified import Network.Wai (ResponseReceived) import Network.Wai qualified as Wai import Network.Wai.Handler.Warp qualified as Warp -import Network.Wai.Parse qualified as Wai import OpenTelemetry.Attributes qualified as Otel import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan') import OpenTelemetry.Trace.Monad qualified as Otel @@ -52,6 +51,7 @@ import Postgres.Decoder qualified as Dec import Postgres.MonadPostgres import Pretty import Redacted +import RunCommand (runCommandExpect0) import System.Directory qualified as Dir import System.Directory qualified as Xdg import System.Environment qualified as Env @@ -91,14 +91,17 @@ htmlUi = do let catchAppException act = try act >>= \case Right a -> pure a - Left (AppException err) -> do - runInIO (logError err) + Left (AppExceptionTree err) -> do + runInIO (logError (prettyErrorTree err)) + respondOrig (Wai.responseLBS Http.status500 [] "") + Left (AppExceptionPretty err) -> do + runInIO (logError (err & Pretty.prettyErrsNoColor & stringToText)) respondOrig (Wai.responseLBS Http.status500 [] "") catchAppException $ do let mp span parser = Multipart.parseMultipartOrThrow - (appThrowTree span) + (appThrow span . AppExceptionTree) parser req @@ -111,7 +114,7 @@ htmlUi = do let parseQueryArgsNewSpan spanName parser = Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) req - & assertMNewSpan spanName id + & assertMNewSpan spanName (first AppExceptionTree) let handlers :: Handlers (AppT IO) handlers respond = @@ -134,7 +137,7 @@ htmlUi = do Html.mkVal <$> (runTransaction $ getTorrentById dat) ), ( "snips/redacted/getTorrentFile", - respond.html $ \span -> do + respond.htmlOrReferer $ \span -> do dat <- torrentIdMp span runTransaction $ do inserted <- redactedGetTorrentFileAndInsert dat @@ -160,7 +163,7 @@ htmlUi = do file <- getTorrentFileById dat <&> annotate [fmt|No torrent file for torrentId "{dat.torrentId}"|] - >>= orAppThrowTree span + >>= orAppThrow span running <- lift @Transaction $ @@ -291,6 +294,17 @@ htmlUi = do /> |] +-- | Reload the current page (via the Referer header) if the browser has Javascript disabled (and thus htmx does not work). This should make post requests work out of the box. +htmxOrReferer :: Wai.Request -> Wai.Response -> Wai.Response +htmxOrReferer req act = do + let fnd h = req & Wai.requestHeaders & List.find (\(hdr, _) -> hdr == h) + let referer = fnd "Referer" + if + | Just _ <- fnd "Hx-Request" -> act + | Nothing <- referer -> act + | Just (_, rfr) <- referer -> do + Wai.responseLBS seeOther303 [("Location", rfr)] "" + htmlPageChrome :: (ToHtml a) => Text -> a -> Html htmlPageChrome title body = Html.docTypeHtml $ @@ -300,6 +314,12 @@ htmlPageChrome title body = <title>{title}</title> <meta charset="utf-8"> <meta name="viewport" content="width=device-width, initial-scale=1"> + <!-- + prevent favicon request, based on answers in + https://stackoverflow.com/questions/1321878/how-to-prevent-favicon-ico-requests + TODO: create favicon + --> + <link rel="icon" href="data:,"> <link href="https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/css/bootstrap.min.css" rel="stylesheet" integrity="sha384-9ndCyUaIbzAi2FUVXJi0CjmCapSmO7SnpJef0486qhLnuZ2cdeRhO02iuK6FUUVM" crossorigin="anonymous"> <script src="https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/js/bootstrap.bundle.min.js" integrity="sha384-geWF76RCwLtnZ8qwWowPQNguL3RmwHVBC9FhGdlKrxdiJJigb/j/68SIy3Te4Bkz" crossorigin="anonymous"></script> <script src="https://unpkg.com/htmx.org@1.9.2" integrity="sha384-L6OqL9pRWyyFU3+/bjdSri+iIphTN/bvYyM37tICVyOJkWZLpP2vGn6VUEXgzg6h" crossorigin="anonymous"></script> @@ -349,6 +369,8 @@ data HandlerResponses m = HandlerResponses 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 html or reload the page via the Referer header if no htmx + htmlOrReferer :: (Otel.Span -> m Html) -> m ResponseReceived, -- | render a plain wai response plain :: (m Wai.Response -> m ResponseReceived) } @@ -362,7 +384,7 @@ runHandlers :: m ResponseReceived runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do let path = req & Wai.pathInfo & Text.intercalate "/" - let html act = + let html' resp act = Otel.inSpan' [fmt|Route /{path}|] ( Otel.defaultSpanArguments @@ -375,8 +397,12 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do ) ( \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 + addEventSimple span "Got Html result, rendering…" + liftIO $ respond (resp res) ) + let htmlResp res = Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . Html.renderHtml $ res.html + let html = html' htmlResp + let htmlOrReferer = html' $ \res -> htmxOrReferer req (htmlResp res) let handlerResponses = ( HandlerResponses @@ -400,7 +426,8 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do <h1>Error:</h1> <pre>{err & prettyErrorTree}</pre> |] - ) + ), + htmlOrReferer } ) let handler = @@ -427,6 +454,24 @@ singleQueryArgument field inner = ) >>> Parse.fieldParser inner +singleQueryArgumentMay :: Text -> FieldParser ByteString to -> Parse Http.Query (Maybe to) +singleQueryArgumentMay field inner = + Parse.mkParsePushContext + field + ( \(ctx, qry) -> case qry + & mapMaybe + ( \(k, v) -> + if k == (field & textToBytesUtf8) + then Just v + else Nothing + ) of + [] -> Right Nothing + [Nothing] -> Left [fmt|Expected one query argument with a value, but "{field}" was a query flag|] + [Just one] -> Right (Just one) + more -> Left [fmt|More than one value for query argument "{field}": {show more}, at {ctx & Parse.showContext}|] + ) + >>> Parse.maybe (Parse.fieldParser inner) + -- | Make sure we can parse the given Text into an URI. textToURI :: Parse Text URI textToURI = @@ -469,7 +514,8 @@ snipsRedactedSearch :: HasField "searchstr" r ByteString, MonadThrow m, MonadTransmission m, - MonadOtel m + MonadOtel m, + MonadRedacted m ) => r -> m Html @@ -500,6 +546,9 @@ getBestTorrentsTable dat = do fresh <- getBestTorrentsData dat pure $ mkBestTorrentsTable fresh +doIfJust :: (Applicative f) => (a -> f ()) -> Maybe a -> f () +doIfJust = traverse_ + getBestTorrentsData :: ( MonadTransmission m, MonadThrow m, @@ -509,26 +558,38 @@ getBestTorrentsData :: ) => Maybe (Label "artistRedactedId" Natural) -> Transaction m [TorrentData (Label "percentDone" Percentage)] -getBestTorrentsData artistFilter = do - bestStale :: [TorrentData ()] <- getBestTorrents GetBestTorrentsFilter {onlyArtist = artistFilter, onlyDownloaded = False} - actual <- +getBestTorrentsData artistFilter = inSpan' "get torrents table data" $ \span -> do + artistFilter & doIfJust (\a -> addAttribute span "artist-filter.redacted-id" (a.artistRedactedId & showToText & Otel.toAttribute)) + let getBest = getBestTorrents GetBestTorrentsFilter {onlyArtist = artistFilter, onlyDownloaded = False} + bestStale :: [TorrentData ()] <- getBest + (statusInfo, transmissionStatus) <- getAndUpdateTransmissionTorrentsStatus ( bestStale & mapMaybe ( \td -> case td.torrentStatus of - InTransmission h -> Just h + InTransmission h -> Just (getLabel @"torrentHash" h, td) _ -> Nothing ) - <&> (\t -> (getLabel @"torrentHash" t, t.transmissionInfo)) & Map.fromList ) + bestBest <- + -- Instead of serving a stale table when a torrent gets deleted, fetch + -- the whole view again. This is a little wasteful, but torrents + -- shouldn’t get deleted very often, so it’s fine. + -- Re-evaluate invariant if this happens too often. + if statusInfo.knownTorrentsStale + then inSpan' "Fetch torrents table data again" $ + \span' -> do + addEventSimple span' "The transmission torrent list was out of date, refetching torrent list." + getBest + else pure bestStale pure $ - bestStale + bestBest -- 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 + case transmissionStatus & 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} @@ -540,7 +601,17 @@ getBestTorrentsData artistFilter = do 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>|] + NoTorrentFileYet -> + [hsx| + <form method="post"> + <input type="hidden" name="torrent-id" value={b.torrentId & show} /> + <button + formaction="snips/redacted/getTorrentFile" + hx-post="snips/redacted/getTorrentFile" + hx-swap="outerHTML" + hx-vals={Enc.encToBytesUtf8 $ Enc.object [("torrent-id", Enc.int b.torrentId)]}>Upload Torrent</button> + </form> + |] InTransmission info -> [hsx|{info.transmissionInfo.percentDone.unPercentage}% done|] NotInTransmissionYet -> [hsx|<button hx-post="snips/redacted/startTorrentFile" hx-swap="outerHTML" hx-vals={Enc.encToBytesUtf8 $ Enc.object [("torrent-id", Enc.int b.torrentId)]}>Start Torrent</button>|] let bestRows = @@ -568,8 +639,9 @@ mkBestTorrentsTable fresh = do {Html.toHtml @Text b.torrentGroupJson.groupName} </a> </td> - <td>{Html.toHtml @Int b.torrentGroupJson.groupYear}</td> + <td>{Html.toHtml @Natural b.torrentGroupJson.groupYear}</td> <td>{Html.toHtml @Int b.seedingWeight}</td> + <td>{Html.toHtml @Text b.torrentFormat}</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> |] @@ -584,8 +656,8 @@ mkBestTorrentsTable fresh = do <th>Name</th> <th>Year</th> <th>Weight</th> + <th>Format</th> <th>Torrent</th> - <th>Torrent Group</th> </tr> </thead> <tbody> @@ -638,7 +710,7 @@ assertOneUpdated :: m () assertOneUpdated span name x = case x.numberOfRowsAffected of 1 -> pure () - n -> appThrowTree span ([fmt|{name :: Text}: Expected to update exactly one row, but updated {n :: Natural} row(s)|]) + n -> appThrow span ([fmt|{name :: Text}: Expected to update exactly one row, but updated {n :: Natural} row(s)|]) migrate :: ( MonadPostgres m, @@ -679,7 +751,8 @@ migrate = inSpan "Database Migration" $ do CREATE OR REPLACE FUNCTION calc_seeding_weight(full_json_result jsonb) RETURNS int AS $$ BEGIN RETURN - ((full_json_result->'seeders')::integer*3 + -- three times seeders plus one times snatches + (3 * (full_json_result->'seeders')::integer + (full_json_result->'snatches')::integer ) -- prefer remasters by multiplying them with 3 @@ -687,7 +760,26 @@ migrate = inSpan "Database Migration" $ do WHEN full_json_result->>'remasterTitle' ILIKE '%remaster%' THEN 3 ELSE 1 - END); + END) + -- slightly push mp3 V0, to make sure it’s preferred over 320 CBR + * (CASE + WHEN full_json_result->>'encoding' ILIKE '%v0%' + THEN 2 + ELSE 1 + END) + -- remove 24bit torrents from the result (wayyy too big) + * (CASE + WHEN full_json_result->>'encoding' ILIKE '%24bit%' + THEN 0 + ELSE 1 + END) + -- discount FLACS, so we only use them when there’s no mp3 alternative (to save space) + / (CASE + WHEN full_json_result->>'encoding' ILIKE '%lossless%' + THEN 5 + ELSE 1 + END) + ; END; $$ LANGUAGE plpgsql IMMUTABLE; @@ -713,43 +805,19 @@ migrate = inSpan "Database Migration" $ do |] () -httpTorrent :: - ( MonadIO m, - MonadThrow m - ) => - Otel.Span -> - Http.Request -> - m ByteString -httpTorrent span req = - Http.httpBS req - >>= assertM - span - ( \resp -> do - let statusCode = resp & Http.responseStatus & (.statusCode) - contentType = - resp - & Http.responseHeaders - & List.lookup "content-type" - <&> Wai.parseContentType - <&> (\(ct, _mimeAttributes) -> ct) - if - | statusCode == 200, - Just "application/x-bittorrent" <- contentType -> - Right $ (resp & Http.responseBody) - | statusCode == 200, - Just otherType <- contentType -> - Left [fmt|Redacted returned a non-torrent body, with content-type "{otherType}"|] - | statusCode == 200, - Nothing <- contentType -> - Left [fmt|Redacted returned a body with unspecified content type|] - | code <- statusCode -> Left [fmt|Redacted returned an non-200 error code, code {code}: {resp & showPretty}|] - ) - runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a) runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do tool <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format") - pgFormat <- initPgFormatPool (label @"pgFormat" tool) - let config = label @"logDatabaseQueries" LogDatabaseQueries + prettyPrintDatabaseQueries <- + Env.lookupEnv "WHATCD_RESOLVER_PRETTY_PRINT_DATABASE_QUERIES" >>= \case + Nothing -> pure DontPrettyPrintDatabaseQueries + Just _ -> do + pgFormat <- initPgFormatPool (label @"pgFormat" tool) + pure $ PrettyPrintDatabaseQueries pgFormat + let pgConfig = + T2 + (label @"logDatabaseQueries" LogDatabaseQueries) + (label @"prettyPrintDatabaseQueries" prettyPrintDatabaseQueries) pgConnPool <- Pool.newPool $ Pool.defaultPoolConfig @@ -758,11 +826,28 @@ runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do {- unusedResourceOpenTime -} 10 {- max resources across all stripes -} 20 transmissionSessionId <- newIORef Nothing + redactedApiKey <- + Env.lookupEnv "WHATCD_RESOLVER_REDACTED_API_KEY" >>= \case + Just k -> pure (k & stringToBytesUtf8) + Nothing -> runStderrLoggingT $ do + logInfo "WHATCD_RESOLVER_REDACTED_API_KEY was not set, trying pass" + runCommandExpect0 "pass" ["internet/redacted/api-keys/whatcd-resolver"] let newAppT = do - logInfo [fmt|Running with config: {showPretty config}|] + logInfo [fmt|Running with config: {showPretty pgConfig}|] logInfo [fmt|Connected to database at {db & TmpPg.toDataDirectory} on socket {db & TmpPg.toConnectionString}|] appT runReaderT newAppT.unAppT Context {..} + `catch` ( \case + AppExceptionPretty p -> throwM $ EscapedException (p & Pretty.prettyErrs) + AppExceptionTree t -> throwM $ EscapedException (t & prettyErrorTree & textToString) + ) + +-- | Just a silly wrapper so that correctly format any 'AppException' that would escape the runAppWith scope. +newtype EscapedException = EscapedException String + deriving anyclass (Exception) + +instance Show EscapedException where + show (EscapedException s) = s withTracer :: (Otel.Tracer -> IO c) -> IO c withTracer f = do |