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/
|
.superpowers/
|
||||||
node_modules/
|
node_modules/
|
||||||
frontend/dist/
|
frontend/dist/
|
||||||
|
test-results/
|
||||||
hyperbole-local/
|
hyperbole-local/
|
||||||
hyperbole-local/
|
hyperbole-local/
|
||||||
|
|||||||
@@ -21,7 +21,12 @@ Hyperbole, a serverside web framework. There is zero application JavaScript.
|
|||||||
## Haskell Conventions
|
## Haskell Conventions
|
||||||
|
|
||||||
- **Style:** fourmolu-formatted. Run `./hs fourmolu --mode inplace app/ src/ test/` before committing.
|
- **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.
|
- **Warnings:** `-Wall -Werror` in `package.yaml`. All warnings are fatal.
|
||||||
- **Module qualifiers:** Use qualified imports with descriptive aliases
|
- **Module qualifiers:** Use qualified imports with descriptive aliases
|
||||||
(e.g., `import Data.Text qualified as T`).
|
(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
|
- **Framework:** [Hyperbole](https://github.com/seanhess/hyperbole) — Haskell
|
||||||
serverside web framework. All HTML rendered in Haskell.
|
serverside web framework. All HTML rendered in Haskell.
|
||||||
- **CSS:** [Neo Brutalism](https://unpkg.com/neobrutalismcss@latest) CDN +
|
- **CSS:** [Neo Brutalism](https://github.com/matifandy8/NeoBrutalismCSS) CDN via jsdelivr + `frontend/static/style.css` for custom styles.
|
||||||
`frontend/static/style.css` for custom styles.
|
|
||||||
- **Build:** No npm/build step for frontend. All pages rendered in Haskell.
|
- **Build:** No npm/build step for frontend. All pages rendered in Haskell.
|
||||||
- **Interactive components:** HyperViews with typed Actions and server-side
|
- **Interactive components:** HyperViews with typed Actions and server-side
|
||||||
updates via VirtualDOM over WebSocket.
|
updates via VirtualDOM over WebSocket.
|
||||||
@@ -86,5 +90,6 @@ sis/
|
|||||||
- Run `./scripts/test` before committing. Tests must pass.
|
- Run `./scripts/test` before committing. Tests must pass.
|
||||||
|
|
||||||
## Agent Autonomy
|
## Agent Autonomy
|
||||||
|
- Run `./hs hlint app/ src/ test/` and fix ALL hints before committing.
|
||||||
- As changes are completed then verify functionality using Playwright
|
- As changes are completed then verify functionality using Playwright
|
||||||
- Once functionality is confirmed then commit and push changes
|
- Once functionality is confirmed then commit and push changes
|
||||||
|
|||||||
+35
-4
@@ -1,10 +1,13 @@
|
|||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists -Wno-name-shadowing #-}
|
{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists -Wno-name-shadowing #-}
|
||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
|
import Control.Exception (IOException, catch)
|
||||||
import Data.ByteString qualified as BS
|
import Data.ByteString qualified as BS
|
||||||
import Data.ByteString.Char8 qualified as C8
|
import Data.ByteString.Char8 qualified as C8
|
||||||
import Data.ByteString.Lazy qualified as BL
|
import Data.ByteString.Lazy qualified as BL
|
||||||
@@ -13,9 +16,12 @@ import Effectful
|
|||||||
import Network.HTTP.Types qualified as HTTP
|
import Network.HTTP.Types qualified as HTTP
|
||||||
import Network.Wai qualified as Wai
|
import Network.Wai qualified as Wai
|
||||||
import Network.Wai.Handler.Warp qualified as Warp
|
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.FilePath (takeDirectory)
|
||||||
|
import System.IO.Error (isDoesNotExistError)
|
||||||
|
|
||||||
|
import Sis (UserId (..))
|
||||||
import Sis.Database
|
import Sis.Database
|
||||||
import Sis.Page.Activity
|
import Sis.Page.Activity
|
||||||
import Sis.Page.Chores
|
import Sis.Page.Chores
|
||||||
@@ -24,7 +30,7 @@ import Sis.Page.Household
|
|||||||
import Sis.Page.Login
|
import Sis.Page.Login
|
||||||
import Sis.Page.Signup
|
import Sis.Page.Signup
|
||||||
import Sis.Route
|
import Sis.Route
|
||||||
import Sis.View.Layout (documentHead)
|
import Sis.View.Layout (UserSession (..), documentHead)
|
||||||
import Web.Hyperbole
|
import Web.Hyperbole
|
||||||
import Web.Hyperbole.Application
|
import Web.Hyperbole.Application
|
||||||
import Web.Hyperbole.Effect.Response
|
import Web.Hyperbole.Effect.Response
|
||||||
@@ -43,13 +49,29 @@ mimeType fp
|
|||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
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)
|
createDirectoryIfMissing True (takeDirectory dbPath)
|
||||||
|
|
||||||
putStrLn "[sis] opening database..."
|
putStrLn "[sis] opening database..."
|
||||||
conn <- openDatabase dbPath
|
conn <- openDatabase dbPath
|
||||||
|
|
||||||
let port = 8080
|
|
||||||
putStrLn $ "[sis] listening on 0.0.0.0:" <> show port
|
putStrLn $ "[sis] listening on 0.0.0.0:" <> show port
|
||||||
|
|
||||||
let hyperboleApp =
|
let hyperboleApp =
|
||||||
@@ -88,6 +110,15 @@ router RDashboard = runPage Sis.Page.Dashboard.page
|
|||||||
router RChores = runPage Sis.Page.Chores.page
|
router RChores = runPage Sis.Page.Chores.page
|
||||||
router RHousehold = runPage Sis.Page.Household.page
|
router RHousehold = runPage Sis.Page.Household.page
|
||||||
router RActivity = runPage Sis.Page.Activity.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
|
router RSeed = do
|
||||||
seed
|
seed
|
||||||
redirect (routeUri RDashboard)
|
redirect (routeUri RDashboard)
|
||||||
|
|||||||
+16
-13
@@ -16,42 +16,45 @@ body {
|
|||||||
padding: 0;
|
padding: 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/* Override NB navbar to have drop shadow like our design */
|
||||||
.nb-navbar {
|
.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;
|
box-shadow: 4px 4px 0 #000;
|
||||||
margin-bottom: 2rem;
|
margin-bottom: 2rem;
|
||||||
}
|
}
|
||||||
|
|
||||||
.nb-navbar-start, .nb-navbar-end {
|
/* List items with subtle dividers */
|
||||||
display: flex;
|
|
||||||
align-items: center;
|
|
||||||
gap: 0.5rem;
|
|
||||||
}
|
|
||||||
|
|
||||||
.nb-list-item {
|
.nb-list-item {
|
||||||
border-bottom: 1px solid rgba(0,0,0,0.1);
|
border-bottom: 1px solid rgba(0,0,0,0.1);
|
||||||
|
padding: 0.5rem;
|
||||||
}
|
}
|
||||||
.nb-list-item:last-child {
|
.nb-list-item:last-child {
|
||||||
border-bottom: none;
|
border-bottom: none;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/* Stat tiles */
|
||||||
|
.stat-tile {
|
||||||
|
text-align: center;
|
||||||
|
padding: 1rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Container padding */
|
||||||
|
.nb-container {
|
||||||
|
padding: 0 1rem;
|
||||||
|
}
|
||||||
|
|
||||||
@keyframes fadeIn {
|
@keyframes fadeIn {
|
||||||
from { opacity: 0; }
|
from { opacity: 0; }
|
||||||
to { opacity: 1; }
|
to { opacity: 1; }
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/* Responsive */
|
||||||
@media (max-width: 768px) {
|
@media (max-width: 768px) {
|
||||||
.nb-navbar {
|
.nb-navbar {
|
||||||
flex-direction: column;
|
flex-direction: column;
|
||||||
gap: 0.5rem;
|
gap: 0.5rem;
|
||||||
padding: 0.5rem;
|
padding: 0.5rem;
|
||||||
}
|
}
|
||||||
.nb-navbar-end {
|
.nb-navbar-nav {
|
||||||
flex-wrap: wrap;
|
flex-wrap: wrap;
|
||||||
justify-content: center;
|
justify-content: center;
|
||||||
}
|
}
|
||||||
|
|||||||
Generated
+16
@@ -5,9 +5,25 @@
|
|||||||
"packages": {
|
"packages": {
|
||||||
"": {
|
"": {
|
||||||
"dependencies": {
|
"dependencies": {
|
||||||
|
"@playwright/test": "^1.61.1",
|
||||||
"playwright": "^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": {
|
"node_modules/fsevents": {
|
||||||
"version": "2.3.2",
|
"version": "2.3.2",
|
||||||
"resolved": "https://registry.npmjs.org/fsevents/-/fsevents-2.3.2.tgz",
|
"resolved": "https://registry.npmjs.org/fsevents/-/fsevents-2.3.2.tgz",
|
||||||
|
|||||||
@@ -1,5 +1,6 @@
|
|||||||
{
|
{
|
||||||
"dependencies": {
|
"dependencies": {
|
||||||
|
"@playwright/test": "^1.61.1",
|
||||||
"playwright": "^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 (..),
|
DB (..),
|
||||||
runDB,
|
runDB,
|
||||||
openDatabase,
|
openDatabase,
|
||||||
runMigrations,
|
|
||||||
|
|
||||||
-- * DB operations (convenience wrappers)
|
-- * DB operations (convenience wrappers)
|
||||||
findUserByEmail,
|
findUserByEmail,
|
||||||
createUser,
|
createUser,
|
||||||
getUser,
|
getUser,
|
||||||
|
setUserHousehold,
|
||||||
getUserHouseholds,
|
getUserHouseholds,
|
||||||
getHousehold,
|
getHousehold,
|
||||||
createHousehold,
|
createHousehold,
|
||||||
@@ -64,6 +64,7 @@ data DB :: Effect where
|
|||||||
FindUserByEmail :: Text -> DB m (Maybe User)
|
FindUserByEmail :: Text -> DB m (Maybe User)
|
||||||
CreateUser :: Text -> Text -> Text -> DB m UserId
|
CreateUser :: Text -> Text -> Text -> DB m UserId
|
||||||
GetUser :: UserId -> DB m (Maybe User)
|
GetUser :: UserId -> DB m (Maybe User)
|
||||||
|
SetUserHousehold :: UserId -> HouseholdId -> DB m ()
|
||||||
GetUserHouseholds :: UserId -> DB m [Household]
|
GetUserHouseholds :: UserId -> DB m [Household]
|
||||||
GetHousehold :: UserId -> Int -> DB m (Maybe Household)
|
GetHousehold :: UserId -> Int -> DB m (Maybe Household)
|
||||||
CreateHousehold :: UserId -> Text -> DB m Household
|
CreateHousehold :: UserId -> Text -> DB m Household
|
||||||
@@ -79,7 +80,7 @@ data DB :: Effect where
|
|||||||
CreateInvite :: Int -> Maybe Text -> DB m Invite
|
CreateInvite :: Int -> Maybe Text -> DB m Invite
|
||||||
GetInvites :: Int -> DB m [Invite]
|
GetInvites :: Int -> DB m [Invite]
|
||||||
RevokeInvite :: Int -> DB m ()
|
RevokeInvite :: Int -> DB m ()
|
||||||
AcceptInvite :: UserId -> Text -> DB m Household
|
AcceptInvite :: UserId -> Text -> DB m (Maybe Household)
|
||||||
Seed :: DB m ()
|
Seed :: DB m ()
|
||||||
|
|
||||||
type instance DispatchOf DB = 'Dynamic
|
type instance DispatchOf DB = 'Dynamic
|
||||||
@@ -94,9 +95,9 @@ runDB conn = interpret $ \_ -> \case
|
|||||||
result <-
|
result <-
|
||||||
SQL.query
|
SQL.query
|
||||||
conn
|
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)
|
(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
|
CreateUser dname email pwHash -> liftIO $ do
|
||||||
SQL.execute
|
SQL.execute
|
||||||
conn
|
conn
|
||||||
@@ -108,9 +109,11 @@ runDB conn = interpret $ \_ -> \case
|
|||||||
result <-
|
result <-
|
||||||
SQL.query
|
SQL.query
|
||||||
conn
|
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)
|
(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
|
GetUserHouseholds (UserId uid) -> liftIO $ do
|
||||||
rows <-
|
rows <-
|
||||||
SQL.query
|
SQL.query
|
||||||
@@ -138,6 +141,7 @@ runDB conn = interpret $ \_ -> \case
|
|||||||
conn
|
conn
|
||||||
"INSERT INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)"
|
"INSERT INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)"
|
||||||
(unHouseholdId hid, uid, "owner" :: String)
|
(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
|
pure $ Household hid name (UserId uid) 1
|
||||||
GetMembers hid -> liftIO $ do
|
GetMembers hid -> liftIO $ do
|
||||||
members <-
|
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 = ?"
|
\ FROM households h JOIN memberships m ON m.household_id = h.id AND m.role = 'owner' WHERE h.id = ?"
|
||||||
(Only hid) ::
|
(Only hid) ::
|
||||||
IO [(Int, Text, Int, Int)]
|
IO [(Int, Text, Int, Int)]
|
||||||
case listToMaybe [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- hResult] of
|
pure $ listToMaybe [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- hResult]
|
||||||
Just h -> pure h
|
_ -> pure Nothing
|
||||||
Nothing -> error "Household not found after accept"
|
|
||||||
_ -> error "Invite not found"
|
|
||||||
Seed -> liftIO $ do
|
Seed -> liftIO $ do
|
||||||
let demoPassword = "password123"
|
let demoPassword = "password123"
|
||||||
pwHash <- hashPasswordIO demoPassword
|
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, 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) VALUES (2, 'Bob', 'bob@demo.com', ?)" (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) 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 (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 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, 1, 'owner')"
|
||||||
SQL.execute_ conn "INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (1, 2, 'member')"
|
SQL.execute_ conn "INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (1, 2, 'member')"
|
||||||
@@ -391,12 +393,12 @@ openDatabase path = do
|
|||||||
conn <- SQL.open path
|
conn <- SQL.open path
|
||||||
SQL.execute_ conn "PRAGMA journal_mode=WAL"
|
SQL.execute_ conn "PRAGMA journal_mode=WAL"
|
||||||
SQL.execute_ conn "PRAGMA foreign_keys=ON"
|
SQL.execute_ conn "PRAGMA foreign_keys=ON"
|
||||||
runMigrations conn
|
createTables conn
|
||||||
pure conn
|
pure conn
|
||||||
|
|
||||||
-- | Create all tables if they don't exist.
|
-- | Create all tables if they don't exist.
|
||||||
runMigrations :: SQL.Connection -> IO ()
|
createTables :: SQL.Connection -> IO ()
|
||||||
runMigrations conn' =
|
createTables conn' = do
|
||||||
mapM_
|
mapM_
|
||||||
(SQL.execute_ conn')
|
(SQL.execute_ conn')
|
||||||
[ "CREATE TABLE IF NOT EXISTS users (\
|
[ "CREATE TABLE IF NOT EXISTS users (\
|
||||||
@@ -404,6 +406,7 @@ runMigrations conn' =
|
|||||||
\ display_name TEXT NOT NULL,\
|
\ display_name TEXT NOT NULL,\
|
||||||
\ email TEXT NOT NULL UNIQUE,\
|
\ email TEXT NOT NULL UNIQUE,\
|
||||||
\ password_hash TEXT NOT NULL,\
|
\ password_hash TEXT NOT NULL,\
|
||||||
|
\ household_id INTEGER REFERENCES households(id),\
|
||||||
\ created_at TEXT NOT NULL DEFAULT (datetime('now')))"
|
\ created_at TEXT NOT NULL DEFAULT (datetime('now')))"
|
||||||
, "CREATE TABLE IF NOT EXISTS sessions (\
|
, "CREATE TABLE IF NOT EXISTS sessions (\
|
||||||
\ id INTEGER PRIMARY KEY AUTOINCREMENT,\
|
\ 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 :: (DB :> es) => UserId -> Eff es (Maybe User)
|
||||||
getUser = send . GetUser
|
getUser = send . GetUser
|
||||||
|
|
||||||
|
setUserHousehold :: (DB :> es) => UserId -> HouseholdId -> Eff es ()
|
||||||
|
setUserHousehold u = send . SetUserHousehold u
|
||||||
|
|
||||||
getUserHouseholds :: (DB :> es) => UserId -> Eff es [Household]
|
getUserHouseholds :: (DB :> es) => UserId -> Eff es [Household]
|
||||||
getUserHouseholds = send . GetUserHouseholds
|
getUserHouseholds = send . GetUserHouseholds
|
||||||
|
|
||||||
@@ -516,7 +522,7 @@ getInvites = send . GetInvites
|
|||||||
revokeInvite :: (DB :> es) => Int -> Eff es ()
|
revokeInvite :: (DB :> es) => Int -> Eff es ()
|
||||||
revokeInvite = send . RevokeInvite
|
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
|
acceptInvite u = send . AcceptInvite u
|
||||||
|
|
||||||
seed :: (DB :> es) => Eff es ()
|
seed :: (DB :> es) => Eff es ()
|
||||||
|
|||||||
@@ -17,7 +17,7 @@ import Effectful
|
|||||||
|
|
||||||
import Sis.Database
|
import Sis.Database
|
||||||
import Sis.Route
|
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.Types
|
||||||
import Sis.View.Layout
|
import Sis.View.Layout
|
||||||
import Web.Hyperbole
|
import Web.Hyperbole
|
||||||
@@ -44,15 +44,15 @@ instance (DB :> es, IOE :> es) => HyperView ActivityPage es where
|
|||||||
Just us -> do
|
Just us -> do
|
||||||
hhs <- getUserHouseholds (UserId (usUserId us))
|
hhs <- getUserHouseholds (UserId (usUserId us))
|
||||||
case hhs of
|
case hhs of
|
||||||
[] -> pure $ hyper ActivityPage $ el "No households"
|
[] -> pure $ hyper ActivityPage $ pageLayout us $ el "No households"
|
||||||
(h : _) -> do
|
(h : _) -> do
|
||||||
log <- getActivityLog (unHouseholdId (householdId h)) pageNum 20
|
log <- getActivityLog (unHouseholdId (householdId h)) pageNum 20
|
||||||
pure $ hyper ActivityPage $ activityView log
|
pure $ hyper ActivityPage $ pageLayout us $ activityView log
|
||||||
|
|
||||||
activityView :: ActivityLogPage -> View ActivityPage ()
|
activityView :: ActivityLogPage -> View ActivityPage ()
|
||||||
activityView log = do
|
activityView log = do
|
||||||
el @ att "class" nbContainerClass @ att "style" "max-width:960px;margin:0 auto" $ 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)
|
if null (alpEntries log)
|
||||||
then el @ att "style" "opacity:0.5" $ text "No activity recorded yet."
|
then el @ att "style" "opacity:0.5" $ text "No activity recorded yet."
|
||||||
else el @ att "class" nbBoxClass $ mapM_ entryRow (alpEntries log)
|
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
|
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
|
let totalPages = (alpTotal log + alpPerPage log - 1) `div` alpPerPage log
|
||||||
if alpPage log > 1
|
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
|
else none
|
||||||
el @ att "style" "align-self:center" $
|
el @ att "style" "align-self:center" $
|
||||||
text ("Page " <> T.pack (show (alpPage log)) <> " of " <> T.pack (show totalPages))
|
text ("Page " <> T.pack (show (alpPage log)) <> " of " <> T.pack (show totalPages))
|
||||||
if alpPage log < 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
|
||||||
else none
|
else none
|
||||||
|
|
||||||
@@ -101,7 +101,7 @@ page = do
|
|||||||
Just us -> do
|
Just us -> do
|
||||||
hhs <- getUserHouseholds (UserId (usUserId us))
|
hhs <- getUserHouseholds (UserId (usUserId us))
|
||||||
case hhs of
|
case hhs of
|
||||||
[] -> pure $ hyper ActivityPage $ el "No households"
|
[] -> pure $ hyper ActivityPage $ pageLayout us $ el "No households"
|
||||||
(h : _) -> do
|
(h : _) -> do
|
||||||
log <- getActivityLog (unHouseholdId (householdId h)) 1 20
|
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 TypeApplications #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# 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
|
module Sis.Page.Chores (page) where
|
||||||
|
|
||||||
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text qualified as T
|
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 Effectful
|
||||||
|
|
||||||
import Sis.Database
|
import Sis.Database
|
||||||
import Sis.Route
|
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.Types
|
||||||
import Sis.View.Layout
|
import Sis.View.Layout
|
||||||
|
import Text.Read (readMaybe)
|
||||||
import Web.Hyperbole
|
import Web.Hyperbole
|
||||||
import Web.Hyperbole.Effect.Session
|
import Web.Hyperbole.Effect.Session
|
||||||
|
import Web.Hyperbole.HyperView.Forms
|
||||||
import Web.Hyperbole.Page
|
import Web.Hyperbole.Page
|
||||||
|
|
||||||
data ChoresPage = ChoresPage
|
data ChoresPage = ChoresPage
|
||||||
@@ -34,6 +39,7 @@ instance (DB :> es, IOE :> es) => HyperView ChoresPage es where
|
|||||||
= CRefreshChores
|
= CRefreshChores
|
||||||
| CDeleteChore ChoreId
|
| CDeleteChore ChoreId
|
||||||
| CNewChore
|
| CNewChore
|
||||||
|
| CCreateChore
|
||||||
deriving stock (Generic)
|
deriving stock (Generic)
|
||||||
deriving anyclass (ViewAction)
|
deriving anyclass (ViewAction)
|
||||||
|
|
||||||
@@ -44,27 +50,90 @@ instance (DB :> es, IOE :> es) => HyperView ChoresPage es where
|
|||||||
Just us -> do
|
Just us -> do
|
||||||
hhs <- getUserHouseholds (UserId (usUserId us))
|
hhs <- getUserHouseholds (UserId (usUserId us))
|
||||||
case hhs of
|
case hhs of
|
||||||
[] -> pure $ hyper ChoresPage $ el "No households"
|
[] -> pure $ hyper ChoresPage $ pageLayout us $ el "No households"
|
||||||
(h : _) -> do
|
(h : _) -> do
|
||||||
chores' <- getChores (unHouseholdId (householdId h))
|
chores' <- getChores (unHouseholdId (householdId h))
|
||||||
pure $ hyper ChoresPage $ choresView chores'
|
pure $ hyper ChoresPage $ pageLayout us $ choresView chores'
|
||||||
update (CDeleteChore cid) = do
|
update (CDeleteChore cid) = do
|
||||||
deleteChore (unChoreId cid)
|
deleteChore (unChoreId cid)
|
||||||
update CRefreshChores
|
update CRefreshChores
|
||||||
update CNewChore = do
|
update CNewChore = do
|
||||||
-- TODO: show chore creation form
|
mUser <- lookupSession @UserSession
|
||||||
pure (el "New chore form coming soon")
|
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 :: [Chore] -> View ChoresPage ()
|
||||||
choresView chores' = do
|
choresView chores' = do
|
||||||
el @ att "class" nbContainerClass @ att "style" "max-width:960px;margin:0 auto" $ 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 "style" "display:flex;justify-content:space-between;align-items:center;margin-bottom:1rem" $ do
|
||||||
el @ att "class" nbFontHeading1Class $ text "Chores"
|
el @ att "class" nbHeadingClass $ text "Chores"
|
||||||
button CNewChore @ att "class" nbButtonClass $ text "+ New Chore"
|
button CNewChore @ att "class" nbButtonDefaultClass $ text "+ New Chore"
|
||||||
if null chores'
|
if null chores'
|
||||||
then el @ att "style" "opacity:0.5" $ text "No chores yet. Create one to get started!"
|
then el @ att "style" "opacity:0.5" $ text "No chores yet. Create one to get started!"
|
||||||
else el @ att "class" nbBoxClass $ mapM_ choreRow chores'
|
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 :: Chore -> View ChoresPage ()
|
||||||
choreRow c = do
|
choreRow c = do
|
||||||
el @ att "class" nbListItemClass @ att "style" "display:flex;justify-content:space-between;align-items:center;padding:0.5rem" $ 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" "font-weight:500" $ text (choreName c)
|
||||||
el @ att "style" "opacity:0.5;font-size:0.85rem" $ text (scheduleLabel (choreSchedule c))
|
el @ att "style" "opacity:0.5;font-size:0.85rem" $ text (scheduleLabel (choreSchedule c))
|
||||||
el @ att "style" "display:flex;gap:0.25rem" $ do
|
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 CNewChore @ att "class" nbButtonDefaultClass @ 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 (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 :: Schedule -> Text
|
||||||
scheduleBadge ScheduleSometime{} = "sometime"
|
scheduleBadge ScheduleSometime{} = "sometime"
|
||||||
@@ -86,9 +159,30 @@ scheduleLabel ScheduleSometime = "Sometime"
|
|||||||
scheduleLabel (ScheduleOneOff d _) = "One-off on " <> T.pack (show d)
|
scheduleLabel (ScheduleOneOff d _) = "One-off on " <> T.pack (show d)
|
||||||
scheduleLabel (ScheduleRecurring p _ mt _ _) =
|
scheduleLabel (ScheduleRecurring p _ mt _ _) =
|
||||||
let pText = case p of PeriodDaily -> "daily"; PeriodWeekly -> "weekly"; PeriodMonthly -> "monthly"
|
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
|
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 :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[ChoresPage]
|
||||||
page = do
|
page = do
|
||||||
mSession <- lookupSession @UserSession
|
mSession <- lookupSession @UserSession
|
||||||
@@ -98,7 +192,7 @@ page = do
|
|||||||
Just us -> do
|
Just us -> do
|
||||||
hhs <- getUserHouseholds (UserId (usUserId us))
|
hhs <- getUserHouseholds (UserId (usUserId us))
|
||||||
case hhs of
|
case hhs of
|
||||||
[] -> pure $ hyper ChoresPage $ el "No households"
|
[] -> pure $ hyper ChoresPage $ pageLayout us $ el "No households"
|
||||||
(h : _) -> do
|
(h : _) -> do
|
||||||
chores' <- getChores (unHouseholdId (householdId h))
|
chores' <- getChores (unHouseholdId (householdId h))
|
||||||
pure $ hyper ChoresPage $ choresView chores'
|
pure $ hyper ChoresPage $ pageLayout us $ choresView chores'
|
||||||
|
|||||||
+17
-13
@@ -19,7 +19,7 @@ import Effectful
|
|||||||
|
|
||||||
import Sis.Database
|
import Sis.Database
|
||||||
import Sis.Route
|
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.Types
|
||||||
import Sis.View.Layout
|
import Sis.View.Layout
|
||||||
import Web.Hyperbole
|
import Web.Hyperbole
|
||||||
@@ -45,38 +45,42 @@ instance (DB :> es, IOE :> es) => HyperView DashboardPage es where
|
|||||||
today <- liftIO (utctDay <$> getCurrentTime)
|
today <- liftIO (utctDay <$> getCurrentTime)
|
||||||
hhs <- getUserHouseholds (UserId (usUserId us))
|
hhs <- getUserHouseholds (UserId (usUserId us))
|
||||||
case hhs of
|
case hhs of
|
||||||
[] -> pure $ hyper DashboardPage $ el "No households"
|
[] -> pure $ hyper DashboardPage $ pageLayout us $ el "No households"
|
||||||
(h : _) -> do
|
(h : _) -> do
|
||||||
dash <- getDashboard (unHouseholdId (householdId h)) today
|
dash <- getDashboard (unHouseholdId (householdId h)) today
|
||||||
pure $ hyper DashboardPage $ dashboardView dash
|
pure $ hyper DashboardPage $ pageLayout us $ dashboardView dash
|
||||||
update (CheckOff _oid) = do
|
update (CheckOff oid) = do
|
||||||
-- TODO: wire up to activity form
|
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
|
update RefreshDashboard
|
||||||
|
|
||||||
dashboardView :: Dashboard -> View DashboardPage ()
|
dashboardView :: Dashboard -> View DashboardPage ()
|
||||||
dashboardView dash = do
|
dashboardView dash = do
|
||||||
el @ att "class" nbContainerClass @ att "style" "max-width:960px;margin:0 auto" $ 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
|
el @ att "style" "display:flex;gap:1rem;margin-bottom:1.5rem" $ do
|
||||||
let stats = dashStats dash
|
let stats = dashStats dash
|
||||||
statTile "Overdue" (T.pack (show (dsOverdue stats))) colorRed
|
statTile "Overdue" (T.pack (show (dsOverdue stats))) colorRed
|
||||||
statTile "Due Today" (T.pack (show (dsDueToday stats))) colorYellow
|
statTile "Due Today" (T.pack (show (dsDueToday stats))) colorYellow
|
||||||
statTile "Done This Week" (T.pack (show (dsDoneThisWeek stats))) colorGreen
|
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)
|
if null (dashDueItems dash)
|
||||||
then el @ att "style" "opacity:0.5" $ text "Nothing due! Great job."
|
then el @ att "style" "opacity:0.5" $ text "Nothing due! Great job."
|
||||||
else el @ att "class" nbBoxClass $ do
|
else el @ att "class" nbBoxClass $ do
|
||||||
mapM_ dueItemRow (dashDueItems dash)
|
mapM_ dueItemRow (dashDueItems dash)
|
||||||
el @ att "class" nbFontHeading2Class $ text "Completed Today"
|
el @ att "class" nbHeadingClass $ text "Completed Today"
|
||||||
if null (dashCompletedItems dash)
|
if null (dashCompletedItems dash)
|
||||||
then el @ att "style" "opacity:0.5" $ text "No activity recorded today."
|
then el @ att "style" "opacity:0.5" $ text "No activity recorded today."
|
||||||
else el @ att "class" nbBoxClass $ mapM_ completedItemRow (dashCompletedItems dash)
|
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 :: Text -> Text -> Text -> View ctx ()
|
||||||
statTile label count color = do
|
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" 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
|
text label
|
||||||
|
|
||||||
dueItemRow :: DueItem -> View DashboardPage ()
|
dueItemRow :: DueItem -> View DashboardPage ()
|
||||||
@@ -90,7 +94,7 @@ dueItemRow di = do
|
|||||||
case diAssigneeName di of
|
case diAssigneeName di of
|
||||||
Just name -> el @ att "style" "opacity:0.5" $ text ("(" <> name <> ")")
|
Just name -> el @ att "style" "opacity:0.5" $ text ("(" <> name <> ")")
|
||||||
Nothing -> none
|
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 :: CompletedItem -> View DashboardPage ()
|
||||||
completedItemRow ci = do
|
completedItemRow ci = do
|
||||||
@@ -115,7 +119,7 @@ page = do
|
|||||||
today <- liftIO (utctDay <$> getCurrentTime)
|
today <- liftIO (utctDay <$> getCurrentTime)
|
||||||
hhs <- getUserHouseholds (UserId (usUserId us))
|
hhs <- getUserHouseholds (UserId (usUserId us))
|
||||||
case hhs of
|
case hhs of
|
||||||
[] -> pure $ hyper DashboardPage $ el "No households"
|
[] -> pure $ hyper DashboardPage $ pageLayout us $ el "No households"
|
||||||
(h : _) -> do
|
(h : _) -> do
|
||||||
dash <- getDashboard (unHouseholdId (householdId h)) today
|
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.Database
|
||||||
import Sis.Route
|
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.Types
|
||||||
import Sis.View.Layout
|
import Sis.View.Layout
|
||||||
import Web.Hyperbole
|
import Web.Hyperbole
|
||||||
import Web.Hyperbole.Effect.Session
|
import Web.Hyperbole.Effect.Session
|
||||||
|
import Web.Hyperbole.HyperView.Forms
|
||||||
import Web.Hyperbole.Page
|
import Web.Hyperbole.Page
|
||||||
|
|
||||||
data HouseholdPage = HouseholdPage
|
data HouseholdPage = HouseholdPage
|
||||||
@@ -33,6 +34,7 @@ instance (DB :> es, IOE :> es) => HyperView HouseholdPage es where
|
|||||||
= RefreshHousehold
|
= RefreshHousehold
|
||||||
| CreateInviteAction
|
| CreateInviteAction
|
||||||
| RevokeInviteAction InviteId
|
| RevokeInviteAction InviteId
|
||||||
|
| CreateHouseholdAction
|
||||||
deriving stock (Generic)
|
deriving stock (Generic)
|
||||||
deriving anyclass (ViewAction)
|
deriving anyclass (ViewAction)
|
||||||
|
|
||||||
@@ -43,12 +45,24 @@ instance (DB :> es, IOE :> es) => HyperView HouseholdPage es where
|
|||||||
Just us -> do
|
Just us -> do
|
||||||
hhs <- getUserHouseholds (UserId (usUserId us))
|
hhs <- getUserHouseholds (UserId (usUserId us))
|
||||||
case hhs of
|
case hhs of
|
||||||
[] -> pure (noHouseholdView)
|
[] -> pure $ hyper HouseholdPage $ pageLayout us noHouseholdView
|
||||||
(h : _) -> do
|
(h : _) -> do
|
||||||
let hid = unHouseholdId (householdId h)
|
let hid = unHouseholdId (householdId h)
|
||||||
mems <- getMembers hid
|
mems <- getMembers hid
|
||||||
invs <- getInvites 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
|
update CreateInviteAction = do
|
||||||
mUser <- lookupSession @UserSession
|
mUser <- lookupSession @UserSession
|
||||||
case mUser of
|
case mUser of
|
||||||
@@ -68,27 +82,29 @@ instance (DB :> es, IOE :> es) => HyperView HouseholdPage es where
|
|||||||
noHouseholdView :: View HouseholdPage ()
|
noHouseholdView :: View HouseholdPage ()
|
||||||
noHouseholdView = do
|
noHouseholdView = do
|
||||||
el @ att "class" nbContainerClass @ att "style" "max-width:480px;margin:4rem auto" $ 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" nbBoxClass @ att "style" "padding:2rem" $ do
|
||||||
el @ att "class" nbFontHeading1Class $ text "Create Your Household"
|
el @ att "class" nbHeadingClass $ text "Create Your Household"
|
||||||
el @ att "style" "margin-bottom:1rem" $ text "You need a household to get started."
|
el @ att "style" "opacity:0.7;margin-bottom:1.5rem" $ text "You need a household to get started."
|
||||||
-- Form for household creation would go here
|
form CreateHouseholdAction $ do
|
||||||
el $ text "Household creation form coming soon"
|
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 :: Household -> [Membership] -> [Invite] -> View HouseholdPage ()
|
||||||
householdView h mems invs = do
|
householdView h mems invs = do
|
||||||
el @ att "class" nbContainerClass @ att "style" "max-width:960px;margin:0 auto" $ 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 "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" 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 "class" nbBoxClass $ do
|
||||||
el @ att "style" "margin-bottom:0.5rem" $ text "Create an invite link to share:"
|
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
|
if null invs
|
||||||
then none
|
then none
|
||||||
else el @ att "style" "margin-top:1rem" $ do
|
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)
|
mapM_ inviteRow (filter ((== InvitePending) . inviteStatus) invs)
|
||||||
|
|
||||||
memberRow :: Membership -> View HouseholdPage ()
|
memberRow :: Membership -> View HouseholdPage ()
|
||||||
@@ -105,8 +121,9 @@ memberRow m = do
|
|||||||
inviteRow :: Invite -> View HouseholdPage ()
|
inviteRow :: Invite -> View HouseholdPage ()
|
||||||
inviteRow i = do
|
inviteRow i = do
|
||||||
el @ att "class" nbListItemClass @ att "style" "display:flex;justify-content:space-between;padding:0.5rem" $ 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)
|
route (RInvite (InviteCode (inviteCode i))) @ att "class" nbButtonDefaultClass @ att "style" "font-size:0.85rem;text-decoration:none" $
|
||||||
button (RevokeInviteAction (inviteId i)) @ att "class" nbButtonClass @ att "style" "font-size:0.8rem;background:var(--nb-red)" $
|
text (inviteCode i)
|
||||||
|
button (RevokeInviteAction (inviteId i)) @ att "class" nbButtonDefaultClass @ att "style" "font-size:0.8rem;background:var(--nb-red)" $
|
||||||
text "Revoke"
|
text "Revoke"
|
||||||
|
|
||||||
initials :: Text -> Text
|
initials :: Text -> Text
|
||||||
@@ -123,9 +140,9 @@ page = do
|
|||||||
Just us -> do
|
Just us -> do
|
||||||
hhs <- getUserHouseholds (UserId (usUserId us))
|
hhs <- getUserHouseholds (UserId (usUserId us))
|
||||||
case hhs of
|
case hhs of
|
||||||
[] -> pure $ hyper HouseholdPage $ noHouseholdView
|
[] -> pure $ hyper HouseholdPage $ pageLayout us noHouseholdView
|
||||||
(h : _) -> do
|
(h : _) -> do
|
||||||
let hid = unHouseholdId (householdId h)
|
let hid = unHouseholdId (householdId h)
|
||||||
mems <- getMembers hid
|
mems <- getMembers hid
|
||||||
invs <- getInvites 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.Auth (generateToken, hashPassword, verifyPassword)
|
||||||
import Sis.Database
|
import Sis.Database
|
||||||
import Sis.Route
|
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.Types
|
||||||
import Sis.View.Layout
|
import Sis.View.Layout
|
||||||
import Web.Hyperbole
|
import Web.Hyperbole
|
||||||
@@ -40,8 +40,8 @@ instance (DB :> es, IOE :> es) => HyperView LoginPage es where
|
|||||||
case mUser of
|
case mUser of
|
||||||
Just u
|
Just u
|
||||||
| verifyPassword (lfPassword formData') (userPasswordHash u) -> do
|
| verifyPassword (lfPassword formData') (userPasswordHash u) -> do
|
||||||
saveSession (UserSession (unUserId (userId u)))
|
saveSession (UserSession (unUserId (userId u)) (userDisplayName u))
|
||||||
pure (loginSuccessView)
|
pure loginSuccessView
|
||||||
_ -> pure (loginView (Just "Invalid email or password"))
|
_ -> pure (loginView (Just "Invalid email or password"))
|
||||||
update Noop = pure (loginView Nothing)
|
update Noop = pure (loginView Nothing)
|
||||||
|
|
||||||
@@ -49,15 +49,15 @@ loginSuccessView :: View LoginPage ()
|
|||||||
loginSuccessView = do
|
loginSuccessView = do
|
||||||
el @ att "class" nbContainerClass @ att "style" "max-width:480px;margin:4rem auto;text-align:center" $ 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" 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."
|
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 :: Maybe Text -> View LoginPage ()
|
||||||
loginView mError = do
|
loginView mError = do
|
||||||
el @ att "class" nbContainerClass @ att "style" "max-width:480px;margin:4rem auto" $ 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" 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."
|
el @ att "style" "opacity:0.7;margin-bottom:1.5rem" $ text "Log in to manage your household chores."
|
||||||
case mError of
|
case mError of
|
||||||
Just err ->
|
Just err ->
|
||||||
@@ -69,10 +69,11 @@ loginView mError = do
|
|||||||
el @ att "class" nbLabelClass $ text "Password"
|
el @ att "class" nbLabelClass $ text "Password"
|
||||||
tag "input" @ att "type" "password" . att "name" "lfPassword" . att "class" nbInputClass @ att "style" "width:100%" $ none
|
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
|
el @ att "style" "display:flex;align-items:center;gap:0.5rem;margin-bottom:1rem" $ do
|
||||||
tag "input" @ att "type" "checkbox" . att "name" "lfRemember" $ none
|
tag "input" @ att "type" "checkbox" . att "name" "lfRemember" . att "class" "nb-checkbox" $ none
|
||||||
text "Remember me"
|
el @ att "class" nbLabelClass $ text "Remember me"
|
||||||
submit (text "Log In") @ att "class" nbButtonClass @ att "style" "width:100%"
|
submit (text "Log In") @ att "class" nbButtonDefaultClass @ att "style" "width:100%"
|
||||||
route RSignup $ text "Don't have an account? Sign Up"
|
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 :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[LoginPage]
|
||||||
page = do
|
page = do
|
||||||
mSession <- lookupSession @UserSession
|
mSession <- lookupSession @UserSession
|
||||||
|
|||||||
+10
-10
@@ -18,7 +18,7 @@ import Effectful
|
|||||||
import Sis.Auth (generateToken, hashPassword, verifyPassword)
|
import Sis.Auth (generateToken, hashPassword, verifyPassword)
|
||||||
import Sis.Database
|
import Sis.Database
|
||||||
import Sis.Route
|
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.Types
|
||||||
import Sis.View.Layout
|
import Sis.View.Layout
|
||||||
import Web.Hyperbole
|
import Web.Hyperbole
|
||||||
@@ -48,22 +48,22 @@ instance (DB :> es, IOE :> es) => HyperView SignupPage es where
|
|||||||
Nothing -> do
|
Nothing -> do
|
||||||
pwHash <- liftIO (hashPassword (sfPassword form))
|
pwHash <- liftIO (hashPassword (sfPassword form))
|
||||||
uid <- createUser (sfDisplayName form) (sfEmail form) pwHash
|
uid <- createUser (sfDisplayName form) (sfEmail form) pwHash
|
||||||
saveSession (UserSession (unUserId uid))
|
saveSession (UserSession (unUserId uid) (sfDisplayName form))
|
||||||
pure (signupSuccessView)
|
pure signupSuccessView
|
||||||
|
|
||||||
signupSuccessView :: View SignupPage ()
|
signupSuccessView :: View SignupPage ()
|
||||||
signupSuccessView = do
|
signupSuccessView = do
|
||||||
el @ att "class" nbContainerClass @ att "style" "max-width:480px;margin:4rem auto;text-align:center" $ 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" 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."
|
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 :: Maybe Text -> View SignupPage ()
|
||||||
signupView mError = do
|
signupView mError = do
|
||||||
el @ att "class" nbContainerClass @ att "style" "max-width:480px;margin:4rem auto" $ 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" 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."
|
el @ att "style" "opacity:0.7;margin-bottom:1.5rem" $ text "Join your household chore tracker."
|
||||||
case mError of
|
case mError of
|
||||||
Just err ->
|
Just err ->
|
||||||
@@ -79,10 +79,10 @@ signupView mError = do
|
|||||||
el @ att "class" nbLabelClass $ text "Confirm Password"
|
el @ att "class" nbLabelClass $ text "Confirm Password"
|
||||||
tag "input" @ att "type" "password" . att "name" "sfConfirm" . att "class" nbInputClass @ att "style" "width:100%" $ none
|
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
|
el @ att "style" "display:flex;align-items:center;gap:0.5rem;margin-bottom:1rem" $ do
|
||||||
tag "input" @ att "type" "checkbox" . att "name" "sfAgree" $ none
|
tag "input" @ att "type" "checkbox" . att "name" "sfAgree" . att "class" "nb-checkbox" $ none
|
||||||
text "I agree to the terms of service"
|
el @ att "class" nbLabelClass $ text "I agree to the terms of service"
|
||||||
submit (text "Sign Up") @ att "class" nbButtonClass @ att "style" "width:100%"
|
submit (text "Sign Up") @ att "class" nbButtonDefaultClass @ att "style" "width:100%"
|
||||||
route RLogin $ text "Already have an account? Log In"
|
route RLogin @ att "class" nbButtonDefaultClass $ text "Log In"
|
||||||
page :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[SignupPage]
|
page :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[SignupPage]
|
||||||
page = do
|
page = do
|
||||||
mSession <- lookupSession @UserSession
|
mSession <- lookupSession @UserSession
|
||||||
|
|||||||
+20
-2
@@ -1,11 +1,28 @@
|
|||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module Sis.Route (AppRoute (..)) where
|
module Sis.Route (AppRoute (..), InviteCode (..)) where
|
||||||
|
|
||||||
|
import Data.Text (Text)
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Web.Hyperbole.Route
|
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
|
data AppRoute
|
||||||
= Home
|
= Home
|
||||||
| RLogin
|
| RLogin
|
||||||
@@ -14,6 +31,7 @@ data AppRoute
|
|||||||
| RChores
|
| RChores
|
||||||
| RHousehold
|
| RHousehold
|
||||||
| RActivity
|
| RActivity
|
||||||
|
| RInvite InviteCode
|
||||||
| RSeed
|
| RSeed
|
||||||
deriving stock (Eq, Generic, Show)
|
deriving stock (Eq, Generic, Show)
|
||||||
|
|
||||||
|
|||||||
+28
-12
@@ -1,17 +1,17 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
{- | Neo Brutalism CSS class name constants for Hyperbole views.
|
{- | Neo Brutalism CSS class name constants for Hyperbole views.
|
||||||
Use with: \@ att \"class\" nbBoxClass
|
Based on https://github.com/matifandy8/NeoBrutalismCSS
|
||||||
-}
|
-}
|
||||||
module Sis.Style (
|
module Sis.Style (
|
||||||
nbBoxClass,
|
nbBoxClass,
|
||||||
nbButtonClass,
|
nbButtonDefaultClass,
|
||||||
nbInputClass,
|
nbInputClass,
|
||||||
nbLabelClass,
|
nbLabelClass,
|
||||||
nbBadgeClass,
|
nbBadgeClass,
|
||||||
nbFontHeading1Class,
|
nbHeadingClass,
|
||||||
nbFontHeading2Class,
|
|
||||||
nbNavbarClass,
|
nbNavbarClass,
|
||||||
|
nbNavbarLinkClass,
|
||||||
nbContainerClass,
|
nbContainerClass,
|
||||||
nbListItemClass,
|
nbListItemClass,
|
||||||
colorRed,
|
colorRed,
|
||||||
@@ -21,22 +21,38 @@ module Sis.Style (
|
|||||||
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
|
||||||
nbBoxClass, nbButtonClass, nbInputClass, nbLabelClass, nbBadgeClass :: Text
|
-- Box/panel
|
||||||
nbBoxClass = "nb-box"
|
nbBoxClass :: Text
|
||||||
nbButtonClass = "nb-button"
|
nbBoxClass = "nb-card"
|
||||||
|
|
||||||
|
-- Button (default variant: black border, white bg)
|
||||||
|
nbButtonDefaultClass :: Text
|
||||||
|
nbButtonDefaultClass = "nb-button default"
|
||||||
|
|
||||||
|
-- Form elements
|
||||||
|
nbInputClass, nbLabelClass :: Text
|
||||||
nbInputClass = "nb-input"
|
nbInputClass = "nb-input"
|
||||||
nbLabelClass = "nb-label"
|
nbLabelClass = "nb-label"
|
||||||
nbBadgeClass = "nb-badge"
|
|
||||||
|
|
||||||
nbFontHeading1Class, nbFontHeading2Class :: Text
|
-- Badge/pill (inline label)
|
||||||
nbFontHeading1Class = "nb-font-heading1"
|
nbBadgeClass :: Text
|
||||||
nbFontHeading2Class = "nb-font-heading2"
|
nbBadgeClass = "nb-button default"
|
||||||
|
|
||||||
nbNavbarClass, nbContainerClass, nbListItemClass :: Text
|
-- Heading
|
||||||
|
nbHeadingClass :: Text
|
||||||
|
nbHeadingClass = "nb-card-title"
|
||||||
|
|
||||||
|
-- Navbar
|
||||||
|
nbNavbarClass, nbNavbarLinkClass :: Text
|
||||||
nbNavbarClass = "nb-navbar"
|
nbNavbarClass = "nb-navbar"
|
||||||
|
nbNavbarLinkClass = "nb-navbar-link"
|
||||||
|
|
||||||
|
-- Layout
|
||||||
|
nbContainerClass, nbListItemClass :: Text
|
||||||
nbContainerClass = "nb-container"
|
nbContainerClass = "nb-container"
|
||||||
nbListItemClass = "nb-list-item"
|
nbListItemClass = "nb-list-item"
|
||||||
|
|
||||||
|
-- CSS color variables
|
||||||
colorRed, colorYellow, colorGreen :: Text
|
colorRed, colorYellow, colorGreen :: Text
|
||||||
colorRed = "var(--nb-red)"
|
colorRed = "var(--nb-red)"
|
||||||
colorYellow = "var(--nb-yellow)"
|
colorYellow = "var(--nb-yellow)"
|
||||||
|
|||||||
+5
-3
@@ -78,7 +78,7 @@ newtype ChoreId = ChoreId {unChoreId :: Int}
|
|||||||
newtype OccurrenceId = OccurrenceId {unOccurrenceId :: Int}
|
newtype OccurrenceId = OccurrenceId {unOccurrenceId :: Int}
|
||||||
deriving newtype (Show, Eq, Read, ToJSON, FromJSON)
|
deriving newtype (Show, Eq, Read, ToJSON, FromJSON)
|
||||||
|
|
||||||
newtype ActivityId = ActivityId {unActivityId :: Int}
|
newtype ActivityId = ActivityId Int
|
||||||
deriving newtype (Show, Eq, Read, ToJSON, FromJSON)
|
deriving newtype (Show, Eq, Read, ToJSON, FromJSON)
|
||||||
|
|
||||||
newtype InviteId = InviteId {unInviteId :: Int}
|
newtype InviteId = InviteId {unInviteId :: Int}
|
||||||
@@ -93,6 +93,7 @@ data User = User
|
|||||||
, userDisplayName :: Text
|
, userDisplayName :: Text
|
||||||
, userEmail :: Text
|
, userEmail :: Text
|
||||||
, userPasswordHash :: Text
|
, userPasswordHash :: Text
|
||||||
|
, userHouseholdId :: Maybe HouseholdId
|
||||||
}
|
}
|
||||||
deriving stock (Show, Eq)
|
deriving stock (Show, Eq)
|
||||||
|
|
||||||
@@ -292,7 +293,8 @@ data ActivityFormData = ActivityFormData
|
|||||||
}
|
}
|
||||||
deriving (Show, Eq, Generic, FromForm)
|
deriving (Show, Eq, Generic, FromForm)
|
||||||
|
|
||||||
data HouseholdFormData = HouseholdFormData
|
newtype HouseholdFormData = HouseholdFormData
|
||||||
{ hfdName :: Text
|
{ 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 (
|
module Sis.View.Layout (
|
||||||
documentHead,
|
documentHead,
|
||||||
navbar,
|
navbar,
|
||||||
|
pageLayout,
|
||||||
UserSession (..),
|
UserSession (..),
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Default
|
import Data.Default
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import Data.Text qualified as T
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
|
|
||||||
import Sis.Route
|
import Sis.Route
|
||||||
import Sis.Style
|
import Sis.Style (nbButtonDefaultClass, nbHeadingClass, nbNavbarClass, nbNavbarLinkClass)
|
||||||
import Web.Hyperbole
|
import Web.Hyperbole
|
||||||
|
import Web.Hyperbole.Data.URI (uriToText)
|
||||||
import Web.Hyperbole.Effect.Session
|
import Web.Hyperbole.Effect.Session
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
@@ -25,15 +28,17 @@ import Web.Hyperbole.Effect.Session
|
|||||||
|
|
||||||
data UserSession = UserSession
|
data UserSession = UserSession
|
||||||
{ usUserId :: Int
|
{ usUserId :: Int
|
||||||
|
, usDisplayName :: Text
|
||||||
}
|
}
|
||||||
deriving stock (Show, Eq, Generic)
|
deriving stock (Show, Eq, Generic)
|
||||||
deriving anyclass (FromJSON, ToJSON)
|
deriving anyclass (FromJSON, ToJSON)
|
||||||
|
|
||||||
instance Session UserSession where
|
instance Session UserSession where
|
||||||
cookiePath = Just "/"
|
cookiePath = Just "/"
|
||||||
|
cookieSecure = False
|
||||||
|
|
||||||
instance Default UserSession where
|
instance Default UserSession where
|
||||||
def = UserSession 0
|
def = UserSession 0 ""
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
-- Document Head
|
-- Document Head
|
||||||
@@ -44,8 +49,12 @@ documentHead = do
|
|||||||
title "Sis — Household Chore Tracker"
|
title "Sis — Household Chore Tracker"
|
||||||
mobileFriendly
|
mobileFriendly
|
||||||
meta @ att "charset" "UTF-8"
|
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"
|
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
|
tag "link" @ att "rel" "manifest" . att "href" "/static/manifest.json" $ none
|
||||||
script' scriptEmbed
|
script' scriptEmbed
|
||||||
|
|
||||||
@@ -53,18 +62,31 @@ documentHead = do
|
|||||||
-- Navbar
|
-- Navbar
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
navbar :: View ctx ()
|
navbar :: UserSession -> View ctx ()
|
||||||
navbar = do
|
navbar us = do
|
||||||
el @ att "class" nbNavbarClass $ do
|
el @ att "class" nbNavbarClass $ do
|
||||||
el @ att "class" "nb-navbar-start" $ do
|
tag "a" @ att "class" "nb-navbar-brand" . att "href" (uriToText (routeUri RDashboard)) $ text "Sis"
|
||||||
el @ att "class" nbFontHeading2Class @ att "style" "font-weight:700" $ text "Sis"
|
el @ att "class" "nb-navbar-nav" $ do
|
||||||
el @ att "class" "nb-navbar-end" $ do
|
routeLink RDashboard "Today"
|
||||||
routeLink RDashboard "Dashboard"
|
|
||||||
routeLink RChores "Chores"
|
routeLink RChores "Chores"
|
||||||
routeLink RHousehold "Household"
|
|
||||||
routeLink RActivity "Activity"
|
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 :: (Route r) => r -> Text -> View ctx ()
|
||||||
routeLink rt lbl = do
|
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
|
||||||
|
|||||||
+55
-30
@@ -2,46 +2,71 @@ const { chromium } = require('playwright');
|
|||||||
|
|
||||||
(async () => {
|
(async () => {
|
||||||
const browser = await chromium.launch({ headless: true });
|
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().substring(0, 150)));
|
||||||
page.on('console', msg => console.log('CONSOLE:', msg.type(), msg.text()));
|
|
||||||
page.on('pageerror', err => console.log('PAGE ERROR:', err.message));
|
page.on('pageerror', err => console.log('PAGE ERROR:', err.message));
|
||||||
|
|
||||||
// Listen for network responses
|
// Step 1: Load login page
|
||||||
page.on('response', resp => {
|
console.log('\n=== Step 1: Load login page ===');
|
||||||
if (resp.url().includes('/rlogin') || resp.url().includes('websocket')) {
|
|
||||||
console.log('RESPONSE:', resp.status(), resp.url().substring(0, 50));
|
|
||||||
}
|
|
||||||
});
|
|
||||||
|
|
||||||
await page.goto('http://localhost:8080/rlogin', { waitUntil: 'networkidle', timeout: 10000 });
|
await page.goto('http://localhost:8080/rlogin', { waitUntil: 'networkidle', timeout: 10000 });
|
||||||
|
console.log('URL:', page.url());
|
||||||
|
|
||||||
// Check the HTML
|
// Step 2: Submit login form
|
||||||
const html = await page.content();
|
console.log('\n=== Step 2: Submit login ===');
|
||||||
console.log('Has "Welcome":', html.includes('Welcome'));
|
|
||||||
console.log('Has "lfEmail":', html.includes('lfEmail'));
|
|
||||||
console.log('Has form action:', html.includes('data-onsubmit'));
|
|
||||||
|
|
||||||
await page.fill('input[name="lfEmail"]', 'alice@demo.com');
|
await page.fill('input[name="lfEmail"]', 'alice@demo.com');
|
||||||
await page.fill('input[name="lfPassword"]', 'password123');
|
await page.fill('input[name="lfPassword"]', 'password123');
|
||||||
|
|
||||||
console.log('Clicking submit...');
|
|
||||||
await page.click('button[type="submit"]');
|
await page.click('button[type="submit"]');
|
||||||
|
await page.waitForTimeout(3000);
|
||||||
// Wait to see what happens
|
console.log('URL after submit:', page.url());
|
||||||
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'));
|
|
||||||
|
|
||||||
// Check cookies
|
// Check cookies
|
||||||
const cookies = await page.context().cookies();
|
const cookies = await context.cookies();
|
||||||
console.log('Cookies:', JSON.stringify(cookies.map(c => c.name + '=' + c.value)));
|
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();
|
await browser.close();
|
||||||
|
console.log('\nDone.');
|
||||||
})().catch(e => { console.error('FAIL:', e.message); process.exit(1); });
|
})().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