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

Change-Id: I75422a1fc4f94e8aa856f1ea1b2dbec42360c7ac
Reviewed-on: https://cl.tvl.fyi/c/depot/+/8874
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>
This commit is contained in:
Profpatsch 2023-06-29 23:18:56 +02:00
parent 4ec27ed088
commit 9504914a59

View file

@ -18,7 +18,7 @@ import Data.Map.Strict qualified as Map
import Data.Pool (Pool) import Data.Pool (Pool)
import Data.Pool qualified as Pool import Data.Pool qualified as Pool
import Data.Text qualified as Text 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 qualified as Postgres
import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.Types (PGArray (PGArray)) import Database.PostgreSQL.Simple.Types (PGArray (PGArray))
@ -56,11 +56,19 @@ import UnliftIO
htmlUi :: App () htmlUi :: App ()
htmlUi = do htmlUi = do
let debug = True let debug = True
withRunInIO $ \runInIO -> Warp.run 8080 $ \req resp -> 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 renderHtml = if debug then toLazyBytes . textToBytesUtf8 . stringToText . Html.Pretty.renderHtml else Html.renderHtml
let h act = do let h act = do
res <- runInIO act res <- runInIO act
resp . Wai.responseLBS Http.ok200 [("Content-Type", "text/html")] . renderHtml $ res respond . Wai.responseLBS Http.ok200 [("Content-Type", "text/html")] . renderHtml $ res
let mp parser = let mp parser =
Multipart.parseMultipartOrThrow Multipart.parseMultipartOrThrow
@ -82,9 +90,18 @@ htmlUi = do
dat <- dat <-
mp mp
( do ( do
label @"id" <$> Multipart.field "torrent-id" ((Field.utf8 >>> Field.signedDecimal >>> Field.bounded @Int "int")) label @"torrentId" <$> Multipart.field "torrent-id" ((Field.utf8 >>> Field.signedDecimal >>> Field.bounded @Int "int"))
) )
mkVal <$> (runTransaction $ getTorrentById dat) 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 _ -> h mainHtml
where where
mainHtml = runTransaction $ do mainHtml = runTransaction $ do
@ -141,17 +158,22 @@ snipsRedactedSearch dat = do
getBestTorrentsTable :: (MonadPostgres m) => Transaction m Html getBestTorrentsTable :: (MonadPostgres m) => Transaction m Html
getBestTorrentsTable = do getBestTorrentsTable = do
best :: [TorrentData] <- getBestTorrents 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 = let bestRows =
best best
& foldMap & foldMap
( \b -> do ( \b -> do
[hsx| [hsx|
<tr> <tr>
<td>{localTorrent b}</td>
<td>{Html.toHtml @Int b.groupId}</td> <td>{Html.toHtml @Int b.groupId}</td>
<td>{Html.toHtml @Text b.torrentGroupJson.artist}</td> <td>{Html.toHtml @Text b.torrentGroupJson.artist}</td>
<td>{Html.toHtml @Text b.torrentGroupJson.groupName}</td> <td>{Html.toHtml @Text b.torrentGroupJson.groupName}</td>
<td>{Html.toHtml @Int b.seedingWeight}</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> </tr>
|] |]
) )
@ -160,6 +182,7 @@ getBestTorrentsTable = do
<table class="table"> <table class="table">
<thead> <thead>
<tr> <tr>
<th>Local</th>
<th>Group ID</th> <th>Group ID</th>
<th>Artist</th> <th>Artist</th>
<th>Name</th> <th>Name</th>
@ -178,8 +201,8 @@ getTransmissionTorrentsTable ::
(MonadIO m, MonadTransmission m, MonadThrow m) => (MonadIO m, MonadTransmission m, MonadThrow m) =>
m Html m Html
getTransmissionTorrentsTable = do getTransmissionTorrentsTable = do
let fields = ["id", "name", "files", "fileStats"] let fields = ["hashString", "name", "activity", "percentDone", "percentComplete", "eta"]
resp <- doTransmissionRequest transmissionConnectionConfig (requestListAllTorrents fields) resp <- doTransmissionRequest transmissionConnectionConfig (transmissionRequestListAllTorrents fields)
case resp.result of case resp.result of
TransmissionResponseFailure err -> appThrowTree (nestedError "Transmission RPC error" $ singleError $ newError err) TransmissionResponseFailure err -> appThrowTree (nestedError "Transmission RPC error" $ singleError $ newError err)
TransmissionResponseSuccess -> TransmissionResponseSuccess ->
@ -195,9 +218,10 @@ getTransmissionTorrentsTable = do
pure $ pure $
toTable toTable
( a ( a
& List.sortOn (\m -> m & Map.lookup "percentDone" & fromMaybe (Json.Number 0))
<&> Map.toList <&> Map.toList
-- TODO -- TODO
& List.take 3 & List.take 100
) )
zipNonEmpty :: NonEmpty a -> NonEmpty b -> NonEmpty (a, b) 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 "host" Text "port" Text
transmissionConnectionConfig = (T2 (label @"host" "localhost") (label @"port" "9091")) transmissionConnectionConfig = (T2 (label @"host" "localhost") (label @"port" "9091"))
requestListAllTorrents :: [Text] -> TransmissionRequest transmissionRequestListAllTorrents :: [Text] -> TransmissionRequest
requestListAllTorrents fields = transmissionRequestListAllTorrents fields =
TransmissionRequest TransmissionRequest
{ method = "torrent-get", { method = "torrent-get",
arguments = arguments =
@ -266,6 +290,33 @@ requestListAllTorrents fields =
tag = Nothing 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 data TransmissionResponse = TransmissionResponse
{ result :: TransmissionResponseStatus, { result :: TransmissionResponseStatus,
arguments :: Map Text Json.Value, arguments :: Map Text Json.Value,
@ -348,12 +399,27 @@ redactedSearch ::
Json.Parse ErrorTree a -> Json.Parse ErrorTree a ->
m a m a
redactedSearch advanced = redactedSearch advanced =
redactedApiRequest redactedApiRequestJson
( T2 ( T2
(label @"action" "browse") (label @"action" "browse")
(label @"actionArgs" ((advanced <&> second Just))) (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 :: Bool -> IO (Either TmpPg.StartError ())
test doSearch = test doSearch =
runAppWith $ do 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 :: MonadPostgres m => Transaction m (Label "numberOfRowsAffected" Natural)
migrate = do migrate = do
execute_ execute_
@ -507,6 +604,11 @@ migrate = do
UNIQUE(torrent_id) 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 -- inflect out values of the full json
CREATE OR REPLACE VIEW redacted.torrents AS CREATE OR REPLACE VIEW redacted.torrents AS
@ -518,7 +620,9 @@ migrate = do
( (full_json_result->'seeders')::integer*3 ( (full_json_result->'seeders')::integer*3
+ (full_json_result->'snatches')::integer) + (full_json_result->'snatches')::integer)
AS seeding_weight, AS seeding_weight,
t.full_json_result t.full_json_result,
t.torrent_file,
t.transmission_torrent_hash
FROM redacted.torrents_json t; FROM redacted.torrents_json t;
CREATE INDEX IF NOT EXISTS torrents_json_seeding ON redacted.torrents_json(((full_json_result->'seeding')::integer)); 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 data TorrentData = TorrentData
{ groupId :: Int, { groupId :: Int,
torrentId :: Int, torrentId :: Int,
torrentIdDb :: Int,
seedingWeight :: Int, seedingWeight :: Int,
torrentJson :: Json.Value, 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 getTorrentById dat = do
queryWith queryWith
[sql| [sql|
SELECT full_json_result FROM redacted.torrents SELECT full_json_result FROM redacted.torrents
WHERE id = ?::integer WHERE torrent_id = ?::integer
|] |]
(getLabel @"id" dat) (getLabel @"torrentId" dat)
(Dec.json Json.asValue) (Dec.json Json.asValue)
>>= ensureSingleRow >>= ensureSingleRow
@ -553,11 +662,12 @@ getBestTorrents = do
SELECT * FROM ( SELECT * FROM (
SELECT DISTINCT ON (group_id) SELECT DISTINCT ON (group_id)
tg.group_id, tg.group_id,
t.id,
t.torrent_id, t.torrent_id,
seeding_weight, seeding_weight,
t.full_json_result AS torrent_json, 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 FROM redacted.torrents t
JOIN redacted.torrent_groups tg ON tg.id = t.torrent_group JOIN redacted.torrent_groups tg ON tg.id = t.torrent_group
ORDER BY group_id, seeding_weight DESC ORDER BY group_id, seeding_weight DESC
@ -567,7 +677,6 @@ getBestTorrents = do
() ()
( do ( do
groupId <- Dec.fromField @Int groupId <- Dec.fromField @Int
torrentIdDb <- Dec.fromField @Int
torrentId <- Dec.fromField @Int torrentId <- Dec.fromField @Int
seedingWeight <- Dec.fromField @Int seedingWeight <- Dec.fromField @Int
torrentJson <- Dec.json Json.asValue torrentJson <- Dec.json Json.asValue
@ -577,7 +686,18 @@ getBestTorrents = do
groupName <- Json.keyLabel @"groupName" "groupName" Json.asText groupName <- Json.keyLabel @"groupName" "groupName" Json.asText
pure $ T2 artist groupName 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 hush :: Either a1 a2 -> Maybe a2
@ -608,9 +728,8 @@ redactedApiRequest ::
HasField "actionArgs" p [(ByteString, Maybe ByteString)] HasField "actionArgs" p [(ByteString, Maybe ByteString)]
) => ) =>
p -> p ->
Json.Parse ErrorTree a -> m ByteString
m a redactedApiRequest dat = do
redactedApiRequest dat parse = do
authKey <- runCommandExpect0 "pass" ["internet/redacted/api-keys/whatcd-resolver"] authKey <- runCommandExpect0 "pass" ["internet/redacted/api-keys/whatcd-resolver"]
let req = let req =
[fmt|https://redacted.ch/ajax.php|] [fmt|https://redacted.ch/ajax.php|]
@ -623,6 +742,19 @@ redactedApiRequest dat parse = do
200 -> Right $ resp & Http.responseBody 200 -> Right $ resp & Http.responseBody
_ -> Left [fmt|Redacted returned an non-200 error code: {resp & showPretty}|] _ -> 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 >>= ( Json.parseStrict parse
>>> first (Json.parseErrorTree "could not parse redacted response") >>> first (Json.parseErrorTree "could not parse redacted response")
>>> assertM id >>> assertM id