Forms.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

module Example.Forms where

import Data.Text as T (Text, elem, length, pack)
import Effectful
import Example.Style qualified as Style
import Web.Hyperbole


page :: (Hyperbole :> es) => Page es Response
page = do
  handle formAction

  load $ do
    pure $ row (pad 20) $ do
      hyper FormView (formView mempty)


data FormView = FormView
  deriving (Generic, Param)


data FormAction = Submit
  deriving (Generic, Param)


instance HyperView FormView where
  type Action FormView = FormAction


-- Form Fields
data User = User Text deriving (Generic, FormField)
data Age = Age Int deriving (Generic, FormField)
data Pass1 = Pass1 Text deriving (Generic, FormField)
data Pass2 = Pass2 Text deriving (Generic, FormField)


formAction :: (Hyperbole :> es) => FormView -> FormAction -> Eff es (View FormView ())
formAction _ Submit = do
  u <- formField @User
  a <- formField @Age
  p1 <- formField @Pass1
  p2 <- formField @Pass2

  case validateUser u a p1 p2 of
    Validation [] -> pure $ userView u a p1
    errs -> pure $ formView errs


validateUser :: User -> Age -> Pass1 -> Pass2 -> Validation
validateUser (User u) (Age a) (Pass1 p1) (Pass2 p2) =
  validation
    [ validate @Age (a < 20) "User must be at least 20 years old"
    , validate @User (T.elem ' ' u) "Username must not contain spaces"
    , validate @User (T.length u < 4) "Username must be at least 4 chars"
    , validate @Pass1 (p1 /= p2) "Passwords did not match"
    , validate @Pass1 (T.length p1 < 8) "Password must be at least 8 chars"
    ]


formView :: Validation -> View FormView ()
formView v = do
  form Submit v (gap 10 . pad 10) $ do
    el Style.h1 "Sign Up"

    field @User id Style.invalid $ do
      label "Username"
      input Username (inp . placeholder "username")
      el_ invalidText

    field @Age id Style.invalid $ do
      label "Age"
      input Number (inp . placeholder "age" . value "0")
      el_ invalidText

    field @Pass1 id Style.invalid $ do
      label "Password"
      input NewPassword (inp . placeholder "password")
      el_ invalidText

    field @Pass2 id id $ do
      label "Repeat Password"
      input NewPassword (inp . placeholder "repeat password")

    submit Style.btn "Submit"
 where
  inp = border 1 . pad 8




userView :: User -> Age -> Pass1 -> View FormView ()
userView (User user) (Age age) (Pass1 pass1) = do
  el (bold . Style.success) "Accepted Signup"
  row (gap 5) $ do
    el_ "Username:"
    el_ $ text user

  row (gap 5) $ do
    el_ "Age:"
    el_ $ text $ pack (show age)

  row (gap 5) $ do
    el_ "Password:"
    el_ $ text pass1