mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

chore(users/Profpatsch/htmx-experiment): move to Multipart2

Browse source 
We don’t strictly need servant-multipart, if all we need is to parse
some multipart forms. This removes some deps.

Change-Id: I218731fada056b9edfb3d01fc33880673d14473e
Reviewed-on: https://cl.tvl.fyi/c/depot/+/9187
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>
This commit is contained in:
Profpatsch 2023-08-31 19:38:45 +02:00
parent e06d38ae54
commit 88c3e2b4a0
5 changed files with 13 additions and 304 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
users/Profpatsch/htmx-experiment/default.nix
View file

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

7
users/Profpatsch/htmx-experiment/htmx-experiment.cabal
View file

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

75
users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs
View file

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

227
users/Profpatsch/htmx-experiment/src/Multipart.hs
View file

@ -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,
..
}

1
users/Profpatsch/shell.nix
View file

@ -31,7 +31,6 @@ pkgs.mkShell {
h.warp
h.profunctors
h.semigroupoids
h.servant-multipart
h.validation-selective
h.free
h.cryptonite-conduit