feat(users/Profpatsch/whatcd-resolver): Cache searches & web UI
When looking up stuff on the tracker, cache the results in our database and display the best torrent matches in a simple web UI. Change-Id: Iba8417fbdd3ea812765ab0289a1d5b03b7c2be81 Reviewed-on: https://cl.tvl.fyi/c/depot/+/8857 Reviewed-by: Profpatsch <mail@profpatsch.de> Tested-by: BuildkiteCI
This commit is contained in:
Profpatsch
parent
70da4318f5
commit
5cfdd259df
2 changed files with 272 additions and 95 deletions
|
|
@ -4,7 +4,6 @@
|
||||||
|
|
||||||
module WhatcdResolver where
|
module WhatcdResolver where
|
||||||
|
|
||||||
import Control.Concurrent (threadDelay)
|
|
||||||
import Control.Monad.Logger qualified as Logger
|
import Control.Monad.Logger qualified as Logger
|
||||||
import Control.Monad.Logger.CallStack
|
import Control.Monad.Logger.CallStack
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
|
|
@ -25,6 +24,7 @@ import Database.PostgreSQL.Simple.Types qualified as Postgres
|
||||||
import Database.Postgres.Temp qualified as TmpPg
|
import Database.Postgres.Temp qualified as TmpPg
|
||||||
import FieldParser qualified as Field
|
import FieldParser qualified as Field
|
||||||
import GHC.Records (HasField (..))
|
import GHC.Records (HasField (..))
|
||||||
|
import IHP.HSX.QQ (hsx)
|
||||||
import Json qualified
|
import Json qualified
|
||||||
import Json.Enc (Enc)
|
import Json.Enc (Enc)
|
||||||
import Json.Enc qualified as Enc
|
import Json.Enc qualified as Enc
|
||||||
|
|
@ -32,6 +32,9 @@ import Label
|
||||||
import Network.HTTP.Conduit qualified as Http
|
import Network.HTTP.Conduit qualified as Http
|
||||||
import Network.HTTP.Simple qualified as Http
|
import Network.HTTP.Simple qualified as Http
|
||||||
import Network.HTTP.Types
|
import Network.HTTP.Types
|
||||||
|
import Network.HTTP.Types qualified as Http
|
||||||
|
import Network.Wai qualified as Wai
|
||||||
|
import Network.Wai.Handler.Warp qualified as Warp
|
||||||
import PossehlAnalyticsPrelude
|
import PossehlAnalyticsPrelude
|
||||||
import Postgres.Decoder qualified as Dec
|
import Postgres.Decoder qualified as Dec
|
||||||
import Postgres.MonadPostgres
|
import Postgres.MonadPostgres
|
||||||
|
|
@ -41,8 +44,95 @@ import System.Directory qualified as Dir
|
||||||
import System.Directory qualified as Xdg
|
import System.Directory qualified as Xdg
|
||||||
import System.FilePath ((</>))
|
import System.FilePath ((</>))
|
||||||
import System.IO qualified as IO
|
import System.IO qualified as IO
|
||||||
|
import Text.Blaze.Html (Html, (!))
|
||||||
|
import Text.Blaze.Html.Renderer.Utf8 qualified as Html
|
||||||
|
import Text.Blaze.Html5 qualified as Html
|
||||||
|
import Text.Blaze.Html5.Attributes qualified as Attr
|
||||||
import UnliftIO
|
import UnliftIO
|
||||||
|
|
||||||
|
htmlUi :: App ()
|
||||||
|
htmlUi = do
|
||||||
|
withRunInIO $ \runInIO -> Warp.run 8080 $ \req resp -> do
|
||||||
|
let h = resp . Wai.responseLBS Http.ok200 []
|
||||||
|
case req & Wai.pathInfo of
|
||||||
|
[] -> h =<< runInIO mainHtml
|
||||||
|
["snips", "song"] -> h snipsSong
|
||||||
|
_ -> h =<< runInIO mainHtml
|
||||||
|
where
|
||||||
|
tableData =
|
||||||
|
( [ "Group ID",
|
||||||
|
"Torrent ID",
|
||||||
|
"Artist",
|
||||||
|
"Name",
|
||||||
|
"Weight",
|
||||||
|
"Torrent"
|
||||||
|
],
|
||||||
|
\t ->
|
||||||
|
[ Enc.int t.groupId,
|
||||||
|
Enc.int t.torrentId,
|
||||||
|
Enc.text t.torrentGroupJson.artist,
|
||||||
|
Enc.text t.torrentGroupJson.groupName,
|
||||||
|
Enc.int t.seedingWeight,
|
||||||
|
Enc.value t.torrentJson
|
||||||
|
]
|
||||||
|
)
|
||||||
|
|
||||||
|
mkTable :: ([Text], t -> [Enc]) -> [t] -> Html
|
||||||
|
mkTable f ts =
|
||||||
|
do
|
||||||
|
let headers = Html.thead (fst f <&> Html.toHtml @Text <&> Html.th & mconcat)
|
||||||
|
let keys = fst f <&> Text.toLower <&> Text.replace " " "_"
|
||||||
|
let json = Enc.list (\t -> Enc.object (zip keys (t & snd f))) ts
|
||||||
|
let tableDataScript =
|
||||||
|
Html.script
|
||||||
|
! Attr.type_ "application/json"
|
||||||
|
! Attr.id "table-data"
|
||||||
|
$ (json & Enc.encToBytesUtf8 & bytesToTextUtf8Unsafe & Html.text)
|
||||||
|
[hsx|
|
||||||
|
{tableDataScript}
|
||||||
|
<table id="table" class="table">
|
||||||
|
{headers}
|
||||||
|
<tbody>
|
||||||
|
</tbody>
|
||||||
|
</table>
|
||||||
|
<script>
|
||||||
|
var tableData = JSON.parse($("#table-data").text());
|
||||||
|
$("table").dynatable({
|
||||||
|
dataset: {
|
||||||
|
records: tableData
|
||||||
|
}
|
||||||
|
} )
|
||||||
|
</script>
|
||||||
|
|]
|
||||||
|
mainHtml = runTransaction $ do
|
||||||
|
bestTorrents <- getBestTorrents
|
||||||
|
pure $
|
||||||
|
Html.renderHtml $
|
||||||
|
Html.docTypeHtml
|
||||||
|
[hsx|
|
||||||
|
<head>
|
||||||
|
<meta charset="utf-8">
|
||||||
|
<meta name="viewport" content="width=device-width, initial-scale=1">
|
||||||
|
|
||||||
|
<script src="https://cdnjs.cloudflare.com/ajax/libs/jquery/3.7.0/jquery.min.js" integrity="sha512-3gJwYpMe3QewGELv8k/BX9vcqhryRdzRMxVfq6ngyWXwo03GFEzjsUm8Q7RZcHPHksttq7/GFoxjCVUjkjvPdw==" crossorigin="anonymous" referrerpolicy="no-referrer"></script>
|
||||||
|
<link href="https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/css/bootstrap.min.css" rel="stylesheet" integrity="sha384-9ndCyUaIbzAi2FUVXJi0CjmCapSmO7SnpJef0486qhLnuZ2cdeRhO02iuK6FUUVM" crossorigin="anonymous">
|
||||||
|
<script src="https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/js/bootstrap.bundle.min.js" integrity="sha384-geWF76RCwLtnZ8qwWowPQNguL3RmwHVBC9FhGdlKrxdiJJigb/j/68SIy3Te4Bkz" crossorigin="anonymous"></script>
|
||||||
|
<script src="https://cdnjs.cloudflare.com/ajax/libs/Dynatable/0.3.1/jquery.dynatable.min.js" integrity="sha512-KJdW8vGZWsRYrhMlZ6d8dR/fbLBK/aPOI0xDTEnGysk8TiFffc0S6TLSeSg7Lzk84GhBu9wI+qQatBrnTAeEYQ==" crossorigin="anonymous" referrerpolicy="no-referrer"></script>
|
||||||
|
<script src="https://unpkg.com/htmx.org@1.9.2" integrity="sha384-L6OqL9pRWyyFU3+/bjdSri+iIphTN/bvYyM37tICVyOJkWZLpP2vGn6VUEXgzg6h" crossorigin="anonymous"></script>
|
||||||
|
<script>
|
||||||
|
$.dynatableSetup({
|
||||||
|
table: {
|
||||||
|
defaultColumnIdStyle: 'underscore'
|
||||||
|
}
|
||||||
|
});
|
||||||
|
</script>
|
||||||
|
</head>
|
||||||
|
<body>
|
||||||
|
{mkTable tableData bestTorrents}
|
||||||
|
</body>
|
||||||
|
|]
|
||||||
|
snipsSong = todo
|
||||||
|
|
||||||
data TransmissionRequest = TransmissionRequest
|
data TransmissionRequest = TransmissionRequest
|
||||||
{ method :: Text,
|
{ method :: Text,
|
||||||
arguments :: Map Text Enc,
|
arguments :: Map Text Enc,
|
||||||
|
|
@ -50,13 +140,15 @@ data TransmissionRequest = TransmissionRequest
|
||||||
}
|
}
|
||||||
deriving stock (Show)
|
deriving stock (Show)
|
||||||
|
|
||||||
|
testTransmission req = runAppWith $ doTransmissionRequest (T2 (label @"host" "localhost") (label @"port" "9091")) req >>= liftIO . printPretty
|
||||||
|
|
||||||
requestListAllTorrents :: TransmissionRequest
|
requestListAllTorrents :: TransmissionRequest
|
||||||
requestListAllTorrents =
|
requestListAllTorrents =
|
||||||
TransmissionRequest
|
TransmissionRequest
|
||||||
{ method = "torrent-get",
|
{ method = "torrent-get",
|
||||||
arguments =
|
arguments =
|
||||||
Map.fromList
|
Map.fromList
|
||||||
[ ("fields", Enc.list Enc.text ["id", "name"])
|
[ ("fields", Enc.list Enc.text ["id", "name", "files", "fileStats"])
|
||||||
],
|
],
|
||||||
tag = Nothing
|
tag = Nothing
|
||||||
}
|
}
|
||||||
|
|
@ -149,22 +241,27 @@ redactedSearch advanced =
|
||||||
(label @"actionArgs" ((advanced <&> second Just)))
|
(label @"actionArgs" ((advanced <&> second Just)))
|
||||||
)
|
)
|
||||||
|
|
||||||
test :: IO (Either TmpPg.StartError a)
|
test :: Bool -> IO (Either TmpPg.StartError ())
|
||||||
test =
|
test doSearch =
|
||||||
runAppWith $ do
|
runAppWith $ do
|
||||||
_ <- runTransaction migrate
|
_ <- runTransaction migrate
|
||||||
|
when doSearch $ do
|
||||||
transaction <- bla
|
transaction <- bla
|
||||||
runTransaction transaction
|
_ <- runTransaction transaction
|
||||||
fix
|
pure ()
|
||||||
( \io -> do
|
htmlUi
|
||||||
logInfo "delay"
|
|
||||||
liftIO $ threadDelay 10_000_000
|
|
||||||
io
|
|
||||||
)
|
|
||||||
|
|
||||||
bla :: (MonadThrow m, MonadIO m, MonadLogger m, MonadPostgres m) => m (Transaction m [Label "numberOfRowsAffected" Natural])
|
-- fix
|
||||||
bla =
|
-- ( \io -> do
|
||||||
redactedSearch
|
-- logInfo "delay"
|
||||||
|
-- liftIO $ threadDelay 10_000_000
|
||||||
|
-- io
|
||||||
|
-- )
|
||||||
|
|
||||||
|
bla :: (MonadThrow m, MonadIO m, MonadLogger m, MonadPostgres m) => m (Transaction m ())
|
||||||
|
bla = do
|
||||||
|
t1 <-
|
||||||
|
realbla
|
||||||
[ ("searchstr", "cherish"),
|
[ ("searchstr", "cherish"),
|
||||||
("artistname", "kirinji"),
|
("artistname", "kirinji"),
|
||||||
-- ("year", "1982"),
|
-- ("year", "1982"),
|
||||||
|
|
@ -172,17 +269,35 @@ bla =
|
||||||
-- ("releasetype", "album"),
|
-- ("releasetype", "album"),
|
||||||
("order_by", "year")
|
("order_by", "year")
|
||||||
]
|
]
|
||||||
|
t2 <-
|
||||||
|
realbla
|
||||||
|
[ ("searchstr", "thriller"),
|
||||||
|
("artistname", "michael jackson"),
|
||||||
|
-- ("year", "1982"),
|
||||||
|
-- ("format", "MP3"),
|
||||||
|
-- ("releasetype", "album"),
|
||||||
|
("order_by", "year")
|
||||||
|
]
|
||||||
|
pure (t1 >> t2)
|
||||||
|
where
|
||||||
|
realbla x =
|
||||||
|
redactedSearch
|
||||||
|
x
|
||||||
( do
|
( do
|
||||||
status <- Json.key "status" Json.asText
|
status <- Json.key "status" Json.asText
|
||||||
when (status /= "success") $ do
|
when (status /= "success") $ do
|
||||||
Json.throwCustomError [fmt|Status was not "success", but {status}|]
|
Json.throwCustomError [fmt|Status was not "success", but {status}|]
|
||||||
Json.key "response" $ do
|
Json.key "response" $ do
|
||||||
Json.key "results" $
|
Json.key "results" $
|
||||||
sequence
|
sequence_
|
||||||
<$> ( Json.eachInArray $ do
|
<$> ( Json.eachInArray $ do
|
||||||
groupId <- Json.key "groupId" (Json.asIntegral @_ @Int)
|
groupId <- Json.key "groupId" (Json.asIntegral @_ @Int)
|
||||||
groupName <- Json.key "groupName" Json.asText
|
groupName <- Json.key "groupName" Json.asText
|
||||||
fullJsonResult <- Json.asValue
|
fullJsonResult <-
|
||||||
|
Json.asObject
|
||||||
|
-- remove torrents cause they are inserted separately below
|
||||||
|
<&> KeyMap.filterWithKey (\k _ -> k /= "torrents")
|
||||||
|
<&> Json.Object
|
||||||
let insertTourGroup = do
|
let insertTourGroup = do
|
||||||
_ <-
|
_ <-
|
||||||
execute
|
execute
|
||||||
|
|
@ -215,13 +330,13 @@ bla =
|
||||||
_ <-
|
_ <-
|
||||||
execute
|
execute
|
||||||
[sql|
|
[sql|
|
||||||
DELETE FROM redacted.torrents
|
DELETE FROM redacted.torrents_json
|
||||||
WHERE torrent_id = ANY (?::integer[])
|
WHERE torrent_id = ANY (?::integer[])
|
||||||
|]
|
|]
|
||||||
(Only $ torrents & unzipT2 & (.torrentId) & PGArray)
|
(Only $ torrents & unzipT2 & (.torrentId) & PGArray)
|
||||||
execute
|
execute
|
||||||
[sql|
|
[sql|
|
||||||
INSERT INTO redacted.torrents
|
INSERT INTO redacted.torrents_json
|
||||||
(torrent_id, torrent_group, full_json_result)
|
(torrent_id, torrent_group, full_json_result)
|
||||||
SELECT inputs.torrent_id, static.torrent_group, inputs.full_json_result FROM
|
SELECT inputs.torrent_id, static.torrent_group, inputs.full_json_result FROM
|
||||||
(SELECT * FROM UNNEST(?::integer[], ?::jsonb[])) AS inputs(torrent_id, full_json_result)
|
(SELECT * FROM UNNEST(?::integer[], ?::jsonb[])) AS inputs(torrent_id, full_json_result)
|
||||||
|
|
@ -235,10 +350,92 @@ bla =
|
||||||
dat.tourGroupIdPg
|
dat.tourGroupIdPg
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
pure ()
|
||||||
pure (insertTourGroup >>= insertTorrents)
|
pure (insertTourGroup >>= insertTorrents)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
|
migrate :: MonadPostgres m => Transaction m (Label "numberOfRowsAffected" Natural)
|
||||||
|
migrate = do
|
||||||
|
execute_
|
||||||
|
[sql|
|
||||||
|
CREATE SCHEMA IF NOT EXISTS redacted;
|
||||||
|
|
||||||
|
CREATE TABLE IF NOT EXISTS redacted.torrent_groups (
|
||||||
|
id SERIAL PRIMARY KEY,
|
||||||
|
group_id INTEGER,
|
||||||
|
group_name TEXT,
|
||||||
|
full_json_result JSONB,
|
||||||
|
UNIQUE(group_id)
|
||||||
|
);
|
||||||
|
|
||||||
|
CREATE TABLE IF NOT EXISTS redacted.torrents_json (
|
||||||
|
id SERIAL PRIMARY KEY,
|
||||||
|
torrent_id INTEGER,
|
||||||
|
torrent_group SERIAL NOT NULL REFERENCES redacted.torrent_groups(id) ON DELETE CASCADE,
|
||||||
|
full_json_result JSONB,
|
||||||
|
UNIQUE(torrent_id)
|
||||||
|
);
|
||||||
|
|
||||||
|
-- inflect out values of the full json
|
||||||
|
|
||||||
|
CREATE OR REPLACE VIEW redacted.torrents AS
|
||||||
|
SELECT
|
||||||
|
t.id,
|
||||||
|
t.torrent_id,
|
||||||
|
t.torrent_group,
|
||||||
|
-- the seeding weight is used to find the best torrent in a group.
|
||||||
|
( (full_json_result->'seeders')::integer*3
|
||||||
|
+ (full_json_result->'snatches')::integer)
|
||||||
|
AS seeding_weight,
|
||||||
|
t.full_json_result
|
||||||
|
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_snatches ON redacted.torrents_json(((full_json_result->'snatches')::integer));
|
||||||
|
|]
|
||||||
|
|
||||||
|
data TorrentData = TorrentData
|
||||||
|
{ groupId :: Int,
|
||||||
|
torrentId :: Int,
|
||||||
|
seedingWeight :: Int,
|
||||||
|
torrentJson :: Json.Value,
|
||||||
|
torrentGroupJson :: T2 "artist" Text "groupName" Text
|
||||||
|
}
|
||||||
|
|
||||||
|
-- | 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
|
||||||
|
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
|
||||||
|
)
|
||||||
|
pure $ TorrentData {..}
|
||||||
|
)
|
||||||
|
|
||||||
hush :: Either a1 a2 -> Maybe a2
|
hush :: Either a1 a2 -> Maybe a2
|
||||||
hush (Left _) = Nothing
|
hush (Left _) = Nothing
|
||||||
hush (Right a) = Just a
|
hush (Right a) = Just a
|
||||||
|
|
@ -259,30 +456,6 @@ unzipT3 xs = xs <&> toTup & unzip3 & fromTup
|
||||||
fromTup :: (a, b, c) -> T3 l1 a l2 b l3 c
|
fromTup :: (a, b, c) -> T3 l1 a l2 b l3 c
|
||||||
fromTup (t1, t2, t3) = T3 (label @l1 t1) (label @l2 t2) (label @l3 t3)
|
fromTup (t1, t2, t3) = T3 (label @l1 t1) (label @l2 t2) (label @l3 t3)
|
||||||
|
|
||||||
migrate :: MonadPostgres m => Transaction m (Label "numberOfRowsAffected" Natural)
|
|
||||||
migrate = do
|
|
||||||
execute_
|
|
||||||
[sql|
|
|
||||||
CREATE SCHEMA IF NOT EXISTS redacted;
|
|
||||||
|
|
||||||
CREATE TABLE IF NOT EXISTS redacted.torrent_groups (
|
|
||||||
id SERIAL PRIMARY KEY,
|
|
||||||
group_id INTEGER,
|
|
||||||
group_name TEXT,
|
|
||||||
full_json_result JSONB,
|
|
||||||
UNIQUE(group_id)
|
|
||||||
);
|
|
||||||
|
|
||||||
CREATE TABLE IF NOT EXISTS redacted.torrents (
|
|
||||||
id SERIAL PRIMARY KEY,
|
|
||||||
torrent_id INTEGER,
|
|
||||||
torrent_group SERIAL NOT NULL REFERENCES redacted.torrent_groups(id),
|
|
||||||
full_json_result JSONB,
|
|
||||||
UNIQUE(torrent_id)
|
|
||||||
);
|
|
||||||
|
|
||||||
|]
|
|
||||||
|
|
||||||
redactedApiRequest ::
|
redactedApiRequest ::
|
||||||
( MonadThrow m,
|
( MonadThrow m,
|
||||||
MonadIO m,
|
MonadIO m,
|
||||||
|
|
|
||||||
|
|
@ -88,4 +88,8 @@ library
|
||||||
unliftio,
|
unliftio,
|
||||||
monad-logger,
|
monad-logger,
|
||||||
unix,
|
unix,
|
||||||
|
warp,
|
||||||
|
wai,
|
||||||
|
ihp-hsx,
|
||||||
|
blaze-html,
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue