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

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>

5 files changed, 13 insertions, 304 deletions

diff --git a/users/Profpatsch/htmx-experiment/default.nix b/users/Profpatsch/htmx-experiment/default.nix
index 13ff4f3939..ef1a28bd2b 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 11fd16bacf..e9a0d93614 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 59cfdf3237..225206a584 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 59650887c6..0000000000
--- 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 2158ed6122..b27b47b2b9 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