Compare commits

..

12 Commits

Author SHA1 Message Date
jbrechtel 92c9fae885 feat: record activity when checking off a household chore 2026-08-04 09:49:19 -04:00
jbrechtel 47a2eff484 feat: accept household invites via shareable /invite/<code> URL 2026-08-04 09:49:16 -04:00
jbrechtel 9d0246cbcf chore: gitignore Playwright test-results output 2026-08-04 09:49:13 -04:00
jbrechtel 1c19d97dc8 feat: add Playwright e2e smoke test covering signup → household → chore flow
- Added smoke.spec.js with Playwright test for full user flow:
  1. Sign up (fill form, submit, click 'Go to Dashboard')
  2. Create household (fill name, submit)
  3. Create chore (fill name + date, submit)
  4. Verify session persistence (revisit dashboard)
- Server now supports --db flag for temp databases and SIS_FRESH_DB env
  to delete the db file on startup (for clean test runs)
- Server reads SIS_PORT env var for port configuration
- scripts/test-e2e: starts server with fresh db, runs tests, cleans up
- playwright.config.js: minimal config pointing at test/e2e/
2026-07-16 10:01:33 -04:00
jbrechtel 6bea83be7d fix: wrap all update action views in pageLayout so navbar persists on WebSocket updates
HyperView update actions replace only the hyper component — without pageLayout
the navbar disappears after any interactive action (create chore, navigate pages,
refresh, create household, etc.). Every hyper-returning update now wraps the
view in pageLayout us.
2026-07-16 09:27:36 -04:00
jbrechtel 92f076f329 chore: remove db migration support — fold household_id into users table definition
- Added household_id column directly to users CREATE TABLE
- Removed ALTER TABLE migration hack and Control.Exception/ScopedTypeVariables
- Renamed runMigrations to createTables (now internal, unexported)
- Tables created from scratch if database doesn't exist; no migration logic
2026-07-16 09:22:03 -04:00
jbrechtel b5ff79fc76 feat: chore creation form with one-off schedule and assignee picker
- Replaced CNewChore placeholder with a full creation form
- Form includes: chore name (text input), date (date picker for one-off),
  assignee (dropdown with Anyone + household members)
- CNewChore action shows choresViewWithForm (list + form inline)
- CCreateChore processes form data, parses date to ScheduleOneOff,
  parses assignee to ChoreAssignee, calls createChore
- Cancel button (CRefreshChores) returns to list-only view
- parseSchedule: reads YYYY-MM-DD date string into ScheduleOneOff
- parseAssignee: parses 'anyone' or 'user:<id>' into ChoreAssignee
2026-07-16 09:18:10 -04:00
jbrechtel 5485bdfd0b feat: household creation form — users without a household see a name input and Create Household button
- Added userHouseholdId (Maybe HouseholdId) to User type
- Added household_id FK column to users table via migration (idempotent)
- CreateHousehold now also sets household_id on the creating user
- SetUserHousehold DB effect for explicit FK updates
- noHouseholdView replaced with a proper Hyperbole form using HouseholdFormData
- On submit, creates household + membership + sets user FK, then redirects to household view
2026-07-16 09:11:09 -04:00
jbrechtel 02044642a7 feat: rebuild navbar with NB structure — Sis brand, nav links with nb-navbar-link class inside nb-navbar-item wrappers, user initials avatar
- UserSession now carries usDisplayName for extracting initials (current: JB)
- Nav items: Today (was Dashboard), Chores, Activity, Household
- Removed Logout link; added black user avatar circle with initials
- routeLink generates proper <li class='nb-navbar-item'><a class='nb-navbar-link'> structure
- All pages wrapped with pageLayout to render shared navbar shell
- Login/Signup save display name into session on authentication
2026-07-16 09:05:56 -04:00
jbrechtel bcdda0754b fix: set cookieSecure=False so session persists on HTTP (localhost)
The UserSession cookie was defaulting to secure=True which prevents
browsers from sending it on non-HTTPS connections. This caused the
dashboard to redirect back to login on every click.

Verified with Playwright: login, dashboard link click, and navbar
navigation all preserve the session correctly.
2026-07-16 07:48:10 -04:00
jbrechtel dbfe3a7c66 chore: fix all hlint warnings, update AGENTS.md pre-commit checklist
- Fix 8 hlint hints across 6 files (unused pragma, newtype, lambda, redundant brackets/\$)
- Add blank line after LANGUAGE pragma in Route.hs (fourmolu)
- Fix HouseholdFormData deriving to use explicit strategies for newtype
- Update AGENTS.md: require hlint clean before every commit, add pre-commit checklist
  (format, lint, build, test), update NB CSS URL to jsdelivr CDN
2026-07-16 07:43:38 -04:00
jbrechtel 95ac550191 fix: update to correct NeoBrutalismCSS CDN and class names
- Switch CDN to jsdelivr (matches design spec)
- Use nb-card, nb-card-title, nb-button default, nb-checkbox, nb-navbar-link
- Add Google Fonts import for Lexend Mega
- Style all route links as nb-button default buttons
- Fix navbar to use nb-navbar-brand and nb-navbar-nav
- Update style.css for new NB version compatibility
2026-07-16 07:34:45 -04:00
21 changed files with 607 additions and 171 deletions
+1
View File
@@ -12,5 +12,6 @@ __pycache__
.superpowers/
node_modules/
frontend/dist/
test-results/
hyperbole-local/
hyperbole-local/
+8 -3
View File
@@ -21,7 +21,12 @@ Hyperbole, a serverside web framework. There is zero application JavaScript.
## Haskell Conventions
- **Style:** fourmolu-formatted. Run `./hs fourmolu --mode inplace app/ src/ test/` before committing.
- **Lint:** hlint clean required. Fix any hints before committing.
- **Lint:** hlint clean required — MUST run `./hs hlint app/ src/ test/` and fix all hints before committing. Zero hints is the standard. Do not suppress or ignore hlint suggestions.
- **Pre-commit checklist:** Before every commit, run:
1. `./hs fourmolu --mode inplace app/ src/ test/` — format code
2. `./hs hlint app/ src/ test/` — fix ALL hints (must output "No hints")
3. `./hs stack build --fast` — must compile with zero errors
4. `./hs stack test --fast` — all tests must pass
- **Warnings:** `-Wall -Werror` in `package.yaml`. All warnings are fatal.
- **Module qualifiers:** Use qualified imports with descriptive aliases
(e.g., `import Data.Text qualified as T`).
@@ -37,8 +42,7 @@ Hyperbole, a serverside web framework. There is zero application JavaScript.
- **Framework:** [Hyperbole](https://github.com/seanhess/hyperbole) — Haskell
serverside web framework. All HTML rendered in Haskell.
- **CSS:** [Neo Brutalism](https://unpkg.com/neobrutalismcss@latest) CDN +
`frontend/static/style.css` for custom styles.
- **CSS:** [Neo Brutalism](https://github.com/matifandy8/NeoBrutalismCSS) CDN via jsdelivr + `frontend/static/style.css` for custom styles.
- **Build:** No npm/build step for frontend. All pages rendered in Haskell.
- **Interactive components:** HyperViews with typed Actions and server-side
updates via VirtualDOM over WebSocket.
@@ -86,5 +90,6 @@ sis/
- Run `./scripts/test` before committing. Tests must pass.
## Agent Autonomy
- Run `./hs hlint app/ src/ test/` and fix ALL hints before committing.
- As changes are completed then verify functionality using Playwright
- Once functionality is confirmed then commit and push changes
+35 -4
View File
@@ -1,10 +1,13 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists -Wno-name-shadowing #-}
module Main where
import Control.Exception (IOException, catch)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as C8
import Data.ByteString.Lazy qualified as BL
@@ -13,9 +16,12 @@ import Effectful
import Network.HTTP.Types qualified as HTTP
import Network.Wai qualified as Wai
import Network.Wai.Handler.Warp qualified as Warp
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile)
import System.Environment (getArgs, lookupEnv)
import System.FilePath (takeDirectory)
import System.IO.Error (isDoesNotExistError)
import Sis (UserId (..))
import Sis.Database
import Sis.Page.Activity
import Sis.Page.Chores
@@ -24,7 +30,7 @@ import Sis.Page.Household
import Sis.Page.Login
import Sis.Page.Signup
import Sis.Route
import Sis.View.Layout (documentHead)
import Sis.View.Layout (UserSession (..), documentHead)
import Web.Hyperbole
import Web.Hyperbole.Application
import Web.Hyperbole.Effect.Response
@@ -43,13 +49,29 @@ mimeType fp
main :: IO ()
main = do
let dbPath = "data/sis.db"
args <- getArgs
let dbPath = case args of
("--db" : p : _) -> p
_ -> "data/sis.db"
-- Use PORT env var or --port arg or default 8080
mPortEnv <- lookupEnv "PORT"
mPortArg <- lookupEnv "SIS_PORT"
let port = case (mPortEnv, mPortArg, args) of
(Just p, _, _) -> read p
(_, Just p, _) -> read p
(_, _, "--port" : p : _) -> read p
_ -> 8080
-- For fresh test databases, remove the file so tables are recreated
rmDB <- lookupEnv "SIS_FRESH_DB"
case rmDB of
Just _ -> removeFile dbPath `catch` (\(_ :: IOException) -> pure ())
Nothing -> pure ()
createDirectoryIfMissing True (takeDirectory dbPath)
putStrLn "[sis] opening database..."
conn <- openDatabase dbPath
let port = 8080
putStrLn $ "[sis] listening on 0.0.0.0:" <> show port
let hyperboleApp =
@@ -88,6 +110,15 @@ router RDashboard = runPage Sis.Page.Dashboard.page
router RChores = runPage Sis.Page.Chores.page
router RHousehold = runPage Sis.Page.Household.page
router RActivity = runPage Sis.Page.Activity.page
router (RInvite code) = do
mSession <- lookupSession @UserSession
case mSession of
Nothing -> redirect (routeUri RLogin)
Just us -> do
mHousehold <- acceptInvite (UserId (usUserId us)) (unInviteCode code)
case mHousehold of
Just _ -> redirect (routeUri RDashboard)
Nothing -> redirect (routeUri RHousehold)
router RSeed = do
seed
redirect (routeUri RDashboard)
+16 -13
View File
@@ -16,42 +16,45 @@ body {
padding: 0;
}
/* Override NB navbar to have drop shadow like our design */
.nb-navbar {
background: #fff;
border-bottom: 3px solid #000;
padding: 0.75rem 1.5rem;
display: flex;
justify-content: space-between;
align-items: center;
box-shadow: 4px 4px 0 #000;
margin-bottom: 2rem;
}
.nb-navbar-start, .nb-navbar-end {
display: flex;
align-items: center;
gap: 0.5rem;
}
/* List items with subtle dividers */
.nb-list-item {
border-bottom: 1px solid rgba(0,0,0,0.1);
padding: 0.5rem;
}
.nb-list-item:last-child {
border-bottom: none;
}
/* Stat tiles */
.stat-tile {
text-align: center;
padding: 1rem;
}
/* Container padding */
.nb-container {
padding: 0 1rem;
}
@keyframes fadeIn {
from { opacity: 0; }
to { opacity: 1; }
}
/* Responsive */
@media (max-width: 768px) {
.nb-navbar {
flex-direction: column;
gap: 0.5rem;
padding: 0.5rem;
}
.nb-navbar-end {
.nb-navbar-nav {
flex-wrap: wrap;
justify-content: center;
}
+16
View File
@@ -5,9 +5,25 @@
"packages": {
"": {
"dependencies": {
"@playwright/test": "^1.61.1",
"playwright": "^1.61.1"
}
},
"node_modules/@playwright/test": {
"version": "1.61.1",
"resolved": "https://registry.npmjs.org/@playwright/test/-/test-1.61.1.tgz",
"integrity": "sha512-8nKv6+0RJSL9FE4jYOEGXnPeM/Hg12qZpmqzZjRh3qM0Y7c3z1mrOTfFLids72RDQYVh9WpLEfR5WdpNX4fkig==",
"license": "Apache-2.0",
"dependencies": {
"playwright": "1.61.1"
},
"bin": {
"playwright": "cli.js"
},
"engines": {
"node": ">=18"
}
},
"node_modules/fsevents": {
"version": "2.3.2",
"resolved": "https://registry.npmjs.org/fsevents/-/fsevents-2.3.2.tgz",
+1
View File
@@ -1,5 +1,6 @@
{
"dependencies": {
"@playwright/test": "^1.61.1",
"playwright": "^1.61.1"
}
}
+12
View File
@@ -0,0 +1,12 @@
// @ts-check
const { defineConfig } = require('@playwright/test');
module.exports = defineConfig({
testDir: './test/e2e',
timeout: 30000,
retries: 0,
use: {
baseURL: process.env.SIS_URL || 'http://localhost:8080',
headless: true,
},
});
+65
View File
@@ -0,0 +1,65 @@
#!/usr/bin/env bash
# Run Playwright end-to-end tests.
#
# Usage: ./scripts/test-e2e
#
# Starts the sis-server with a fresh database, runs the smoke test,
# then shuts down. Set SIS_URL to test against a running instance:
# SIS_URL=http://localhost:8080 ./scripts/test-e2e
set -euo pipefail
PROJECT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")/.." && pwd)"
cd "$PROJECT_DIR"
# Build the server if needed
BIN="./.stack-work/dist/x86_64-linux/ghc-9.10.3/build/sis-server/sis-server"
if [ ! -f "$BIN" ]; then
echo "[test-e2e] building server..."
./hs stack build --fast
fi
echo "[test-e2e] running Playwright tests..."
if [ -n "${SIS_URL:-}" ]; then
npx playwright test --config=playwright.config.js "$@"
else
DB_PATH="/tmp/sis-test-$$.db"
PORT=8081
# Kill anything already on our test port
if lsof -ti:"$PORT" > /dev/null 2>&1; then
echo "[test-e2e] killing existing process on port $PORT..."
kill "$(lsof -ti:"$PORT")" 2>/dev/null || true
sleep 1
fi
# Remove stale db
rm -f "$DB_PATH"
# Clean up on exit
cleanup() {
rm -f "$DB_PATH"
if [ -n "${SERVER_PID:-}" ]; then
kill "$SERVER_PID" 2>/dev/null
wait "$SERVER_PID" 2>/dev/null || true
fi
}
trap cleanup EXIT
echo "[test-e2e] starting server on port $PORT with fresh db..."
SIS_FRESH_DB=1 SIS_PORT="$PORT" "$BIN" --db "$DB_PATH" &
SERVER_PID=$!
# Wait for server to be ready
echo "[test-e2e] waiting for server..."
for i in $(seq 1 30); do
if curl -sf http://localhost:$PORT/signup > /dev/null 2>&1; then
echo "[test-e2e] server ready"
break
fi
sleep 0.5
done
# Run tests
SIS_URL="http://localhost:$PORT" npx playwright test --config=playwright.config.js "$@"
fi
+23 -17
View File
@@ -11,12 +11,12 @@ module Sis.Database (
DB (..),
runDB,
openDatabase,
runMigrations,
-- * DB operations (convenience wrappers)
findUserByEmail,
createUser,
getUser,
setUserHousehold,
getUserHouseholds,
getHousehold,
createHousehold,
@@ -64,6 +64,7 @@ data DB :: Effect where
FindUserByEmail :: Text -> DB m (Maybe User)
CreateUser :: Text -> Text -> Text -> DB m UserId
GetUser :: UserId -> DB m (Maybe User)
SetUserHousehold :: UserId -> HouseholdId -> DB m ()
GetUserHouseholds :: UserId -> DB m [Household]
GetHousehold :: UserId -> Int -> DB m (Maybe Household)
CreateHousehold :: UserId -> Text -> DB m Household
@@ -79,7 +80,7 @@ data DB :: Effect where
CreateInvite :: Int -> Maybe Text -> DB m Invite
GetInvites :: Int -> DB m [Invite]
RevokeInvite :: Int -> DB m ()
AcceptInvite :: UserId -> Text -> DB m Household
AcceptInvite :: UserId -> Text -> DB m (Maybe Household)
Seed :: DB m ()
type instance DispatchOf DB = 'Dynamic
@@ -94,9 +95,9 @@ runDB conn = interpret $ \_ -> \case
result <-
SQL.query
conn
"SELECT id, display_name, email, password_hash FROM users WHERE email = ?"
"SELECT id, display_name, email, password_hash, household_id FROM users WHERE email = ?"
(Only email)
pure $ listToMaybe [User (UserId uid) dname em pwHash | (uid, dname, em, pwHash) <- result]
pure $ listToMaybe [User (UserId uid) dname em pwHash (HouseholdId <$> hId) | (uid, dname, em, pwHash, hId) <- result]
CreateUser dname email pwHash -> liftIO $ do
SQL.execute
conn
@@ -108,9 +109,11 @@ runDB conn = interpret $ \_ -> \case
result <-
SQL.query
conn
"SELECT id, display_name, email, password_hash FROM users WHERE id = ?"
"SELECT id, display_name, email, password_hash, household_id FROM users WHERE id = ?"
(Only uid)
pure $ listToMaybe [User (UserId uid') dname em pwHash | (uid', dname, em, pwHash) <- result]
pure $ listToMaybe [User (UserId uid') dname em pwHash (HouseholdId <$> hId) | (uid', dname, em, pwHash, hId) <- result]
SetUserHousehold (UserId uid) (HouseholdId hid) -> liftIO $ do
SQL.execute conn "UPDATE users SET household_id = ? WHERE id = ?" (hid, uid)
GetUserHouseholds (UserId uid) -> liftIO $ do
rows <-
SQL.query
@@ -138,6 +141,7 @@ runDB conn = interpret $ \_ -> \case
conn
"INSERT INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)"
(unHouseholdId hid, uid, "owner" :: String)
SQL.execute conn "UPDATE users SET household_id = ? WHERE id = ?" (unHouseholdId hid, uid)
pure $ Household hid name (UserId uid) 1
GetMembers hid -> liftIO $ do
members <-
@@ -320,16 +324,14 @@ runDB conn = interpret $ \_ -> \case
\ 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"
pure $ listToMaybe [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- hResult]
_ -> pure Nothing
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 users (id, display_name, email, password_hash, household_id) VALUES (1, 'Alice', 'alice@demo.com', ?, 1)" (Only pwHash)
SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash, household_id) VALUES (2, 'Bob', 'bob@demo.com', ?, 1)" (Only pwHash)
SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash, household_id) VALUES (3, 'Charlie', 'charlie@demo.com', ?, 1)" (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')"
@@ -391,12 +393,12 @@ openDatabase path = do
conn <- SQL.open path
SQL.execute_ conn "PRAGMA journal_mode=WAL"
SQL.execute_ conn "PRAGMA foreign_keys=ON"
runMigrations conn
createTables conn
pure conn
-- | Create all tables if they don't exist.
runMigrations :: SQL.Connection -> IO ()
runMigrations conn' =
createTables :: SQL.Connection -> IO ()
createTables conn' = do
mapM_
(SQL.execute_ conn')
[ "CREATE TABLE IF NOT EXISTS users (\
@@ -404,6 +406,7 @@ runMigrations conn' =
\ display_name TEXT NOT NULL,\
\ email TEXT NOT NULL UNIQUE,\
\ password_hash TEXT NOT NULL,\
\ household_id INTEGER REFERENCES households(id),\
\ created_at TEXT NOT NULL DEFAULT (datetime('now')))"
, "CREATE TABLE IF NOT EXISTS sessions (\
\ id INTEGER PRIMARY KEY AUTOINCREMENT,\
@@ -474,6 +477,9 @@ createUser d e p = send (CreateUser d e p)
getUser :: (DB :> es) => UserId -> Eff es (Maybe User)
getUser = send . GetUser
setUserHousehold :: (DB :> es) => UserId -> HouseholdId -> Eff es ()
setUserHousehold u = send . SetUserHousehold u
getUserHouseholds :: (DB :> es) => UserId -> Eff es [Household]
getUserHouseholds = send . GetUserHouseholds
@@ -516,7 +522,7 @@ getInvites = send . GetInvites
revokeInvite :: (DB :> es) => Int -> Eff es ()
revokeInvite = send . RevokeInvite
acceptInvite :: (DB :> es) => UserId -> Text -> Eff es Household
acceptInvite :: (DB :> es) => UserId -> Text -> Eff es (Maybe Household)
acceptInvite u = send . AcceptInvite u
seed :: (DB :> es) => Eff es ()
+8 -8
View File
@@ -17,7 +17,7 @@ import Effectful
import Sis.Database
import Sis.Route
import Sis.Style
import Sis.Style (colorGreen, colorRed, colorYellow, nbBadgeClass, nbBoxClass, nbButtonDefaultClass, nbContainerClass, nbHeadingClass, nbInputClass, nbLabelClass, nbListItemClass)
import Sis.Types
import Sis.View.Layout
import Web.Hyperbole
@@ -44,15 +44,15 @@ instance (DB :> es, IOE :> es) => HyperView ActivityPage es where
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper ActivityPage $ el "No households"
[] -> pure $ hyper ActivityPage $ pageLayout us $ el "No households"
(h : _) -> do
log <- getActivityLog (unHouseholdId (householdId h)) pageNum 20
pure $ hyper ActivityPage $ activityView log
pure $ hyper ActivityPage $ pageLayout us $ 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"
el @ att "class" nbHeadingClass $ 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)
@@ -60,12 +60,12 @@ activityView log = do
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"
then button (GoToPage (alpPage log - 1)) @ att "class" nbButtonDefaultClass $ text "Previous"
else none
el @ att "style" "align-self:center" $
text ("Page " <> T.pack (show (alpPage log)) <> " of " <> T.pack (show totalPages))
if alpPage log < totalPages
then button (GoToPage (alpPage log + 1)) @ att "class" nbButtonClass $ text "Next"
then button (GoToPage (alpPage log + 1)) @ att "class" nbButtonDefaultClass $ text "Next"
else none
else none
@@ -101,7 +101,7 @@ page = do
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper ActivityPage $ el "No households"
[] -> pure $ hyper ActivityPage $ pageLayout us $ el "No households"
(h : _) -> do
log <- getActivityLog (unHouseholdId (householdId h)) 1 20
pure $ hyper ActivityPage $ activityView log
pure $ hyper ActivityPage $ pageLayout us $ activityView log
+108 -14
View File
@@ -7,22 +7,27 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-name-shadowing -Wno-redundant-constraints -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-name-shadowing -Wno-redundant-constraints #-}
module Sis.Page.Chores (page) where
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Time (getCurrentTime)
import Data.Text.Read qualified as TR
import Data.Time (Day)
import Data.Time qualified as Time
import Effectful
import Sis.Database
import Sis.Route
import Sis.Style
import Sis.Style (colorGreen, colorRed, colorYellow, nbBadgeClass, nbBoxClass, nbButtonDefaultClass, nbContainerClass, nbHeadingClass, nbInputClass, nbLabelClass, nbListItemClass)
import Sis.Types
import Sis.View.Layout
import Text.Read (readMaybe)
import Web.Hyperbole
import Web.Hyperbole.Effect.Session
import Web.Hyperbole.HyperView.Forms
import Web.Hyperbole.Page
data ChoresPage = ChoresPage
@@ -34,6 +39,7 @@ instance (DB :> es, IOE :> es) => HyperView ChoresPage es where
= CRefreshChores
| CDeleteChore ChoreId
| CNewChore
| CCreateChore
deriving stock (Generic)
deriving anyclass (ViewAction)
@@ -44,27 +50,90 @@ instance (DB :> es, IOE :> es) => HyperView ChoresPage es where
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper ChoresPage $ el "No households"
[] -> pure $ hyper ChoresPage $ pageLayout us $ el "No households"
(h : _) -> do
chores' <- getChores (unHouseholdId (householdId h))
pure $ hyper ChoresPage $ choresView chores'
pure $ hyper ChoresPage $ pageLayout us $ choresView chores'
update (CDeleteChore cid) = do
deleteChore (unChoreId cid)
update CRefreshChores
update CNewChore = do
-- TODO: show chore creation form
pure (el "New chore form coming soon")
mUser <- lookupSession @UserSession
case mUser of
Nothing -> pure (el "Not authenticated")
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper ChoresPage $ pageLayout us $ el "No households"
(h : _) -> do
let hid = unHouseholdId (householdId h)
chores' <- getChores hid
mems <- getMembers hid
pure $ hyper ChoresPage $ pageLayout us $ choresViewWithForm chores' mems
update CCreateChore = do
form <- formData @ChoreFormData
mUser <- lookupSession @UserSession
case mUser of
Nothing -> pure (el "Not authenticated")
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper ChoresPage $ pageLayout us $ el "No households"
(h : _) -> do
let hid = unHouseholdId (householdId h)
let schedule = parseSchedule (cfdStartDate form)
assignee = parseAssignee (cfdAssignee form)
_ <- createChore hid (cfdName form) assignee schedule (cfdNotify form)
chores' <- getChores hid
pure $ hyper ChoresPage $ pageLayout us $ choresView chores'
----------------------------------------------------------------------
-- Views
----------------------------------------------------------------------
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"
el @ att "class" nbHeadingClass $ text "Chores"
button CNewChore @ att "class" nbButtonDefaultClass $ 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'
-- | Chores list with the creation form shown
choresViewWithForm :: [Chore] -> [Membership] -> View ChoresPage ()
choresViewWithForm chores' mems = 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" nbHeadingClass $ text "Chores"
button CRefreshChores @ att "class" nbButtonDefaultClass $ text "Cancel"
-- New chore form
el @ att "class" nbBoxClass @ att "style" "padding:1.5rem;margin-bottom:1.5rem" $ do
el @ att "class" nbHeadingClass $ text "New Chore"
form CCreateChore $ do
el @ att "class" nbLabelClass $ text "Chore Name"
tag "input" @ att "type" "text" . att "name" "cfdName" . att "class" nbInputClass @ att "style" "width:100%;margin-bottom:1rem" $ none
el @ att "class" nbLabelClass $ text "Date (YYYY-MM-DD)"
tag "input" @ att "type" "date" . att "name" "cfdStartDate" . att "class" nbInputClass @ att "style" "width:100%;margin-bottom:1rem" $ none
tag "input" @ att "type" "hidden" . att "name" "cfdScheduleType" . att "value" "one_off" $ none
tag "input" @ att "type" "hidden" . att "name" "cfdPeriod" . att "value" "daily" $ none
tag "input" @ att "type" "hidden" . att "name" "cfdNotify" . att "value" "false" $ none
el @ att "class" nbLabelClass $ text "Assigned To"
tag "select" @ att "name" "cfdAssignee" . att "class" nbInputClass @ att "style" "width:100%;margin-bottom:1rem" $ do
tag "option" @ att "value" "anyone" $ text "Anyone"
mapM_ memberOption mems
submit (text "Create Chore") @ att "class" nbButtonDefaultClass @ att "style" "width:100%"
-- Chores list below the form
if null chores'
then el @ att "style" "opacity:0.5" $ text "No chores yet."
else el @ att "class" nbBoxClass $ mapM_ choreRow chores'
memberOption :: Membership -> View ctx ()
memberOption m = do
let val = "user:" <> T.pack (show (unUserId (membershipUserId m)))
tag "option" @ att "value" val $ text (membershipDisplayName m)
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
@@ -73,8 +142,12 @@ choreRow c = do
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"
button CNewChore @ att "class" nbButtonDefaultClass @ att "style" "font-size:0.8rem;padding:0.25rem 0.5rem" $ text "Edit"
button (CDeleteChore (choreId c)) @ att "class" nbButtonDefaultClass @ att "style" "font-size:0.8rem;padding:0.25rem 0.5rem;background:var(--nb-red)" $ text "Delete"
----------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------
scheduleBadge :: Schedule -> Text
scheduleBadge ScheduleSometime{} = "sometime"
@@ -86,9 +159,30 @@ scheduleLabel ScheduleSometime = "Sometime"
scheduleLabel (ScheduleOneOff d _) = "One-off on " <> T.pack (show d)
scheduleLabel (ScheduleRecurring p _ mt _ _) =
let pText = case p of PeriodDaily -> "daily"; PeriodWeekly -> "weekly"; PeriodMonthly -> "monthly"
timePart = maybe "" (\t -> " at " <> t) mt
timePart = maybe "" (" at " <>) mt
in "Recurs " <> pText <> timePart
-- | Parse a date string (YYYY-MM-DD) into a ScheduleOneOff. Falls back to today.
parseSchedule :: Text -> Schedule
parseSchedule t = case readMaybe (T.unpack t) of
Just d -> ScheduleOneOff d Nothing
Nothing -> ScheduleSometime
-- | Parse an assignee value ("anyone" or "user:<id>")
parseAssignee :: Text -> ChoreAssignee
parseAssignee "anyone" = AssigneeAnyone
parseAssignee t
| "user:" `T.isPrefixOf` t =
let uidText = T.drop 5 t
in case TR.decimal uidText of
Right (uid, _) -> AssigneeUser (UserId uid)
Left _ -> AssigneeAnyone
| otherwise = AssigneeAnyone
----------------------------------------------------------------------
-- Page
----------------------------------------------------------------------
page :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[ChoresPage]
page = do
mSession <- lookupSession @UserSession
@@ -98,7 +192,7 @@ page = do
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper ChoresPage $ el "No households"
[] -> pure $ hyper ChoresPage $ pageLayout us $ el "No households"
(h : _) -> do
chores' <- getChores (unHouseholdId (householdId h))
pure $ hyper ChoresPage $ choresView chores'
pure $ hyper ChoresPage $ pageLayout us $ choresView chores'
+18 -14
View File
@@ -19,7 +19,7 @@ import Effectful
import Sis.Database
import Sis.Route
import Sis.Style
import Sis.Style (colorGreen, colorRed, colorYellow, nbBadgeClass, nbBoxClass, nbButtonDefaultClass, nbContainerClass, nbHeadingClass, nbInputClass, nbLabelClass, nbListItemClass)
import Sis.Types
import Sis.View.Layout
import Web.Hyperbole
@@ -45,38 +45,42 @@ instance (DB :> es, IOE :> es) => HyperView DashboardPage es where
today <- liftIO (utctDay <$> getCurrentTime)
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper DashboardPage $ el "No households"
[] -> pure $ hyper DashboardPage $ pageLayout us $ el "No households"
(h : _) -> do
dash <- getDashboard (unHouseholdId (householdId h)) today
pure $ hyper DashboardPage $ dashboardView dash
update (CheckOff _oid) = do
-- TODO: wire up to activity form
update RefreshDashboard
pure $ hyper DashboardPage $ pageLayout us $ dashboardView dash
update (CheckOff oid) = do
mUser <- lookupSession @UserSession
case mUser of
Nothing -> pure (el "Not authenticated")
Just us -> do
_ <- recordActivity (unOccurrenceId oid) (UserId (usUserId us)) ActivityCompleted Nothing False
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 "class" nbHeadingClass $ text "Dashboard"
el @ att "style" "display:flex;gap:1rem;margin-bottom:1.5rem" $ do
let stats = dashStats dash
statTile "Overdue" (T.pack (show (dsOverdue stats))) colorRed
statTile "Due Today" (T.pack (show (dsDueToday stats))) colorYellow
statTile "Done This Week" (T.pack (show (dsDoneThisWeek stats))) colorGreen
el @ att "class" nbFontHeading2Class $ text "Overdue & Due Today"
el @ att "class" nbHeadingClass $ 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"
el @ att "class" nbHeadingClass $ 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 RActivity $ text "View Full Activity Log"
route RActivity @ att "class" nbButtonDefaultClass $ 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
el @ att "class" nbHeadingClass $ text count
text label
dueItemRow :: DueItem -> View DashboardPage ()
@@ -90,7 +94,7 @@ dueItemRow di = do
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"
button (CheckOff (occurrenceId (diOccurrence di))) @ att "class" nbButtonDefaultClass @ att "style" "font-size:0.85rem" $ text "Check Off"
completedItemRow :: CompletedItem -> View DashboardPage ()
completedItemRow ci = do
@@ -115,7 +119,7 @@ page = do
today <- liftIO (utctDay <$> getCurrentTime)
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper DashboardPage $ el "No households"
[] -> pure $ hyper DashboardPage $ pageLayout us $ el "No households"
(h : _) -> do
dash <- getDashboard (unHouseholdId (householdId h)) today
pure $ hyper DashboardPage $ dashboardView dash
pure $ hyper DashboardPage $ pageLayout us $ dashboardView dash
+34 -17
View File
@@ -17,11 +17,12 @@ import Effectful
import Sis.Database
import Sis.Route
import Sis.Style
import Sis.Style (colorGreen, colorRed, colorYellow, nbBadgeClass, nbBoxClass, nbButtonDefaultClass, nbContainerClass, nbHeadingClass, nbInputClass, nbLabelClass, nbListItemClass)
import Sis.Types
import Sis.View.Layout
import Web.Hyperbole
import Web.Hyperbole.Effect.Session
import Web.Hyperbole.HyperView.Forms
import Web.Hyperbole.Page
data HouseholdPage = HouseholdPage
@@ -33,6 +34,7 @@ instance (DB :> es, IOE :> es) => HyperView HouseholdPage es where
= RefreshHousehold
| CreateInviteAction
| RevokeInviteAction InviteId
| CreateHouseholdAction
deriving stock (Generic)
deriving anyclass (ViewAction)
@@ -43,12 +45,24 @@ instance (DB :> es, IOE :> es) => HyperView HouseholdPage es where
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure (noHouseholdView)
[] -> pure $ hyper HouseholdPage $ pageLayout us noHouseholdView
(h : _) -> do
let hid = unHouseholdId (householdId h)
mems <- getMembers hid
invs <- getInvites hid
pure $ hyper HouseholdPage $ householdView h mems invs
pure $ hyper HouseholdPage $ pageLayout us $ householdView h mems invs
update CreateHouseholdAction = do
form <- formData @HouseholdFormData
mUser <- lookupSession @UserSession
case mUser of
Nothing -> pure (el "Not authenticated")
Just us -> do
let uid = UserId (usUserId us)
h <- createHousehold uid (hfdName form)
let hid = unHouseholdId (householdId h)
mems <- getMembers hid
invs <- getInvites hid
pure $ hyper HouseholdPage $ pageLayout us $ householdView h mems invs
update CreateInviteAction = do
mUser <- lookupSession @UserSession
case mUser of
@@ -68,27 +82,29 @@ instance (DB :> es, IOE :> es) => HyperView HouseholdPage es where
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"
el @ att "class" nbBoxClass @ att "style" "padding:2rem" $ do
el @ att "class" nbHeadingClass $ text "Create Your Household"
el @ att "style" "opacity:0.7;margin-bottom:1.5rem" $ text "You need a household to get started."
form CreateHouseholdAction $ do
el @ att "class" nbLabelClass $ text "Household Name"
tag "input" @ att "type" "text" . att "name" "hfdName" . att "class" nbInputClass @ att "style" "width:100%;margin-bottom:1rem" $ none
submit (text "Create Household") @ att "class" nbButtonDefaultClass @ att "style" "width:100%"
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 "class" nbHeadingClass $ text (householdName h)
el @ att "style" "opacity:0.7" $ text (T.pack (show (length mems)) <> " members")
el @ att "class" nbFontHeading2Class $ text "Members"
el @ att "class" nbHeadingClass $ 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" nbHeadingClass $ 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"
button CreateInviteAction @ att "class" nbButtonDefaultClass $ text "+ Create Invite Link"
if null invs
then none
else el @ att "style" "margin-top:1rem" $ do
el @ att "class" nbFontHeading2Class $ text "Pending Invites"
el @ att "class" nbHeadingClass $ text "Pending Invites"
mapM_ inviteRow (filter ((== InvitePending) . inviteStatus) invs)
memberRow :: Membership -> View HouseholdPage ()
@@ -105,8 +121,9 @@ memberRow m = do
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)" $
route (RInvite (InviteCode (inviteCode i))) @ att "class" nbButtonDefaultClass @ att "style" "font-size:0.85rem;text-decoration:none" $
text (inviteCode i)
button (RevokeInviteAction (inviteId i)) @ att "class" nbButtonDefaultClass @ att "style" "font-size:0.8rem;background:var(--nb-red)" $
text "Revoke"
initials :: Text -> Text
@@ -123,9 +140,9 @@ page = do
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper HouseholdPage $ noHouseholdView
[] -> pure $ hyper HouseholdPage $ pageLayout us noHouseholdView
(h : _) -> do
let hid = unHouseholdId (householdId h)
mems <- getMembers hid
invs <- getInvites hid
pure $ hyper HouseholdPage $ householdView h mems invs
pure $ hyper HouseholdPage $ pageLayout us $ householdView h mems invs
+11 -10
View File
@@ -17,7 +17,7 @@ import Effectful
import Sis.Auth (generateToken, hashPassword, verifyPassword)
import Sis.Database
import Sis.Route
import Sis.Style
import Sis.Style (colorGreen, colorRed, colorYellow, nbBadgeClass, nbBoxClass, nbButtonDefaultClass, nbContainerClass, nbHeadingClass, nbInputClass, nbLabelClass, nbListItemClass)
import Sis.Types
import Sis.View.Layout
import Web.Hyperbole
@@ -40,8 +40,8 @@ instance (DB :> es, IOE :> es) => HyperView LoginPage es where
case mUser of
Just u
| verifyPassword (lfPassword formData') (userPasswordHash u) -> do
saveSession (UserSession (unUserId (userId u)))
pure (loginSuccessView)
saveSession (UserSession (unUserId (userId u)) (userDisplayName u))
pure loginSuccessView
_ -> pure (loginView (Just "Invalid email or password"))
update Noop = pure (loginView Nothing)
@@ -49,15 +49,15 @@ loginSuccessView :: View LoginPage ()
loginSuccessView = do
el @ att "class" nbContainerClass @ att "style" "max-width:480px;margin:4rem auto;text-align:center" $ do
el @ att "class" nbBoxClass @ att "style" "padding:2rem" $ do
el @ att "class" nbFontHeading1Class $ text "Logged In!"
el @ att "class" nbHeadingClass $ text "Logged In!"
el @ att "style" "margin-top:1rem;margin-bottom:1rem" $ text "You are now logged in."
route RDashboard $ text "Go to Dashboard"
route RDashboard @ att "class" nbButtonDefaultClass $ text "Go to Dashboard"
loginView :: Maybe Text -> View LoginPage ()
loginView mError = do
el @ att "class" nbContainerClass @ att "style" "max-width:480px;margin:4rem auto" $ do
el @ att "class" nbBoxClass @ att "style" "padding:2rem" $ do
el @ att "class" nbFontHeading1Class $ text "Welcome Back"
el @ att "class" nbHeadingClass $ text "Welcome Back"
el @ att "style" "opacity:0.7;margin-bottom:1.5rem" $ text "Log in to manage your household chores."
case mError of
Just err ->
@@ -69,10 +69,11 @@ loginView mError = do
el @ att "class" nbLabelClass $ text "Password"
tag "input" @ att "type" "password" . att "name" "lfPassword" . att "class" nbInputClass @ att "style" "width:100%" $ none
el @ att "style" "display:flex;align-items:center;gap:0.5rem;margin-bottom:1rem" $ do
tag "input" @ att "type" "checkbox" . att "name" "lfRemember" $ none
text "Remember me"
submit (text "Log In") @ att "class" nbButtonClass @ att "style" "width:100%"
route RSignup $ text "Don't have an account? Sign Up"
tag "input" @ att "type" "checkbox" . att "name" "lfRemember" . att "class" "nb-checkbox" $ none
el @ att "class" nbLabelClass $ text "Remember me"
submit (text "Log In") @ att "class" nbButtonDefaultClass @ att "style" "width:100%"
el @ att "style" "margin-top:1rem;text-align:center" $ do
route RSignup @ att "class" nbButtonDefaultClass $ text "Sign Up"
page :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[LoginPage]
page = do
mSession <- lookupSession @UserSession
+10 -10
View File
@@ -18,7 +18,7 @@ import Effectful
import Sis.Auth (generateToken, hashPassword, verifyPassword)
import Sis.Database
import Sis.Route
import Sis.Style
import Sis.Style (colorGreen, colorRed, colorYellow, nbBadgeClass, nbBoxClass, nbButtonDefaultClass, nbContainerClass, nbHeadingClass, nbInputClass, nbLabelClass, nbListItemClass)
import Sis.Types
import Sis.View.Layout
import Web.Hyperbole
@@ -48,22 +48,22 @@ instance (DB :> es, IOE :> es) => HyperView SignupPage es where
Nothing -> do
pwHash <- liftIO (hashPassword (sfPassword form))
uid <- createUser (sfDisplayName form) (sfEmail form) pwHash
saveSession (UserSession (unUserId uid))
pure (signupSuccessView)
saveSession (UserSession (unUserId uid) (sfDisplayName form))
pure signupSuccessView
signupSuccessView :: View SignupPage ()
signupSuccessView = do
el @ att "class" nbContainerClass @ att "style" "max-width:480px;margin:4rem auto;text-align:center" $ do
el @ att "class" nbBoxClass @ att "style" "padding:2rem" $ do
el @ att "class" nbFontHeading1Class $ text "Account Created!"
el @ att "class" nbHeadingClass $ text "Account Created!"
el @ att "style" "margin-top:1rem;margin-bottom:1rem" $ text "Your account has been created."
route RDashboard $ text "Go to Dashboard"
route RDashboard @ att "class" nbButtonDefaultClass $ text "Go to Dashboard"
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 "class" nbHeadingClass $ text "Create Account"
el @ att "style" "opacity:0.7;margin-bottom:1.5rem" $ text "Join your household chore tracker."
case mError of
Just err ->
@@ -79,10 +79,10 @@ signupView mError = do
el @ att "class" nbLabelClass $ text "Confirm Password"
tag "input" @ att "type" "password" . att "name" "sfConfirm" . att "class" nbInputClass @ att "style" "width:100%" $ none
el @ att "style" "display:flex;align-items:center;gap:0.5rem;margin-bottom:1rem" $ do
tag "input" @ att "type" "checkbox" . att "name" "sfAgree" $ none
text "I agree to the terms of service"
submit (text "Sign Up") @ att "class" nbButtonClass @ att "style" "width:100%"
route RLogin $ text "Already have an account? Log In"
tag "input" @ att "type" "checkbox" . att "name" "sfAgree" . att "class" "nb-checkbox" $ none
el @ att "class" nbLabelClass $ text "I agree to the terms of service"
submit (text "Sign Up") @ att "class" nbButtonDefaultClass @ att "style" "width:100%"
route RLogin @ att "class" nbButtonDefaultClass $ text "Log In"
page :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[SignupPage]
page = do
mSession <- lookupSession @UserSession
+20 -2
View File
@@ -1,11 +1,28 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Sis.Route (AppRoute (..)) where
module Sis.Route (AppRoute (..), InviteCode (..)) where
import Data.Text (Text)
import GHC.Generics (Generic)
import Web.Hyperbole.Route
----------------------------------------------------------------------
-- Invite Code
----------------------------------------------------------------------
newtype InviteCode = InviteCode {unInviteCode :: Text}
deriving stock (Show, Eq)
instance Route InviteCode where
matchRoute (Path [t]) = Just (InviteCode t)
matchRoute _ = Nothing
routePath (InviteCode c) = Path [c]
baseRoute = Nothing
----------------------------------------------------------------------
-- App Routes
----------------------------------------------------------------------
data AppRoute
= Home
| RLogin
@@ -14,6 +31,7 @@ data AppRoute
| RChores
| RHousehold
| RActivity
| RInvite InviteCode
| RSeed
deriving stock (Eq, Generic, Show)
+28 -12
View File
@@ -1,17 +1,17 @@
{-# LANGUAGE OverloadedStrings #-}
{- | Neo Brutalism CSS class name constants for Hyperbole views.
Use with: \@ att \"class\" nbBoxClass
Based on https://github.com/matifandy8/NeoBrutalismCSS
-}
module Sis.Style (
nbBoxClass,
nbButtonClass,
nbButtonDefaultClass,
nbInputClass,
nbLabelClass,
nbBadgeClass,
nbFontHeading1Class,
nbFontHeading2Class,
nbHeadingClass,
nbNavbarClass,
nbNavbarLinkClass,
nbContainerClass,
nbListItemClass,
colorRed,
@@ -21,22 +21,38 @@ module Sis.Style (
import Data.Text (Text)
nbBoxClass, nbButtonClass, nbInputClass, nbLabelClass, nbBadgeClass :: Text
nbBoxClass = "nb-box"
nbButtonClass = "nb-button"
-- Box/panel
nbBoxClass :: Text
nbBoxClass = "nb-card"
-- Button (default variant: black border, white bg)
nbButtonDefaultClass :: Text
nbButtonDefaultClass = "nb-button default"
-- Form elements
nbInputClass, nbLabelClass :: Text
nbInputClass = "nb-input"
nbLabelClass = "nb-label"
nbBadgeClass = "nb-badge"
nbFontHeading1Class, nbFontHeading2Class :: Text
nbFontHeading1Class = "nb-font-heading1"
nbFontHeading2Class = "nb-font-heading2"
-- Badge/pill (inline label)
nbBadgeClass :: Text
nbBadgeClass = "nb-button default"
nbNavbarClass, nbContainerClass, nbListItemClass :: Text
-- Heading
nbHeadingClass :: Text
nbHeadingClass = "nb-card-title"
-- Navbar
nbNavbarClass, nbNavbarLinkClass :: Text
nbNavbarClass = "nb-navbar"
nbNavbarLinkClass = "nb-navbar-link"
-- Layout
nbContainerClass, nbListItemClass :: Text
nbContainerClass = "nb-container"
nbListItemClass = "nb-list-item"
-- CSS color variables
colorRed, colorYellow, colorGreen :: Text
colorRed = "var(--nb-red)"
colorYellow = "var(--nb-yellow)"
+5 -3
View File
@@ -78,7 +78,7 @@ newtype ChoreId = ChoreId {unChoreId :: Int}
newtype OccurrenceId = OccurrenceId {unOccurrenceId :: Int}
deriving newtype (Show, Eq, Read, ToJSON, FromJSON)
newtype ActivityId = ActivityId {unActivityId :: Int}
newtype ActivityId = ActivityId Int
deriving newtype (Show, Eq, Read, ToJSON, FromJSON)
newtype InviteId = InviteId {unInviteId :: Int}
@@ -93,6 +93,7 @@ data User = User
, userDisplayName :: Text
, userEmail :: Text
, userPasswordHash :: Text
, userHouseholdId :: Maybe HouseholdId
}
deriving stock (Show, Eq)
@@ -292,7 +293,8 @@ data ActivityFormData = ActivityFormData
}
deriving (Show, Eq, Generic, FromForm)
data HouseholdFormData = HouseholdFormData
newtype HouseholdFormData = HouseholdFormData
{ hfdName :: Text
}
deriving (Show, Eq, Generic, FromForm)
deriving stock (Show, Eq, Generic)
deriving anyclass (FromForm)
+34 -12
View File
@@ -6,17 +6,20 @@
module Sis.View.Layout (
documentHead,
navbar,
pageLayout,
UserSession (..),
) where
import Data.Aeson
import Data.Default
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics (Generic)
import Sis.Route
import Sis.Style
import Sis.Style (nbButtonDefaultClass, nbHeadingClass, nbNavbarClass, nbNavbarLinkClass)
import Web.Hyperbole
import Web.Hyperbole.Data.URI (uriToText)
import Web.Hyperbole.Effect.Session
----------------------------------------------------------------------
@@ -25,15 +28,17 @@ import Web.Hyperbole.Effect.Session
data UserSession = UserSession
{ usUserId :: Int
, usDisplayName :: Text
}
deriving stock (Show, Eq, Generic)
deriving anyclass (FromJSON, ToJSON)
instance Session UserSession where
cookiePath = Just "/"
cookieSecure = False
instance Default UserSession where
def = UserSession 0
def = UserSession 0 ""
----------------------------------------------------------------------
-- Document Head
@@ -44,8 +49,12 @@ documentHead = do
title "Sis — Household Chore Tracker"
mobileFriendly
meta @ att "charset" "UTF-8"
stylesheet "https://unpkg.com/neobrutalismcss@latest"
stylesheet "https://cdn.jsdelivr.net/gh/matifandy8/NeoBrutalismCSS/dist/index.min.css"
stylesheet "/static/style.css"
-- Lexend Mega font for headings/buttons (used by NeoBrutalismCSS)
tag "link" @ att "rel" "preconnect" . att "href" "https://fonts.googleapis.com" $ none
tag "link" @ att "rel" "preconnect" . att "href" "https://fonts.gstatic.com" @ att "crossorigin" "" $ none
tag "link" @ att "href" "https://fonts.googleapis.com/css2?family=Lexend+Mega:wght@900&family=Public+Sans:wght@400;600;700&display=swap" . att "rel" "stylesheet" $ none
tag "link" @ att "rel" "manifest" . att "href" "/static/manifest.json" $ none
script' scriptEmbed
@@ -53,18 +62,31 @@ documentHead = do
-- Navbar
----------------------------------------------------------------------
navbar :: View ctx ()
navbar = do
navbar :: UserSession -> View ctx ()
navbar us = 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 RDashboard "Dashboard"
tag "a" @ att "class" "nb-navbar-brand" . att "href" (uriToText (routeUri RDashboard)) $ text "Sis"
el @ att "class" "nb-navbar-nav" $ do
routeLink RDashboard "Today"
routeLink RChores "Chores"
routeLink RHousehold "Household"
routeLink RActivity "Activity"
routeLink RLogin "Logout"
routeLink RHousehold "Household"
el @ att "class" "nb-navbar-avatar" @ att "style" "width:2.5rem;height:2.5rem;border-radius:50%;background:#000;color:#fff;display:flex;align-items:center;justify-content:center;font-family:'Lexend Mega','Public Sans',sans-serif;font-weight:900;font-size:0.85rem;flex-shrink:0" $
text (initials (usDisplayName us))
routeLink :: (Route r) => r -> Text -> View ctx ()
routeLink rt lbl = do
el @ att "class" nbButtonClass $ route rt $ text lbl
tag "li" @ att "class" "nb-navbar-item" $ do
tag "a" @ att "class" nbNavbarLinkClass . att "href" (uriToText (routeUri rt)) $ text lbl
-- | Extract up to 2 initials from a display name
initials :: Text -> Text
initials displayName =
let ws = map (T.take 1) (T.words displayName)
in T.toUpper (T.take 2 (T.concat ws))
-- | Wrap content in a shared page shell (navbar + container)
pageLayout :: UserSession -> View ctx () -> View ctx ()
pageLayout us body = do
navbar us
body
+57 -32
View File
@@ -2,46 +2,71 @@ const { chromium } = require('playwright');
(async () => {
const browser = await chromium.launch({ headless: true });
const page = await browser.newPage();
const context = await browser.newContext();
const page = await context.newPage();
// Collect ALL console messages
page.on('console', msg => console.log('CONSOLE:', msg.type(), msg.text()));
page.on('console', msg => console.log('CONSOLE:', msg.type(), msg.text().substring(0, 150)));
page.on('pageerror', err => console.log('PAGE ERROR:', err.message));
// Listen for network responses
page.on('response', resp => {
if (resp.url().includes('/rlogin') || resp.url().includes('websocket')) {
console.log('RESPONSE:', resp.status(), resp.url().substring(0, 50));
}
});
// Step 1: Load login page
console.log('\n=== Step 1: Load login page ===');
await page.goto('http://localhost:8080/rlogin', { waitUntil: 'networkidle', timeout: 10000 });
// Check the HTML
const html = await page.content();
console.log('Has "Welcome":', html.includes('Welcome'));
console.log('Has "lfEmail":', html.includes('lfEmail'));
console.log('Has form action:', html.includes('data-onsubmit'));
console.log('URL:', page.url());
// Step 2: Submit login form
console.log('\n=== Step 2: Submit login ===');
await page.fill('input[name="lfEmail"]', 'alice@demo.com');
await page.fill('input[name="lfPassword"]', 'password123');
console.log('Clicking submit...');
await page.click('button[type="submit"]');
// Wait to see what happens
await page.waitForTimeout(4000);
const newHtml = await page.content();
console.log('After submit URL:', page.url());
console.log('Has "Invalid":', newHtml.includes('Invalid'));
console.log('Has "Logged In":', newHtml.includes('Logged In'));
console.log('Has "Redirecting":', newHtml.includes('Redirecting'));
console.log('Has "Dashboard":', newHtml.includes('Dashboard'));
await page.waitForTimeout(3000);
console.log('URL after submit:', page.url());
// Check cookies
const cookies = await page.context().cookies();
console.log('Cookies:', JSON.stringify(cookies.map(c => c.name + '=' + c.value)));
const cookies = await context.cookies();
console.log('Cookies:', JSON.stringify(cookies.map(c => ({ name: c.name, value: c.value.substring(0, 20), domain: c.domain, path: c.path }))));
// Check content
const content = await page.content();
console.log('Has "Go to Dashboard":', content.includes('Go to Dashboard'));
console.log('Has "Logged In":', content.includes('Logged In'));
// Step 3: Click "Go to Dashboard"
console.log('\n=== Step 3: Click Go to Dashboard ===');
const dashLink = await page.$('a[href="/rdashboard"]');
if (dashLink) {
console.log('Found dashboard link');
await dashLink.click();
await page.waitForTimeout(3000);
} else {
console.log('No dashboard link found, navigating directly');
await page.goto('http://localhost:8080/rdashboard', { waitUntil: 'networkidle', timeout: 10000 });
}
console.log('URL after dashboard:', page.url());
const dashContent = await page.content();
console.log('Has "Welcome Back":', dashContent.includes('Welcome Back'));
console.log('Has "Dashboard":', dashContent.includes('Dashboard'));
console.log('Has "Overdue":', dashContent.includes('Overdue'));
console.log('Has "No households":', dashContent.includes('No households'));
// Step 4: Check what happens when clicking navbar Dashboard
console.log('\n=== Step 4: Click navbar Dashboard ===');
const navLinks = await page.$$('a');
for (const link of navLinks) {
const href = await link.getAttribute('href');
const text = await link.textContent();
if (text && text.trim() === 'Dashboard') {
console.log('Found navbar Dashboard link:', href);
await link.click();
await page.waitForTimeout(3000);
break;
}
}
console.log('URL after navbar click:', page.url());
const navContent = await page.content();
console.log('Has "Welcome Back":', navContent.includes('Welcome Back'));
console.log('Has "Overdue":', navContent.includes('Overdue'));
await browser.close();
console.log('\nDone.');
})().catch(e => { console.error('FAIL:', e.message); process.exit(1); });
+97
View File
@@ -0,0 +1,97 @@
// @ts-check
const { test, expect } = require('@playwright/test');
const BASE_URL = process.env.SIS_URL || 'http://localhost:8080';
// Hyperbole lowercases constructor names for URLs: RDashboard -> /rdashboard
const URLS = {
signup: `${BASE_URL}/rsignup`,
login: `${BASE_URL}/rlogin`,
dashboard: `${BASE_URL}/rdashboard`,
chores: `${BASE_URL}/rchores`,
household: `${BASE_URL}/rhousehold`,
activity: `${BASE_URL}/ractivity`,
};
test.describe('Sis app smoke test', () => {
test('full flow: signup → login → create household → create chore', async ({ page }) => {
const unique = Date.now();
const email = `test-${unique}@example.com`;
const displayName = 'James Brechtel';
const password = 'password123';
const householdName = 'Test Casa';
const choreName = 'Take out the trash';
// ── 1. Sign up ──────────────────────────────────────────────
await page.goto(URLS.signup);
await page.waitForSelector('input[name="sfDisplayName"]', { timeout: 5000 });
// Fill out the signup form
await page.fill('input[name="sfDisplayName"]', displayName);
await page.fill('input[name="sfEmail"]', email);
await page.fill('input[name="sfPassword"]', password);
await page.fill('input[name="sfConfirm"]', password);
await page.check('input[name="sfAgree"]');
// Submit (Hyperbole replaces content in-place, no navigation)
await Promise.all([
page.waitForResponse(resp => resp.url().includes('/rsignup') && resp.status() === 200),
page.click('button[type="submit"]'),
]);
// Signup success page has a "Go to Dashboard" link
await expect(page.getByText('Account Created!')).toBeVisible({ timeout: 10000 });
await page.click('a:has-text("Go to Dashboard")');
// Now on dashboard or household page (no household yet)
await expect(page.locator('.nb-navbar-brand')).toBeVisible({ timeout: 10000 });
// ── 2. Create household ─────────────────────────────────────
const householdLink = page.locator('.nb-navbar-link', { hasText: 'Household' });
await householdLink.click();
// Should see the "Create Your Household" form
await expect(page.getByText('Create Your Household')).toBeVisible({ timeout: 10000 });
await page.fill('input[name="hfdName"]', householdName);
await Promise.all([
page.waitForResponse(resp => resp.url().includes('/rhousehold') && resp.status() === 200),
page.click('button[type="submit"]'),
]);
// Should see the household view with member count
await expect(page.getByText('1 members')).toBeVisible({ timeout: 10000 });
await expect(page.getByText(householdName)).toBeVisible();
// ── 3. Create chore ─────────────────────────────────────────
const choresLink = page.locator('.nb-navbar-link', { hasText: 'Chores' });
await choresLink.click();
// Click "+ New Chore" to open the form
const newChoreBtn = page.getByRole('button', { name: '+ New Chore' });
await newChoreBtn.click();
// Fill out the chore form
await expect(page.getByText('New Chore')).toBeVisible({ timeout: 10000 });
await page.fill('input[name="cfdName"]', choreName);
await page.fill('input[name="cfdStartDate"]', '2026-12-25');
// Submit
await Promise.all([
page.waitForResponse(resp => resp.url().includes('/rchores') && resp.status() === 200),
page.click('button[type="submit"]'),
]);
// Should appear in the chores list
await expect(page.getByText(choreName)).toBeVisible({ timeout: 10000 });
await expect(page.getByText('One-off on 2026-12-25')).toBeVisible();
// ── 4. Verify we're still authenticated ────────────────────
// Navigate to dashboard — should work since we have a session cookie
await page.goto(URLS.dashboard);
await expect(page.locator('.nb-navbar-brand')).toBeVisible({ timeout: 10000 });
await expect(page.getByText('Dashboard')).toBeVisible({ timeout: 5000 });
});
});