diff options
author | Profpatsch <mail@profpatsch.de> | 2023-05-28T15·39+0200 |
---|---|---|
committer | Profpatsch <mail@profpatsch.de> | 2023-07-13T20·50+0000 |
commit | ee21f725a38855e43fd8e82eb8c6c6fc99aca235 (patch) | |
tree | 7c49c266b0bc0262857b72cbb9b828bd96621f22 /users | |
parent | 6a15e8e71ab318b47e4c62d90f8e541b45df7fd4 (diff) |
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>
Diffstat (limited to '')
-rw-r--r-- | users/Profpatsch/cabal.project | 3 | ||||
-rw-r--r-- | users/Profpatsch/hie.yaml | 11 | ||||
-rw-r--r-- | users/Profpatsch/htmx-experiment/Main.hs | 4 | ||||
-rw-r--r-- | users/Profpatsch/htmx-experiment/default.nix | 51 | ||||
-rw-r--r-- | users/Profpatsch/htmx-experiment/htmx-experiment.cabal | 94 | ||||
-rw-r--r-- | users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs | 430 | ||||
-rw-r--r-- | users/Profpatsch/htmx-experiment/src/Multipart.hs | 227 | ||||
-rw-r--r-- | users/Profpatsch/htmx-experiment/src/ServerErrors.hs | 244 | ||||
-rw-r--r-- | users/Profpatsch/htmx-experiment/src/ValidationParseT.hs | 40 |
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 |