diff --git a/users/Profpatsch/cabal.project b/users/Profpatsch/cabal.project
new file mode 100644
index 000000000..d82af89d5
--- /dev/null
+++ b/users/Profpatsch/cabal.project
@@ -0,0 +1,3 @@
+packages:
+ ./my-prelude/my-prelude.cabal
+ ./htmx-experiment/htmx-experiment.cabal
diff --git a/users/Profpatsch/hie.yaml b/users/Profpatsch/hie.yaml
new file mode 100644
index 000000000..895120d42
--- /dev/null
+++ b/users/Profpatsch/hie.yaml
@@ -0,0 +1,11 @@
+cradle:
+ cabal:
+ - path: "./my-prelude"
+ component: "lib:my-prelude"
+ - path: "./htmx-experiment/src"
+ component: "lib:htmx-experiment"
+ - path: "./htmx-experiment/src"
+ component: "lib:htmx-experiment"
+ - path: "./htmx-experiment/Main.hs"
+ component: "htmx-experiment:exe:htmx-experiment"
+
diff --git a/users/Profpatsch/htmx-experiment/Main.hs b/users/Profpatsch/htmx-experiment/Main.hs
new file mode 100644
index 000000000..29ce8610f
--- /dev/null
+++ b/users/Profpatsch/htmx-experiment/Main.hs
@@ -0,0 +1,4 @@
+import HtmxExperiment qualified
+
+main :: IO ()
+main = HtmxExperiment.main
diff --git a/users/Profpatsch/htmx-experiment/default.nix b/users/Profpatsch/htmx-experiment/default.nix
new file mode 100644
index 000000000..13ff4f393
--- /dev/null
+++ b/users/Profpatsch/htmx-experiment/default.nix
@@ -0,0 +1,51 @@
+{ depot, pkgs, lib, ... }:
+
+let
+ htmx-experiment = pkgs.haskellPackages.mkDerivation {
+ pname = "htmx-experiment";
+ version = "0.1.0";
+
+ src = depot.users.Profpatsch.exactSource ./. [
+ ./htmx-experiment.cabal
+ ./Main.hs
+ ./src/HtmxExperiment.hs
+ ./src/Multipart.hs
+ ./src/ServerErrors.hs
+ ./src/ValidationParseT.hs
+ ];
+
+ libraryHaskellDepends = [
+ 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
+ pkgs.haskellPackages.monad-logger
+ pkgs.haskellPackages.pa-error-tree
+ 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
+
+ ];
+
+ isLibrary = false;
+ isExecutable = true;
+ license = lib.licenses.mit;
+ };
+
+
+in
+htmx-experiment
diff --git a/users/Profpatsch/htmx-experiment/htmx-experiment.cabal b/users/Profpatsch/htmx-experiment/htmx-experiment.cabal
new file mode 100644
index 000000000..e287a8501
--- /dev/null
+++ b/users/Profpatsch/htmx-experiment/htmx-experiment.cabal
@@ -0,0 +1,94 @@
+cabal-version: 2.4
+name: htmx-experiment
+version: 0.1.0.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
+ exposed-modules:
+ HtmxExperiment,
+ Multipart,
+ ServerErrors,
+ ValidationParseT
+ hs-source-dirs: ./src
+
+ build-depends:
+ base >=4.15 && <5,
+ -- http-api-data
+ blaze-html,
+ blaze-markup,
+ bytestring,
+ conduit,
+ dlist,
+ http-types,
+ ihp-hsx,
+ monad-logger,
+ pa-error-tree,
+ pa-field-parser,
+ pa-label,
+ pa-prelude,
+ profunctors,
+ selective,
+ servant-multipart-api,
+ servant-multipart,
+ text,
+ unliftio,
+ wai-extra,
+ wai,
+ warp
+
+
+executable htmx-experiment
+ import: common-options
+ main-is: Main.hs
+
+ build-depends:
+ htmx-experiment,
+ base >=4.15 && <5,
diff --git a/users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs b/users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs
new file mode 100644
index 000000000..59cfdf323
--- /dev/null
+++ b/users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs
@@ -0,0 +1,430 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module HtmxExperiment where
+
+import Control.Category qualified as Cat
+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.DList (DList)
+import Data.Error.Tree
+import Data.Functor.Compose
+import Data.List qualified as List
+import Data.Maybe (maybeToList)
+import Data.Maybe qualified as Maybe
+import Data.Monoid qualified as Monoid
+import Data.Text qualified as Text
+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 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 Text.Blaze.Html5 (Html, docTypeHtml)
+import Text.Blaze.Renderer.Utf8 (renderMarkup)
+import UnliftIO (MonadUnliftIO (withRunInIO))
+import Prelude hiding (compare)
+
+-- data Routes
+-- = Root
+-- | Register
+-- | RegisterSubmit
+
+-- data Router url = Router
+-- { parse :: Routes.URLParser url,
+-- print :: url -> [Text]
+-- }
+
+-- routerPathInfo :: Routes.PathInfo a => Router a
+-- routerPathInfo =
+-- Router
+-- { parse = Routes.fromPathSegments,
+-- print = Routes.toPathSegments
+-- }
+
+-- subroute :: Text -> Router subUrl -> Router subUrl
+-- subroute path inner =
+-- Router
+-- { parse = Routes.segment path *> inner.parse,
+-- print = \url -> path : inner.print url
+-- }
+
+-- routerLeaf :: a -> Router a
+-- routerLeaf a =
+-- Router
+-- { parse = pure a,
+-- print = \_ -> []
+-- }
+
+-- routerToSite ::
+-- ((url -> [(Text, Maybe Text)] -> Text) -> url -> a) ->
+-- Router url ->
+-- Routes.Site url a
+-- routerToSite handler router =
+-- Routes.Site
+-- { handleSite = handler,
+-- formatPathSegments = (\x -> (x, [])) . router.print,
+-- parsePathSegments = Routes.parseSegments router.parse
+-- }
+
+-- handlers queryParams = \case
+-- Root -> "root"
+-- Register -> "register"
+-- RegisterSubmit -> "registersubmit"
+
+newtype Router handler from to = Router {unRouter :: from -> [Text] -> (Maybe handler, to)}
+ deriving
+ (Functor, Applicative)
+ via ( Compose
+ ((->) from)
+ ( Compose
+ ((->) [Text])
+ ((,) (Monoid.First handler))
+ )
+ )
+
+data Routes r handler = Routes
+ { users :: r (Label "register" handler)
+ }
+
+data Endpoint handler subroutes = Endpoint
+ { root :: handler,
+ subroutes :: subroutes
+ }
+ deriving stock (Show, Eq)
+
+data Handler = Handler {url :: Text}
+
+-- myRoute :: Router () from (Endpoint (Routes (Endpoint ()) Handler) b)
+-- myRoute =
+-- root $ do
+-- users <- fixed "users" () $ fixedFinal @"register" ()
+-- pure $ Routes {..}
+
+-- -- | the root and its children
+-- root :: routes from a -> routes from (Endpoint a b)
+-- root = todo
+
+-- | A fixed sub-route with children
+fixed :: Text -> handler -> Router handler from a -> Router handler from (Endpoint handler a)
+fixed route handler inner = Router $ \from -> \case
+ [final]
+ | route == final ->
+ ( Just handler,
+ Endpoint
+ { root = handler,
+ subroutes = (inner.unRouter from []) & snd
+ }
+ )
+ (this : more)
+ | route == this ->
+ ( (inner.unRouter from more) & fst,
+ Endpoint
+ { root = handler,
+ subroutes = (inner.unRouter from more) & snd
+ }
+ )
+ _ -> (Nothing, Endpoint {root = handler, subroutes = (inner.unRouter from []) & snd})
+
+-- integer ::
+-- forall routeName routes from a.
+-- Router (T2 routeName Integer "more" from) a ->
+-- Router from (Endpoint () a)
+-- integer inner = Router $ \case
+-- (path, []) ->
+-- runFieldParser Field.signedDecimal path
+-- (path, more) ->
+-- inner.unRouter more (runFieldParser Field.signedDecimal path)
+
+-- -- | A leaf route
+-- fixedFinal :: forall route handler from. (KnownSymbol route) => handler -> Router handler from (Label route Handler)
+-- fixedFinal handler = do
+-- let route = symbolText @route
+-- Rounter $ \from -> \case
+-- [final] | route == final -> (Just handler, label @route (Handler from))
+-- _ -> (Nothing, label @route handler)
+
+-- | Get the text of a symbol via TypeApplications
+symbolText :: forall sym. KnownSymbol sym => Text
+symbolText = do
+ symbolVal (Proxy :: Proxy sym)
+ & stringToText
+
+main :: IO ()
+main = runStderrLoggingT @IO $ do
+ withRunInIO @(LoggingT IO) $ \runInIO -> do
+ Warp.run 8080 $ \req respond -> catchServerError respond $ do
+ let respondOk res = Wai.responseLBS Http.ok200 [] (renderMarkup res)
+ let htmlRoot inner =
+ docTypeHtml
+ [hsx|
+
+
+
+
+ {inner}
+
+ |]
+ res <-
+ case req & Wai.pathInfo of
+ [] ->
+ pure $
+ respondOk $
+ htmlRoot
+ [hsx|
+
+
+
+
+ |]
+ ["register"] ->
+ pure $ respondOk $ fullEndpoint req $ \case
+ FullPage -> htmlRoot $ registerForm mempty
+ Snippet -> registerForm mempty
+ ["register", "submit"] -> do
+ FormValidation body <-
+ req
+ & parsePostBody
+ registerFormValidate
+ & runInIO
+ case body of
+ -- if the parse succeeds, ignore any of the data
+ (_, Just a) -> pure $ respondOk $ htmlRoot [hsx|{a}|]
+ (errs, Nothing) -> pure $ respondOk $ htmlRoot $ registerForm errs
+ other ->
+ pure $ respondOk [hsx|no route here at {other}|]
+ respond $ res
+ where
+ catchServerError respond io =
+ Exc.catch io (\(ex :: ServerError) -> respond $ Wai.responseLBS ex.status [] ex.errBody)
+
+parsePostBody ::
+ (MonadIO m, MonadThrow m, MonadLogger m) =>
+ MultipartParseT Multipart.Mem 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}
+
+-- migrate :: IO (Label "numberOfRowsAffected" Natural)
+-- migrate =
+-- Init.runAppTest $ do
+-- runTransaction $
+-- execute
+-- [sql|
+-- CREATE TABLE IF NOT EXISTS experiments.users (
+-- id SERIAL PRIMARY KEY,
+-- email TEXT NOT NULL,
+-- registration_pending_token TEXT NULL
+-- )
+-- |]
+-- ()
+
+data HsxRequest
+ = Snippet
+ | FullPage
+
+fullEndpoint :: Wai.Request -> (HsxRequest -> t) -> t
+fullEndpoint req act = do
+ let isHxRequest = req & Wai.requestHeaders & List.find (\h -> (h & fst) == "HX-Request") & Maybe.isJust
+ if isHxRequest
+ then act Snippet
+ else act FullPage
+
+data FormField = FormField
+ { label_ :: Html,
+ required :: Bool,
+ id_ :: Text,
+ name :: Text,
+ type_ :: Text,
+ placeholder :: Maybe Text
+ }
+
+inputHtml ::
+ FormField ->
+ DList FormValidationResult ->
+ Html
+inputHtml (FormField {..}) validationResults = do
+ let validation =
+ validationResults
+ & toList
+ & mapMaybe
+ ( \v ->
+ if v.formFieldName == name
+ then
+ Just
+ ( T2
+ (label @"errors" (maybeToList v.hasError))
+ (label @"originalValue" (Monoid.First (Just v.originalValue)))
+ )
+ else Nothing
+ )
+ & mconcat
+ let isFirstError =
+ validationResults
+ & List.find (\res -> Maybe.isJust res.hasError && res.formFieldName == name)
+ & Maybe.isJust
+ [hsx|
+
+ |]
+
+registerForm :: DList FormValidationResult -> Html
+registerForm validationErrors =
+ let fields =
+ mconcat
+ [ inputHtml $
+ FormField
+ { label_ = "Your Email:",
+ required = True,
+ id_ = "register_email",
+ name = "email",
+ type_ = "email",
+ placeholder = Just "your@email.com"
+ },
+ inputHtml $
+ FormField
+ { label_ = "New password:",
+ required = True,
+ id_ = "register_password",
+ name = "password",
+ type_ = "password",
+ placeholder = Just "hunter2"
+ },
+ inputHtml $
+ FormField
+ { label_ = "Repeated password:",
+ required = True,
+ id_ = "register_password_repeated",
+ name = "password_repeated",
+ type_ = "password",
+ placeholder = Just "hunter2"
+ }
+ ]
+ in [hsx|
+
+ |]
+
+registerFormValidate ::
+ Applicative m =>
+ MultipartParseT
+ w
+ m
+ (FormValidation (T2 "email" Text "password" Text))
+registerFormValidate = do
+ let emailFP = FieldParser $ \t ->
+ if
+ | Text.elem '@' t -> Right t
+ | otherwise -> Left [fmt|This is not an email address: "{t}"|]
+
+ getCompose @(MultipartParseT _ _) @FormValidation $ do
+ email <- Compose $ Multipart.fieldLabel' @"email" "email" emailFP
+ password <-
+ aEqB
+ "password_repeated"
+ "The two password fields must be the same"
+ (Compose $ Multipart.field' "password" Cat.id)
+ (\field -> Compose $ Multipart.field' field Cat.id)
+ pure $ T2 email (label @"password" password)
+ where
+ aEqB field validateErr fCompare fValidate =
+ Selective.fromMaybeS
+ -- TODO: this check only reached if the field itself is valid. Could we combine those errors?
+ (Compose $ pure $ failFormValidation (T2 (label @"formFieldName" field) (label @"originalValue" "")) validateErr)
+ $ do
+ compare <- fCompare
+ validate <- fValidate field
+ pure $ if compare == validate then Just validate else Nothing
+
+-- | A lifted version of 'Data.Maybe.fromMaybe'.
+fromMaybeS :: Selective f => f a -> f (Maybe a) -> f a
+fromMaybeS ifNothing fma =
+ select
+ ( fma <&> \case
+ Nothing -> Left ()
+ Just a -> Right a
+ )
+ ( do
+ a <- ifNothing
+ pure (\() -> a)
+ )
diff --git a/users/Profpatsch/htmx-experiment/src/Multipart.hs b/users/Profpatsch/htmx-experiment/src/Multipart.hs
new file mode 100644
index 000000000..59650887c
--- /dev/null
+++ b/users/Profpatsch/htmx-experiment/src/Multipart.hs
@@ -0,0 +1,227 @@
+{-# 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 @\@
+ 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/htmx-experiment/src/ServerErrors.hs b/users/Profpatsch/htmx-experiment/src/ServerErrors.hs
new file mode 100644
index 000000000..0fca7ab46
--- /dev/null
+++ b/users/Profpatsch/htmx-experiment/src/ServerErrors.hs
@@ -0,0 +1,244 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module ServerErrors where
+
+import Control.Exception (Exception)
+import Control.Monad.Logger (MonadLogger, logError, logWarn)
+import Data.ByteString.Lazy qualified as Bytes.Lazy
+import Data.Error.Tree
+import Network.HTTP.Types qualified as Http
+import PossehlAnalyticsPrelude
+
+data ServerError = ServerError
+ { status :: Http.Status,
+ errBody :: Bytes.Lazy.ByteString
+ }
+ deriving stock (Show)
+ deriving anyclass (Exception)
+
+emptyServerError :: Http.Status -> ServerError
+emptyServerError status = ServerError {status, errBody = ""}
+
+-- | Throw a user error.
+--
+-- “User” here is a client using our API, not a human user.
+-- So we throw a `HTTP 400` error, which means the API was used incorrectly.
+--
+-- We also log the error as a warning, because it probably signifies a programming bug in our client.
+--
+-- If you need to display a message to a human user, return a `FrontendResponse`
+-- or a structured type with translation keys (so we can localize the errors).
+throwUserError ::
+ (MonadLogger m, MonadThrow m) =>
+ -- | The error to log & throw to the user
+ Error ->
+ m b
+throwUserError err = do
+ -- TODO: should we make this into a macro to keep the line numbers?
+ $logWarn (err & errorContext "There was a “user holding it wrong” error, check the client code" & prettyError)
+ throwM
+ ServerError
+ { status = Http.badRequest400,
+ errBody = err & prettyError & textToBytesUtf8 & toLazyBytes
+ }
+
+-- | Throw a user error.
+--
+-- “User” here is a client using our API, not a human user.
+-- So we throw a `HTTP 400` error, which means the API was used incorrectly.
+--
+-- We also log the error as a warning, because it probably signifies a programming bug in our client.
+--
+-- If you need to display a message to a human user, return a `FrontendResponse`
+-- or a structured type with translation keys (so we can localize the errors).
+throwUserErrorTree ::
+ (MonadLogger m, MonadThrow m) =>
+ -- | The error to log & throw to the user
+ ErrorTree ->
+ m b
+throwUserErrorTree err = do
+ -- TODO: should we make this into a macro to keep the line numbers?
+ $logWarn (err & nestedError "There was a “user holding it wrong” error, check the client code" & prettyErrorTree)
+ throwM
+ ServerError
+ { status = Http.badRequest400,
+ errBody = err & prettyErrorTree & textToBytesUtf8 & toLazyBytes
+ }
+
+-- | Unwrap the `Either` and if `Left` throw a user error.
+--
+-- Intended to use in a pipeline, e.g.:
+--
+-- @@
+-- doSomething
+-- >>= orUserError "Oh no something did not work"
+-- >>= doSomethingElse
+-- @@
+--
+-- “User” here is a client using our API, not a human user.
+-- So we throw a `HTTP 400` error, which means the API was used incorrectly.
+--
+-- We also log the error as a warning, because it probably signifies a programming bug in our client.
+--
+-- If you need to display a message to a human user, return a `FrontendResponse`
+-- or a structured type with translation keys (so we can localize the errors).
+orUserError ::
+ (MonadThrow m, MonadLogger m) =>
+ -- | The message to add as a context to the error being thrown
+ Text ->
+ -- | Result to unwrap and potentially throw
+ Either Error a ->
+ m a
+orUserError outerMsg eErrA =
+ orUserErrorTree outerMsg (first singleError eErrA)
+
+-- | Unwrap the `Either` and if `Left` throw a user error. Will pretty-print the 'ErrorTree'
+--
+-- Intended to use in a pipeline, e.g.:
+--
+-- @@
+-- doSomething
+-- >>= orUserErrorTree "Oh no something did not work"
+-- >>= doSomethingElse
+-- @@
+--
+-- “User” here is a client using our API, not a human user.
+-- So we throw a `HTTP 400` error, which means the API was used incorrectly.
+--
+-- We also log the error as a warning, because it probably signifies a programming bug in our client.
+--
+-- If you need to display a message to a human user, return a `FrontendResponse`
+-- or a structured type with translation keys (so we can localize the errors).
+orUserErrorTree ::
+ (MonadThrow m, MonadLogger m) =>
+ -- | The message to add as a context to the 'ErrorTree' being thrown
+ Text ->
+ -- | Result to unwrap and potentially throw
+ Either ErrorTree a ->
+ m a
+orUserErrorTree outerMsg = \case
+ Right a -> pure a
+ Left err -> do
+ -- TODO: this outer message should probably be added as a separate root instead of adding to the root error?
+ let tree = errorTreeContext outerMsg err
+ -- TODO: should we make this into a macro to keep the line numbers?
+ $logWarn (errorTreeContext "There was a “user holding it wrong” error, check the client code" tree & prettyErrorTree)
+ throwM
+ ServerError
+ { status = Http.badRequest400,
+ errBody = tree & prettyErrorTree & textToBytesUtf8 & toLazyBytes
+ }
+
+-- | Throw an internal error.
+--
+-- “Internal” here means some assertion that we depend on failed,
+-- e.g. some database request returned a wrong result/number of results
+-- or some invariant that we expect to hold failed.
+--
+-- This prints the full error to the log,
+-- and returns a “HTTP 500” error without the message.
+--
+-- If you want to signify a mishandling of the API (e.g. a wrong request), throw a `userError`.
+-- If you need to display a message to a human user, return a `FrontendResponse`
+-- or a structured type with translation keys (so we can localize the errors).
+throwInternalError ::
+ (MonadLogger m, MonadThrow m) =>
+ -- | The error to log internally
+ Error ->
+ m b
+throwInternalError err = do
+ -- TODO: should we make this into a macro to keep the line numbers?
+ $logError
+ (err & prettyError)
+ throwM $ emptyServerError Http.internalServerError500
+
+-- | Throw an internal error.
+--
+-- “Internal” here means some assertion that we depend on failed,
+-- e.g. some database request returned a wrong result/number of results
+-- or some invariant that we expect to hold failed.
+--
+-- This prints the full error to the log,
+-- and returns a “HTTP 500” error without the message.
+--
+-- If you want to signify a mishandling of the API (e.g. a wrong request), throw a `userError`.
+-- If you need to display a message to a human user, return a `FrontendResponse`
+-- or a structured type with translation keys (so we can localize the errors).
+throwInternalErrorTree ::
+ (MonadLogger m, MonadThrow m) =>
+ -- | The error to log internally
+ ErrorTree ->
+ m b
+throwInternalErrorTree err = do
+ -- TODO: should we make this into a macro to keep the line numbers?
+ $logError
+ (err & prettyErrorTree)
+ throwM $ emptyServerError Http.internalServerError500
+
+-- | Unwrap the `Either` and if `Left` throw an internal error.
+--
+-- Intended to use in a pipeline, e.g.:
+--
+-- @@
+-- doSomething
+-- >>= orInternalError "Oh no something did not work"
+-- >>= doSomethingElse
+-- @@
+--
+-- “Internal” here means some assertion that we depend on failed,
+-- e.g. some database request returned a wrong result/number of results
+-- or some invariant that we expect to hold failed.
+--
+-- This prints the full error to the log,
+-- and returns a “HTTP 500” error without the message.
+--
+-- If you want to signify a mishandling of the API (e.g. a wrong request), throw a `userError`.
+-- If you need to display a message to a human user, return a `FrontendResponse`
+-- or a structured type with translation keys (so we can localize the errors).
+orInternalError ::
+ (MonadThrow m, MonadLogger m) =>
+ -- | The message to add as a context to the error being thrown
+ Text ->
+ -- | Result to unwrap and potentially throw
+ Either Error a ->
+ m a
+orInternalError outerMsg eErrA = orInternalErrorTree outerMsg (first singleError eErrA)
+
+-- | Unwrap the `Either` and if `Left` throw an internal error. Will pretty-print the 'ErrorTree'.
+--
+-- Intended to use in a pipeline, e.g.:
+--
+-- @@
+-- doSomething
+-- >>= orInternalErrorTree "Oh no something did not work"
+-- >>= doSomethingElse
+-- @@
+--
+-- “Internal” here means some assertion that we depend on failed,
+-- e.g. some database request returned a wrong result/number of results
+-- or some invariant that we expect to hold failed.
+--
+-- This prints the full error to the log,
+-- and returns a “HTTP 500” error without the message.
+--
+-- If you want to signify a mishandling of the API (e.g. a wrong request), throw a `userError`.
+-- If you need to display a message to a human user, return a `FrontendResponse`
+-- or a structured type with translation keys (so we can localize the errors).
+orInternalErrorTree ::
+ (MonadThrow m, MonadLogger m) =>
+ -- | The message to add as a context to the 'ErrorTree' being thrown
+ Text ->
+ -- | Result to unwrap and potentially throw
+ Either ErrorTree a ->
+ m a
+orInternalErrorTree outerMsg = \case
+ Right a -> pure a
+ Left err -> do
+ -- TODO: this outer message should probably be added as a separate root instead of adding to the root error?
+ let tree = errorTreeContext outerMsg err
+ -- TODO: should we make this into a macro to keep the line numbers?
+ $logError (tree & prettyErrorTree)
+ throwM $ emptyServerError Http.internalServerError500
diff --git a/users/Profpatsch/htmx-experiment/src/ValidationParseT.hs b/users/Profpatsch/htmx-experiment/src/ValidationParseT.hs
new file mode 100644
index 000000000..ffb6c2f39
--- /dev/null
+++ b/users/Profpatsch/htmx-experiment/src/ValidationParseT.hs
@@ -0,0 +1,40 @@
+module ValidationParseT where
+
+import Control.Monad.Logger (MonadLogger)
+import Control.Selective (Selective)
+import Data.Error.Tree
+import Data.Functor.Compose (Compose (..))
+import PossehlAnalyticsPrelude
+import ServerErrors
+
+-- | A simple way to create an Applicative parser that parses from some environment.
+--
+-- Use with DerivingVia. Grep codebase for examples.
+newtype ValidationParseT env m a = ValidationParseT {unValidationParseT :: env -> m (Validation (NonEmpty Error) a)}
+ deriving
+ (Functor, Applicative, Selective)
+ via ( Compose
+ ((->) env)
+ (Compose m (Validation (NonEmpty Error)))
+ )
+
+-- | Helper that runs the given parser and throws a user error if the parsing failed.
+runValidationParseTOrUserError ::
+ forall validationParseT env m a.
+ ( Coercible validationParseT (ValidationParseT env m a),
+ MonadLogger m,
+ MonadThrow m
+ ) =>
+ -- | toplevel error message to throw if the parsing fails
+ Error ->
+ -- | The parser which should be run
+ validationParseT ->
+ -- | input to the parser
+ env ->
+ m a
+{-# INLINE runValidationParseTOrUserError #-}
+runValidationParseTOrUserError contextError parser env =
+ (coerce @_ @(ValidationParseT _ _ _) parser).unValidationParseT env
+ >>= \case
+ Failure errs -> throwUserErrorTree (errorTree contextError errs)
+ Success a -> pure a