feat: Hyperbole port - all modules created, Database effect working

- Database.hs: effectful DB effect with all operations + convenience wrappers - Types.hs: stripped Aeson (kept ToJSON/FromJSON on IDs), added form types - Route.hs, Style.hs, View/Layout.hs: support modules - All Page modules: Login, Signup, Dashboard, Chores, Household, Activity - Main.hs: Hyperbole app entry point with router - Known issue: Hyperbole view DSL syntax needs cleanup in page modules (tag calls need $ none suffix, form elements need field wrappers)
2026-07-16 06:38:34 -04:00
parent b92947cdcc
commit 7eaf6ab7e7
13 changed files with 1160 additions and 80 deletions
@@ -0,0 +1,64 @@
+{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-}
+
+module Sis.Page.Login (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 LoginPage = LoginPage
+    deriving stock (Generic)
+    deriving anyclass (ViewId)
+instance (DB :> 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)))
+                    redirect (routeUri RouteDashboard)
+                    pure (el "Redirecting...")
+            _ -> pure (loginView (Just "Invalid email or password"))
+    update Noop = pure (loginView Nothing)
+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" nbFontHeading1Class $ 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%"
+                el @ att "class" nbLabelClass $ text "Password"
+                tag "input" @ att "type" "password" . att "name" "lfPassword" . att "class" nbInputClass @ att "style" "width:100%"
+                el @ att "style" "display:flex;align-items:center;gap:0.5rem;margin-bottom:1rem" $ do
+                    tag "input" @ att "type" "checkbox" . att "name" "lfRemember"
+                    text "Remember me"
+                submit (text "Log In") @ att "class" nbButtonClass @ att "style" "width:100%"
+            route RouteSignup $ text "Don't have an account? Sign Up"
+page :: (Hyperbole :> es, DB :> es) => Eff es (View LoginPage ())
+page = do
+    mSession <- lookupSession @UserSession
+    case mSession of
+        Just _ -> do
+            redirect (routeUri RouteDashboard)
+            pure (el "Redirecting...")
+        Nothing -> pure (loginView Nothing)