jbrechtel
c45ae41645
- Fix tag calls to use \$ none for self-closing tags - Add IOE constraint to HyperView instances - Add warning suppressions where needed - Fix Form data type imports - Remove duplicate getUserHouseholds helpers - Remaining issues: String/Text mismatches in text calls, a few view DSL type errors in Dashboard/Chores
76 lines
4.1 KiB
Haskell
76 lines
4.1 KiB
Haskell
{-# OPTIONS_GHC -Wno-name-shadowing #-}
|
|
{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-}
|
|
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-redundant-constraints #-}
|
|
|
|
module Sis.Page.Signup (page) where
|
|
import Effectful
|
|
import Data.Text (Text)
|
|
import Data.Text qualified as T
|
|
import Sis.Database
|
|
import Sis.Auth (hashPassword, verifyPassword, generateToken)
|
|
import Sis.Route
|
|
import Sis.Style
|
|
import Sis.Types
|
|
import Sis.View.Layout
|
|
import Web.Hyperbole
|
|
import Web.Hyperbole.Effect.Session
|
|
import Web.Hyperbole.HyperView.Forms
|
|
import Web.Hyperbole.Page
|
|
data SignupPage = SignupPage
|
|
deriving stock (Generic)
|
|
deriving anyclass (ViewId)
|
|
instance (DB :> es, IOE :> es) => HyperView SignupPage es where
|
|
data Action SignupPage
|
|
= SubmitSignup
|
|
deriving stock (Generic)
|
|
deriving anyclass (ViewAction)
|
|
update SubmitSignup = do
|
|
form <- formData @SignupForm
|
|
if T.length (sfPassword form) < 8
|
|
then pure (signupView (Just "Password must be at least 8 characters"))
|
|
else
|
|
if sfPassword form /= sfConfirm form
|
|
then pure (signupView (Just "Passwords do not match"))
|
|
else do
|
|
mExisting <- findUserByEmail (sfEmail form)
|
|
case mExisting of
|
|
Just _ -> pure (signupView (Just "Email already registered"))
|
|
Nothing -> do
|
|
pwHash <- liftIO (hashPassword (sfPassword form))
|
|
uid <- createUser (sfDisplayName form) (sfEmail form) pwHash
|
|
saveSession (UserSession (unUserId uid))
|
|
redirect (routeUri RouteDashboard)
|
|
pure (el "Redirecting...")
|
|
signupView :: Maybe Text -> View SignupPage ()
|
|
signupView mError = do
|
|
el @ att "class" nbContainerClass @ att "style" "max-width:480px;margin:4rem auto" $ do
|
|
el @ att "class" nbBoxClass @ att "style" "padding:2rem" $ do
|
|
el @ att "class" nbFontHeading1Class $ text "Create Account"
|
|
el @ att "style" "opacity:0.7;margin-bottom:1.5rem" $ text "Join your household chore tracker."
|
|
case mError of
|
|
Just err ->
|
|
el @ att "class" nbBoxClass @ att "style" ("border-color:" <> colorRed <> ";color:" <> colorRed <> ";padding:0.5rem;margin-bottom:1rem") $ text err
|
|
Nothing -> none
|
|
form SubmitSignup $ do
|
|
el @ att "class" nbLabelClass $ text "Display Name"
|
|
tag "input" @ att "type" "text" . att "name" "sfDisplayName" . att "class" nbInputClass @ att "style" "width:100%" $ none
|
|
el @ att "class" nbLabelClass $ text "Email"
|
|
tag "input" @ att "type" "email" . att "name" "sfEmail" . att "class" nbInputClass @ att "style" "width:100%" $ none
|
|
el @ att "class" nbLabelClass $ text "Password (min 8 characters)"
|
|
tag "input" @ att "type" "password" . att "name" "sfPassword" . att "class" nbInputClass @ att "style" "width:100%" $ none
|
|
el @ att "class" nbLabelClass $ text "Confirm Password"
|
|
tag "input" @ att "type" "password" . att "name" "sfConfirm" . att "class" nbInputClass @ att "style" "width:100%" $ none
|
|
el @ att "style" "display:flex;align-items:center;gap:0.5rem;margin-bottom:1rem" $ do
|
|
tag "input" @ att "type" "checkbox" . att "name" "sfAgree" $ none
|
|
text "I agree to the terms of service"
|
|
submit (text "Sign Up") @ att "class" nbButtonClass @ att "style" "width:100%"
|
|
route RouteLogin $ text "Already have an account? Log In"
|
|
page :: (Hyperbole :> es, DB :> es) => Eff es (View SignupPage ())
|
|
page = do
|
|
mSession <- lookupSession @UserSession
|
|
case mSession of
|
|
Just _ -> do
|
|
redirect (routeUri RouteDashboard)
|
|
pure (el "Redirecting...")
|
|
Nothing -> pure (signupView Nothing)
|