{-# LANGUAGE QuasiQuotes #-} module Redacted where import AppT import Arg import Bencode import Builder import Comparison import Control.Monad.Logger.CallStack import Control.Monad.Reader import Data.Aeson qualified as Json import Data.Aeson.BetterErrors qualified as Json import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap import Data.BEncode (BEncode) import Data.Error.Tree import Data.List qualified as List import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe (catMaybes) import Data.Text.IO qualified as Text.IO import Data.Time (NominalDiffTime, UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Database.PostgreSQL.Simple (Binary (Binary), Only (..)) 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.Types import Network.Wai.Parse qualified as Wai import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan') import Optional import Parse (Parse, mapLookup, mapLookupMay, runParse) import Parse qualified import Postgres.Decoder qualified as Dec import Postgres.MonadPostgres import Pretty import Prelude hiding (length, span) class MonadRedacted m where getRedactedApiKey :: m ByteString instance (MonadIO m) => MonadRedacted (AppT m) where getRedactedApiKey = AppT (asks (.redactedApiKey)) redactedSearch :: ( MonadThrow m, MonadOtel m, MonadRedacted m, HasField "actionArgs" extraArguments [(ByteString, ByteString)], HasField "page" dat (Maybe Natural) ) => extraArguments -> dat -> Json.Parse ErrorTree a -> m a redactedSearch extraArguments dat parser = inSpan' "Redacted API Search" $ \span -> redactedPagedRequest span ( T3 (label @"action" "browse") (getLabel @"actionArgs" extraArguments) (getLabel @"page" dat) ) parser redactedGetArtist :: ( MonadOtel m, MonadThrow m, MonadRedacted m, HasField "artistId" r Int, HasField "page" r (Maybe Natural) ) => r -> Json.Parse ErrorTree a -> m a redactedGetArtist dat parser = inSpan' "Redacted Get Artist" $ \span -> do redactedPagedRequest span ( T3 (label @"action" "artist") (label @"actionArgs" [("id", buildBytes intDecimalB dat.artistId)]) (getLabel @"page" dat) ) parser redactedPagedRequest :: ( MonadThrow m, MonadOtel m, MonadRedacted m, HasField "action" dat ByteString, HasField "actionArgs" dat [(ByteString, ByteString)], HasField "page" dat (Maybe Natural) ) => Otel.Span -> dat -> Json.Parse ErrorTree a -> m a redactedPagedRequest span dat parser = redactedApiRequestJson span ( T2 (label @"action" dat.action) ( label @"actionArgs" $ (dat.actionArgs <&> second Just) <> ( dat.page & ifExists (\page -> ("page", Just $ buildBytes naturalDecimalB page)) ) ) ) parser redactedGetTorrentFile :: ( MonadLogger m, MonadThrow m, HasField "torrentId" dat Int, HasField "useFreeleechTokens" dat Bool, MonadOtel m, MonadRedacted m ) => dat -> m ByteString redactedGetTorrentFile dat = inSpan' "Redacted Get Torrent File" $ \span -> do let actionArgs = [ ("id", Just (buildBytes intDecimalB dat.torrentId)) ] -- try using tokens as long as we have them (TODO: what if there’s no tokens left? -- ANSWER: it breaks: -- responseBody = "{\"status\":\"failure\",\"error\":\"You do not have any freeleech tokens left. Please use the regular DL link.\"}", <> (if dat.useFreeleechTokens then [("usetoken", Just "1")] else []) let reqDat = ( T2 (label @"action" "download") ( label @"actionArgs" $ actionArgs ) ) addAttribute span "redacted.request" (toOtelJsonAttr reqDat) req <- mkRedactedApiRequest reqDat httpTorrent span req mkRedactedTorrentLink :: Arg "torrentGroupId" Int -> Text mkRedactedTorrentLink torrentId = [fmt|https://redacted.sh/torrents.php?id={torrentId.unArg}|] exampleSearch :: (MonadThrow m, MonadLogger m, MonadPostgres m, MonadOtel m, MonadRedacted m) => m (Transaction m ()) exampleSearch = do t1 <- redactedSearchAndInsert [ ("searchstr", "cherish"), ("artistname", "kirinji"), -- ("year", "1982"), -- ("format", "MP3"), -- ("releasetype", "album"), ("order_by", "year") ] t3 <- redactedSearchAndInsert [ ("searchstr", "mouss et hakim"), ("artistname", "mouss et hakim"), -- ("year", "1982"), -- ("format", "MP3"), -- ("releasetype", "album"), ("order_by", "year") ] t2 <- redactedSearchAndInsert [ ("searchstr", "thriller"), ("artistname", "michael jackson"), -- ("year", "1982"), -- ("format", "MP3"), -- ("releasetype", "album"), ("order_by", "year") ] pure (t1 >> t2 >> t3 >> pure ()) redactedRefreshArtist :: ( MonadLogger m, MonadPostgres m, MonadThrow m, MonadOtel m, MonadRedacted m, HasField "artistId" dat Int ) => dat -> m (Transaction m (Label "newTorrents" [Label "torrentId" Int])) redactedRefreshArtist dat = do redactedPagedSearchAndInsert (Json.key "torrentgroup" $ parseTourGroups (T2 (label @"torrentFieldName" "torrent") (label @"torrentIdName" "id"))) ( \page -> redactedGetArtist ( T2 (getLabel @"artistId" dat) page ) ) -- | Do the search, return a transaction that inserts all results from all pages of the search. redactedSearchAndInsert :: (MonadLogger m, MonadPostgres m, MonadThrow m, MonadOtel m, MonadRedacted m) => [(ByteString, ByteString)] -> m (Transaction m (Label "newTorrents" [Label "torrentId" Int])) redactedSearchAndInsert extraArguments = redactedPagedSearchAndInsert (Json.key "results" $ parseTourGroups (T2 (label @"torrentFieldName" "torrents") (label @"torrentIdName" "torrentId"))) ( redactedSearch (label @"actionArgs" extraArguments) ) -- | Parse the standard Redacted reply object, @{ status: "success", response: ... }@ or throw an error. -- -- The response might contain a `pages` field, if not we’ll return 1. parseRedactedReplyStatus :: (Monad m) => Json.ParseT ErrorTree m b -> Json.ParseT ErrorTree m (T2 "pages" Natural "response" b) parseRedactedReplyStatus inner = do status <- Json.key "status" Json.asText when (status /= "success") $ do Json.throwCustomError ([fmt|Status was not "success", but {status}|] :: ErrorTree) Json.key "response" $ do pages <- Json.keyMay "pages" ( Field.toJsonParser ( Field.mapError singleError $ Field.jsonNumber >>> Field.boundedScientificIntegral @Int "not an Integer" >>> Field.integralToNatural ) ) -- in case the field is missing, let’s assume there is only one page <&> fromMaybe 1 res <- inner pure $ T2 (label @"pages" pages) (label @"response" res) type TourGroups = ( Label "tourGroups" [ T2 "tourGroup" (T3 "groupId" Int "groupName" Text "fullJsonResult" Json.Value) "torrents" [T2 "torrentId" Int "fullJsonResult" Json.Value] ] ) parseTourGroups :: ( Monad m, HasField "torrentFieldName" opts Text, HasField "torrentIdName" opts Text ) => opts -> Json.ParseT err m TourGroups parseTourGroups opts = do label @"tourGroups" <$> ( catMaybes <$> ( Json.eachInArray $ do Json.keyMay opts.torrentFieldName (pure ()) >>= \case -- not a torrent group, maybe some files or something (e.g. guitar tabs see Dream Theater Systematic Chaos) Nothing -> pure Nothing Just () -> do groupId <- Json.keyLabel @"groupId" "groupId" (Json.asIntegral @_ @Int) groupName <- Json.keyLabel @"groupName" "groupName" Json.asText fullJsonResult <- label @"fullJsonResult" <$> ( Json.asObject -- remove torrents cause they are inserted separately below <&> KeyMap.filterWithKey (\k _ -> k /= (opts.torrentFieldName & Key.fromText)) <&> Json.Object ) let tourGroup = T3 groupId groupName fullJsonResult torrents <- Json.keyLabel @"torrents" opts.torrentFieldName $ Json.eachInArray $ do torrentId <- Json.keyLabel @"torrentId" opts.torrentIdName (Json.asIntegral @_ @Int) fullJsonResultT <- label @"fullJsonResult" <$> ( Json.asObject <&> KeyMap.mapKeyVal ( \k -> if -- some torrent objects use “snatched” instead of “snatches” | k == "snatched" -> "snatches" -- normalize the torrent id field | k == (opts.torrentIdName & Key.fromText) -> "torrentId" | otherwise -> k ) id <&> Json.Object ) pure $ T2 torrentId fullJsonResultT pure $ Just (T2 (label @"tourGroup" tourGroup) torrents) ) ) redactedPagedSearchAndInsert :: forall m. ( MonadLogger m, MonadPostgres m ) => Json.Parse ErrorTree TourGroups -> -- | A redacted request that returns a paged result ( forall a. Label "page" (Maybe Natural) -> Json.Parse ErrorTree a -> m a ) -> m (Transaction m (Label "newTorrents" [Label "torrentId" Int])) redactedPagedSearchAndInsert innerParser pagedRequest = do -- The first search returns the amount of pages, so we use that to query all results piece by piece. firstPage <- go Nothing let remainingPages = firstPage.pages - 1 logInfo [fmt|Got the first page, found {remainingPages} more pages|] let otherPagesNum = [(2 :: Natural) .. remainingPages] otherPages <- traverse go (Just <$> otherPagesNum) pure $ (firstPage : otherPages) & concatMap (.response.tourGroups) & \case IsNonEmpty tgs -> do tgs & insertTourGroupsAndTorrents pure $ label @"newTorrents" (tgs & concatMap (\tg -> tg.torrents <&> getLabel @"torrentId")) IsEmpty -> pure $ label @"newTorrents" [] where go mpage = pagedRequest (label @"page" mpage) ( parseRedactedReplyStatus $ innerParser ) insertTourGroupsAndTorrents :: NonEmpty ( T2 "tourGroup" (T3 "groupId" Int "groupName" Text "fullJsonResult" Json.Value) "torrents" [T2 "torrentId" Int "fullJsonResult" Json.Value] ) -> Transaction m () insertTourGroupsAndTorrents dat = do let tourGroups = dat <&> (.tourGroup) let torrents = dat <&> (.torrents) insertTourGroups tourGroups >>= ( \res -> insertTorrents $ zipT2 $ T2 (label @"torrentGroupIdPg" $ res <&> (.tourGroupIdPg)) (label @"torrents" (torrents & toList)) ) insertTourGroups :: NonEmpty ( T3 "groupId" Int "groupName" Text "fullJsonResult" Json.Value ) -> Transaction m [Label "tourGroupIdPg" Int] insertTourGroups dats = do let groupNames = dats <&> \dat -> [fmt|{dat.groupId}: {dat.groupName}|] logInfo [fmt|Inserting tour groups for {showPretty groupNames}|] _ <- execute [fmt| DELETE FROM redacted.torrent_groups WHERE group_id = ANY (?::integer[]) |] (Only $ (dats <&> (.groupId) & toList & PGArray :: PGArray Int)) executeManyReturningWith [fmt| INSERT INTO redacted.torrent_groups ( group_id, group_name, full_json_result ) VALUES ( ?, ? , ? ) ON CONFLICT (group_id) DO UPDATE SET group_id = excluded.group_id, group_name = excluded.group_name, full_json_result = excluded.full_json_result RETURNING (id) |] ( dats -- make sure we don’t have the same conflict target twice & NonEmpty.nubBy (\a b -> a.groupId == b.groupId) <&> ( \dat -> ( dat.groupId, dat.groupName, dat.fullJsonResult ) ) ) (label @"tourGroupIdPg" <$> Dec.fromField @Int) insertTorrents :: [ T2 "torrentGroupIdPg" Int "torrents" [T2 "torrentId" Int "fullJsonResult" Json.Value] ] -> Transaction m () insertTorrents dats = do _ <- execute [sql| DELETE FROM redacted.torrents_json WHERE torrent_id = ANY (?::integer[]) |] ( Only $ PGArray [ torrent.torrentId | dat <- dats, torrent <- dat.torrents ] ) execute [sql| INSERT INTO redacted.torrents_json ( torrent_group , torrent_id , full_json_result) SELECT * FROM UNNEST( ?::integer[] , ?::integer[] , ?::jsonb[] ) AS inputs( torrent_group , torrent_id , full_json_result) |] ( [ T3 (getLabel @"torrentGroupIdPg" dat) (getLabel @"torrentId" group) (getLabel @"fullJsonResult" group) | dat <- dats, group <- dat.torrents ] & List.nubBy (\a b -> a.torrentId == b.torrentId) & unzip3PGArray @"torrentGroupIdPg" @Int @"torrentId" @Int @"fullJsonResult" @Json.Value ) pure () redactedGetTorrentFileAndInsert :: ( HasField "torrentId" r Int, HasField "useFreeleechTokens" r Bool, MonadPostgres m, MonadThrow m, MonadLogger m, MonadOtel m, MonadRedacted m ) => r -> Transaction m (Label "torrentFile" ByteString) redactedGetTorrentFileAndInsert dat = inSpan' "Redacted Get Torrent File and Insert" $ \span -> do bytes <- lift $ redactedGetTorrentFile dat execute [sql| UPDATE redacted.torrents_json SET torrent_file = ?::bytea WHERE torrent_id = ?::integer |] ( (Binary bytes :: Binary ByteString), dat.torrentId ) >>= assertOneUpdated span "redactedGetTorrentFileAndInsert" >>= \() -> pure (label @"torrentFile" bytes) getTorrentFileById :: ( MonadPostgres m, HasField "torrentId" r Int, MonadThrow m ) => r -> Transaction m (Maybe (Label "torrentFile" ByteString)) getTorrentFileById dat = do queryWith [sql| SELECT torrent_file FROM redacted.torrents WHERE torrent_id = ?::integer |] (Only $ (dat.torrentId :: Int)) (fmap @Maybe (label @"torrentFile") <$> Dec.byteaMay) >>= ensureSingleRow updateTransmissionTorrentHashById :: ( MonadPostgres m, HasField "torrentId" r Int, HasField "torrentHash" r Text ) => r -> Transaction m (Label "numberOfRowsAffected" Natural) updateTransmissionTorrentHashById dat = do execute [sql| UPDATE redacted.torrents_json SET transmission_torrent_hash = ?::text WHERE torrent_id = ?::integer |] ( dat.torrentHash :: Text, dat.torrentId :: Int ) assertOneUpdated :: (HasField "numberOfRowsAffected" r Natural, MonadThrow m, MonadIO m) => Otel.Span -> Text -> r -> m () assertOneUpdated span name x = case x.numberOfRowsAffected of 1 -> pure () 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, releaseType :: ReleaseType, seedingWeight :: Int, artists :: [T2 "artistId" Int "artistName" Text], torrentGroupJson :: TorrentGroupJson, torrentStatus :: TorrentStatus transmissionInfo, torrentFormat :: Text } -- | https://redacted.sh/wiki.php?action=article&id=455#_1804298149 data ReleaseType = ReleaseType {intKey :: Int, stringKey :: Text} deriving stock (Eq, Show) releaseTypeFromTextOrIntKey :: Text -> ReleaseType releaseTypeFromTextOrIntKey t = allReleaseTypesSorted & List.find ( \rt -> do rt.stringKey == t || buildText intDecimalT rt.intKey == t ) & fromMaybe (ReleaseType {intKey = (-1), stringKey = t}) releaseTypeComparison :: Comparison ReleaseType releaseTypeComparison = listIndexComparison allReleaseTypesSorted allReleaseTypesSorted :: [ReleaseType] allReleaseTypesSorted = [ releaseTypeAlbum, releaseTypeLiveAlbum, releaseTypeAnthology, releaseTypeSoundtrack, releaseTypeEP, releaseTypeCompilation, releaseTypeSingle, releaseTypeRemix, releaseTypeBootleg, releaseTypeInterview, releaseTypeMixtape, releaseTypeDemo, releaseTypeConcertRecording, releaseTypeDJMix, releaseTypeUnknown, releaseTypeProducedBy, releaseTypeComposition, releaseTypeRemixedBy, releaseTypeGuestAppearance ] releaseTypeAlbum, releaseTypeSoundtrack, releaseTypeEP, releaseTypeAnthology, releaseTypeCompilation, releaseTypeSingle, releaseTypeLiveAlbum, releaseTypeRemix, releaseTypeBootleg, releaseTypeInterview, releaseTypeMixtape, releaseTypeDemo, releaseTypeConcertRecording, releaseTypeDJMix, releaseTypeUnknown, releaseTypeProducedBy, releaseTypeComposition, releaseTypeRemixedBy, releaseTypeGuestAppearance :: ReleaseType releaseTypeAlbum = ReleaseType 1 "Album" releaseTypeSoundtrack = ReleaseType 3 "Soundtrack" releaseTypeEP = ReleaseType 5 "EP" releaseTypeAnthology = ReleaseType 6 "Anthology" releaseTypeCompilation = ReleaseType 7 "Compilation" releaseTypeSingle = ReleaseType 9 "Single" releaseTypeLiveAlbum = ReleaseType 11 "Live album" releaseTypeRemix = ReleaseType 13 "Remix" releaseTypeBootleg = ReleaseType 14 "Bootleg" releaseTypeInterview = ReleaseType 15 "Interview" releaseTypeMixtape = ReleaseType 16 "Mixtape" releaseTypeDemo = ReleaseType 17 "Demo" releaseTypeConcertRecording = ReleaseType 18 "Concert Recording" releaseTypeDJMix = ReleaseType 19 "DJ Mix" releaseTypeUnknown = ReleaseType 21 "Unknown" releaseTypeProducedBy = ReleaseType 1021 "Produced By" releaseTypeComposition = ReleaseType 1022 "Composition" releaseTypeRemixedBy = ReleaseType 1023 "Remixed By" releaseTypeGuestAppearance = ReleaseType 1024 "Guest Appearance" data TorrentGroupJson = TorrentGroupJson { groupName :: Text, groupYear :: Natural } data TorrentStatus transmissionInfo = NoTorrentFileYet | NotInTransmissionYet | InTransmission (T2 "torrentHash" Text "transmissionInfo" transmissionInfo) getTorrentById :: (MonadPostgres m, HasField "torrentId" r Int, MonadThrow m) => r -> Transaction m Json.Value getTorrentById dat = do queryWith [sql| SELECT full_json_result FROM redacted.torrents WHERE torrent_id = ?::integer |] (getLabel @"torrentId" dat) (Dec.json Json.asValue) >>= ensureSingleRow data GetBestTorrentsFilter = GetBestTorrentsFilter { onlyArtist :: Maybe (Label "artistRedactedId" Int), onlyTheseTorrents :: Maybe ([Label "torrentId" Int]), disallowedReleaseTypes :: [ReleaseType], limitResults :: Maybe Natural, ordering :: BestTorrentsOrdering } data BestTorrentsOrdering = BySeedingWeight | ByLastReleases -- | Find the best torrent for each torrent group (based on the seeding_weight) getBestTorrents :: (MonadPostgres m) => GetBestTorrentsFilter -> Transaction m [TorrentData ()] getBestTorrents opts = do queryWith ( [sql| WITH filtered_torrents AS ( SELECT DISTINCT ON (torrent_group) id FROM redacted.torrents WHERE -- filter by artist id (?::bool OR (to_jsonb(?::int) <@ (jsonb_path_query_array(full_json_result, '$.artists[*].id')))) -- filter by torrent ids AND (?::bool OR torrent_id = ANY (?::int[])) ORDER BY torrent_group, -- prefer torrents which we already downloaded torrent_file, seeding_weight DESC ), prepare1 AS ( SELECT tg.group_id, t.torrent_id, t.seeding_weight, tg.full_json_result->>'releaseType' AS release_type, -- 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, 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 WHERE tg.full_json_result->>'releaseType' <> ALL (?::text[]) ) SELECT group_id, torrent_id, seeding_weight, release_type, artists, group_name, group_year, has_torrent_file, transmission_torrent_hash, torrent_format FROM prepare1 |] <> case opts.ordering of BySeedingWeight -> [fmt|ORDER BY seeding_weight DESC|] <> "\n" ByLastReleases -> [fmt|ORDER BY group_id DESC|] <> "\n" <> [sql| LIMIT ?::int |] ) ( do let (onlyArtistB, onlyArtistId) = case opts.onlyArtist of Nothing -> (True, 0) Just a -> (False, a.artistRedactedId) let (onlyTheseTorrentsB, onlyTheseTorrents) = case opts.onlyTheseTorrents of Nothing -> (True, PGArray []) Just a -> (False, a <&> (.torrentId) & PGArray) ( onlyArtistB :: Bool, onlyArtistId :: Int, onlyTheseTorrentsB :: Bool, onlyTheseTorrents, (opts.disallowedReleaseTypes & concatMap (\rt -> [rt.stringKey, rt.intKey & buildText intDecimalT]) & PGArray :: PGArray Text), opts.limitResults <&> naturalToInteger :: Maybe Integer ) ) ( do groupId <- Dec.fromField @Int torrentId <- Dec.fromField @Int seedingWeight <- Dec.fromField @Int releaseType <- releaseTypeFromTextOrIntKey <$> Dec.text 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) torrentFormat <- Dec.text pure $ TorrentData { torrentStatus = if | not hasTorrentFile -> NoTorrentFileYet | Nothing <- transmissionTorrentHash -> NotInTransmissionYet | 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, .. } ) 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. mkRedactedApiRequest :: ( MonadThrow m, HasField "action" p ByteString, HasField "actionArgs" p [(ByteString, Maybe ByteString)], MonadRedacted m ) => p -> m Http.Request mkRedactedApiRequest dat = do authKey <- getRedactedApiKey pure $ [fmt|https://redacted.sh/ajax.php|] & Http.setRequestMethod "GET" & Http.setQueryString (("action", Just dat.action) : dat.actionArgs) & Http.setRequestHeader "Authorization" [authKey] 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.getResponseStatus & (.statusCode) contentType = resp & Http.getResponseHeaders & List.lookup "content-type" <&> Wai.parseContentType <&> (\(ct, _mimeAttributes) -> ct) if | statusCode == 200, Just "application/x-bittorrent" <- contentType -> 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 $ AppExceptionPretty [[fmt|Redacted returned an non-200 error code, code {code}|], pretty resp] ) redactedApiRequestJson :: ( MonadThrow m, HasField "action" p ByteString, HasField "actionArgs" p [(ByteString, Maybe ByteString)], MonadOtel m, MonadRedacted m ) => Otel.Span -> p -> Json.Parse ErrorTree a -> m a redactedApiRequestJson span dat parser = do addAttribute span "redacted.request" (toOtelJsonAttr (T2 (getLabel @"action" dat) (getLabel @"actionArgs" dat))) mkRedactedApiRequest dat >>= Http.httpJson defaults parser test :: (MonadThrow m, MonadRedacted m, MonadOtel m) => m () test = inSpan' "test" $ \span -> do redactedApiRequestJson span (T2 (label @"action" "artist") (label @"actionArgs" [("id", Just "2785")])) (Json.asValue) <&> Pretty.showPrettyJsonColored >>= liftIO . putStderrLn readTorrentFile :: (MonadIO m, MonadPostgres m) => m () readTorrentFile = runTransaction $ do torrentBytes <- queryWith [sql| SELECT torrent_file from redacted.torrents where torrent_file is not null limit 10 |] () Dec.bytea liftIO $ for_ torrentBytes $ \b -> case testBencode b of Left e -> do Text.IO.putStrLn $ prettyErrorTree e Right a -> printPretty a liftIO $ print $ lengthNatural torrentBytes testBencode :: ByteString -> (Either ErrorTree TorrentFile) testBencode bs = Parse.runParse "cannot parse bencode" (parseBencode >>> bencodeTorrentParser) bs -- | A torrent file -- -- from wikipedia: -- -- * announce—the URL of the high tracker -- * info—this maps to a dictionary whose keys are very dependent on whether one or more files are being shared: -- - files—a list of dictionaries each corresponding to a file (only when multiple files are being shared). Each dictionary has the following keys: -- * length—size of the file in bytes. -- * path—a list of strings corresponding to subdirectory names, the last of which is the actual file name -- - length—size of the file in bytes (only when one file is being shared though) -- - name—suggested filename where the file is to be saved (if one file)/suggested directory name where the files are to be saved (if multiple files) -- - piece length—number of bytes per piece. This is commonly 28 KiB = 256 KiB = 262,144 B. -- - pieces—a hash list, i.e., a concatenation of each piece's SHA-1 hash. As SHA-1 returns a 160-bit hash, pieces will be a string whose length is a multiple of 20 bytes. If the torrent contains multiple files, the pieces are formed by concatenating the files in the order they appear in the files dictionary (i.e., all pieces in the torrent are the full piece length except for the last piece, which may be shorter). data TorrentFile = TorrentFile { announce :: Text, comment :: Maybe Text, createdBy :: Maybe Text, creationDate :: Maybe UTCTime, encoding :: Maybe Text, info :: Info } deriving stock (Eq, Show) data Info = Info { name :: Text, files :: [File], pieceLength :: Natural, pieces :: ByteString, private :: Maybe Bool, source :: Maybe Text } deriving stock (Eq, Show) data File = File { length_ :: Natural, path :: [Text] } deriving stock (Eq, Show) bencodeTorrentParser :: Parse BEncode TorrentFile bencodeTorrentParser = bencodeDict >>> do announce <- mapLookup "announce" bencodeTextLenient comment <- mapLookupMay "comment" bencodeTextLenient createdBy <- mapLookupMay "created by" bencodeTextLenient creationDate <- mapLookupMay "creation date" (bencodeInteger <&> posixSecondsToUTCTime . fromInteger @NominalDiffTime) encoding <- mapLookupMay "encoding" bencodeTextLenient info <- mapLookup "info" $ bencodeDict >>> do name <- mapLookup "name" bencodeTextLenient files <- mapLookup "files" $ bencodeList >>> ( Parse.multiple $ bencodeDict >>> do length_ <- mapLookup "length" bencodeNatural path <- mapLookup "path" $ bencodeList >>> Parse.multiple bencodeTextLenient pure $ File {..} ) pieceLength <- mapLookup "piece length" bencodeNatural pieces <- mapLookup "pieces" bencodeBytes private <- mapLookupMay "private" bencodeInteger <&> fmap ( \case 0 -> False _ -> True ) source <- mapLookupMay "source" bencodeTextLenient pure Info {..} pure TorrentFile {..}