feat(users/Profpatsch): init HtmxExperiment r/6408

I’m playing around with htmx (server-side html snippet rendering),
this is a simple registration form and some form validation that
happens in-place.

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

9 files changed, 1104 insertions, 0 deletions

diff --git a/users/Profpatsch/cabal.project b/users/Profpatsch/cabal.project
new file mode 100644
index 000000000000..d82af89d5417
--- /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 000000000000..895120d42b0e
--- /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 000000000000..29ce8610ff3e
--- /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 000000000000..13ff4f3939c9
--- /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 000000000000..e287a850152c
--- /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 000000000000..59cfdf3237a7
--- /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|
+            <head>
+              <script src="https://unpkg.com/htmx.org@1.9.2" integrity="sha384-L6OqL9pRWyyFU3+/bjdSri+iIphTN/bvYyM37tICVyOJkWZLpP2vGn6VUEXgzg6h" crossorigin="anonymous"></script>
+            </head>
+            <body>
+              {inner}
+            </body>
+        |]
+      res <-
+        case req & Wai.pathInfo of
+          [] ->
+            pure $
+              respondOk $
+                htmlRoot
+                  [hsx|
+                      <div id="register_buttons">
+                        <button hx-get="/register" hx-target="body" hx-push-url="/register">Register an account</button>
+                        <button hx-get="/login" hx-target="body">Login</button>
+                      </div>
+              |]
+          ["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|
+      <label for={id_}>{label_}
+        <input
+          autofocus={isFirstError}
+          onfocus="this.select()"
+          required={required}
+          id={id_}
+          name={name}
+          type={type_}
+          placeholder={placeholder}
+          value={validation.originalValue.getFirst}
+        />
+        <p id="{id_}.validation">{validation.errors & nonEmpty <&> toList <&> map prettyError <&> Text.intercalate "; "}</p>
+      </label>
+  |]
+
+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|
+  <form hx-post="/register/submit">
+    <fieldset>
+      <legend>Register user</legend>
+      {fields validationErrors}
+      <button id="register_submit_button" name="register">
+        Register
+      </button>
+    </fieldset>
+  </form>
+  |]
+
+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 000000000000..59650887c633
--- /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 @\<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/htmx-experiment/src/ServerErrors.hs b/users/Profpatsch/htmx-experiment/src/ServerErrors.hs
new file mode 100644
index 000000000000..0fca7ab46424
--- /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 000000000000..ffb6c2f395cb
--- /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