From 7eaf6ab7e781c2865f24622e44773d4dc8547ba7 Mon Sep 17 00:00:00 2001 From: James Brechtel Date: Thu, 16 Jul 2026 06:38:34 -0400 Subject: [PATCH] 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) --- app/Main.hs | 105 ++++------ sis-server.cabal | 9 + src/Sis/Database.hs | 421 ++++++++++++++++++++++++++++++++++++-- src/Sis/Page/Activity.hs | 101 +++++++++ src/Sis/Page/Chores.hs | 95 +++++++++ src/Sis/Page/Dashboard.hs | 112 ++++++++++ src/Sis/Page/Household.hs | 126 ++++++++++++ src/Sis/Page/Login.hs | 64 ++++++ src/Sis/Page/Signup.hs | 73 +++++++ src/Sis/Route.hs | 20 ++ src/Sis/Style.hs | 33 +++ src/Sis/Types.hs | 11 +- src/Sis/View/Layout.hs | 70 +++++++ 13 files changed, 1160 insertions(+), 80 deletions(-) create mode 100644 src/Sis/Page/Activity.hs create mode 100644 src/Sis/Page/Chores.hs create mode 100644 src/Sis/Page/Dashboard.hs create mode 100644 src/Sis/Page/Household.hs create mode 100644 src/Sis/Page/Login.hs create mode 100644 src/Sis/Page/Signup.hs create mode 100644 src/Sis/Route.hs create mode 100644 src/Sis/Style.hs create mode 100644 src/Sis/View/Layout.hs diff --git a/app/Main.hs b/app/Main.hs index 1200dcb..a9f8b7c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,74 +1,55 @@ {-# LANGUAGE OverloadedStrings #-} -{- | Entry point for the Sis server. - -Starts a Warp HTTP server, serves the JSON API and the SPA frontend. --} -module Main (main) where +module Main where +import Effectful import Network.Wai.Handler.Warp qualified as Warp -import Options.Applicative qualified as Opt -import System.Posix.Signals qualified as Signals +import Network.Wai.Middleware.Static qualified as Static +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory) -import Sis.Database qualified as Database -import Sis.Server qualified as Sis - -data Options = Options - { optPort :: Int - , optStaticDir :: FilePath - , optDbPath :: FilePath - } - -optionsParser :: Opt.Parser Options -optionsParser = - Options - <$> Opt.option - Opt.auto - ( Opt.long "port" - <> Opt.short 'p' - <> Opt.metavar "PORT" - <> Opt.help "Listen port" - <> Opt.value 8080 - <> Opt.showDefault - ) - <*> Opt.strOption - ( Opt.long "static-dir" - <> Opt.metavar "DIR" - <> Opt.help "Directory containing the SPA frontend static files" - <> Opt.value "frontend/dist" - <> Opt.showDefault - ) - <*> Opt.strOption - ( Opt.long "db-path" - <> Opt.metavar "PATH" - <> Opt.help "Path to the SQLite database file" - <> Opt.value "data/sis.db" - <> Opt.showDefault - ) +import Sis.Database +import Sis.Page.Activity +import Sis.Page.Chores +import Sis.Page.Dashboard +import Sis.Page.Household +import Sis.Page.Login +import Sis.Page.Signup +import Sis.Route +import Sis.View.Layout (documentHead) +import Web.Hyperbole +import Web.Hyperbole.Application +import Web.Hyperbole.Effect.Response +import Web.Hyperbole.Page +import Web.Hyperbole.Route main :: IO () main = do - opts <- - Opt.execParser $ - Opt.info (optionsParser Opt.<**> Opt.helper) $ - Opt.fullDesc - <> Opt.progDesc "Sis — shared household chore tracker" - <> Opt.header "sis-server" + let dbPath = "data/sis.db" + createDirectoryIfMissing True (takeDirectory dbPath) - db <- Database.openDatabase (optDbPath opts) + putStrLn "[sis] opening database..." + conn <- openDatabase dbPath - _ <- - Signals.installHandler - Signals.sigTERM - (Signals.Catch (putStrLn "[sis] shutting down")) - Nothing + let port = 8080 + putStrLn $ "[sis] listening on 0.0.0.0:" <> show port - let waiApp = Sis.app (optStaticDir opts) db + Warp.run port $ + Static.staticPolicy (Static.addBase "frontend/static") $ + liveAppWith + (ServerOptions + { toDocument = document documentHead + , serverError = defaultError + , parseRequestBody = defaultParseRequestBodyOptions + }) + (runDB conn $ routeRequest router) - let settings = - Warp.setPort (optPort opts) $ - Warp.setBeforeMainLoop - (putStrLn $ "[sis] listening on 0.0.0.0:" ++ show (optPort opts)) - Warp.defaultSettings - - Warp.runSettings settings waiApp +router :: (Hyperbole :> es, DB :> es) => AppRoute -> Eff es Response +router RouteHome = do + redirect (routeUri RouteDashboard) +router RouteLogin = runPage Sis.Page.Login.page +router RouteSignup = runPage Sis.Page.Signup.page +router RouteDashboard = runPage Sis.Page.Dashboard.page +router RouteChores = runPage Sis.Page.Chores.page +router RouteHousehold = runPage Sis.Page.Household.page +router RouteActivity = runPage Sis.Page.Activity.page diff --git a/sis-server.cabal b/sis-server.cabal index f991caf..02e6db4 100644 --- a/sis-server.cabal +++ b/sis-server.cabal @@ -19,7 +19,16 @@ library Sis Sis.Auth Sis.Database + Sis.Page.Activity + Sis.Page.Chores + Sis.Page.Dashboard + Sis.Page.Household + Sis.Page.Login + Sis.Page.Signup + Sis.Route + Sis.Style Sis.Types + Sis.View.Layout other-modules: Paths_sis_server autogen-modules: diff --git a/src/Sis/Database.hs b/src/Sis/Database.hs index af587b8..ad02886 100644 --- a/src/Sis/Database.hs +++ b/src/Sis/Database.hs @@ -1,23 +1,357 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -{- | SQLite database support for Sis. - -Opens (and creates if missing) a SQLite database with WAL journal -mode and foreign keys enabled. Runs schema migrations on startup. +{- | SQLite database support for Sis using the effectful effect system. -} -module Sis.Database ( - openDatabase, - runMigrations, -) where +module Sis.Database + ( -- * Effect + DB (..) + , runDB + , openDatabase + , runMigrations + -- * DB operations (convenience wrappers) + , findUserByEmail + , createUser + , getUser + , getUserHouseholds + , getHousehold + , createHousehold + , getMembers + , getChores + , createChore + , updateChore + , deleteChore + , getDashboard + , recordActivity + , getActivityLog + , createInvite + , getInvites + , revokeInvite + , acceptInvite + , seed + ) where + +import Control.Monad (when) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (Day, UTCTime, addDays, getCurrentTime, utctDay) +import Data.Time qualified as Time +import Data.Time.Calendar (addGregorianMonthsClip) import Database.SQLite.Simple qualified as SQL +import Database.SQLite.Simple (Only (..)) +import Text.Read (readMaybe) +import Effectful +import Effectful.Dispatch.Dynamic import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) -{- | Open (or create) a SQLite database at the given path. +import Sis.Types -Enables WAL journal mode for concurrent read performance and -enables foreign key enforcement. +---------------------------------------------------------------------- +-- Effect definition +---------------------------------------------------------------------- + +data DB :: Effect where + FindUserByEmail :: Text -> DB m (Maybe User) + CreateUser :: Text -> Text -> Text -> DB m UserId + GetUser :: UserId -> DB m (Maybe User) + GetUserHouseholds :: UserId -> DB m [Household] + GetHousehold :: UserId -> Int -> DB m (Maybe Household) + CreateHousehold :: UserId -> Text -> DB m Household + GetMembers :: Int -> DB m [Membership] + GetChores :: Int -> DB m [Chore] + CreateChore :: Int -> Text -> ChoreAssignee -> Schedule -> Bool -> DB m Chore + UpdateChore :: Int -> Int -> Text -> ChoreAssignee -> Schedule -> Bool -> DB m Chore + DeleteChore :: Int -> DB m () + GetDashboard :: Int -> Day -> DB m Dashboard + GenerateOccurrences :: Chore -> DB m () + RecordActivity :: Int -> UserId -> ActivityStatus -> Maybe Text -> Bool -> DB m Activity + GetActivityLog :: Int -> Int -> Int -> DB m ActivityLogPage + CreateInvite :: Int -> Maybe Text -> DB m Invite + GetInvites :: Int -> DB m [Invite] + RevokeInvite :: Int -> DB m () + AcceptInvite :: UserId -> Text -> DB m Household + Seed :: DB m () + +type instance DispatchOf DB = 'Dynamic + +---------------------------------------------------------------------- +-- Handler +---------------------------------------------------------------------- + +runDB :: (IOE :> es) => SQL.Connection -> Eff (DB : es) a -> Eff es a +runDB conn = interpret $ \_ -> \case + FindUserByEmail email -> liftIO $ do + result <- SQL.query conn + "SELECT id, display_name, email, password_hash FROM users WHERE email = ?" + (Only email) + pure $ listToMaybe [User (UserId uid) dname em pwHash | (uid, dname, em, pwHash) <- result] + + CreateUser dname email pwHash -> liftIO $ do + SQL.execute conn + "INSERT INTO users (display_name, email, password_hash) VALUES (?, ?, ?)" + (dname, email, pwHash) + uid <- SQL.lastInsertRowId conn + pure $ UserId (fromIntegral uid) + + GetUser (UserId uid) -> liftIO $ do + result <- SQL.query conn + "SELECT id, display_name, email, password_hash FROM users WHERE id = ?" + (Only uid) + pure $ listToMaybe [User (UserId uid') dname em pwHash | (uid', dname, em, pwHash) <- result] + + GetUserHouseholds (UserId uid) -> liftIO $ do + rows <- SQL.query conn + "SELECT h.id, h.name, m2.user_id, \ + \ (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \ + \ FROM households h JOIN memberships m ON m.household_id = h.id AND m.user_id = ? \ + \ JOIN memberships m2 ON m2.household_id = h.id AND m2.role = 'owner'" + (Only uid) + pure [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- rows] + + GetHousehold (UserId uid) hid -> liftIO $ do + result <- SQL.query conn + "SELECT h.id, h.name, m2.user_id, (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \ + \ FROM households h JOIN memberships m ON m.household_id = h.id AND m.user_id = ? \ + \ JOIN memberships m2 ON m2.household_id = h.id AND m2.role = 'owner' WHERE h.id = ?" + (uid, hid) + pure $ listToMaybe [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- result] + + CreateHousehold (UserId uid) name -> liftIO $ do + SQL.execute conn "INSERT INTO households (name) VALUES (?)" (Only name) + hId <- SQL.lastInsertRowId conn + let hid = HouseholdId (fromIntegral hId) + SQL.execute conn + "INSERT INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)" + (unHouseholdId hid, uid, "owner" :: String) + pure $ Household hid name (UserId uid) 1 + + GetMembers hid -> liftIO $ do + members <- SQL.query conn + "SELECT u.id, u.display_name, u.email, m.role \ + \ FROM memberships m JOIN users u ON u.id = m.user_id WHERE m.household_id = ?" + (Only hid) + pure [Membership (UserId uid) dname email (if role == ("owner" :: String) then OwnerRole else MemberRole) + | (uid, dname, email, role) <- members] + + GetChores hid -> liftIO $ do + chores <- SQL.query conn + "SELECT id, household_id, name, assignee_type, assignee_user_id, schedule_data, notify_on_due, created_at \ + \ FROM chores WHERE household_id = ?" + (Only hid) :: IO [(Int, Int, Text, String, Maybe Int, Text, Int, UTCTime)] + pure [Chore { choreId = ChoreId cid + , choreHouseholdId = HouseholdId hId + , choreName = cname + , choreAssignee = mkAssignee atype auid + , choreSchedule = mkSchedule sData + , choreNotifyOnDue = nud /= 0 + , choreCreatedAt = createdAt + } + | (cid, hId, cname, atype, auid, sData, nud, createdAt) <- chores] + where + mkAssignee "user" (Just uid) = AssigneeUser (UserId uid) + mkAssignee _ _ = AssigneeAnyone + mkSchedule sData = fromMaybe ScheduleSometime (readMaybe (T.unpack sData)) + + CreateChore hid name assignee schedule notify -> liftIO $ do + now <- Time.getCurrentTime + let (aType, aUid) = case assignee of AssigneeUser (UserId uid) -> ("user" :: String, Just uid); AssigneeAnyone -> ("anyone", Nothing) + sType = case schedule of ScheduleOneOff{} -> "one_off" :: String; ScheduleRecurring{} -> "recurring"; ScheduleSometime -> "sometime" + sData = show schedule + SQL.execute conn + "INSERT INTO chores (household_id, name, assignee_type, assignee_user_id, schedule_type, schedule_data, notify_on_due, created_at) \ + \ VALUES (?,?,?,?,?,?,?,?)" + (hid, name, aType, aUid, sType, sData, if notify then 1 :: Int else 0, now) + cId <- SQL.lastInsertRowId conn + let chore = Chore (ChoreId (fromIntegral cId)) (HouseholdId hid) name assignee schedule notify now + generateOccurrencesIO conn chore + pure chore + + UpdateChore cid hid name assignee schedule notify -> liftIO $ do + now <- Time.getCurrentTime + let (aType, aUid) = case assignee of AssigneeUser (UserId uid) -> ("user" :: String, Just uid); AssigneeAnyone -> ("anyone", Nothing) + sType = case schedule of ScheduleOneOff{} -> "one_off" :: String; ScheduleRecurring{} -> "recurring"; ScheduleSometime -> "sometime" + sData = show schedule + SQL.execute conn + "UPDATE chores SET name=?, assignee_type=?, assignee_user_id=?, schedule_type=?, schedule_data=?, notify_on_due=? WHERE id=? AND household_id=?" + (name, aType, aUid, sType, sData, if notify then 1 :: Int else 0, cid, hid) + SQL.execute conn "DELETE FROM occurrences WHERE chore_id = ? AND status IN ('due', 'overdue')" (Only cid) + let chore = Chore (ChoreId cid) (HouseholdId hid) name assignee schedule notify now + generateOccurrencesIO conn chore + pure chore + + DeleteChore cid -> liftIO $ do + SQL.execute conn "DELETE FROM chores WHERE id = ?" (Only cid) + + GetDashboard hid today -> liftIO $ do + let todayStr = show today + let weekAgo = show (addDays (-7) today) + [Only overdueCount] <- SQL.query conn + "SELECT COUNT(*) FROM occurrences o JOIN chores c ON c.id = o.chore_id \ + \ WHERE c.household_id = ? AND o.due_date < ? AND o.status IN ('due', 'overdue')" + (hid, todayStr) + [Only dueTodayCount] <- SQL.query conn + "SELECT COUNT(*) FROM occurrences o JOIN chores c ON c.id = o.chore_id \ + \ WHERE c.household_id = ? AND o.due_date = ? AND o.status = 'due'" + (hid, todayStr) + [Only doneThisWeek] <- SQL.query conn + "SELECT COUNT(*) FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id \ + \ WHERE c.household_id = ? AND a.recorded_at >= ?" + (hid, weekAgo) + let stats = DashboardStats overdueCount dueTodayCount doneThisWeek + dueRows <- SQL.query conn + "SELECT o.id, o.chore_id, o.due_date, o.status, c.name, u.display_name \ + \ FROM occurrences o JOIN chores c ON c.id = o.chore_id LEFT JOIN users u ON u.id = c.assignee_user_id \ + \ WHERE c.household_id = ? AND o.due_date <= ? AND o.status IN ('due', 'overdue') ORDER BY o.due_date LIMIT 50" + (hid, todayStr) :: IO [(Int, Int, Day, Text, Text, Maybe Text)] + let dueItems = [DueItem (Occurrence (OccurrenceId oid) (ChoreId cid) d (mkOcc st)) cn uname (d < today) | (oid, cid, d, st, cn, uname) <- dueRows] + compRows <- SQL.query conn + "SELECT a.id, a.occurrence_id, a.user_id, a.status, a.note, a.notify_household, a.recorded_at, u.display_name, c.name \ + \ FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id JOIN users u ON u.id = a.user_id \ + \ WHERE c.household_id = ? AND a.recorded_at >= ? ORDER BY a.recorded_at DESC LIMIT 50" + (hid, show today) :: IO [(Int, Int, Int, Text, Maybe Text, Int, UTCTime, Text, Text)] + let compItems = [CompletedItem (Activity (ActivityId aid) (OccurrenceId oid) (UserId uid) (mkAct st) note (nh /= 0) recAt) uname cn | (aid, oid, uid, st, note, nh, recAt, uname, cn) <- compRows] + pure $ Dashboard stats dueItems compItems + where + mkOcc "due" = OccDue; mkOcc "overdue" = OccOverdue; mkOcc _ = OccCompleted + mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped + + GenerateOccurrences chore -> liftIO $ generateOccurrencesIO conn chore + + RecordActivity oid (UserId uid) status note notify -> liftIO $ do + now <- Time.getCurrentTime + let actStatus = case status of ActivityCompleted -> "completed" :: String; ActivitySkipped -> "skipped" + SQL.execute conn + "INSERT INTO activities (occurrence_id, user_id, status, note, notify_household, recorded_at) VALUES (?,?,?,?,?,?)" + (oid, uid, actStatus, note, if notify then 1 :: Int else 0, now) + let occStatus = case status of ActivityCompleted -> "completed" :: String; ActivitySkipped -> "skipped" + SQL.execute conn "UPDATE occurrences SET status = ? WHERE id = ?" (occStatus, oid) + actId <- SQL.lastInsertRowId conn + pure $ Activity (ActivityId (fromIntegral actId)) (OccurrenceId oid) (UserId uid) status note notify now + + GetActivityLog hid page perPage -> liftIO $ do + let offset = (page - 1) * perPage + [Only totalCount] <- SQL.query conn + "SELECT COUNT(*) FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id WHERE c.household_id = ?" + (Only hid) + entries <- SQL.query conn + "SELECT a.id, a.occurrence_id, a.user_id, a.status, a.note, a.notify_household, a.recorded_at, u.display_name, c.name, o.due_date \ + \ FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id JOIN users u ON u.id = a.user_id \ + \ WHERE c.household_id = ? ORDER BY a.recorded_at DESC LIMIT ? OFFSET ?" + (hid, perPage, offset) :: IO [(Int, Int, Int, Text, Maybe Text, Int, UTCTime, Text, Text, Day)] + let logEntries = [ActivityLogEntry (Activity (ActivityId aid) (OccurrenceId oid) (UserId uid) (mkAct st) note (nh /= 0) recAt) uname "" cn d | (aid, oid, uid, st, note, nh, recAt, uname, cn, d) <- entries] + pure $ ActivityLogPage logEntries page perPage totalCount + where + mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped + + CreateInvite hid email -> liftIO $ do + code <- generateTokenIO + now <- Time.getCurrentTime + SQL.execute conn + "INSERT INTO invites (household_id, code, email, created_at) VALUES (?, ?, ?, ?)" + (hid, code, email, now) + iid <- SQL.lastInsertRowId conn + pure $ Invite (InviteId (fromIntegral iid)) (HouseholdId hid) code email InvitePending now + + GetInvites hid -> liftIO $ do + invites <- SQL.query conn + "SELECT id, household_id, code, email, status, created_at FROM invites WHERE household_id = ?" + (Only hid) :: IO [(Int, Int, Text, Maybe Text, Text, UTCTime)] + pure [Invite (InviteId iid) (HouseholdId hhid) code email (mkStatus st) createdAt | (iid, hhid, code, email, st, createdAt) <- invites] + where + mkStatus "pending" = InvitePending; mkStatus "accepted" = InviteAccepted; mkStatus _ = InviteRevoked + + RevokeInvite iid -> liftIO $ do + SQL.execute conn "UPDATE invites SET status = 'revoked' WHERE id = ?" (Only iid) + + AcceptInvite (UserId uid) code -> liftIO $ do + result <- SQL.query conn + "SELECT id, household_id FROM invites WHERE code = ? AND status = 'pending'" + (Only code) :: IO [(Int, Int)] + case result of + [(_, hid)] -> do + SQL.execute conn + "INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)" + (hid, uid, "member" :: String) + SQL.execute conn "UPDATE invites SET status = 'accepted' WHERE code = ?" (Only code) + hResult <- SQL.query conn + "SELECT h.id, h.name, m.user_id, (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \ + \ FROM households h JOIN memberships m ON m.household_id = h.id AND m.role = 'owner' WHERE h.id = ?" + (Only hid) :: IO [(Int, Text, Int, Int)] + case listToMaybe [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- hResult] of + Just h -> pure h + Nothing -> error "Household not found after accept" + _ -> error "Invite not found" + + Seed -> liftIO $ do + let demoPassword = "password123" + pwHash <- hashPasswordIO demoPassword + SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash) VALUES (1, 'Alice', 'alice@demo.com', ?)" (Only pwHash) + SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash) VALUES (2, 'Bob', 'bob@demo.com', ?)" (Only pwHash) + SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash) VALUES (3, 'Charlie', 'charlie@demo.com', ?)" (Only pwHash) + SQL.execute_ conn "INSERT OR IGNORE INTO households (id, name) VALUES (1, 'Demo House')" + SQL.execute_ conn "INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (1, 1, 'owner')" + SQL.execute_ conn "INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (1, 2, 'member')" + SQL.execute_ conn "INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (1, 3, 'member')" + let sData1 = show (ScheduleRecurring PeriodDaily (read "2026-07-15") (Just "08:00:00") Nothing Nothing :: Schedule) + SQL.execute conn "INSERT OR IGNORE INTO chores (id, household_id, name, assignee_type, schedule_type, schedule_data, notify_on_due) VALUES (1, 1, 'Take out trash', 'anyone', 'recurring', ?, 1)" (Only sData1) + let sData2 = show (ScheduleRecurring PeriodWeekly (read "2026-07-13") (Just "10:00:00") (Just [1, 4]) Nothing :: Schedule) + SQL.execute conn "INSERT OR IGNORE INTO chores (id, household_id, name, assignee_type, assignee_user_id, schedule_type, schedule_data, notify_on_due) VALUES (2, 1, 'Vacuum living room', 'user', 2, 'recurring', ?, 0)" (Only sData2) + let sData3 = show (ScheduleSometime :: Schedule) + SQL.execute conn "INSERT OR IGNORE INTO chores (id, household_id, name, assignee_type, schedule_type, schedule_data, notify_on_due) VALUES (3, 1, 'Clean the garage', 'anyone', 'sometime', ?, 0)" (Only sData3) + today <- utctDay <$> getCurrentTime + let windowEnd = addDays 90 today + let dates1 = take 90 $ generateRecurringDates PeriodDaily (read "2026-07-15") today windowEnd + mapM_ (SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (1, ?)" . Only) dates1 + let dates2 = take 90 $ generateRecurringDates PeriodWeekly (read "2026-07-13") today windowEnd + mapM_ (SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (2, ?)" . Only) dates2 + SQL.execute_ conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (3, '9999-12-31')" + +---------------------------------------------------------------------- +-- Helpers +---------------------------------------------------------------------- + +generateOccurrencesIO :: SQL.Connection -> Chore -> IO () +generateOccurrencesIO conn' chore = do + today <- utctDay <$> getCurrentTime + let windowEnd = addDays 90 today + case choreSchedule chore of + ScheduleOneOff date _ -> + when (date >= today && date <= windowEnd) $ + SQL.execute conn' "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (?, ?)" (unChoreId (choreId chore), date) + ScheduleRecurring period startDate _ _ _ -> do + let dates = generateRecurringDates period startDate today windowEnd + mapM_ (\d -> SQL.execute conn' "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (?, ?)" (unChoreId (choreId chore), d)) dates + ScheduleSometime -> + SQL.execute conn' "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (?, '9999-12-31')" (Only (unChoreId (choreId chore))) + +generateRecurringDates :: SchedulePeriod -> Day -> Day -> Day -> [Day] +generateRecurringDates period startDate fromDate toDate = go (max startDate fromDate) + where + go d | d > toDate = [] | otherwise = d : go (next period d) + next PeriodDaily = addDays 1; next PeriodWeekly = addDays 7; next PeriodMonthly = addGregorianMonthsClip 1 + +hashPasswordIO :: Text -> IO Text +hashPasswordIO password = do + -- Simple hashing stub — we'll use crypton via Auth.hs in the real implementation + pure password + +generateTokenIO :: IO Text +generateTokenIO = do + -- Simple token stub + pure "dummy-token" + +---------------------------------------------------------------------- +-- Database open helper +---------------------------------------------------------------------- + +{- | Open (or create) a SQLite database at the given path. -} openDatabase :: FilePath -> IO SQL.Connection openDatabase path = do @@ -30,9 +364,9 @@ openDatabase path = do -- | Create all tables if they don't exist. runMigrations :: SQL.Connection -> IO () -runMigrations conn = +runMigrations conn' = mapM_ - (SQL.execute_ conn) + (SQL.execute_ conn') [ "CREATE TABLE IF NOT EXISTS users (\ \ id INTEGER PRIMARY KEY AUTOINCREMENT,\ \ display_name TEXT NOT NULL,\ @@ -94,3 +428,64 @@ runMigrations conn = \ expires_at TEXT NOT NULL,\ \ created_at TEXT NOT NULL DEFAULT (datetime('now')))" ] + +---------------------------------------------------------------------- +-- Convenience wrappers (send through the DB effect) +---------------------------------------------------------------------- + +findUserByEmail :: (DB :> es) => Text -> Eff es (Maybe User) +findUserByEmail = send . FindUserByEmail + +createUser :: (DB :> es) => Text -> Text -> Text -> Eff es UserId +createUser d e p = send (CreateUser d e p) + +getUser :: (DB :> es) => UserId -> Eff es (Maybe User) +getUser = send . GetUser + +getUserHouseholds :: (DB :> es) => UserId -> Eff es [Household] +getUserHouseholds = send . GetUserHouseholds + +getHousehold :: (DB :> es) => UserId -> Int -> Eff es (Maybe Household) +getHousehold u = send . GetHousehold u + +createHousehold :: (DB :> es) => UserId -> Text -> Eff es Household +createHousehold u = send . CreateHousehold u + +getMembers :: (DB :> es) => Int -> Eff es [Membership] +getMembers = send . GetMembers + +getChores :: (DB :> es) => Int -> Eff es [Chore] +getChores = send . GetChores + +createChore :: (DB :> es) => Int -> Text -> ChoreAssignee -> Schedule -> Bool -> Eff es Chore +createChore h n a s b = send (CreateChore h n a s b) + +updateChore :: (DB :> es) => Int -> Int -> Text -> ChoreAssignee -> Schedule -> Bool -> Eff es Chore +updateChore c h n a s b = send (UpdateChore c h n a s b) + +deleteChore :: (DB :> es) => Int -> Eff es () +deleteChore = send . DeleteChore + +getDashboard :: (DB :> es) => Int -> Day -> Eff es Dashboard +getDashboard h = send . GetDashboard h + +recordActivity :: (DB :> es) => Int -> UserId -> ActivityStatus -> Maybe Text -> Bool -> Eff es Activity +recordActivity o u s n b = send (RecordActivity o u s n b) + +getActivityLog :: (DB :> es) => Int -> Int -> Int -> Eff es ActivityLogPage +getActivityLog h p pp = send (GetActivityLog h p pp) + +createInvite :: (DB :> es) => Int -> Maybe Text -> Eff es Invite +createInvite h = send . CreateInvite h + +getInvites :: (DB :> es) => Int -> Eff es [Invite] +getInvites = send . GetInvites + +revokeInvite :: (DB :> es) => Int -> Eff es () +revokeInvite = send . RevokeInvite + +acceptInvite :: (DB :> es) => UserId -> Text -> Eff es Household +acceptInvite u = send . AcceptInvite u + +seed :: (DB :> es) => Eff es () +seed = send Seed diff --git a/src/Sis/Page/Activity.hs b/src/Sis/Page/Activity.hs new file mode 100644 index 0000000..38156bc --- /dev/null +++ b/src/Sis/Page/Activity.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-} + +module Sis.Page.Activity (page) where + +import Data.Text (Text) +import Effectful + +import Sis.Database +import Sis.Route +import Sis.Style +import Sis.Types +import Sis.View.Layout +import Web.Hyperbole +import Web.Hyperbole.Effect.Session +import Web.Hyperbole.Page + +data ActivityPage = ActivityPage + deriving stock (Generic) + deriving anyclass (ViewId) + +instance (DB :> es) => HyperView ActivityPage es where + data Action ActivityPage + = RefreshActivity + | GoToPage Int + deriving stock (Generic) + deriving anyclass (ViewAction) + + update RefreshActivity = do + update (GoToPage 1) + update (GoToPage pageNum) = do + mUser <- lookupSession @UserSession + case mUser of + Nothing -> pure (el "Not authenticated") + Just us -> do + hhs <- getUserHouseholds (UserId (usUserId us)) + case hhs of + [] -> pure (el "No households") + (h : _) -> do + log <- getActivityLog (unHouseholdId (householdId h)) pageNum 20 + pure (activityView log) + +activityView :: ActivityLogPage -> View ActivityPage () +activityView log = do + el @ att "class" nbContainerClass @ att "style" "max-width:960px;margin:0 auto" $ do + el @ att "class" nbFontHeading1Class $ text "Activity Log" + if null (alpEntries log) + then el @ att "style" "opacity:0.5" $ text "No activity recorded yet." + else el @ att "class" nbBoxClass $ mapM_ entryRow (alpEntries log) + if alpTotal log > alpPerPage log + then el @ att "style" "margin-top:1rem;display:flex;gap:0.5rem;justify-content:center" $ do + let totalPages = (alpTotal log + alpPerPage log - 1) `div` alpPerPage log + if alpPage log > 1 + then button (GoToPage (alpPage log - 1)) @ att "class" nbButtonClass $ text "Previous" + else none + el @ att "style" "align-self:center" $ + text ("Page " <> show (alpPage log) <> " of " <> show totalPages) + if alpPage log < totalPages + then button (GoToPage (alpPage log + 1)) @ att "class" nbButtonClass $ text "Next" + else none + else none + +entryRow :: ActivityLogEntry -> View ActivityPage () +entryRow e = do + let act = aleActivity e + statusText = case activityStatus act of + ActivityCompleted -> "COMPLETED" + ActivitySkipped -> "SKIPPED" + statusColor = case activityStatus act of + ActivityCompleted -> colorGreen + ActivitySkipped -> "var(--nb-orange)" + el @ att "class" nbListItemClass @ att "style" "padding:0.5rem" $ do + el @ att "class" nbBadgeClass @ att "style" ("margin-right:0.5rem;background:" <> statusColor <> ";color:#000") $ + text statusText + el @ att "style" "font-weight:500" $ text (aleUserName e) + text (" " <> statusText <> " ") + el @ att "style" "font-weight:500" $ text (aleChoreName e) + el @ att "style" "opacity:0.5" $ + text ("on " <> show (aleOccurrenceDate e)) + case activityNote act of + Just note -> + el @ att "style" "opacity:0.5;font-style:italic;margin-left:0.5rem" $ + text ("\"" <> note <> "\"") + Nothing -> none + +getUserHouseholds :: (DB :> es) => UserId -> Eff es [Household] +getUserHouseholds = getUserHouseholds + +page :: (Hyperbole :> es, DB :> es) => Eff es (View ActivityPage ()) +page = do + mSession <- lookupSession @UserSession + case mSession of + Nothing -> do + redirect (routeUri RouteLogin) + pure (el "Redirecting...") + Just us -> do + hhs <- getUserHouseholds (UserId (usUserId us)) + case hhs of + [] -> pure (el "No households") + (h : _) -> do + log <- getActivityLog (unHouseholdId (householdId h)) 1 20 + pure (activityView log) diff --git a/src/Sis/Page/Chores.hs b/src/Sis/Page/Chores.hs new file mode 100644 index 0000000..84c6d47 --- /dev/null +++ b/src/Sis/Page/Chores.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-} + +module Sis.Page.Chores (page) where + +import Data.Text (Text) +import Data.Time (getCurrentTime) +import Effectful + +import Sis.Database +import Sis.Route +import Sis.Style +import Sis.Types +import Sis.View.Layout +import Web.Hyperbole +import Web.Hyperbole.Effect.Session +import Web.Hyperbole.Page + +data ChoresPage = ChoresPage + deriving stock (Generic) + deriving anyclass (ViewId) + +instance (DB :> es) => HyperView ChoresPage es where + data Action ChoresPage + = CRefreshChores + | CDeleteChore ChoreId + | CNewChore + deriving stock (Generic) + deriving anyclass (ViewAction) + + update CRefreshChores = do + mUser <- lookupSession @UserSession + case mUser of + Nothing -> pure (el "Not authenticated") + Just us -> do + hhs <- getUserHouseholds (UserId (usUserId us)) + case hhs of + [] -> pure (el "No households") + (h : _) -> do + chores' <- getChores (unHouseholdId (householdId h)) + pure (choresView chores') + update (CDeleteChore cid) = do + Sis.Database.DeleteChore (unChoreId cid) + update CRefreshChores + update CNewChore = do + -- TODO: show chore creation form + pure (el "New chore form coming soon") + +choresView :: [Chore] -> View ChoresPage () +choresView chores' = do + el @ att "class" nbContainerClass @ att "style" "max-width:960px;margin:0 auto" $ do + el @ att "style" "display:flex;justify-content:space-between;align-items:center;margin-bottom:1rem" $ do + el @ att "class" nbFontHeading1Class $ text "Chores" + button CNewChore @ att "class" nbButtonClass $ text "+ New Chore" + if null chores' + then el @ att "style" "opacity:0.5" $ text "No chores yet. Create one to get started!" + else el @ att "class" nbBoxClass $ mapM_ choreRow chores' + +choreRow :: Chore -> View ChoresPage () +choreRow c = do + el @ att "class" nbListItemClass @ att "style" "display:flex;justify-content:space-between;align-items:center;padding:0.5rem" $ do + el @ att "style" "display:flex;gap:0.5rem;align-items:center" $ do + el @ att "class" nbBadgeClass $ text (scheduleBadge (choreSchedule c)) + el @ att "style" "font-weight:500" $ text (choreName c) + el @ att "style" "opacity:0.5;font-size:0.85rem" $ text (scheduleLabel (choreSchedule c)) + el @ att "style" "display:flex;gap:0.25rem" $ do + button CNewChore @ att "class" nbButtonClass @ att "style" "font-size:0.8rem;padding:0.25rem 0.5rem" $ text "Edit" + button (CDeleteChore (choreId c)) @ att "class" nbButtonClass @ att "style" "font-size:0.8rem;padding:0.25rem 0.5rem;background:var(--nb-red)" $ text "Delete" + +scheduleBadge :: Schedule -> Text +scheduleBadge ScheduleSometime{} = "sometime" +scheduleBadge ScheduleOneOff{} = "one-off" +scheduleBadge ScheduleRecurring{} = "recurring" + +scheduleLabel :: Schedule -> Text +scheduleLabel ScheduleSometime = "Sometime" +scheduleLabel (ScheduleOneOff d _) = "One-off on " <> show d +scheduleLabel (ScheduleRecurring p _ mt _ _) = + let pText = case p of PeriodDaily -> "daily"; PeriodWeekly -> "weekly"; PeriodMonthly -> "monthly" + timePart = maybe "" (\t -> " at " <> t) mt + in "Recurs " <> pText <> timePart + +page :: (Hyperbole :> es, DB :> es) => Eff es (View ChoresPage ()) +page = do + mSession <- lookupSession @UserSession + case mSession of + Nothing -> do + redirect (routeUri RouteLogin) + pure (el "Redirecting...") + Just us -> do + hhs <- getUserHouseholds (UserId (usUserId us)) + case hhs of + [] -> pure (el "No households") + (h : _) -> do + chores' <- getChores (unHouseholdId (householdId h)) + pure (choresView chores') diff --git a/src/Sis/Page/Dashboard.hs b/src/Sis/Page/Dashboard.hs new file mode 100644 index 0000000..adee55f --- /dev/null +++ b/src/Sis/Page/Dashboard.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-} + +module Sis.Page.Dashboard (page) where + +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Time (getCurrentTime, utctDay) +import Effectful + +import Sis.Database +import Sis.Route +import Sis.Style +import Sis.Types +import Sis.View.Layout +import Web.Hyperbole +import Web.Hyperbole.Effect.Session +import Web.Hyperbole.Page + +data DashboardPage = DashboardPage + deriving stock (Generic) + deriving anyclass (ViewId) + +instance (DB :> es) => HyperView DashboardPage es where + data Action DashboardPage + = RefreshDashboard + | CheckOff OccurrenceId + deriving stock (Generic) + deriving anyclass (ViewAction) + + update RefreshDashboard = do + mUser <- lookupSession @UserSession + case mUser of + Nothing -> pure (el "Not authenticated") + Just us -> do + today <- liftIO (utctDay <$> getCurrentTime) + hhs <- getUserHouseholds (UserId (usUserId us)) + case hhs of + [] -> pure (el "No households found") + (h : _) -> do + dash <- getDashboard (unHouseholdId (householdId h)) today + pure (dashboardView dash) + update (CheckOff _oid) = do + -- TODO: wire up to activity form + update RefreshDashboard + +dashboardView :: Dashboard -> View DashboardPage () +dashboardView dash = do + el @ att "class" nbContainerClass @ att "style" "max-width:960px;margin:0 auto" $ do + el @ att "class" nbFontHeading1Class $ text "Dashboard" + el @ att "style" "display:flex;gap:1rem;margin-bottom:1.5rem" $ do + let stats = dashStats dash + statTile "Overdue" (show (dsOverdue stats)) colorRed + statTile "Due Today" (show (dsDueToday stats)) colorYellow + statTile "Done This Week" (show (dsDoneThisWeek stats)) colorGreen + el @ att "class" nbFontHeading2Class $ text "Overdue & Due Today" + if null (dashDueItems dash) + then el @ att "style" "opacity:0.5" $ text "Nothing due! Great job." + else el @ att "class" nbBoxClass $ do + mapM_ dueItemRow (dashDueItems dash) + el @ att "class" nbFontHeading2Class $ text "Completed Today" + if null (dashCompletedItems dash) + then el @ att "style" "opacity:0.5" $ text "No activity recorded today." + else el @ att "class" nbBoxClass $ mapM_ completedItemRow (dashCompletedItems dash) + route RouteActivity $ text "View Full Activity Log" + +statTile :: Text -> Text -> Text -> View ctx () +statTile label count color = do + el @ att "class" nbBoxClass @ att "style" ("flex:1;text-align:center;padding:1rem;border-color:" <> color) $ do + el @ att "class" nbFontHeading1Class $ text count + text label + +dueItemRow :: DueItem -> View ctx () +dueItemRow di = do + el @ att "class" nbListItemClass @ att "style" "display:flex;justify-content:space-between;align-items:center;padding:0.5rem" $ do + el @ att "style" "display:flex;gap:0.5rem;align-items:center" $ do + let badgeColor = if diIsOverdue di then colorRed else colorYellow + badgeText = if diIsOverdue di then "OVERDUE" else "DUE" + el @ att "class" nbBadgeClass @ att "style" ("background:" <> badgeColor <> ";color:#000") $ text badgeText + text (diChoreName di) + case diAssigneeName di of + Just name -> el @ att "style" "opacity:0.5" $ text ("(" <> name <> ")") + Nothing -> none + button (CheckOff (occurrenceId (diOccurrence di))) @ att "class" nbButtonClass @ att "style" "font-size:0.85rem" $ text "Check Off" + +completedItemRow :: CompletedItem -> View ctx () +completedItemRow ci = do + el @ att "class" nbListItemClass @ att "style" "padding:0.5rem" $ do + let act = ciActivity ci + statusText = case activityStatus act of + ActivityCompleted -> "COMPLETED" + ActivitySkipped -> "SKIPPED" + el @ att "class" nbBadgeClass @ att "style" ("margin-right:0.5rem;background:" <> colorGreen <> ";color:#000") $ text statusText + text (ciUserName ci <> " " <> show (activityStatus act) <> " " <> ciChoreName ci) + case activityNote act of + Just note -> el @ att "style" "opacity:0.5;font-style:italic;margin-left:0.5rem" $ text ("— \"" <> note <> "\"") + Nothing -> none + +page :: (Hyperbole :> es, DB :> es) => Eff es (View DashboardPage ()) +page = do + mSession <- lookupSession @UserSession + case mSession of + Nothing -> do + redirect (routeUri RouteLogin) + pure (el "Redirecting...") + Just us -> do + today <- liftIO (utctDay <$> getCurrentTime) + hhs <- getUserHouseholds (UserId (usUserId us)) + case hhs of + [] -> pure (el "No households — create one first") + (h : _) -> do + dash <- getDashboard (unHouseholdId (householdId h)) today + pure (dashboardView dash) diff --git a/src/Sis/Page/Household.hs b/src/Sis/Page/Household.hs new file mode 100644 index 0000000..a16b692 --- /dev/null +++ b/src/Sis/Page/Household.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-} + +module Sis.Page.Household (page) where + +import Data.Text (Text) +import Data.Text qualified as T +import Effectful + +import Sis.Database +import Sis.Route +import Sis.Style +import Sis.Types +import Sis.View.Layout +import Web.Hyperbole +import Web.Hyperbole.Effect.Session +import Web.Hyperbole.Page + +data HouseholdPage = HouseholdPage + deriving stock (Generic) + deriving anyclass (ViewId) + +instance (DB :> es) => HyperView HouseholdPage es where + data Action HouseholdPage + = RefreshHousehold + | CreateInviteAction + | RevokeInviteAction InviteId + deriving stock (Generic) + deriving anyclass (ViewAction) + + update RefreshHousehold = do + mUser <- lookupSession @UserSession + case mUser of + Nothing -> pure (el "Not authenticated") + Just us -> do + hhs <- getUserHouseholds (UserId (usUserId us)) + case hhs of + [] -> pure (noHouseholdView) + (h : _) -> do + let hid = unHouseholdId (householdId h) + mems <- getMembers hid + invs <- getInvites hid + pure (householdView h mems invs) + update CreateInviteAction = do + mUser <- lookupSession @UserSession + case mUser of + Nothing -> pure (el "Not authenticated") + Just us -> do + hhs <- getUserHouseholds (UserId (usUserId us)) + case hhs of + [] -> pure (el "No households") + (h : _) -> do + let hid = unHouseholdId (householdId h) + _ <- createInvite hid Nothing + update RefreshHousehold + update (RevokeInviteAction iid) = do + revokeInvite (unInviteId iid) + update RefreshHousehold + +noHouseholdView :: View HouseholdPage () +noHouseholdView = do + el @ att "class" nbContainerClass @ att "style" "max-width:480px;margin:4rem auto" $ do + el @ att "class" nbBoxClass @ att "style" "padding:2rem;text-align:center" $ do + el @ att "class" nbFontHeading1Class $ text "Create Your Household" + el @ att "style" "margin-bottom:1rem" $ text "You need a household to get started." + -- Form for household creation would go here + el $ text "Household creation form coming soon" + +householdView :: Household -> [Membership] -> [Invite] -> View HouseholdPage () +householdView h mems invs = do + el @ att "class" nbContainerClass @ att "style" "max-width:960px;margin:0 auto" $ do + el @ att "class" nbFontHeading1Class $ text (householdName h) + el @ att "style" "opacity:0.7" $ text (show (length mems) <> " members") + el @ att "class" nbFontHeading2Class $ text "Members" + el @ att "class" nbBoxClass @ att "style" "margin-bottom:1.5rem" $ mapM_ memberRow mems + el @ att "class" nbFontHeading2Class $ text "Invite Members" + el @ att "class" nbBoxClass $ do + el @ att "style" "margin-bottom:0.5rem" $ text "Create an invite link to share:" + button CreateInviteAction @ att "class" nbButtonClass $ text "+ Create Invite Link" + if null invs + then none + else el @ att "style" "margin-top:1rem" $ do + el @ att "class" nbFontHeading2Class $ text "Pending Invites" + mapM_ inviteRow (filter ((== InvitePending) . inviteStatus) invs) + +memberRow :: Membership -> View HouseholdPage () +memberRow m = do + el @ att "class" nbListItemClass @ att "style" "display:flex;justify-content:space-between;align-items:center;padding:0.5rem" $ do + el @ att "style" "display:flex;gap:0.5rem;align-items:center" $ do + el @ att "class" nbBadgeClass @ att "style" "border-radius:50%;width:2rem;height:2rem;display:inline-flex;align-items:center;justify-content:center;font-size:0.8rem" $ + text (initials (membershipDisplayName m)) + el @ att "style" "font-weight:500" $ text (membershipDisplayName m) + el @ att "style" "opacity:0.5" $ text (membershipEmail m) + el @ att "class" nbBadgeClass @ att "style" (if membershipRole m == OwnerRole then "background:var(--nb-yellow);color:#000" else "") $ + text (show (membershipRole m)) + +inviteRow :: Invite -> View HouseholdPage () +inviteRow i = do + el @ att "class" nbListItemClass @ att "style" "display:flex;justify-content:space-between;padding:0.5rem" $ do + el @ att "style" "font-size:0.85rem" $ text ("/invite/" <> inviteCode i) + button (RevokeInviteAction (inviteId i)) @ att "class" nbButtonClass @ att "style" "font-size:0.8rem;background:var(--nb-red)" $ + text "Revoke" + +initials :: Text -> Text +initials name = + let ws = T.words name + in T.toUpper (T.take 2 (T.concat (map (T.take 1) ws))) + +getUserHouseholds :: (DB :> es) => UserId -> Eff es [Household] +getUserHouseholds = getUserHouseholds + +page :: (Hyperbole :> es, DB :> es) => Eff es (View HouseholdPage ()) +page = do + mSession <- lookupSession @UserSession + case mSession of + Nothing -> do + redirect (routeUri RouteLogin) + pure (el "Redirecting...") + Just us -> do + hhs <- getUserHouseholds (UserId (usUserId us)) + case hhs of + [] -> pure noHouseholdView + (h : _) -> do + let hid = unHouseholdId (householdId h) + mems <- getMembers hid + invs <- getInvites hid + pure (householdView h mems invs) diff --git a/src/Sis/Page/Login.hs b/src/Sis/Page/Login.hs new file mode 100644 index 0000000..ca91f70 --- /dev/null +++ b/src/Sis/Page/Login.hs @@ -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) diff --git a/src/Sis/Page/Signup.hs b/src/Sis/Page/Signup.hs new file mode 100644 index 0000000..38ac8c6 --- /dev/null +++ b/src/Sis/Page/Signup.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE FlexibleContexts, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, TypeApplications, TypeOperators, OverloadedStrings #-} + +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) => 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%" + el @ att "class" nbLabelClass $ text "Email" + tag "input" @ att "type" "email" . att "name" "sfEmail" . att "class" nbInputClass @ att "style" "width:100%" + el @ att "class" nbLabelClass $ text "Password (min 8 characters)" + tag "input" @ att "type" "password" . att "name" "sfPassword" . att "class" nbInputClass @ att "style" "width:100%" + el @ att "class" nbLabelClass $ text "Confirm Password" + tag "input" @ att "type" "password" . att "name" "sfConfirm" . 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" "sfAgree" + 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) diff --git a/src/Sis/Route.hs b/src/Sis/Route.hs new file mode 100644 index 0000000..df6c1a6 --- /dev/null +++ b/src/Sis/Route.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Sis.Route (AppRoute (..)) where + +import GHC.Generics (Generic) +import Web.Hyperbole.Route + +data AppRoute + = RouteHome + | RouteLogin + | RouteSignup + | RouteDashboard + | RouteChores + | RouteHousehold + | RouteActivity + deriving stock (Eq, Generic, Show) + +instance Route AppRoute where + baseRoute = Just RouteHome diff --git a/src/Sis/Style.hs b/src/Sis/Style.hs new file mode 100644 index 0000000..b2dd053 --- /dev/null +++ b/src/Sis/Style.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Neo Brutalism CSS class name constants for Hyperbole views. +-- Use with: \@ att \"class\" nbBoxClass +module Sis.Style + ( nbBoxClass, nbButtonClass, nbInputClass, nbLabelClass + , nbBadgeClass, nbFontHeading1Class, nbFontHeading2Class + , nbNavbarClass, nbContainerClass, nbListItemClass + , colorRed, colorYellow, colorGreen + ) where + +import Data.Text (Text) + +nbBoxClass, nbButtonClass, nbInputClass, nbLabelClass, nbBadgeClass :: Text +nbBoxClass = "nb-box" +nbButtonClass = "nb-button" +nbInputClass = "nb-input" +nbLabelClass = "nb-label" +nbBadgeClass = "nb-badge" + +nbFontHeading1Class, nbFontHeading2Class :: Text +nbFontHeading1Class = "nb-font-heading1" +nbFontHeading2Class = "nb-font-heading2" + +nbNavbarClass, nbContainerClass, nbListItemClass :: Text +nbNavbarClass = "nb-navbar" +nbContainerClass = "nb-container" +nbListItemClass = "nb-list-item" + +colorRed, colorYellow, colorGreen :: Text +colorRed = "var(--nb-red)" +colorYellow = "var(--nb-yellow)" +colorGreen = "var(--nb-green)" diff --git a/src/Sis/Types.hs b/src/Sis/Types.hs index 2c98882..82b0476 100644 --- a/src/Sis/Types.hs +++ b/src/Sis/Types.hs @@ -56,6 +56,7 @@ module Sis.Types ( HouseholdFormData (..), ) where +import Data.Aeson (FromJSON, ToJSON) import Data.Text (Text) import Data.Time (Day, LocalTime, UTCTime) import GHC.Generics (Generic) @@ -66,22 +67,22 @@ import Web.Hyperbole.HyperView.Forms (FromForm) ---------------------------------------------------------------------- newtype UserId = UserId {unUserId :: Int} - deriving newtype (Show, Eq, Read) + deriving newtype (Show, Eq, Read, ToJSON, FromJSON) newtype HouseholdId = HouseholdId {unHouseholdId :: Int} deriving newtype (Show, Eq, Read) newtype ChoreId = ChoreId {unChoreId :: Int} - deriving newtype (Show, Eq, Read) + deriving newtype (Show, Eq, Read, ToJSON, FromJSON) newtype OccurrenceId = OccurrenceId {unOccurrenceId :: Int} - deriving newtype (Show, Eq, Read) + deriving newtype (Show, Eq, Read, ToJSON, FromJSON) newtype ActivityId = ActivityId {unActivityId :: Int} - deriving newtype (Show, Eq, Read) + deriving newtype (Show, Eq, Read, ToJSON, FromJSON) newtype InviteId = InviteId {unInviteId :: Int} - deriving newtype (Show, Eq, Read) + deriving newtype (Show, Eq, Read, ToJSON, FromJSON) ---------------------------------------------------------------------- -- User diff --git a/src/Sis/View/Layout.hs b/src/Sis/View/Layout.hs new file mode 100644 index 0000000..4a88822 --- /dev/null +++ b/src/Sis/View/Layout.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Sis.View.Layout + ( documentHead + , navbar + , UserSession (..) + ) where + +import Data.Aeson +import Data.Default +import Data.Text (Text) +import GHC.Generics (Generic) + +import Sis.Route +import Sis.Style +import Web.Hyperbole +import Web.Hyperbole.Effect.Session + +---------------------------------------------------------------------- +-- Session +---------------------------------------------------------------------- + +data UserSession = UserSession + { usUserId :: Int + } + deriving stock (Show, Eq, Generic) + deriving anyclass (FromJSON, ToJSON) + +instance Session UserSession where + cookiePath = Just "/" + +instance Default UserSession where + def = UserSession 0 + +---------------------------------------------------------------------- +-- Document Head +---------------------------------------------------------------------- + +documentHead :: View DocumentHead () +documentHead = do + title "Sis — Household Chore Tracker" + mobileFriendly + meta @ att "charset" "UTF-8" + stylesheet "https://unpkg.com/neobrutalismcss@latest" + stylesheet "/static/style.css" + tag "link" @ att "rel" "manifest" . att "href" "/static/manifest.json" $ none + script' scriptEmbed + +---------------------------------------------------------------------- +-- Navbar +---------------------------------------------------------------------- + +navbar :: View ctx () +navbar = do + el @ att "class" nbNavbarClass $ do + el @ att "class" "nb-navbar-start" $ do + el @ att "class" nbFontHeading2Class @ att "style" "font-weight:700" $ text "Sis" + el @ att "class" "nb-navbar-end" $ do + routeLink RouteDashboard "Dashboard" + routeLink RouteChores "Chores" + routeLink RouteHousehold "Household" + routeLink RouteActivity "Activity" + routeLink RouteLogin "Logout" + +routeLink :: (Route r) => r -> Text -> View ctx () +routeLink rt lbl = do + el @ att "class" nbButtonClass $ route rt $ text lbl