diff options
Diffstat (limited to 'users/Profpatsch/whatcd-resolver/src/Redacted.hs')
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Redacted.hs | 221 |
1 files changed, 116 insertions, 105 deletions
diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index 4369c184087a..7bf9e8c2ce27 100644 --- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs +++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs @@ -3,6 +3,7 @@ module Redacted where import AppT +import Arg import Control.Monad.Logger.CallStack import Control.Monad.Reader import Data.Aeson qualified as Json @@ -11,14 +12,12 @@ import Data.Aeson.KeyMap qualified as KeyMap import Data.Error.Tree import Data.List qualified as List import Database.PostgreSQL.Simple (Binary (Binary), Only (..)) -import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple.Types (PGArray (PGArray)) import FieldParser qualified as Field +import Http qualified import Json qualified import Label import MyPrelude -import Network.HTTP.Client.Conduit qualified as Http -import Network.HTTP.Simple qualified as Http import Network.HTTP.Types import Network.Wai.Parse qualified as Wai import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan') @@ -26,11 +25,16 @@ import Optional import Postgres.Decoder qualified as Dec import Postgres.MonadPostgres import Pretty -import RunCommand (runCommandExpect0) import Prelude hiding (span) +class MonadRedacted m where + getRedactedApiKey :: m ByteString + +instance (MonadIO m) => MonadRedacted (AppT m) where + getRedactedApiKey = AppT (asks (.redactedApiKey)) + redactedSearch :: - (MonadLogger m, MonadThrow m, MonadOtel m) => + (MonadThrow m, MonadOtel m, MonadRedacted m) => [(ByteString, ByteString)] -> Json.Parse ErrorTree a -> m a @@ -47,7 +51,8 @@ redactedGetTorrentFile :: ( MonadLogger m, MonadThrow m, HasField "torrentId" dat Int, - MonadOtel m + MonadOtel m, + MonadRedacted m ) => dat -> m ByteString @@ -67,14 +72,10 @@ redactedGetTorrentFile dat = inSpan' "Redacted Get Torrent File" $ \span -> do ) httpTorrent span req --- fix --- ( \io -> do --- logInfo "delay" --- liftIO $ threadDelay 10_000_000 --- io --- ) +mkRedactedTorrentLink :: Arg "torrentGroupId" Int -> Text +mkRedactedTorrentLink torrentId = [fmt|https://redacted.ch/torrents.php?id={torrentId.unArg}|] -exampleSearch :: (MonadThrow m, MonadLogger m, MonadPostgres m, MonadOtel m) => m (Transaction m ()) +exampleSearch :: (MonadThrow m, MonadLogger m, MonadPostgres m, MonadOtel m, MonadRedacted m) => m (Transaction m ()) exampleSearch = do t1 <- redactedSearchAndInsert @@ -111,7 +112,8 @@ redactedSearchAndInsert :: ( MonadLogger m, MonadPostgres m, MonadThrow m, - MonadOtel m + MonadOtel m, + MonadRedacted m ) => [(ByteString, ByteString)] -> m (Transaction m ()) @@ -273,31 +275,35 @@ redactedSearchAndInsert extraArguments = do , torrent_id , full_json_result) |] - ( [ ( dat.torrentGroupIdPg :: Int, - group.torrentId :: Int, - group.fullJsonResult :: Json.Value - ) + ( [ T3 + (getLabel @"torrentGroupIdPg" dat) + (getLabel @"torrentId" group) + (getLabel @"fullJsonResult" group) | dat <- dats, group <- dat.torrents ] & unzip3PGArray + @"torrentGroupIdPg" + @Int + @"torrentId" + @Int + @"fullJsonResult" + @Json.Value ) pure () -unzip3PGArray :: [(a1, a2, a3)] -> (PGArray a1, PGArray a2, PGArray a3) -unzip3PGArray xs = xs & unzip3 & \(a, b, c) -> (PGArray a, PGArray b, PGArray c) - redactedGetTorrentFileAndInsert :: ( HasField "torrentId" r Int, MonadPostgres m, MonadThrow m, MonadLogger m, - MonadOtel m + MonadOtel m, + MonadRedacted m ) => r -> Transaction m (Label "torrentFile" ByteString) redactedGetTorrentFileAndInsert dat = inSpan' "Redacted Get Torrent File and Insert" $ \span -> do - bytes <- redactedGetTorrentFile dat + bytes <- lift $ redactedGetTorrentFile dat execute [sql| UPDATE redacted.torrents_json @@ -354,15 +360,21 @@ 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)|]) data TorrentData transmissionInfo = TorrentData { groupId :: Int, torrentId :: Int, seedingWeight :: Int, - torrentJson :: Json.Value, - torrentGroupJson :: T3 "artist" Text "groupName" Text "groupYear" Int, - torrentStatus :: TorrentStatus transmissionInfo + artists :: [T2 "artistId" Int "artistName" Text], + torrentGroupJson :: TorrentGroupJson, + torrentStatus :: TorrentStatus transmissionInfo, + torrentFormat :: Text + } + +data TorrentGroupJson = TorrentGroupJson + { groupName :: Text, + groupYear :: Natural } data TorrentStatus transmissionInfo @@ -381,42 +393,76 @@ getTorrentById dat = do (Dec.json Json.asValue) >>= ensureSingleRow +data GetBestTorrentsFilter = GetBestTorrentsFilter + { onlyDownloaded :: Bool, + onlyArtist :: Maybe (Label "artistRedactedId" Natural) + } + -- | Find the best torrent for each torrent group (based on the seeding_weight) -getBestTorrents :: (MonadPostgres m) => Transaction m [TorrentData ()] -getBestTorrents = do +getBestTorrents :: + (MonadPostgres m) => + GetBestTorrentsFilter -> + Transaction m [TorrentData ()] +getBestTorrents opts = do queryWith [sql| - SELECT * FROM ( - SELECT DISTINCT ON (group_id) - tg.group_id, - t.torrent_id, - seeding_weight, - t.full_json_result AS torrent_json, - tg.full_json_result AS torrent_group_json, - t.torrent_file IS NOT NULL, - t.transmission_torrent_hash - FROM redacted.torrents t - JOIN redacted.torrent_groups tg ON tg.id = t.torrent_group - ORDER BY group_id, seeding_weight DESC - ) as _ + WITH filtered_torrents AS ( + SELECT DISTINCT ON (torrent_group) + id + FROM + redacted.torrents + WHERE + -- onlyDownloaded + ((NOT ?::bool) OR torrent_file IS NOT NULL) + -- filter by artist id + AND + (?::bool OR (to_jsonb(?::int) <@ (jsonb_path_query_array(full_json_result, '$.artists[*].id')))) + ORDER BY + torrent_group, + -- prefer torrents which we already downloaded + torrent_file, + seeding_weight DESC + ) + SELECT + tg.group_id, + t.torrent_id, + t.seeding_weight, + t.full_json_result->'artists' AS artists, + tg.full_json_result->>'groupName' AS group_name, + tg.full_json_result->>'groupYear' AS group_year, + t.torrent_file IS NOT NULL AS has_torrent_file, + t.transmission_torrent_hash, + t.full_json_result->>'encoding' AS torrent_format + FROM filtered_torrents f + 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 |] - () + ( do + let (onlyArtistB, onlyArtistId) = case opts.onlyArtist of + Nothing -> (True, 0) + Just a -> (False, a.artistRedactedId) + ( opts.onlyDownloaded :: Bool, + onlyArtistB :: Bool, + onlyArtistId & fromIntegral @Natural @Int + ) + ) ( do groupId <- Dec.fromField @Int torrentId <- Dec.fromField @Int seedingWeight <- Dec.fromField @Int - torrentJson <- Dec.json Json.asValue - torrentGroupJson <- - ( Dec.json $ do - artist <- Json.keyLabel @"artist" "artist" Json.asText - groupName <- Json.keyLabel @"groupName" "groupName" Json.asText - groupYear <- Json.keyLabel @"groupYear" "groupYear" (Json.asIntegral @_ @Int) - pure $ T3 artist groupName groupYear - ) + artists <- Dec.json $ + Json.eachInArray $ do + id_ <- Json.keyLabel @"artistId" "id" (Json.asIntegral @_ @Int) + name <- Json.keyLabel @"artistName" "name" Json.asText + pure $ T2 id_ name + torrentGroupJson <- do + groupName <- Dec.text + groupYear <- Dec.textParse Field.decimalNatural + pure $ TorrentGroupJson {..} hasTorrentFile <- Dec.fromField @Bool - transmissionTorrentHash <- - Dec.fromField @(Maybe Text) + transmissionTorrentHash <- Dec.fromField @(Maybe Text) + torrentFormat <- Dec.text pure $ TorrentData { torrentStatus = @@ -426,6 +472,13 @@ getBestTorrents = do | Just hash <- transmissionTorrentHash -> InTransmission $ T2 (label @"torrentHash" hash) (label @"transmissionInfo" ()), + torrentFormat = case torrentFormat of + "Lossless" -> "flac" + "V0 (VBR)" -> "V0" + "V2 (VBR)" -> "V2" + "320" -> "320" + "256" -> "256" + o -> o, .. } ) @@ -433,15 +486,14 @@ getBestTorrents = do -- | Do a request to the redacted API. If you know what that is, you know how to find the API docs. mkRedactedApiRequest :: ( MonadThrow m, - MonadIO m, - MonadLogger m, HasField "action" p ByteString, - HasField "actionArgs" p [(ByteString, Maybe ByteString)] + HasField "actionArgs" p [(ByteString, Maybe ByteString)], + MonadRedacted m ) => p -> m Http.Request mkRedactedApiRequest dat = do - authKey <- runCommandExpect0 "pass" ["internet/redacted/api-keys/whatcd-resolver"] + authKey <- getRedactedApiKey pure $ [fmt|https://redacted.ch/ajax.php|] & Http.setRequestMethod "GET" @@ -460,73 +512,32 @@ httpTorrent span req = >>= assertM span ( \resp -> do - let statusCode = resp & Http.responseStatus & (.statusCode) + let statusCode = resp & Http.getResponseStatus & (.statusCode) contentType = resp - & Http.responseHeaders + & Http.getResponseHeaders & List.lookup "content-type" <&> Wai.parseContentType <&> (\(ct, _mimeAttributes) -> ct) if | statusCode == 200, Just "application/x-bittorrent" <- contentType -> - Right $ (resp & Http.responseBody) + Right $ (resp & Http.getResponseBody) | 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}|] - ) - -httpJson :: - ( MonadThrow m, - MonadOtel m - ) => - (Optional (Label "contentType" ByteString)) -> - Json.Parse ErrorTree b -> - Http.Request -> - m b -httpJson opts parser req = inSpan' "HTTP Request (JSON)" $ \span -> do - let opts' = opts.withDefault (label @"contentType" "application/json") - 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 ct <- contentType, - ct == opts'.contentType -> - Right $ (resp & Http.responseBody) - | statusCode == 200, - Just otherType <- contentType -> - Left [fmt|Server returned a non-json body, with content-type "{otherType}"|] - | statusCode == 200, - Nothing <- contentType -> - Left [fmt|Server returned a body with unspecified content type|] - | code <- statusCode -> Left [fmt|Server returned an non-200 error code, code {code}: {resp & showPretty}|] - ) - >>= assertM - span - ( \body -> - Json.parseStrict parser body - & first (Json.parseErrorTree "could not parse redacted response") + | code <- statusCode -> Left $ AppExceptionPretty [[fmt|Redacted returned an non-200 error code, code {code}|], pretty resp] ) redactedApiRequestJson :: ( MonadThrow m, - MonadLogger m, HasField "action" p ByteString, HasField "actionArgs" p [(ByteString, Maybe ByteString)], - MonadOtel m + MonadOtel m, + MonadRedacted m ) => p -> Json.Parse ErrorTree a -> @@ -534,4 +545,4 @@ redactedApiRequestJson :: redactedApiRequestJson dat parser = do mkRedactedApiRequest dat - >>= httpJson defaults parser + >>= Http.httpJson defaults parser |