diff options
Diffstat (limited to 'users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs')
| -rw-r--r-- | users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs | 430 |
1 files changed, 430 insertions, 0 deletions
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) + ) |