6 files changed, 800 insertions, 0 deletions
diff --git a/users/Profpatsch/htmx-experiment/Main.hs b/users/Profpatsch/htmx-experiment/Main.hs
new file mode 100644
index 0000000000..29ce8610ff
--- /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 0000000000..ef1a28bd2b
--- /dev/null
+++ b/users/Profpatsch/htmx-experiment/default.nix
@@ -0,0 +1,46 @@
+{ 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/ServerErrors.hs
+      ./src/ValidationParseT.hs
+    ];
+
+    libraryHaskellDepends = [
+      depot.users.Profpatsch.my-webstuff
+      pkgs.haskellPackages.pa-label
+      pkgs.haskellPackages.pa-error-tree
+      pkgs.haskellPackages.blaze-html
+      pkgs.haskellPackages.blaze-markup
+      pkgs.haskellPackages.bytestring
+      pkgs.haskellPackages.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.selective
+      pkgs.haskellPackages.text
+      pkgs.haskellPackages.unliftio
+      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 0000000000..e9a0d93614
--- /dev/null
+++ b/users/Profpatsch/htmx-experiment/htmx-experiment.cabal
@@ -0,0 +1,89 @@
+cabal-version:      3.0
+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,
+      ServerErrors,
+      ValidationParseT
+    hs-source-dirs: ./src
+
+    build-depends:
+        base >=4.15 && <5,
+        -- http-api-data
+        blaze-html,
+        blaze-markup,
+        bytestring,
+        dlist,
+        http-types,
+        ihp-hsx,
+        monad-logger,
+        pa-error-tree,
+        pa-field-parser,
+        pa-label,
+        pa-prelude,
+        my-webstuff,
+        selective,
+        text,
+        unliftio,
+        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 0000000000..225206a584
--- /dev/null
+++ b/users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs
@@ -0,0 +1,377 @@
+{-# 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 qualified as Bytes
+import Data.DList (DList)
+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 Multipart2 (FormValidation (FormValidation), FormValidationResult, MultipartParseT, failFormValidation)
+import Multipart2 qualified as Multipart
+import Network.HTTP.Types qualified as Http
+import Network.Wai qualified as Wai
+import Network.Wai.Handler.Warp qualified as Warp
+import PossehlAnalyticsPrelude
+import ServerErrors (ServerError (..), throwUserErrorTree)
+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 backend m b ->
+  Wai.Request ->
+  m b
+parsePostBody parser req =
+  Multipart.parseMultipartOrThrow throwUserErrorTree parser req
+
+-- 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 :: ByteString,
+    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" ByteString "password" ByteString))
+registerFormValidate = do
+  let emailFP = FieldParser $ \b ->
+        if
+            | Bytes.elem (charToWordUnsafe '@') b -> Right b
+            | otherwise -> Left [fmt|This is not an email address: "{b & bytesToTextUtf8Unsafe}"|]
+
+  getCompose @(MultipartParseT _ _) @FormValidation $ do
+    email <- Compose $ Multipart.fieldLabel' @"email" "email" emailFP
+    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/ServerErrors.hs b/users/Profpatsch/htmx-experiment/src/ServerErrors.hs
new file mode 100644
index 0000000000..0fca7ab464
--- /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 0000000000..ffb6c2f395
--- /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