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:
parent
4ec27ed088
commit
9504914a59
1 changed files with 177 additions and 45 deletions
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue