feat(users/Profpatsch/whatcd-resolver): Download torrent file r/6420

Change-Id: I75422a1fc4f94e8aa856f1ea1b2dbec42360c7ac
Reviewed-on: https://cl.tvl.fyi/c/depot/+/8874
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>

1 files changed, 179 insertions, 47 deletions

diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
index fee64b62f2..6f2f041484 100644
--- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
+++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
@@ -18,7 +18,7 @@ import Data.Map.Strict qualified as Map
 import Data.Pool (Pool)
 import Data.Pool qualified as Pool
 import Data.Text qualified as Text
-import Database.PostgreSQL.Simple (Only (..))
+import Database.PostgreSQL.Simple (Binary (Binary), Only (..))
 import Database.PostgreSQL.Simple qualified as Postgres
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Database.PostgreSQL.Simple.Types (PGArray (PGArray))
@@ -56,36 +56,53 @@ import UnliftIO
 htmlUi :: App ()
 htmlUi = do
   let debug = True
-  withRunInIO $ \runInIO -> Warp.run 8080 $ \req resp -> do
-    let renderHtml = if debug then toLazyBytes . textToBytesUtf8 . stringToText . Html.Pretty.renderHtml else Html.renderHtml
-    let h act = do
-          res <- runInIO act
-          resp . Wai.responseLBS Http.ok200 [("Content-Type", "text/html")] . renderHtml $ res
-
-    let mp parser =
-          Multipart.parseMultipartOrThrow
-            appThrowTree
-            parser
-            req
-
-    case req & Wai.pathInfo & Text.intercalate "/" of
-      "" -> h mainHtml
-      "snips/redacted/search" -> do
-        h $ do
+  withRunInIO $ \runInIO -> Warp.run 8080 $ \req respond -> do
+    let catchAppException act =
+          try act >>= \case
+            Right a -> pure a
+            Left (AppException err) -> do
+              runInIO (logError err)
+              respond (Wai.responseLBS Http.status500 [] "")
+
+    catchAppException $ do
+      let renderHtml = if debug then toLazyBytes . textToBytesUtf8 . stringToText . Html.Pretty.renderHtml else Html.renderHtml
+      let h act = do
+            res <- runInIO act
+            respond . Wai.responseLBS Http.ok200 [("Content-Type", "text/html")] . renderHtml $ res
+
+      let mp parser =
+            Multipart.parseMultipartOrThrow
+              appThrowTree
+              parser
+              req
+
+      case req & Wai.pathInfo & Text.intercalate "/" of
+        "" -> h mainHtml
+        "snips/redacted/search" -> do
+          h $ do
+            dat <-
+              mp
+                ( do
+                    label @"searchstr" <$> Multipart.field "redacted-search" Cat.id
+                )
+            snipsRedactedSearch dat
+        "snips/redacted/torrentDataJson" -> h $ do
           dat <-
             mp
               ( do
-                  label @"searchstr" <$> Multipart.field "redacted-search" Cat.id
+                  label @"torrentId" <$> Multipart.field "torrent-id" ((Field.utf8 >>> Field.signedDecimal >>> Field.bounded @Int "int"))
               )
-          snipsRedactedSearch dat
-      "snips/redacted/torrentDataJson" -> h $ do
-        dat <-
-          mp
-            ( do
-                label @"id" <$> Multipart.field "torrent-id" ((Field.utf8 >>> Field.signedDecimal >>> Field.bounded @Int "int"))
-            )
-        mkVal <$> (runTransaction $ getTorrentById dat)
-      _ -> h mainHtml
+          mkVal <$> (runTransaction $ getTorrentById dat)
+        "snips/redacted/getTorrentFile" -> h $ do
+          dat <-
+            mp
+              ( do
+                  label @"torrentId" <$> Multipart.field "torrent-id" ((Field.utf8 >>> Field.signedDecimal >>> Field.bounded @Int "int"))
+              )
+          runTransaction $ do
+            redactedGetTorrentFileAndInsert dat
+            pure [hsx|Got!|]
+        _ -> h mainHtml
   where
     mainHtml = runTransaction $ do
       bestTorrentsTable <- getBestTorrentsTable
@@ -141,17 +158,22 @@ snipsRedactedSearch dat = do
 getBestTorrentsTable :: (MonadPostgres m) => Transaction m Html
 getBestTorrentsTable = do
   best :: [TorrentData] <- getBestTorrents
+  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)]}>Get Torrent</button>|]
+        InTransmission -> [hsx|Started.|]
+        NotInTransmissionYet -> [hsx|Not started.|]
   let bestRows =
         best
           & foldMap
             ( \b -> do
                 [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>{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.torrentIdDb)]}></details></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>
                 |]
             )
@@ -160,6 +182,7 @@ getBestTorrentsTable = do
         <table class="table">
           <thead>
             <tr>
+              <th>Local</th>
               <th>Group ID</th>
               <th>Artist</th>
               <th>Name</th>
@@ -178,8 +201,8 @@ getTransmissionTorrentsTable ::
   (MonadIO m, MonadTransmission m, MonadThrow m) =>
   m Html
 getTransmissionTorrentsTable = do
-  let fields = ["id", "name", "files", "fileStats"]
-  resp <- doTransmissionRequest transmissionConnectionConfig (requestListAllTorrents fields)
+  let fields = ["hashString", "name", "activity", "percentDone", "percentComplete", "eta"]
+  resp <- doTransmissionRequest transmissionConnectionConfig (transmissionRequestListAllTorrents fields)
   case resp.result of
     TransmissionResponseFailure err -> appThrowTree (nestedError "Transmission RPC error" $ singleError $ newError err)
     TransmissionResponseSuccess ->
@@ -195,9 +218,10 @@ getTransmissionTorrentsTable = do
             pure $
               toTable
                 ( a
+                    & List.sortOn (\m -> m & Map.lookup "percentDone" & fromMaybe (Json.Number 0))
                     <&> Map.toList
                     -- TODO
-                    & List.take 3
+                    & List.take 100
                 )
 
 zipNonEmpty :: NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
@@ -255,8 +279,8 @@ testTransmission req = runAppWith $ doTransmissionRequest transmissionConnection
 transmissionConnectionConfig :: T2 "host" Text "port" Text
 transmissionConnectionConfig = (T2 (label @"host" "localhost") (label @"port" "9091"))
 
-requestListAllTorrents :: [Text] -> TransmissionRequest
-requestListAllTorrents fields =
+transmissionRequestListAllTorrents :: [Text] -> TransmissionRequest
+transmissionRequestListAllTorrents fields =
   TransmissionRequest
     { method = "torrent-get",
       arguments =
@@ -266,6 +290,33 @@ requestListAllTorrents fields =
       tag = Nothing
     }
 
+transmissionRequestListOnlyTorrents ::
+  ( HasField "ids" r1 [r2],
+    HasField "fields" r1 [Text],
+    HasField "torrentSha" r2 Text
+  ) =>
+  r1 ->
+  TransmissionRequest
+transmissionRequestListOnlyTorrents dat =
+  TransmissionRequest
+    { method = "torrent-get",
+      arguments =
+        Map.fromList
+          [ ("ids", Enc.list (\i -> Enc.text i.torrentSha) dat.ids),
+            ("fields", Enc.list Enc.text dat.fields)
+          ],
+      tag = Nothing
+    }
+
+-- transmissionRequestAddTorrent dat =
+--   TransmissionRequest {
+--     method = "torrent-add",
+--     arguments =
+--       Map.fromList [
+--         ("metainfo", Enc.text $)
+--       ]
+--   }
+
 data TransmissionResponse = TransmissionResponse
   { result :: TransmissionResponseStatus,
     arguments :: Map Text Json.Value,
@@ -348,12 +399,27 @@ redactedSearch ::
   Json.Parse ErrorTree a ->
   m a
 redactedSearch advanced =
-  redactedApiRequest
+  redactedApiRequestJson
     ( T2
         (label @"action" "browse")
         (label @"actionArgs" ((advanced <&> second Just)))
     )
 
+redactedGetTorrentFile ::
+  ( MonadLogger m,
+    MonadIO m,
+    MonadThrow m,
+    HasField "torrentId" dat Int
+  ) =>
+  dat ->
+  m ByteString
+redactedGetTorrentFile dat =
+  redactedApiRequest
+    ( T2
+        (label @"action" "download")
+        (label @"actionArgs" [("id", Just (dat.torrentId & showToText @Int & textToBytesUtf8))])
+    )
+
 test :: Bool -> IO (Either TmpPg.StartError ())
 test doSearch =
   runAppWith $ do
@@ -485,6 +551,37 @@ redactedSearchAndInsert x =
                   )
     )
 
+redactedGetTorrentFileAndInsert ::
+  ( HasField "torrentId" r Int,
+    MonadPostgres m,
+    MonadThrow m,
+    MonadIO m,
+    MonadLogger m
+  ) =>
+  r ->
+  Transaction m ()
+redactedGetTorrentFileAndInsert dat = 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 "redactedGetTorrentFileAndInsert"
+
+assertOneUpdated ::
+  (HasField "numberOfRowsAffected" r Natural, MonadThrow m) =>
+  Text ->
+  r ->
+  m ()
+assertOneUpdated name x = case x.numberOfRowsAffected of
+  1 -> pure ()
+  n -> appThrowTree ([fmt|{name :: Text}: Expected to update exactly one row, but updated {n :: Natural} row(s)|])
+
 migrate :: MonadPostgres m => Transaction m (Label "numberOfRowsAffected" Natural)
 migrate = do
   execute_
@@ -507,6 +604,11 @@ migrate = do
       UNIQUE(torrent_id)
     );
 
+    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
 
     CREATE OR REPLACE VIEW redacted.torrents AS
@@ -518,7 +620,9 @@ migrate = do
       ( (full_json_result->'seeders')::integer*3
       + (full_json_result->'snatches')::integer)
       AS seeding_weight,
-      t.full_json_result
+      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));
@@ -528,20 +632,25 @@ migrate = do
 data TorrentData = TorrentData
   { groupId :: Int,
     torrentId :: Int,
-    torrentIdDb :: Int,
     seedingWeight :: Int,
     torrentJson :: Json.Value,
-    torrentGroupJson :: T2 "artist" Text "groupName" Text
+    torrentGroupJson :: T2 "artist" Text "groupName" Text,
+    torrentStatus :: TorrentStatus
   }
 
-getTorrentById :: (MonadPostgres m, HasField "id" r Int, MonadThrow m) => r -> Transaction m Json.Value
+data TorrentStatus
+  = NoTorrentFileYet
+  | NotInTransmissionYet
+  | InTransmission
+
+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 id = ?::integer
+    WHERE torrent_id = ?::integer
   |]
-    (getLabel @"id" dat)
+    (getLabel @"torrentId" dat)
     (Dec.json Json.asValue)
     >>= ensureSingleRow
 
@@ -553,11 +662,12 @@ getBestTorrents = do
       SELECT * FROM (
         SELECT DISTINCT ON (group_id)
           tg.group_id,
-          t.id,
           t.torrent_id,
           seeding_weight,
           t.full_json_result AS torrent_json,
-          tg.full_json_result AS torrent_group_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
@@ -567,7 +677,6 @@ getBestTorrents = do
     ()
     ( do
         groupId <- Dec.fromField @Int
-        torrentIdDb <- Dec.fromField @Int
         torrentId <- Dec.fromField @Int
         seedingWeight <- Dec.fromField @Int
         torrentJson <- Dec.json Json.asValue
@@ -577,7 +686,18 @@ getBestTorrents = do
               groupName <- Json.keyLabel @"groupName" "groupName" Json.asText
               pure $ T2 artist groupName
             )
-        pure $ TorrentData {..}
+        hasTorrentFile <- Dec.fromField @Bool
+        transmissionTorrentHash <-
+          Dec.fromField @(Maybe Text)
+        pure $
+          TorrentData
+            { torrentStatus =
+                if
+                    | not hasTorrentFile -> NoTorrentFileYet
+                    | Nothing <- transmissionTorrentHash -> NotInTransmissionYet
+                    | Just _hash <- transmissionTorrentHash -> InTransmission,
+              ..
+            }
     )
 
 hush :: Either a1 a2 -> Maybe a2
@@ -608,9 +728,8 @@ redactedApiRequest ::
     HasField "actionArgs" p [(ByteString, Maybe ByteString)]
   ) =>
   p ->
-  Json.Parse ErrorTree a ->
-  m a
-redactedApiRequest dat parse = do
+  m ByteString
+redactedApiRequest dat = do
   authKey <- runCommandExpect0 "pass" ["internet/redacted/api-keys/whatcd-resolver"]
   let req =
         [fmt|https://redacted.ch/ajax.php|]
@@ -623,6 +742,19 @@ redactedApiRequest dat parse = do
           200 -> Right $ resp & Http.responseBody
           _ -> Left [fmt|Redacted returned an non-200 error code: {resp & showPretty}|]
       )
+
+redactedApiRequestJson ::
+  ( MonadThrow m,
+    MonadIO m,
+    MonadLogger m,
+    HasField "action" p ByteString,
+    HasField "actionArgs" p [(ByteString, Maybe ByteString)]
+  ) =>
+  p ->
+  Json.Parse ErrorTree a ->
+  m a
+redactedApiRequestJson dat parse = do
+  redactedApiRequest dat
     >>= ( Json.parseStrict parse
             >>> first (Json.parseErrorTree "could not parse redacted response")
             >>> assertM id