about summary refs log tree commit diff
path: root/users/Profpatsch/htmx-experiment/src/Multipart.hs
diff options
context:
space:
mode:
Diffstat (limited to 'users/Profpatsch/htmx-experiment/src/Multipart.hs')
-rw-r--r--users/Profpatsch/htmx-experiment/src/Multipart.hs227
1 files changed, 0 insertions, 227 deletions
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,
-        ..
-      }