jbrechtel
dbfe3a7c66
- Fix 8 hlint hints across 6 files (unused pragma, newtype, lambda, redundant brackets/\$) - Add blank line after LANGUAGE pragma in Route.hs (fourmolu) - Fix HouseholdFormData deriving to use explicit strategies for newtype - Update AGENTS.md: require hlint clean before every commit, add pre-commit checklist (format, lint, build, test), update NB CSS URL to jsdelivr CDN
84 lines
4.0 KiB
Haskell
84 lines
4.0 KiB
Haskell
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-redundant-constraints #-}
|
|
|
|
module Sis.Page.Login (page) where
|
|
|
|
import Data.Text (Text)
|
|
import Data.Text qualified as T
|
|
import Effectful
|
|
import Sis.Auth (generateToken, hashPassword, verifyPassword)
|
|
import Sis.Database
|
|
import Sis.Route
|
|
import Sis.Style (colorGreen, colorRed, colorYellow, nbBadgeClass, nbBoxClass, nbButtonDefaultClass, nbContainerClass, nbHeadingClass, nbInputClass, nbLabelClass, nbListItemClass)
|
|
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 LoginPage = LoginPage
|
|
deriving stock (Generic)
|
|
deriving anyclass (ViewId)
|
|
instance (DB :> es, IOE :> es) => HyperView LoginPage es where
|
|
data Action LoginPage
|
|
= SubmitLogin
|
|
| Noop
|
|
deriving stock (Generic)
|
|
deriving anyclass (ViewAction)
|
|
update SubmitLogin = do
|
|
formData' <- formData @LoginForm
|
|
mUser <- findUserByEmail (lfEmail formData')
|
|
case mUser of
|
|
Just u
|
|
| verifyPassword (lfPassword formData') (userPasswordHash u) -> do
|
|
saveSession (UserSession (unUserId (userId u)))
|
|
pure loginSuccessView
|
|
_ -> pure (loginView (Just "Invalid email or password"))
|
|
update Noop = pure (loginView Nothing)
|
|
|
|
loginSuccessView :: View LoginPage ()
|
|
loginSuccessView = do
|
|
el @ att "class" nbContainerClass @ att "style" "max-width:480px;margin:4rem auto;text-align:center" $ do
|
|
el @ att "class" nbBoxClass @ att "style" "padding:2rem" $ do
|
|
el @ att "class" nbHeadingClass $ text "Logged In!"
|
|
el @ att "style" "margin-top:1rem;margin-bottom:1rem" $ text "You are now logged in."
|
|
route RDashboard @ att "class" nbButtonDefaultClass $ text "Go to Dashboard"
|
|
|
|
loginView :: Maybe Text -> View LoginPage ()
|
|
loginView 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" nbHeadingClass $ text "Welcome Back"
|
|
el @ att "style" "opacity:0.7;margin-bottom:1.5rem" $ text "Log in to manage your household chores."
|
|
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 SubmitLogin $ do
|
|
el @ att "class" nbLabelClass $ text "Email"
|
|
tag "input" @ att "type" "email" . att "name" "lfEmail" . att "class" nbInputClass @ att "style" "width:100%" $ none
|
|
el @ att "class" nbLabelClass $ text "Password"
|
|
tag "input" @ att "type" "password" . att "name" "lfPassword" . 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" "lfRemember" . att "class" "nb-checkbox" $ none
|
|
el @ att "class" nbLabelClass $ text "Remember me"
|
|
submit (text "Log In") @ att "class" nbButtonDefaultClass @ att "style" "width:100%"
|
|
el @ att "style" "margin-top:1rem;text-align:center" $ do
|
|
route RSignup @ att "class" nbButtonDefaultClass $ text "Sign Up"
|
|
page :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[LoginPage]
|
|
page = do
|
|
mSession <- lookupSession @UserSession
|
|
case mSession of
|
|
Just _ -> do
|
|
redirect (routeUri RDashboard)
|
|
Nothing -> pure $ hyper LoginPage $ loginView Nothing
|