feat(users/Profpatsch/whatcd-resolver): Add server-side search
Change-Id: Ifbbe3bca6988b0a090f456ae8d9dbaa808c89e19 Reviewed-on: https://cl.tvl.fyi/c/depot/+/8867 Tested-by: BuildkiteCI Reviewed-by: Profpatsch <mail@profpatsch.de>
This commit is contained in:
parent
5cfdd259df
commit
68a9037d17
5 changed files with 462 additions and 81 deletions
220
users/Profpatsch/whatcd-resolver/src/Multipart2.hs
Normal file
220
users/Profpatsch/whatcd-resolver/src/Multipart2.hs
Normal file
|
@ -0,0 +1,220 @@
|
|||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Multipart2 where
|
||||
|
||||
import Control.Monad.Logger (MonadLogger)
|
||||
import Control.Selective (Selective)
|
||||
import Data.ByteString.Lazy qualified as Lazy
|
||||
import Data.DList (DList)
|
||||
import Data.DList qualified as DList
|
||||
import Data.Error.Tree
|
||||
import Data.Functor.Compose
|
||||
import Data.List qualified as List
|
||||
import FieldParser
|
||||
import Label
|
||||
import Network.Wai qualified as Wai
|
||||
import Network.Wai.Parse qualified as Wai
|
||||
import PossehlAnalyticsPrelude
|
||||
import ValidationParseT
|
||||
|
||||
data FormFields = FormFields
|
||||
{ inputs :: [Wai.Param],
|
||||
files :: [MultipartFile Lazy.ByteString]
|
||||
}
|
||||
|
||||
-- | A parser for a HTTP multipart form (a form sent by the browser)
|
||||
newtype MultipartParseT backend m a = MultipartParseT
|
||||
{ unMultipartParseT ::
|
||||
FormFields ->
|
||||
m (Validation (NonEmpty Error) a)
|
||||
}
|
||||
deriving
|
||||
(Functor, Applicative, Selective)
|
||||
via (ValidationParseT FormFields m)
|
||||
|
||||
-- | After parsing a form, either we get the result or a list of form fields that failed
|
||||
newtype FormValidation a
|
||||
= FormValidation
|
||||
(DList FormValidationResult, Maybe a)
|
||||
deriving (Functor, Applicative, Selective) via (Compose ((,) (DList FormValidationResult)) Maybe)
|
||||
deriving stock (Show)
|
||||
|
||||
data FormValidationResult = FormValidationResult
|
||||
{ hasError :: Maybe Error,
|
||||
formFieldName :: ByteString,
|
||||
originalValue :: ByteString
|
||||
}
|
||||
deriving stock (Show)
|
||||
|
||||
mkFormValidationResult ::
|
||||
( HasField "formFieldName" form ByteString,
|
||||
HasField "originalValue" form ByteString
|
||||
) =>
|
||||
form ->
|
||||
Maybe Error ->
|
||||
FormValidationResult
|
||||
mkFormValidationResult form err =
|
||||
FormValidationResult
|
||||
{ hasError = err,
|
||||
formFieldName = form.formFieldName,
|
||||
originalValue = form.originalValue
|
||||
}
|
||||
|
||||
eitherToFormValidation ::
|
||||
( HasField "formFieldName" form ByteString,
|
||||
HasField "originalValue" form ByteString
|
||||
) =>
|
||||
form ->
|
||||
Either Error a ->
|
||||
FormValidation a
|
||||
eitherToFormValidation form = \case
|
||||
Left err ->
|
||||
FormValidation $ (DList.singleton $ mkFormValidationResult form (Just err), Nothing)
|
||||
Right a ->
|
||||
FormValidation $ ((DList.singleton $ mkFormValidationResult form Nothing), Just a)
|
||||
|
||||
failFormValidation ::
|
||||
( HasField "formFieldName" form ByteString,
|
||||
HasField "originalValue" form ByteString
|
||||
) =>
|
||||
form ->
|
||||
Error ->
|
||||
FormValidation a
|
||||
failFormValidation form err =
|
||||
FormValidation (DList.singleton $ mkFormValidationResult form (Just err), Nothing)
|
||||
|
||||
-- | Parse the multipart form or throw a user error with a descriptive error message.
|
||||
parseMultipartOrThrow ::
|
||||
(MonadLogger m, MonadIO m) =>
|
||||
(ErrorTree -> m a) ->
|
||||
MultipartParseT backend m a ->
|
||||
Wai.Request ->
|
||||
m a
|
||||
parseMultipartOrThrow throwF parser req = do
|
||||
-- TODO: this throws all errors with `error`, so leads to 500 on bad input …
|
||||
formFields <-
|
||||
liftIO $
|
||||
Wai.parseRequestBodyEx
|
||||
Wai.defaultParseRequestBodyOptions
|
||||
Wai.lbsBackEnd
|
||||
req
|
||||
parser.unMultipartParseT
|
||||
FormFields
|
||||
{ inputs = fst formFields,
|
||||
files = map fileDataToMultipartFile $ snd formFields
|
||||
}
|
||||
>>= \case
|
||||
Failure errs -> throwF (errorTree "Cannot parse the multipart form" errs)
|
||||
Success a -> pure a
|
||||
|
||||
-- | Parse the field out of the multipart message
|
||||
field :: Applicative m => ByteString -> FieldParser ByteString a -> MultipartParseT backend m a
|
||||
field fieldName fieldParser = MultipartParseT $ \mp ->
|
||||
mp.inputs
|
||||
& findMaybe (\input -> if fst input == fieldName then Just (snd input) else Nothing)
|
||||
& annotate [fmt|Field "{fieldName}" does not exist in the multipart form|]
|
||||
>>= runFieldParser fieldParser
|
||||
& eitherToListValidation
|
||||
& pure
|
||||
|
||||
-- | Parse the field out of the multipart message
|
||||
field' :: Applicative m => ByteString -> FieldParser ByteString a -> MultipartParseT backend m (FormValidation a)
|
||||
field' fieldName fieldParser = MultipartParseT $ \mp ->
|
||||
mp.inputs
|
||||
& findMaybe (\input -> if fst input == fieldName then Just $ snd input else Nothing)
|
||||
& annotate [fmt|Field "{fieldName}" does not exist in the multipart form|]
|
||||
<&> ( \originalValue ->
|
||||
originalValue
|
||||
& runFieldParser fieldParser
|
||||
& eitherToFormValidation
|
||||
( T2
|
||||
(label @"formFieldName" fieldName)
|
||||
(label @"originalValue" originalValue)
|
||||
)
|
||||
)
|
||||
& eitherToListValidation
|
||||
& pure
|
||||
|
||||
-- | Parse the field out of the multipart message, and into a 'Label' of the given name.
|
||||
fieldLabel :: forall lbl backend m a. Applicative m => ByteString -> FieldParser ByteString a -> MultipartParseT backend m (Label lbl a)
|
||||
fieldLabel fieldName fieldParser = label @lbl <$> field fieldName fieldParser
|
||||
|
||||
-- | Parse the field out of the multipart message, and into a 'Label' of the given name.
|
||||
fieldLabel' :: forall lbl backend m a. Applicative m => ByteString -> FieldParser ByteString a -> MultipartParseT backend m (FormValidation (Label lbl a))
|
||||
fieldLabel' fieldName fieldParser = fmap (label @lbl) <$> field' fieldName fieldParser
|
||||
|
||||
-- | parse all fields out of the multipart message, with the same parser
|
||||
allFields :: Applicative m => FieldParser (T2 "key" ByteString "value" ByteString) b -> MultipartParseT backend m [b]
|
||||
allFields fieldParser = MultipartParseT $ \mp ->
|
||||
mp.inputs
|
||||
<&> tupToT2 @"key" @"value"
|
||||
& traverseValidate (runFieldParser fieldParser)
|
||||
& eitherToValidation
|
||||
& pure
|
||||
|
||||
tupToT2 :: forall l1 l2 t1 t2. (t1, t2) -> T2 l1 t1 l2 t2
|
||||
tupToT2 (a, b) = T2 (label a) (label b)
|
||||
|
||||
-- | Parse a file by name out of the multipart message
|
||||
file ::
|
||||
Applicative m =>
|
||||
ByteString ->
|
||||
MultipartParseT backend m (MultipartFile Lazy.ByteString)
|
||||
file fieldName = MultipartParseT $ \mp ->
|
||||
mp.files
|
||||
& List.find (\input -> input.multipartNameAttribute == fieldName)
|
||||
& annotate [fmt|File "{fieldName}" does not exist in the multipart form|]
|
||||
& ( \case
|
||||
Left err -> Failure (singleton err)
|
||||
Right filePath -> Success filePath
|
||||
)
|
||||
& pure
|
||||
|
||||
-- | Return all files from the multipart message
|
||||
allFiles ::
|
||||
Applicative m =>
|
||||
MultipartParseT backend m [MultipartFile Lazy.ByteString]
|
||||
allFiles = MultipartParseT $ \mp -> do
|
||||
pure $ Success $ mp.files
|
||||
|
||||
-- | Ensure there is exactly one file and return it (ignoring the field name)
|
||||
exactlyOneFile ::
|
||||
Applicative m =>
|
||||
MultipartParseT backend m (MultipartFile Lazy.ByteString)
|
||||
exactlyOneFile = MultipartParseT $ \mp ->
|
||||
mp.files
|
||||
& \case
|
||||
[] -> pure $ failParse "Expected to receive a file, but the multipart form did not contain any files"
|
||||
[file_] -> pure $ Success file_
|
||||
more -> pure $ failParse [fmt|Expected to receive exactly one file, but the multipart form contained {List.length more} files|]
|
||||
where
|
||||
-- \| Fail to parse the multipart form with the given error message.
|
||||
failParse :: Text -> Validation (NonEmpty Error) a
|
||||
failParse = Failure . singleton . newError
|
||||
|
||||
newtype GetFileContent backend m content = GetFileContent
|
||||
{unGetFileContent :: (Wai.Request -> m (Either Error content))}
|
||||
|
||||
-- | A file field in a multipart message.
|
||||
data MultipartFile content = MultipartFile
|
||||
{ -- | @name@ attribute of the corresponding HTML @\<input\>@
|
||||
multipartNameAttribute :: ByteString,
|
||||
-- | name of the file on the client's disk
|
||||
fileNameOnDisk :: ByteString,
|
||||
-- | MIME type for the file
|
||||
fileMimeType :: ByteString,
|
||||
-- | Content of the file
|
||||
content :: content
|
||||
}
|
||||
|
||||
-- | Convert the multipart library struct of a multipart file to our own.
|
||||
fileDataToMultipartFile ::
|
||||
Wai.File Lazy.ByteString ->
|
||||
(MultipartFile Lazy.ByteString)
|
||||
fileDataToMultipartFile (multipartNameAttribute, file_) = do
|
||||
MultipartFile
|
||||
{ multipartNameAttribute,
|
||||
fileNameOnDisk = file_.fileName,
|
||||
fileMimeType = file_.fileContentType,
|
||||
content = file_.fileContent
|
||||
}
|
|
@ -369,6 +369,9 @@ pgFormatQueryByteString queryBytes = do
|
|||
logDebug [fmt|pg_format stdout: stderr|]
|
||||
pure (queryBytes & bytesToTextUtf8Lenient)
|
||||
|
||||
instance (ToField t1) => ToRow (Label l1 t1) where
|
||||
toRow t2 = toRow $ PG.Only $ getField @l1 t2
|
||||
|
||||
instance (ToField t1, ToField t2) => ToRow (T2 l1 t1 l2 t2) where
|
||||
toRow t2 = toRow (getField @l1 t2, getField @l2 t2)
|
||||
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
module ValidationParseT where
|
||||
|
||||
import Control.Selective (Selective)
|
||||
import Data.Functor.Compose (Compose (..))
|
||||
import PossehlAnalyticsPrelude
|
||||
|
||||
|
@ -8,7 +9,7 @@ import PossehlAnalyticsPrelude
|
|||
-- Use with DerivingVia. Grep codebase for examples.
|
||||
newtype ValidationParseT env m a = ValidationParseT {unValidationParseT :: env -> m (Validation (NonEmpty Error) a)}
|
||||
deriving
|
||||
(Functor, Applicative)
|
||||
(Functor, Applicative, Selective)
|
||||
via ( Compose
|
||||
((->) env)
|
||||
(Compose m (Validation (NonEmpty Error)))
|
||||
|
|
|
@ -4,6 +4,7 @@
|
|||
|
||||
module WhatcdResolver where
|
||||
|
||||
import Control.Category qualified as Cat
|
||||
import Control.Monad.Logger qualified as Logger
|
||||
import Control.Monad.Logger.CallStack
|
||||
import Control.Monad.Reader
|
||||
|
@ -29,6 +30,7 @@ import Json qualified
|
|||
import Json.Enc (Enc)
|
||||
import Json.Enc qualified as Enc
|
||||
import Label
|
||||
import Multipart2 qualified as Multipart
|
||||
import Network.HTTP.Conduit qualified as Http
|
||||
import Network.HTTP.Simple qualified as Http
|
||||
import Network.HTTP.Types
|
||||
|
@ -53,11 +55,34 @@ 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
|
||||
let h act = do
|
||||
res <- runInIO act
|
||||
resp . Wai.responseLBS Http.ok200 [("Content-Type", "text/html")] . Html.renderHtml $ res
|
||||
let mp parser =
|
||||
Multipart.parseMultipartOrThrow
|
||||
appThrowTree
|
||||
parser
|
||||
req
|
||||
|
||||
case req & Wai.pathInfo & Text.intercalate "/" of
|
||||
"" -> h mainHtml
|
||||
"snips/song" -> h snipsSong
|
||||
"snips/redacted/search" -> do
|
||||
h $ do
|
||||
dat <-
|
||||
mp
|
||||
( do
|
||||
label @"searchstr" <$> Multipart.field "redacted-search" Cat.id
|
||||
)
|
||||
snipsRedactedSearch dat
|
||||
"snips/redacted/torrentDataJson" -> h $ do
|
||||
dat <-
|
||||
mp
|
||||
( do
|
||||
label @"id" <$> Multipart.field "torrent-id" ((Field.utf8 >>> Field.signedDecimal >>> Field.bounded @Int "int"))
|
||||
)
|
||||
mkVal <$> (runTransaction $ getTorrentById dat)
|
||||
_ -> h mainHtml
|
||||
where
|
||||
tableData =
|
||||
( [ "Group ID",
|
||||
|
@ -78,17 +103,16 @@ htmlUi = do
|
|||
)
|
||||
|
||||
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|
|
||||
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}
|
||||
|
@ -104,16 +128,15 @@ htmlUi = do
|
|||
} )
|
||||
</script>
|
||||
|]
|
||||
|
||||
mainHtml = runTransaction $ do
|
||||
bestTorrents <- getBestTorrents
|
||||
pure $
|
||||
Html.renderHtml $
|
||||
Html.docTypeHtml
|
||||
[hsx|
|
||||
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>
|
||||
|
@ -128,11 +151,107 @@ htmlUi = do
|
|||
</script>
|
||||
</head>
|
||||
<body>
|
||||
<form
|
||||
hx-post="/snips/redacted/search"
|
||||
hx-target="#redacted-search-results">
|
||||
<label for="redacted-search">Redacted Search</label>
|
||||
<input
|
||||
id="redacted-search"
|
||||
type="text"
|
||||
name="redacted-search" />
|
||||
<button type="submit">Search</button>
|
||||
</form>
|
||||
<div id="redacted-search-results"></div>
|
||||
{mkTable tableData bestTorrents}
|
||||
</body>
|
||||
|]
|
||||
snipsSong = todo
|
||||
|
||||
snipsRedactedSearch ::
|
||||
( MonadLogger m,
|
||||
MonadIO m,
|
||||
MonadThrow m,
|
||||
MonadPostgres m,
|
||||
HasField "searchstr" r ByteString
|
||||
) =>
|
||||
r ->
|
||||
m Html
|
||||
snipsRedactedSearch dat = do
|
||||
t <-
|
||||
redactedSearchAndInsert
|
||||
[ ("searchstr", dat.searchstr)
|
||||
]
|
||||
best :: [TorrentData] <- runTransaction $ do
|
||||
t
|
||||
getBestTorrents
|
||||
let bestRows =
|
||||
best
|
||||
& foldMap
|
||||
( \b -> do
|
||||
[hsx|
|
||||
<tr>
|
||||
<td>{Html.toHtml @Int b.groupId}</td>
|
||||
<td>{Html.toHtml @Text b.torrentGroupJson.artist}</td>
|
||||
<td>{Html.toHtml @Text b.torrentGroupJson.groupName}</td>
|
||||
<td>{Html.toHtml @Int b.seedingWeight}</td>
|
||||
<td><details hx-post="snips/redacted/torrentDataJson" hx-vals={Enc.encToBytesUtf8 $ Enc.object [("torrent-id", Enc.int b.torrentIdDb)]}></details></td>
|
||||
</tr>
|
||||
|]
|
||||
)
|
||||
pure $
|
||||
[hsx|
|
||||
<table class="table">
|
||||
<thead>
|
||||
<th>Group ID</th>
|
||||
<th>Artist</th>
|
||||
<th>Name</th>
|
||||
<th>Weight</th>
|
||||
<th>Torrent</th>
|
||||
<th>Torrent Group</th>
|
||||
</thead>
|
||||
<tbody>
|
||||
{bestRows}
|
||||
</tbody>
|
||||
</table>
|
||||
|]
|
||||
|
||||
mkVal :: Json.Value -> Html
|
||||
mkVal = \case
|
||||
Json.Number n -> Html.toHtml @Text $ showToText n
|
||||
Json.String s -> Html.toHtml @Text s
|
||||
Json.Bool True -> [hsx|<em>true</em>|]
|
||||
Json.Bool False -> [hsx|<em>false</em>|]
|
||||
Json.Null -> [hsx|<em>null</em>|]
|
||||
Json.Array arr ->
|
||||
arr
|
||||
& foldMap (\el -> Html.ul $ mkVal el)
|
||||
& Html.ol
|
||||
Json.Object obj ->
|
||||
obj
|
||||
& KeyMap.toMapText
|
||||
& Map.toList
|
||||
& foldMap (\(k, v) -> Html.dt (Html.toHtml @Text k <> Html.dd (mkVal v)))
|
||||
& Html.dl
|
||||
|
||||
toTable :: [[(Text, Json.Value)]] -> Html
|
||||
toTable xs =
|
||||
case xs & nonEmpty of
|
||||
Nothing ->
|
||||
[hsx|<p>No results.</p>|]
|
||||
Just xs' -> do
|
||||
let headers = xs' & NonEmpty.head <&> fst <&> (\h -> [hsx|<th>{h}</th>|]) & mconcat
|
||||
let vals = xs' <&> fmap (mkVal . snd)
|
||||
[hsx|
|
||||
<table class="table">
|
||||
<thead>
|
||||
{headers}
|
||||
</thead>
|
||||
<tbody>
|
||||
{vals}
|
||||
</tbody>
|
||||
</table>
|
||||
|]
|
||||
|
||||
data TransmissionRequest = TransmissionRequest
|
||||
{ method :: Text,
|
||||
arguments :: Map Text Enc,
|
||||
|
@ -140,6 +259,7 @@ data TransmissionRequest = TransmissionRequest
|
|||
}
|
||||
deriving stock (Show)
|
||||
|
||||
testTransmission :: TransmissionRequest -> IO (Either TmpPg.StartError ())
|
||||
testTransmission req = runAppWith $ doTransmissionRequest (T2 (label @"host" "localhost") (label @"port" "9091")) req >>= liftIO . printPretty
|
||||
|
||||
requestListAllTorrents :: TransmissionRequest
|
||||
|
@ -261,7 +381,7 @@ test doSearch =
|
|||
bla :: (MonadThrow m, MonadIO m, MonadLogger m, MonadPostgres m) => m (Transaction m ())
|
||||
bla = do
|
||||
t1 <-
|
||||
realbla
|
||||
redactedSearchAndInsert
|
||||
[ ("searchstr", "cherish"),
|
||||
("artistname", "kirinji"),
|
||||
-- ("year", "1982"),
|
||||
|
@ -269,8 +389,17 @@ bla = do
|
|||
-- ("releasetype", "album"),
|
||||
("order_by", "year")
|
||||
]
|
||||
t3 <-
|
||||
redactedSearchAndInsert
|
||||
[ ("searchstr", "mouss et hakim"),
|
||||
("artistname", "mouss et hakim"),
|
||||
-- ("year", "1982"),
|
||||
-- ("format", "MP3"),
|
||||
-- ("releasetype", "album"),
|
||||
("order_by", "year")
|
||||
]
|
||||
t2 <-
|
||||
realbla
|
||||
redactedSearchAndInsert
|
||||
[ ("searchstr", "thriller"),
|
||||
("artistname", "michael jackson"),
|
||||
-- ("year", "1982"),
|
||||
|
@ -278,82 +407,91 @@ bla = do
|
|||
-- ("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|
|
||||
pure (t1 >> t2 >> t3)
|
||||
|
||||
redactedSearchAndInsert ::
|
||||
( MonadLogger m1,
|
||||
MonadIO m1,
|
||||
MonadThrow m1,
|
||||
MonadPostgres m2,
|
||||
MonadThrow m2
|
||||
) =>
|
||||
[(ByteString, ByteString)] ->
|
||||
m1 (Transaction m2 ())
|
||||
redactedSearchAndInsert 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|
|
||||
[ ( 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|
|
||||
(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 ()
|
||||
pure (insertTourGroup >>= insertTorrents)
|
||||
)
|
||||
)
|
||||
( 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
|
||||
|
@ -398,11 +536,23 @@ migrate = do
|
|||
data TorrentData = TorrentData
|
||||
{ groupId :: Int,
|
||||
torrentId :: Int,
|
||||
torrentIdDb :: Int,
|
||||
seedingWeight :: Int,
|
||||
torrentJson :: Json.Value,
|
||||
torrentGroupJson :: T2 "artist" Text "groupName" Text
|
||||
}
|
||||
|
||||
getTorrentById :: (MonadPostgres m, HasField "id" r Int, MonadThrow m) => r -> Transaction m Json.Value
|
||||
getTorrentById dat = do
|
||||
queryWith
|
||||
[sql|
|
||||
SELECT full_json_result FROM redacted.torrents
|
||||
WHERE id = ?::integer
|
||||
|]
|
||||
(getLabel @"id" dat)
|
||||
(Dec.json Json.asValue)
|
||||
>>= ensureSingleRow
|
||||
|
||||
-- | Find the best torrent for each torrent group (based on the seeding_weight)
|
||||
getBestTorrents :: MonadPostgres m => Transaction m [TorrentData]
|
||||
getBestTorrents = do
|
||||
|
@ -411,6 +561,7 @@ getBestTorrents = do
|
|||
SELECT * FROM (
|
||||
SELECT DISTINCT ON (group_id)
|
||||
tg.group_id,
|
||||
t.id,
|
||||
t.torrent_id,
|
||||
seeding_weight,
|
||||
t.full_json_result AS torrent_json,
|
||||
|
@ -424,6 +575,7 @@ getBestTorrents = do
|
|||
()
|
||||
( do
|
||||
groupId <- Dec.fromField @Int
|
||||
torrentIdDb <- Dec.fromField @Int
|
||||
torrentId <- Dec.fromField @Int
|
||||
seedingWeight <- Dec.fromField @Int
|
||||
torrentJson <- Dec.json Json.asValue
|
||||
|
|
|
@ -62,6 +62,7 @@ library
|
|||
Postgres.MonadPostgres
|
||||
Tool
|
||||
ValidationParseT
|
||||
Multipart2
|
||||
|
||||
build-depends:
|
||||
base >=4.15 && <5,
|
||||
|
@ -90,6 +91,10 @@ library
|
|||
unix,
|
||||
warp,
|
||||
wai,
|
||||
wai-extra,
|
||||
ihp-hsx,
|
||||
blaze-html,
|
||||
bytestring,
|
||||
dlist,
|
||||
selective
|
||||
|
||||
|
|
Loading…
Reference in a new issue