From b4e47b652f2cc6997047154f63321075ebdfbed3 Mon Sep 17 00:00:00 2001 From: James Brechtel Date: Wed, 15 Jul 2026 21:20:57 -0400 Subject: [PATCH] WIP: backend auth/chores/households work and frontend styling --- app/Main.hs | 9 +- frontend/index.html | 5 +- frontend/public/manifest.json | 13 + frontend/public/style.css | 62 +++ package.yaml | 7 +- scripts/run | 2 +- sis-server.cabal | 15 +- src/Sis.hs | 2 + src/Sis/Auth.hs | 103 ++++ src/Sis/Database.hs | 73 ++- src/Sis/Server.hs | 900 +++++++++++++++++++++++++++------- src/Sis/Types.hs | 682 ++++++++++++++++++++++---- 12 files changed, 1597 insertions(+), 276 deletions(-) create mode 100644 frontend/public/manifest.json create mode 100644 src/Sis/Auth.hs 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