diff options
| author | Profpatsch <mail@profpatsch.de> | 2023-06-27T13·22+0200 |
|---|---|---|
| committer | Profpatsch <mail@profpatsch.de> | 2023-07-14T08·03+0000 |
| commit | 5cfdd259df88bc8ecc739b76c68943c7a45f5389 (patch) | |
| tree | ec8c7b2d5c3b1d597fec51ab169aa2dfce919a47 /users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs | |
| parent | 70da4318f5aeb8489847e28ff1b8430ef5a7ef28 (diff) | |
feat(users/Profpatsch/whatcd-resolver): Cache searches & web UI r/6416
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
Diffstat (limited to 'users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs')
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs | 363 |
1 files changed, 268 insertions, 95 deletions
diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index f79e4b0c6fed..c4aab4bee661 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -4,7 +4,6 @@ module WhatcdResolver where -import Control.Concurrent (threadDelay) import Control.Monad.Logger qualified as Logger import Control.Monad.Logger.CallStack import Control.Monad.Reader @@ -25,6 +24,7 @@ import Database.PostgreSQL.Simple.Types qualified as Postgres import Database.Postgres.Temp qualified as TmpPg import FieldParser qualified as Field import GHC.Records (HasField (..)) +import IHP.HSX.QQ (hsx) import Json qualified import Json.Enc (Enc) import Json.Enc qualified as Enc @@ -32,6 +32,9 @@ import Label import Network.HTTP.Conduit qualified as Http import Network.HTTP.Simple qualified as Http 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 Postgres.Decoder qualified as Dec import Postgres.MonadPostgres @@ -41,8 +44,95 @@ import System.Directory qualified as Dir import System.Directory qualified as Xdg import System.FilePath ((</>)) 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 +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 { method :: Text, arguments :: Map Text Enc, @@ -50,13 +140,15 @@ data TransmissionRequest = TransmissionRequest } deriving stock (Show) +testTransmission req = runAppWith $ doTransmissionRequest (T2 (label @"host" "localhost") (label @"port" "9091")) req >>= liftIO . printPretty + requestListAllTorrents :: TransmissionRequest requestListAllTorrents = TransmissionRequest { method = "torrent-get", arguments = Map.fromList - [ ("fields", Enc.list Enc.text ["id", "name"]) + [ ("fields", Enc.list Enc.text ["id", "name", "files", "fileStats"]) ], tag = Nothing } @@ -149,115 +241,119 @@ redactedSearch advanced = (label @"actionArgs" ((advanced <&> second Just))) ) -test :: IO (Either TmpPg.StartError a) -test = +test :: Bool -> IO (Either TmpPg.StartError ()) +test doSearch = runAppWith $ do _ <- runTransaction migrate - transaction <- bla - runTransaction transaction - fix - ( \io -> do - logInfo "delay" - liftIO $ threadDelay 10_000_000 - io - ) - -bla :: (MonadThrow m, MonadIO m, MonadLogger m, MonadPostgres m) => m (Transaction m [Label "numberOfRowsAffected" Natural]) -bla = - redactedSearch - [ ("searchstr", "cherish"), - ("artistname", "kirinji"), - -- ("year", "1982"), - -- ("format", "MP3"), - -- ("releasetype", "album"), - ("order_by", "year") - ] - ( do - status <- Json.key "status" Json.asText - when (status /= "success") $ do - Json.throwCustomError [fmt|Status was not "success", but {status}|] - Json.key "response" $ do - Json.key "results" $ - sequence - <$> ( Json.eachInArray $ do - groupId <- Json.key "groupId" (Json.asIntegral @_ @Int) - groupName <- Json.key "groupName" Json.asText - fullJsonResult <- Json.asValue - let insertTourGroup = do - _ <- - execute - [fmt| + when doSearch $ do + transaction <- bla + _ <- runTransaction transaction + pure () + htmlUi + +-- fix +-- ( \io -> do +-- 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"), + ("artistname", "kirinji"), + -- ("year", "1982"), + -- ("format", "MP3"), + -- ("releasetype", "album"), + ("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 + status <- Json.key "status" Json.asText + when (status /= "success") $ do + Json.throwCustomError [fmt|Status was not "success", but {status}|] + Json.key "response" $ do + Json.key "results" $ + sequence_ + <$> ( Json.eachInArray $ do + groupId <- Json.key "groupId" (Json.asIntegral @_ @Int) + groupName <- Json.key "groupName" Json.asText + fullJsonResult <- + Json.asObject + -- remove torrents cause they are inserted separately below + <&> KeyMap.filterWithKey (\k _ -> k /= "torrents") + <&> Json.Object + let insertTourGroup = do + _ <- + execute + [fmt| DELETE FROM redacted.torrent_groups WHERE group_id = ?::integer |] - (Only groupId) - executeManyReturningWith - [fmt| + (Only groupId) + executeManyReturningWith + [fmt| INSERT INTO redacted.torrent_groups ( group_id, group_name, full_json_result ) VALUES ( ?, ? , ? ) RETURNING (id) |] - [ ( groupId, - groupName, - fullJsonResult - ) - ] - (label @"tourGroupIdPg" <$> Dec.fromField @Int) - >>= ensureSingleRow - insertTorrents <- Json.key "torrents" $ do - torrents <- Json.eachInArray $ do - torrentId <- Json.keyLabel @"torrentId" "torrentId" (Json.asIntegral @_ @Int) - fullJsonResultT <- label @"fullJsonResult" <$> Json.asValue - pure $ T2 torrentId fullJsonResultT - pure $ \dat -> do - _ <- - execute - [sql| - DELETE FROM redacted.torrents + [ ( groupId, + groupName, + fullJsonResult + ) + ] + (label @"tourGroupIdPg" <$> Dec.fromField @Int) + >>= ensureSingleRow + insertTorrents <- Json.key "torrents" $ do + torrents <- Json.eachInArray $ do + torrentId <- Json.keyLabel @"torrentId" "torrentId" (Json.asIntegral @_ @Int) + fullJsonResultT <- label @"fullJsonResult" <$> Json.asValue + pure $ T2 torrentId fullJsonResultT + pure $ \dat -> do + _ <- + execute + [sql| + DELETE FROM redacted.torrents_json WHERE torrent_id = ANY (?::integer[]) |] - (Only $ torrents & unzipT2 & (.torrentId) & PGArray) - execute - [sql| - INSERT INTO redacted.torrents + (Only $ torrents & unzipT2 & (.torrentId) & PGArray) + execute + [sql| + INSERT INTO redacted.torrents_json (torrent_id, torrent_group, full_json_result) SELECT inputs.torrent_id, static.torrent_group, inputs.full_json_result FROM (SELECT * FROM UNNEST(?::integer[], ?::jsonb[])) AS inputs(torrent_id, full_json_result) CROSS JOIN (VALUES(?::integer)) as static(torrent_group) |] - ( torrents - & unzipT2 - & \t -> - ( t.torrentId & PGArray, - t.fullJsonResult & PGArray, - dat.tourGroupIdPg - ) - ) - pure (insertTourGroup >>= insertTorrents) - ) - ) - -hush :: Either a1 a2 -> Maybe a2 -hush (Left _) = Nothing -hush (Right a) = Just a - -unzipT2 :: forall l1 t1 l2 t2. [T2 l1 t1 l2 t2] -> T2 l1 [t1] l2 [t2] -unzipT2 xs = xs <&> toTup & unzip & fromTup - where - toTup :: forall a b. T2 a t1 b t2 -> (t1, t2) - toTup (T2 a b) = (getField @a a, getField @b b) - fromTup :: (a, b) -> T2 l1 a l2 b - fromTup (t1, t2) = T2 (label @l1 t1) (label @l2 t2) - -unzipT3 :: forall l1 t1 l2 t2 l3 t3. [T3 l1 t1 l2 t2 l3 t3] -> T3 l1 [t1] l2 [t2] l3 [t3] -unzipT3 xs = xs <&> toTup & unzip3 & fromTup - where - toTup :: forall a b c. T3 a t1 b t2 c t3 -> (t1, t2, t3) - toTup (T3 a b c) = (getField @a a, getField @b b, getField @c 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) + ( torrents + & unzipT2 + & \t -> + ( t.torrentId & PGArray, + t.fullJsonResult & PGArray, + dat.tourGroupIdPg + ) + ) + pure () + pure (insertTourGroup >>= insertTorrents) + ) + ) migrate :: MonadPostgres m => Transaction m (Label "numberOfRowsAffected" Natural) migrate = do @@ -273,16 +369,93 @@ migrate = do UNIQUE(group_id) ); - CREATE TABLE IF NOT EXISTS redacted.torrents ( + 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), + 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 (Left _) = Nothing +hush (Right a) = Just a + +unzipT2 :: forall l1 t1 l2 t2. [T2 l1 t1 l2 t2] -> T2 l1 [t1] l2 [t2] +unzipT2 xs = xs <&> toTup & unzip & fromTup + where + toTup :: forall a b. T2 a t1 b t2 -> (t1, t2) + toTup (T2 a b) = (getField @a a, getField @b b) + fromTup :: (a, b) -> T2 l1 a l2 b + fromTup (t1, t2) = T2 (label @l1 t1) (label @l2 t2) + +unzipT3 :: forall l1 t1 l2 t2 l3 t3. [T3 l1 t1 l2 t2 l3 t3] -> T3 l1 [t1] l2 [t2] l3 [t3] +unzipT3 xs = xs <&> toTup & unzip3 & fromTup + where + toTup :: forall a b c. T3 a t1 b t2 c t3 -> (t1, t2, t3) + toTup (T3 a b c) = (getField @a a, getField @b b, getField @c 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) + redactedApiRequest :: ( MonadThrow m, MonadIO m, |