mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

feat(users/Profpatsch): init HtmxExperiment

Browse source 
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>
This commit is contained in:
Profpatsch 2023-05-28 17:39:21 +02:00
parent 6a15e8e71a
commit ee21f725a3
9 changed files with 1104 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
users/Profpatsch/cabal.project Normal file
View file

@ -0,0 +1,3 @@
packages:
./my-prelude/my-prelude.cabal
./htmx-experiment/htmx-experiment.cabal

11
users/Profpatsch/hie.yaml Normal file
View file

@ -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"

4
users/Profpatsch/htmx-experiment/Main.hs Normal file
View file

@ -0,0 +1,4 @@
import HtmxExperiment qualified
main :: IO ()
main = HtmxExperiment.main

51
users/Profpatsch/htmx-experiment/default.nix Normal file
View file

@ -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

94
users/Profpatsch/htmx-experiment/htmx-experiment.cabal Normal file
View file

@ -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,

430
users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs Normal file
View file

@ -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)
)

227
users/Profpatsch/htmx-experiment/src/Multipart.hs Normal file
View file

@ -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,
..
}

244
users/Profpatsch/htmx-experiment/src/ServerErrors.hs Normal file
View file

@ -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

40
users/Profpatsch/htmx-experiment/src/ValidationParseT.hs Normal file
View file

@ -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