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)
This commit is contained in:
+43
-62
@@ -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
|
||||
|
||||
@@ -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:
|
||||
|
||||
+408
-13
@@ -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
|
||||
|
||||
@@ -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)
|
||||
@@ -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')
|
||||
@@ -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)
|
||||
@@ -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)
|
||||
@@ -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)
|
||||
@@ -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)
|
||||
@@ -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
|
||||
@@ -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)"
|
||||
+6
-5
@@ -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
|
||||
|
||||
@@ -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
|
||||
Reference in New Issue
Block a user