chore(users/Profpatsch): Move Multipart2 into new webstuff package r/6466

Change-Id: I903f1b554beed1240d2a9cf14ff44d1f3cb41ec5
Reviewed-on: https://cl.tvl.fyi/c/depot/+/9013
Tested-by: BuildkiteCI
Autosubmit: Profpatsch <mail@profpatsch.de>
Reviewed-by: Profpatsch <mail@profpatsch.de>

3 files changed, 319 insertions, 0 deletions

diff --git a/users/Profpatsch/my-webstuff/default.nix b/users/Profpatsch/my-webstuff/default.nix
new file mode 100644
index 000000000000..0067235be269
--- /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 000000000000..fb42d9f6a55d
--- /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 000000000000..17246546ab35
--- /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 @\<input\>@
+    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
+    }