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:
Profpatsch 2023-06-29 13:18:18 +02:00
parent 5cfdd259df
commit 68a9037d17
5 changed files with 462 additions and 81 deletions

View 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
}

View file

@ -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)

View file

@ -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)))

View file

@ -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

View file

@ -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