diff options
Diffstat (limited to 'users/Profpatsch/htmx-experiment')
| -rw-r--r-- | users/Profpatsch/htmx-experiment/Main.hs | 4 | ||||
| -rw-r--r-- | users/Profpatsch/htmx-experiment/default.nix | 46 | ||||
| -rw-r--r-- | users/Profpatsch/htmx-experiment/htmx-experiment.cabal | 89 | ||||
| -rw-r--r-- | users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs | 377 | ||||
| -rw-r--r-- | users/Profpatsch/htmx-experiment/src/ServerErrors.hs | 244 | ||||
| -rw-r--r-- | users/Profpatsch/htmx-experiment/src/ValidationParseT.hs | 40 |
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 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..ef1a28bd2b05 --- /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 000000000000..e9a0d9361486 --- /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 000000000000..225206a5843d --- /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 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 |