diff options
| -rw-r--r-- | users/Profpatsch/htmx-experiment/default.nix | 7 | ||||
| -rw-r--r-- | users/Profpatsch/htmx-experiment/htmx-experiment.cabal | 7 | ||||
| -rw-r--r-- | users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs | 75 | ||||
| -rw-r--r-- | users/Profpatsch/htmx-experiment/src/Multipart.hs | 227 | ||||
| -rw-r--r-- | users/Profpatsch/shell.nix | 1 |
5 files changed, 13 insertions, 304 deletions
diff --git a/users/Profpatsch/htmx-experiment/default.nix b/users/Profpatsch/htmx-experiment/default.nix index 13ff4f3939c9..ef1a28bd2b05 100644 --- a/users/Profpatsch/htmx-experiment/default.nix +++ b/users/Profpatsch/htmx-experiment/default.nix @@ -9,18 +9,17 @@ let ./htmx-experiment.cabal ./Main.hs ./src/HtmxExperiment.hs - ./src/Multipart.hs ./src/ServerErrors.hs ./src/ValidationParseT.hs ]; libraryHaskellDepends = [ + depot.users.Profpatsch.my-webstuff pkgs.haskellPackages.pa-label pkgs.haskellPackages.pa-error-tree pkgs.haskellPackages.blaze-html pkgs.haskellPackages.blaze-markup pkgs.haskellPackages.bytestring - pkgs.haskellPackages.conduit pkgs.haskellPackages.dlist pkgs.haskellPackages.http-types pkgs.haskellPackages.ihp-hsx @@ -29,13 +28,9 @@ let pkgs.haskellPackages.pa-field-parser pkgs.haskellPackages.pa-label pkgs.haskellPackages.pa-prelude - pkgs.haskellPackages.profunctors pkgs.haskellPackages.selective - pkgs.haskellPackages.servant-multipart-api - pkgs.haskellPackages.servant-multipart pkgs.haskellPackages.text pkgs.haskellPackages.unliftio - pkgs.haskellPackages.wai-extra pkgs.haskellPackages.wai pkgs.haskellPackages.warp diff --git a/users/Profpatsch/htmx-experiment/htmx-experiment.cabal b/users/Profpatsch/htmx-experiment/htmx-experiment.cabal index 11fd16bacfe7..e9a0d9361486 100644 --- a/users/Profpatsch/htmx-experiment/htmx-experiment.cabal +++ b/users/Profpatsch/htmx-experiment/htmx-experiment.cabal @@ -54,7 +54,6 @@ library import: common-options exposed-modules: HtmxExperiment, - Multipart, ServerErrors, ValidationParseT hs-source-dirs: ./src @@ -65,7 +64,6 @@ library blaze-html, blaze-markup, bytestring, - conduit, dlist, http-types, ihp-hsx, @@ -74,13 +72,10 @@ library pa-field-parser, pa-label, pa-prelude, - profunctors, + my-webstuff, selective, - servant-multipart-api, - servant-multipart, text, unliftio, - wai-extra, wai, warp diff --git a/users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs b/users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs index 59cfdf3237a7..225206a5843d 100644 --- a/users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs +++ b/users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs @@ -9,9 +9,8 @@ import Control.Exception qualified as Exc import Control.Monad.Logger import Control.Selective (Selective (select)) import Control.Selective qualified as Selective -import Data.ByteString.Lazy qualified as Lazy +import Data.ByteString qualified as Bytes import Data.DList (DList) -import Data.Error.Tree import Data.Functor.Compose import Data.List qualified as List import Data.Maybe (maybeToList) @@ -22,16 +21,13 @@ import FieldParser hiding (nonEmpty) import GHC.TypeLits (KnownSymbol, symbolVal) import IHP.HSX.QQ (hsx) import Label -import Multipart (FormValidation (FormValidation), FormValidationResult, MultipartParseT, failFormValidation) -import Multipart qualified +import Multipart2 (FormValidation (FormValidation), FormValidationResult, MultipartParseT, failFormValidation) +import Multipart2 qualified as Multipart import Network.HTTP.Types qualified as Http import Network.Wai qualified as Wai import Network.Wai.Handler.Warp qualified as Warp -import Network.Wai.Parse qualified as Wai.Extra -import Network.Wai.Parse qualified as Wai.Parse import PossehlAnalyticsPrelude -import Servant.Multipart qualified as Multipart -import ServerErrors (ServerError (..), orUserErrorTree) +import ServerErrors (ServerError (..), throwUserErrorTree) import Text.Blaze.Html5 (Html, docTypeHtml) import Text.Blaze.Renderer.Utf8 (renderMarkup) import UnliftIO (MonadUnliftIO (withRunInIO)) @@ -212,60 +208,11 @@ main = runStderrLoggingT @IO $ do parsePostBody :: (MonadIO m, MonadThrow m, MonadLogger m) => - MultipartParseT Multipart.Mem m b -> + MultipartParseT backend m b -> Wai.Request -> m b parsePostBody parser req = - req - & Wai.Extra.parseRequestBodyEx - Wai.Extra.defaultParseRequestBodyOptions - Wai.Extra.lbsBackEnd - & liftIO - <&> parseAllAsText - <&> first (errorTree "Cannot parse multipart form data into UTF-8 text") - >>= orUserErrorTree "Failed parsing post body" - >>= Multipart.parseMultipart parser - where - parseAllAsText :: - ([(ByteString, ByteString)], [(ByteString, Wai.Parse.FileInfo Lazy.ByteString)]) -> - Either (NonEmpty Error) (Multipart.MultipartData Multipart.Mem) - -- our multipart parser expects every form field to be valid Text, so we parse from Utf-8 - parseAllAsText (inputsBytes, filesBytes) = validationToEither $ do - let asText what b = - b - & bytesToTextUtf8 - & first (errorContext [fmt|"{what & bytesToTextUtf8Lenient}" is not unicode|]) - & eitherToListValidation - - inputs <- - inputsBytes - & traverse - ( \(k, v) -> do - k' <- k & asText [fmt|input name {k}|] - v' <- v & asText [fmt|value of input key {k}|] - pure - Multipart.Input - { iName = k', - iValue = v' - } - ) - - files <- - filesBytes - & traverse - ( \(k, f) -> do - let fdPayload = f.fileContent - k' <- k & asText [fmt|file input name {k}|] - fdFileName <- f.fileName & asText [fmt|file input file name {f.fileName}|] - fdFileCType <- f.fileContentType & asText [fmt|file input content type {f.fileContentType}|] - pure - Multipart.FileData - { fdInputName = k', - .. - } - ) - - pure $ Multipart.MultipartData {inputs, files} + Multipart.parseMultipartOrThrow throwUserErrorTree parser req -- migrate :: IO (Label "numberOfRowsAffected" Natural) -- migrate = @@ -296,7 +243,7 @@ data FormField = FormField { label_ :: Html, required :: Bool, id_ :: Text, - name :: Text, + name :: ByteString, type_ :: Text, placeholder :: Maybe Text } @@ -390,12 +337,12 @@ registerFormValidate :: MultipartParseT w m - (FormValidation (T2 "email" Text "password" Text)) + (FormValidation (T2 "email" ByteString "password" ByteString)) registerFormValidate = do - let emailFP = FieldParser $ \t -> + let emailFP = FieldParser $ \b -> if - | Text.elem '@' t -> Right t - | otherwise -> Left [fmt|This is not an email address: "{t}"|] + | Bytes.elem (charToWordUnsafe '@') b -> Right b + | otherwise -> Left [fmt|This is not an email address: "{b & bytesToTextUtf8Unsafe}"|] getCompose @(MultipartParseT _ _) @FormValidation $ do email <- Compose $ Multipart.fieldLabel' @"email" "email" emailFP diff --git a/users/Profpatsch/htmx-experiment/src/Multipart.hs b/users/Profpatsch/htmx-experiment/src/Multipart.hs deleted file mode 100644 index 59650887c633..000000000000 --- a/users/Profpatsch/htmx-experiment/src/Multipart.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module Multipart where - -import Conduit (ConduitT, MonadResource) -import Conduit qualified as Cond -import Control.Monad.Logger (MonadLogger) -import Control.Selective (Selective) -import Data.ByteString qualified as ByteString -import Data.DList (DList) -import Data.DList qualified as DList -import Data.Functor.Compose -import Data.List qualified as List -import FieldParser -import Label -import PossehlAnalyticsPrelude --- TODO: Use the multipart module from wai-extra -import Servant.Multipart -import Servant.Multipart.API -import ValidationParseT - --- | A parser for a HTTP multipart form (a form sent by the browser) -newtype MultipartParseT backend m a = MultipartParseT - { unMultipartParseT :: - MultipartData backend -> - m (Validation (NonEmpty Error) a) - } - deriving - (Functor, Applicative, Selective) - via (ValidationParseT (MultipartData backend) 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 :: Text, - originalValue :: Text - } - deriving stock (Show) - -mkFormValidationResult :: - ( HasField "formFieldName" form Text, - HasField "originalValue" form Text - ) => - form -> - Maybe Error -> - FormValidationResult -mkFormValidationResult form err = - FormValidationResult - { hasError = err, - formFieldName = form.formFieldName, - originalValue = form.originalValue - } - -eitherToFormValidation :: - ( HasField "formFieldName" form Text, - HasField "originalValue" form Text - ) => - 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 Text, - HasField "originalValue" form Text - ) => - 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. -parseMultipart :: - (MonadLogger m, MonadThrow m) => - MultipartParseT backend m a -> - MultipartData backend -> - m a -parseMultipart parser multipartData = - runValidationParseTOrUserError "Cannot parse the multipart form" parser multipartData - --- | Parse the field out of the multipart message -field :: Applicative m => Text -> FieldParser Text a -> MultipartParseT backend m a -field fieldName fieldParser = MultipartParseT $ \mp -> - mp.inputs - & findMaybe (\input -> if input.iName == fieldName then Just input.iValue 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 => Text -> FieldParser Text a -> MultipartParseT backend m (FormValidation a) -field' fieldName fieldParser = MultipartParseT $ \mp -> - mp.inputs - & findMaybe (\input -> if input.iName == fieldName then Just input.iValue 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 => Text -> FieldParser Text 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 => Text -> FieldParser Text 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 Input b -> MultipartParseT backend m [b] -allFields fieldParser = MultipartParseT $ \mp -> - mp.inputs - & traverseValidate (runFieldParser fieldParser) - & eitherToValidation - & pure - --- | Parse a file by name out of the multipart message -file :: - Applicative m => - Text -> - GetFileContent backend m content -> - MultipartParseT backend m (MultipartFile content) -file fieldName getContent = MultipartParseT $ \mp -> - mp.files - & List.find (\input -> input.fdInputName == fieldName) - & annotate [fmt|File "{fieldName}" does not exist in the multipart form|] - & \case - Left err -> pure $ Failure (singleton err) - Right filePath -> fileDataToMultipartFile getContent filePath <&> eitherToListValidation - --- | Return all files from the multipart message -allFiles :: - Applicative m => - GetFileContent backend m content -> - MultipartParseT backend m [MultipartFile content] -allFiles getContent = MultipartParseT $ \mp -> do - traverseValidateM (fileDataToMultipartFile getContent) mp.files - <&> eitherToValidation - --- | Ensure there is exactly one file and return it (ignoring the field name) -exactlyOneFile :: - Applicative m => - GetFileContent backend m content -> - MultipartParseT backend m (MultipartFile content) -exactlyOneFile getContent = MultipartParseT $ \mp -> - mp.files - & \case - [] -> pure $ failParse "Expected to receive a file, but the multipart form did not contain any files" - [file_] -> - file_ - & fileDataToMultipartFile getContent - <&> eitherToListValidation - 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 :: (MultipartResult backend -> m (Either Error content))} - --- | Get the 'FilePath' of the temporary file on disk. --- --- __ATTN__: Must be consumed before the handler returns, otherwise the temporary file is deleted! -tmpFilePath :: Applicative m => GetFileContent Tmp m FilePath -tmpFilePath = GetFileContent $ \filePath -> pure $ Right $ filePath - -tmpFileContent :: MonadIO m => GetFileContent Tmp m ByteString -tmpFileContent = - -- \| TODO: potentially catch file reading exceptions :P - GetFileContent $ \filePath -> liftIO $ Right <$> ByteString.readFile filePath - --- | Streams the contents of the file. --- --- __ATTN__: Must be consumed before the handler returns, otherwise the temporary file is deleted! --- (Although I can’t figure out whether the handle stays open so it might not be that bad; just don’t move it to a different thread.) -tmpFileContentStream :: (MonadResource io, Applicative m) => GetFileContent Tmp m (ConduitT () ByteString io ()) -tmpFileContentStream = - -- \| TODO: potentially catch file reading exceptions :P - GetFileContent $ \filePath -> pure $ Right $ Cond.sourceFile filePath - --- | A file field in a multipart message. -data MultipartFile content = MultipartFile - { -- | @name@ attribute of the corresponding HTML @\<input\>@ - multipartNameAttribute :: Text, - -- | name of the file on the client's disk - fileNameOnDisk :: Text, - -- | MIME type for the file - fileMimeType :: Text, - -- | Content of the file - content :: content - } - --- | Convert the multipart library struct of a multipart file to our own. -fileDataToMultipartFile :: - Functor f => - GetFileContent backend f content -> - FileData backend -> - f (Either Error (MultipartFile content)) -fileDataToMultipartFile getContent file_ = runExceptT $ do - content <- ExceptT $ getContent.unGetFileContent file_.fdPayload - pure $ - MultipartFile - { multipartNameAttribute = file_.fdInputName, - fileNameOnDisk = file_.fdFileName, - fileMimeType = file_.fdFileCType, - .. - } diff --git a/users/Profpatsch/shell.nix b/users/Profpatsch/shell.nix index 2158ed6122ca..b27b47b2b939 100644 --- a/users/Profpatsch/shell.nix +++ b/users/Profpatsch/shell.nix @@ -31,7 +31,6 @@ pkgs.mkShell { h.warp h.profunctors h.semigroupoids - h.servant-multipart h.validation-selective h.free h.cryptonite-conduit |