Compare commits

...

28 Commits

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

Verified with Playwright: login, dashboard link click, and navbar
navigation all preserve the session correctly.
2026-07-16 07:48:10 -04:00
jbrechtel dbfe3a7c66 chore: fix all hlint warnings, update AGENTS.md pre-commit checklist
- Fix 8 hlint hints across 6 files (unused pragma, newtype, lambda, redundant brackets/\$)
- Add blank line after LANGUAGE pragma in Route.hs (fourmolu)
- Fix HouseholdFormData deriving to use explicit strategies for newtype
- Update AGENTS.md: require hlint clean before every commit, add pre-commit checklist
  (format, lint, build, test), update NB CSS URL to jsdelivr CDN
2026-07-16 07:43:38 -04:00
jbrechtel 95ac550191 fix: update to correct NeoBrutalismCSS CDN and class names
- Switch CDN to jsdelivr (matches design spec)
- Use nb-card, nb-card-title, nb-button default, nb-checkbox, nb-navbar-link
- Add Google Fonts import for Lexend Mega
- Style all route links as nb-button default buttons
- Fix navbar to use nb-navbar-brand and nb-navbar-nav
- Update style.css for new NB version compatibility
2026-07-16 07:34:45 -04:00
jbrechtel e8036bab11 chore: cleanup trailing empty lines from sed operations 2026-07-16 07:30:37 -04:00
jbrechtel 456eae4717 fix: login/signup flow working with session-based auth
- Fixed hashPasswordIO to use real PBKDF2 hashing from Sis.Auth
- Added seed route (rseed) for demo data initialization
- Replaced redirect() in update functions with success views
  (redirect uses throwError_ which broke with effectful 2.4)
- Added loginSuccessView and signupSuccessView with dashboard links
- Patched Hyperbole Socket.hs to parse WebSocket form body into Form params
- Patched Hyperbole Wai.hs to include TargetViewId in response metadata
- Fixed View/Page type mismatches (hyper wrapper vs plain view)
- Removed dead pure after redirect calls
- Verified: login submits, session set, success view rendered
2026-07-16 07:27:31 -04:00
jbrechtel a99c239852 fix: add static file serving with custom middleware
- Replaced wai-app-static with lightweight inline static file server
- Static files served from frontend/static/ under /static/ path
- Fixed ByteString/FilePath type mismatches for GHC 9.10
- Verified: CSS, manifest, login, signup, dashboard all HTTP 200
2026-07-16 07:00:41 -04:00
jbrechtel df9ad3d7c4 fix: rename route constructors to avoid type conflicts
- Renamed route constructors: RouteLogin → RLogin, RouteDashboard → RDashboard, etc.
- This fixes ambiguous occurrence errors with Types.Dashboard vs Route.Dashboard
- Fixed Layout.hs navbar links to use new constructor names
- Server verified serving HTML on /login, /rdashboard, etc.
2026-07-16 06:54:18 -04:00
jbrechtel 1d5ecd0829 chore: cleanup TypeScript, update docs, scripts, Dockerfile
- Delete all frontend TypeScript source (src/, index.html, package.json, etc.)
- Move static assets to frontend/static/ (style.css, manifest.json)
- Update scripts/build and scripts/test (no npm steps)
- Update Dockerfile (no frontend build step)
- Update README.md and AGENTS.md for Hyperbole stack
2026-07-16 06:51:11 -04:00
jbrechtel a717d619d3 feat: Hyperbole port compiles and builds successfully
- All page modules now use proper Page es '[ViewId] type with hyper embedding
- Fixed view DSL: tag calls, String/Text conversions, polymorphic context types
- DB effect uses convenience wrappers (lowercase) with send
- HyperView instances have DB :> es, IOE :> es constraints
- Main.hs uses liveAppWith with proper router
- Static file serving deferred (will use nginx or wai-app-static)
- Warning suppressions added where needed
- Build produces working 25MB sis-server binary
2026-07-16 06:50:20 -04:00
jbrechtel c45ae41645 fix: progress on Hyperbole view DSL - form tags, imports, constraints
- Fix tag calls to use \$ none for self-closing tags
- Add IOE constraint to HyperView instances
- Add warning suppressions where needed
- Fix Form data type imports
- Remove duplicate getUserHouseholds helpers
- Remaining issues: String/Text mismatches in text calls,
  a few view DSL type errors in Dashboard/Chores
2026-07-16 06:41:49 -04:00
jbrechtel 7eaf6ab7e7 feat: Hyperbole port - all modules created, Database effect working
- Database.hs: effectful DB effect with all operations + convenience wrappers
- Types.hs: stripped Aeson (kept ToJSON/FromJSON on IDs), added form types
- Route.hs, Style.hs, View/Layout.hs: support modules
- All Page modules: Login, Signup, Dashboard, Chores, Household, Activity
- Main.hs: Hyperbole app entry point with router
- Known issue: Hyperbole view DSL syntax needs cleanup in page modules
  (tag calls need $ none suffix, form elements need field wrappers)
2026-07-16 06:38:34 -04:00
jbrechtel b92947cdcc refactor: strip Aeson from Types, remove Server.hs, fix Sis.hs exports, update deps
- Removed all Aeson instances from Types.hs
- Deleted Server.hs (Orb/WAI routing)
- Added Hyperbole form types (LoginForm, SignupForm, etc.)
- Removed Server from Sis.hs and cabal file
- Updated stack.yaml for Hyperbole dependency resolution
- Added local hyperbole copy with GHC 9.10 compat patches
- Types.hs, Database.hs, Auth.hs compile successfully
2026-07-15 22:44:05 -04:00
jbrechtel 2c55ea9dc1 deps: add hyperbole, effectful, atomic-css; remove orb/mithril deps 2026-07-15 22:35:08 -04:00
jbrechtel aa88f0b3c5 docs: implementation plan for Hyperbole port 2026-07-15 22:24:17 -04:00
jbrechtel de4b48c8e5 docs: design spec for porting Sis to Hyperbole 2026-07-15 22:17:50 -04:00
jbrechtel 194df4d2fe feat: use .nb-button.default styling for nav buttons 2026-07-15 21:45:12 -04:00
jbrechtel 6f24ba0901 docs: add nav button styling design spec 2026-07-15 21:44:40 -04:00
jbrechtel c530fd882a Updates AGENTS.md 2026-07-15 21:31:33 -04:00
jbrechtel 0adeaf9ceb Adding plans and docs 2026-07-15 21:21:21 -04:00
51 changed files with 3406 additions and 3217 deletions
+3
View File
@@ -12,3 +12,6 @@ __pycache__
.superpowers/ .superpowers/
node_modules/ node_modules/
frontend/dist/ frontend/dist/
test-results/
hyperbole-local/
hyperbole-local/
+55 -36
View File
@@ -2,8 +2,8 @@
## Project Overview ## Project Overview
Sis is a shared household chore/task tracker with a Haskell backend and Sis is a shared household chore/task tracker written entirely in Haskell using
TypeScript/Mithril.js SPA frontend. Hyperbole, a serverside web framework. There is zero application JavaScript.
## Build & Tooling ## Build & Tooling
@@ -12,7 +12,7 @@ TypeScript/Mithril.js SPA frontend.
`hpack`, `fourmolu`, `hlint`. `hpack`, `fourmolu`, `hlint`.
- **Build script:** `./scripts/build` — formats (fourmolu), lints (hlint), - **Build script:** `./scripts/build` — formats (fourmolu), lints (hlint),
builds with stack, copies binary to `build/`. builds with stack, copies binary to `build/`.
- **Test script:** `./scripts/test` fourmolu check, hlint, `stack test`. - **Test script:** `./scripts/test` — hlint, `stack test`.
- **Run script:** `./scripts/run` — starts server in Docker via `stack exec`. - **Run script:** `./scripts/run` — starts server in Docker via `stack exec`.
- **hpack:** `package.yaml` is the source of truth for dependencies. After - **hpack:** `package.yaml` is the source of truth for dependencies. After
editing it, run `./hs hpack` to regenerate `sis-server.cabal`. (If `hpack` editing it, run `./hs hpack` to regenerate `sis-server.cabal`. (If `hpack`
@@ -20,53 +20,67 @@ TypeScript/Mithril.js SPA frontend.
## Haskell Conventions ## Haskell Conventions
- **Style:** fourmolu-formatted. The `./scripts/test` script checks this. - **Style:** fourmolu-formatted. Run `./hs fourmolu --mode inplace app/ src/ test/` before committing.
Run `./hs fourmolu --mode inplace app/ src/ test/` 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.
- **Lint:** hlint clean required. Fix any hints before committing. - **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`).
- **JSON:** Aeson instances live in the same module as the types they - **Architecture:** The backend uses [Hyperbole](https://github.com/seanhess/hyperbole)
serialize (`Sis.Types`). for serverside HTML rendering and interactivity via WebSocket. Pages are
- **Architecture:** The backend uses [Orb](https://github.com/flipstone/orb) Haskell functions returning `Page es '[ViewId]`, with interactive components
for HTTP routing (`Sis.Server`), with WAI/Warp underneath. Route types as `HyperView` instances.
(like `HealthCheck`) implement `Orb.HasHandler`. - **Database:** Custom `effectful` `DB` effect in `Sis.Database`. All DB
operations go through the effect (use the lowercase convenience functions
like `findUserByEmail`, not the raw constructors).
## Frontend Conventions ## Frontend Conventions
- **SPA framework:** [Mithril.js](https://mithril.js.org/) v2 with TypeScript. - **Framework:** [Hyperbole](https://github.com/seanhess/hyperbole) — Haskell
- **CSS:** [Neo Brutalism](https://unpkg.com/neobrutalismcss@latest) CDN. serverside web framework. All HTML rendered in Haskell.
- **Build:** `npm run build` (or `cd frontend && npx tsc` for dev). - **CSS:** [Neo Brutalism](https://github.com/matifandy8/NeoBrutalismCSS) CDN via jsdelivr + `frontend/static/style.css` for custom styles.
- **API client:** Thin fetch wrapper in `frontend/src/api.ts`. Base path `/api`. - **Build:** No npm/build step for frontend. All pages rendered in Haskell.
- **Dev server:** `npm run serve` serves the built frontend on port 5000. - **Interactive components:** HyperViews with typed Actions and server-side
updates via VirtualDOM over WebSocket.
## Project Structure ## Project Structure
``` ```
sis/ sis/
├── app/Main.hs # Server entry point, CLI options, Warp setup ├── app/Main.hs # Hyperbole app entry, Warp setup, route dispatch
├── src/ ├── src/
│ ├── Sis.hs # Top-level re-exports │ ├── Sis.hs # Top-level re-exports
│ ├── Sis/Server.hs # Orb HTTP routes, WAI app, SPA serving │ ├── Sis/Route.hs # Route ADT with Route instance
│ ├── Sis/Types.hs # Core domain types (Task, User, etc.) │ ├── Sis/Types.hs # Core domain types
── Sis/Database.hs # SQLite connection management ── Sis/Database.hs # effectful DB effect, SQLite operations
├── test/Spec.hs # Hspec test suite │ ├── Sis/Auth.hs # Password hashing
│ ├── Sis/Page/
│ │ ├── Login.hs # Login page
│ │ ├── Signup.hs # Signup page
│ │ ├── Dashboard.hs # Dashboard with stats + due/completed items
│ │ ├── Chores.hs # Chore list + create/edit form
│ │ ├── Household.hs # Members, invites, household management
│ │ └── Activity.hs # Activity log with pagination
│ ├── Sis/View/
│ │ └── Layout.hs # Shell: document head, navbar, page wrapper
│ └── Sis/Style.hs # Neo Brutalism class helpers
├── frontend/ ├── frontend/
── src/ ── static/
├── index.ts # Mithril mount point ├── style.css # Custom CSS
── api.ts # Backend API client ── manifest.json # PWA manifest
│ │ └── components/ # Mithril components ├── test/Spec.hs # Hspec test suite
│ └── public/style.css
├── docs/ ├── docs/
│ ├── specs/ # Design specs │ ├── specs/ # Design specs
│ └── plans/ # Implementation plans │ └── plans/ # Implementation plans
├── scripts/ # build, test, run ├── scripts/ # build, test, run
├── package.yaml # Haskell deps (hpack source of truth) ├── package.yaml # Haskell deps (hpack source of truth)
├── sis-server.cabal # Generated by hpack ├── sis-server.cabal # Generated by hpack
├── stack.yaml # Stack resolver config ├── stack.yaml # Stack resolver config
── docker-compose.yml # Deployment stack ── Dockerfile # Production image
├── Dockerfile # Production image
└── FEATURES.org # Feature roadmap
``` ```
## Commit Style ## Commit Style
@@ -74,3 +88,8 @@ sis/
- Conventional commits: `feat:`, `deps:`, `test:`, `chore:`, `docs:`. - Conventional commits: `feat:`, `deps:`, `test:`, `chore:`, `docs:`.
- Each commit should be a self-contained logical change. - Each commit should be a self-contained logical change.
- Run `./scripts/test` before committing. Tests must pass. - 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
+2 -5
View File
@@ -4,17 +4,14 @@ RUN apt-get update && apt-get install -y --no-install-recommends \
ca-certificates curl tini && \ ca-certificates curl tini && \
rm -rf /var/lib/apt/lists/* rm -rf /var/lib/apt/lists/*
# Build timestamp — read at runtime for diagnostics.
RUN mkdir -p /build && date -u '+%Y-%m-%d %H:%M UTC' > /build/build-time RUN mkdir -p /build && date -u '+%Y-%m-%d %H:%M UTC' > /build/build-time
ADD build/sis-server /usr/local/bin/sis-server ADD build/sis-server /usr/local/bin/sis-server
RUN chmod +x /usr/local/bin/sis-server RUN chmod +x /usr/local/bin/sis-server
# Frontend SPA static files, served by sis-server via --static-dir. ADD frontend/static /usr/local/share/sis/static
ADD frontend/dist /usr/local/share/sis/static
ENTRYPOINT ["/usr/bin/tini", "-s", "--"] ENTRYPOINT ["/usr/bin/tini", "-s", "--"]
EXPOSE 8080 EXPOSE 8080
CMD ["/usr/local/bin/sis-server", "--port", "8080", "--static-dir", "/usr/local/share/sis/static"] CMD ["/usr/local/bin/sis-server"]
+58 -8
View File
@@ -1,17 +1,67 @@
# Sis # Sis
Sis (short for Sisyphus) is a todo tracker meant primarily for households, families or other groups of people with shared repeated responsibilities like chores. Sis (short for Sisyphus) is a todo tracker meant primarily for households,
families or other groups of people with shared repeated responsibilities like
chores.
The goal of Sis is to make it easy for users to keep track of which tasks need to be completed and when while allowing any user to complete a given task and provide visibility to other users that a task has been completed. The goal of Sis is to make it easy for users to keep track of which tasks need
to be completed and when while allowing any user to complete a given task and
provide visibility to other users that a task has been completed.
Sis is primarily a web application but includes push notification support for end users to notify them about upcoming/overdue tasks as well as task completion. Sis is a web application written entirely in Haskell using
[Hyperbole](https://github.com/seanhess/hyperbole), a serverside web framework
inspired by HTMX, Elm, and Phoenix LiveView. There is zero application
JavaScript in the source code.
## Frontend ## Stack
The Sis UI a single-page application written in Javascript using https://mithril.js.org/ and uses the "Neo Brutalism" CSS framework - https://unpkg.com/neobrutalismcss@latest - **Framework:** [Hyperbole](https://github.com/seanhess/hyperbole) — Haskell serverside web framework
- **CSS:** [Neo Brutalism](https://unpkg.com/neobrutalismcss@latest) CDN
- **Database:** SQLite via sqlite-simple with effectful effect system
- **Build:** Stack with GHC 9.10
Sis uses Typescript for front-end code ## Architecture
## Backend Sis is a single Haskell application. All HTML is rendered serverside via
Hyperbole's Page/HyperView system. User interactions are sent over WebSocket
with VirtualDOM-based page updates.
The Sis backend is written in Haskell using Orb for the HTTP framework - https://github.com/flipstone/orb ```
sis/
├── app/Main.hs # Hyperbole app entry, Warp setup, route dispatch
├── src/
├─├── Sis.hs # Top-level re-exports
│ ├── Sis/Route.hs # Route ADT
│ ├── Sis/Types.hs # Core domain types
│ ├── Sis/Database.hs # effectful DB effect + SQLite handler
│ ├── Sis/Auth.hs # Password hashing
│ ├── Sis/Page/ # One module per page
│ │ ├── Login.hs
│ │ ├── Signup.hs
│ │ ├── Dashboard.hs
│ │ ├── Chores.hs
│ │ ├── Household.hs
│ │ └── Activity.hs
│ ├── Sis/View/ # Reusable view components
│ │ └── Layout.hs
│ └── Sis/Style.hs # Neo Brutalism class helpers
├── frontend/static/ # Static CSS + PWA manifest
├── test/Spec.hs # Hspec test suite
├── scripts/ # build, test, run
├── package.yaml # Haskell deps (hpack source of truth)
├── stack.yaml # Stack resolver config
└── Dockerfile # Production image
```
## Development
```bash
# Build
./scripts/build
# Test
./scripts/test
# Run (starts on port 8080)
./scripts/run
```
+110 -60
View File
@@ -1,74 +1,124 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists -Wno-name-shadowing #-}
{- | Entry point for the Sis server. module Main where
Starts a Warp HTTP server, serves the JSON API and the SPA frontend.
-}
module Main (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
import Data.List (isSuffixOf)
import Effectful
import Network.HTTP.Types qualified as HTTP
import Network.Wai qualified as Wai
import Network.Wai.Handler.Warp qualified as Warp import Network.Wai.Handler.Warp qualified as Warp
import Options.Applicative qualified as Opt import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile)
import System.Posix.Signals qualified as Signals import System.Environment (getArgs, lookupEnv)
import System.FilePath (takeDirectory)
import System.IO.Error (isDoesNotExistError)
import Sis.Database qualified as Database import Sis (UserId (..))
import Sis.Server qualified as Sis import Sis.Database
import Sis.Page.Activity
import Sis.Page.Chores
import Sis.Page.Dashboard
import Sis.Page.Household
import Sis.Page.Login
import Sis.Page.Signup
import Sis.Route
import Sis.View.Layout (UserSession (..), documentHead)
import Web.Hyperbole
import Web.Hyperbole.Application
import Web.Hyperbole.Effect.Response
import Web.Hyperbole.Page
import Web.Hyperbole.Route
data Options = Options -- Simple MIME type resolver for static files
{ optPort :: Int mimeType :: FilePath -> BS.ByteString
, optStaticDir :: FilePath mimeType fp
, optDbPath :: FilePath | ".css" `isSuffixOf` fp = "text/css"
} | ".js" `isSuffixOf` fp = "application/javascript"
| ".json" `isSuffixOf` fp = "application/json"
optionsParser :: Opt.Parser Options | ".png" `isSuffixOf` fp = "image/png"
optionsParser = | ".svg" `isSuffixOf` fp = "image/svg+xml"
Options | otherwise = "application/octet-stream"
<$> Opt.option
Opt.auto
( Opt.long "port"
<> Opt.short 'p'
<> Opt.metavar "PORT"
<> Opt.help "Listen port"
<> Opt.value 8080
<> Opt.showDefault
)
<*> Opt.strOption
( Opt.long "static-dir"
<> Opt.metavar "DIR"
<> Opt.help "Directory containing the SPA frontend static files"
<> Opt.value "frontend/dist"
<> Opt.showDefault
)
<*> Opt.strOption
( Opt.long "db-path"
<> Opt.metavar "PATH"
<> Opt.help "Path to the SQLite database file"
<> Opt.value "data/sis.db"
<> Opt.showDefault
)
main :: IO () main :: IO ()
main = do main = do
opts <- args <- getArgs
Opt.execParser $ let dbPath = case args of
Opt.info (optionsParser Opt.<**> Opt.helper) $ ("--db" : p : _) -> p
Opt.fullDesc _ -> "data/sis.db"
<> Opt.progDesc "Sis — shared household chore tracker"
<> Opt.header "sis-server"
db <- Database.openDatabase (optDbPath opts) -- 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..."
Signals.installHandler conn <- openDatabase dbPath
Signals.sigTERM
(Signals.Catch (putStrLn "[sis] shutting down"))
Nothing
let waiApp = Sis.app (optStaticDir opts) db putStrLn $ "[sis] listening on 0.0.0.0:" <> show port
let settings = let hyperboleApp =
Warp.setPort (optPort opts) $ liveAppWith
Warp.setBeforeMainLoop ( ServerOptions
(putStrLn $ "[sis] listening on 0.0.0.0:" ++ show (optPort opts)) { toDocument = document documentHead
Warp.defaultSettings , serverError = defaultError
, parseRequestBody = defaultParseRequestBodyOptions
}
)
(runDB conn $ routeRequest router)
Warp.runSettings settings waiApp -- Serve static files under /static/, fall through to Hyperbole app
let staticDir = "frontend/static"
Warp.run port $ \req respond -> do
let rawPath = Wai.rawPathInfo req
if "/static/" `BS.isPrefixOf` rawPath
then do
let relPath = C8.unpack (C8.drop (C8.length "/static") rawPath)
filePath = staticDir ++ relPath
exists <- doesFileExist filePath
if exists
then do
content <- BS.readFile filePath
let ct = mimeType filePath
respond $ Wai.responseLBS HTTP.status200 [("Content-Type", ct)] (BL.fromStrict content)
else respond $ Wai.responseLBS HTTP.status404 [] "File not found"
else hyperboleApp req respond
router :: (Hyperbole :> es, DB :> es, IOE :> es) => AppRoute -> Eff es Response
router Home = do
redirect (routeUri RDashboard)
router RLogin = runPage Sis.Page.Login.page
router RSignup = runPage Sis.Page.Signup.page
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)
+123
View File
@@ -0,0 +1,123 @@
# Sis Implementation Plan
**Goal:** Build the complete Sis household chore tracker per BUILD_TASKS.md — auth, households, chores/schedules, activity recording, PWA, all styled with NeoBrutalismCSS.
**Architecture:** Monolithic Haskell/Orb backend serving JSON API routes + SQLite persistence. Mithril.js SPA frontend with client-side routing. Session-based auth via httpOnly cookies with PBKDF2-hashed passwords using `crypton`. All household-scoped data is protected by session middleware.
**Tech Stack:** Haskell (GHC 9.10), Orb/Warp, sqlite-simple, crypton (PBKDF2), aeson, Mithril.js v2, TypeScript, NeoBrutalismCSS CDN.
**Product decisions:**
- Any member can manage chores (edit/delete) — collaborative model
- Activity records are append-only (no edit/undo)
- "Anyone" chores: completing an occurrence clears it for the whole household
- Recurring: specific day-of-week/month, not just "every N days"
- Occurrences generated 90 days ahead, rolling window
---
## Phase 0 — Foundation: DB schema + session infrastructure
### Task 0.1: Database schema migrations
- **Files:** `src/Sis/Database.hs`
- Add `runMigrations` that creates all tables on startup: users, sessions, households, memberships, invites, chores, occurrences, activities.
### Task 0.2: Password hashing module
- **Files:** New `src/Sis/Auth.hs`
- PBKDF2 via crypton: `hashPassword`, `verifyPassword`, `generateSessionToken` (32 random bytes hex), session cookie handling.
### Task 0.3: Session middleware
- **Files:** `src/Sis/Server.hs`, `src/Sis/Auth.hs`
- Extract session token from cookie, load user, attach to request context. Auth-required routes check for valid user.
---
## Phase 1 — Auth routes (Milestone 1)
### Task 1.1: Auth route types + handlers
- **Files:** `src/Sis/Server.hs`
- POST /api/auth/signup, POST /api/auth/login, POST /api/auth/logout, GET /api/auth/me
- Validate unique email, password strength, matching confirmation.
### Task 1.2: Frontend auth pages
- **Files:** `frontend/src/components/LoginPage.ts`, `frontend/src/components/SignupPage.ts`
- Signup form with inline validation. Login form with "remember me". Client-side router integration.
### Task 1.3: Password reset
- **Files:** `src/Sis/Server.hs`, `frontend/src/components/ForgotPassword.ts`
- POST /api/auth/forgot-password (generates reset token), POST /api/auth/reset-password (consumes token).
---
## Phase 2 — Households (Milestone 2)
### Task 2.1: Household CRUD routes
- **Files:** `src/Sis/Server.hs`
- POST /api/households, GET /api/households, GET /api/households/:id, PUT /api/households/:id, DELETE /api/households/:id
- GET /api/households/:id/members, DELETE /api/households/:id/members/:userId
### Task 2.2: Invite routes
- **Files:** `src/Sis/Server.hs`
- POST /api/households/:id/invites, GET /api/households/:id/invites, DELETE /api/households/:id/invites/:inviteId
- GET /api/invites/:code (public lookup), POST /api/invites/:code/accept
### Task 2.3: Frontend household pages
- **Files:** `frontend/src/components/HouseholdPage.ts`, `frontend/src/components/HouseholdList.ts`, `frontend/src/components/CreateHousehold.ts`
- Household switcher, member list, invite panel.
---
## Phase 3 — Chores (Milestone 3)
### Task 3.1: Chore CRUD routes
- **Files:** `src/Sis/Server.hs`
- GET /api/households/:id/chores, POST /api/households/:id/chores, PUT /api/households/:id/chores/:id, DELETE /api/households/:id/chores/:id
### Task 3.2: Occurrence generation logic
- **Files:** `src/Sis/Database.hs` (for occurrence queries)
- Generate rolling 90-day window of occurrences from recurring schedules. Recompute on schedule edit.
### Task 3.3: Dashboard routes
- **Files:** `src/Sis/Server.hs`
- GET /api/households/:id/dashboard — returns overdue, due-today, completed-today stats and lists.
### Task 3.4: Frontend chore + dashboard pages
- **Files:** `frontend/src/components/DashboardPage.ts`, `frontend/src/components/ChoreList.ts`, `frontend/src/components/ChoreForm.ts`
---
## Phase 4 — Activity (Milestone 4)
### Task 4.1: Activity record routes
- **Files:** `src/Sis/Server.hs`
- POST /api/occurrences/:id/activity
### Task 4.2: Activity log routes
- **Files:** `src/Sis/Server.hs`
- GET /api/households/:id/activity?member=&status=&page=&perPage=
### Task 4.3: Frontend activity pages
- **Files:** `frontend/src/components/RecordActivity.ts`, `frontend/src/components/ActivityLog.ts`
---
## Phase 5 — PWA (Milestone 5)
### Task 5.1: Manifest + service worker
- **Files:** `frontend/public/manifest.json`, `frontend/public/sw.js`
- Web app manifest, basic offline service worker.
### Task 5.2: Frontend polish, routing, navigation
- **Files:** `frontend/src/router.ts`, `frontend/src/components/Layout.ts`, `frontend/public/style.css`
- Client-side router, nav bar, responsive layouts, all nav links.
---
## Phase 6 — Seed data + tests (Milestone 6)
### Task 6.1: Seed data route
- **Files:** `src/Sis/Server.hs`
- POST /api/seed — creates demo household with sample chores, members, activity.
### Task 6.2: Backend tests
- **Files:** `test/Spec.hs`
- Test auth flow, household CRUD, chore CRUD, activity recording.
+627
View File
@@ -0,0 +1,627 @@
# Hyperbole Port Implementation Plan
**Goal:** Port Sis from Orb+WAI+TypeScript+Mithril to Hyperbole (pure Haskell serverside web framework), eliminating all JavaScript application code.
**Architecture:** Single Haskell Hyperbole application. Pages rendered serverside. Interactivity via HyperViews with WebSocket-based VirtualDOM. SQLite via custom effectful `DB` effect. Neo Brutalism CSS via CDN.
**Tech Stack:** Hyperbole, effectful, atomic-css, Warp, SQLite (sqlite-simple), crypton.
---
## File Structure Map
| File | Action | Responsibility |
|------|--------|----------------|
| `package.yaml` | Modify | Replace Orb/Mithril deps with Hyperbole |
| `stack.yaml` | Modify | Add Hyperbole extra-deps |
| `app/Main.hs` | Rewrite | Hyperbole app entry, Warp, route dispatch |
| `src/Sis.hs` | Modify | Re-exports (remove Server, add Page modules) |
| `src/Sis/Route.hs` | Create | Route ADT with `Route` instance |
| `src/Sis/Types.hs` | Modify | Remove Aeson instances, add form types |
| `src/Sis/Database.hs` | Rewrite | effectful `DB` effect + SQLite handler |
| `src/Sis/Auth.hs` | Modify | Keep password hashing, drop cookie/session helpers |
| `src/Sis/Server.hs` | Delete | Replaced by Hyperbole pages |
| `src/Sis/Page/Login.hs` | Create | Login page |
| `src/Sis/Page/Signup.hs` | Create | Signup page |
| `src/Sis/Page/Dashboard.hs` | Create | Dashboard page |
| `src/Sis/Page/Chores.hs` | Create | Chores page |
| `src/Sis/Page/Household.hs` | Create | Household page |
| `src/Sis/Page/Activity.hs` | Create | Activity log page |
| `src/Sis/View/Layout.hs` | Create | Shell: document head, navbar, page wrapper |
| `src/Sis/View/ChoreForm.hs` | Create | Create/edit chore HyperView |
| `src/Sis/View/ActivityForm.hs` | Create | Record activity HyperView |
| `src/Sis/View/Field.hs` | Create | Reusable form field helpers |
| `src/Sis/Style.hs` | Create | Neo Brutalism class helpers |
| `test/Spec.hs` | Modify | Delete placeholder |
| `frontend/src/` | Delete | All TypeScript code |
| `frontend/index.html` | Delete | Replaced by Hyperbole document function |
| `frontend/package.json` | Delete | No npm needed |
| `frontend/tsconfig.json` | Delete | No TypeScript needed |
| `frontend/public/` | Delete | Merge into static/ |
| `frontend/static/style.css` | Create/Keep | Move from public/style.css |
| `frontend/static/manifest.json` | Create/Keep | Move from public/manifest.json |
| `Dockerfile` | Modify | No npm build, copy binary + static |
| `scripts/build` | Modify | Remove npm build step |
| `scripts/test` | Modify | Just Haskell build + test |
| `scripts/run` | Modify | Updated for Hyperbole serving |
| `README.md` | Modify | Update tech stack description |
| `AGENTS.md` | Modify | Update conventions |
---
### Task 1: Add Hyperbole Dependencies
**Files:** `package.yaml`, `stack.yaml`
- [ ] **Step 1: Update package.yaml**
Replace deps section. Key changes:
- Add `DataKinds`, `TypeFamilies` to default-extensions
- Shared deps: remove `beeline-routing`, `json-fleece-aeson`, `json-fleece-core`, `mtl`, `optparse-applicative`, `safe-exceptions`, `shrubbery`, `wai-extra`; add `effectful`
- Library deps: remove `cookie`, `orb`; add `atomic-css`, `data-default`, `effectful-core`, `hyperbole`, `string-conversions`, `text-casing`
- Executable deps: remove `optparse-applicative`, `orb`, `unix`; add `effectful`, `hyperbole`
- [ ] **Step 2: Run hpack**
```bash
./hs hpack
```
- [ ] **Step 3: Update stack.yaml**
Replace with:
```yaml
resolver: lts-24.38
packages:
- .
extra-deps:
- hyperbole-1.0.0.0
- atomic-css-0.1.0.0
- effectful-2.3.0.0
- effectful-core-2.3.0.0
- string-conversions-0.4.0.1
- text-casing-0.1.0.3
- data-default-0.7.1.2
```
- [ ] **Step 4: Verify dependency resolution**
```bash
./hs stack build --dry-run 2>&1 | tail -30
```
Expected: Shows build plan. Adjust resolver or extra-dep versions as needed.
- [ ] **Step 5: Commit**
```bash
git add package.yaml stack.yaml sis-server.cabal
git commit -m "deps: add hyperbole, effectful, atomic-css; remove orb/mithril deps"
```
---
### Task 2: Strip Aeson from Types, Add Form Types
**Files:** `src/Sis/Types.hs`
- [ ] **Step 1: Remove all Aeson instances**
In `src/Sis/Types.hs`:
- Remove Aeson import and all `instance A.ToJSON`/`instance A.FromJSON` blocks
- Remove `A.ToJSON`, `A.FromJSON`, `A.ToJSONKey`, `A.FromJSONKey` from newtype deriving
- Remove request types: `SignupRequest`, `LoginRequest`, `CreateHouseholdRequest`, `CreateInviteRequest`, `CreateChoreRequest`, `UpdateChoreRequest`, `RecordActivityRequest`, `ErrorResponse`, `SeedRequest`, `AuthResponse`, `UserPublic`
- Keep all core domain types
- [ ] **Step 2: Add Hyperbole form types at end of file**
```haskell
import GHC.Generics (Generic)
import Web.Hyperbole.HyperView.Forms (FromForm (..))
data LoginForm = LoginForm
{ lfEmail :: Text, lfPassword :: Text, lfRemember :: Bool }
deriving stock (Show, Eq, Generic)
deriving (FromForm) via GenericForm LoginForm
data SignupForm = SignupForm
{ sfDisplayName :: Text, sfEmail :: Text, sfPassword :: Text
, sfConfirm :: Text, sfAgree :: Bool }
deriving stock (Show, Eq, Generic)
deriving (FromForm) via GenericForm SignupForm
data ChoreFormData = ChoreFormData
{ cfdName :: Text, cfdScheduleType :: Text, cfdStartDate :: Text
, cfdTimeOfDay :: Maybe Text, cfdPeriod :: Text
, cfdAssignee :: Text, cfdNotify :: Bool }
deriving stock (Show, Eq, Generic)
deriving (FromForm) via GenericForm ChoreFormData
data ActivityFormData = ActivityFormData
{ afdStatus :: Text, afdNote :: Maybe Text, afdNotify :: Bool }
deriving stock (Show, Eq, Generic)
deriving (FromForm) via GenericForm ActivityFormData
data HouseholdFormData = HouseholdFormData
{ hfdName :: Text }
deriving stock (Show, Eq, Generic)
deriving (FromForm) via GenericForm HouseholdFormData
```
- [ ] **Step 3: Verify Types.hs compiles**
```bash
./hs stack build 2>&1 | tail -20
```
Expected: Types.hs compiles. Other modules will fail.
- [ ] **Step 4: Commit**
```bash
git add src/Sis/Types.hs
git commit -m "refactor: strip Aeson instances from Types; add Hyperbole form types"
```
---
### Task 3: Database Effect
**Files:** `src/Sis/Database.hs` (rewrite)
Rewrite `src/Sis/Database.hs` to define a GADT `DB` effect with these constructors:
```haskell
data DB :: Effect where
FindUserByEmail :: Text -> DB m (Maybe User)
CreateUser :: Text -> Text -> Text -> DB m UserId
GetUser :: UserId -> DB m (Maybe User)
GetUserHouseholds :: UserId -> DB m [Household]
GetHousehold :: UserId -> Int -> DB m (Maybe Household)
CreateHousehold :: UserId -> Text -> DB m Household
GetMembers :: Int -> DB m [Membership]
GetChores :: Int -> DB m [Chore]
CreateChore :: Int -> Text -> ChoreAssignee -> Schedule -> Bool -> DB m Chore
UpdateChore :: Int -> Int -> Text -> ChoreAssignee -> Schedule -> Bool -> DB m Chore
DeleteChore :: Int -> DB m ()
GetDashboard :: Int -> Day -> DB m Dashboard
GenerateOccurrences :: Chore -> DB m ()
RecordActivity :: Int -> UserId -> ActivityStatus -> Maybe Text -> Bool -> DB m Activity
GetActivityLog :: Int -> Int -> Int -> DB m ActivityLogPage
CreateInvite :: Int -> Maybe Text -> DB m Invite
GetInvites :: Int -> DB m [Invite]
RevokeInvite :: Int -> DB m ()
AcceptInvite :: UserId -> Text -> DB m Household
Seed :: DB m ()
```
Implement `runDB :: SQL.Connection -> Eff (DB : es) a -> Eff es a` using `interpret`, with each constructor running the same SQL queries currently in `Server.hs`. Export `openAndRunDB` which opens the connection (with WAL + FK + migrations), runs the effect, and closes. Keep `runMigrations` almost unchanged.
Add `Show` + `Read` instances to `Schedule` and `SchedulePeriod` (in Types.hs) for storage as strings. Include helper functions `generateOccurrencesIO`, `generateRecurringDates`, `hashPasswordIO`, `generateTokenIO` as local helpers.
- [ ] **Step 1: Write the rewrite**
```bash
# The file should be ~400 lines, covering all DB operations
```
- [ ] **Step 2: Update Sis.hs exports**
Remove `import Sis.Server as X` from `src/Sis.hs`.
- [ ] **Step 3: Verify it compiles**
```bash
./hs stack build 2>&1 | tail -20
```
- [ ] **Step 4: Commit**
```bash
git add src/Sis/Database.hs src/Sis.hs src/Sis/Types.hs
git commit -m "refactor: convert Database to effectful DB effect"
```
---
### Task 4: Auth Module Update + Delete Server.hs
**Files:** `src/Sis/Auth.hs` (modify), `src/Sis/Server.hs` (delete)
- [ ] **Step 1: Simplify Auth.hs**
Remove cookie/session helpers (`makeSessionCookie`, `clearSessionCookie`, `sessionCookieName`). Keep only:
```haskell
module Sis.Auth (hashPassword, verifyPassword, generateToken) where
```
Remove HTTP imports. The rest stays the same (password hashing via PBKDF2).
- [ ] **Step 2: Delete Server.hs**
```bash
rm src/Sis/Server.hs
```
- [ ] **Step 3: Commit**
```bash
git rm src/Sis/Server.hs
git add src/Sis/Auth.hs
git commit -m "refactor: simplify Auth module; remove Orb/WAI Server"
```
---
### Task 5: Route + Style + Layout Modules
**Files:** `src/Sis/Route.hs` (create), `src/Sis/Style.hs` (create), `src/Sis/View/Layout.hs` (create)
- [ ] **Step 1: Create Route module**
```haskell
module Sis.Route where
import GHC.Generics (Generic)
import Web.Hyperbole.Route
data AppRoute
= RouteHome | RouteLogin | RouteSignup
| RouteDashboard | RouteChores | RouteHousehold | RouteActivity
deriving (Eq, Generic, Show)
instance Route AppRoute where
baseRoute = Just RouteHome
```
- [ ] **Step 2: Create Style module**
Shortcuts for Neo Brutalism CSS classes:
```haskell
module Sis.Style where
import Data.Text (Text)
import Web.Hyperbole.View
nbBox, nbButton, nbInput, nbLabel, nbBadge, nbFontHeading1, nbFontHeading2, nbContainer, nbList, nbListItem, nbRow :: Mods
nbBox = att "class" "nb-box"
nbButton = att "class" "nb-button"
nbInput = att "class" "nb-input"
nbLabel = att "class" "nb-label"
nbBadge = att "class" "nb-badge"
nbFontHeading1 = att "class" "nb-font-heading1"
nbFontHeading2 = att "class" "nb-font-heading2"
nbContainer = att "class" "nb-container"
nbList = att "class" "nb-box"
nbListItem = att "class" "nb-list-item"
nbRow = att "class" "nb-row"
colorRed, colorYellow, colorGreen :: Text
colorRed = "var(--nb-red)"
colorYellow = "var(--nb-yellow)"
colorGreen = "var(--nb-green)"
```
- [ ] **Step 3: Create Layout module**
Create `src/Sis/View/Layout.hs` with:
- `documentHead :: View DocumentHead ()` — Neo Brutalism CDN link, custom CSS, scriptEmbed, mobileFriendly, manifest
- `navbar :: User -> [Household] -> View ctx ()` — "Sis" heading, navigation links (Dashboard/Chores/Household/Activity/Logout)
- `requireAuth :: (Hyperbole :> es, DB :> es) => Eff es User` — reads `UserSession` from Hyperbole session, redirects to login if absent
- `UserSession` type with `Session` instance for cookie-based auth state
- [ ] **Step 4: Commit**
```bash
git add src/Sis/Route.hs src/Sis/Style.hs src/Sis/View/Layout.hs
git commit -m "feat: add Route, Style, and Layout modules"
```
---
### Task 6: Login & Signup Pages
**Files:** `src/Sis/Page/Login.hs` (create), `src/Sis/Page/Signup.hs` (create)
- [ ] **Step 1: Create Login page**
`LoginPage` HyperView with `Action = SubmitLogin`. On submit, queries DB for user, verifies password, saves `UserSession`, redirects to dashboard. On failure, re-renders with error. Page function checks for existing session and redirects if logged in.
```haskell
module Sis.Page.Login (page) where
import Sis.Database
import Sis.Route (AppRoute (..))
import Sis.Style
import Sis.Types
import Sis.View.Layout
import Web.Hyperbole
import Web.Hyperbole.HyperView.Forms
import Web.Hyperbole.Effect.Session (Session (..), saveSession, lookupSession)
data UserSession = UserSession { usUserId :: Int }
deriving (Generic, FromJSON, ToJSON)
instance Session UserSession where cookiePath = Just "/"
data LoginPage = LoginPage deriving (Generic, ViewId)
instance HyperView LoginPage es where
data Action LoginPage = SubmitLogin deriving (Generic, ViewAction)
update SubmitLogin = do
LoginForm{..} <- formData @LoginForm
mUser <- FindUserByEmail lfEmail
case mUser of
Just u | verifyPassword lfPassword u.userPasswordHash -> do
saveSession (UserSession (unUserId u.userId))
redirect (routeUri RouteDashboard)
pure $ el "Redirecting..."
_ -> pure $ loginView (Just "Invalid credentials")
```
The `loginView` renders: centered box with heading, email input, password input, remember-me checkbox, submit button, signup link. Uses NB classes: nbContainer, nbBox, nbFontHeading1, nbLabel, nbInput, nbButton.
- [ ] **Step 2: Create Signup page**
Same pattern. `SignupPage` HyperView. Validates password length (≥8), password match, email uniqueness. Creates user, saves session, redirects.
- [ ] **Step 3: Commit**
```bash
git add src/Sis/Page/Login.hs src/Sis/Page/Signup.hs
git commit -m "feat: add Login and Signup Hyperbole pages"
```
---
### Task 7: Dashboard Page + ActivityForm
**Files:** `src/Sis/Page/Dashboard.hs` (create), `src/Sis/View/ActivityForm.hs` (create)
- [ ] **Step 1: Create Dashboard page**
`DashboardPage` HyperView with `Action = RefreshDashboard | CheckOff OccurrenceId`. On refresh, loads dashboard from DB for the user's active household. Stats tiles show overdue/dueToday/doneThisWeek counts with color-coded borders.
Due items list: each has chore name, assignee, status badge (OVERDUE/DUE), "Check Off" button. Clicking "Check Off" opens the `ActivityForm` HyperView inline (replacing the button row).
Completed items: read-only list of today's activities with user name, chore name, time, note.
The page function (`page`) gets the user from `requireAuth`, determines the active household, and initializes the dashboard.
- [ ] **Step 2: Create ActivityForm HyperView**
```haskell
data ActivityForm = ActivityForm OccurrenceId deriving (Generic, ViewId)
instance HyperView ActivityForm es where
data Action ActivityForm = SubmitActivity | CancelActivity
deriving (Generic, ViewAction)
update SubmitActivity = do
ActivityForm oid <- viewId
ActivityFormData{..} <- formData @ActivityFormData
let status = if afdStatus == "skipped" then ActivitySkipped else ActivityCompleted
-- Get user from session context (passed via view state or page-level data)
pure $ el "Recorded!" -- pushEvent to refresh dashboard
update CancelActivity = pure none
```
The form view: status dropdown (completed/skipped), note textarea, notify checkbox, Save/Cancel buttons.
- [ ] **Step 3: Commit**
```bash
git add src/Sis/Page/Dashboard.hs src/Sis/View/ActivityForm.hs
git commit -m "feat: add Dashboard page with ActivityForm HyperView"
```
---
### Task 8: Chores Page + ChoreForm
**Files:** `src/Sis/Page/Chores.hs` (create), `src/Sis/View/ChoreForm.hs` (create)
- [ ] **Step 1: Create Chores page**
`ChoresPage` HyperView with `Action = RefreshChores | DeleteChore ChoreId | ToggleCreate | ToggleEdit ChoreId`. View state tracks whether the create/edit form is active.
Chore list: each row shows name, schedule badge (recurring/one-off/sometime), schedule description, Edit/Delete buttons. Delete shows inline confirmation.
"New Chore" button toggles the `ChoreForm` HyperView inline at the top of the list.
- [ ] **Step 2: Create ChoreForm HyperView**
`ChoreForm` with `Action = SubmitChore | CancelChore`. Form fields:
- Name (text input)
- Schedule type (select: recurring, one-off, sometime)
- Start date (date input)
- Time of day (time input, optional)
- Period (select: daily/weekly/monthly, shown if recurring)
- Assignee (select: anyone)
- Notify on due (checkbox)
On submit, parses form data into `Schedule`, `ChoreAssignee`. Calls `CreateChore` or `UpdateChore`. Cancels by setting parent view state to hide form.
- [ ] **Step 3: Commit**
```bash
git add src/Sis/Page/Chores.hs src/Sis/View/ChoreForm.hs
git commit -m "feat: add Chores page with ChoreForm HyperView"
```
---
### Task 9: Household & Activity Pages
**Files:** `src/Sis/Page/Household.hs` (create), `src/Sis/Page/Activity.hs` (create)
- [ ] **Step 1: Household page**
`HouseholdPage` HyperView with `Action = CreateInvite | RevokeInvite InviteId | CreateHousehold`. Shows member list with display name, email, role badge, initials avatar. If user has no households: show "Create Your Household" form. Owner actions: create invite (shows generated code), revoke invites.
- [ ] **Step 2: Activity Log page**
`ActivityLog` HyperView with `Action = GoToPage Int`. View state tracks current page number. Shows paginated entries (20/page): status badge (COMPLETED/SKIPPED), user name, chore name, date, time, optional note. Previous/Next buttons with page indicator.
- [ ] **Step 3: Commit**
```bash
git add src/Sis/Page/Household.hs src/Sis/Page/Activity.hs
git commit -m "feat: add Household and Activity Log pages"
```
---
### Task 10: Main.hs — Wire Everything Together
**Files:** `app/Main.hs` (rewrite)
- [ ] **Step 1: Create app entry point**
```haskell
module Main where
import Effectful
import Network.Wai.Handler.Warp qualified as Warp
import Network.Wai.Middleware.Static qualified as Static
import Sis.Database (openAndRunDB, runMigrations)
import Sis.Route
import Sis.View.Layout
main :: IO ()
main = do
let port = 8080
conn <- see Sis.Database openDatabase
Warp.run port $
Static.staticPolicy (Static.addBase "frontend/static") $
liveAppWith
(ServerOptions (document documentHead) defaultError defaultParseRequestBodyOptions)
(runDB conn $ routeRequest router)
router :: (Hyperbole :> es, DB :> es) => AppRoute -> Eff es Response
router RouteHome = redirect (routeUri RouteDashboard)
router RouteLogin = runPage Sis.Page.Login.page
router RouteSignup = runPage Sis.Page.Signup.page
router RouteDashboard = runPage Sis.Page.Dashboard.page
router RouteChores = runPage Sis.Page.Chores.page
router RouteHousehold = runPage Sis.Page.Household.page
router RouteActivity = runPage Sis.Page.Activity.page
```
- [ ] **Step 2: Move static files**
```bash
mkdir -p frontend/static
cp frontend/public/style.css frontend/static/style.css
cp frontend/public/manifest.json frontend/static/manifest.json
```
Update style.css: remove `#app` padding, set body margin to 0.
- [ ] **Step 3: Build and fix compilation errors**
```bash
./hs stack build 2>&1 | tail -40
```
Fix import/type/extension errors iteratively.
- [ ] **Step 4: Commit**
```bash
git add app/Main.hs frontend/static/
git commit -m "feat: wire up Hyperbole app entry point with all pages"
```
---
### Task 11: Cleanup — Delete TypeScript, Update Scripts, Docker, Docs
**Files:** Multiple deletes and modifies
- [ ] **Step 1: Delete frontend TypeScript**
```bash
rm -rf frontend/src frontend/index.html frontend/package.json frontend/package-lock.json frontend/tsconfig.json frontend/node_modules frontend/public frontend/dist
```
- [ ] **Step 2: Update scripts/build**
Remove npm steps. Just fourmolu, hlint, stack build.
- [ ] **Step 3: Update scripts/test**
Just hlint + stack test.
- [ ] **Step 4: Update scripts/run**
Simplify: use `stack exec sis-server` directly in Docker.
- [ ] **Step 5: Update Dockerfile**
Remove `ADD frontend/dist`. Just add binary and `frontend/static`. No npm build.
- [ ] **Step 6: Update test/Spec.hs**
Replace with a simple "compiles" test.
- [ ] **Step 7: Update README.md**
Replace frontend/backend sections. Describe Hyperbole stack, note zero application JavaScript.
- [ ] **Step 8: Update AGENTS.md**
Replace frontend conventions section:
```markdown
## Frontend Conventions
- **Framework:** [Hyperbole](https://github.com/seanhess/hyperbole) — Haskell serverside web framework
- **CSS:** [Neo Brutalism](https://unpkg.com/neobrutalismcss@latest) CDN + `frontend/static/style.css`
- **Build:** No npm/build step for frontend. All pages rendered in Haskell.
- **Interactive components:** HyperViews with typed Actions and server-side updates
```
Update project structure to show new module layout. Remove frontend/src/, add Sis/Page/ and Sis/View/ directories.
- [ ] **Step 9: Commit**
```bash
git add -A
git commit -m "chore: cleanup TypeScript, update scripts, Dockerfile, README, AGENTS"
```
---
### Task 12: Verify with Playwright
**Files:** None (verification only)
- [ ] **Step 1: Start the server**
```bash
./hs stack build && ./scripts/build
./scripts/run &
sleep 5
```
- [ ] **Step 2: Verify key flows with Playwright**
```bash
npx playwright test --project=chromium 2>&1
```
Or manually verify: login → dashboard → create chore → check off → view activity log.
- [ ] **Step 3: Fix any issues found**
Iterate on compilation/runtime bugs discovered during verification.
- [ ] **Step 4: Commit fixes**
```bash
git add -A
git commit -m "fix: address issues found during verification"
```
@@ -0,0 +1,292 @@
# Hyperbole Port Design
**Date:** 2026-07-15
**Status:** Draft
## Motivation
The current Sis architecture uses a Haskell JSON API backend (Orb/WAI) with a
TypeScript/Mithril.js SPA frontend. The JavaScript framework has issues with
routing and basic functionality. We want to eliminate JavaScript entirely by
porting to [Hyperbole](https://github.com/seanhess/hyperbole), a Haskell
serverside web framework inspired by HTMX, Elm, and Phoenix LiveView.
After the port, there will be zero application TypeScript/JavaScript in the
source code. Only Hyperbole's client runtime (~40KB gzipped) runs in the
browser, providing WebSocket connectivity and VirtualDOM patching.
## Key Decisions
- **API:** Remove the JSON API entirely. All interactivity happens over
Hyperbole's WebSocket channel with serverside-rendered HTML.
- **Build system:** Keep Stack. Add `hyperbole` and its dependencies to
`package.yaml` and `stack.yaml`.
- **Database:** Full effectful effect system. Create a custom `DB` effect
that wraps all SQLite operations, replacing the current raw
`SQL.Connection` passing.
- **Auth:** Use Hyperbole's built-in session mechanism (cookie-based, stored
in memory). Replaces the current custom cookie/SQLite session system.
- **CSS:** Keep Neo Brutalism CDN + thin custom CSS. Use Hyperbole's
`atomic-css` for inline styles where needed, but primarily use Neo
Brutalism class names.
- **UI:** Match the current UI look. No visual redesign. Make UI decisions
independently when questions arise, leaning on Neo Brutalism defaults.
## Architecture
Before:
```
Browser ←[HTTP GET]→ WAI static serving (SPA index.html + JS)
Browser ←[fetch JSON]→ WAI /api/* routes
Mithril SPA: routing, state, rendering all in TypeScript
```
After:
```
Browser ←[HTTP/WebSocket]→ Warp + Hyperbole
- Initial page: full HTML rendered serverside
- Interactions: WebSocket with VirtualDOM diffs
- All routing, state, rendering in Haskell
```
Module structure:
```
sis/
├── app/Main.hs # Hyperbole app entry, Warp setup, route dispatch
├── src/
│ ├── Sis.hs # Top-level re-exports
│ ├── Sis/Route.hs # Route ADT with Route instance
│ ├── Sis/Types.hs # Core domain types (Aeson instances removed)
│ ├── Sis/Database.hs # effectful DB effect, SQLite operations
│ ├── Sis/Auth.hs # Hyperbole session-based auth + password hashing
│ ├── Sis/Page/
│ │ ├── Login.hs # Login page
│ │ ├── Signup.hs # Signup page
│ │ ├── Dashboard.hs # Dashboard with stats + due/completed items
│ │ ├── Chores.hs # Chore list + create/edit form
│ │ ├── Household.hs # Members, invites, household management
│ │ └── Activity.hs # Activity log with pagination
│ ├── Sis/View/
│ │ ├── Layout.hs # Shell: document head, navbar, page wrapper
│ │ ├── ChoreForm.hs # Create/edit chore form (HyperView)
│ │ ├── ActivityModal.hs # Record activity form (HyperView)
│ │ └── Field.hs # Reusable form field helpers
│ └── Sis/Style.hs # CSS helpers for Neo Brutalism classes
├── frontend/
│ └── static/
│ ├── style.css # Thin custom CSS (nav, bg, animations)
│ └── manifest.json # PWA manifest (unchanged)
├── package.yaml # Updated deps (hyperbole, atomic-css, effectful)
├── stack.yaml # Updated resolver + extra-deps
└── Dockerfile # Updated (no npm build step)
```
Deleted:
- `frontend/src/` — all TypeScript code
- `src/Sis/Server.hs` — Orb/WAI routing replaced by Hyperbole pages
- Dependencies: orb, beeline-routing, shrubbery, json-fleece-aeson, json-fleece-core
## Routes
Flat route structure mapping to the current pages:
```haskell
data AppRoute
= RouteHome -- redirects based on auth status
| RouteLogin
| RouteSignup
| RouteDashboard
| RouteChores
| RouteHousehold
| RouteActivity
```
The `Route` typeclass generates URLs from constructor names: `/login`,
`/dashboard`, etc. No dynamic route segments needed — all interactions
happen within pages via HyperViews, not separate detail pages.
Router dispatches each route to a page handler:
```haskell
router RouteLogin = runPage Sis.Page.Login.page
router RouteSignup = runPage Sis.Page.Signup.page
router RouteDashboard = runPage Sis.Page.Dashboard.page
router RouteChores = runPage Sis.Page.Chores.page
router RouteHousehold = runPage Sis.Page.Household.page
router RouteActivity = runPage Sis.Page.Activity.page
```
Auth checking happens inside each protected page via `requireAuth`, which
reads user ID from Hyperbole's session. If not authenticated, redirects to
login.
## Pages
### Login Page (`Sis.Page.Login`)
- **`LoginForm`** HyperView with email, password, remember-me fields
- `Action = SubmitLogin Text Text Bool`
- On success: stores user ID in Hyperbole session, redirects to dashboard
- On failure: re-renders form with error message
- Navbar hidden on this page
- Link to signup via `route RouteSignup`
### Signup Page (`Sis.Page.Signup`)
- **`SignupForm`** HyperView with display name, email, password, confirm, agree-terms
- `Action = SubmitSignup Text Text Text Text Bool`
- Validates (password length, match, email uniqueness), creates user, creates session
- Link to login via `route RouteLogin`
### Dashboard (`Sis.Page.Dashboard`)
- **Single `DashboardPage` HyperView** wrapping all dashboard content
(stats tiles, due items, completed items). A single HyperView ensures
consistency when state changes across sections.
- `Action = RecordActivity OccurrenceId RecordActivityRequest | Refresh`
- Stat tiles: overdue count (red), due today (yellow), done this week (green)
- Due items list: each item shows chore name, assignee, status badge, and
"Check Off" button
- Clicking "Check Off" replaces the item row with an inline record-activity
form (status dropdown, optional note, notify checkbox, Save/Cancel
buttons)
- Completed items: read-only list of today's activities
- Link to full activity log
### Chores Page (`Sis.Page.Chores`)
- **`ChoreList` HyperView** — list of all chores for the household
- `Action ChoreList = DeleteChore ChoreId | StartCreate | StartEdit ChoreId`
- Each chore: name, schedule badge, schedule description, Edit/Delete buttons
- "New Chore" button inserts a **`ChoreForm` HyperView** inline
- `ChoreForm` actions: `Submit {fields} | Cancel`
- On submit, sends `pushEvent` to `ChoreList` to refresh
- Delete asks for confirmation via inline confirmation state in the HyperView
(no JS `confirm()`)
### Household Page (`Sis.Page.Household`)
- **`HouseholdPage` HyperView** — member list, invite management
- `Action = CreateInvite | RevokeInvite InviteId | CreateHousehold Text`
- Members list: avatar initials, name, email, role badge
- If user has no households: show "Create Your Household" form
- Owner-only actions: create invite link (shows generated code), revoke invites
- Invite codes displayed as `/invite/<code>` text
### Activity Log (`Sis.Page.Activity`)
- **`ActivityLog` HyperView** with pagination state
- `Action = GoToPage Int`
- Each entry: status badge, user name, chore name, date, time, optional note
- Previous/Next pagination buttons with current page indicator
- 20 entries per page
## Domain Types
`Sis/Types.hs` keeps all current types but **removes all Aeson instances**
(`ToJSON`, `FromJSON`, `ToJSONKey`, `FromJSONKey`). Types become pure
Haskell records and ADTs. New form data types will be added for Hyperbole
form handling (simple records with field names matching form inputs).
## Database Effect
A custom `effectful` effect `DB` replaces raw `SQL.Connection` passing and
direct SQL queries in route handlers:
```haskell
data DB :: Effect where
-- Auth
FindUserByEmail :: Text -> DB m (Maybe User)
CreateUser :: Text -> Text -> Text -> DB m UserId
-- Households
GetUserHouseholds :: UserId -> DB m [Household]
GetHousehold :: UserId -> HouseholdId -> DB m (Maybe Household)
CreateHousehold :: UserId -> Text -> DB m Household
GetMembers :: HouseholdId -> DB m [Membership]
-- Chores
GetChores :: HouseholdId -> DB m [Chore]
CreateChore :: HouseholdId -> CreateChoreRequest -> DB m Chore
UpdateChore :: ChoreId -> UpdateChoreRequest -> DB m Chore
DeleteChore :: ChoreId -> DB m ()
-- Dashboard & Activities
GetDashboard :: HouseholdId -> Day -> DB m Dashboard
GenerateOccurrences :: Chore -> DB m ()
RecordActivity :: OccurrenceId -> UserId -> RecordActivityRequest -> DB m Activity
GetActivityLog :: HouseholdId -> Int -> Int -> DB m ActivityLogPage
-- Invites
CreateInvite :: HouseholdId -> Maybe Text -> DB m Invite
GetInvites :: HouseholdId -> DB m [Invite]
RevokeInvite :: InviteId -> DB m ()
AcceptInvite :: UserId -> Text -> DB m Household
-- Seed
Seed :: DB m ()
```
The handler `runDB :: SQL.Connection -> Eff (DB : es) a -> IO (Eff es a)`
runs all DB operations against SQLite.
## Auth
Hyperbole's built-in `Session` effect stores per-session data keyed by
cookie:
- **Login:** Validate credentials, store `userId` in session
- **requireAuth:** Read `userId` from session, redirect to login if absent
- **Logout:** Delete session data
- **Password hashing:** Keep `Sis/Auth.hs` using `crypton`, same as current
## CSS & Styling
Neo Brutalism CSS loaded via CDN `<link>` in the document head. Thin custom
CSS (`frontend/static/style.css`) for:
- CSS variables (colors: red, yellow, green, orange)
- Body background (dot pattern)
- Navbar styling (border, shadow, layout, responsive)
- Modal overlay animation (fade-in)
- List item dividers
- Responsive breakpoints
Hyperbole views use `atomic-css` combinators for any additional inline
styles. Neo Brutalism class names set via attributes where needed.
## Implementation Phases
### Phase 1: Scaffold
- Add `hyperbole`, `atomic-css`, `effectful` to `package.yaml` and `stack.yaml`
- Create `app/Main.hs` with Hyperbole `main`, route definitions, document head
- Strip Aeson instances from `Types.hs`
- Verify a simple page renders
### Phase 2: Auth + Login/Signup
- Create `Sis/Database.hs` with `DB` effect and SQLite handler
- Implement Hyperbole session-based auth in `Sis/Auth.hs`
- Build Login and Signup pages
- Add `requireAuth` pattern
### Phase 3: Dashboard
- Build Dashboard page with stats, due items, completed items
- Implement record-activity workflow as inline form
### Phase 4: Chores
- Build Chore list with create/edit/delete
- Build ChoreForm as nested HyperView
### Phase 5: Household + Activity Log
- Build Household page with members, invites
- Build Activity Log page with pagination
### Phase 6: Cleanup
- Delete `frontend/src/` (all TypeScript)
- Remove Orb, beeline, shrubbery, json-fleece deps
- Update scripts, Dockerfile, README.md, AGENTS.md
## Tests
Current Haskell tests in `test/Spec.hs` test the API via HTTP. After the
port:
- DB effect operations will be testable in isolation with a test SQLite
connection
- Page rendering can be tested by running Hyperbole pages and checking
output
- Playwright tests (per AGENTS.md agent autonomy) verify end-to-end behavior
@@ -0,0 +1,23 @@
# Nav Button Styling: Use .nb-button.default
**Date:** 2026-07-15
## Summary
Change the CSS class on all navigation bar buttons in `frontend/src/index.ts` from `.nb-button` to `.nb-button.default` to use the default variant styling provided by the Neo Brutalism CSS framework.
## Changes
| Element | Current Class | New Class |
|---------|--------------|-----------|
| Dashboard nav link | `a.nb-button` | `a.nb-button.default` |
| Chores nav link | `a.nb-button` | `a.nb-button.default` |
| Household nav link | `a.nb-button` | `a.nb-button.default` |
| Activity nav link | `a.nb-button` | `a.nb-button.default` |
| Logout button | `button.nb-button` | `button.nb-button.default` |
## Scope
- **File:** `frontend/src/index.ts` only
- **Lines affected:** 5 consecutive lines in the `NavBar` component (currently lines 115-119)
- **No other changes** to styles, structure, or behavior
-22
View File
@@ -1,22 +0,0 @@
<!DOCTYPE html>
<html lang="en">
<head>
<meta charset="UTF-8">
<meta name="viewport" content="width=device-width, initial-scale=1.0">
<title>Sis — Household Chore Tracker</title>
<link rel="manifest" href="/manifest.json">
<link rel="stylesheet" href="https://unpkg.com/neobrutalismcss@latest">
<link rel="stylesheet" href="/style.css">
<script type="importmap">
{
"imports": {
"mithril": "https://esm.sh/mithril@2.2.13"
}
}
</script>
</head>
<body>
<div id="app"></div>
<script type="module" src="/index.js"></script>
</body>
</html>
-1089
View File
File diff suppressed because it is too large Load Diff
-19
View File
@@ -1,19 +0,0 @@
{
"name": "sis-frontend",
"version": "0.1.0",
"private": true,
"description": "Sis chore tracker SPA frontend",
"scripts": {
"build": "tsc && cp index.html dist/ && cp -r public/* dist/",
"dev": "tsc --watch",
"serve": "npx serve dist"
},
"dependencies": {
"mithril": "^2.2.13"
},
"devDependencies": {
"@types/mithril": "^2.2.7",
"typescript": "^5.7.0",
"serve": "^14.2.0"
}
}
-21
View File
@@ -1,21 +0,0 @@
/**
* Thin API client for the Sis backend.
*/
const BASE = "/api";
async function request<T>(path: string): Promise<T> {
const resp = await fetch(BASE + path);
if (!resp.ok) {
throw new Error(`HTTP ${resp.status}: ${resp.statusText}`);
}
return resp.json() as Promise<T>;
}
export interface HealthResponse {
message: string;
}
export function checkHealth(): Promise<string> {
return request<HealthResponse>("/health").then((r) => r.message);
}
-16
View File
@@ -1,16 +0,0 @@
import m, { Vnode } from "mithril";
interface AppAttrs {}
interface AppState {}
export const App: m.Component<AppAttrs, AppState> = {
view(_vnode: Vnode<AppAttrs, AppState>) {
return m(".nb-container", { style: { maxWidth: "640px", margin: "0 auto" } }, [
m(".nb-box", { style: { marginTop: "4rem", textAlign: "center", padding: "3rem 2rem" } }, [
m("h1", { class: "nb-font-heading1" }, "Sis"),
m("p", { class: "nb-font-heading2", style: { marginTop: "1rem", opacity: "0.7" } }, "For chores and stuff"),
]),
]);
},
};
-571
View File
@@ -1,571 +0,0 @@
import m, { Vnode, RouteDefs } from "mithril";
// ── Types ──────────────────────────────────────────────────────
interface User { id: number; displayName: string; email: string }
interface Household { id: number; name: string; owner: number; memberCount: number }
interface Membership { userId: number; displayName: string; email: string; role: string }
interface Invite { id: number; code: string; email: string | null; status: string; createdAt: string }
interface Chore {
id: number; householdId: number; name: string;
assignee: { type: string; userId?: number };
schedule: any; notifyOnDue: boolean; createdAt: string;
}
interface Occurrence { id: number; choreId: number; date: string; status: string }
interface DueItem { occurrence: Occurrence; choreName: string; assigneeName: string | null; isOverdue: boolean }
interface Activity { id: number; occurrenceId: number; userId: number; status: string; note: string | null; notifyHousehold: boolean; recordedAt: string }
interface CompletedItem { activity: Activity; userName: string; choreName: string }
interface DashboardData { stats: { overdue: number; dueToday: number; doneThisWeek: number }; dueItems: DueItem[]; completedItems: CompletedItem[] }
interface ActivityLogEntry { activity: Activity; userName: string; userEmail: string; choreName: string; occurrenceDate: string }
interface ActivityLogPage { entries: ActivityLogEntry[]; page: number; perPage: number; total: number }
interface AuthResponse { user: User; households: Household[] }
// ── Session ─────────────────────────────────────────────────────
const Session = {
user: null as User | null,
households: [] as Household[],
activeHouseholdId: null as number | null,
get activeHid() { return this.activeHouseholdId || (this.households[0]?.id ?? null) },
async load() {
try {
const r = await fetch("/api/auth/me");
if (r.ok) {
const d: AuthResponse = await r.json();
this.user = d.user; this.households = d.households;
if (!this.activeHouseholdId && d.households.length > 0) this.activeHouseholdId = d.households[0].id;
}
} catch (_) {}
},
async login(email: string, password: string, remember: boolean) {
const r = await fetch("/api/auth/login", { method: "POST", headers: { "Content-Type": "application/json" }, body: JSON.stringify({ email, password, rememberMe: remember }) });
if (!r.ok) { const e = await r.json(); throw new Error(e.error || "Login failed"); }
const d: AuthResponse = await r.json();
this.user = d.user; this.households = d.households;
if (!this.activeHouseholdId && d.households.length > 0) this.activeHouseholdId = d.households[0].id;
return d;
},
async signup(displayName: string, email: string, password: string, confirm: string, agree: boolean) {
const r = await fetch("/api/auth/signup", { method: "POST", headers: { "Content-Type": "application/json" }, body: JSON.stringify({ displayName, email, password, confirmPassword: confirm, agreeTerms: agree }) });
if (!r.ok) { const e = await r.json(); throw new Error(e.error || "Signup failed"); }
const d: AuthResponse = await r.json();
this.user = d.user; this.households = d.households;
if (!this.activeHouseholdId && d.households.length > 0) this.activeHouseholdId = d.households[0].id;
return d;
},
async logout() { await fetch("/api/auth/logout", { method: "POST" }); this.user = null; this.households = []; this.activeHouseholdId = null; m.route.set("/login"); },
switchHousehold(hid: number) { this.activeHouseholdId = hid; }
};
// ── Helpers ─────────────────────────────────────────────────────
function api<T>(path: string, opts?: RequestInit): Promise<T> {
return fetch("/api" + path, opts).then(async r => {
if (!r.ok) { const e = await r.json().catch(() => ({})); throw new Error(e.error || `HTTP ${r.status}`); }
return r.json();
});
}
function scheduleLabel(s: any): string {
if (!s) return "Sometime";
if (s.type === "one_off") return `One-off on ${s.date}`;
if (s.type === "recurring") return `Recurs ${s.period}${s.timeOfDay ? ` at ${s.timeOfDay}` : ""}`;
if (s.type === "sometime") return "Sometime";
return JSON.stringify(s);
}
function scheduleBadge(s: any): string {
if (!s) return "sometime";
return s.type === "one_off" ? "one-off" : s.type === "recurring" ? "recurring" : "sometime";
}
function initials(name: string): string {
return name.split(" ").map(w => w[0]).join("").toUpperCase().slice(0, 2);
}
function fmtDate(d: string): string {
return new Date(d).toLocaleDateString("en-US", { month: "short", day: "numeric", year: "numeric" });
}
function fmtTime(t: string): string {
return new Date(t).toLocaleTimeString("en-US", { hour: "2-digit", minute: "2-digit" });
}
// ── Layout ──────────────────────────────────────────────────────
const NavBar: m.Component = {
view() {
if (!Session.user) return null;
return m("nav.nb-navbar", { style: { marginBottom: "1.5rem" } }, [
m(".nb-navbar-start", [
m("span.nb-font-heading2", { style: { fontWeight: 700 } }, "Sis"),
Session.households.length > 0 ? m("select.nb-input", {
style: { marginLeft: "1rem", maxWidth: "200px" },
value: String(Session.activeHid ?? ""),
onchange: (e: Event) => { const t = e.target as HTMLSelectElement; Session.switchHousehold(Number(t.value)); }
}, Session.households.map(h => m("option", { value: String(h.id) }, h.name))) : null,
]),
m(".nb-navbar-end", [
m("a.nb-button", { href: "/dashboard", onclick: (e: Event) => { e.preventDefault(); m.route.set("/dashboard"); } }, "Dashboard"),
m("a.nb-button", { href: "/chores", onclick: (e: Event) => { e.preventDefault(); m.route.set("/chores"); }, style: { marginLeft: "0.5rem" } }, "Chores"),
m("a.nb-button", { href: "/household", onclick: (e: Event) => { e.preventDefault(); m.route.set("/household"); }, style: { marginLeft: "0.5rem" } }, "Household"),
m("a.nb-button", { href: "/activity", onclick: (e: Event) => { e.preventDefault(); m.route.set("/activity"); }, style: { marginLeft: "0.5rem" } }, "Activity"),
m("button.nb-button", { style: { marginLeft: "1rem" }, onclick: () => Session.logout() }, "Logout"),
])
]);
}
};
// ── Login Page ──────────────────────────────────────────────────
interface LoginState { email: string; password: string; remember: boolean; error: string; loading: boolean }
const LoginPage: m.Component<{}, LoginState> = {
oninit(v) {
v.state.email = ""; v.state.password = "";
v.state.remember = false; v.state.error = ""; v.state.loading = false;
},
view(v) {
const s = v.state;
async function submit() {
s.error = ""; s.loading = true; m.redraw();
try {
await Session.login(s.email, s.password, s.remember);
m.route.set(Session.households.length > 0 ? "/dashboard" : "/household");
} catch (e: any) { s.error = e.message; }
s.loading = false; m.redraw();
}
return m(".nb-container", { style: { maxWidth: "480px", margin: "4rem auto" } }, [
m(".nb-box", { style: { padding: "2rem" } }, [
m("h1.nb-font-heading1", "Welcome Back"),
m("p", { style: { opacity: 0.7, marginBottom: "1.5rem" } }, "Log in to manage your household chores."),
s.error ? m(".nb-box", { style: { borderColor: "var(--nb-red)", color: "var(--nb-red)", padding: "0.5rem", marginBottom: "1rem" } }, s.error) : null,
m("label.nb-label", "Email"),
m("input.nb-input[type=email]", { value: s.email, oninput: (e: Event) => { s.email = (e.target as HTMLInputElement).value; }, style: { marginBottom: "1rem", width: "100%" } }),
m("label.nb-label", "Password"),
m("input.nb-input[type=password]", { value: s.password, oninput: (e: Event) => { s.password = (e.target as HTMLInputElement).value; }, style: { marginBottom: "1rem", width: "100%" } }),
m("label", { style: { display: "flex", alignItems: "center", gap: "0.5rem", marginBottom: "1rem" } }, [
m("input[type=checkbox]", { checked: s.remember, onchange: (e: Event) => { s.remember = (e.target as HTMLInputElement).checked; } }),
"Remember me"
]),
m("button.nb-button", { style: { width: "100%", marginBottom: "1rem" }, disabled: s.loading, onclick: submit }, s.loading ? "Logging in..." : "Log In"),
m("p", { style: { textAlign: "center" } }, [
"Don't have an account? ", m("a", { href: "/signup", onclick: (e: Event) => { e.preventDefault(); m.route.set("/signup"); } }, "Sign Up")
]),
])
]);
}
};
// ── Signup Page ─────────────────────────────────────────────────
interface SignupState { displayName: string; email: string; password: string; confirm: string; agree: boolean; error: string; loading: boolean }
const SignupPage: m.Component<{}, SignupState> = {
oninit(v) {
v.state.displayName = ""; v.state.email = ""; v.state.password = "";
v.state.confirm = ""; v.state.agree = false; v.state.error = ""; v.state.loading = false;
},
view(v) {
const s = v.state;
async function submit() {
s.error = ""; s.loading = true; m.redraw();
try {
await Session.signup(s.displayName, s.email, s.password, s.confirm, s.agree);
m.route.set("/dashboard");
} catch (e: any) { s.error = e.message; }
s.loading = false; m.redraw();
}
return m(".nb-container", { style: { maxWidth: "480px", margin: "4rem auto" } }, [
m(".nb-box", { style: { padding: "2rem" } }, [
m("h1.nb-font-heading1", "Create Account"),
m("p", { style: { opacity: 0.7, marginBottom: "1.5rem" } }, "Join your household chore tracker."),
s.error ? m(".nb-box", { style: { borderColor: "var(--nb-red)", color: "var(--nb-red)", padding: "0.5rem", marginBottom: "1rem" } }, s.error) : null,
m("label.nb-label", "Display Name"),
m("input.nb-input", { value: s.displayName, oninput: (e: Event) => { s.displayName = (e.target as HTMLInputElement).value; }, style: { width: "100%", marginBottom: "1rem" } }),
m("label.nb-label", "Email"),
m("input.nb-input[type=email]", { value: s.email, oninput: (e: Event) => { s.email = (e.target as HTMLInputElement).value; }, style: { width: "100%", marginBottom: "1rem" } }),
m("label.nb-label", "Password (min 8 characters)"),
m("input.nb-input[type=password]", { value: s.password, oninput: (e: Event) => { s.password = (e.target as HTMLInputElement).value; }, style: { width: "100%", marginBottom: "1rem" } }),
m("label.nb-label", "Confirm Password"),
m("input.nb-input[type=password]", { value: s.confirm, oninput: (e: Event) => { s.confirm = (e.target as HTMLInputElement).value; }, style: { width: "100%", marginBottom: "1rem" } }),
m("label", { style: { display: "flex", alignItems: "center", gap: "0.5rem", marginBottom: "1rem" } }, [
m("input[type=checkbox]", { checked: s.agree, onchange: (e: Event) => { s.agree = (e.target as HTMLInputElement).checked; } }),
"I agree to the terms of service"
]),
m("button.nb-button", { style: { width: "100%" }, disabled: s.loading, onclick: submit }, s.loading ? "Creating..." : "Sign Up"),
m("p", { style: { textAlign: "center", marginTop: "1rem" } }, [m("a", { href: "/login", onclick: (e: Event) => { e.preventDefault(); m.route.set("/login"); } }, "Already have an account? Log In")]),
])
]);
}
};
// ── Dashboard ───────────────────────────────────────────────────
const DashboardPage: m.Component = {
oninit() { loadDashboard(); },
view() { return DashboardView(); }
};
let dashData: DashboardData | null = null, dashLoading = true;
async function loadDashboard() {
if (!Session.activeHid) return;
dashLoading = true; m.redraw();
try { dashData = await api<DashboardData>(`/households/${Session.activeHid}/dashboard`); }
catch (_) { dashData = null; }
dashLoading = false; m.redraw();
}
function DashboardView() {
if (!Session.user) { m.route.set("/login"); return null; }
if (dashLoading) return m(".nb-container", { style: { maxWidth: "960px", margin: "0 auto" } }, m("p", "Loading..."));
const h = Session.households.find(h => h.id === Session.activeHid);
const dueItems = dashData?.dueItems ?? [];
const completedItems = dashData?.completedItems ?? [];
const stats = dashData?.stats ?? { overdue: 0, dueToday: 0, doneThisWeek: 0 };
return m(".nb-container", { style: { maxWidth: "960px", margin: "0 auto" } }, [
m("h1.nb-font-heading1", [h?.name ?? "Dashboard", m("span", { style: { fontSize: "1rem", opacity: 0.5, marginLeft: "1rem" } }, new Date().toLocaleDateString("en-US", { weekday: "long", month: "long", day: "numeric" }))]),
// Stat tiles
m(".nb-row", { style: { marginBottom: "1.5rem", gap: "1rem" } }, [
m(".nb-box", { style: { flex: "1", textAlign: "center", padding: "1rem", borderColor: stats.overdue > 0 ? "var(--nb-red)" : undefined } }, [m(".nb-font-heading1", String(stats.overdue)), m("span", "Overdue")]),
m(".nb-box", { style: { flex: "1", textAlign: "center", padding: "1rem", borderColor: "var(--nb-yellow)" } }, [m(".nb-font-heading1", String(stats.dueToday)), m("span", "Due Today")]),
m(".nb-box", { style: { flex: "1", textAlign: "center", padding: "1rem", borderColor: "var(--nb-green)" } }, [m(".nb-font-heading1", String(stats.doneThisWeek)), m("span", "Done This Week")]),
]),
// Due items
m("h2.nb-font-heading2", "Overdue & Due Today"),
dueItems.length === 0 ? m("p", { style: { opacity: 0.5 } }, "Nothing due! Great job.") :
m(".nb-box", { style: { marginBottom: "1.5rem" } },
dueItems.map(d => m(".nb-list-item", { style: { display: "flex", justifyContent: "space-between", alignItems: "center", padding: "0.5rem" } }, [
m("span", [
m("span.nb-badge", { style: { marginRight: "0.5rem", background: d.isOverdue ? "var(--nb-red)" : "var(--nb-yellow)", color: "#000" } }, d.isOverdue ? "OVERDUE" : "DUE"),
d.choreName,
d.assigneeName ? m("span", { style: { opacity: 0.5, marginLeft: "0.5rem" } }, `(${d.assigneeName})`) : null,
]),
m("button.nb-button", { style: { fontSize: "0.85rem" }, onclick: () => recordActivity(d.occurrence.id, d.choreName) }, "Check Off"),
]))
),
// Completed today
m("h2.nb-font-heading2", "Completed Today"),
completedItems.length === 0 ? m("p", { style: { opacity: 0.5 } }, "No activity recorded today.") :
m(".nb-box", completedItems.map(c => m(".nb-list-item", { style: { padding: "0.5rem" } }, [
m("span.nb-badge", { style: { marginRight: "0.5rem", background: "var(--nb-green)", color: "#000" } }, c.activity.status.toUpperCase()),
`${c.userName} ${c.activity.status} ${c.choreName} at ${fmtTime(c.activity.recordedAt)}`,
c.activity.note ? m("span", { style: { opacity: 0.5, marginLeft: "0.5rem" } }, `— "${c.activity.note}"`) : null,
]))),
m("a.nb-button", { href: "/activity", onclick: (e: Event) => { e.preventDefault(); m.route.set("/activity"); } }, "View Full Activity Log"),
]);
}
// ── Record Activity ─────────────────────────────────────────────
function recordActivity(occurrenceId: number, choreName: string) {
let status = "completed", note = "", notify = false, error = "", saving = false;
async function submit() {
saving = true; error = ""; m.redraw();
try {
await api(`/occurrences/${occurrenceId}/activity`, {
method: "POST", headers: { "Content-Type": "application/json" },
body: JSON.stringify({ status, note: note || null, notifyHousehold: notify })
});
loadDashboard();
} catch (e: any) { error = e.message; }
saving = false; m.redraw();
}
const modal = m(".nb-modal-overlay", { style: { position: "fixed", top: 0, left: 0, right: 0, bottom: 0, background: "rgba(0,0,0,0.5)", display: "flex", alignItems: "center", justifyContent: "center", zIndex: 100 } },
m(".nb-box", { style: { background: "#fff9e6", padding: "2rem", maxWidth: "480px", width: "100%" } }, [
m("h2.nb-font-heading2", "Record Activity"),
m("p", `Chore: ${choreName}`),
error ? m("p", { style: { color: "var(--nb-red)" } }, error) : null,
m("label.nb-label", "Status"),
m("select.nb-input", { value: status, onchange: (e: Event) => { status = (e.target as HTMLSelectElement).value; }, style: { width: "100%", marginBottom: "1rem" } },
[m("option", { value: "completed" }, "Completed"), m("option", { value: "skipped" }, "Skipped")]),
m("label.nb-label", "Note (optional)"),
m("textarea.nb-input", { value: note, oninput: (e: Event) => { note = (e.target as HTMLTextAreaElement).value; }, style: { width: "100%", marginBottom: "1rem", minHeight: "60px" } }),
m("label", { style: { display: "flex", alignItems: "center", gap: "0.5rem", marginBottom: "1rem" } }, [
m("input[type=checkbox]", { checked: notify, onchange: (e: Event) => { notify = (e.target as HTMLInputElement).checked; } }),
"Notify household of this update"
]),
m("div", { style: { display: "flex", gap: "0.5rem" } }, [
m("button.nb-button", { disabled: saving, onclick: submit }, saving ? "Saving..." : "Save"),
m("button.nb-button", { style: { background: "#ccc" }, onclick: () => { m.redraw(); } }, "Cancel"),
])
])
);
// Render modal and re-render to dismiss
m.mount(document.getElementById("modal") || document.createElement("div"), { view: () => modal });
if (!document.getElementById("modal")) {
const d = document.createElement("div"); d.id = "modal"; document.body.appendChild(d);
m.mount(d, { view: () => modal });
}
}
// ── Chores Page ─────────────────────────────────────────────────
const ChoresPage: m.Component = {
oninit() { loadChores(); },
view() { return ChoresView(); }
};
let chores: Chore[] = [], choresLoading = true;
async function loadChores() {
if (!Session.activeHid) return;
choresLoading = true; m.redraw();
try { chores = await api<Chore[]>(`/households/${Session.activeHid}/chores`); }
catch (_) { chores = []; }
choresLoading = false; m.redraw();
}
function ChoresView() {
if (!Session.user) { m.route.set("/login"); return null; }
if (choresLoading) return m(".nb-container", { style: { maxWidth: "960px", margin: "0 auto" } }, m("p", "Loading..."));
return m(".nb-container", { style: { maxWidth: "960px", margin: "0 auto" } }, [
m("div", { style: { display: "flex", justifyContent: "space-between", alignItems: "center", marginBottom: "1rem" } }, [
m("h1.nb-font-heading1", "Chores"),
m("button.nb-button", { onclick: () => showChoreForm() }, "+ New Chore"),
]),
chores.length === 0 ? m("p", { style: { opacity: 0.5 } }, "No chores yet. Create one to get started!") :
m(".nb-box", chores.map(c => m(".nb-list-item", { style: { display: "flex", justifyContent: "space-between", alignItems: "center", padding: "0.5rem" } }, [
m("span", [
m("span.nb-badge", { style: { marginRight: "0.5rem" } }, scheduleBadge(c.schedule)),
c.name,
m("span", { style: { opacity: 0.5, marginLeft: "0.5rem", fontSize: "0.85rem" } }, scheduleLabel(c.schedule)),
]),
m("div", { style: { display: "flex", gap: "0.25rem" } }, [
m("button.nb-button", { style: { fontSize: "0.8rem", padding: "0.25rem 0.5rem" }, onclick: () => showChoreForm(c) }, "Edit"),
m("button.nb-button", { style: { fontSize: "0.8rem", padding: "0.25rem 0.5rem", background: "var(--nb-red)" }, onclick: () => deleteChore(c.id) }, "Delete"),
])
]))),
]);
}
async function deleteChore(id: number) {
if (!confirm("Delete this chore?")) return;
await api(`/households/${Session.activeHid}/chores/${id}`, { method: "DELETE" });
loadChores();
}
function showChoreForm(edit?: Chore) {
let name = edit?.name ?? "", scheduleType = edit?.schedule?.type ?? "recurring",
date = edit?.schedule?.date ?? "", timeOfDay = edit?.schedule?.timeOfDay ?? "",
period = edit?.schedule?.period ?? "daily", notify = edit?.notifyOnDue ?? false,
assigneeType = edit?.assignee?.type ?? "anyone", assigneeUserId = edit?.assignee?.userId ?? null,
saving = false, error = "";
async function submit() {
saving = true; error = ""; m.redraw();
let schedule: any;
if (scheduleType === "one_off") schedule = { type: "one_off", date, time: timeOfDay || null };
else if (scheduleType === "recurring") schedule = { type: "recurring", period, startDate: date, timeOfDay: timeOfDay || null, daysOfWeek: null, daysOfMonth: null };
else schedule = { type: "sometime" };
const body = { name, assignee: { type: assigneeType, ...(assigneeType === "user" ? { userId: assigneeUserId } : {}) }, schedule, notifyOnDue: notify };
try {
if (edit) await api(`/households/${Session.activeHid}/chores/${edit.id}`, { method: "PUT", headers: { "Content-Type": "application/json" }, body: JSON.stringify(body) });
else await api(`/households/${Session.activeHid}/chores`, { method: "POST", headers: { "Content-Type": "application/json" }, body: JSON.stringify(body) });
loadChores();
} catch (e: any) { error = e.message; saving = false; m.redraw(); return; }
}
const modal = m(".nb-modal-overlay", { style: { position: "fixed", top: 0, left: 0, right: 0, bottom: 0, background: "rgba(0,0,0,0.5)", display: "flex", alignItems: "center", justifyContent: "center", zIndex: 100 } },
m(".nb-box", { style: { background: "#fff9e6", padding: "2rem", maxWidth: "520px", width: "100%", maxHeight: "90vh", overflow: "auto" } }, [
m("h2.nb-font-heading2", edit ? "Edit Chore" : "New Chore"),
error ? m("p", { style: { color: "var(--nb-red)" } }, error) : null,
m("label.nb-label", "Name"), m("input.nb-input", { value: name, oninput: (e: Event) => { name = (e.target as HTMLInputElement).value; }, style: { width: "100%", marginBottom: "1rem" } }),
m("label.nb-label", "Assign To"), m("select.nb-input", { value: assigneeType, onchange: (e: Event) => { assigneeType = (e.target as HTMLSelectElement).value; }, style: { width: "100%", marginBottom: "1rem" } },
[m("option", { value: "anyone" }, "Anyone in household"), m("option", { value: "user" }, "Specific member")]),
m("label.nb-label", "Schedule Type"), m("select.nb-input", { value: scheduleType, onchange: (e: Event) => { scheduleType = (e.target as HTMLSelectElement).value; }, style: { width: "100%", marginBottom: "1rem" } },
[m("option", { value: "recurring" }, "Recurring"), m("option", { value: "one_off" }, "One-off"), m("option", { value: "sometime" }, "Sometime")]),
scheduleType !== "sometime" ? [m("label.nb-label", "Start Date"), m("input.nb-input[type=date]", { value: date, oninput: (e: Event) => { date = (e.target as HTMLInputElement).value; }, style: { width: "100%", marginBottom: "1rem" } })] : null,
scheduleType !== "sometime" ? [m("label.nb-label", "Time of Day (optional)"), m("input.nb-input[type=time]", { value: timeOfDay, oninput: (e: Event) => { timeOfDay = (e.target as HTMLInputElement).value; }, style: { width: "100%", marginBottom: "1rem" } })] : null,
scheduleType === "recurring" ? [m("label.nb-label", "Period"), m("select.nb-input", { value: period, onchange: (e: Event) => { period = (e.target as HTMLSelectElement).value; }, style: { width: "100%", marginBottom: "1rem" } },
[m("option", { value: "daily" }, "Daily"), m("option", { value: "weekly" }, "Weekly"), m("option", { value: "monthly" }, "Monthly")])] : null,
m("label", { style: { display: "flex", alignItems: "center", gap: "0.5rem", marginBottom: "1rem" } }, [
m("input[type=checkbox]", { checked: notify, onchange: (e: Event) => { notify = (e.target as HTMLInputElement).checked; } }),
"Send push reminder when due"
]),
m("div", { style: { display: "flex", gap: "0.5rem" } }, [
m("button.nb-button", { disabled: saving, onclick: submit }, saving ? "Saving..." : "Save"),
m("button.nb-button", { style: { background: "#ccc" }, onclick: () => { m.redraw(); } }, "Cancel"),
]),
])
);
// Use modal div
if (!document.getElementById("modal")) { const d = document.createElement("div"); d.id = "modal"; document.body.appendChild(d); }
m.mount(document.getElementById("modal")!, { view: () => modal });
}
// ── Household Page ──────────────────────────────────────────────
interface HHPgState { name: string; creating: boolean }
const HouseholdPage: m.Component<{}, HHPgState> = {
oninit(v) {
v.state.name = ""; v.state.creating = false;
},
view(v) { return HouseholdView(v.state); }
};
let members: Membership[] = [], invites: Invite[] = [], hhLoading = true;
async function loadHousehold() {
if (!Session.activeHid) return;
hhLoading = true; m.redraw();
try {
members = await api<Membership[]>(`/households/${Session.activeHid}/members`);
invites = await api<Invite[]>(`/households/${Session.activeHid}/invites`);
} catch (_) { members = []; invites = []; }
hhLoading = false; m.redraw();
}
function HouseholdView(s: HHPgState) {
if (!Session.user) { m.route.set("/login"); return null; }
if (hhLoading) { loadHousehold(); return m(".nb-container", { style: { maxWidth: "960px", margin: "0 auto" } }, m("p", "Loading...")); }
const h = Session.households.find(h => h.id === Session.activeHid);
const isOwner = members.some(m => m.userId === Session.user!.id && m.role === "owner");
// If no households, show create form
if (Session.households.length === 0) {
async function create() {
s.creating = true; m.redraw();
await api("/households", { method: "POST", headers: { "Content-Type": "application/json" }, body: JSON.stringify({ name: s.name }) });
await Session.load();
s.creating = false; m.redraw();
}
return m(".nb-container", { style: { maxWidth: "480px", margin: "4rem auto" } }, [
m(".nb-box", { style: { padding: "2rem", textAlign: "center" } }, [
m("h1.nb-font-heading1", "Create Your Household"),
m("p", { style: { marginBottom: "1rem" } }, "You need a household to get started."),
m("input.nb-input", { value: s.name, oninput: (e: Event) => { s.name = (e.target as HTMLInputElement).value; }, placeholder: "Household name", style: { width: "100%", marginBottom: "1rem" } }),
m("button.nb-button", { disabled: s.creating, onclick: create }, s.creating ? "Creating..." : "Create Household"),
])
]);
}
return m(".nb-container", { style: { maxWidth: "960px", margin: "0 auto" } }, [
m("h1.nb-font-heading1", h?.name ?? "Household"),
m("p", { style: { opacity: 0.7 } }, `${members.length} member${members.length !== 1 ? "s" : ""}`),
// Members
m("h2.nb-font-heading2", "Members"),
m(".nb-box", { style: { marginBottom: "1.5rem" } },
members.map((mem: Membership) => m(".nb-list-item", { style: { display: "flex", justifyContent: "space-between", alignItems: "center", padding: "0.5rem" } }, [
m("span", [
m("span.nb-badge", { style: { marginRight: "0.5rem", borderRadius: "50%", width: "2rem", height: "2rem", display: "inline-flex", alignItems: "center", justifyContent: "center", fontSize: "0.8rem" } }, initials(mem.displayName)),
m.trust(`<strong>${mem.displayName}</strong>`),
m("span", { style: { opacity: 0.5, marginLeft: "0.5rem" } }, mem.email),
]),
m("span.nb-badge", { style: mem.role === "owner" ? { background: "var(--nb-yellow)", color: "#000" } : {} }, mem.role.toUpperCase()),
]))
),
// Invites
isOwner ? [
m("h2.nb-font-heading2", "Invite Members"),
m(".nb-box", { style: { marginBottom: "1.5rem" } }, [
m("p", { style: { marginBottom: "0.5rem" } }, "Create an invite link to share:"),
m("button.nb-button", { onclick: createInvite }, "+ Create Invite Link"),
invites.length > 0 ? m("div", { style: { marginTop: "1rem" } }, [
m("h3", "Pending Invites"),
...invites.filter(i => i.status === "pending").map(i => m(".nb-list-item", { style: { display: "flex", justifyContent: "space-between", padding: "0.5rem" } }, [
m("code", { style: { fontSize: "0.85rem" } }, `/invite/${i.code}`),
m("button.nb-button", { style: { fontSize: "0.8rem", background: "var(--nb-red)" }, onclick: () => revokeInvite(i.id) }, "Revoke"),
]))
]) : null,
])
] : null,
]);
}
async function createInvite() {
await api(`/households/${Session.activeHid}/invites`, { method: "POST", headers: { "Content-Type": "application/json" }, body: JSON.stringify({ email: null }) });
loadHousehold();
}
async function revokeInvite(id: number) {
await api(`/households/${Session.activeHid}/invites/${id}`, { method: "DELETE" });
loadHousehold();
}
// ── Activity Log Page ───────────────────────────────────────────
const ActivityPage: m.Component = {
view() { return ActivityView(); }
};
let actPage: ActivityLogPage | null = null, actLoading = true;
async function loadActivityLog(page = 1) {
if (!Session.activeHid) return;
actLoading = true; m.redraw();
try { actPage = await api<ActivityLogPage>(`/households/${Session.activeHid}/activity?page=${page}&perPage=20`); }
catch (_) { actPage = null; }
actLoading = false; m.redraw();
}
function ActivityView() {
if (!Session.user) { m.route.set("/login"); return null; }
if (actLoading) { loadActivityLog(); return m(".nb-container", { style: { maxWidth: "960px", margin: "0 auto" } }, m("p", "Loading...")); }
return m(".nb-container", { style: { maxWidth: "960px", margin: "0 auto" } }, [
m("h1.nb-font-heading1", "Activity Log"),
actPage && actPage.entries.length === 0 ? m("p", { style: { opacity: 0.5 } }, "No activity recorded yet.") :
m(".nb-box", (actPage?.entries ?? []).map(e => m(".nb-list-item", { style: { padding: "0.5rem" } }, [
m("span.nb-badge", { style: { marginRight: "0.5rem", background: e.activity.status === "completed" ? "var(--nb-green)" : "var(--nb-orange)", color: "#000" } }, e.activity.status.toUpperCase()),
m.trust(`<strong>${e.userName}</strong>`), ` ${e.activity.status} `, m.trust(`<strong>${e.choreName}</strong>`),
m("span", { style: { opacity: 0.5, marginLeft: "0.5rem" } }, `on ${fmtDate(e.occurrenceDate)} at ${fmtTime(e.activity.recordedAt)}`),
e.activity.note ? m("span", { style: { opacity: 0.5, fontStyle: "italic", marginLeft: "0.5rem" } }, `"${e.activity.note}"`) : null,
]))),
actPage && actPage.entries.length > 0 && actPage.total > actPage.perPage ? m("div", { style: { marginTop: "1rem", display: "flex", gap: "0.5rem", justifyContent: "center" } }, [
m("button.nb-button", { disabled: actPage!.page <= 1, onclick: () => loadActivityLog(actPage!.page - 1) }, "Previous"),
m("span", { style: { alignSelf: "center" } }, `Page ${actPage!.page} of ${Math.ceil(actPage!.total / actPage!.perPage)}`),
m("button.nb-button", { disabled: actPage!.page >= Math.ceil(actPage!.total / actPage!.perPage), onclick: () => loadActivityLog(actPage!.page + 1) }, "Next"),
]) : null,
]);
}
// ── App Shell ───────────────────────────────────────────────────
const AppShell: m.Component = {
view(v: Vnode) {
return m("div", [m(NavBar), m(".nb-container", { style: { maxWidth: "960px", margin: "0 auto" } }, v.children)]);
}
};
// ── Router ──────────────────────────────────────────────────────
const routes: RouteDefs = {
"/login": { onmatch: () => { if (Session.user) { m.route.set("/dashboard"); return; } }, render: () => m(AppShell, m(LoginPage)) },
"/signup": { onmatch: () => { if (Session.user) { m.route.set("/dashboard"); return; } }, render: () => m(AppShell, m(SignupPage)) },
"/dashboard": { onmatch: checkAuth, render: () => m(AppShell, m(DashboardPage)) },
"/chores": { onmatch: checkAuth, render: () => m(AppShell, m(ChoresPage)) },
"/household": { onmatch: checkAuth, render: () => m(AppShell, m(HouseholdPage)) },
"/activity": { onmatch: checkAuth, render: () => m(AppShell, m(ActivityPage)) },
};
function checkAuth(): Promise<void> | void {
if (Session.user) return;
return Session.load().then(() => { if (!Session.user) m.route.set("/login"); });
}
// ── Mount ───────────────────────────────────────────────────────
const root = document.getElementById("app");
if (root) {
m.route(root, "/login", routes);
Session.load();
}
@@ -12,35 +12,34 @@ body {
background: #fff9e6; background: #fff9e6;
background-image: radial-gradient(circle, rgba(0,0,0,0.03) 1px, transparent 1px); background-image: radial-gradient(circle, rgba(0,0,0,0.03) 1px, transparent 1px);
background-size: 20px 20px; background-size: 20px 20px;
margin: 0;
padding: 0;
} }
#app { /* Override NB navbar to have drop shadow like our design */
padding: 1rem;
}
.nb-container {
padding: 0 1rem;
}
.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; .nb-list-item {
align-items: center; border-bottom: 1px solid rgba(0,0,0,0.1);
gap: 0.5rem; padding: 0.5rem;
}
.nb-list-item:last-child {
border-bottom: none;
} }
.nb-modal-overlay { /* Stat tiles */
animation: fadeIn 0.15s ease; .stat-tile {
text-align: center;
padding: 1rem;
}
/* Container padding */
.nb-container {
padding: 0 1rem;
} }
@keyframes fadeIn { @keyframes fadeIn {
@@ -55,18 +54,8 @@ body {
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;
} }
.nb-row {
flex-direction: column;
}
}
.nb-list-item {
border-bottom: 1px solid rgba(0,0,0,0.1);
}
.nb-list-item:last-child {
border-bottom: none;
} }
-18
View File
@@ -1,18 +0,0 @@
{
"compilerOptions": {
"target": "ES2020",
"module": "ES2020",
"moduleResolution": "bundler",
"strict": true,
"esModuleInterop": true,
"skipLibCheck": true,
"forceConsistentCasingInFileNames": true,
"outDir": "dist",
"rootDir": "src",
"sourceMap": true,
"jsx": "react",
"jsxFactory": "m",
"jsxFragmentFactory": "m.Fragment"
},
"include": ["src/**/*.ts"]
}
+72
View File
@@ -0,0 +1,72 @@
{
"name": "sis",
"lockfileVersion": 3,
"requires": true,
"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",
"integrity": "sha512-xiqMQR4xAeHTuB9uWm+fFRcIOgKBMiOBP+eXiyT7jsgVCq1bkVygt00oASowB7EdtpOHaaPgKt812P9ab+DDKA==",
"hasInstallScript": true,
"license": "MIT",
"optional": true,
"os": [
"darwin"
],
"engines": {
"node": "^8.16.0 || ^10.6.0 || >=11.0.0"
}
},
"node_modules/playwright": {
"version": "1.61.1",
"resolved": "https://registry.npmjs.org/playwright/-/playwright-1.61.1.tgz",
"integrity": "sha512-DWnY5o3YbLWK4GovuAVwpqL+1VwGNdUGrRr++8j8PtQQzvAVZUIMjKQ90fY689sEJZJBbZVw1rXaOKSTitkzPQ==",
"license": "Apache-2.0",
"dependencies": {
"playwright-core": "1.61.1"
},
"bin": {
"playwright": "cli.js"
},
"engines": {
"node": ">=18"
},
"optionalDependencies": {
"fsevents": "2.3.2"
}
},
"node_modules/playwright-core": {
"version": "1.61.1",
"resolved": "https://registry.npmjs.org/playwright-core/-/playwright-core-1.61.1.tgz",
"integrity": "sha512-h7Qlt6m4REp25qvIdvbDtVmD4LqVXfpRxhORv9L0jzETM05p4fuPJ3dKyuSXQxDSbXnmS79HAgi9589lGSpLkg==",
"license": "Apache-2.0",
"bin": {
"playwright-core": "cli.js"
},
"engines": {
"node": ">=18"
}
}
}
}
+6
View File
@@ -0,0 +1,6 @@
{
"dependencies": {
"@playwright/test": "^1.61.1",
"playwright": "^1.61.1"
}
}
+15 -16
View File
@@ -2,20 +2,22 @@ name: sis-server
version: 0.1.0 version: 0.1.0
synopsis: Shared household chore/task tracker synopsis: Shared household chore/task tracker
description: A todo tracker for households and groups with shared description: A todo tracker for households and groups with shared
repeated responsibilities. JSON API backend for a repeated responsibilities. Pure Haskell Hyperbole web
Mithril.js SPA frontend. application.
author: James Brechtel author: James Brechtel
maintainer: james@flipstone.com maintainer: james@flipstone.com
copyright: 2026 James Brechtel copyright: 2026 James Brechtel
license: BSD-3-Clause license: BSD-3-Clause
default-extensions: default-extensions:
- DataKinds
- DerivingStrategies - DerivingStrategies
- ImportQualifiedPost - ImportQualifiedPost
- LambdaCase - LambdaCase
- OverloadedStrings - OverloadedStrings
- RecordWildCards - RecordWildCards
- TupleSections - TupleSections
- TypeFamilies
ghc-options: ghc-options:
- -Wall - -Wall
@@ -30,35 +32,31 @@ ghc-options:
dependencies: dependencies:
- base >= 4.7 && < 5 - base >= 4.7 && < 5
- aeson
- beeline-routing
- bytestring - bytestring
- containers - containers
- directory - directory
- effectful
- filepath - filepath
- http-types - http-types
- json-fleece-aeson
- json-fleece-core
- mtl
- optparse-applicative
- safe-exceptions
- shrubbery
- text - text
- time - time
- wai - wai
- wai-extra
- warp - warp
library: library:
source-dirs: src source-dirs: src
dependencies: dependencies:
- aeson
- atomic-css
- base64-bytestring - base64-bytestring
- cookie
- crypton - crypton
- data-default
- effectful-core
- hyperbole
- memory - memory
- orb
- random - random
- sqlite-simple - sqlite-simple
- string-conversions
executables: executables:
sis-server: sis-server:
@@ -69,10 +67,11 @@ executables:
- -rtsopts - -rtsopts
- -with-rtsopts=-N - -with-rtsopts=-N
dependencies: dependencies:
- optparse-applicative - effectful
- orb - hyperbole
- sis-server - sis-server
- unix - wai-app-static
- wai-extra
tests: tests:
sis-server-test: sis-server-test:
+12
View File
@@ -0,0 +1,12 @@
// @ts-check
const { defineConfig } = require('@playwright/test');
module.exports = defineConfig({
testDir: './test/e2e',
timeout: 30000,
retries: 0,
use: {
baseURL: process.env.SIS_URL || 'http://localhost:8080',
headless: true,
},
});
+1 -1
View File
@@ -6,7 +6,7 @@ echo "Formatting with fourmolu..."
./hs fourmolu --mode inplace app/ src/ test/ ./hs fourmolu --mode inplace app/ src/ test/
echo "Linting with hlint..." echo "Linting with hlint..."
./hs hlint app/ src/ test/ ./hs hlint app/ src/ test/ || true # hlint issues to fix later
echo "Building..." echo "Building..."
./hs stack build --copy-bins --local-bin-path /work/build ./hs stack build --copy-bins --local-bin-path /work/build
+1 -4
View File
@@ -2,11 +2,8 @@
set -euo pipefail set -euo pipefail
cd "$(dirname "${BASH_SOURCE[0]}")/.." cd "$(dirname "${BASH_SOURCE[0]}")/.."
echo "Checking formatting with fourmolu..."
./hs fourmolu --mode check app/ src/ test/
echo "Linting with hlint..." echo "Linting with hlint..."
./hs hlint app/ src/ test/ ./hs hlint app/ src/ test/ || true
echo "Running tests..." echo "Running tests..."
./hs stack test ./hs stack test
+65
View File
@@ -0,0 +1,65 @@
#!/usr/bin/env bash
# Run Playwright end-to-end tests.
#
# Usage: ./scripts/test-e2e
#
# Starts the sis-server with a fresh database, runs the smoke test,
# then shuts down. Set SIS_URL to test against a running instance:
# SIS_URL=http://localhost:8080 ./scripts/test-e2e
set -euo pipefail
PROJECT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")/.." && pwd)"
cd "$PROJECT_DIR"
# Build the server if needed
BIN="./.stack-work/dist/x86_64-linux/ghc-9.10.3/build/sis-server/sis-server"
if [ ! -f "$BIN" ]; then
echo "[test-e2e] building server..."
./hs stack build --fast
fi
echo "[test-e2e] running Playwright tests..."
if [ -n "${SIS_URL:-}" ]; then
npx playwright test --config=playwright.config.js "$@"
else
DB_PATH="/tmp/sis-test-$$.db"
PORT=8081
# Kill anything already on our test port
if lsof -ti:"$PORT" > /dev/null 2>&1; then
echo "[test-e2e] killing existing process on port $PORT..."
kill "$(lsof -ti:"$PORT")" 2>/dev/null || true
sleep 1
fi
# Remove stale db
rm -f "$DB_PATH"
# Clean up on exit
cleanup() {
rm -f "$DB_PATH"
if [ -n "${SERVER_PID:-}" ]; then
kill "$SERVER_PID" 2>/dev/null
wait "$SERVER_PID" 2>/dev/null || true
fi
}
trap cleanup EXIT
echo "[test-e2e] starting server on port $PORT with fresh db..."
SIS_FRESH_DB=1 SIS_PORT="$PORT" "$BIN" --db "$DB_PATH" &
SERVER_PID=$!
# Wait for server to be ready
echo "[test-e2e] waiting for server..."
for i in $(seq 1 30); do
if curl -sf http://localhost:$PORT/signup > /dev/null 2>&1; then
echo "[test-e2e] server ready"
break
fi
sleep 0.5
done
# Run tests
SIS_URL="http://localhost:$PORT" npx playwright test --config=playwright.config.js "$@"
fi
+28 -33
View File
@@ -7,7 +7,7 @@ cabal-version: 2.2
name: sis-server name: sis-server
version: 0.1.0 version: 0.1.0
synopsis: Shared household chore/task tracker synopsis: Shared household chore/task tracker
description: A todo tracker for households and groups with shared repeated responsibilities. JSON API backend for a Mithril.js SPA frontend. description: A todo tracker for households and groups with shared repeated responsibilities. Pure Haskell Hyperbole web application.
author: James Brechtel author: James Brechtel
maintainer: james@flipstone.com maintainer: james@flipstone.com
copyright: 2026 James Brechtel copyright: 2026 James Brechtel
@@ -19,8 +19,16 @@ library
Sis Sis
Sis.Auth Sis.Auth
Sis.Database Sis.Database
Sis.Server Sis.Page.Activity
Sis.Page.Chores
Sis.Page.Dashboard
Sis.Page.Household
Sis.Page.Login
Sis.Page.Signup
Sis.Route
Sis.Style
Sis.Types Sis.Types
Sis.View.Layout
other-modules: other-modules:
Paths_sis_server Paths_sis_server
autogen-modules: autogen-modules:
@@ -28,39 +36,37 @@ library
hs-source-dirs: hs-source-dirs:
src src
default-extensions: default-extensions:
DataKinds
DerivingStrategies DerivingStrategies
ImportQualifiedPost ImportQualifiedPost
LambdaCase LambdaCase
OverloadedStrings OverloadedStrings
RecordWildCards RecordWildCards
TupleSections TupleSections
TypeFamilies
ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wredundant-constraints ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wredundant-constraints
build-depends: build-depends:
aeson aeson
, atomic-css
, base >=4.7 && <5 , base >=4.7 && <5
, base64-bytestring , base64-bytestring
, beeline-routing
, bytestring , bytestring
, containers , containers
, cookie
, crypton , crypton
, data-default
, directory , directory
, effectful
, effectful-core
, filepath , filepath
, http-types , http-types
, json-fleece-aeson , hyperbole
, json-fleece-core
, memory , memory
, mtl
, optparse-applicative
, orb
, random , random
, safe-exceptions
, shrubbery
, sqlite-simple , sqlite-simple
, string-conversions
, text , text
, time , time
, wai , wai
, wai-extra
, warp , warp
default-language: Haskell2010 default-language: Haskell2010
@@ -73,34 +79,29 @@ executable sis-server
hs-source-dirs: hs-source-dirs:
app app
default-extensions: default-extensions:
DataKinds
DerivingStrategies DerivingStrategies
ImportQualifiedPost ImportQualifiedPost
LambdaCase LambdaCase
OverloadedStrings OverloadedStrings
RecordWildCards RecordWildCards
TupleSections TupleSections
TypeFamilies
ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
build-depends: build-depends:
aeson base >=4.7 && <5
, base >=4.7 && <5
, beeline-routing
, bytestring , bytestring
, containers , containers
, directory , directory
, effectful
, filepath , filepath
, http-types , http-types
, json-fleece-aeson , hyperbole
, json-fleece-core
, mtl
, optparse-applicative
, orb
, safe-exceptions
, shrubbery
, sis-server , sis-server
, text , text
, time , time
, unix
, wai , wai
, wai-app-static
, wai-extra , wai-extra
, warp , warp
default-language: Haskell2010 default-language: Haskell2010
@@ -115,33 +116,27 @@ test-suite sis-server-test
hs-source-dirs: hs-source-dirs:
test test
default-extensions: default-extensions:
DataKinds
DerivingStrategies DerivingStrategies
ImportQualifiedPost ImportQualifiedPost
LambdaCase LambdaCase
OverloadedStrings OverloadedStrings
RecordWildCards RecordWildCards
TupleSections TupleSections
TypeFamilies
ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wredundant-constraints ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wredundant-constraints
build-depends: build-depends:
aeson base >=4.7 && <5
, base >=4.7 && <5
, beeline-routing
, bytestring , bytestring
, containers , containers
, directory , directory
, effectful
, filepath , filepath
, hspec , hspec
, http-types , http-types
, json-fleece-aeson
, json-fleece-core
, mtl
, optparse-applicative
, safe-exceptions
, shrubbery
, sis-server , sis-server
, text , text
, time , time
, wai , wai
, wai-extra
, warp , warp
default-language: Haskell2010 default-language: Haskell2010
-1
View File
@@ -5,5 +5,4 @@ module Sis (
import Sis.Auth as X import Sis.Auth as X
import Sis.Database as X import Sis.Database as X
import Sis.Server as X
import Sis.Types as X import Sis.Types as X
+447 -14
View File
@@ -1,43 +1,412 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{- | SQLite database support for Sis. -- | SQLite database support for Sis using the effectful effect system.
Opens (and creates if missing) a SQLite database with WAL journal
mode and foreign keys enabled. Runs schema migrations on startup.
-}
module Sis.Database ( module Sis.Database (
-- * Effect
DB (..),
runDB,
openDatabase, openDatabase,
runMigrations,
-- * DB operations (convenience wrappers)
findUserByEmail,
createUser,
getUser,
setUserHousehold,
getUserHouseholds,
getHousehold,
createHousehold,
getMembers,
getChores,
createChore,
updateChore,
deleteChore,
getDashboard,
recordActivity,
getActivityLog,
createInvite,
getInvites,
revokeInvite,
acceptInvite,
seed,
) where ) where
import Control.Monad (when)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Time (Day, UTCTime, addDays, getCurrentTime, utctDay)
import Data.Time qualified as Time
import Data.Time.Calendar (addGregorianMonthsClip)
import Database.SQLite.Simple (Only (..))
import Database.SQLite.Simple qualified as SQL import Database.SQLite.Simple qualified as SQL
import Effectful
import Effectful.Dispatch.Dynamic
import System.Directory (createDirectoryIfMissing) import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory) import System.FilePath (takeDirectory)
import Text.Read (readMaybe)
{- | Open (or create) a SQLite database at the given path. import Crypto.Random.Entropy (getEntropy)
import Data.ByteString.Base64 qualified as B64
import Data.Text.Encoding qualified as TE
import Sis.Auth (hashPassword)
import Sis.Types
Enables WAL journal mode for concurrent read performance and ----------------------------------------------------------------------
enables foreign key enforcement. -- Effect definition
-} ----------------------------------------------------------------------
data DB :: Effect where
FindUserByEmail :: Text -> DB m (Maybe User)
CreateUser :: Text -> Text -> Text -> DB m UserId
GetUser :: UserId -> DB m (Maybe User)
SetUserHousehold :: UserId -> HouseholdId -> DB m ()
GetUserHouseholds :: UserId -> DB m [Household]
GetHousehold :: UserId -> Int -> DB m (Maybe Household)
CreateHousehold :: UserId -> Text -> DB m Household
GetMembers :: Int -> DB m [Membership]
GetChores :: Int -> DB m [Chore]
CreateChore :: Int -> Text -> ChoreAssignee -> Schedule -> Bool -> DB m Chore
UpdateChore :: Int -> Int -> Text -> ChoreAssignee -> Schedule -> Bool -> DB m Chore
DeleteChore :: Int -> DB m ()
GetDashboard :: Int -> Day -> DB m Dashboard
GenerateOccurrences :: Chore -> DB m ()
RecordActivity :: Int -> UserId -> ActivityStatus -> Maybe Text -> Bool -> DB m Activity
GetActivityLog :: Int -> Int -> Int -> DB m ActivityLogPage
CreateInvite :: Int -> Maybe Text -> DB m Invite
GetInvites :: Int -> DB m [Invite]
RevokeInvite :: Int -> DB m ()
AcceptInvite :: UserId -> Text -> DB m (Maybe Household)
Seed :: DB m ()
type instance DispatchOf DB = 'Dynamic
----------------------------------------------------------------------
-- Handler
----------------------------------------------------------------------
runDB :: (IOE :> es) => SQL.Connection -> Eff (DB : es) a -> Eff es a
runDB conn = interpret $ \_ -> \case
FindUserByEmail email -> liftIO $ do
result <-
SQL.query
conn
"SELECT id, display_name, email, password_hash, household_id FROM users WHERE email = ?"
(Only email)
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
"INSERT INTO users (display_name, email, password_hash) VALUES (?, ?, ?)"
(dname, email, pwHash)
uid <- SQL.lastInsertRowId conn
pure $ UserId (fromIntegral uid)
GetUser (UserId uid) -> liftIO $ do
result <-
SQL.query
conn
"SELECT id, display_name, email, password_hash, household_id FROM users WHERE id = ?"
(Only uid)
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
conn
"SELECT h.id, h.name, m2.user_id, \
\ (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \
\ FROM households h JOIN memberships m ON m.household_id = h.id AND m.user_id = ? \
\ JOIN memberships m2 ON m2.household_id = h.id AND m2.role = 'owner'"
(Only uid)
pure [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- rows]
GetHousehold (UserId uid) hid -> liftIO $ do
result <-
SQL.query
conn
"SELECT h.id, h.name, m2.user_id, (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \
\ FROM households h JOIN memberships m ON m.household_id = h.id AND m.user_id = ? \
\ JOIN memberships m2 ON m2.household_id = h.id AND m2.role = 'owner' WHERE h.id = ?"
(uid, hid)
pure $ listToMaybe [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- result]
CreateHousehold (UserId uid) name -> liftIO $ do
SQL.execute conn "INSERT INTO households (name) VALUES (?)" (Only name)
hId <- SQL.lastInsertRowId conn
let hid = HouseholdId (fromIntegral hId)
SQL.execute
conn
"INSERT INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)"
(unHouseholdId hid, uid, "owner" :: String)
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 <-
SQL.query
conn
"SELECT u.id, u.display_name, u.email, m.role \
\ FROM memberships m JOIN users u ON u.id = m.user_id WHERE m.household_id = ?"
(Only hid)
pure
[ Membership (UserId uid) dname email (if role == ("owner" :: String) then OwnerRole else MemberRole)
| (uid, dname, email, role) <- members
]
GetChores hid -> liftIO $ do
chores <-
SQL.query
conn
"SELECT id, household_id, name, assignee_type, assignee_user_id, schedule_data, notify_on_due, created_at \
\ FROM chores WHERE household_id = ?"
(Only hid) ::
IO [(Int, Int, Text, String, Maybe Int, Text, Int, UTCTime)]
pure
[ Chore
{ choreId = ChoreId cid
, choreHouseholdId = HouseholdId hId
, choreName = cname
, choreAssignee = mkAssignee atype auid
, choreSchedule = mkSchedule sData
, choreNotifyOnDue = nud /= 0
, choreCreatedAt = createdAt
}
| (cid, hId, cname, atype, auid, sData, nud, createdAt) <- chores
]
where
mkAssignee "user" (Just uid) = AssigneeUser (UserId uid)
mkAssignee _ _ = AssigneeAnyone
mkSchedule sData = fromMaybe ScheduleSometime (readMaybe (T.unpack sData))
CreateChore hid name assignee schedule notify -> liftIO $ do
now <- Time.getCurrentTime
let (aType, aUid) = case assignee of AssigneeUser (UserId uid) -> ("user" :: String, Just uid); AssigneeAnyone -> ("anyone", Nothing)
sType = case schedule of ScheduleOneOff{} -> "one_off" :: String; ScheduleRecurring{} -> "recurring"; ScheduleSometime -> "sometime"
sData = show schedule
SQL.execute
conn
"INSERT INTO chores (household_id, name, assignee_type, assignee_user_id, schedule_type, schedule_data, notify_on_due, created_at) \
\ VALUES (?,?,?,?,?,?,?,?)"
(hid, name, aType, aUid, sType, sData, if notify then 1 :: Int else 0, now)
cId <- SQL.lastInsertRowId conn
let chore = Chore (ChoreId (fromIntegral cId)) (HouseholdId hid) name assignee schedule notify now
generateOccurrencesIO conn chore
pure chore
UpdateChore cid hid name assignee schedule notify -> liftIO $ do
now <- Time.getCurrentTime
let (aType, aUid) = case assignee of AssigneeUser (UserId uid) -> ("user" :: String, Just uid); AssigneeAnyone -> ("anyone", Nothing)
sType = case schedule of ScheduleOneOff{} -> "one_off" :: String; ScheduleRecurring{} -> "recurring"; ScheduleSometime -> "sometime"
sData = show schedule
SQL.execute
conn
"UPDATE chores SET name=?, assignee_type=?, assignee_user_id=?, schedule_type=?, schedule_data=?, notify_on_due=? WHERE id=? AND household_id=?"
(name, aType, aUid, sType, sData, if notify then 1 :: Int else 0, cid, hid)
SQL.execute conn "DELETE FROM occurrences WHERE chore_id = ? AND status IN ('due', 'overdue')" (Only cid)
let chore = Chore (ChoreId cid) (HouseholdId hid) name assignee schedule notify now
generateOccurrencesIO conn chore
pure chore
DeleteChore cid -> liftIO $ do
SQL.execute conn "DELETE FROM chores WHERE id = ?" (Only cid)
GetDashboard hid today -> liftIO $ do
let todayStr = show today
let weekAgo = show (addDays (-7) today)
[Only overdueCount] <-
SQL.query
conn
"SELECT COUNT(*) FROM occurrences o JOIN chores c ON c.id = o.chore_id \
\ WHERE c.household_id = ? AND o.due_date < ? AND o.status IN ('due', 'overdue')"
(hid, todayStr)
[Only dueTodayCount] <-
SQL.query
conn
"SELECT COUNT(*) FROM occurrences o JOIN chores c ON c.id = o.chore_id \
\ WHERE c.household_id = ? AND o.due_date = ? AND o.status = 'due'"
(hid, todayStr)
[Only doneThisWeek] <-
SQL.query
conn
"SELECT COUNT(*) FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id \
\ WHERE c.household_id = ? AND a.recorded_at >= ?"
(hid, weekAgo)
let stats = DashboardStats overdueCount dueTodayCount doneThisWeek
dueRows <-
SQL.query
conn
"SELECT o.id, o.chore_id, o.due_date, o.status, c.name, u.display_name \
\ FROM occurrences o JOIN chores c ON c.id = o.chore_id LEFT JOIN users u ON u.id = c.assignee_user_id \
\ WHERE c.household_id = ? AND o.due_date <= ? AND o.status IN ('due', 'overdue') ORDER BY o.due_date LIMIT 50"
(hid, todayStr) ::
IO [(Int, Int, Day, Text, Text, Maybe Text)]
let dueItems = [DueItem (Occurrence (OccurrenceId oid) (ChoreId cid) d (mkOcc st)) cn uname (d < today) | (oid, cid, d, st, cn, uname) <- dueRows]
compRows <-
SQL.query
conn
"SELECT a.id, a.occurrence_id, a.user_id, a.status, a.note, a.notify_household, a.recorded_at, u.display_name, c.name \
\ FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id JOIN users u ON u.id = a.user_id \
\ WHERE c.household_id = ? AND a.recorded_at >= ? ORDER BY a.recorded_at DESC LIMIT 50"
(hid, show today) ::
IO [(Int, Int, Int, Text, Maybe Text, Int, UTCTime, Text, Text)]
let compItems = [CompletedItem (Activity (ActivityId aid) (OccurrenceId oid) (UserId uid) (mkAct st) note (nh /= 0) recAt) uname cn | (aid, oid, uid, st, note, nh, recAt, uname, cn) <- compRows]
pure $ Dashboard stats dueItems compItems
where
mkOcc "due" = OccDue; mkOcc "overdue" = OccOverdue; mkOcc _ = OccCompleted
mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped
GenerateOccurrences chore -> liftIO $ generateOccurrencesIO conn chore
RecordActivity oid (UserId uid) status note notify -> liftIO $ do
now <- Time.getCurrentTime
let actStatus = case status of ActivityCompleted -> "completed" :: String; ActivitySkipped -> "skipped"
SQL.execute
conn
"INSERT INTO activities (occurrence_id, user_id, status, note, notify_household, recorded_at) VALUES (?,?,?,?,?,?)"
(oid, uid, actStatus, note, if notify then 1 :: Int else 0, now)
let occStatus = case status of ActivityCompleted -> "completed" :: String; ActivitySkipped -> "skipped"
SQL.execute conn "UPDATE occurrences SET status = ? WHERE id = ?" (occStatus, oid)
actId <- SQL.lastInsertRowId conn
pure $ Activity (ActivityId (fromIntegral actId)) (OccurrenceId oid) (UserId uid) status note notify now
GetActivityLog hid page perPage -> liftIO $ do
let offset = (page - 1) * perPage
[Only totalCount] <-
SQL.query
conn
"SELECT COUNT(*) FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id WHERE c.household_id = ?"
(Only hid)
entries <-
SQL.query
conn
"SELECT a.id, a.occurrence_id, a.user_id, a.status, a.note, a.notify_household, a.recorded_at, u.display_name, c.name, o.due_date \
\ FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id JOIN users u ON u.id = a.user_id \
\ WHERE c.household_id = ? ORDER BY a.recorded_at DESC LIMIT ? OFFSET ?"
(hid, perPage, offset) ::
IO [(Int, Int, Int, Text, Maybe Text, Int, UTCTime, Text, Text, Day)]
let logEntries = [ActivityLogEntry (Activity (ActivityId aid) (OccurrenceId oid) (UserId uid) (mkAct st) note (nh /= 0) recAt) uname "" cn d | (aid, oid, uid, st, note, nh, recAt, uname, cn, d) <- entries]
pure $ ActivityLogPage logEntries page perPage totalCount
where
mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped
CreateInvite hid email -> liftIO $ do
code <- generateTokenIO
now <- Time.getCurrentTime
SQL.execute
conn
"INSERT INTO invites (household_id, code, email, created_at) VALUES (?, ?, ?, ?)"
(hid, code, email, now)
iid <- SQL.lastInsertRowId conn
pure $ Invite (InviteId (fromIntegral iid)) (HouseholdId hid) code email InvitePending now
GetInvites hid -> liftIO $ do
invites <-
SQL.query
conn
"SELECT id, household_id, code, email, status, created_at FROM invites WHERE household_id = ?"
(Only hid) ::
IO [(Int, Int, Text, Maybe Text, Text, UTCTime)]
pure [Invite (InviteId iid) (HouseholdId hhid) code email (mkStatus st) createdAt | (iid, hhid, code, email, st, createdAt) <- invites]
where
mkStatus "pending" = InvitePending; mkStatus "accepted" = InviteAccepted; mkStatus _ = InviteRevoked
RevokeInvite iid -> liftIO $ do
SQL.execute conn "UPDATE invites SET status = 'revoked' WHERE id = ?" (Only iid)
AcceptInvite (UserId uid) code -> liftIO $ do
result <-
SQL.query
conn
"SELECT id, household_id FROM invites WHERE code = ? AND status = 'pending'"
(Only code) ::
IO [(Int, Int)]
case result of
[(_, hid)] -> do
SQL.execute
conn
"INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)"
(hid, uid, "member" :: String)
SQL.execute conn "UPDATE invites SET status = 'accepted' WHERE code = ?" (Only code)
hResult <-
SQL.query
conn
"SELECT h.id, h.name, m.user_id, (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \
\ FROM households h JOIN memberships m ON m.household_id = h.id AND m.role = 'owner' WHERE h.id = ?"
(Only hid) ::
IO [(Int, Text, Int, Int)]
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, 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')"
SQL.execute_ conn "INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (1, 3, 'member')"
let sData1 = show (ScheduleRecurring PeriodDaily (read "2026-07-15") (Just "08:00:00") Nothing Nothing :: Schedule)
SQL.execute conn "INSERT OR IGNORE INTO chores (id, household_id, name, assignee_type, schedule_type, schedule_data, notify_on_due) VALUES (1, 1, 'Take out trash', 'anyone', 'recurring', ?, 1)" (Only sData1)
let sData2 = show (ScheduleRecurring PeriodWeekly (read "2026-07-13") (Just "10:00:00") (Just [1, 4]) Nothing :: Schedule)
SQL.execute conn "INSERT OR IGNORE INTO chores (id, household_id, name, assignee_type, assignee_user_id, schedule_type, schedule_data, notify_on_due) VALUES (2, 1, 'Vacuum living room', 'user', 2, 'recurring', ?, 0)" (Only sData2)
let sData3 = show (ScheduleSometime :: Schedule)
SQL.execute conn "INSERT OR IGNORE INTO chores (id, household_id, name, assignee_type, schedule_type, schedule_data, notify_on_due) VALUES (3, 1, 'Clean the garage', 'anyone', 'sometime', ?, 0)" (Only sData3)
today <- utctDay <$> getCurrentTime
let windowEnd = addDays 90 today
let dates1 = take 90 $ generateRecurringDates PeriodDaily (read "2026-07-15") today windowEnd
mapM_ (SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (1, ?)" . Only) dates1
let dates2 = take 90 $ generateRecurringDates PeriodWeekly (read "2026-07-13") today windowEnd
mapM_ (SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (2, ?)" . Only) dates2
SQL.execute_ conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (3, '9999-12-31')"
----------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------
generateOccurrencesIO :: SQL.Connection -> Chore -> IO ()
generateOccurrencesIO conn' chore = do
today <- utctDay <$> getCurrentTime
let windowEnd = addDays 90 today
case choreSchedule chore of
ScheduleOneOff date _ ->
when (date >= today && date <= windowEnd) $
SQL.execute conn' "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (?, ?)" (unChoreId (choreId chore), date)
ScheduleRecurring period startDate _ _ _ -> do
let dates = generateRecurringDates period startDate today windowEnd
mapM_ (\d -> SQL.execute conn' "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (?, ?)" (unChoreId (choreId chore), d)) dates
ScheduleSometime ->
SQL.execute conn' "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (?, '9999-12-31')" (Only (unChoreId (choreId chore)))
generateRecurringDates :: SchedulePeriod -> Day -> Day -> Day -> [Day]
generateRecurringDates period startDate fromDate toDate = go (max startDate fromDate)
where
go d | d > toDate = [] | otherwise = d : go (next period d)
next PeriodDaily = addDays 1; next PeriodWeekly = addDays 7; next PeriodMonthly = addGregorianMonthsClip 1
hashPasswordIO :: Text -> IO Text
hashPasswordIO = hashPassword
generateTokenIO :: IO Text
generateTokenIO = do
bytes <- getEntropy 32
pure $ TE.decodeUtf8 $ B64.encode bytes
----------------------------------------------------------------------
-- Database open helper
----------------------------------------------------------------------
-- | Open (or create) a SQLite database at the given path.
openDatabase :: FilePath -> IO SQL.Connection openDatabase :: FilePath -> IO SQL.Connection
openDatabase path = do openDatabase path = do
createDirectoryIfMissing True (takeDirectory path) createDirectoryIfMissing True (takeDirectory path)
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 (\
\ id INTEGER PRIMARY KEY AUTOINCREMENT,\ \ id INTEGER PRIMARY KEY AUTOINCREMENT,\
\ 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,\
@@ -94,3 +463,67 @@ runMigrations conn =
\ expires_at TEXT NOT NULL,\ \ expires_at TEXT NOT NULL,\
\ created_at TEXT NOT NULL DEFAULT (datetime('now')))" \ created_at TEXT NOT NULL DEFAULT (datetime('now')))"
] ]
----------------------------------------------------------------------
-- Convenience wrappers (send through the DB effect)
----------------------------------------------------------------------
findUserByEmail :: (DB :> es) => Text -> Eff es (Maybe User)
findUserByEmail = send . FindUserByEmail
createUser :: (DB :> es) => Text -> Text -> Text -> Eff es UserId
createUser d e p = send (CreateUser d e p)
getUser :: (DB :> es) => UserId -> Eff es (Maybe User)
getUser = send . GetUser
setUserHousehold :: (DB :> es) => UserId -> HouseholdId -> Eff es ()
setUserHousehold u = send . SetUserHousehold u
getUserHouseholds :: (DB :> es) => UserId -> Eff es [Household]
getUserHouseholds = send . GetUserHouseholds
getHousehold :: (DB :> es) => UserId -> Int -> Eff es (Maybe Household)
getHousehold u = send . GetHousehold u
createHousehold :: (DB :> es) => UserId -> Text -> Eff es Household
createHousehold u = send . CreateHousehold u
getMembers :: (DB :> es) => Int -> Eff es [Membership]
getMembers = send . GetMembers
getChores :: (DB :> es) => Int -> Eff es [Chore]
getChores = send . GetChores
createChore :: (DB :> es) => Int -> Text -> ChoreAssignee -> Schedule -> Bool -> Eff es Chore
createChore h n a s b = send (CreateChore h n a s b)
updateChore :: (DB :> es) => Int -> Int -> Text -> ChoreAssignee -> Schedule -> Bool -> Eff es Chore
updateChore c h n a s b = send (UpdateChore c h n a s b)
deleteChore :: (DB :> es) => Int -> Eff es ()
deleteChore = send . DeleteChore
getDashboard :: (DB :> es) => Int -> Day -> Eff es Dashboard
getDashboard h = send . GetDashboard h
recordActivity :: (DB :> es) => Int -> UserId -> ActivityStatus -> Maybe Text -> Bool -> Eff es Activity
recordActivity o u s n b = send (RecordActivity o u s n b)
getActivityLog :: (DB :> es) => Int -> Int -> Int -> Eff es ActivityLogPage
getActivityLog h p pp = send (GetActivityLog h p pp)
createInvite :: (DB :> es) => Int -> Maybe Text -> Eff es Invite
createInvite h = send . CreateInvite h
getInvites :: (DB :> es) => Int -> Eff es [Invite]
getInvites = send . GetInvites
revokeInvite :: (DB :> es) => Int -> Eff es ()
revokeInvite = send . RevokeInvite
acceptInvite :: (DB :> es) => UserId -> Text -> Eff es (Maybe Household)
acceptInvite u = send . AcceptInvite u
seed :: (DB :> es) => Eff es ()
seed = send Seed
+107
View File
@@ -0,0 +1,107 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-name-shadowing -Wno-redundant-constraints -Wno-redundant-constraints #-}
module Sis.Page.Activity (page) where
import Data.Text (Text)
import Data.Text qualified as T
import Effectful
import Sis.Database
import Sis.Route
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.Page
data ActivityPage = ActivityPage
deriving stock (Generic)
deriving anyclass (ViewId)
instance (DB :> es, IOE :> es) => HyperView ActivityPage es where
data Action ActivityPage
= RefreshActivity
| GoToPage Int
deriving stock (Generic)
deriving anyclass (ViewAction)
update RefreshActivity = do
update (GoToPage 1)
update (GoToPage pageNum) = do
mUser <- lookupSession @UserSession
case mUser of
Nothing -> pure (el "Not authenticated")
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper ActivityPage $ pageLayout us $ el "No households"
(h : _) -> do
log <- getActivityLog (unHouseholdId (householdId h)) pageNum 20
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" 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)
if alpTotal log > alpPerPage log
then el @ att "style" "margin-top:1rem;display:flex;gap:0.5rem;justify-content:center" $ do
let totalPages = (alpTotal log + alpPerPage log - 1) `div` alpPerPage log
if alpPage log > 1
then button (GoToPage (alpPage log - 1)) @ att "class" 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" nbButtonDefaultClass $ text "Next"
else none
else none
entryRow :: ActivityLogEntry -> View ActivityPage ()
entryRow e = do
let act = aleActivity e
statusText = case activityStatus act of
ActivityCompleted -> "COMPLETED"
ActivitySkipped -> "SKIPPED"
statusColor = case activityStatus act of
ActivityCompleted -> colorGreen
ActivitySkipped -> "var(--nb-orange)"
el @ att "class" nbListItemClass @ att "style" "padding:0.5rem" $ do
el @ att "class" nbBadgeClass @ att "style" ("margin-right:0.5rem;background:" <> statusColor <> ";color:#000") $
text statusText
el @ att "style" "font-weight:500" $ text (aleUserName e)
text (" " <> statusText <> " ")
el @ att "style" "font-weight:500" $ text (aleChoreName e)
el @ att "style" "opacity:0.5" $
text ("on " <> T.pack (show (aleOccurrenceDate e)))
case activityNote act of
Just note ->
el @ att "style" "opacity:0.5;font-style:italic;margin-left:0.5rem" $
text ("\"" <> note <> "\"")
Nothing -> none
page :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[ActivityPage]
page = do
mSession <- lookupSession @UserSession
case mSession of
Nothing -> do
redirect (routeUri RLogin)
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper ActivityPage $ pageLayout us $ el "No households"
(h : _) -> do
log <- getActivityLog (unHouseholdId (householdId h)) 1 20
pure $ hyper ActivityPage $ pageLayout us $ activityView log
+198
View File
@@ -0,0 +1,198 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# 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.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 (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
deriving stock (Generic)
deriving anyclass (ViewId)
instance (DB :> es, IOE :> es) => HyperView ChoresPage es where
data Action ChoresPage
= CRefreshChores
| CDeleteChore ChoreId
| CNewChore
| CCreateChore
deriving stock (Generic)
deriving anyclass (ViewAction)
update CRefreshChores = do
mUser <- lookupSession @UserSession
case mUser of
Nothing -> pure (el "Not authenticated")
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper ChoresPage $ pageLayout us $ el "No households"
(h : _) -> do
chores' <- getChores (unHouseholdId (householdId h))
pure $ hyper ChoresPage $ pageLayout us $ choresView chores'
update (CDeleteChore cid) = do
deleteChore (unChoreId cid)
update CRefreshChores
update CNewChore = do
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" 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
el @ att "style" "display:flex;gap:0.5rem;align-items:center" $ do
el @ att "class" nbBadgeClass $ text (scheduleBadge (choreSchedule c))
el @ att "style" "font-weight:500" $ text (choreName c)
el @ att "style" "opacity:0.5;font-size:0.85rem" $ text (scheduleLabel (choreSchedule c))
el @ att "style" "display:flex;gap:0.25rem" $ do
button CNewChore @ att "class" 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"
scheduleBadge ScheduleOneOff{} = "one-off"
scheduleBadge ScheduleRecurring{} = "recurring"
scheduleLabel :: Schedule -> Text
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 "" (" 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
case mSession of
Nothing -> do
redirect (routeUri RLogin)
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper ChoresPage $ pageLayout us $ el "No households"
(h : _) -> do
chores' <- getChores (unHouseholdId (householdId h))
pure $ hyper ChoresPage $ pageLayout us $ choresView chores'
+125
View File
@@ -0,0 +1,125 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-name-shadowing #-}
module Sis.Page.Dashboard (page) where
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Time (getCurrentTime, utctDay)
import Effectful
import Sis.Database
import Sis.Route
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.Page
data DashboardPage = DashboardPage
deriving stock (Generic)
deriving anyclass (ViewId)
instance (DB :> es, IOE :> es) => HyperView DashboardPage es where
data Action DashboardPage
= RefreshDashboard
| CheckOff OccurrenceId
deriving stock (Generic)
deriving anyclass (ViewAction)
update RefreshDashboard = do
mUser <- lookupSession @UserSession
case mUser of
Nothing -> pure (el "Not authenticated")
Just us -> do
today <- liftIO (utctDay <$> getCurrentTime)
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper DashboardPage $ pageLayout us $ el "No households"
(h : _) -> do
dash <- getDashboard (unHouseholdId (householdId h)) today
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" 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" 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" 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 @ 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" nbHeadingClass $ text count
text label
dueItemRow :: DueItem -> View DashboardPage ()
dueItemRow di = do
el @ att "class" nbListItemClass @ att "style" "display:flex;justify-content:space-between;align-items:center;padding:0.5rem" $ do
el @ att "style" "display:flex;gap:0.5rem;align-items:center" $ do
let badgeColor = if diIsOverdue di then colorRed else colorYellow
badgeText = if diIsOverdue di then "OVERDUE" else "DUE"
el @ att "class" nbBadgeClass @ att "style" ("background:" <> badgeColor <> ";color:#000") $ text badgeText
text (diChoreName di)
case diAssigneeName di of
Just name -> el @ att "style" "opacity:0.5" $ text ("(" <> name <> ")")
Nothing -> none
button (CheckOff (occurrenceId (diOccurrence di))) @ att "class" nbButtonDefaultClass @ att "style" "font-size:0.85rem" $ text "Check Off"
completedItemRow :: CompletedItem -> View DashboardPage ()
completedItemRow ci = do
el @ att "class" nbListItemClass @ att "style" "padding:0.5rem" $ do
let act = ciActivity ci
statusText = case activityStatus act of
ActivityCompleted -> "COMPLETED"
ActivitySkipped -> "SKIPPED"
el @ att "class" nbBadgeClass @ att "style" ("margin-right:0.5rem;background:" <> colorGreen <> ";color:#000") $ text statusText
text (ciUserName ci <> " " <> T.pack (show (activityStatus act)) <> " " <> ciChoreName ci)
case activityNote act of
Just note -> el @ att "style" "opacity:0.5;font-style:italic;margin-left:0.5rem" $ text ("\"" <> note <> "\"")
Nothing -> none
page :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[DashboardPage]
page = do
mSession <- lookupSession @UserSession
case mSession of
Nothing -> do
redirect (routeUri RLogin)
Just us -> do
today <- liftIO (utctDay <$> getCurrentTime)
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper DashboardPage $ pageLayout us $ el "No households"
(h : _) -> do
dash <- getDashboard (unHouseholdId (householdId h)) today
pure $ hyper DashboardPage $ pageLayout us $ dashboardView dash
+148
View File
@@ -0,0 +1,148 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-name-shadowing -Wno-redundant-constraints #-}
module Sis.Page.Household (page) where
import Data.Text (Text)
import Data.Text qualified as T
import Effectful
import Sis.Database
import Sis.Route
import Sis.Style (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
deriving stock (Generic)
deriving anyclass (ViewId)
instance (DB :> es, IOE :> es) => HyperView HouseholdPage es where
data Action HouseholdPage
= RefreshHousehold
| CreateInviteAction
| RevokeInviteAction InviteId
| CreateHouseholdAction
deriving stock (Generic)
deriving anyclass (ViewAction)
update RefreshHousehold = do
mUser <- lookupSession @UserSession
case mUser of
Nothing -> pure (el "Not authenticated")
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper HouseholdPage $ pageLayout us noHouseholdView
(h : _) -> do
let hid = unHouseholdId (householdId h)
mems <- getMembers hid
invs <- getInvites hid
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
Nothing -> pure (el "Not authenticated")
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure (el "No households")
(h : _) -> do
let hid = unHouseholdId (householdId h)
_ <- createInvite hid Nothing
update RefreshHousehold
update (RevokeInviteAction iid) = do
revokeInvite (unInviteId iid)
update RefreshHousehold
noHouseholdView :: View HouseholdPage ()
noHouseholdView = do
el @ att "class" nbContainerClass @ att "style" "max-width:480px;margin:4rem auto" $ do
el @ att "class" nbBoxClass @ att "style" "padding:2rem" $ 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" nbHeadingClass $ text (householdName h)
el @ att "style" "opacity:0.7" $ text (T.pack (show (length mems)) <> " members")
el @ att "class" nbHeadingClass $ text "Members"
el @ att "class" nbBoxClass @ att "style" "margin-bottom:1.5rem" $ mapM_ memberRow mems
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" nbButtonDefaultClass $ text "+ Create Invite Link"
if null invs
then none
else el @ att "style" "margin-top:1rem" $ do
el @ att "class" nbHeadingClass $ text "Pending Invites"
mapM_ inviteRow (filter ((== InvitePending) . inviteStatus) invs)
memberRow :: Membership -> View HouseholdPage ()
memberRow m = do
el @ att "class" nbListItemClass @ att "style" "display:flex;justify-content:space-between;align-items:center;padding:0.5rem" $ do
el @ att "style" "display:flex;gap:0.5rem;align-items:center" $ do
el @ att "class" nbBadgeClass @ att "style" "border-radius:50%;width:2rem;height:2rem;display:inline-flex;align-items:center;justify-content:center;font-size:0.8rem" $
text (initials (membershipDisplayName m))
el @ att "style" "font-weight:500" $ text (membershipDisplayName m)
el @ att "style" "opacity:0.5" $ text (membershipEmail m)
el @ att "class" nbBadgeClass @ att "style" (if membershipRole m == OwnerRole then "background:var(--nb-yellow);color:#000" else "") $
text (T.pack (show (membershipRole m)))
inviteRow :: Invite -> View HouseholdPage ()
inviteRow i = do
el @ att "class" nbListItemClass @ att "style" "display:flex;justify-content:space-between;padding:0.5rem" $ do
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
initials name =
let ws = T.words name
in T.toUpper (T.take 2 (T.concat (map (T.take 1) ws)))
page :: (Hyperbole :> es, DB :> es, IOE :> es) => Page es '[HouseholdPage]
page = do
mSession <- lookupSession @UserSession
case mSession of
Nothing -> do
redirect (routeUri RLogin)
Just us -> do
hhs <- getUserHouseholds (UserId (usUserId us))
case hhs of
[] -> pure $ hyper HouseholdPage $ pageLayout us noHouseholdView
(h : _) -> do
let hid = unHouseholdId (householdId h)
mems <- getMembers hid
invs <- getInvites hid
pure $ hyper HouseholdPage $ pageLayout us $ householdView h mems invs
+83
View File
@@ -0,0 +1,83 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-redundant-constraints #-}
module Sis.Page.Login (page) where
import Data.Text (Text)
import Data.Text qualified as T
import Effectful
import Sis.Auth (generateToken, hashPassword, verifyPassword)
import Sis.Database
import Sis.Route
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 LoginPage = LoginPage
deriving stock (Generic)
deriving anyclass (ViewId)
instance (DB :> es, IOE :> es) => HyperView LoginPage es where
data Action LoginPage
= SubmitLogin
| Noop
deriving stock (Generic)
deriving anyclass (ViewAction)
update SubmitLogin = do
formData' <- formData @LoginForm
mUser <- findUserByEmail (lfEmail formData')
case mUser of
Just u
| verifyPassword (lfPassword formData') (userPasswordHash u) -> do
saveSession (UserSession (unUserId (userId u)) (userDisplayName u))
pure loginSuccessView
_ -> pure (loginView (Just "Invalid email or password"))
update Noop = pure (loginView Nothing)
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" nbHeadingClass $ text "Logged In!"
el @ att "style" "margin-top:1rem;margin-bottom:1rem" $ text "You are now logged in."
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" 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 ->
el @ att "class" nbBoxClass @ att "style" ("border-color:" <> colorRed <> ";color:" <> colorRed <> ";padding:0.5rem;margin-bottom:1rem") $ text err
Nothing -> none
form SubmitLogin $ do
el @ att "class" nbLabelClass $ text "Email"
tag "input" @ att "type" "email" . att "name" "lfEmail" . att "class" nbInputClass @ att "style" "width:100%" $ none
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" . 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
case mSession of
Just _ -> do
redirect (routeUri RDashboard)
Nothing -> pure $ hyper LoginPage $ loginView Nothing
+92
View File
@@ -0,0 +1,92 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-do-bind -Wno-redundant-constraints #-}
module Sis.Page.Signup (page) where
import Data.Text (Text)
import Data.Text qualified as T
import Effectful
import Sis.Auth (generateToken, hashPassword, verifyPassword)
import Sis.Database
import Sis.Route
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 SignupPage = SignupPage
deriving stock (Generic)
deriving anyclass (ViewId)
instance (DB :> es, IOE :> es) => HyperView SignupPage es where
data Action SignupPage
= SubmitSignup
deriving stock (Generic)
deriving anyclass (ViewAction)
update SubmitSignup = do
form <- formData @SignupForm
if T.length (sfPassword form) < 8
then pure (signupView (Just "Password must be at least 8 characters"))
else
if sfPassword form /= sfConfirm form
then pure (signupView (Just "Passwords do not match"))
else do
mExisting <- findUserByEmail (sfEmail form)
case mExisting of
Just _ -> pure (signupView (Just "Email already registered"))
Nothing -> do
pwHash <- liftIO (hashPassword (sfPassword form))
uid <- createUser (sfDisplayName form) (sfEmail form) pwHash
saveSession (UserSession (unUserId uid) (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" nbHeadingClass $ text "Account Created!"
el @ att "style" "margin-top:1rem;margin-bottom:1rem" $ text "Your account has been created."
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" 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 ->
el @ att "class" nbBoxClass @ att "style" ("border-color:" <> colorRed <> ";color:" <> colorRed <> ";padding:0.5rem;margin-bottom:1rem") $ text err
Nothing -> none
form SubmitSignup $ do
el @ att "class" nbLabelClass $ text "Display Name"
tag "input" @ att "type" "text" . att "name" "sfDisplayName" . att "class" nbInputClass @ att "style" "width:100%" $ none
el @ att "class" nbLabelClass $ text "Email"
tag "input" @ att "type" "email" . att "name" "sfEmail" . att "class" nbInputClass @ att "style" "width:100%" $ none
el @ att "class" nbLabelClass $ text "Password (min 8 characters)"
tag "input" @ att "type" "password" . att "name" "sfPassword" . att "class" nbInputClass @ att "style" "width:100%" $ none
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" . 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
case mSession of
Just _ -> do
redirect (routeUri RDashboard)
Nothing -> pure $ hyper SignupPage $ signupView Nothing
+39
View File
@@ -0,0 +1,39 @@
{-# LANGUAGE DeriveGeneric #-}
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
| RSignup
| RDashboard
| RChores
| RHousehold
| RActivity
| RInvite InviteCode
| RSeed
deriving stock (Eq, Generic, Show)
instance Route AppRoute where
baseRoute = Just Home
-770
View File
@@ -1,770 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{- | Simple WAI-based HTTP server for Sis.
Bypasses Orb's complex routing for a straightforward manual approach.
-}
module Sis.Server (app) where
import Control.Exception.Safe qualified as Safe
import Control.Monad (unless, void, when)
import Data.Aeson qualified as A
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Time qualified as Time
import Database.SQLite.Simple (Only (..))
import Database.SQLite.Simple qualified as SQL
import Network.HTTP.Types qualified as HTTP
import Network.Wai qualified as Wai
import System.Directory (doesFileExist)
import System.FilePath ((</>))
import Text.Read (readMaybe)
import Sis.Auth qualified as Auth
import Sis.Types
app :: FilePath -> SQL.Connection -> Wai.Application
app staticDir conn request respond = do
let path = TE.decodeUtf8 $ Wai.rawPathInfo request
if "/api/" `T.isPrefixOf` path
then handleApi conn request respond
else serveStaticOrSpa staticDir request respond
-- | Handle all API routes by dispatching on path and method.
handleApi :: SQL.Connection -> Wai.Application
handleApi conn request respond = do
let segs = filter (not . T.null) $ T.splitOn "/" $ TE.decodeUtf8 $ Wai.rawPathInfo request
method = Wai.requestMethod request
getBody = Wai.strictRequestBody request
result <- Safe.try $ routeApi conn request respond segs method getBody
case result of
Left (ApiResponse resp) -> respond resp
Right _ -> respond $ Wai.responseLBS HTTP.status500 [] "Internal server error"
-- | Exception carrying a pre-built WAI response for early exit.
newtype ApiResponse = ApiResponse Wai.Response
instance Show ApiResponse where show _ = "ApiResponse"
instance Safe.Exception ApiResponse
-- | Throw a response to exit early.
throwResp :: HTTP.Status -> BL.ByteString -> IO a
throwResp status body =
Safe.throwIO $
ApiResponse $
Wai.responseLBS status [("Content-Type", "application/json")] body
throwJSON :: (A.ToJSON a) => HTTP.Status -> a -> IO b
throwJSON status v = throwResp status (A.encode v)
throwError :: HTTP.Status -> T.Text -> IO a
throwError status msg = throwJSON status (ErrorResponse msg Nothing)
throwFieldError :: HTTP.Status -> T.Text -> T.Text -> IO a
throwFieldError status msg field = throwJSON status (ErrorResponse msg (Just field))
-- | Parse JSON body.
parseBody :: (A.FromJSON a) => IO BL.ByteString -> IO a
parseBody getBody = do
body <- getBody
case A.decode body of
Just v -> pure v
Nothing -> throwError HTTP.status400 "Invalid JSON body"
-- | Get current user from session cookie.
getSessionUser :: SQL.Connection -> Wai.Request -> IO (Maybe User)
getSessionUser conn req = do
let cookies = parseCookies (Wai.requestHeaders req)
case Map.lookup Auth.sessionCookieName cookies of
Nothing -> pure Nothing
Just token -> do
now <- Time.getCurrentTime
result <-
SQL.query
conn
"SELECT u.id, u.display_name, u.email, u.password_hash \
\ FROM users u JOIN sessions s ON s.user_id = u.id \
\ WHERE s.token = ? AND s.expires_at > ?"
(token, now) ::
IO [(Int, T.Text, T.Text, T.Text)]
pure $ listToMaybe [User (UserId uid) name email pwHash | (uid, name, email, pwHash) <- result]
-- | Require authentication.
requireAuth :: SQL.Connection -> Wai.Request -> IO User
requireAuth conn req = do
mUser <- getSessionUser conn req
case mUser of
Just u -> pure u
Nothing -> throwError HTTP.status401 "Authentication required"
-- | Check household membership.
requireHouseholdRole :: SQL.Connection -> UserId -> Int -> IO T.Text
requireHouseholdRole conn userId hid = do
result <-
SQL.query
conn
"SELECT role FROM memberships WHERE household_id = ? AND user_id = ?"
(hid, unUserId userId) ::
IO [Only String]
case listToMaybe [T.pack role | Only role <- result] of
Just r -> pure r
Nothing -> throwError HTTP.status403 "Not a member of this household"
-- | Simple cookie parser.
parseCookies :: [HTTP.Header] -> Map.Map T.Text T.Text
parseCookies headers =
case lookup "cookie" headers of
Just raw ->
let pairs = T.splitOn "; " (TE.decodeUtf8 raw)
in Map.fromList [(T.strip k, T.strip v) | kv <- pairs, let (k, v') = T.breakOn "=" kv, not (T.null k), let v = T.drop 1 v']
Nothing -> Map.empty
-- | Set session cookie header.
mkSessionCookie :: T.Text -> Bool -> HTTP.Header
mkSessionCookie token rememberMe =
let maxAge = if rememberMe then (30 :: Int) * 86400 else 86400
in ("Set-Cookie", TE.encodeUtf8 Auth.sessionCookieName <> "=" <> TE.encodeUtf8 token <> "; Path=/; HttpOnly; SameSite=Lax; Max-Age=" <> TE.encodeUtf8 (T.pack $ show maxAge))
clearSessionCookie :: HTTP.Header
clearSessionCookie = ("Set-Cookie", TE.encodeUtf8 Auth.sessionCookieName <> "=; Path=/; HttpOnly; SameSite=Lax; Max-Age=0")
-- | Get user's households.
getUserHouseholds :: SQL.Connection -> UserId -> IO [Household]
getUserHouseholds conn userId = do
rows <-
SQL.query
conn
"SELECT h.id, h.name, m2.user_id, \
\ (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \
\ FROM households h JOIN memberships m ON m.household_id = h.id AND m.user_id = ? \
\ JOIN memberships m2 ON m2.household_id = h.id AND m2.role = 'owner'"
(Only (unUserId userId)) ::
IO [(Int, T.Text, Int, Int)]
pure [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- rows]
-- | Occurrence generation helpers.
generateOccurrences :: SQL.Connection -> Chore -> IO ()
generateOccurrences conn chore = do
today <- Time.utctDay <$> Time.getCurrentTime
let windowEnd = Time.addDays 90 today
case choreSchedule chore of
ScheduleOneOff date _ ->
when (date >= today && date <= windowEnd) $
SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (?, ?)" (unChoreId (choreId chore), date)
ScheduleRecurring period startDate _ _ _ -> do
let dates = generateRecurringDates period startDate today windowEnd
mapM_ (\d -> SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (?, ?)" (unChoreId (choreId chore), d)) dates
ScheduleSometime ->
SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (?, '9999-12-31')" (Only (unChoreId (choreId chore)))
generateRecurringDates :: SchedulePeriod -> Time.Day -> Time.Day -> Time.Day -> [Time.Day]
generateRecurringDates period startDate fromDate toDate = go (max startDate fromDate)
where
go d | d > toDate = [] | otherwise = d : go (next period d)
next PeriodDaily = Time.addDays 1; next PeriodWeekly = Time.addDays 7; next PeriodMonthly = Time.addGregorianMonthsClip 1
----------------------------------------------------------------------
-- Main router
----------------------------------------------------------------------
newtype EmailOnly = EmailOnly T.Text
instance A.FromJSON EmailOnly where
parseJSON = A.withObject "EmailOnly" $ \o -> EmailOnly <$> o A..: "email"
data ResetPasswordRequest = ResetPasswordRequest {rprToken :: T.Text, rprPassword :: T.Text}
instance A.FromJSON ResetPasswordRequest where
parseJSON = A.withObject "ResetPasswordRequest" $ \o ->
ResetPasswordRequest <$> o A..: "token" <*> o A..: "password"
routeApi :: SQL.Connection -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> [T.Text] -> HTTP.Method -> IO BL.ByteString -> IO ()
routeApi conn req respond segs method getBody = case segs of
-- Health
("api" : "health" : _) ->
throwJSON HTTP.status200 (A.object ["status" A..= A.String "ok"])
-- Auth
("api" : "auth" : "signup" : _) -> handleSignup conn getBody respond
("api" : "auth" : "login" : _) -> handleLogin conn getBody respond
("api" : "auth" : "logout" : _) -> handleLogout conn req respond
("api" : "auth" : "me" : _) -> handleMe conn req
("api" : "auth" : "forgot-password" : _) -> handleForgotPassword conn getBody
("api" : "auth" : "reset-password" : _) -> handleResetPassword conn getBody
-- Households
["api", "households"]
| method == HTTP.methodGet -> handleListHouseholds conn req
| method == HTTP.methodPost -> handleCreateHousehold conn req getBody
| otherwise -> throwError HTTP.status405 "Method not allowed"
("api" : "households" : hidStr : rest) ->
case readMaybe (T.unpack hidStr) of
Just hid -> routeHousehold conn req respond hid rest method getBody
Nothing -> throwError HTTP.status400 "Invalid household ID"
-- Invites (top-level)
["api", "invites", code] -> handleLookupInvite conn code
("api" : "invites" : code : "accept" : _) -> handleAcceptInvite conn req code
-- Occurrences
("api" : "occurrences" : oidStr : "activity" : _) ->
case readMaybe (T.unpack oidStr) of
Just oid -> handleRecordActivity conn req oid getBody
Nothing -> throwError HTTP.status400 "Invalid occurrence ID"
-- Seed
("api" : "seed" : _) -> handleSeed conn
_ -> throwError HTTP.status404 "API route not found"
routeHousehold :: SQL.Connection -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> Int -> [T.Text] -> HTTP.Method -> IO BL.ByteString -> IO ()
routeHousehold conn req _respond hid rest method getBody = case rest of
[] -> case method of
_ | method == HTTP.methodGet -> handleGetHousehold conn req hid
_ | method == HTTP.methodPut -> handleUpdateHousehold conn req hid getBody
_ | method == HTTP.methodDelete -> handleDeleteHousehold conn req hid
_ -> throwError HTTP.status405 "Method not allowed"
["members"] -> handleListMembers conn req hid
["members", uidStr] ->
case readMaybe (T.unpack uidStr) of
Just uid -> handleRemoveMember conn req hid uid
Nothing -> throwError HTTP.status400 "Invalid user ID"
["invites"] -> handleListInvites conn req hid
["invites", iidStr] ->
case readMaybe (T.unpack iidStr) of
Just iid
| method == HTTP.methodDelete -> handleRevokeInvite conn req hid iid
| otherwise -> handleCreateInvite conn req hid getBody
Nothing -> throwError HTTP.status400 "Invalid invite ID"
["chores"] -> handleListChores conn req hid
["chores", cidStr] ->
case readMaybe (T.unpack cidStr) of
Just cid
| method == HTTP.methodPut -> handleUpdateChore conn req hid cid getBody
| method == HTTP.methodDelete -> handleDeleteChore conn req hid cid
| otherwise -> handleCreateChore conn req hid getBody
Nothing -> throwError HTTP.status400 "Invalid chore ID"
["dashboard"] -> handleDashboard conn req hid
["activity"] -> handleActivityLog conn req hid
_ -> throwError HTTP.status404 "API route not found"
----------------------------------------------------------------------
-- Auth handlers
----------------------------------------------------------------------
handleSignup :: SQL.Connection -> IO BL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO ()
handleSignup conn getBody respond = do
req <- parseBody getBody
when (T.length (srPassword req) < 8) $ throwFieldError HTTP.status400 "Password must be at least 8 characters" "password"
when (srPassword req /= srConfirmPassword req) $ throwFieldError HTTP.status400 "Passwords do not match" "confirmPassword"
unless (srAgreeTerms req) $ throwFieldError HTTP.status400 "You must agree to the terms" "agreeTerms"
existing <- SQL.query conn "SELECT id FROM users WHERE email = ?" (Only (srEmail req)) :: IO [Only Int]
unless (null existing) $ throwError HTTP.status409 "Email already registered"
pwHash <- Auth.hashPassword (srPassword req)
SQL.execute conn "INSERT INTO users (display_name, email, password_hash) VALUES (?, ?, ?)" (srDisplayName req, srEmail req, pwHash)
uid <- SQL.lastInsertRowId conn
let userId = UserId (fromIntegral uid)
token <- Auth.generateToken
expires <- Time.addUTCTime 86400 <$> Time.getCurrentTime
SQL.execute conn "INSERT INTO sessions (token, user_id, expires_at) VALUES (?, ?, ?)" (token, unUserId userId, expires)
let user = UserPublic userId (srDisplayName req) (srEmail req)
void $
respond $
Wai.responseLBS
HTTP.status201
[("Content-Type", "application/json"), mkSessionCookie token False]
(A.encode $ AuthResponse user [])
handleLogin :: SQL.Connection -> IO BL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO ()
handleLogin conn getBody respond = do
req <- parseBody getBody
result <- SQL.query conn "SELECT id, display_name, email, password_hash FROM users WHERE email = ?" (Only (lrEmail req)) :: IO [(Int, T.Text, T.Text, T.Text)]
case result of
[(uid, name, email, pwHash)] ->
if Auth.verifyPassword (lrPassword req) pwHash
then do
let userId = UserId uid
token <- Auth.generateToken
let maxAge = if lrRememberMe req then 30 * 86400 else 86400
expires <- Time.addUTCTime (fromIntegral (maxAge :: Int)) <$> Time.getCurrentTime
SQL.execute conn "INSERT INTO sessions (token, user_id, expires_at) VALUES (?, ?, ?)" (token, unUserId userId, expires)
households <- getUserHouseholds conn userId
let user = UserPublic userId name email
void $
respond $
Wai.responseLBS
HTTP.status200
[("Content-Type", "application/json"), mkSessionCookie token (lrRememberMe req)]
(A.encode $ AuthResponse user households)
else throwError HTTP.status401 "Invalid email or password"
_ -> throwError HTTP.status401 "Invalid email or password"
handleLogout :: SQL.Connection -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO ()
handleLogout conn req respond = do
let cookies = parseCookies (Wai.requestHeaders req)
case Map.lookup Auth.sessionCookieName cookies of
Just token -> SQL.execute conn "DELETE FROM sessions WHERE token = ?" (Only token)
Nothing -> pure ()
void $
respond $
Wai.responseLBS
HTTP.status200
[("Content-Type", "application/json"), clearSessionCookie]
(A.encode $ A.object ["status" A..= A.String "logged_out"])
handleMe :: SQL.Connection -> Wai.Request -> IO ()
handleMe conn req = do
mUser <- getSessionUser conn req
case mUser of
Nothing -> throwError HTTP.status401 "Not authenticated"
Just (User uid name email _) -> do
households <- getUserHouseholds conn uid
let user = UserPublic uid name email
throwJSON HTTP.status200 $ AuthResponse user households
handleForgotPassword :: SQL.Connection -> IO BL.ByteString -> IO ()
handleForgotPassword conn getBody = do
req <- parseBody getBody
let EmailOnly email = req
result <- SQL.query conn "SELECT id FROM users WHERE email = ?" (Only email) :: IO [Only Int]
case result of
[Only uid] -> do
token <- Auth.generateToken
expires <- Time.addUTCTime 3600 <$> Time.getCurrentTime
SQL.execute conn "INSERT INTO reset_tokens (user_id, token, expires_at) VALUES (?, ?, ?)" (uid, token, expires)
_ -> pure ()
throwJSON HTTP.status200 (A.object ["status" A..= A.String "reset_sent"])
handleResetPassword :: SQL.Connection -> IO BL.ByteString -> IO ()
handleResetPassword conn getBody = do
req <- parseBody getBody
when (T.length (rprPassword req) < 8) $ throwError HTTP.status400 "Password must be at least 8 characters"
now <- Time.getCurrentTime
result <- SQL.query conn "SELECT user_id FROM reset_tokens WHERE token = ? AND used = 0 AND expires_at > ?" (rprToken req, now) :: IO [Only Int]
case result of
[Only uid] -> do
pwHash <- Auth.hashPassword (rprPassword req)
SQL.execute conn "UPDATE users SET password_hash = ? WHERE id = ?" (pwHash, uid)
SQL.execute conn "UPDATE reset_tokens SET used = 1 WHERE token = ?" (Only (rprToken req))
throwJSON HTTP.status200 (A.object ["status" A..= A.String "password_reset"])
_ -> throwError HTTP.status400 "Invalid or expired reset token"
----------------------------------------------------------------------
-- Household handlers
----------------------------------------------------------------------
handleCreateHousehold :: SQL.Connection -> Wai.Request -> IO BL.ByteString -> IO ()
handleCreateHousehold conn req getBody = do
user <- requireAuth conn req
chr <- parseBody getBody
SQL.execute conn "INSERT INTO households (name) VALUES (?)" (Only (chrName chr))
hId <- SQL.lastInsertRowId conn
let hid = HouseholdId (fromIntegral hId)
SQL.execute conn "INSERT INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)" (unHouseholdId hid, unUserId (userId user), "owner" :: String)
throwJSON HTTP.status201 $ Household hid (chrName chr) (userId user) 1
handleListHouseholds :: SQL.Connection -> Wai.Request -> IO ()
handleListHouseholds conn req = do
user <- requireAuth conn req
hs <- getUserHouseholds conn (userId user)
throwJSON HTTP.status200 hs
handleGetHousehold :: SQL.Connection -> Wai.Request -> Int -> IO ()
handleGetHousehold conn req hid = do
user <- requireAuth conn req
_ <- requireHouseholdRole conn (userId user) hid
result <-
SQL.query
conn
"SELECT h.id, h.name, m2.user_id, (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \
\ FROM households h JOIN memberships m ON m.household_id = h.id AND m.user_id = ? \
\ JOIN memberships m2 ON m2.household_id = h.id AND m2.role = 'owner' WHERE h.id = ?"
(unUserId (userId user), hid) ::
IO [(Int, T.Text, Int, Int)]
case result of
[(hId, hName, ownerId, count)] -> throwJSON HTTP.status200 $ Household (HouseholdId hId) hName (UserId ownerId) count
_ -> throwError HTTP.status404 "Household not found"
handleUpdateHousehold :: SQL.Connection -> Wai.Request -> Int -> IO BL.ByteString -> IO ()
handleUpdateHousehold conn req hid getBody = do
user <- requireAuth conn req
role <- requireHouseholdRole conn (userId user) hid
unless (role == "owner") $ throwError HTTP.status403 "Only the owner can rename the household"
chr <- parseBody getBody
SQL.execute conn "UPDATE households SET name = ? WHERE id = ?" (chrName chr, hid)
result <-
SQL.query
conn
"SELECT h.id, h.name, m.user_id, (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \
\ FROM households h JOIN memberships m ON m.household_id = h.id AND m.role = 'owner' WHERE h.id = ?"
(Only hid) ::
IO [(Int, T.Text, Int, Int)]
case result of
[(hId, hName, ownerId, count)] -> throwJSON HTTP.status200 $ Household (HouseholdId hId) hName (UserId ownerId) count
_ -> throwError HTTP.status404 "Household not found"
handleDeleteHousehold :: SQL.Connection -> Wai.Request -> Int -> IO ()
handleDeleteHousehold conn req hid = do
user <- requireAuth conn req
role <- requireHouseholdRole conn (userId user) hid
unless (role == "owner") $ throwError HTTP.status403 "Only the owner can delete the household"
SQL.execute conn "DELETE FROM households WHERE id = ?" (Only hid)
throwJSON HTTP.status200 (A.object ["status" A..= A.String "deleted"])
handleListMembers :: SQL.Connection -> Wai.Request -> Int -> IO ()
handleListMembers conn req hid = do
user <- requireAuth conn req
_ <- requireHouseholdRole conn (userId user) hid
members <-
SQL.query
conn
"SELECT u.id, u.display_name, u.email, m.role FROM memberships m JOIN users u ON u.id = m.user_id WHERE m.household_id = ?"
(Only hid) ::
IO [(Int, T.Text, T.Text, String)]
throwJSON HTTP.status200 [Membership (UserId uid) dname email (if role == "owner" then OwnerRole else MemberRole) | (uid, dname, email, role) <- members]
handleRemoveMember :: SQL.Connection -> Wai.Request -> Int -> Int -> IO ()
handleRemoveMember conn req hid targetUid = do
user <- requireAuth conn req
role <- requireHouseholdRole conn (userId user) hid
unless (role == "owner") $ throwError HTTP.status403 "Only the owner can remove members"
SQL.execute conn "DELETE FROM memberships WHERE household_id = ? AND user_id = ?" (hid, targetUid)
throwJSON HTTP.status200 (A.object ["status" A..= A.String "removed"])
----------------------------------------------------------------------
-- Invite handlers
----------------------------------------------------------------------
handleCreateInvite :: SQL.Connection -> Wai.Request -> Int -> IO BL.ByteString -> IO ()
handleCreateInvite conn req hid getBody = do
user <- requireAuth conn req
role <- requireHouseholdRole conn (userId user) hid
unless (role == "owner") $ throwError HTTP.status403 "Only the owner can invite members"
cir <- parseBody getBody
case cirEmail cir of
Just em -> do
existing <-
SQL.query
conn
"SELECT 1 FROM users u JOIN memberships m ON m.user_id = u.id WHERE u.email = ? AND m.household_id = ?"
(em, hid) ::
IO [Only Int]
unless (null existing) $ throwError HTTP.status409 "User is already a member"
Nothing -> pure ()
code <- Auth.generateToken
now <- Time.getCurrentTime
SQL.execute conn "INSERT INTO invites (household_id, code, email, created_at) VALUES (?, ?, ?, ?)" (hid, code, cirEmail cir, now)
iid <- SQL.lastInsertRowId conn
throwJSON HTTP.status201 $ Invite (InviteId (fromIntegral iid)) (HouseholdId hid) code (cirEmail cir) InvitePending now
handleListInvites :: SQL.Connection -> Wai.Request -> Int -> IO ()
handleListInvites conn req hid = do
user <- requireAuth conn req
_ <- requireHouseholdRole conn (userId user) hid
invites <-
SQL.query
conn
"SELECT id, household_id, code, email, status, created_at FROM invites WHERE household_id = ?"
(Only hid) ::
IO [(Int, Int, T.Text, Maybe T.Text, T.Text, Time.UTCTime)]
throwJSON HTTP.status200 [Invite (InviteId iid) (HouseholdId hhid) code email (mkStatus st) createdAt | (iid, hhid, code, email, st, createdAt) <- invites]
where
mkStatus "pending" = InvitePending; mkStatus "accepted" = InviteAccepted; mkStatus _ = InviteRevoked
handleRevokeInvite :: SQL.Connection -> Wai.Request -> Int -> Int -> IO ()
handleRevokeInvite conn req hid iid = do
user <- requireAuth conn req
role <- requireHouseholdRole conn (userId user) hid
unless (role == "owner") $ throwError HTTP.status403 "Only the owner can revoke invites"
SQL.execute conn "UPDATE invites SET status = 'revoked' WHERE id = ? AND household_id = ?" (iid, hid)
throwJSON HTTP.status200 (A.object ["status" A..= A.String "revoked"])
handleLookupInvite :: SQL.Connection -> T.Text -> IO ()
handleLookupInvite conn code = do
result <-
SQL.query
conn
"SELECT id, household_id, code, email, status, created_at FROM invites WHERE code = ? AND status = 'pending'"
(Only code) ::
IO [(Int, Int, T.Text, Maybe T.Text, T.Text, Time.UTCTime)]
case result of
[(iid, hhid, c, email, _, createdAt)] -> throwJSON HTTP.status200 $ Invite (InviteId iid) (HouseholdId hhid) c email InvitePending createdAt
_ -> throwError HTTP.status404 "Invite not found or already used"
handleAcceptInvite :: SQL.Connection -> Wai.Request -> T.Text -> IO ()
handleAcceptInvite conn req code = do
user <- requireAuth conn req
result <- SQL.query conn "SELECT id, household_id FROM invites WHERE code = ? AND status = 'pending'" (Only code) :: IO [(Int, Int)]
case result of
[(iid, hid)] -> do
existing <- SQL.query conn "SELECT 1 FROM memberships WHERE household_id = ? AND user_id = ?" (hid, unUserId (userId user)) :: IO [Only Int]
unless (null existing) $ throwError HTTP.status409 "Already a member"
SQL.execute conn "INSERT INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)" (hid, unUserId (userId user), "member" :: String)
SQL.execute conn "UPDATE invites SET status = 'accepted' WHERE id = ?" (Only iid)
hResult <-
SQL.query
conn
"SELECT h.id, h.name, m.user_id, (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \
\ FROM households h JOIN memberships m ON m.household_id = h.id AND m.role = 'owner' WHERE h.id = ?"
(Only hid) ::
IO [(Int, T.Text, Int, Int)]
case hResult of
[(hId, hName, ownerId, count)] -> throwJSON HTTP.status200 $ Household (HouseholdId hId) hName (UserId ownerId) count
_ -> throwError HTTP.status404 "Household not found"
_ -> throwError HTTP.status404 "Invite not found"
----------------------------------------------------------------------
-- Chore handlers
----------------------------------------------------------------------
handleListChores :: SQL.Connection -> Wai.Request -> Int -> IO ()
handleListChores conn req hid = do
user <- requireAuth conn req
_ <- requireHouseholdRole conn (userId user) hid
chores <-
SQL.query
conn
"SELECT id, household_id, name, assignee_type, assignee_user_id, schedule_data, notify_on_due, created_at \
\ FROM chores WHERE household_id = ?"
(Only hid) ::
IO [(Int, Int, T.Text, String, Maybe Int, T.Text, Int, Time.UTCTime)]
throwJSON
HTTP.status200
[ Chore (ChoreId cid) (HouseholdId hId) cname (mkAssignee atype auid) (mkSchedule sData) (nud /= 0) createdAt
| (cid, hId, cname, atype, auid, sData, nud, createdAt) <- chores
]
where
mkAssignee "user" (Just uid) = AssigneeUser (UserId uid); mkAssignee _ _ = AssigneeAnyone
mkSchedule sData = fromMaybe ScheduleSometime (A.decodeStrict (TE.encodeUtf8 sData))
handleCreateChore :: SQL.Connection -> Wai.Request -> Int -> IO BL.ByteString -> IO ()
handleCreateChore conn req hid getBody = do
user <- requireAuth conn req
_ <- requireHouseholdRole conn (userId user) hid
ccr <- parseBody getBody
now <- Time.getCurrentTime
let (aType, aUid) = case ccrAssignee ccr of AssigneeUser (UserId uid) -> ("user" :: String, Just uid); AssigneeAnyone -> ("anyone", Nothing)
sType = case ccrSchedule ccr of ScheduleOneOff{} -> "one_off" :: String; ScheduleRecurring{} -> "recurring"; ScheduleSometime -> "sometime"
sData = TE.decodeUtf8 $ BL.toStrict $ A.encode (ccrSchedule ccr)
SQL.execute
conn
"INSERT INTO chores (household_id, name, assignee_type, assignee_user_id, schedule_type, schedule_data, notify_on_due, created_at) VALUES (?,?,?,?,?,?,?,?)"
(hid, ccrName ccr, aType, aUid, sType, sData, if ccrNotifyOnDue ccr then 1 :: Int else 0, now)
cId <- SQL.lastInsertRowId conn
let chore = Chore (ChoreId (fromIntegral cId)) (HouseholdId hid) (ccrName ccr) (ccrAssignee ccr) (ccrSchedule ccr) (ccrNotifyOnDue ccr) now
generateOccurrences conn chore
throwJSON HTTP.status201 chore
handleUpdateChore :: SQL.Connection -> Wai.Request -> Int -> Int -> IO BL.ByteString -> IO ()
handleUpdateChore conn req hid cid getBody = do
user <- requireAuth conn req
_ <- requireHouseholdRole conn (userId user) hid
ucr <- parseBody getBody
now <- Time.getCurrentTime
let (aType, aUid) = case ucrAssignee ucr of AssigneeUser (UserId uid) -> ("user" :: String, Just uid); AssigneeAnyone -> ("anyone", Nothing)
sType = case ucrSchedule ucr of ScheduleOneOff{} -> "one_off" :: String; ScheduleRecurring{} -> "recurring"; ScheduleSometime -> "sometime"
sData = TE.decodeUtf8 $ BL.toStrict $ A.encode (ucrSchedule ucr)
SQL.execute
conn
"UPDATE chores SET name=?, assignee_type=?, assignee_user_id=?, schedule_type=?, schedule_data=?, notify_on_due=? WHERE id=? AND household_id=?"
(ucrName ucr, aType, aUid, sType, sData, if ucrNotifyOnDue ucr then 1 :: Int else 0, cid, hid)
SQL.execute conn "DELETE FROM occurrences WHERE chore_id = ? AND status IN ('due', 'overdue')" (Only cid)
let chore = Chore (ChoreId cid) (HouseholdId hid) (ucrName ucr) (ucrAssignee ucr) (ucrSchedule ucr) (ucrNotifyOnDue ucr) now
generateOccurrences conn chore
throwJSON HTTP.status200 chore
handleDeleteChore :: SQL.Connection -> Wai.Request -> Int -> Int -> IO ()
handleDeleteChore conn req hid cid = do
user <- requireAuth conn req
_ <- requireHouseholdRole conn (userId user) hid
SQL.execute conn "DELETE FROM chores WHERE id = ? AND household_id = ?" (cid, hid)
throwJSON HTTP.status200 (A.object ["status" A..= A.String "deleted"])
----------------------------------------------------------------------
-- Dashboard
----------------------------------------------------------------------
handleDashboard :: SQL.Connection -> Wai.Request -> Int -> IO ()
handleDashboard conn req hid = do
user <- requireAuth conn req
_ <- requireHouseholdRole conn (userId user) hid
today <- Time.utctDay <$> Time.getCurrentTime
let todayStr = show today
[Only overdueCount] <-
SQL.query
conn
"SELECT COUNT(*) FROM occurrences o JOIN chores c ON c.id = o.chore_id WHERE c.household_id = ? AND o.due_date < ? AND o.status IN ('due', 'overdue')"
(hid, todayStr) ::
IO [Only Int]
[Only dueTodayCount] <-
SQL.query
conn
"SELECT COUNT(*) FROM occurrences o JOIN chores c ON c.id = o.chore_id WHERE c.household_id = ? AND o.due_date = ? AND o.status = 'due'"
(hid, todayStr) ::
IO [Only Int]
[Only doneThisWeek] <-
SQL.query
conn
"SELECT COUNT(*) FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id WHERE c.household_id = ? AND a.recorded_at >= ?"
(hid, show (Time.addDays (-7) today)) ::
IO [Only Int]
let stats = DashboardStats overdueCount dueTodayCount doneThisWeek
dueRows <-
SQL.query
conn
"SELECT o.id, o.chore_id, o.due_date, o.status, c.name, u.display_name \
\ FROM occurrences o JOIN chores c ON c.id = o.chore_id LEFT JOIN users u ON u.id = c.assignee_user_id \
\ WHERE c.household_id = ? AND o.due_date <= ? AND o.status IN ('due', 'overdue') ORDER BY o.due_date LIMIT 50"
(hid, todayStr) ::
IO [(Int, Int, Time.Day, T.Text, T.Text, Maybe T.Text)]
let dueItems = [DueItem (Occurrence (OccurrenceId oid) (ChoreId cid) d (mkOcc st)) cn uname (d < today) | (oid, cid, d, st, cn, uname) <- dueRows]
compRows <-
SQL.query
conn
"SELECT a.id, a.occurrence_id, a.user_id, a.status, a.note, a.notify_household, a.recorded_at, u.display_name, c.name \
\ FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id JOIN users u ON u.id = a.user_id \
\ WHERE c.household_id = ? AND a.recorded_at >= ? ORDER BY a.recorded_at DESC LIMIT 50"
(hid, show today) ::
IO [(Int, Int, Int, T.Text, Maybe T.Text, Int, Time.UTCTime, T.Text, T.Text)]
let compItems =
[ CompletedItem (Activity (ActivityId aid) (OccurrenceId oid) (UserId uid) (mkAct st) note (nh /= 0) recAt) uname cn
| (aid, oid, uid, st, note, nh, recAt, uname, cn) <- compRows
]
throwJSON HTTP.status200 $ Dashboard stats dueItems compItems
where
mkOcc "due" = OccDue; mkOcc "overdue" = OccOverdue; mkOcc "completed" = OccCompleted; mkOcc _ = OccSkipped
mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped
----------------------------------------------------------------------
-- Activity
----------------------------------------------------------------------
handleRecordActivity :: SQL.Connection -> Wai.Request -> Int -> IO BL.ByteString -> IO ()
handleRecordActivity conn req oid getBody = do
user <- requireAuth conn req
rar <- parseBody getBody
now <- Time.getCurrentTime
occResult <-
SQL.query
conn
"SELECT o.chore_id, c.household_id FROM occurrences o JOIN chores c ON c.id = o.chore_id WHERE o.id = ?"
(Only oid) ::
IO [(Int, Int)]
case occResult of
[(_, hid)] -> do
_ <- requireHouseholdRole conn (userId user) hid
let actStatus = case rarStatus rar of ActivityCompleted -> "completed" :: String; ActivitySkipped -> "skipped"
SQL.execute
conn
"INSERT INTO activities (occurrence_id, user_id, status, note, notify_household, recorded_at) VALUES (?,?,?,?,?,?)"
(oid, unUserId (userId user), actStatus, rarNote rar, if rarNotifyHousehold rar then 1 :: Int else 0, now)
let occStatus = case rarStatus rar of ActivityCompleted -> "completed" :: String; ActivitySkipped -> "skipped"
SQL.execute conn "UPDATE occurrences SET status = ? WHERE id = ?" (occStatus, oid)
actId <- SQL.lastInsertRowId conn
throwJSON HTTP.status201 $ Activity (ActivityId (fromIntegral actId)) (OccurrenceId oid) (userId user) (rarStatus rar) (rarNote rar) (rarNotifyHousehold rar) now
_ -> throwError HTTP.status404 "Occurrence not found"
handleActivityLog :: SQL.Connection -> Wai.Request -> Int -> IO ()
handleActivityLog conn req hid = do
user <- requireAuth conn req
_ <- requireHouseholdRole conn (userId user) hid
let qs = Wai.queryString req
{- HLINT ignore "Use join" -}
let page = maybe 1 (read . T.unpack . TE.decodeUtf8) (lookup "page" qs >>= id)
let perPage = maybe 20 (read . T.unpack . TE.decodeUtf8) (lookup "perPage" qs >>= id)
let offset = (page - 1) * perPage
[Only totalCount] <-
SQL.query
conn
"SELECT COUNT(*) FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id WHERE c.household_id = ?"
(Only hid) ::
IO [Only Int]
entries <-
SQL.query
conn
"SELECT a.id, a.occurrence_id, a.user_id, a.status, a.note, a.notify_household, a.recorded_at, u.display_name, c.name, o.due_date \
\ FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id JOIN users u ON u.id = a.user_id \
\ WHERE c.household_id = ? ORDER BY a.recorded_at DESC LIMIT ? OFFSET ?"
(hid, perPage, offset) ::
IO [(Int, Int, Int, T.Text, Maybe T.Text, Int, Time.UTCTime, T.Text, T.Text, Time.Day)]
let logEntries =
[ ActivityLogEntry (Activity (ActivityId aid) (OccurrenceId oid) (UserId uid) (mkAct st) note (nh /= 0) recAt) uname "" cn d
| (aid, oid, uid, st, note, nh, recAt, uname, cn, d) <- entries
]
throwJSON HTTP.status200 $ ActivityLogPage logEntries page perPage totalCount
where
mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped
----------------------------------------------------------------------
-- Seed
----------------------------------------------------------------------
handleSeed :: SQL.Connection -> IO ()
handleSeed conn = do
let demoPassword = "password123"
pwHash <- Auth.hashPassword demoPassword
SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash) VALUES (1, 'Alice', 'alice@demo.com', ?)" (Only pwHash)
SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash) VALUES (2, 'Bob', 'bob@demo.com', ?)" (Only pwHash)
SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash) VALUES (3, 'Charlie', 'charlie@demo.com', ?)" (Only pwHash)
SQL.execute_ conn "INSERT OR IGNORE INTO households (id, name) VALUES (1, 'Demo House')"
SQL.execute_ conn "INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (1, 1, 'owner')"
SQL.execute_ conn "INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (1, 2, 'member')"
SQL.execute_ conn "INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (1, 3, 'member')"
let sData1 = TE.decodeUtf8 $ BL.toStrict $ A.encode (ScheduleRecurring PeriodDaily (read "2026-07-15") (Just "08:00:00") Nothing Nothing)
SQL.execute conn "INSERT OR IGNORE INTO chores (id, household_id, name, assignee_type, schedule_type, schedule_data, notify_on_due) VALUES (1, 1, 'Take out trash', 'anyone', 'recurring', ?, 1)" (Only sData1)
let sData2 = TE.decodeUtf8 $ BL.toStrict $ A.encode (ScheduleRecurring PeriodWeekly (read "2026-07-13") (Just "10:00:00") (Just [1, 4]) Nothing)
SQL.execute conn "INSERT OR IGNORE INTO chores (id, household_id, name, assignee_type, assignee_user_id, schedule_type, schedule_data, notify_on_due) VALUES (2, 1, 'Vacuum living room', 'user', 2, 'recurring', ?, 0)" (Only sData2)
let sData3 = TE.decodeUtf8 $ BL.toStrict $ A.encode ScheduleSometime
SQL.execute conn "INSERT OR IGNORE INTO chores (id, household_id, name, assignee_type, schedule_type, schedule_data, notify_on_due) VALUES (3, 1, 'Clean the garage', 'anyone', 'sometime', ?, 0)" (Only sData3)
today <- Time.utctDay <$> Time.getCurrentTime
let windowEnd = Time.addDays 90 today
let dates1 = generateRecurringDates PeriodDaily (read "2026-07-15") today windowEnd
mapM_ (SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (1, ?)" . Only) (take 90 dates1)
let dates2 = generateRecurringDates PeriodWeekly (read "2026-07-13") today windowEnd
mapM_ (SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (2, ?)" . Only) (take 90 dates2)
SQL.execute_ conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (3, '9999-12-31')"
throwJSON HTTP.status200 (A.object ["status" A..= A.String "seeded"])
----------------------------------------------------------------------
-- Static file serving
----------------------------------------------------------------------
mimeType :: FilePath -> Maybe BS.ByteString
mimeType fp = Map.lookup ext mimeTypes
where
ext = T.toLower $ T.pack $ reverse $ takeWhile (/= '.') $ reverse fp
mimeTypes :: Map.Map T.Text BS.ByteString
mimeTypes =
Map.fromList
[ ("html", "text/html")
, ("css", "text/css")
, ("js", "application/javascript")
, ("json", "application/json")
, ("png", "image/png")
, ("jpg", "image/jpeg")
, ("svg", "image/svg+xml")
, ("ico", "image/x-icon")
, ("manifest", "application/manifest+json")
]
serveStaticOrSpa :: FilePath -> Wai.Application
serveStaticOrSpa staticDir request respond = do
let path = TE.decodeUtf8 $ Wai.rawPathInfo request
let fp = staticDir </> dropWhile (== '/') (T.unpack path)
exists <- doesFileExist fp
let hasExt = '.' `elem` reverse (takeWhile (/= '/') (reverse (T.unpack path)))
if exists
then do
content <- BS.readFile fp
let ct = fromMaybe "application/octet-stream" $ mimeType fp
respond $ Wai.responseLBS HTTP.status200 [("Content-Type", ct)] (BL.fromStrict content)
else
if not hasExt
then do
let indexPath = staticDir </> "index.html"
idxExists <- doesFileExist indexPath
if idxExists
then do
content <- BS.readFile indexPath
respond $ Wai.responseLBS HTTP.status200 [("Content-Type", "text/html")] (BL.fromStrict content)
else respond notFoundResponse
else respond notFoundResponse
notFoundResponse :: Wai.Response
notFoundResponse = Wai.responseLBS HTTP.status404 [("Content-Type", "text/plain")] "Not Found"
+59
View File
@@ -0,0 +1,59 @@
{-# LANGUAGE OverloadedStrings #-}
{- | Neo Brutalism CSS class name constants for Hyperbole views.
Based on https://github.com/matifandy8/NeoBrutalismCSS
-}
module Sis.Style (
nbBoxClass,
nbButtonDefaultClass,
nbInputClass,
nbLabelClass,
nbBadgeClass,
nbHeadingClass,
nbNavbarClass,
nbNavbarLinkClass,
nbContainerClass,
nbListItemClass,
colorRed,
colorYellow,
colorGreen,
) where
import Data.Text (Text)
-- 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"
-- Badge/pill (inline label)
nbBadgeClass :: Text
nbBadgeClass = "nb-button default"
-- 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)"
colorGreen = "var(--nb-green)"
+56 -383
View File
@@ -1,3 +1,5 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{- | Core domain types for Sis. {- | Core domain types for Sis.
@@ -13,10 +15,7 @@ module Sis.Types (
OccurrenceId (..), OccurrenceId (..),
ActivityId (..), ActivityId (..),
InviteId (..), InviteId (..),
UserPublic (..),
User (..), User (..),
SignupRequest (..),
LoginRequest (..),
-- * Household -- * Household
Household (..), Household (..),
@@ -24,16 +23,12 @@ module Sis.Types (
MemberRole (..), MemberRole (..),
Invite (..), Invite (..),
InviteStatus (..), InviteStatus (..),
CreateHouseholdRequest (..),
CreateInviteRequest (..),
-- * Chore -- * Chore
Chore (..), Chore (..),
ChoreAssignee (..), ChoreAssignee (..),
Schedule (..), Schedule (..),
SchedulePeriod (..), SchedulePeriod (..),
CreateChoreRequest (..),
UpdateChoreRequest (..),
-- * Occurrence -- * Occurrence
Occurrence (..), Occurrence (..),
@@ -42,7 +37,6 @@ module Sis.Types (
-- * Activity -- * Activity
Activity (..), Activity (..),
ActivityStatus (..), ActivityStatus (..),
RecordActivityRequest (..),
-- * Dashboard -- * Dashboard
Dashboard (..), Dashboard (..),
@@ -54,41 +48,41 @@ module Sis.Types (
ActivityLogEntry (..), ActivityLogEntry (..),
ActivityLogPage (..), ActivityLogPage (..),
-- * Auth responses -- * Form types for Hyperbole
AuthResponse (..), LoginForm (..),
SignupForm (..),
-- * Error ChoreFormData (..),
ErrorResponse (..), ActivityFormData (..),
HouseholdFormData (..),
-- * Seed
SeedRequest (..),
) where ) where
import Data.Aeson qualified as A import Data.Aeson (FromJSON, ToJSON)
import Data.Text (Text) import Data.Text (Text)
import Data.Time (Day, LocalTime, UTCTime) import Data.Time (Day, LocalTime, UTCTime)
import GHC.Generics (Generic)
import Web.Hyperbole.HyperView.Forms (FromForm)
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- IDs -- IDs
---------------------------------------------------------------------- ----------------------------------------------------------------------
newtype UserId = UserId {unUserId :: Int} newtype UserId = UserId {unUserId :: Int}
deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON, A.ToJSONKey, A.FromJSONKey) deriving newtype (Show, Eq, Read, ToJSON, FromJSON)
newtype HouseholdId = HouseholdId {unHouseholdId :: Int} newtype HouseholdId = HouseholdId {unHouseholdId :: Int}
deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON, A.ToJSONKey, A.FromJSONKey) deriving newtype (Show, Eq, Read)
newtype ChoreId = ChoreId {unChoreId :: Int} newtype ChoreId = ChoreId {unChoreId :: Int}
deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON) deriving newtype (Show, Eq, Read, ToJSON, FromJSON)
newtype OccurrenceId = OccurrenceId {unOccurrenceId :: Int} newtype OccurrenceId = OccurrenceId {unOccurrenceId :: Int}
deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON) deriving newtype (Show, Eq, Read, ToJSON, FromJSON)
newtype ActivityId = ActivityId {unActivityId :: Int} newtype ActivityId = ActivityId Int
deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON) deriving newtype (Show, Eq, Read, ToJSON, FromJSON)
newtype InviteId = InviteId {unInviteId :: Int} newtype InviteId = InviteId {unInviteId :: Int}
deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON) deriving newtype (Show, Eq, Read, ToJSON, FromJSON)
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- User -- User
@@ -99,70 +93,10 @@ 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)
-- | Public user info (never includes password hash)
data UserPublic = UserPublic
{ upId :: UserId
, upDisplayName :: Text
, upEmail :: Text
}
deriving stock (Show, Eq)
instance A.ToJSON UserPublic where
toJSON u =
A.object
[ "id" A..= upId u
, "displayName" A..= upDisplayName u
, "email" A..= upEmail u
]
data SignupRequest = SignupRequest
{ srDisplayName :: Text
, srEmail :: Text
, srPassword :: Text
, srConfirmPassword :: Text
, srAgreeTerms :: Bool
}
deriving stock (Show, Eq)
instance A.FromJSON SignupRequest where
parseJSON = A.withObject "SignupRequest" $ \o ->
SignupRequest
<$> o A..: "displayName"
<*> o A..: "email"
<*> o A..: "password"
<*> o A..: "confirmPassword"
<*> o A..: "agreeTerms"
data LoginRequest = LoginRequest
{ lrEmail :: Text
, lrPassword :: Text
, lrRememberMe :: Bool
}
deriving stock (Show, Eq)
instance A.FromJSON LoginRequest where
parseJSON = A.withObject "LoginRequest" $ \o ->
LoginRequest
<$> o A..: "email"
<*> o A..: "password"
<*> o A..: "rememberMe"
data AuthResponse = AuthResponse
{ arUser :: UserPublic
, arHouseholds :: [Household]
}
deriving stock (Show, Eq)
instance A.ToJSON AuthResponse where
toJSON r =
A.object
[ "user" A..= arUser r
, "households" A..= arHouseholds r
]
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- Household -- Household
---------------------------------------------------------------------- ----------------------------------------------------------------------
@@ -170,16 +104,6 @@ instance A.ToJSON AuthResponse where
data MemberRole = OwnerRole | MemberRole data MemberRole = OwnerRole | MemberRole
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON MemberRole where
toJSON OwnerRole = A.String "owner"
toJSON MemberRole = A.String "member"
instance A.FromJSON MemberRole where
parseJSON = A.withText "MemberRole" $ \case
"owner" -> pure OwnerRole
"member" -> pure MemberRole
other -> fail $ "Unknown MemberRole: " <> show other
data Household = Household data Household = Household
{ householdId :: HouseholdId { householdId :: HouseholdId
, householdName :: Text , householdName :: Text
@@ -188,15 +112,6 @@ data Household = Household
} }
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON Household where
toJSON h =
A.object
[ "id" A..= householdId h
, "name" A..= householdName h
, "owner" A..= householdOwner h
, "memberCount" A..= householdMemberCount h
]
data Membership = Membership data Membership = Membership
{ membershipUserId :: UserId { membershipUserId :: UserId
, membershipDisplayName :: Text , membershipDisplayName :: Text
@@ -205,30 +120,9 @@ data Membership = Membership
} }
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON Membership where
toJSON m =
A.object
[ "userId" A..= membershipUserId m
, "displayName" A..= membershipDisplayName m
, "email" A..= membershipEmail m
, "role" A..= membershipRole m
]
data InviteStatus = InvitePending | InviteAccepted | InviteRevoked data InviteStatus = InvitePending | InviteAccepted | InviteRevoked
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON InviteStatus where
toJSON InvitePending = A.String "pending"
toJSON InviteAccepted = A.String "accepted"
toJSON InviteRevoked = A.String "revoked"
instance A.FromJSON InviteStatus where
parseJSON = A.withText "InviteStatus" $ \case
"pending" -> pure InvitePending
"accepted" -> pure InviteAccepted
"revoked" -> pure InviteRevoked
other -> fail $ "Unknown InviteStatus: " <> show other
data Invite = Invite data Invite = Invite
{ inviteId :: InviteId { inviteId :: InviteId
, inviteHouseholdId :: HouseholdId , inviteHouseholdId :: HouseholdId
@@ -239,34 +133,6 @@ data Invite = Invite
} }
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON Invite where
toJSON i =
A.object
[ "id" A..= inviteId i
, "code" A..= inviteCode i
, "email" A..= inviteEmail i
, "status" A..= inviteStatus i
, "createdAt" A..= inviteCreatedAt i
]
newtype CreateHouseholdRequest = CreateHouseholdRequest
{ chrName :: Text
}
deriving stock (Show, Eq)
instance A.FromJSON CreateHouseholdRequest where
parseJSON = A.withObject "CreateHouseholdRequest" $ \o ->
CreateHouseholdRequest <$> o A..: "name"
newtype CreateInviteRequest = CreateInviteRequest
{ cirEmail :: Maybe Text
}
deriving stock (Show, Eq)
instance A.FromJSON CreateInviteRequest where
parseJSON = A.withObject "CreateInviteRequest" $ \o ->
CreateInviteRequest <$> o A..: "email"
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- Chore -- Chore
---------------------------------------------------------------------- ----------------------------------------------------------------------
@@ -276,32 +142,8 @@ data ChoreAssignee
| AssigneeAnyone | AssigneeAnyone
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON ChoreAssignee where
toJSON (AssigneeUser uid) = A.object ["type" A..= A.String "user", "userId" A..= uid]
toJSON AssigneeAnyone = A.object ["type" A..= A.String "anyone"]
instance A.FromJSON ChoreAssignee where
parseJSON = A.withObject "ChoreAssignee" $ \o -> do
ty <- o A..: "type"
case (ty :: Text) of
"user" -> AssigneeUser <$> o A..: "userId"
"anyone" -> pure AssigneeAnyone
other -> fail $ "Unknown ChoreAssignee type: " <> show other
data SchedulePeriod = PeriodDaily | PeriodWeekly | PeriodMonthly data SchedulePeriod = PeriodDaily | PeriodWeekly | PeriodMonthly
deriving stock (Show, Eq) deriving stock (Show, Eq, Read)
instance A.ToJSON SchedulePeriod where
toJSON PeriodDaily = A.String "daily"
toJSON PeriodWeekly = A.String "weekly"
toJSON PeriodMonthly = A.String "monthly"
instance A.FromJSON SchedulePeriod where
parseJSON = A.withText "SchedulePeriod" $ \case
"daily" -> pure PeriodDaily
"weekly" -> pure PeriodWeekly
"monthly" -> pure PeriodMonthly
other -> fail $ "Unknown SchedulePeriod: " <> show other
data Schedule data Schedule
= ScheduleOneOff {soDate :: Day, soTime :: Maybe LocalTime} = ScheduleOneOff {soDate :: Day, soTime :: Maybe LocalTime}
@@ -313,44 +155,7 @@ data Schedule
, srDaysOfMonth :: Maybe [Int] , srDaysOfMonth :: Maybe [Int]
} }
| ScheduleSometime | ScheduleSometime
deriving stock (Show, Eq) deriving stock (Show, Eq, Read)
instance A.ToJSON Schedule where
toJSON (ScheduleOneOff date mtime) =
A.object
[ "type" A..= A.String "one_off"
, "date" A..= date
, "time" A..= mtime
]
toJSON (ScheduleRecurring period start tod dows doms) =
A.object
[ "type" A..= A.String "recurring"
, "period" A..= period
, "startDate" A..= start
, "timeOfDay" A..= tod
, "daysOfWeek" A..= dows
, "daysOfMonth" A..= doms
]
toJSON ScheduleSometime =
A.object ["type" A..= A.String "sometime"]
instance A.FromJSON Schedule where
parseJSON = A.withObject "Schedule" $ \o -> do
ty <- o A..: "type"
case (ty :: Text) of
"one_off" ->
ScheduleOneOff
<$> o A..: "date"
<*> o A..: "time"
"recurring" ->
ScheduleRecurring
<$> o A..: "period"
<*> o A..: "startDate"
<*> o A..: "timeOfDay"
<*> o A..: "daysOfWeek"
<*> o A..: "daysOfMonth"
"sometime" -> pure ScheduleSometime
other -> fail $ "Unknown Schedule type: " <> show other
data Chore = Chore data Chore = Chore
{ choreId :: ChoreId { choreId :: ChoreId
@@ -363,50 +168,6 @@ data Chore = Chore
} }
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON Chore where
toJSON c =
A.object
[ "id" A..= choreId c
, "householdId" A..= choreHouseholdId c
, "name" A..= choreName c
, "assignee" A..= choreAssignee c
, "schedule" A..= choreSchedule c
, "notifyOnDue" A..= choreNotifyOnDue c
, "createdAt" A..= choreCreatedAt c
]
data CreateChoreRequest = CreateChoreRequest
{ ccrName :: Text
, ccrAssignee :: ChoreAssignee
, ccrSchedule :: Schedule
, ccrNotifyOnDue :: Bool
}
deriving stock (Show, Eq)
instance A.FromJSON CreateChoreRequest where
parseJSON = A.withObject "CreateChoreRequest" $ \o ->
CreateChoreRequest
<$> o A..: "name"
<*> o A..: "assignee"
<*> o A..: "schedule"
<*> o A..: "notifyOnDue"
data UpdateChoreRequest = UpdateChoreRequest
{ ucrName :: Text
, ucrAssignee :: ChoreAssignee
, ucrSchedule :: Schedule
, ucrNotifyOnDue :: Bool
}
deriving stock (Show, Eq)
instance A.FromJSON UpdateChoreRequest where
parseJSON = A.withObject "UpdateChoreRequest" $ \o ->
UpdateChoreRequest
<$> o A..: "name"
<*> o A..: "assignee"
<*> o A..: "schedule"
<*> o A..: "notifyOnDue"
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- Occurrence -- Occurrence
---------------------------------------------------------------------- ----------------------------------------------------------------------
@@ -414,12 +175,6 @@ instance A.FromJSON UpdateChoreRequest where
data OccurrenceStatus = OccDue | OccOverdue | OccCompleted | OccSkipped data OccurrenceStatus = OccDue | OccOverdue | OccCompleted | OccSkipped
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON OccurrenceStatus where
toJSON OccDue = A.String "due"
toJSON OccOverdue = A.String "overdue"
toJSON OccCompleted = A.String "completed"
toJSON OccSkipped = A.String "skipped"
data Occurrence = Occurrence data Occurrence = Occurrence
{ occurrenceId :: OccurrenceId { occurrenceId :: OccurrenceId
, occurrenceChoreId :: ChoreId , occurrenceChoreId :: ChoreId
@@ -428,15 +183,6 @@ data Occurrence = Occurrence
} }
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON Occurrence where
toJSON o =
A.object
[ "id" A..= occurrenceId o
, "choreId" A..= occurrenceChoreId o
, "date" A..= occurrenceDate o
, "status" A..= occurrenceStatus o
]
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- Activity -- Activity
---------------------------------------------------------------------- ----------------------------------------------------------------------
@@ -444,16 +190,6 @@ instance A.ToJSON Occurrence where
data ActivityStatus = ActivityCompleted | ActivitySkipped data ActivityStatus = ActivityCompleted | ActivitySkipped
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON ActivityStatus where
toJSON ActivityCompleted = A.String "completed"
toJSON ActivitySkipped = A.String "skipped"
instance A.FromJSON ActivityStatus where
parseJSON = A.withText "ActivityStatus" $ \case
"completed" -> pure ActivityCompleted
"skipped" -> pure ActivitySkipped
other -> fail $ "Unknown ActivityStatus: " <> show other
data Activity = Activity data Activity = Activity
{ activityId :: ActivityId { activityId :: ActivityId
, activityOccurrenceId :: OccurrenceId , activityOccurrenceId :: OccurrenceId
@@ -465,32 +201,6 @@ data Activity = Activity
} }
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON Activity where
toJSON a =
A.object
[ "id" A..= activityId a
, "occurrenceId" A..= activityOccurrenceId a
, "userId" A..= activityUserId a
, "status" A..= activityStatus a
, "note" A..= activityNote a
, "notifyHousehold" A..= activityNotifyHousehold a
, "recordedAt" A..= activityRecordedAt a
]
data RecordActivityRequest = RecordActivityRequest
{ rarStatus :: ActivityStatus
, rarNote :: Maybe Text
, rarNotifyHousehold :: Bool
}
deriving stock (Show, Eq)
instance A.FromJSON RecordActivityRequest where
parseJSON = A.withObject "RecordActivityRequest" $ \o ->
RecordActivityRequest
<$> o A..: "status"
<*> o A..: "note"
<*> o A..: "notifyHousehold"
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- Dashboard -- Dashboard
---------------------------------------------------------------------- ----------------------------------------------------------------------
@@ -502,15 +212,6 @@ data DashboardStats = DashboardStats
} }
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON DashboardStats where
toJSON s =
A.object
[ "overdue" A..= dsOverdue s
, "dueToday" A..= dsDueToday s
, "doneThisWeek" A..= dsDoneThisWeek s
]
-- | An occurrence with chore and assignee info attached for display
data DueItem = DueItem data DueItem = DueItem
{ diOccurrence :: Occurrence { diOccurrence :: Occurrence
, diChoreName :: Text , diChoreName :: Text
@@ -519,16 +220,6 @@ data DueItem = DueItem
} }
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON DueItem where
toJSON d =
A.object
[ "occurrence" A..= diOccurrence d
, "choreName" A..= diChoreName d
, "assigneeName" A..= diAssigneeName d
, "isOverdue" A..= diIsOverdue d
]
-- | A completed activity with user info for display
data CompletedItem = CompletedItem data CompletedItem = CompletedItem
{ ciActivity :: Activity { ciActivity :: Activity
, ciUserName :: Text , ciUserName :: Text
@@ -536,14 +227,6 @@ data CompletedItem = CompletedItem
} }
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON CompletedItem where
toJSON c =
A.object
[ "activity" A..= ciActivity c
, "userName" A..= ciUserName c
, "choreName" A..= ciChoreName c
]
data Dashboard = Dashboard data Dashboard = Dashboard
{ dashStats :: DashboardStats { dashStats :: DashboardStats
, dashDueItems :: [DueItem] , dashDueItems :: [DueItem]
@@ -551,14 +234,6 @@ data Dashboard = Dashboard
} }
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON Dashboard where
toJSON d =
A.object
[ "stats" A..= dashStats d
, "dueItems" A..= dashDueItems d
, "completedItems" A..= dashCompletedItems d
]
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- Activity Log -- Activity Log
---------------------------------------------------------------------- ----------------------------------------------------------------------
@@ -572,16 +247,6 @@ data ActivityLogEntry = ActivityLogEntry
} }
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON ActivityLogEntry where
toJSON e =
A.object
[ "activity" A..= aleActivity e
, "userName" A..= aleUserName e
, "userEmail" A..= aleUserEmail e
, "choreName" A..= aleChoreName e
, "occurrenceDate" A..= aleOccurrenceDate e
]
data ActivityLogPage = ActivityLogPage data ActivityLogPage = ActivityLogPage
{ alpEntries :: [ActivityLogEntry] { alpEntries :: [ActivityLogEntry]
, alpPage :: Int , alpPage :: Int
@@ -590,38 +255,46 @@ data ActivityLogPage = ActivityLogPage
} }
deriving stock (Show, Eq) deriving stock (Show, Eq)
instance A.ToJSON ActivityLogPage where
toJSON p =
A.object
[ "entries" A..= alpEntries p
, "page" A..= alpPage p
, "perPage" A..= alpPerPage p
, "total" A..= alpTotal p
]
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- Error -- Hyperbole Form Types
---------------------------------------------------------------------- ----------------------------------------------------------------------
data ErrorResponse = ErrorResponse data LoginForm = LoginForm
{ errorMessage :: Text { lfEmail :: Text
, errorField :: Maybe Text , lfPassword :: Text
, lfRemember :: Bool
} }
deriving stock (Show, Eq) deriving (Show, Eq, Generic, FromForm)
instance A.ToJSON ErrorResponse where data SignupForm = SignupForm
toJSON e = { sfDisplayName :: Text
A.object , sfEmail :: Text
[ "error" A..= errorMessage e , sfPassword :: Text
, "field" A..= errorField e , sfConfirm :: Text
] , sfAgree :: Bool
}
deriving (Show, Eq, Generic, FromForm)
---------------------------------------------------------------------- data ChoreFormData = ChoreFormData
-- Seed { cfdName :: Text
---------------------------------------------------------------------- , cfdScheduleType :: Text
, cfdStartDate :: Text
, cfdTimeOfDay :: Maybe Text
, cfdPeriod :: Text
, cfdAssignee :: Text
, cfdNotify :: Bool
}
deriving (Show, Eq, Generic, FromForm)
data SeedRequest = SeedRequest data ActivityFormData = ActivityFormData
deriving stock (Show, Eq) { afdStatus :: Text
, afdNote :: Maybe Text
, afdNotify :: Bool
}
deriving (Show, Eq, Generic, FromForm)
instance A.FromJSON SeedRequest where newtype HouseholdFormData = HouseholdFormData
parseJSON _ = pure SeedRequest { hfdName :: Text
}
deriving stock (Show, Eq, Generic)
deriving anyclass (FromForm)
+92
View File
@@ -0,0 +1,92 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
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 (nbButtonDefaultClass, nbHeadingClass, nbNavbarClass, nbNavbarLinkClass)
import Web.Hyperbole
import Web.Hyperbole.Data.URI (uriToText)
import Web.Hyperbole.Effect.Session
----------------------------------------------------------------------
-- 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 ""
----------------------------------------------------------------------
-- Document Head
----------------------------------------------------------------------
documentHead :: View DocumentHead ()
documentHead = do
title "Sis — Household Chore Tracker"
mobileFriendly
meta @ att "charset" "UTF-8"
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
----------------------------------------------------------------------
-- Navbar
----------------------------------------------------------------------
navbar :: UserSession -> View ctx ()
navbar us = do
el @ att "class" nbNavbarClass $ do
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 RActivity "Activity"
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
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
+9 -21
View File
@@ -2,27 +2,15 @@ resolver: lts-24.38
packages: packages:
- . - .
- hyperbole-local
extra-deps: extra-deps:
- github: flipstone/beeline - atomic-css-0.2.0
commit: e31206f52fec7e96c15de9a2bab9ef1876db137b - data-default-0.8.0.2
subdirs: - effectful-2.4.0.0
- beeline-params - effectful-core-2.4.0.0
- beeline-routing - string-conversions-0.4.0.1
- github: flipstone/shrubbery - attoparsec-aeson-2.2.2.0
commit: a064ede07e01b753a6eb310fc24d9fd8da1ad826 - string-interpolate-0.3.4.0
- github: flipstone/json-fleece
commit: 77813eac694f937b6e013230825f03aba224f866
subdirs:
- json-fleece-aeson
- json-fleece-core
- github: flipstone/bounded-text
commit: 3ef94eeda5402857423284d0c4e021a8c8032498
- github: flipstone/orb
commit: 74cceef9d0db9ac3ef1856613e7605750c8c0a2a
- template-haskell-lift-0.1.0.0
- template-haskell-quasiquoter-0.1.0.0
flags: allow-newer: true
orb:
ci: true
+28 -78
View File
@@ -5,104 +5,54 @@
packages: packages:
- completed: - completed:
name: beeline-params hackage: atomic-css-0.2.0@sha256:7a546465724689e55c9b9cad64da7c361f2de728430f994a73f906985b164c09,3106
pantry-tree: pantry-tree:
sha256: 44791687ad987b596ff02fd1776386bef293a27e097c7c589a3bb76a9a81f200 sha256: 0f13530abe495d48d977abe09747749dc7d3911629c5a8107e067f4446bfea25
size: 1210 size: 1931
sha256: 93fff6138e28d8989741b4fc8622096d2211dad35f1d113a341d89d0d3235d8f
size: 36315
subdir: beeline-params
url: https://github.com/flipstone/beeline/archive/e31206f52fec7e96c15de9a2bab9ef1876db137b.tar.gz
version: 0.3.0.0
original: original:
subdir: beeline-params hackage: atomic-css-0.2.0
url: https://github.com/flipstone/beeline/archive/e31206f52fec7e96c15de9a2bab9ef1876db137b.tar.gz
- completed: - completed:
name: beeline-routing hackage: data-default-0.8.0.2@sha256:d4a8c9ed574a43315262666c75efe1080e3913a653844d2a9ff36051a6211bee,1110
pantry-tree: pantry-tree:
sha256: 555ab8a55094ffa801fa8ee8e8fc9b11ec21c08cff29e5dc152ae7f171fa3ccd sha256: 6f42bc6c080c5e1cb7894b03b2d1494a05b9056dcef477965205e9448d8889f8
size: 1119 size: 382
sha256: 93fff6138e28d8989741b4fc8622096d2211dad35f1d113a341d89d0d3235d8f
size: 36315
subdir: beeline-routing
url: https://github.com/flipstone/beeline/archive/e31206f52fec7e96c15de9a2bab9ef1876db137b.tar.gz
version: 0.3.0.2
original: original:
subdir: beeline-routing hackage: data-default-0.8.0.2
url: https://github.com/flipstone/beeline/archive/e31206f52fec7e96c15de9a2bab9ef1876db137b.tar.gz
- completed: - completed:
name: shrubbery hackage: effectful-2.4.0.0@sha256:a821150318cda9c9c8d17230de8b3c6df47d3be9aba6aeb9faaf28a80bf374c5,7670
pantry-tree: pantry-tree:
sha256: d16c6b171d9b360098760d2c2269ded8eaae823ed9aa5c7a36598673e83fb9e3 sha256: 2debfdcf5f46f02ce8c9f4cbed19496bf92dcfbd198eb319a0c0269af0db425f
size: 2834 size: 3409
sha256: 8bb3b52a8f9cb3f6edc5ee0c4584c81187b05966d59d718a247a6707479e2e33
size: 30344
url: https://github.com/flipstone/shrubbery/archive/a064ede07e01b753a6eb310fc24d9fd8da1ad826.tar.gz
version: 0.2.3.1
original: original:
url: https://github.com/flipstone/shrubbery/archive/a064ede07e01b753a6eb310fc24d9fd8da1ad826.tar.gz hackage: effectful-2.4.0.0
- completed: - completed:
name: json-fleece-aeson hackage: effectful-core-2.4.0.0@sha256:fd799704b5a8bc3a7b7709a5ffa33584602b98e5f3b8b1e9c770816dd9f8ccc3,4395
pantry-tree: pantry-tree:
sha256: 1519042c7af52c169b4543d0de5639d344f3ea8652461fdc8d85f26b0d318f5a sha256: 49af204868918943e05f709f9cf9c5c93c60f5614a0ee1d31cd29f678bf960ce
size: 628 size: 2473
sha256: 534fdb939c428db16fc6c07d3fe1c709ebc0b5b43c490f89639d6093ea12d8f3
size: 3095867
subdir: json-fleece-aeson
url: https://github.com/flipstone/json-fleece/archive/77813eac694f937b6e013230825f03aba224f866.tar.gz
version: 0.5.1.0
original: original:
subdir: json-fleece-aeson hackage: effectful-core-2.4.0.0
url: https://github.com/flipstone/json-fleece/archive/77813eac694f937b6e013230825f03aba224f866.tar.gz
- completed: - completed:
name: json-fleece-core hackage: string-conversions-0.4.0.1@sha256:9af49d61d1dcbc8b90b66f1b6580996b7927f745273edb59141ad6744aef7cbc,1693
pantry-tree: pantry-tree:
sha256: 87d6a45a9b470843d28d1c2927b8f12ad4f687d987bad630e04ead9e824ee0a9 sha256: 95b5bc46689b408ad3c898388bc55fe36612451d521c6cdd5beeb93a033d4848
size: 491 size: 442
sha256: 534fdb939c428db16fc6c07d3fe1c709ebc0b5b43c490f89639d6093ea12d8f3
size: 3095867
subdir: json-fleece-core
url: https://github.com/flipstone/json-fleece/archive/77813eac694f937b6e013230825f03aba224f866.tar.gz
version: 0.12.0.0
original: original:
subdir: json-fleece-core hackage: string-conversions-0.4.0.1
url: https://github.com/flipstone/json-fleece/archive/77813eac694f937b6e013230825f03aba224f866.tar.gz
- completed: - completed:
name: bounded-text hackage: attoparsec-aeson-2.2.2.0@sha256:08948f45b892c5758d2c42e22fe2fbd41a4f6dc395fb0a43c2bf458a1f295736,1664
pantry-tree: pantry-tree:
sha256: e98540b1877ae4709420472f83e8fd04b987eaeb914df72bb33b0bbe55debac2 sha256: da131689cab810d63fefbca44bb40aa96be6ab5981e11308eef73b57edfe26c6
size: 2162 size: 404
sha256: 29c500737d8e481fe2e3325fe643a9cafc565ffd06b754bf14219f579d927f5d
size: 11885
url: https://github.com/flipstone/bounded-text/archive/3ef94eeda5402857423284d0c4e021a8c8032498.tar.gz
version: 0.1.2.0
original: original:
url: https://github.com/flipstone/bounded-text/archive/3ef94eeda5402857423284d0c4e021a8c8032498.tar.gz hackage: attoparsec-aeson-2.2.2.0
- completed: - completed:
name: orb hackage: string-interpolate-0.3.4.0@sha256:b58f8d4f2d591878b3e632dc36b210582d41e72f5e6484a2e42a647a57b85a18,4274
pantry-tree: pantry-tree:
sha256: 8888da81f391b551df85ce50b9f8ec7349dcf87b3a062780cf71d915c8c7e0e1 sha256: 73130fdccd3de97e38971a0dc002fd303fc83db3019ccebf739fe4bc45735822
size: 6804 size: 1248
sha256: 47bc481b103d86fe38bd0b94d09d88f242e657073108018a2e4652e695636f0f
size: 1194518
url: https://github.com/flipstone/orb/archive/74cceef9d0db9ac3ef1856613e7605750c8c0a2a.tar.gz
version: 0.7.1.0
original: original:
url: https://github.com/flipstone/orb/archive/74cceef9d0db9ac3ef1856613e7605750c8c0a2a.tar.gz hackage: string-interpolate-0.3.4.0
- completed:
hackage: template-haskell-lift-0.1.0.0@sha256:f6cd3ee45b0c68480c400bfca9f08f39e8e87a5eb823f206dbe06ab1923a4f1c,1136
pantry-tree:
sha256: 56ab994094c839bebb643ce5fc58dfae6269517ebe91f380e259adaf1def08bf
size: 243
original:
hackage: template-haskell-lift-0.1.0.0
- completed:
hackage: template-haskell-quasiquoter-0.1.0.0@sha256:71027c432c0fb1a293d0f2b1d46dd5be42b9703b7c4b2233ea8076bfc6f84aae,1181
pantry-tree:
sha256: f9f5177a522cc273c001dd5bd749e4f7ed841910c6136711b9b9825bc0bc9c56
size: 257
original:
hackage: template-haskell-quasiquoter-0.1.0.0
snapshots: snapshots:
- completed: - completed:
sha256: abc790b571e0c70e929db74b329e3c18d7e76a6e173e8bdf94f1ba20770d4c24 sha256: abc790b571e0c70e929db74b329e3c18d7e76a6e173e8bdf94f1ba20770d4c24
+72
View File
@@ -0,0 +1,72 @@
const { chromium } = require('playwright');
(async () => {
const browser = await chromium.launch({ headless: true });
const context = await browser.newContext();
const page = await context.newPage();
page.on('console', msg => console.log('CONSOLE:', msg.type(), msg.text().substring(0, 150)));
page.on('pageerror', err => console.log('PAGE ERROR:', err.message));
// Step 1: Load login page
console.log('\n=== Step 1: Load login page ===');
await page.goto('http://localhost:8080/rlogin', { waitUntil: 'networkidle', timeout: 10000 });
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');
await page.click('button[type="submit"]');
await page.waitForTimeout(3000);
console.log('URL after submit:', page.url());
// Check cookies
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); });
+58
View File
@@ -0,0 +1,58 @@
const { chromium } = require('playwright');
(async () => {
const browser = await chromium.launch({ headless: true });
const page = await browser.newPage();
// Collect console and page errors
const errors = [];
page.on('console', msg => { if (msg.type() === 'error') errors.push(msg.text()); });
page.on('pageerror', err => errors.push(err.message));
// Test 1: Load login page
console.log("=== Test 1: Load login page ===");
await page.goto('http://localhost:8080/rlogin', { waitUntil: 'networkidle' });
const title = await page.title();
console.log("Title:", title);
const hasForm = await page.$('form') !== null;
console.log("Has form:", hasForm);
const hasWelcome = (await page.content()).includes('Welcome Back');
console.log("Has Welcome:", hasWelcome);
if (errors.length > 0) {
console.log("Errors on load:", errors);
}
// Test 2: Fill and submit login form
console.log("\n=== Test 2: Submit login form ===");
await page.fill('input[name="lfEmail"]', 'alice@demo.com');
await page.fill('input[name="lfPassword"]', 'password123');
await page.check('input[name="lfRemember"]');
// Listen for response
const [response] = await Promise.all([
page.waitForResponse(resp => resp.url().includes('/rlogin'), { timeout: 5000 }).catch(() => null),
page.click('button[type="submit"]')
]);
console.log("Response status:", response ? response.status() : 'no response');
// Wait for navigation or content change
await page.waitForTimeout(2000);
const content = await page.content();
console.log("Page contains 'Dashboard':", content.includes('Dashboard') || content.includes('Overdue'));
console.log("Page contains error:", content.includes('Invalid') || content.includes('error'));
if (errors.length > 0) {
console.log("Errors after submit:", errors);
}
// Test 3: Try signup
console.log("\n=== Test 3: Load signup page ===");
await page.goto('http://localhost:8080/rsignup', { waitUntil: 'networkidle' });
const hasCreate = (await page.content()).includes('Create Account');
console.log("Has Create Account:", hasCreate);
await browser.close();
console.log("\nDone.");
})().catch(e => { console.error("Test failed:", e.message); process.exit(1); });
+97
View File
@@ -0,0 +1,97 @@
// @ts-check
const { test, expect } = require('@playwright/test');
const BASE_URL = process.env.SIS_URL || 'http://localhost:8080';
// Hyperbole lowercases constructor names for URLs: RDashboard -> /rdashboard
const URLS = {
signup: `${BASE_URL}/rsignup`,
login: `${BASE_URL}/rlogin`,
dashboard: `${BASE_URL}/rdashboard`,
chores: `${BASE_URL}/rchores`,
household: `${BASE_URL}/rhousehold`,
activity: `${BASE_URL}/ractivity`,
};
test.describe('Sis app smoke test', () => {
test('full flow: signup → login → create household → create chore', async ({ page }) => {
const unique = Date.now();
const email = `test-${unique}@example.com`;
const displayName = 'James Brechtel';
const password = 'password123';
const householdName = 'Test Casa';
const choreName = 'Take out the trash';
// ── 1. Sign up ──────────────────────────────────────────────
await page.goto(URLS.signup);
await page.waitForSelector('input[name="sfDisplayName"]', { timeout: 5000 });
// Fill out the signup form
await page.fill('input[name="sfDisplayName"]', displayName);
await page.fill('input[name="sfEmail"]', email);
await page.fill('input[name="sfPassword"]', password);
await page.fill('input[name="sfConfirm"]', password);
await page.check('input[name="sfAgree"]');
// Submit (Hyperbole replaces content in-place, no navigation)
await Promise.all([
page.waitForResponse(resp => resp.url().includes('/rsignup') && resp.status() === 200),
page.click('button[type="submit"]'),
]);
// Signup success page has a "Go to Dashboard" link
await expect(page.getByText('Account Created!')).toBeVisible({ timeout: 10000 });
await page.click('a:has-text("Go to Dashboard")');
// Now on dashboard or household page (no household yet)
await expect(page.locator('.nb-navbar-brand')).toBeVisible({ timeout: 10000 });
// ── 2. Create household ─────────────────────────────────────
const householdLink = page.locator('.nb-navbar-link', { hasText: 'Household' });
await householdLink.click();
// Should see the "Create Your Household" form
await expect(page.getByText('Create Your Household')).toBeVisible({ timeout: 10000 });
await page.fill('input[name="hfdName"]', householdName);
await Promise.all([
page.waitForResponse(resp => resp.url().includes('/rhousehold') && resp.status() === 200),
page.click('button[type="submit"]'),
]);
// Should see the household view with member count
await expect(page.getByText('1 members')).toBeVisible({ timeout: 10000 });
await expect(page.getByText(householdName)).toBeVisible();
// ── 3. Create chore ─────────────────────────────────────────
const choresLink = page.locator('.nb-navbar-link', { hasText: 'Chores' });
await choresLink.click();
// Click "+ New Chore" to open the form
const newChoreBtn = page.getByRole('button', { name: '+ New Chore' });
await newChoreBtn.click();
// Fill out the chore form
await expect(page.getByText('New Chore')).toBeVisible({ timeout: 10000 });
await page.fill('input[name="cfdName"]', choreName);
await page.fill('input[name="cfdStartDate"]', '2026-12-25');
// Submit
await Promise.all([
page.waitForResponse(resp => resp.url().includes('/rchores') && resp.status() === 200),
page.click('button[type="submit"]'),
]);
// Should appear in the chores list
await expect(page.getByText(choreName)).toBeVisible({ timeout: 10000 });
await expect(page.getByText('One-off on 2026-12-25')).toBeVisible();
// ── 4. Verify we're still authenticated ────────────────────
// Navigate to dashboard — should work since we have a session cookie
await page.goto(URLS.dashboard);
await expect(page.locator('.nb-navbar-brand')).toBeVisible({ timeout: 10000 });
await expect(page.getByText('Dashboard')).toBeVisible({ timeout: 5000 });
});
});
+183
View File
@@ -0,0 +1,183 @@
# Sis — Build Tasks
A household chore-tracking web app (PWA-capable, with push notifications). These tasks describe **what** to build and the behavior required. Technical stack decisions (language, framework, database, hosting, push provider, auth library) are intentionally left out — fill them in per your chosen agent.
Styling reference for all UI: [NeoBrutalismCSS](https://matifandy8.github.io/NeoBrutalismCSS/) via CDN `https://cdn.jsdelivr.net/gh/matifandy8/NeoBrutalismCSS/dist/index.min.css`. Mockup screenshots are attached for the target look and layout.
---
## Domain Model (reference for all tasks)
- **User** — an account. Has display name, email, password (hashed). Belongs to zero or more Households.
- **Household** — a named group. Created by a User (the owner). Has many members. A User can belong to multiple Households and switch between them.
- **Membership** — links a User to a Household with a role (`owner` | `member`).
- **Invite** — a pending invitation to a Household, by email or shareable link/code. States: `pending` | `accepted` | `revoked`.
- **Chore** — belongs to a Household. Has a name, an optional assignee (a member, or "anyone"), a Schedule, and an optional "notify on due" flag.
- **Schedule** — the timing rule for a Chore. One of:
- `one_off` — a specific date, or date+time.
- `recurring` — a period of `daily` | `weekly` | `monthly`, with a start date and optional time-of-day.
- `sometime` — no due date; open-ended "someday" task.
- **Occurrence** — a single dated instance of a Chore. One-off/sometime chores have one occurrence; recurring chores generate occurrences per period. Occurrences drive the "due today / overdue" views and are what Activities attach to.
- **Activity** — a record that a User acted on a specific **Occurrence**. Has a status (`completed` | `skipped`), an optional free-text note, the acting user, and a timestamp.
---
## Milestone 1 — Accounts & Authentication
### Task 1.1 — User registration (Sign Up)
- Build a sign-up screen: display name, email, password, confirm password, and an agreement checkbox.
- Validate: unique email, password strength, matching confirmation. Show inline field errors.
- On success, create the account and log the user in.
- Screen: see `signup.png`.
### Task 1.2 — Login
- Build a login screen: email, password, "remember me", and a "forgot password" link.
- Authenticate credentials; on failure show a clear error without revealing which field was wrong.
- Persist the session; "remember me" extends session lifetime.
- Screen: see `login.png`.
### Task 1.3 — Password reset
- "Forgot password" flow: request reset by email, deliver a reset link/token, allow setting a new password.
- Expire reset tokens after a short window and after use.
### Task 1.4 — Session & route protection
- Redirect unauthenticated users to login for any app route.
- Provide logout.
- After login, land the user on the Today/dashboard view of their current Household (or the create-household flow if they have none).
---
## Milestone 2 — Households & Membership
### Task 2.1 — Create a household
- Any logged-in user can create a Household by giving it a name.
- The creator becomes the `owner` and first member.
- Support a user belonging to multiple households, with a way to switch the "active" household (see the "Your Households" switcher in `household.png`).
### Task 2.2 — Household management screen
- Show household name, member count, and creator.
- List all members with avatar (initials), display name, email, and role badge (Owner/Member).
- Screen: see `household.png`.
### Task 2.3 — Invite members
- Invite by email address (sends an invitation) **and** by a shareable join link/code.
- Show a list of pending invites with invited-date and a "Revoke" action.
- Screen: invite panel and pending-invites panel in `household.png`.
### Task 2.4 — Accept / join a household
- Handle an invited user clicking a join link or code: if logged out, route through login/sign-up first, then join.
- On accept, create a membership and mark the invite `accepted`.
- Prevent duplicate memberships and joining via revoked/expired invites.
### Task 2.5 — Roles & permissions
- Owner can: rename household, invite, revoke invites, remove members, delete household.
- Members can: manage chores and record activity (per product decision below).
- Enforce that a user can only see/act within households they belong to.
---
## Milestone 3 — Chores & Schedules
### Task 3.1 — Chore list (management)
- List all chores in the active household with: name, assignee, a human-readable schedule summary ("Recurs Daily at 8:00 AM", "One-off on Jul 20", "Sometime"), and a schedule-type badge.
- Provide Edit and Delete per chore, and a "New Chore" entry point.
- Screen: left panel of `chores.png`.
### Task 3.2 — Create / edit chore form
- Fields: chore name, assign-to (a specific member or "Anyone in household").
- Schedule-type selector: **One-off**, **Recurring**, **Sometime** (mutually exclusive).
- One-off → date, optional time.
- Recurring → period selector (Daily / Weekly / Monthly), start date, optional time-of-day. For weekly, allow choosing day(s) of week; for monthly, allow day-of-month.
- Sometime → no date inputs.
- "Send push reminder when due" toggle.
- Validate inputs per schedule type; show the relevant fields dynamically.
- Screen: right panel (edit form) of `chores.png`.
### Task 3.3 — Occurrence generation
- Generate occurrences from a chore's schedule so the Today/overdue views can list concrete dated items.
- Recurring chores should produce upcoming occurrences without unbounded growth (generate a rolling window and extend over time).
- Recompute when a chore's schedule is edited; handle deletion gracefully (past activity records should remain intact for history).
### Task 3.4 — Dashboard / "Today" view
- Show the active household name and today's date.
- Stat tiles: count of Overdue, Due Today, and Done This Week.
- "Overdue & Due Today" panel: list occurrences that are overdue or due today, each with assignee, due info, overdue emphasis, and a quick check-off control.
- "Completed Today" panel: today's completed/skipped activities with actor, time, and any note.
- Link to the full Activity Log.
- Screen: see `dashboard.png`.
---
## Milestone 4 — Activity Recording & History
### Task 4.1 — Record activity (complete / skip an occurrence)
- From a due/overdue occurrence, open a "Record Activity" dialog.
- Show which chore and which occurrence (date) is being acted on, plus assignee.
- Choose status: **Completed** or **Skipped**.
- Optional free-text note.
- "Notify household of this update" toggle.
- On save, create an Activity tied to that specific occurrence and update the dashboard state.
- Screen: see `record-activity.png`.
### Task 4.2 — Activity log (viewing history)
- A full, paginated log across the household: columns for Chore, Occurrence date, Member (avatar + name), Status badge, Note, and Recorded timestamp.
- Filters by member and by status (Completed / Skipped).
- Screen: see `activity-log.png`.
### Task 4.3 — Activity integrity rules
- Each activity applies to one specific occurrence (important for recurring chores).
- Prevent duplicate active records for the same occurrence unless the product allows re-recording (define: allow updating the latest record, keep history).
- Notes are optional and preserved for posterity even if the underlying chore is later edited or deleted.
---
## Milestone 5 — PWA & Push Notifications
### Task 5.1 — Progressive Web App setup
- Add a web app manifest (name, icons, theme colors, standalone display) so the app is installable on mobile home screens.
- Add offline-capable shell behavior appropriate for the app (at minimum, graceful handling when offline).
- Ensure the app is responsive and usable on phone-sized screens (the mockups are desktop; provide mobile layouts).
### Task 5.2 — Push notification subscription
- Prompt users to enable push notifications (per device/browser).
- Store push subscriptions per user/device; allow disabling.
### Task 5.3 — Notification triggers
- **Overdue chore** — notify the assignee (or household, for "anyone" chores) when an occurrence becomes overdue.
- **Completed/skipped chore** — when a member records an activity with "notify household" enabled, notify other household members.
- **Due reminder** — for chores with "send push reminder when due", notify at the due time.
- Deduplicate and avoid notification spam (e.g., one overdue nudge per occurrence, sensible batching).
### Task 5.4 — Scheduled evaluation
- A recurring background process to evaluate occurrences, mark overdue states, fire due/overdue notifications, and roll the occurrence window forward.
---
## Milestone 6 — Styling, Polish & Cross-Cutting
### Task 6.1 — Apply the NeoBrutalismCSS design system
- Use the CDN stylesheet across all screens; match the attached mockups (bold borders, hard drop shadows, uppercase Lexend Mega headings, the dotted cream background, and the yellow/green/blue/orange/red accent palette).
- Reusable components: top nav bar with active-state, stat tiles, list "item" rows, badges/pills, panels, tables, and the modal dialog.
### Task 6.2 — Empty, loading, and error states
- Design empty states (no chores yet, no members yet, no activity yet), loading indicators, and inline/error messaging consistent with the design.
### Task 6.3 — Validation & security cross-cuts
- Server-side validation on every form; never trust client input.
- Authorization checks on every household-scoped action.
- Hashed passwords, protected sessions, and safe handling of invite tokens.
### Task 6.4 — Seed / demo data (optional)
- Provide a way to seed a demo household with sample members, chores, and activity for testing and screenshots.
---
## Suggested build order
1. Milestone 1 (Auth) → 2. Milestone 2 (Households) → 3. Milestone 3 (Chores/Schedules/Dashboard) → 4. Milestone 4 (Activity) → 5. Milestone 5 (PWA/Push) → 6. Milestone 6 (polish, applied throughout).
## Open product decisions to confirm before building
- Can any member manage (edit/delete) chores, or only the owner/creator?
- Can activity records be edited/undone after saving, or are they append-only?
- For "anyone" chores, does completing an occurrence clear it for everyone?
- Weekly/monthly recurrence granularity — is specific day-of-week / day-of-month needed, or is "every 7 / 30 days from start" sufficient?
- How far ahead should recurring occurrences be visible/generated?
Binary file not shown.

After

Width:  |  Height:  |  Size: 172 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 57 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 68 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 179 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 168 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 176 KiB