From 3e5a2ea57f9a25533b0a59c80a43014653cdddd1 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sun, 6 Aug 2023 18:04:56 +0200 Subject: chore(users/Profpatsch): Move Multipart2 into new webstuff package Change-Id: I903f1b554beed1240d2a9cf14ff44d1f3cb41ec5 Reviewed-on: https://cl.tvl.fyi/c/depot/+/9013 Tested-by: BuildkiteCI Autosubmit: Profpatsch Reviewed-by: Profpatsch --- users/Profpatsch/cabal.project | 1 + users/Profpatsch/hie.yaml | 2 + users/Profpatsch/my-webstuff/default.nix | 27 +++ users/Profpatsch/my-webstuff/my-webstuff.cabal | 72 +++++++ users/Profpatsch/my-webstuff/src/Multipart2.hs | 220 +++++++++++++++++++++ users/Profpatsch/whatcd-resolver/default.nix | 2 +- users/Profpatsch/whatcd-resolver/src/Multipart2.hs | 220 --------------------- .../whatcd-resolver/whatcd-resolver.cabal | 2 +- 8 files changed, 324 insertions(+), 222 deletions(-) create mode 100644 users/Profpatsch/my-webstuff/default.nix create mode 100644 users/Profpatsch/my-webstuff/my-webstuff.cabal create mode 100644 users/Profpatsch/my-webstuff/src/Multipart2.hs delete mode 100644 users/Profpatsch/whatcd-resolver/src/Multipart2.hs diff --git a/users/Profpatsch/cabal.project b/users/Profpatsch/cabal.project index ed34b2f282..9c9b1a5151 100644 --- a/users/Profpatsch/cabal.project +++ b/users/Profpatsch/cabal.project @@ -1,5 +1,6 @@ packages: ./my-prelude/my-prelude.cabal + ./my-webstuff/my-webstuff.cabal ./netencode/netencode.cabal ./arglib/arglib-netencode.cabal ./execline/exec-helpers.cabal diff --git a/users/Profpatsch/hie.yaml b/users/Profpatsch/hie.yaml index 308fa8fe91..64e57b885d 100644 --- a/users/Profpatsch/hie.yaml +++ b/users/Profpatsch/hie.yaml @@ -2,6 +2,8 @@ cradle: cabal: - path: "./my-prelude" component: "lib:my-prelude" + - path: "./my-webstuff" + component: "lib:my-webstuff" - path: "./netencode" component: "lib:netencode" - path: "./arglib" diff --git a/users/Profpatsch/my-webstuff/default.nix b/users/Profpatsch/my-webstuff/default.nix new file mode 100644 index 0000000000..0067235be2 --- /dev/null +++ b/users/Profpatsch/my-webstuff/default.nix @@ -0,0 +1,27 @@ +{ depot, pkgs, lib, ... }: + +pkgs.haskellPackages.mkDerivation { + pname = "my-webstuff"; + version = "0.0.1-unreleased"; + + src = depot.users.Profpatsch.exactSource ./. [ + ./my-webstuff.cabal + ./src/Multipart2.hs + ]; + + isLibrary = true; + + libraryHaskellDepends = [ + depot.users.Profpatsch.my-prelude + pkgs.haskellPackages.dlist + pkgs.haskellPackages.monad-logger + pkgs.haskellPackages.pa-error-tree + pkgs.haskellPackages.pa-field-parser + pkgs.haskellPackages.pa-prelude + pkgs.haskellPackages.selective + pkgs.haskellPackages.wai-extra + ]; + + license = lib.licenses.mit; + +} diff --git a/users/Profpatsch/my-webstuff/my-webstuff.cabal b/users/Profpatsch/my-webstuff/my-webstuff.cabal new file mode 100644 index 0000000000..fb42d9f6a5 --- /dev/null +++ b/users/Profpatsch/my-webstuff/my-webstuff.cabal @@ -0,0 +1,72 @@ +cabal-version: 3.0 +name: my-webstuff +version: 0.0.1.0 +author: Profpatsch +maintainer: mail@profpatsch.de + +common common-options + ghc-options: + -Wall + -Wno-type-defaults + -Wunused-packages + -Wredundant-constraints + -fwarn-missing-deriving-strategies + + -- See https://downloads.haskell.org/ghc/latest/docs/users_guide/exts.html + -- for a description of all these extensions + default-extensions: + -- Infer Applicative instead of Monad where possible + ApplicativeDo + + -- Allow literal strings to be Text + OverloadedStrings + + -- Syntactic sugar improvements + LambdaCase + MultiWayIf + + -- Makes the (deprecated) usage of * instead of Data.Kind.Type an error + NoStarIsType + + -- Convenient and crucial to deal with ambiguous field names, commonly + -- known as RecordDotSyntax + OverloadedRecordDot + + -- does not export record fields as functions, use OverloadedRecordDot to access instead + NoFieldSelectors + + -- Record punning + RecordWildCards + + -- Improved Deriving + DerivingStrategies + DerivingVia + + -- Type-level strings + DataKinds + + -- to enable the `type` keyword in import lists (ormolu uses this automatically) + ExplicitNamespaces + + default-language: GHC2021 + + +library + import: common-options + hs-source-dirs: src + exposed-modules: + Multipart2 + + build-depends: + base >=4.15 && <5 + , my-prelude + , pa-prelude + , pa-label + , pa-error-tree + , pa-field-parser + , bytestring + , monad-logger + , dlist + , selective + , wai + , wai-extra diff --git a/users/Profpatsch/my-webstuff/src/Multipart2.hs b/users/Profpatsch/my-webstuff/src/Multipart2.hs new file mode 100644 index 0000000000..17246546ab --- /dev/null +++ b/users/Profpatsch/my-webstuff/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/default.nix b/users/Profpatsch/whatcd-resolver/default.nix index 2135ad7cbc..17200ffe93 100644 --- a/users/Profpatsch/whatcd-resolver/default.nix +++ b/users/Profpatsch/whatcd-resolver/default.nix @@ -9,12 +9,12 @@ let src = depot.users.Profpatsch.exactSource ./. [ ./whatcd-resolver.cabal - ./src/Multipart2.hs ./src/WhatcdResolver.hs ]; libraryHaskellDepends = [ depot.users.Profpatsch.my-prelude + depot.users.Profpatsch.my-webstuff pkgs.haskellPackages.pa-prelude pkgs.haskellPackages.pa-label pkgs.haskellPackages.pa-json diff --git a/users/Profpatsch/whatcd-resolver/src/Multipart2.hs b/users/Profpatsch/whatcd-resolver/src/Multipart2.hs deleted file mode 100644 index 17246546ab..0000000000 --- a/users/Profpatsch/whatcd-resolver/src/Multipart2.hs +++ /dev/null @@ -1,220 +0,0 @@ -{-# 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/whatcd-resolver.cabal b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal index 1c595eb2e2..d05182deb3 100644 --- a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal +++ b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal @@ -58,12 +58,12 @@ library exposed-modules: WhatcdResolver - Multipart2 build-depends: base >=4.15 && <5, text, my-prelude, + my-webstuff, pa-prelude, pa-error-tree, pa-label, -- cgit 1.4.1