From 68a9037d179b02f4736d088510721686d5798f81 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Thu, 29 Jun 2023 13:18:18 +0200 Subject: 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 --- users/Profpatsch/whatcd-resolver/src/Multipart2.hs | 220 +++++++++++++++ .../whatcd-resolver/src/Postgres/MonadPostgres.hs | 3 + .../whatcd-resolver/src/ValidationParseT.hs | 3 +- .../whatcd-resolver/src/WhatcdResolver.hs | 312 +++++++++++++++------ .../whatcd-resolver/whatcd-resolver.cabal | 5 + 5 files changed, 462 insertions(+), 81 deletions(-) create mode 100644 users/Profpatsch/whatcd-resolver/src/Multipart2.hs (limited to 'users') diff --git a/users/Profpatsch/whatcd-resolver/src/Multipart2.hs b/users/Profpatsch/whatcd-resolver/src/Multipart2.hs new file mode 100644 index 000000000000..17246546ab35 --- /dev/null +++ b/users/Profpatsch/whatcd-resolver/src/Multipart2.hs @@ -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 @\@ + 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 + } diff --git a/users/Profpatsch/whatcd-resolver/src/Postgres/MonadPostgres.hs b/users/Profpatsch/whatcd-resolver/src/Postgres/MonadPostgres.hs index 012cf0caaca8..e602ee287fa2 100644 --- a/users/Profpatsch/whatcd-resolver/src/Postgres/MonadPostgres.hs +++ b/users/Profpatsch/whatcd-resolver/src/Postgres/MonadPostgres.hs @@ -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) diff --git a/users/Profpatsch/whatcd-resolver/src/ValidationParseT.hs b/users/Profpatsch/whatcd-resolver/src/ValidationParseT.hs index 62322a0ac0bc..593b7ebf3918 100644 --- a/users/Profpatsch/whatcd-resolver/src/ValidationParseT.hs +++ b/users/Profpatsch/whatcd-resolver/src/ValidationParseT.hs @@ -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))) diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index c4aab4bee661..c33ddd62d6ca 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -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} {headers} @@ -104,16 +128,15 @@ htmlUi = do } ) |] + mainHtml = runTransaction $ do bestTorrents <- getBestTorrents pure $ - Html.renderHtml $ - Html.docTypeHtml - [hsx| + Html.docTypeHtml + [hsx| - @@ -128,11 +151,107 @@ htmlUi = do + + + + + +
{mkTable tableData bestTorrents} |] 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| + + + + + + + + |] + ) + pure $ + [hsx| +
{Html.toHtml @Int b.groupId}{Html.toHtml @Text b.torrentGroupJson.artist}{Html.toHtml @Text b.torrentGroupJson.groupName}{Html.toHtml @Int b.seedingWeight}
+ + + + + + + + + + {bestRows} + +
Group IDArtistNameWeightTorrentTorrent Group
+ |] + +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|true|] + Json.Bool False -> [hsx|false|] + Json.Null -> [hsx|null|] + 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|

No results.

|] + Just xs' -> do + let headers = xs' & NonEmpty.head <&> fst <&> (\h -> [hsx|{h}|]) & mconcat + let vals = xs' <&> fmap (mkVal . snd) + [hsx| + + + {headers} + + + {vals} + +
+ |] + 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 diff --git a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal index 58aebe943c7c..8b9dcee422b1 100644 --- a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal +++ b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal @@ -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 -- cgit 1.4.1