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>

1 files changed, 244 insertions, 0 deletions

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