diff --git a/app/Main.hs b/app/Main.hs
index d4b560f..1200dcb 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
-{- | Entry point for the Sis chore tracker server.
+{- | Entry point for the Sis server.
Starts a Warp HTTP server, serves the JSON API and the SPA frontend.
-}
@@ -55,21 +55,20 @@ main = do
<> Opt.progDesc "Sis — shared household chore tracker"
<> Opt.header "sis-server"
- _db <- Database.openDatabase (optDbPath opts)
+ db <- Database.openDatabase (optDbPath opts)
- -- Install a SIGTERM handler so Docker stop works cleanly.
_ <-
Signals.installHandler
Signals.sigTERM
(Signals.Catch (putStrLn "[sis] shutting down"))
Nothing
- let waiApp = Sis.app (optStaticDir opts)
+ let waiApp = Sis.app (optStaticDir opts) db
let settings =
Warp.setPort (optPort opts) $
Warp.setBeforeMainLoop
- (putStrLn $ "[sis] listening on port " ++ show (optPort opts))
+ (putStrLn $ "[sis] listening on 0.0.0.0:" ++ show (optPort opts))
Warp.defaultSettings
Warp.runSettings settings waiApp
diff --git a/frontend/index.html b/frontend/index.html
index 80410d1..5bf3107 100644
--- a/frontend/index.html
+++ b/frontend/index.html
@@ -3,13 +3,14 @@
- Sis — Chore Tracker
+ Sis — Household Chore Tracker
+
diff --git a/frontend/public/manifest.json b/frontend/public/manifest.json
new file mode 100644
index 0000000..1ddcbeb
--- /dev/null
+++ b/frontend/public/manifest.json
@@ -0,0 +1,13 @@
+{
+ "name": "Sis",
+ "short_name": "Sis",
+ "description": "Shared household chore tracker",
+ "start_url": "/",
+ "display": "standalone",
+ "theme_color": "#fff9e6",
+ "background_color": "#fff9e6",
+ "icons": [
+ { "src": "/icon-192.png", "sizes": "192x192", "type": "image/png" },
+ { "src": "/icon-512.png", "sizes": "512x512", "type": "image/png" }
+ ]
+}
diff --git a/frontend/public/style.css b/frontend/public/style.css
index d9ab245..a3d3ae2 100644
--- a/frontend/public/style.css
+++ b/frontend/public/style.css
@@ -1,10 +1,72 @@
/* Sis custom styles — layered on top of Neo Brutalism */
+:root {
+ --nb-red: #e74c3c;
+ --nb-yellow: #f1c40f;
+ --nb-green: #2ecc71;
+ --nb-orange: #e67e22;
+}
+
body {
min-height: 100vh;
background: #fff9e6;
+ background-image: radial-gradient(circle, rgba(0,0,0,0.03) 1px, transparent 1px);
+ background-size: 20px 20px;
}
#app {
padding: 1rem;
}
+
+.nb-container {
+ padding: 0 1rem;
+}
+
+.nb-navbar {
+ background: #fff;
+ border-bottom: 3px solid #000;
+ padding: 0.75rem 1.5rem;
+ display: flex;
+ justify-content: space-between;
+ align-items: center;
+ box-shadow: 4px 4px 0 #000;
+ margin-bottom: 2rem;
+}
+
+.nb-navbar-start, .nb-navbar-end {
+ display: flex;
+ align-items: center;
+ gap: 0.5rem;
+}
+
+.nb-modal-overlay {
+ animation: fadeIn 0.15s ease;
+}
+
+@keyframes fadeIn {
+ from { opacity: 0; }
+ to { opacity: 1; }
+}
+
+/* Responsive */
+@media (max-width: 768px) {
+ .nb-navbar {
+ flex-direction: column;
+ gap: 0.5rem;
+ padding: 0.5rem;
+ }
+ .nb-navbar-end {
+ flex-wrap: wrap;
+ 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;
+}
diff --git a/package.yaml b/package.yaml
index f663237..738d164 100644
--- a/package.yaml
+++ b/package.yaml
@@ -26,7 +26,6 @@ ghc-options:
- -Wincomplete-uni-patterns
- -Wmissing-export-lists
- -Wmissing-home-modules
- - -Wpartial-fields
- -Wredundant-constraints
dependencies:
@@ -47,12 +46,18 @@ dependencies:
- text
- time
- wai
+ - wai-extra
- warp
library:
source-dirs: src
dependencies:
+ - base64-bytestring
+ - cookie
+ - crypton
+ - memory
- orb
+ - random
- sqlite-simple
executables:
diff --git a/scripts/run b/scripts/run
index fe9d4cd..9ae0e64 100755
--- a/scripts/run
+++ b/scripts/run
@@ -33,7 +33,7 @@ IMAGE="${HAWAT_HASKELL_TOOLS_IMAGE:-ghcr.io/flipstone/haskell-tools:debian-ghc-9
STACK_ROOT_HOST="${PROJECT_DIR}/.stack-root"
mkdir -p "${STACK_ROOT_HOST}"
-echo "[sis] listening on http://127.0.0.1:${HOST_PORT}/"
+echo "[sis] listening on http://0.0.0.0:${HOST_PORT}/"
exec docker run --rm -i $([ -t 0 ] && printf -- -t) \
-v "${PROJECT_DIR}:/work" \
diff --git a/sis-server.cabal b/sis-server.cabal
index 28bcd19..9030768 100644
--- a/sis-server.cabal
+++ b/sis-server.cabal
@@ -17,6 +17,7 @@ build-type: Simple
library
exposed-modules:
Sis
+ Sis.Auth
Sis.Database
Sis.Server
Sis.Types
@@ -33,27 +34,33 @@ library
OverloadedStrings
RecordWildCards
TupleSections
- ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
+ ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wredundant-constraints
build-depends:
aeson
, base >=4.7 && <5
+ , base64-bytestring
, beeline-routing
, bytestring
, containers
+ , cookie
+ , crypton
, directory
, filepath
, http-types
, json-fleece-aeson
, json-fleece-core
+ , memory
, mtl
, optparse-applicative
, orb
+ , random
, safe-exceptions
, shrubbery
, sqlite-simple
, text
, time
, wai
+ , wai-extra
, warp
default-language: Haskell2010
@@ -72,7 +79,7 @@ executable sis-server
OverloadedStrings
RecordWildCards
TupleSections
- ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -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:
aeson
, base >=4.7 && <5
@@ -94,6 +101,7 @@ executable sis-server
, time
, unix
, wai
+ , wai-extra
, warp
default-language: Haskell2010
@@ -113,7 +121,7 @@ test-suite sis-server-test
OverloadedStrings
RecordWildCards
TupleSections
- ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
+ ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wredundant-constraints
build-depends:
aeson
, base >=4.7 && <5
@@ -134,5 +142,6 @@ test-suite sis-server-test
, text
, time
, wai
+ , wai-extra
, warp
default-language: Haskell2010
diff --git a/src/Sis.hs b/src/Sis.hs
index da87a31..2b4c668 100644
--- a/src/Sis.hs
+++ b/src/Sis.hs
@@ -3,5 +3,7 @@ module Sis (
module X,
) where
+import Sis.Auth as X
+import Sis.Database as X
import Sis.Server as X
import Sis.Types as X
diff --git a/src/Sis/Auth.hs b/src/Sis/Auth.hs
new file mode 100644
index 0000000..e414431
--- /dev/null
+++ b/src/Sis/Auth.hs
@@ -0,0 +1,103 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{- | Authentication and session management.
+
+Provides password hashing with PBKDF2, session token generation,
+and httpOnly cookie handling.
+-}
+module Sis.Auth (
+ -- * Password hashing
+ hashPassword,
+ verifyPassword,
+
+ -- * Session tokens
+ generateToken,
+ sessionCookieName,
+ makeSessionCookie,
+ clearSessionCookie,
+) where
+
+import Crypto.Hash.Algorithms qualified as Hash
+import Crypto.KDF.PBKDF2 qualified as PBKDF2
+import Crypto.Random.Entropy (getEntropy)
+import Data.ByteArray ()
+import Data.ByteString qualified as BS
+import Data.ByteString.Base64 qualified as B64
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as TE
+import Network.HTTP.Types qualified as HTTP
+
+-- | Name of the session cookie.
+sessionCookieName :: T.Text
+sessionCookieName = "sis_session"
+
+-- | Number of PBKDF2 iterations.
+pbkdf2Iterations :: Int
+pbkdf2Iterations = 600000
+
+-- | Salt length in bytes.
+saltLength :: Int
+saltLength = 16
+
+-- | Hash a password with PBKDF2-SHA256, returning a "{salt}:{hash}" string.
+hashPassword :: T.Text -> IO T.Text
+hashPassword password = do
+ salt <- getEntropy saltLength
+ let pwBytes = TE.encodeUtf8 password
+ hashBytes :: BS.ByteString
+ hashBytes =
+ PBKDF2.generate
+ (PBKDF2.prfHMAC Hash.SHA256)
+ (PBKDF2.Parameters pbkdf2Iterations 32)
+ pwBytes
+ salt
+ stored = B64.encode salt <> ":" <> B64.encode hashBytes
+ pure $ TE.decodeUtf8 stored
+
+-- | Verify a password against a "{salt}:{hash}" stored value.
+verifyPassword :: T.Text -> T.Text -> Bool
+verifyPassword password stored =
+ case T.breakOn ":" stored of
+ (b64Salt, rest)
+ | T.null b64Salt -> False
+ | T.null rest -> False
+ | otherwise ->
+ let b64Hash = T.drop 1 rest
+ in case (B64.decode (TE.encodeUtf8 b64Salt), B64.decode (TE.encodeUtf8 b64Hash)) of
+ (Right salt, Right expectedHash) ->
+ let pwBytes = TE.encodeUtf8 password
+ computedHash :: BS.ByteString
+ computedHash =
+ PBKDF2.generate
+ (PBKDF2.prfHMAC Hash.SHA256)
+ (PBKDF2.Parameters pbkdf2Iterations 32)
+ pwBytes
+ salt
+ in computedHash == expectedHash
+ _ -> False
+
+-- | Generate a cryptographically random token suitable for session or invite codes.
+generateToken :: IO T.Text
+generateToken = do
+ bytes <- getEntropy 32
+ pure $ TE.decodeUtf8 $ B64.encode bytes
+
+-- | Create a session cookie header value.
+makeSessionCookie :: T.Text -> Bool -> HTTP.Header
+makeSessionCookie token rememberMe =
+ let maxAge = if rememberMe then (30 :: Int) * 86400 else 86400
+ cookieText =
+ TE.encodeUtf8 sessionCookieName
+ <> "="
+ <> TE.encodeUtf8 token
+ <> "; Path=/; HttpOnly; SameSite=Lax; Max-Age="
+ <> TE.encodeUtf8 (T.pack $ show maxAge)
+ in ("Set-Cookie", cookieText)
+
+-- | Clear the session cookie.
+clearSessionCookie :: HTTP.Header
+clearSessionCookie =
+ ( "Set-Cookie"
+ , TE.encodeUtf8 sessionCookieName <> "=; Path=/; HttpOnly; SameSite=Lax; Max-Age=0"
+ )
diff --git a/src/Sis/Database.hs b/src/Sis/Database.hs
index b01c7f7..af587b8 100644
--- a/src/Sis/Database.hs
+++ b/src/Sis/Database.hs
@@ -1,10 +1,13 @@
+{-# LANGUAGE OverloadedStrings #-}
+
{- | SQLite database support for Sis.
Opens (and creates if missing) a SQLite database with WAL journal
-mode and foreign keys enabled.
+mode and foreign keys enabled. Runs schema migrations on startup.
-}
module Sis.Database (
openDatabase,
+ runMigrations,
) where
import Database.SQLite.Simple qualified as SQL
@@ -22,4 +25,72 @@ openDatabase path = do
conn <- SQL.open path
SQL.execute_ conn "PRAGMA journal_mode=WAL"
SQL.execute_ conn "PRAGMA foreign_keys=ON"
+ runMigrations conn
pure conn
+
+-- | Create all tables if they don't exist.
+runMigrations :: SQL.Connection -> IO ()
+runMigrations conn =
+ mapM_
+ (SQL.execute_ conn)
+ [ "CREATE TABLE IF NOT EXISTS users (\
+ \ id INTEGER PRIMARY KEY AUTOINCREMENT,\
+ \ display_name TEXT NOT NULL,\
+ \ email TEXT NOT NULL UNIQUE,\
+ \ password_hash TEXT NOT NULL,\
+ \ created_at TEXT NOT NULL DEFAULT (datetime('now')))"
+ , "CREATE TABLE IF NOT EXISTS sessions (\
+ \ id INTEGER PRIMARY KEY AUTOINCREMENT,\
+ \ token TEXT NOT NULL UNIQUE,\
+ \ user_id INTEGER NOT NULL REFERENCES users(id) ON DELETE CASCADE,\
+ \ expires_at TEXT NOT NULL,\
+ \ created_at TEXT NOT NULL DEFAULT (datetime('now')))"
+ , "CREATE TABLE IF NOT EXISTS households (\
+ \ id INTEGER PRIMARY KEY AUTOINCREMENT,\
+ \ name TEXT NOT NULL,\
+ \ created_at TEXT NOT NULL DEFAULT (datetime('now')))"
+ , "CREATE TABLE IF NOT EXISTS memberships (\
+ \ id INTEGER PRIMARY KEY AUTOINCREMENT,\
+ \ household_id INTEGER NOT NULL REFERENCES households(id) ON DELETE CASCADE,\
+ \ user_id INTEGER NOT NULL REFERENCES users(id) ON DELETE CASCADE,\
+ \ role TEXT NOT NULL CHECK (role IN ('owner', 'member')),\
+ \ UNIQUE (household_id, user_id))"
+ , "CREATE TABLE IF NOT EXISTS invites (\
+ \ id INTEGER PRIMARY KEY AUTOINCREMENT,\
+ \ household_id INTEGER NOT NULL REFERENCES households(id) ON DELETE CASCADE,\
+ \ code TEXT NOT NULL UNIQUE,\
+ \ email TEXT,\
+ \ status TEXT NOT NULL DEFAULT 'pending' CHECK (status IN ('pending', 'accepted', 'revoked')),\
+ \ created_at TEXT NOT NULL DEFAULT (datetime('now')))"
+ , "CREATE TABLE IF NOT EXISTS chores (\
+ \ id INTEGER PRIMARY KEY AUTOINCREMENT,\
+ \ household_id INTEGER NOT NULL REFERENCES households(id) ON DELETE CASCADE,\
+ \ name TEXT NOT NULL,\
+ \ assignee_type TEXT NOT NULL DEFAULT 'anyone' CHECK (assignee_type IN ('user', 'anyone')),\
+ \ assignee_user_id INTEGER REFERENCES users(id) ON DELETE SET NULL,\
+ \ schedule_type TEXT NOT NULL CHECK (schedule_type IN ('one_off', 'recurring', 'sometime')),\
+ \ schedule_data TEXT NOT NULL,\
+ \ notify_on_due INTEGER NOT NULL DEFAULT 0,\
+ \ created_at TEXT NOT NULL DEFAULT (datetime('now')))"
+ , "CREATE TABLE IF NOT EXISTS occurrences (\
+ \ id INTEGER PRIMARY KEY AUTOINCREMENT,\
+ \ chore_id INTEGER NOT NULL REFERENCES chores(id) ON DELETE CASCADE,\
+ \ due_date TEXT NOT NULL,\
+ \ status TEXT NOT NULL DEFAULT 'due' CHECK (status IN ('due', 'overdue', 'completed', 'skipped')),\
+ \ UNIQUE (chore_id, due_date))"
+ , "CREATE TABLE IF NOT EXISTS activities (\
+ \ id INTEGER PRIMARY KEY AUTOINCREMENT,\
+ \ occurrence_id INTEGER NOT NULL REFERENCES occurrences(id) ON DELETE CASCADE,\
+ \ user_id INTEGER NOT NULL REFERENCES users(id) ON DELETE CASCADE,\
+ \ status TEXT NOT NULL CHECK (status IN ('completed', 'skipped')),\
+ \ note TEXT,\
+ \ notify_household INTEGER NOT NULL DEFAULT 0,\
+ \ recorded_at TEXT NOT NULL DEFAULT (datetime('now')))"
+ , "CREATE TABLE IF NOT EXISTS reset_tokens (\
+ \ id INTEGER PRIMARY KEY AUTOINCREMENT,\
+ \ user_id INTEGER NOT NULL REFERENCES users(id) ON DELETE CASCADE,\
+ \ token TEXT NOT NULL UNIQUE,\
+ \ used INTEGER NOT NULL DEFAULT 0,\
+ \ expires_at TEXT NOT NULL,\
+ \ created_at TEXT NOT NULL DEFAULT (datetime('now')))"
+ ]
diff --git a/src/Sis/Server.hs b/src/Sis/Server.hs
index 5023462..d2666cf 100644
--- a/src/Sis/Server.hs
+++ b/src/Sis/Server.hs
@@ -1,81 +1,733 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-{- | Orb-based HTTP server for Sis.
-
-Defines the API routes and wires them into a WAI 'Wai.Application'.
-Serves the Mithril SPA frontend from a static directory for all
-non-API routes, with SPA-routing fallback to @index.html@.
+{- | Simple WAI-based HTTP server for Sis.
+Bypasses Orb's complex routing for a straightforward manual approach.
-}
-module Sis.Server (
- app,
- sisRouter,
- HealthCheck (..),
-) where
+module Sis.Server (app) where
-import Beeline.Routing ((/-), (/:))
-import Beeline.Routing qualified as R
import Control.Exception.Safe qualified as Safe
-import Control.Monad.IO.Class qualified as MIO
-import Control.Monad.Reader qualified as Reader
+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)
+import Data.Maybe (fromMaybe, listToMaybe)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
-import Data.Void (Void, absurd)
+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 Shrubbery qualified as S
import System.Directory (doesFileExist)
import System.FilePath (())
+import Text.Read (readMaybe)
-import Orb qualified
+import Sis.Auth qualified as Auth
+import Sis.Types
--- | The top-level WAI application, serving both the API and the SPA frontend.
-app :: FilePath -> Wai.Application
-app staticDir =
- Orb.orbAppToWai sisOrbApp{Orb.handleNotFound = serveStaticOrSpa staticDir}
+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
--- | Full Orb application wiring routes to a WAI dispatcher.
-sisOrbApp :: Orb.OrbApp (S.Union Routes)
-sisOrbApp =
- Orb.OrbApp
- { Orb.router = sisRouter
- , Orb.dispatcher = sisDispatcher
- , Orb.handleNotFound = Orb.defaultHandleNotFound -- overridden in 'app'
- }
+-- | 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"
--- | The route recognizer for all sis routes.
-sisRouter :: R.RouteRecognizer (S.Union Routes)
-sisRouter =
- R.routeList $
- Orb.get (R.make HealthCheck /- "api" /- "health")
- /: R.emptyRoutes
+-- | Exception carrying a pre-built WAI response for early exit.
+newtype ApiResponse = ApiResponse Wai.Response
--- | Dispatch a recognized route to its handler via the 'SisDispatchM' monad.
-sisDispatcher :: S.Union Routes -> Wai.Application
-sisDispatcher route request respond = do
- let env = SisDispatchEnv request respond
- let SisDispatchM action = Orb.dispatch route
- Reader.runReaderT action env
+instance Show ApiResponse where show _ = "ApiResponse"
+instance Safe.Exception ApiResponse
--- | The union of all route types in the application.
-type Routes =
- '[ HealthCheck
- ]
+-- | 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
--- Static file + SPA fallback
+throwJSON :: (A.ToJSON a) => HTTP.Status -> a -> IO b
+throwJSON status v = throwResp status (A.encode v)
--- | MIME type lookup by file extension.
-mimeType :: FilePath -> Maybe BS.ByteString
-mimeType path = Map.lookup (takeExtensionLower path) mimeTypes
+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
- takeExtensionLower p =
- let ext = reverse $ takeWhile (/= '.') $ reverse p
- in T.toLower $ T.pack ext
+ 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 =
@@ -85,130 +737,34 @@ mimeTypes =
, ("js", "application/javascript")
, ("json", "application/json")
, ("png", "image/png")
+ , ("jpg", "image/jpeg")
, ("svg", "image/svg+xml")
, ("ico", "image/x-icon")
- , ("woff2", "font/woff2")
+ , ("manifest", "application/manifest+json")
]
-{- | Serve a static file from @staticDir@.
-
-For paths without a file extension (SPA client-side routes), serves
-@index.html@ instead so the SPA can handle routing.
-
-Returns 'True' if a file was served, 'False' if nothing matched.
--}
serveStaticOrSpa :: FilePath -> Wai.Application
serveStaticOrSpa staticDir request respond = do
- let path = T.unpack $ TE.decodeUtf8 $ Wai.rawPathInfo request
- -- Drop leading slash for filesystem lookup.
- let relPath = case path of
- '/' : rest -> rest
- other -> other
- let candidate =
- if null relPath || not (hasExtension relPath)
- then "index.html"
- else relPath
- let filePath = staticDir candidate
- exists <- doesFileExist filePath
+ 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
- let mime = fromMaybe "application/octet-stream" (mimeType candidate)
- respond $ Wai.responseFile HTTP.status200 [("Content-Type", mime)] filePath Nothing
+ content <- BS.readFile fp
+ let ct = fromMaybe "application/octet-stream" $ mimeType fp
+ respond $ Wai.responseLBS HTTP.status200 [("Content-Type", ct)] (BL.fromStrict content)
else
- respond notFoundResponse
-
-hasExtension :: FilePath -> Bool
-hasExtension = elem '.' . takeFileName
-
-takeFileName :: FilePath -> FilePath
-takeFileName = reverse . takeWhile (/= '/') . reverse
+ 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"
-
--- Internal WAI dispatch monad
-
-data SisDispatchEnv = SisDispatchEnv
- { sisRequest :: Wai.Request
- , sisRespond :: Wai.Response -> IO Wai.ResponseReceived
- }
-
-newtype SisDispatchM a
- = SisDispatchM (Reader.ReaderT SisDispatchEnv IO a)
- deriving
- ( Functor
- , Applicative
- , Monad
- , MIO.MonadIO
- , Safe.MonadThrow
- , Safe.MonadCatch
- )
-
-instance Orb.HasRequest SisDispatchM where
- request = SisDispatchM (Reader.asks sisRequest)
-
-instance Orb.HasRespond SisDispatchM where
- respond = SisDispatchM (Reader.asks sisRespond)
-
-instance Orb.HasLogger SisDispatchM where
- log = MIO.liftIO . putStrLn . Safe.displayException
-
--- Health check route
-
-{- | GET \/api\/health
-
-Returns a simple health-check response.
--}
-data HealthCheck = HealthCheck
-
-instance Orb.HasHandler HealthCheck where
- type HandlerResponses HealthCheck = HealthCheckResponses
- type HandlerPermissionAction HealthCheck = NoPermissions
- type HandlerMonad HealthCheck = SisDispatchM
-
- routeHandler = healthCheckHandler
-
-type HealthCheckResponses =
- '[ Orb.Response200 Orb.SuccessMessage
- , Orb.Response500 Orb.InternalServerError
- ]
-
-healthCheckHandler :: Orb.Handler HealthCheck
-healthCheckHandler =
- Orb.Handler
- { Orb.handlerId = "healthCheck"
- , Orb.requestBody = Orb.EmptyRequestBody
- , Orb.requestQuery = Orb.EmptyRequestQuery
- , Orb.requestHeaders = Orb.EmptyRequestHeaders
- , Orb.handlerResponseBodies =
- Orb.responseBodies
- . Orb.addResponseSchema200 Orb.successMessageSchema
- . Orb.addResponseSchema500 Orb.internalServerErrorSchema
- $ Orb.noResponseBodies
- , Orb.mkPermissionAction =
- const NoPermissions
- , Orb.handleRequest =
- \_request () -> Orb.return200 (Orb.SuccessMessage "ok")
- }
-
--- NoPermissions — all routes are public for now.
-
-data NoPermissions = NoPermissions
-
-instance Orb.PermissionAction NoPermissions where
- type PermissionActionMonad NoPermissions = SisDispatchM
- type PermissionActionError NoPermissions = NoError
- type PermissionActionResult NoPermissions = ()
-
- checkPermissionAction _ =
- pure (Right ())
-
-newtype NoError = NoError Void
-
-instance Orb.PermissionError NoError where
- type PermissionErrorConstraints NoError _tags = ()
- type PermissionErrorMonad NoError = SisDispatchM
-
- returnPermissionError (NoError v) =
- absurd v
+notFoundResponse = Wai.responseLBS HTTP.status404 [("Content-Type", "text/plain")] "Not Found"
diff --git a/src/Sis/Types.hs b/src/Sis/Types.hs
index 1eec104..15d6808 100644
--- a/src/Sis/Types.hs
+++ b/src/Sis/Types.hs
@@ -1,127 +1,627 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
{- | Core domain types for Sis.
-Sis tracks tasks (chores, responsibilities) that are shared among
-members of a household or group. Any user can complete a task, and
-completion is visible to all.
+Covers users, households, memberships, invites, chores with
+schedules, occurrences, and activity records.
-}
module Sis.Types (
- -- * Task
- Task (..),
- TaskId,
- TaskName,
- TaskStatus (..),
-
- -- * User
+ -- * IDs
+ UserId (..),
+ HouseholdId (..),
+ ChoreId (..),
+ OccurrenceId (..),
+ ActivityId (..),
+ InviteId (..),
+ UserPublic (..),
User (..),
- UserId,
- UserName,
+ SignupRequest (..),
+ LoginRequest (..),
- -- * Task completion
- TaskCompletion (..),
+ -- * Household
+ Household (..),
+ Membership (..),
+ MemberRole (..),
+ Invite (..),
+ InviteStatus (..),
+ CreateHouseholdRequest (..),
+ CreateInviteRequest (..),
+
+ -- * Chore
+ Chore (..),
+ ChoreAssignee (..),
+ Schedule (..),
+ SchedulePeriod (..),
+ CreateChoreRequest (..),
+ UpdateChoreRequest (..),
+
+ -- * Occurrence
+ Occurrence (..),
+ OccurrenceStatus (..),
+
+ -- * Activity
+ Activity (..),
+ ActivityStatus (..),
+ RecordActivityRequest (..),
+
+ -- * Dashboard
+ Dashboard (..),
+ DashboardStats (..),
+ DueItem (..),
+ CompletedItem (..),
+
+ -- * Activity log
+ ActivityLogEntry (..),
+ ActivityLogPage (..),
+
+ -- * Auth responses
+ AuthResponse (..),
+
+ -- * Error
+ ErrorResponse (..),
+
+ -- * Seed
+ SeedRequest (..),
) where
import Data.Aeson qualified as A
import Data.Text (Text)
-import Data.Time (UTCTime)
+import Data.Time (Day, LocalTime, UTCTime)
--- | Unique identifier for a task.
-type TaskId = Int
+----------------------------------------------------------------------
+-- IDs
+----------------------------------------------------------------------
--- | Human-readable task name.
-type TaskName = Text
+newtype UserId = UserId {unUserId :: Int}
+ deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON, A.ToJSONKey, A.FromJSONKey)
--- | Whether a task is pending or done.
-data TaskStatus
- = TaskPending
- | TaskDone
- deriving stock (Show, Eq)
+newtype HouseholdId = HouseholdId {unHouseholdId :: Int}
+ deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON, A.ToJSONKey, A.FromJSONKey)
--- | A chore or responsibility that needs to be completed.
-data Task = Task
- { taskId :: TaskId
- , taskName :: TaskName
- , taskStatus :: TaskStatus
- , taskAssignedTo :: Maybe UserId
- , taskLastCompleted :: Maybe UTCTime
- }
- deriving stock (Show, Eq)
+newtype ChoreId = ChoreId {unChoreId :: Int}
+ deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON)
--- | Unique identifier for a user.
-type UserId = Int
+newtype OccurrenceId = OccurrenceId {unOccurrenceId :: Int}
+ deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON)
--- | Display name for a user.
-type UserName = Text
+newtype ActivityId = ActivityId {unActivityId :: Int}
+ deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON)
+
+newtype InviteId = InviteId {unInviteId :: Int}
+ deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON)
+
+----------------------------------------------------------------------
+-- User
+----------------------------------------------------------------------
--- | A user who can complete tasks.
data User = User
{ userId :: UserId
- , userName :: UserName
+ , userDisplayName :: Text
+ , userEmail :: Text
+ , userPasswordHash :: Text
}
deriving stock (Show, Eq)
--- | Records when a user completed a task.
-data TaskCompletion = TaskCompletion
- { completionTaskId :: TaskId
- , completionUserId :: UserId
- , completionTime :: UTCTime
+-- | Public user info (never includes password hash)
+data UserPublic = UserPublic
+ { upId :: UserId
+ , upDisplayName :: Text
+ , upEmail :: Text
}
deriving stock (Show, Eq)
--- JSON instances
-
-instance A.ToJSON TaskStatus where
- toJSON TaskPending = A.String "pending"
- toJSON TaskDone = A.String "done"
-
-instance A.FromJSON TaskStatus where
- parseJSON = A.withText "TaskStatus" $ \case
- "pending" -> pure TaskPending
- "done" -> pure TaskDone
- other -> fail $ "Unknown TaskStatus: " <> show other
-
-instance A.ToJSON Task where
- toJSON Task{..} =
+instance A.ToJSON UserPublic where
+ toJSON u =
A.object
- [ "id" A..= taskId
- , "name" A..= taskName
- , "status" A..= taskStatus
- , "assignedTo" A..= taskAssignedTo
- , "lastCompleted" A..= taskLastCompleted
+ [ "id" A..= upId u
+ , "displayName" A..= upDisplayName u
+ , "email" A..= upEmail u
]
-instance A.FromJSON Task where
- parseJSON = A.withObject "Task" $ \o ->
- Task
- <$> o A..: "id"
- <*> o A..: "name"
- <*> o A..: "status"
- <*> o A..: "assignedTo"
- <*> o A..: "lastCompleted"
+data SignupRequest = SignupRequest
+ { srDisplayName :: Text
+ , srEmail :: Text
+ , srPassword :: Text
+ , srConfirmPassword :: Text
+ , srAgreeTerms :: Bool
+ }
+ deriving stock (Show, Eq)
-instance A.ToJSON User where
- toJSON User{..} =
+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
- [ "id" A..= userId
- , "name" A..= userName
+ [ "user" A..= arUser r
+ , "households" A..= arHouseholds r
]
-instance A.FromJSON User where
- parseJSON = A.withObject "User" $ \o ->
- User
- <$> o A..: "id"
- <*> o A..: "name"
+----------------------------------------------------------------------
+-- Household
+----------------------------------------------------------------------
-instance A.ToJSON TaskCompletion where
- toJSON TaskCompletion{..} =
+data MemberRole = OwnerRole | MemberRole
+ 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
+ { householdId :: HouseholdId
+ , householdName :: Text
+ , householdOwner :: UserId
+ , householdMemberCount :: Int
+ }
+ deriving stock (Show, Eq)
+
+instance A.ToJSON Household where
+ toJSON h =
A.object
- [ "taskId" A..= completionTaskId
- , "userId" A..= completionUserId
- , "time" A..= completionTime
+ [ "id" A..= householdId h
+ , "name" A..= householdName h
+ , "owner" A..= householdOwner h
+ , "memberCount" A..= householdMemberCount h
]
-instance A.FromJSON TaskCompletion where
- parseJSON = A.withObject "TaskCompletion" $ \o ->
- TaskCompletion
- <$> o A..: "taskId"
- <*> o A..: "userId"
- <*> o A..: "time"
+data Membership = Membership
+ { membershipUserId :: UserId
+ , membershipDisplayName :: Text
+ , membershipEmail :: Text
+ , membershipRole :: MemberRole
+ }
+ 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
+ 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
+ { inviteId :: InviteId
+ , inviteHouseholdId :: HouseholdId
+ , inviteCode :: Text
+ , inviteEmail :: Maybe Text
+ , inviteStatus :: InviteStatus
+ , inviteCreatedAt :: UTCTime
+ }
+ 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
+----------------------------------------------------------------------
+
+data ChoreAssignee
+ = AssigneeUser UserId
+ | AssigneeAnyone
+ 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
+ deriving stock (Show, Eq)
+
+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
+ = ScheduleOneOff {soDate :: Day, soTime :: Maybe LocalTime}
+ | ScheduleRecurring
+ { srPeriod :: SchedulePeriod
+ , srStartDate :: Day
+ , srTimeOfDay :: Maybe Text
+ , srDaysOfWeek :: Maybe [Int]
+ , srDaysOfMonth :: Maybe [Int]
+ }
+ | ScheduleSometime
+ deriving stock (Show, Eq)
+
+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
+ { choreId :: ChoreId
+ , choreHouseholdId :: HouseholdId
+ , choreName :: Text
+ , choreAssignee :: ChoreAssignee
+ , choreSchedule :: Schedule
+ , choreNotifyOnDue :: Bool
+ , choreCreatedAt :: UTCTime
+ }
+ 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
+----------------------------------------------------------------------
+
+data OccurrenceStatus = OccDue | OccOverdue | OccCompleted | OccSkipped
+ 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
+ { occurrenceId :: OccurrenceId
+ , occurrenceChoreId :: ChoreId
+ , occurrenceDate :: Day
+ , occurrenceStatus :: OccurrenceStatus
+ }
+ 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
+----------------------------------------------------------------------
+
+data ActivityStatus = ActivityCompleted | ActivitySkipped
+ 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
+ { activityId :: ActivityId
+ , activityOccurrenceId :: OccurrenceId
+ , activityUserId :: UserId
+ , activityStatus :: ActivityStatus
+ , activityNote :: Maybe Text
+ , activityNotifyHousehold :: Bool
+ , activityRecordedAt :: UTCTime
+ }
+ 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
+----------------------------------------------------------------------
+
+data DashboardStats = DashboardStats
+ { dsOverdue :: Int
+ , dsDueToday :: Int
+ , dsDoneThisWeek :: Int
+ }
+ 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
+ { diOccurrence :: Occurrence
+ , diChoreName :: Text
+ , diAssigneeName :: Maybe Text
+ , diIsOverdue :: Bool
+ }
+ 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
+ { ciActivity :: Activity
+ , ciUserName :: Text
+ , ciChoreName :: Text
+ }
+ 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
+ { dashStats :: DashboardStats
+ , dashDueItems :: [DueItem]
+ , dashCompletedItems :: [CompletedItem]
+ }
+ 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
+----------------------------------------------------------------------
+
+data ActivityLogEntry = ActivityLogEntry
+ { aleActivity :: Activity
+ , aleUserName :: Text
+ , aleUserEmail :: Text
+ , aleChoreName :: Text
+ , aleOccurrenceDate :: Day
+ }
+ 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
+ { alpEntries :: [ActivityLogEntry]
+ , alpPage :: Int
+ , alpPerPage :: Int
+ , alpTotal :: Int
+ }
+ 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
+----------------------------------------------------------------------
+
+data ErrorResponse = ErrorResponse
+ { errorMessage :: Text
+ , errorField :: Maybe Text
+ }
+ deriving stock (Show, Eq)
+
+instance A.ToJSON ErrorResponse where
+ toJSON e =
+ A.object
+ [ "error" A..= errorMessage e
+ , "field" A..= errorField e
+ ]
+
+----------------------------------------------------------------------
+-- Seed
+----------------------------------------------------------------------
+
+data SeedRequest = SeedRequest
+ deriving stock (Show, Eq)
+
+instance A.FromJSON SeedRequest where
+ parseJSON _ = pure SeedRequest