Compare commits
12 Commits
e8036bab11
..
main
| Author | SHA1 | Date | |
|---|---|---|---|
| 92c9fae885 | |||
| 47a2eff484 | |||
| 9d0246cbcf | |||
| 1c19d97dc8 | |||
| 6bea83be7d | |||
| 92f076f329 | |||
| b5ff79fc76 | |||
| 5485bdfd0b | |||
| 02044642a7 | |||
| bcdda0754b | |||
| dbfe3a7c66 | |||
| 95ac550191 |
@@ -12,5 +12,6 @@ __pycache__
|
||||
.superpowers/
|
||||
node_modules/
|
||||
frontend/dist/
|
||||
test-results/
|
||||
hyperbole-local/
|
||||
hyperbole-local/
|
||||
|
||||
@@ -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
@@ -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
@@ -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;
|
||||
}
|
||||
|
||||
Generated
+16
@@ -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,5 +1,6 @@
|
||||
{
|
||||
"dependencies": {
|
||||
"@playwright/test": "^1.61.1",
|
||||
"playwright": "^1.61.1"
|
||||
}
|
||||
}
|
||||
|
||||
@@ -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,
|
||||
},
|
||||
});
|
||||
Executable
+65
@@ -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
@@ -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 ()
|
||||
|
||||
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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); });
|
||||
|
||||
@@ -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 });
|
||||
});
|
||||
|
||||
});
|
||||
Reference in New Issue
Block a user