feat(users/Profpatsch/whatcd-resolver): misc improvements r/6593

* run on port 9092 (transmission runs on 9091)
* run postgres on port 5431 instead of 5432 (to not interfere)
* only search for albums for now
* correctly handle missing torrent file in SELECT

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

1 files changed, 30 insertions, 18 deletions

diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
index caa0d9b11ecc..0d9e84d00fc6 100644
--- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
+++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
@@ -58,7 +58,7 @@ import UnliftIO
 htmlUi :: App ()
 htmlUi = do
   let debug = True
-  withRunInIO $ \runInIO -> Warp.run 8080 $ \req respond -> do
+  withRunInIO $ \runInIO -> Warp.run 9092 $ \req respond -> do
     let catchAppException act =
           try act >>= \case
             Right a -> pure a
@@ -121,7 +121,11 @@ htmlUi = do
         "snips/redacted/startTorrentFile" -> h $ do
           dat <- torrentIdMp
           runTransaction $ do
-            file <- getTorrentFileById dat
+            file <-
+              getTorrentFileById dat
+                <&> annotate [fmt|No torrent file for torrentId "{dat.torrentId}"|]
+                >>= orAppThrowTree
+
             running <-
               lift @Transaction $
                 doTransmissionRequest' (transmissionRequestAddTorrent file)
@@ -203,7 +207,8 @@ snipsRedactedSearch ::
 snipsRedactedSearch dat = do
   t <-
     redactedSearchAndInsert
-      [ ("searchstr", dat.searchstr)
+      [ ("searchstr", dat.searchstr),
+        ("releasetype", "album")
       ]
   runTransaction $ do
     t
@@ -235,7 +240,7 @@ getBestTorrentsTable = do
                       Nothing -> td {torrentStatus = NotInTransmissionYet}
                       Just transmissionInfo -> td {torrentStatus = InTransmission (T2 (getLabel @"torrentHash" info) (label @"transmissionInfo" transmissionInfo))}
                   NotInTransmissionYet -> td {torrentStatus = NotInTransmissionYet}
-                  NoTorrentFileYet -> td {torrentStatus = NotInTransmissionYet}
+                  NoTorrentFileYet -> td {torrentStatus = NoTorrentFileYet}
               )
   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>|]
@@ -396,13 +401,13 @@ data TransmissionRequest = TransmissionRequest
   }
   deriving stock (Show)
 
-testTransmission :: Show out => (TransmissionRequest, Json.Parse Error out) -> IO (Either TmpPg.StartError ())
+testTransmission :: (Show out) => (TransmissionRequest, Json.Parse Error out) -> IO (Either TmpPg.StartError ())
 testTransmission req = runAppWith $ doTransmissionRequest transmissionConnectionConfig req >>= liftIO . printPretty
 
 transmissionConnectionConfig :: T2 "host" Text "port" Text
 transmissionConnectionConfig = (T2 (label @"host" "localhost") (label @"port" "9091"))
 
-transmissionRequestListAllTorrents :: Monad m => [Text] -> Json.ParseT e m out -> (TransmissionRequest, Json.ParseT e m [out])
+transmissionRequestListAllTorrents :: (Monad m) => [Text] -> Json.ParseT e m out -> (TransmissionRequest, Json.ParseT e m [out])
 transmissionRequestListAllTorrents fields parseTorrent =
   ( TransmissionRequest
       { method = "torrent-get",
@@ -448,7 +453,7 @@ transmissionRequestAddTorrent dat =
         arguments =
           Map.fromList
             [ ("metainfo", Enc.base64Bytes dat.torrentFile),
-              ("paused", Enc.bool True)
+              ("paused", Enc.bool False)
             ],
         tag = Nothing
       },
@@ -585,7 +590,14 @@ redactedGetTorrentFile dat =
   redactedApiRequest
     ( T2
         (label @"action" "download")
-        (label @"actionArgs" [("id", Just (dat.torrentId & showToText @Int & textToBytesUtf8))])
+        ( 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")
+            ]
+        )
     )
 
 test :: Bool -> IO (Either TmpPg.StartError ())
@@ -772,7 +784,7 @@ getTorrentFileById ::
     MonadThrow m
   ) =>
   r ->
-  Transaction m (Label "torrentFile" ByteString)
+  Transaction m (Maybe (Label "torrentFile" ByteString))
 getTorrentFileById dat = do
   queryWith
     [sql|
@@ -781,7 +793,7 @@ getTorrentFileById dat = do
     WHERE torrent_id = ?::integer
   |]
     (Only $ (dat.torrentId :: Int))
-    (label @"torrentFile" <$> Dec.bytea)
+    (fmap @Maybe (label @"torrentFile") <$> Dec.byteaMay)
     >>= ensureSingleRow
 
 updateTransmissionTorrentHashById ::
@@ -811,7 +823,7 @@ 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 :: (MonadPostgres m) => Transaction m (Label "numberOfRowsAffected" Natural)
 migrate = do
   execute_
     [sql|
@@ -892,7 +904,7 @@ getTorrentById dat = do
     >>= ensureSingleRow
 
 -- | Find the best torrent for each torrent group (based on the seeding_weight)
-getBestTorrents :: MonadPostgres m => Transaction m [TorrentData ()]
+getBestTorrents :: (MonadPostgres m) => Transaction m [TorrentData ()]
 getBestTorrents = do
   queryWith
     [sql|
@@ -1000,7 +1012,7 @@ redactedApiRequestJson dat parse = do
             >>> assertM id
         )
 
-assertM :: MonadThrow f => (t -> Either ErrorTree a) -> t -> f a
+assertM :: (MonadThrow f) => (t -> Either ErrorTree a) -> t -> f a
 assertM f v = case f v of
   Right a -> pure a
   Left err -> appThrowTree err
@@ -1040,7 +1052,7 @@ withDb act = do
         mempty
           { TmpPg.dataDirectory = TmpPg.Permanent (databaseDir),
             TmpPg.socketDirectory = TmpPg.Permanent socketDir,
-            TmpPg.port = pure $ Just 5432,
+            TmpPg.port = pure $ Just 5431,
             TmpPg.initDbConfig
           }
   TmpPg.withConfig cfg $ \db -> do
@@ -1064,15 +1076,15 @@ data AppException = AppException Text
   deriving stock (Show)
   deriving anyclass (Exception)
 
-appThrowTree :: MonadThrow m => ErrorTree -> m a
+appThrowTree :: (MonadThrow m) => ErrorTree -> m a
 appThrowTree exc = throwM $ AppException $ prettyErrorTree exc
 
-orAppThrowTree :: MonadThrow m => Either ErrorTree a -> m a
+orAppThrowTree :: (MonadThrow m) => Either ErrorTree a -> m a
 orAppThrowTree = \case
   Left err -> appThrowTree err
   Right a -> pure a
 
-instance MonadIO m => MonadLogger (AppT m) where
+instance (MonadIO m) => MonadLogger (AppT m) where
   monadLoggerLog loc src lvl msg = liftIO $ Logger.defaultOutput IO.stderr loc src lvl (Logger.toLogStr msg)
 
 class MonadTransmission m where
@@ -1095,7 +1107,7 @@ instance (MonadThrow m, MonadUnliftIO m) => MonadPostgres (AppT m) where
   foldRows = foldRowsImpl (AppT ask)
   runTransaction = runPGTransaction
 
-runPGTransaction :: MonadUnliftIO m => Transaction (AppT m) a -> AppT m a
+runPGTransaction :: (MonadUnliftIO m) => Transaction (AppT m) a -> AppT m a
 runPGTransaction (Transaction transaction) = do
   pool <- AppT ask <&> (.pgConnPool)
   withRunInIO $ \unliftIO ->