about summary refs log tree commit diff
path: root/users/Profpatsch/whatcd-resolver/src/Redacted.hs
diff options
context:
space:
mode:
Diffstat (limited to 'users/Profpatsch/whatcd-resolver/src/Redacted.hs')
-rw-r--r--users/Profpatsch/whatcd-resolver/src/Redacted.hs549
1 files changed, 549 insertions, 0 deletions
diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs
new file mode 100644
index 000000000000..573dd75877bf
--- /dev/null
+++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs
@@ -0,0 +1,549 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Redacted where
+
+import AppT
+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.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 GHC.Records (HasField (..))
+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')
+import Postgres.Decoder qualified as Dec
+import Postgres.MonadPostgres
+import Pretty
+import RunCommand (runCommandExpect0)
+import Prelude hiding (span)
+
+redactedSearch ::
+  (MonadLogger m, MonadThrow m, MonadOtel m) =>
+  [(ByteString, ByteString)] ->
+  Json.Parse ErrorTree a ->
+  m a
+redactedSearch advanced parser =
+  inSpan "Redacted API Search" $
+    redactedApiRequestJson
+      ( T2
+          (label @"action" "browse")
+          (label @"actionArgs" ((advanced <&> second Just)))
+      )
+      parser
+
+redactedGetTorrentFile ::
+  ( MonadLogger m,
+    MonadThrow m,
+    HasField "torrentId" dat Int,
+    MonadOtel m
+  ) =>
+  dat ->
+  m ByteString
+redactedGetTorrentFile dat = inSpan' "Redacted Get Torrent File" $ \span -> do
+  req <-
+    mkRedactedApiRequest
+      ( T2
+          (label @"action" "download")
+          ( label @"actionArgs"
+              [ ("id", Just (dat.torrentId & showToText @Int & textToBytesUtf8))
+              -- 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.\"}",
+              -- ("usetoken", Just "1")
+              ]
+          )
+      )
+  httpTorrent span req
+
+-- fix
+--   ( \io -> do
+--       logInfo "delay"
+--       liftIO $ threadDelay 10_000_000
+--       io
+--   )
+
+exampleSearch :: (MonadThrow m, MonadLogger m, MonadPostgres m, MonadOtel 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)
+
+-- | Do the search, return a transaction that inserts all results from all pages of the search.
+redactedSearchAndInsert ::
+  forall m.
+  ( MonadLogger m,
+    MonadPostgres m,
+    MonadThrow m,
+    MonadOtel m
+  ) =>
+  [(ByteString, ByteString)] ->
+  m (Transaction m ())
+redactedSearchAndInsert extraArguments = do
+  logInfo [fmt|Doing redacted search with arguments: {showPretty extraArguments}|]
+  -- 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 (.tourGroups)
+      & \case
+        IsNonEmpty tgs -> tgs & insertTourGroupsAndTorrents
+        IsEmpty -> pure ()
+  where
+    go mpage =
+      redactedSearch
+        ( extraArguments
+            -- pass the page (for every search but the first one)
+            <> ifExists (mpage <&> (\page -> [("page", (page :: Natural) & showToText & textToBytesUtf8)]))
+        )
+        ( do
+            status <- Json.key "status" Json.asText
+            when (status /= "success") $ do
+              Json.throwCustomError [fmt|Status was not "success", but {status}|]
+            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
+              Json.key "results" $ do
+                tourGroups <-
+                  label @"tourGroups"
+                    <$> ( Json.eachInArray $ 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 /= "torrents")
+                                        <&> Json.Object
+                                    )
+                            let tourGroup = T3 groupId groupName fullJsonResult
+                            torrents <- Json.keyLabel @"torrents" "torrents" $
+                              Json.eachInArray $ do
+                                torrentId <- Json.keyLabel @"torrentId" "torrentId" (Json.asIntegral @_ @Int)
+                                fullJsonResultT <- label @"fullJsonResult" <$> Json.asValue
+                                pure $ T2 torrentId fullJsonResultT
+                            pure (T2 (label @"tourGroup" tourGroup) torrents)
+                        )
+                pure
+                  ( T2
+                      (label @"pages" pages)
+                      tourGroups
+                  )
+        )
+    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 <&> \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)
+          |]
+        ( [ ( dat.torrentGroupIdPg :: Int,
+              group.torrentId :: Int,
+              group.fullJsonResult :: Json.Value
+            )
+            | dat <- dats,
+              group <- dat.torrents
+          ]
+            & unzip3PGArray
+        )
+      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
+  ) =>
+  r ->
+  Transaction m (Label "torrentFile" ByteString)
+redactedGetTorrentFileAndInsert dat = inSpan' "Redacted Get Torrent File and Insert" $ \span -> do
+  bytes <- 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 -> appThrowTree 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 :: T2 "artist" Text "groupName" Text,
+    torrentStatus :: TorrentStatus transmissionInfo
+  }
+
+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
+
+-- | Find the best torrent for each torrent group (based on the seeding_weight)
+getBestTorrents :: (MonadPostgres m) => Transaction m [TorrentData ()]
+getBestTorrents = 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 _
+      ORDER BY seeding_weight DESC
+    |]
+    ()
+    ( 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
+              pure $ T2 artist groupName
+            )
+        hasTorrentFile <- Dec.fromField @Bool
+        transmissionTorrentHash <-
+          Dec.fromField @(Maybe Text)
+        pure $
+          TorrentData
+            { torrentStatus =
+                if
+                  | not hasTorrentFile -> NoTorrentFileYet
+                  | Nothing <- transmissionTorrentHash -> NotInTransmissionYet
+                  | Just hash <- transmissionTorrentHash ->
+                      InTransmission $
+                        T2 (label @"torrentHash" hash) (label @"transmissionInfo" ()),
+              ..
+            }
+    )
+
+-- | 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)]
+  ) =>
+  p ->
+  m Http.Request
+mkRedactedApiRequest dat = do
+  authKey <- runCommandExpect0 "pass" ["internet/redacted/api-keys/whatcd-resolver"]
+  pure $
+    [fmt|https://redacted.ch/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.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}|]
+      )
+
+newtype Optional a = OptionalInternal (Maybe a)
+
+mkOptional :: a -> Optional a
+mkOptional defaultValue = OptionalInternal $ Just defaultValue
+
+defaults :: Optional a
+defaults = OptionalInternal Nothing
+
+instance HasField "withDefault" (Optional a) (a -> a) where
+  getField (OptionalInternal m) defaultValue = case m of
+    Nothing -> defaultValue
+    Just a -> a
+
+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")
+      )
+
+redactedApiRequestJson ::
+  ( MonadThrow m,
+    MonadLogger m,
+    HasField "action" p ByteString,
+    HasField "actionArgs" p [(ByteString, Maybe ByteString)],
+    MonadOtel m
+  ) =>
+  p ->
+  Json.Parse ErrorTree a ->
+  m a
+redactedApiRequestJson dat parser =
+  do
+    mkRedactedApiRequest dat
+    >>= httpJson defaults parser