From b92947cdcc77c0ecf60fbcd2e71b0724b4c7fd45 Mon Sep 17 00:00:00 2001 From: James Brechtel Date: Wed, 15 Jul 2026 22:44:05 -0400 Subject: [PATCH] refactor: strip Aeson from Types, remove Server.hs, fix Sis.hs exports, update deps - Removed all Aeson instances from Types.hs - Deleted Server.hs (Orb/WAI routing) - Added Hyperbole form types (LoginForm, SignupForm, etc.) - Removed Server from Sis.hs and cabal file - Updated stack.yaml for Hyperbole dependency resolution - Added local hyperbole copy with GHC 9.10 compat patches - Types.hs, Database.hs, Auth.hs compile successfully --- .gitignore | 2 + sis-server.cabal | 1 - src/Sis.hs | 1 - src/Sis/Server.hs | 770 ---------------------------------------------- src/Sis/Types.hs | 434 ++++---------------------- stack.yaml | 5 +- stack.yaml.lock | 106 ++----- 7 files changed, 84 insertions(+), 1235 deletions(-) delete mode 100644 src/Sis/Server.hs diff --git a/.gitignore b/.gitignore index 6356f76..6ac6ea0 100644 --- a/.gitignore +++ b/.gitignore @@ -12,3 +12,5 @@ __pycache__ .superpowers/ node_modules/ frontend/dist/ +hyperbole-local/ +hyperbole-local/ diff --git a/sis-server.cabal b/sis-server.cabal index 3db4d4f..f991caf 100644 --- a/sis-server.cabal +++ b/sis-server.cabal @@ -19,7 +19,6 @@ library Sis Sis.Auth Sis.Database - Sis.Server Sis.Types other-modules: Paths_sis_server diff --git a/src/Sis.hs b/src/Sis.hs index 2b4c668..c82e7d4 100644 --- a/src/Sis.hs +++ b/src/Sis.hs @@ -5,5 +5,4 @@ module Sis ( 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/Server.hs b/src/Sis/Server.hs deleted file mode 100644 index d2666cf..0000000 --- a/src/Sis/Server.hs +++ /dev/null @@ -1,770 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- | Simple WAI-based HTTP server for Sis. -Bypasses Orb's complex routing for a straightforward manual approach. --} -module Sis.Server (app) where - -import Control.Exception.Safe qualified as Safe -import Control.Monad (unless, void, when) -import Data.Aeson qualified as A -import Data.ByteString qualified as BS -import Data.ByteString.Lazy qualified as BL -import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe, listToMaybe) -import Data.Text qualified as T -import Data.Text.Encoding qualified as TE -import Data.Time qualified as Time -import Database.SQLite.Simple (Only (..)) -import Database.SQLite.Simple qualified as SQL -import Network.HTTP.Types qualified as HTTP -import Network.Wai qualified as Wai -import System.Directory (doesFileExist) -import System.FilePath (()) -import Text.Read (readMaybe) - -import Sis.Auth qualified as Auth -import Sis.Types - -app :: FilePath -> SQL.Connection -> Wai.Application -app staticDir conn request respond = do - let path = TE.decodeUtf8 $ Wai.rawPathInfo request - if "/api/" `T.isPrefixOf` path - then handleApi conn request respond - else serveStaticOrSpa staticDir request respond - --- | Handle all API routes by dispatching on path and method. -handleApi :: SQL.Connection -> Wai.Application -handleApi conn request respond = do - let segs = filter (not . T.null) $ T.splitOn "/" $ TE.decodeUtf8 $ Wai.rawPathInfo request - method = Wai.requestMethod request - getBody = Wai.strictRequestBody request - result <- Safe.try $ routeApi conn request respond segs method getBody - case result of - Left (ApiResponse resp) -> respond resp - Right _ -> respond $ Wai.responseLBS HTTP.status500 [] "Internal server error" - --- | Exception carrying a pre-built WAI response for early exit. -newtype ApiResponse = ApiResponse Wai.Response - -instance Show ApiResponse where show _ = "ApiResponse" -instance Safe.Exception ApiResponse - --- | Throw a response to exit early. -throwResp :: HTTP.Status -> BL.ByteString -> IO a -throwResp status body = - Safe.throwIO $ - ApiResponse $ - Wai.responseLBS status [("Content-Type", "application/json")] body - -throwJSON :: (A.ToJSON a) => HTTP.Status -> a -> IO b -throwJSON status v = throwResp status (A.encode v) - -throwError :: HTTP.Status -> T.Text -> IO a -throwError status msg = throwJSON status (ErrorResponse msg Nothing) - -throwFieldError :: HTTP.Status -> T.Text -> T.Text -> IO a -throwFieldError status msg field = throwJSON status (ErrorResponse msg (Just field)) - --- | Parse JSON body. -parseBody :: (A.FromJSON a) => IO BL.ByteString -> IO a -parseBody getBody = do - body <- getBody - case A.decode body of - Just v -> pure v - Nothing -> throwError HTTP.status400 "Invalid JSON body" - --- | Get current user from session cookie. -getSessionUser :: SQL.Connection -> Wai.Request -> IO (Maybe User) -getSessionUser conn req = do - let cookies = parseCookies (Wai.requestHeaders req) - case Map.lookup Auth.sessionCookieName cookies of - Nothing -> pure Nothing - Just token -> do - now <- Time.getCurrentTime - result <- - SQL.query - conn - "SELECT u.id, u.display_name, u.email, u.password_hash \ - \ FROM users u JOIN sessions s ON s.user_id = u.id \ - \ WHERE s.token = ? AND s.expires_at > ?" - (token, now) :: - IO [(Int, T.Text, T.Text, T.Text)] - pure $ listToMaybe [User (UserId uid) name email pwHash | (uid, name, email, pwHash) <- result] - --- | Require authentication. -requireAuth :: SQL.Connection -> Wai.Request -> IO User -requireAuth conn req = do - mUser <- getSessionUser conn req - case mUser of - Just u -> pure u - Nothing -> throwError HTTP.status401 "Authentication required" - --- | Check household membership. -requireHouseholdRole :: SQL.Connection -> UserId -> Int -> IO T.Text -requireHouseholdRole conn userId hid = do - result <- - SQL.query - conn - "SELECT role FROM memberships WHERE household_id = ? AND user_id = ?" - (hid, unUserId userId) :: - IO [Only String] - case listToMaybe [T.pack role | Only role <- result] of - Just r -> pure r - Nothing -> throwError HTTP.status403 "Not a member of this household" - --- | Simple cookie parser. -parseCookies :: [HTTP.Header] -> Map.Map T.Text T.Text -parseCookies headers = - case lookup "cookie" headers of - Just raw -> - let pairs = T.splitOn "; " (TE.decodeUtf8 raw) - in Map.fromList [(T.strip k, T.strip v) | kv <- pairs, let (k, v') = T.breakOn "=" kv, not (T.null k), let v = T.drop 1 v'] - Nothing -> Map.empty - --- | Set session cookie header. -mkSessionCookie :: T.Text -> Bool -> HTTP.Header -mkSessionCookie token rememberMe = - let maxAge = if rememberMe then (30 :: Int) * 86400 else 86400 - in ("Set-Cookie", TE.encodeUtf8 Auth.sessionCookieName <> "=" <> TE.encodeUtf8 token <> "; Path=/; HttpOnly; SameSite=Lax; Max-Age=" <> TE.encodeUtf8 (T.pack $ show maxAge)) - -clearSessionCookie :: HTTP.Header -clearSessionCookie = ("Set-Cookie", TE.encodeUtf8 Auth.sessionCookieName <> "=; Path=/; HttpOnly; SameSite=Lax; Max-Age=0") - --- | Get user's households. -getUserHouseholds :: SQL.Connection -> UserId -> IO [Household] -getUserHouseholds conn userId = do - rows <- - SQL.query - conn - "SELECT h.id, h.name, m2.user_id, \ - \ (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \ - \ FROM households h JOIN memberships m ON m.household_id = h.id AND m.user_id = ? \ - \ JOIN memberships m2 ON m2.household_id = h.id AND m2.role = 'owner'" - (Only (unUserId userId)) :: - IO [(Int, T.Text, Int, Int)] - pure [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- rows] - --- | Occurrence generation helpers. -generateOccurrences :: SQL.Connection -> Chore -> IO () -generateOccurrences conn chore = do - today <- Time.utctDay <$> Time.getCurrentTime - let windowEnd = Time.addDays 90 today - case choreSchedule chore of - ScheduleOneOff date _ -> - when (date >= today && date <= windowEnd) $ - SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (?, ?)" (unChoreId (choreId chore), date) - ScheduleRecurring period startDate _ _ _ -> do - let dates = generateRecurringDates period startDate today windowEnd - mapM_ (\d -> SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (?, ?)" (unChoreId (choreId chore), d)) dates - ScheduleSometime -> - SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (?, '9999-12-31')" (Only (unChoreId (choreId chore))) - -generateRecurringDates :: SchedulePeriod -> Time.Day -> Time.Day -> Time.Day -> [Time.Day] -generateRecurringDates period startDate fromDate toDate = go (max startDate fromDate) - where - go d | d > toDate = [] | otherwise = d : go (next period d) - next PeriodDaily = Time.addDays 1; next PeriodWeekly = Time.addDays 7; next PeriodMonthly = Time.addGregorianMonthsClip 1 - ----------------------------------------------------------------------- --- Main router ----------------------------------------------------------------------- - -newtype EmailOnly = EmailOnly T.Text -instance A.FromJSON EmailOnly where - parseJSON = A.withObject "EmailOnly" $ \o -> EmailOnly <$> o A..: "email" - -data ResetPasswordRequest = ResetPasswordRequest {rprToken :: T.Text, rprPassword :: T.Text} -instance A.FromJSON ResetPasswordRequest where - parseJSON = A.withObject "ResetPasswordRequest" $ \o -> - ResetPasswordRequest <$> o A..: "token" <*> o A..: "password" - -routeApi :: SQL.Connection -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> [T.Text] -> HTTP.Method -> IO BL.ByteString -> IO () -routeApi conn req respond segs method getBody = case segs of - -- Health - ("api" : "health" : _) -> - throwJSON HTTP.status200 (A.object ["status" A..= A.String "ok"]) - -- Auth - ("api" : "auth" : "signup" : _) -> handleSignup conn getBody respond - ("api" : "auth" : "login" : _) -> handleLogin conn getBody respond - ("api" : "auth" : "logout" : _) -> handleLogout conn req respond - ("api" : "auth" : "me" : _) -> handleMe conn req - ("api" : "auth" : "forgot-password" : _) -> handleForgotPassword conn getBody - ("api" : "auth" : "reset-password" : _) -> handleResetPassword conn getBody - -- Households - ["api", "households"] - | method == HTTP.methodGet -> handleListHouseholds conn req - | method == HTTP.methodPost -> handleCreateHousehold conn req getBody - | otherwise -> throwError HTTP.status405 "Method not allowed" - ("api" : "households" : hidStr : rest) -> - case readMaybe (T.unpack hidStr) of - Just hid -> routeHousehold conn req respond hid rest method getBody - Nothing -> throwError HTTP.status400 "Invalid household ID" - -- Invites (top-level) - ["api", "invites", code] -> handleLookupInvite conn code - ("api" : "invites" : code : "accept" : _) -> handleAcceptInvite conn req code - -- Occurrences - ("api" : "occurrences" : oidStr : "activity" : _) -> - case readMaybe (T.unpack oidStr) of - Just oid -> handleRecordActivity conn req oid getBody - Nothing -> throwError HTTP.status400 "Invalid occurrence ID" - -- Seed - ("api" : "seed" : _) -> handleSeed conn - _ -> throwError HTTP.status404 "API route not found" - -routeHousehold :: SQL.Connection -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> Int -> [T.Text] -> HTTP.Method -> IO BL.ByteString -> IO () -routeHousehold conn req _respond hid rest method getBody = case rest of - [] -> case method of - _ | method == HTTP.methodGet -> handleGetHousehold conn req hid - _ | method == HTTP.methodPut -> handleUpdateHousehold conn req hid getBody - _ | method == HTTP.methodDelete -> handleDeleteHousehold conn req hid - _ -> throwError HTTP.status405 "Method not allowed" - ["members"] -> handleListMembers conn req hid - ["members", uidStr] -> - case readMaybe (T.unpack uidStr) of - Just uid -> handleRemoveMember conn req hid uid - Nothing -> throwError HTTP.status400 "Invalid user ID" - ["invites"] -> handleListInvites conn req hid - ["invites", iidStr] -> - case readMaybe (T.unpack iidStr) of - Just iid - | method == HTTP.methodDelete -> handleRevokeInvite conn req hid iid - | otherwise -> handleCreateInvite conn req hid getBody - Nothing -> throwError HTTP.status400 "Invalid invite ID" - ["chores"] -> handleListChores conn req hid - ["chores", cidStr] -> - case readMaybe (T.unpack cidStr) of - Just cid - | method == HTTP.methodPut -> handleUpdateChore conn req hid cid getBody - | method == HTTP.methodDelete -> handleDeleteChore conn req hid cid - | otherwise -> handleCreateChore conn req hid getBody - Nothing -> throwError HTTP.status400 "Invalid chore ID" - ["dashboard"] -> handleDashboard conn req hid - ["activity"] -> handleActivityLog conn req hid - _ -> throwError HTTP.status404 "API route not found" - ----------------------------------------------------------------------- --- Auth handlers ----------------------------------------------------------------------- - -handleSignup :: SQL.Connection -> IO BL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO () -handleSignup conn getBody respond = do - req <- parseBody getBody - when (T.length (srPassword req) < 8) $ throwFieldError HTTP.status400 "Password must be at least 8 characters" "password" - when (srPassword req /= srConfirmPassword req) $ throwFieldError HTTP.status400 "Passwords do not match" "confirmPassword" - unless (srAgreeTerms req) $ throwFieldError HTTP.status400 "You must agree to the terms" "agreeTerms" - existing <- SQL.query conn "SELECT id FROM users WHERE email = ?" (Only (srEmail req)) :: IO [Only Int] - unless (null existing) $ throwError HTTP.status409 "Email already registered" - pwHash <- Auth.hashPassword (srPassword req) - SQL.execute conn "INSERT INTO users (display_name, email, password_hash) VALUES (?, ?, ?)" (srDisplayName req, srEmail req, pwHash) - uid <- SQL.lastInsertRowId conn - let userId = UserId (fromIntegral uid) - token <- Auth.generateToken - expires <- Time.addUTCTime 86400 <$> Time.getCurrentTime - SQL.execute conn "INSERT INTO sessions (token, user_id, expires_at) VALUES (?, ?, ?)" (token, unUserId userId, expires) - let user = UserPublic userId (srDisplayName req) (srEmail req) - void $ - respond $ - Wai.responseLBS - HTTP.status201 - [("Content-Type", "application/json"), mkSessionCookie token False] - (A.encode $ AuthResponse user []) - -handleLogin :: SQL.Connection -> IO BL.ByteString -> (Wai.Response -> IO Wai.ResponseReceived) -> IO () -handleLogin conn getBody respond = do - req <- parseBody getBody - result <- SQL.query conn "SELECT id, display_name, email, password_hash FROM users WHERE email = ?" (Only (lrEmail req)) :: IO [(Int, T.Text, T.Text, T.Text)] - case result of - [(uid, name, email, pwHash)] -> - if Auth.verifyPassword (lrPassword req) pwHash - then do - let userId = UserId uid - token <- Auth.generateToken - let maxAge = if lrRememberMe req then 30 * 86400 else 86400 - expires <- Time.addUTCTime (fromIntegral (maxAge :: Int)) <$> Time.getCurrentTime - SQL.execute conn "INSERT INTO sessions (token, user_id, expires_at) VALUES (?, ?, ?)" (token, unUserId userId, expires) - households <- getUserHouseholds conn userId - let user = UserPublic userId name email - void $ - respond $ - Wai.responseLBS - HTTP.status200 - [("Content-Type", "application/json"), mkSessionCookie token (lrRememberMe req)] - (A.encode $ AuthResponse user households) - else throwError HTTP.status401 "Invalid email or password" - _ -> throwError HTTP.status401 "Invalid email or password" - -handleLogout :: SQL.Connection -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO () -handleLogout conn req respond = do - let cookies = parseCookies (Wai.requestHeaders req) - case Map.lookup Auth.sessionCookieName cookies of - Just token -> SQL.execute conn "DELETE FROM sessions WHERE token = ?" (Only token) - Nothing -> pure () - void $ - respond $ - Wai.responseLBS - HTTP.status200 - [("Content-Type", "application/json"), clearSessionCookie] - (A.encode $ A.object ["status" A..= A.String "logged_out"]) - -handleMe :: SQL.Connection -> Wai.Request -> IO () -handleMe conn req = do - mUser <- getSessionUser conn req - case mUser of - Nothing -> throwError HTTP.status401 "Not authenticated" - Just (User uid name email _) -> do - households <- getUserHouseholds conn uid - let user = UserPublic uid name email - throwJSON HTTP.status200 $ AuthResponse user households - -handleForgotPassword :: SQL.Connection -> IO BL.ByteString -> IO () -handleForgotPassword conn getBody = do - req <- parseBody getBody - let EmailOnly email = req - result <- SQL.query conn "SELECT id FROM users WHERE email = ?" (Only email) :: IO [Only Int] - case result of - [Only uid] -> do - token <- Auth.generateToken - expires <- Time.addUTCTime 3600 <$> Time.getCurrentTime - SQL.execute conn "INSERT INTO reset_tokens (user_id, token, expires_at) VALUES (?, ?, ?)" (uid, token, expires) - _ -> pure () - throwJSON HTTP.status200 (A.object ["status" A..= A.String "reset_sent"]) - -handleResetPassword :: SQL.Connection -> IO BL.ByteString -> IO () -handleResetPassword conn getBody = do - req <- parseBody getBody - when (T.length (rprPassword req) < 8) $ throwError HTTP.status400 "Password must be at least 8 characters" - now <- Time.getCurrentTime - result <- SQL.query conn "SELECT user_id FROM reset_tokens WHERE token = ? AND used = 0 AND expires_at > ?" (rprToken req, now) :: IO [Only Int] - case result of - [Only uid] -> do - pwHash <- Auth.hashPassword (rprPassword req) - SQL.execute conn "UPDATE users SET password_hash = ? WHERE id = ?" (pwHash, uid) - SQL.execute conn "UPDATE reset_tokens SET used = 1 WHERE token = ?" (Only (rprToken req)) - throwJSON HTTP.status200 (A.object ["status" A..= A.String "password_reset"]) - _ -> throwError HTTP.status400 "Invalid or expired reset token" - ----------------------------------------------------------------------- --- Household handlers ----------------------------------------------------------------------- - -handleCreateHousehold :: SQL.Connection -> Wai.Request -> IO BL.ByteString -> IO () -handleCreateHousehold conn req getBody = do - user <- requireAuth conn req - chr <- parseBody getBody - SQL.execute conn "INSERT INTO households (name) VALUES (?)" (Only (chrName chr)) - hId <- SQL.lastInsertRowId conn - let hid = HouseholdId (fromIntegral hId) - SQL.execute conn "INSERT INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)" (unHouseholdId hid, unUserId (userId user), "owner" :: String) - throwJSON HTTP.status201 $ Household hid (chrName chr) (userId user) 1 - -handleListHouseholds :: SQL.Connection -> Wai.Request -> IO () -handleListHouseholds conn req = do - user <- requireAuth conn req - hs <- getUserHouseholds conn (userId user) - throwJSON HTTP.status200 hs - -handleGetHousehold :: SQL.Connection -> Wai.Request -> Int -> IO () -handleGetHousehold conn req hid = do - user <- requireAuth conn req - _ <- requireHouseholdRole conn (userId user) hid - result <- - SQL.query - conn - "SELECT h.id, h.name, m2.user_id, (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \ - \ FROM households h JOIN memberships m ON m.household_id = h.id AND m.user_id = ? \ - \ JOIN memberships m2 ON m2.household_id = h.id AND m2.role = 'owner' WHERE h.id = ?" - (unUserId (userId user), hid) :: - IO [(Int, T.Text, Int, Int)] - case result of - [(hId, hName, ownerId, count)] -> throwJSON HTTP.status200 $ Household (HouseholdId hId) hName (UserId ownerId) count - _ -> throwError HTTP.status404 "Household not found" - -handleUpdateHousehold :: SQL.Connection -> Wai.Request -> Int -> IO BL.ByteString -> IO () -handleUpdateHousehold conn req hid getBody = do - user <- requireAuth conn req - role <- requireHouseholdRole conn (userId user) hid - unless (role == "owner") $ throwError HTTP.status403 "Only the owner can rename the household" - chr <- parseBody getBody - SQL.execute conn "UPDATE households SET name = ? WHERE id = ?" (chrName chr, hid) - result <- - SQL.query - conn - "SELECT h.id, h.name, m.user_id, (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \ - \ FROM households h JOIN memberships m ON m.household_id = h.id AND m.role = 'owner' WHERE h.id = ?" - (Only hid) :: - IO [(Int, T.Text, Int, Int)] - case result of - [(hId, hName, ownerId, count)] -> throwJSON HTTP.status200 $ Household (HouseholdId hId) hName (UserId ownerId) count - _ -> throwError HTTP.status404 "Household not found" - -handleDeleteHousehold :: SQL.Connection -> Wai.Request -> Int -> IO () -handleDeleteHousehold conn req hid = do - user <- requireAuth conn req - role <- requireHouseholdRole conn (userId user) hid - unless (role == "owner") $ throwError HTTP.status403 "Only the owner can delete the household" - SQL.execute conn "DELETE FROM households WHERE id = ?" (Only hid) - throwJSON HTTP.status200 (A.object ["status" A..= A.String "deleted"]) - -handleListMembers :: SQL.Connection -> Wai.Request -> Int -> IO () -handleListMembers conn req hid = do - user <- requireAuth conn req - _ <- requireHouseholdRole conn (userId user) hid - members <- - SQL.query - conn - "SELECT u.id, u.display_name, u.email, m.role FROM memberships m JOIN users u ON u.id = m.user_id WHERE m.household_id = ?" - (Only hid) :: - IO [(Int, T.Text, T.Text, String)] - throwJSON HTTP.status200 [Membership (UserId uid) dname email (if role == "owner" then OwnerRole else MemberRole) | (uid, dname, email, role) <- members] - -handleRemoveMember :: SQL.Connection -> Wai.Request -> Int -> Int -> IO () -handleRemoveMember conn req hid targetUid = do - user <- requireAuth conn req - role <- requireHouseholdRole conn (userId user) hid - unless (role == "owner") $ throwError HTTP.status403 "Only the owner can remove members" - SQL.execute conn "DELETE FROM memberships WHERE household_id = ? AND user_id = ?" (hid, targetUid) - throwJSON HTTP.status200 (A.object ["status" A..= A.String "removed"]) - ----------------------------------------------------------------------- --- Invite handlers ----------------------------------------------------------------------- - -handleCreateInvite :: SQL.Connection -> Wai.Request -> Int -> IO BL.ByteString -> IO () -handleCreateInvite conn req hid getBody = do - user <- requireAuth conn req - role <- requireHouseholdRole conn (userId user) hid - unless (role == "owner") $ throwError HTTP.status403 "Only the owner can invite members" - cir <- parseBody getBody - case cirEmail cir of - Just em -> do - existing <- - SQL.query - conn - "SELECT 1 FROM users u JOIN memberships m ON m.user_id = u.id WHERE u.email = ? AND m.household_id = ?" - (em, hid) :: - IO [Only Int] - unless (null existing) $ throwError HTTP.status409 "User is already a member" - Nothing -> pure () - code <- Auth.generateToken - now <- Time.getCurrentTime - SQL.execute conn "INSERT INTO invites (household_id, code, email, created_at) VALUES (?, ?, ?, ?)" (hid, code, cirEmail cir, now) - iid <- SQL.lastInsertRowId conn - throwJSON HTTP.status201 $ Invite (InviteId (fromIntegral iid)) (HouseholdId hid) code (cirEmail cir) InvitePending now - -handleListInvites :: SQL.Connection -> Wai.Request -> Int -> IO () -handleListInvites conn req hid = do - user <- requireAuth conn req - _ <- requireHouseholdRole conn (userId user) hid - invites <- - SQL.query - conn - "SELECT id, household_id, code, email, status, created_at FROM invites WHERE household_id = ?" - (Only hid) :: - IO [(Int, Int, T.Text, Maybe T.Text, T.Text, Time.UTCTime)] - throwJSON HTTP.status200 [Invite (InviteId iid) (HouseholdId hhid) code email (mkStatus st) createdAt | (iid, hhid, code, email, st, createdAt) <- invites] - where - mkStatus "pending" = InvitePending; mkStatus "accepted" = InviteAccepted; mkStatus _ = InviteRevoked - -handleRevokeInvite :: SQL.Connection -> Wai.Request -> Int -> Int -> IO () -handleRevokeInvite conn req hid iid = do - user <- requireAuth conn req - role <- requireHouseholdRole conn (userId user) hid - unless (role == "owner") $ throwError HTTP.status403 "Only the owner can revoke invites" - SQL.execute conn "UPDATE invites SET status = 'revoked' WHERE id = ? AND household_id = ?" (iid, hid) - throwJSON HTTP.status200 (A.object ["status" A..= A.String "revoked"]) - -handleLookupInvite :: SQL.Connection -> T.Text -> IO () -handleLookupInvite conn code = do - result <- - SQL.query - conn - "SELECT id, household_id, code, email, status, created_at FROM invites WHERE code = ? AND status = 'pending'" - (Only code) :: - IO [(Int, Int, T.Text, Maybe T.Text, T.Text, Time.UTCTime)] - case result of - [(iid, hhid, c, email, _, createdAt)] -> throwJSON HTTP.status200 $ Invite (InviteId iid) (HouseholdId hhid) c email InvitePending createdAt - _ -> throwError HTTP.status404 "Invite not found or already used" - -handleAcceptInvite :: SQL.Connection -> Wai.Request -> T.Text -> IO () -handleAcceptInvite conn req code = do - user <- requireAuth conn req - result <- SQL.query conn "SELECT id, household_id FROM invites WHERE code = ? AND status = 'pending'" (Only code) :: IO [(Int, Int)] - case result of - [(iid, hid)] -> do - existing <- SQL.query conn "SELECT 1 FROM memberships WHERE household_id = ? AND user_id = ?" (hid, unUserId (userId user)) :: IO [Only Int] - unless (null existing) $ throwError HTTP.status409 "Already a member" - SQL.execute conn "INSERT INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)" (hid, unUserId (userId user), "member" :: String) - SQL.execute conn "UPDATE invites SET status = 'accepted' WHERE id = ?" (Only iid) - hResult <- - SQL.query - conn - "SELECT h.id, h.name, m.user_id, (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \ - \ FROM households h JOIN memberships m ON m.household_id = h.id AND m.role = 'owner' WHERE h.id = ?" - (Only hid) :: - IO [(Int, T.Text, Int, Int)] - case hResult of - [(hId, hName, ownerId, count)] -> throwJSON HTTP.status200 $ Household (HouseholdId hId) hName (UserId ownerId) count - _ -> throwError HTTP.status404 "Household not found" - _ -> throwError HTTP.status404 "Invite not found" - ----------------------------------------------------------------------- --- Chore handlers ----------------------------------------------------------------------- - -handleListChores :: SQL.Connection -> Wai.Request -> Int -> IO () -handleListChores conn req hid = do - user <- requireAuth conn req - _ <- requireHouseholdRole conn (userId user) hid - chores <- - SQL.query - conn - "SELECT id, household_id, name, assignee_type, assignee_user_id, schedule_data, notify_on_due, created_at \ - \ FROM chores WHERE household_id = ?" - (Only hid) :: - IO [(Int, Int, T.Text, String, Maybe Int, T.Text, Int, Time.UTCTime)] - throwJSON - HTTP.status200 - [ Chore (ChoreId cid) (HouseholdId hId) cname (mkAssignee atype auid) (mkSchedule sData) (nud /= 0) createdAt - | (cid, hId, cname, atype, auid, sData, nud, createdAt) <- chores - ] - where - mkAssignee "user" (Just uid) = AssigneeUser (UserId uid); mkAssignee _ _ = AssigneeAnyone - mkSchedule sData = fromMaybe ScheduleSometime (A.decodeStrict (TE.encodeUtf8 sData)) - -handleCreateChore :: SQL.Connection -> Wai.Request -> Int -> IO BL.ByteString -> IO () -handleCreateChore conn req hid getBody = do - user <- requireAuth conn req - _ <- requireHouseholdRole conn (userId user) hid - ccr <- parseBody getBody - now <- Time.getCurrentTime - let (aType, aUid) = case ccrAssignee ccr of AssigneeUser (UserId uid) -> ("user" :: String, Just uid); AssigneeAnyone -> ("anyone", Nothing) - sType = case ccrSchedule ccr of ScheduleOneOff{} -> "one_off" :: String; ScheduleRecurring{} -> "recurring"; ScheduleSometime -> "sometime" - sData = TE.decodeUtf8 $ BL.toStrict $ A.encode (ccrSchedule ccr) - SQL.execute - conn - "INSERT INTO chores (household_id, name, assignee_type, assignee_user_id, schedule_type, schedule_data, notify_on_due, created_at) VALUES (?,?,?,?,?,?,?,?)" - (hid, ccrName ccr, aType, aUid, sType, sData, if ccrNotifyOnDue ccr then 1 :: Int else 0, now) - cId <- SQL.lastInsertRowId conn - let chore = Chore (ChoreId (fromIntegral cId)) (HouseholdId hid) (ccrName ccr) (ccrAssignee ccr) (ccrSchedule ccr) (ccrNotifyOnDue ccr) now - generateOccurrences conn chore - throwJSON HTTP.status201 chore - -handleUpdateChore :: SQL.Connection -> Wai.Request -> Int -> Int -> IO BL.ByteString -> IO () -handleUpdateChore conn req hid cid getBody = do - user <- requireAuth conn req - _ <- requireHouseholdRole conn (userId user) hid - ucr <- parseBody getBody - now <- Time.getCurrentTime - let (aType, aUid) = case ucrAssignee ucr of AssigneeUser (UserId uid) -> ("user" :: String, Just uid); AssigneeAnyone -> ("anyone", Nothing) - sType = case ucrSchedule ucr of ScheduleOneOff{} -> "one_off" :: String; ScheduleRecurring{} -> "recurring"; ScheduleSometime -> "sometime" - sData = TE.decodeUtf8 $ BL.toStrict $ A.encode (ucrSchedule ucr) - SQL.execute - conn - "UPDATE chores SET name=?, assignee_type=?, assignee_user_id=?, schedule_type=?, schedule_data=?, notify_on_due=? WHERE id=? AND household_id=?" - (ucrName ucr, aType, aUid, sType, sData, if ucrNotifyOnDue ucr then 1 :: Int else 0, cid, hid) - SQL.execute conn "DELETE FROM occurrences WHERE chore_id = ? AND status IN ('due', 'overdue')" (Only cid) - let chore = Chore (ChoreId cid) (HouseholdId hid) (ucrName ucr) (ucrAssignee ucr) (ucrSchedule ucr) (ucrNotifyOnDue ucr) now - generateOccurrences conn chore - throwJSON HTTP.status200 chore - -handleDeleteChore :: SQL.Connection -> Wai.Request -> Int -> Int -> IO () -handleDeleteChore conn req hid cid = do - user <- requireAuth conn req - _ <- requireHouseholdRole conn (userId user) hid - SQL.execute conn "DELETE FROM chores WHERE id = ? AND household_id = ?" (cid, hid) - throwJSON HTTP.status200 (A.object ["status" A..= A.String "deleted"]) - ----------------------------------------------------------------------- --- Dashboard ----------------------------------------------------------------------- - -handleDashboard :: SQL.Connection -> Wai.Request -> Int -> IO () -handleDashboard conn req hid = do - user <- requireAuth conn req - _ <- requireHouseholdRole conn (userId user) hid - today <- Time.utctDay <$> Time.getCurrentTime - let todayStr = show today - [Only overdueCount] <- - SQL.query - conn - "SELECT COUNT(*) FROM occurrences o JOIN chores c ON c.id = o.chore_id WHERE c.household_id = ? AND o.due_date < ? AND o.status IN ('due', 'overdue')" - (hid, todayStr) :: - IO [Only Int] - [Only dueTodayCount] <- - SQL.query - conn - "SELECT COUNT(*) FROM occurrences o JOIN chores c ON c.id = o.chore_id WHERE c.household_id = ? AND o.due_date = ? AND o.status = 'due'" - (hid, todayStr) :: - IO [Only Int] - [Only doneThisWeek] <- - SQL.query - conn - "SELECT COUNT(*) FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id WHERE c.household_id = ? AND a.recorded_at >= ?" - (hid, show (Time.addDays (-7) today)) :: - IO [Only Int] - let stats = DashboardStats overdueCount dueTodayCount doneThisWeek - dueRows <- - SQL.query - conn - "SELECT o.id, o.chore_id, o.due_date, o.status, c.name, u.display_name \ - \ FROM occurrences o JOIN chores c ON c.id = o.chore_id LEFT JOIN users u ON u.id = c.assignee_user_id \ - \ WHERE c.household_id = ? AND o.due_date <= ? AND o.status IN ('due', 'overdue') ORDER BY o.due_date LIMIT 50" - (hid, todayStr) :: - IO [(Int, Int, Time.Day, T.Text, T.Text, Maybe T.Text)] - let dueItems = [DueItem (Occurrence (OccurrenceId oid) (ChoreId cid) d (mkOcc st)) cn uname (d < today) | (oid, cid, d, st, cn, uname) <- dueRows] - compRows <- - SQL.query - conn - "SELECT a.id, a.occurrence_id, a.user_id, a.status, a.note, a.notify_household, a.recorded_at, u.display_name, c.name \ - \ FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id JOIN users u ON u.id = a.user_id \ - \ WHERE c.household_id = ? AND a.recorded_at >= ? ORDER BY a.recorded_at DESC LIMIT 50" - (hid, show today) :: - IO [(Int, Int, Int, T.Text, Maybe T.Text, Int, Time.UTCTime, T.Text, T.Text)] - let compItems = - [ CompletedItem (Activity (ActivityId aid) (OccurrenceId oid) (UserId uid) (mkAct st) note (nh /= 0) recAt) uname cn - | (aid, oid, uid, st, note, nh, recAt, uname, cn) <- compRows - ] - throwJSON HTTP.status200 $ Dashboard stats dueItems compItems - where - mkOcc "due" = OccDue; mkOcc "overdue" = OccOverdue; mkOcc "completed" = OccCompleted; mkOcc _ = OccSkipped - mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped - ----------------------------------------------------------------------- --- Activity ----------------------------------------------------------------------- - -handleRecordActivity :: SQL.Connection -> Wai.Request -> Int -> IO BL.ByteString -> IO () -handleRecordActivity conn req oid getBody = do - user <- requireAuth conn req - rar <- parseBody getBody - now <- Time.getCurrentTime - occResult <- - SQL.query - conn - "SELECT o.chore_id, c.household_id FROM occurrences o JOIN chores c ON c.id = o.chore_id WHERE o.id = ?" - (Only oid) :: - IO [(Int, Int)] - case occResult of - [(_, hid)] -> do - _ <- requireHouseholdRole conn (userId user) hid - let actStatus = case rarStatus rar of ActivityCompleted -> "completed" :: String; ActivitySkipped -> "skipped" - SQL.execute - conn - "INSERT INTO activities (occurrence_id, user_id, status, note, notify_household, recorded_at) VALUES (?,?,?,?,?,?)" - (oid, unUserId (userId user), actStatus, rarNote rar, if rarNotifyHousehold rar then 1 :: Int else 0, now) - let occStatus = case rarStatus rar of ActivityCompleted -> "completed" :: String; ActivitySkipped -> "skipped" - SQL.execute conn "UPDATE occurrences SET status = ? WHERE id = ?" (occStatus, oid) - actId <- SQL.lastInsertRowId conn - throwJSON HTTP.status201 $ Activity (ActivityId (fromIntegral actId)) (OccurrenceId oid) (userId user) (rarStatus rar) (rarNote rar) (rarNotifyHousehold rar) now - _ -> throwError HTTP.status404 "Occurrence not found" - -handleActivityLog :: SQL.Connection -> Wai.Request -> Int -> IO () -handleActivityLog conn req hid = do - user <- requireAuth conn req - _ <- requireHouseholdRole conn (userId user) hid - let qs = Wai.queryString req - {- HLINT ignore "Use join" -} - let page = maybe 1 (read . T.unpack . TE.decodeUtf8) (lookup "page" qs >>= id) - let perPage = maybe 20 (read . T.unpack . TE.decodeUtf8) (lookup "perPage" qs >>= id) - let offset = (page - 1) * perPage - [Only totalCount] <- - SQL.query - conn - "SELECT COUNT(*) FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id WHERE c.household_id = ?" - (Only hid) :: - IO [Only Int] - entries <- - SQL.query - conn - "SELECT a.id, a.occurrence_id, a.user_id, a.status, a.note, a.notify_household, a.recorded_at, u.display_name, c.name, o.due_date \ - \ FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id JOIN users u ON u.id = a.user_id \ - \ WHERE c.household_id = ? ORDER BY a.recorded_at DESC LIMIT ? OFFSET ?" - (hid, perPage, offset) :: - IO [(Int, Int, Int, T.Text, Maybe T.Text, Int, Time.UTCTime, T.Text, T.Text, Time.Day)] - let logEntries = - [ ActivityLogEntry (Activity (ActivityId aid) (OccurrenceId oid) (UserId uid) (mkAct st) note (nh /= 0) recAt) uname "" cn d - | (aid, oid, uid, st, note, nh, recAt, uname, cn, d) <- entries - ] - throwJSON HTTP.status200 $ ActivityLogPage logEntries page perPage totalCount - where - mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped - ----------------------------------------------------------------------- --- Seed ----------------------------------------------------------------------- - -handleSeed :: SQL.Connection -> IO () -handleSeed conn = do - let demoPassword = "password123" - pwHash <- Auth.hashPassword demoPassword - SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash) VALUES (1, 'Alice', 'alice@demo.com', ?)" (Only pwHash) - SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash) VALUES (2, 'Bob', 'bob@demo.com', ?)" (Only pwHash) - SQL.execute conn "INSERT OR IGNORE INTO users (id, display_name, email, password_hash) VALUES (3, 'Charlie', 'charlie@demo.com', ?)" (Only pwHash) - SQL.execute_ conn "INSERT OR IGNORE INTO households (id, name) VALUES (1, 'Demo House')" - SQL.execute_ conn "INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (1, 1, 'owner')" - SQL.execute_ conn "INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (1, 2, 'member')" - SQL.execute_ conn "INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (1, 3, 'member')" - let sData1 = TE.decodeUtf8 $ BL.toStrict $ A.encode (ScheduleRecurring PeriodDaily (read "2026-07-15") (Just "08:00:00") Nothing Nothing) - SQL.execute conn "INSERT OR IGNORE INTO chores (id, household_id, name, assignee_type, schedule_type, schedule_data, notify_on_due) VALUES (1, 1, 'Take out trash', 'anyone', 'recurring', ?, 1)" (Only sData1) - let sData2 = TE.decodeUtf8 $ BL.toStrict $ A.encode (ScheduleRecurring PeriodWeekly (read "2026-07-13") (Just "10:00:00") (Just [1, 4]) Nothing) - SQL.execute conn "INSERT OR IGNORE INTO chores (id, household_id, name, assignee_type, assignee_user_id, schedule_type, schedule_data, notify_on_due) VALUES (2, 1, 'Vacuum living room', 'user', 2, 'recurring', ?, 0)" (Only sData2) - let sData3 = TE.decodeUtf8 $ BL.toStrict $ A.encode ScheduleSometime - SQL.execute conn "INSERT OR IGNORE INTO chores (id, household_id, name, assignee_type, schedule_type, schedule_data, notify_on_due) VALUES (3, 1, 'Clean the garage', 'anyone', 'sometime', ?, 0)" (Only sData3) - today <- Time.utctDay <$> Time.getCurrentTime - let windowEnd = Time.addDays 90 today - let dates1 = generateRecurringDates PeriodDaily (read "2026-07-15") today windowEnd - mapM_ (SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (1, ?)" . Only) (take 90 dates1) - let dates2 = generateRecurringDates PeriodWeekly (read "2026-07-13") today windowEnd - mapM_ (SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (2, ?)" . Only) (take 90 dates2) - SQL.execute_ conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (3, '9999-12-31')" - throwJSON HTTP.status200 (A.object ["status" A..= A.String "seeded"]) - ----------------------------------------------------------------------- --- Static file serving ----------------------------------------------------------------------- - -mimeType :: FilePath -> Maybe BS.ByteString -mimeType fp = Map.lookup ext mimeTypes - where - ext = T.toLower $ T.pack $ reverse $ takeWhile (/= '.') $ reverse fp - -mimeTypes :: Map.Map T.Text BS.ByteString -mimeTypes = - Map.fromList - [ ("html", "text/html") - , ("css", "text/css") - , ("js", "application/javascript") - , ("json", "application/json") - , ("png", "image/png") - , ("jpg", "image/jpeg") - , ("svg", "image/svg+xml") - , ("ico", "image/x-icon") - , ("manifest", "application/manifest+json") - ] - -serveStaticOrSpa :: FilePath -> Wai.Application -serveStaticOrSpa staticDir request respond = do - let path = TE.decodeUtf8 $ Wai.rawPathInfo request - let fp = staticDir dropWhile (== '/') (T.unpack path) - exists <- doesFileExist fp - let hasExt = '.' `elem` reverse (takeWhile (/= '/') (reverse (T.unpack path))) - if exists - then do - content <- BS.readFile fp - let ct = fromMaybe "application/octet-stream" $ mimeType fp - respond $ Wai.responseLBS HTTP.status200 [("Content-Type", ct)] (BL.fromStrict content) - else - if not hasExt - then do - let indexPath = staticDir "index.html" - idxExists <- doesFileExist indexPath - if idxExists - then do - content <- BS.readFile indexPath - respond $ Wai.responseLBS HTTP.status200 [("Content-Type", "text/html")] (BL.fromStrict content) - else respond notFoundResponse - else respond notFoundResponse - -notFoundResponse :: Wai.Response -notFoundResponse = Wai.responseLBS HTTP.status404 [("Content-Type", "text/plain")] "Not Found" diff --git a/src/Sis/Types.hs b/src/Sis/Types.hs index 15d6808..2c98882 100644 --- a/src/Sis/Types.hs +++ b/src/Sis/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | Core domain types for Sis. @@ -13,10 +15,7 @@ module Sis.Types ( OccurrenceId (..), ActivityId (..), InviteId (..), - UserPublic (..), User (..), - SignupRequest (..), - LoginRequest (..), -- * Household Household (..), @@ -24,16 +23,12 @@ module Sis.Types ( MemberRole (..), Invite (..), InviteStatus (..), - CreateHouseholdRequest (..), - CreateInviteRequest (..), -- * Chore Chore (..), ChoreAssignee (..), Schedule (..), SchedulePeriod (..), - CreateChoreRequest (..), - UpdateChoreRequest (..), -- * Occurrence Occurrence (..), @@ -42,7 +37,6 @@ module Sis.Types ( -- * Activity Activity (..), ActivityStatus (..), - RecordActivityRequest (..), -- * Dashboard Dashboard (..), @@ -54,41 +48,40 @@ module Sis.Types ( ActivityLogEntry (..), ActivityLogPage (..), - -- * Auth responses - AuthResponse (..), - - -- * Error - ErrorResponse (..), - - -- * Seed - SeedRequest (..), + -- * Form types for Hyperbole + LoginForm (..), + SignupForm (..), + ChoreFormData (..), + ActivityFormData (..), + HouseholdFormData (..), ) where -import Data.Aeson qualified as A import Data.Text (Text) import Data.Time (Day, LocalTime, UTCTime) +import GHC.Generics (Generic) +import Web.Hyperbole.HyperView.Forms (FromForm) ---------------------------------------------------------------------- -- IDs ---------------------------------------------------------------------- newtype UserId = UserId {unUserId :: Int} - deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON, A.ToJSONKey, A.FromJSONKey) + deriving newtype (Show, Eq, Read) newtype HouseholdId = HouseholdId {unHouseholdId :: Int} - deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON, A.ToJSONKey, A.FromJSONKey) + deriving newtype (Show, Eq, Read) newtype ChoreId = ChoreId {unChoreId :: Int} - deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON) + deriving newtype (Show, Eq, Read) newtype OccurrenceId = OccurrenceId {unOccurrenceId :: Int} - deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON) + deriving newtype (Show, Eq, Read) newtype ActivityId = ActivityId {unActivityId :: Int} - deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON) + deriving newtype (Show, Eq, Read) newtype InviteId = InviteId {unInviteId :: Int} - deriving newtype (Show, Eq, Read, A.ToJSON, A.FromJSON) + deriving newtype (Show, Eq, Read) ---------------------------------------------------------------------- -- User @@ -102,67 +95,6 @@ data User = User } deriving stock (Show, Eq) --- | Public user info (never includes password hash) -data UserPublic = UserPublic - { upId :: UserId - , upDisplayName :: Text - , upEmail :: Text - } - deriving stock (Show, Eq) - -instance A.ToJSON UserPublic where - toJSON u = - A.object - [ "id" A..= upId u - , "displayName" A..= upDisplayName u - , "email" A..= upEmail u - ] - -data SignupRequest = SignupRequest - { srDisplayName :: Text - , srEmail :: Text - , srPassword :: Text - , srConfirmPassword :: Text - , srAgreeTerms :: Bool - } - deriving stock (Show, Eq) - -instance A.FromJSON SignupRequest where - parseJSON = A.withObject "SignupRequest" $ \o -> - SignupRequest - <$> o A..: "displayName" - <*> o A..: "email" - <*> o A..: "password" - <*> o A..: "confirmPassword" - <*> o A..: "agreeTerms" - -data LoginRequest = LoginRequest - { lrEmail :: Text - , lrPassword :: Text - , lrRememberMe :: Bool - } - deriving stock (Show, Eq) - -instance A.FromJSON LoginRequest where - parseJSON = A.withObject "LoginRequest" $ \o -> - LoginRequest - <$> o A..: "email" - <*> o A..: "password" - <*> o A..: "rememberMe" - -data AuthResponse = AuthResponse - { arUser :: UserPublic - , arHouseholds :: [Household] - } - deriving stock (Show, Eq) - -instance A.ToJSON AuthResponse where - toJSON r = - A.object - [ "user" A..= arUser r - , "households" A..= arHouseholds r - ] - ---------------------------------------------------------------------- -- Household ---------------------------------------------------------------------- @@ -170,16 +102,6 @@ instance A.ToJSON AuthResponse where 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 @@ -188,15 +110,6 @@ data Household = Household } deriving stock (Show, Eq) -instance A.ToJSON Household where - toJSON h = - A.object - [ "id" A..= householdId h - , "name" A..= householdName h - , "owner" A..= householdOwner h - , "memberCount" A..= householdMemberCount h - ] - data Membership = Membership { membershipUserId :: UserId , membershipDisplayName :: Text @@ -205,30 +118,9 @@ data Membership = Membership } 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 @@ -239,34 +131,6 @@ data Invite = Invite } 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 ---------------------------------------------------------------------- @@ -276,32 +140,8 @@ data ChoreAssignee | 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 + deriving stock (Show, Eq, Read) data Schedule = ScheduleOneOff {soDate :: Day, soTime :: Maybe LocalTime} @@ -313,44 +153,7 @@ data Schedule , 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 + deriving stock (Show, Eq, Read) data Chore = Chore { choreId :: ChoreId @@ -363,50 +166,6 @@ data Chore = Chore } 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 ---------------------------------------------------------------------- @@ -414,12 +173,6 @@ instance A.FromJSON UpdateChoreRequest where 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 @@ -428,15 +181,6 @@ data Occurrence = Occurrence } 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 ---------------------------------------------------------------------- @@ -444,16 +188,6 @@ instance A.ToJSON Occurrence where 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 @@ -465,32 +199,6 @@ data Activity = Activity } 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 ---------------------------------------------------------------------- @@ -502,15 +210,6 @@ data DashboardStats = DashboardStats } 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 @@ -519,16 +218,6 @@ data DueItem = DueItem } 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 @@ -536,14 +225,6 @@ data CompletedItem = CompletedItem } 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] @@ -551,14 +232,6 @@ data Dashboard = Dashboard } 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 ---------------------------------------------------------------------- @@ -572,16 +245,6 @@ data ActivityLogEntry = ActivityLogEntry } 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 @@ -590,38 +253,45 @@ data ActivityLogPage = ActivityLogPage } deriving stock (Show, Eq) -instance A.ToJSON ActivityLogPage where - toJSON p = - A.object - [ "entries" A..= alpEntries p - , "page" A..= alpPage p - , "perPage" A..= alpPerPage p - , "total" A..= alpTotal p - ] - ---------------------------------------------------------------------- --- Error +-- Hyperbole Form Types ---------------------------------------------------------------------- -data ErrorResponse = ErrorResponse - { errorMessage :: Text - , errorField :: Maybe Text +data LoginForm = LoginForm + { lfEmail :: Text + , lfPassword :: Text + , lfRemember :: Bool } - deriving stock (Show, Eq) + deriving (Show, Eq, Generic, FromForm) -instance A.ToJSON ErrorResponse where - toJSON e = - A.object - [ "error" A..= errorMessage e - , "field" A..= errorField e - ] +data SignupForm = SignupForm + { sfDisplayName :: Text + , sfEmail :: Text + , sfPassword :: Text + , sfConfirm :: Text + , sfAgree :: Bool + } + deriving (Show, Eq, Generic, FromForm) ----------------------------------------------------------------------- --- Seed ----------------------------------------------------------------------- +data ChoreFormData = ChoreFormData + { cfdName :: Text + , cfdScheduleType :: Text + , cfdStartDate :: Text + , cfdTimeOfDay :: Maybe Text + , cfdPeriod :: Text + , cfdAssignee :: Text + , cfdNotify :: Bool + } + deriving (Show, Eq, Generic, FromForm) -data SeedRequest = SeedRequest - deriving stock (Show, Eq) +data ActivityFormData = ActivityFormData + { afdStatus :: Text + , afdNote :: Maybe Text + , afdNotify :: Bool + } + deriving (Show, Eq, Generic, FromForm) -instance A.FromJSON SeedRequest where - parseJSON _ = pure SeedRequest +data HouseholdFormData = HouseholdFormData + { hfdName :: Text + } + deriving (Show, Eq, Generic, FromForm) diff --git a/stack.yaml b/stack.yaml index 420ff49..75a1177 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,16 +2,15 @@ resolver: lts-24.38 packages: - . + - hyperbole-local extra-deps: - - hyperbole-0.7.1 - atomic-css-0.2.0 - data-default-0.8.0.2 - effectful-2.4.0.0 - effectful-core-2.4.0.0 - string-conversions-0.4.0.1 - - aeson-2.1.2.1 - - attoparsec-aeson-2.1.0.0 + - attoparsec-aeson-2.2.2.0 - string-interpolate-0.3.4.0 allow-newer: true diff --git a/stack.yaml.lock b/stack.yaml.lock index 14e1dc2..ed61fa0 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,104 +5,54 @@ packages: - completed: - name: beeline-params + hackage: atomic-css-0.2.0@sha256:7a546465724689e55c9b9cad64da7c361f2de728430f994a73f906985b164c09,3106 pantry-tree: - sha256: 44791687ad987b596ff02fd1776386bef293a27e097c7c589a3bb76a9a81f200 - size: 1210 - sha256: 93fff6138e28d8989741b4fc8622096d2211dad35f1d113a341d89d0d3235d8f - size: 36315 - subdir: beeline-params - url: https://github.com/flipstone/beeline/archive/e31206f52fec7e96c15de9a2bab9ef1876db137b.tar.gz - version: 0.3.0.0 + sha256: 0f13530abe495d48d977abe09747749dc7d3911629c5a8107e067f4446bfea25 + size: 1931 original: - subdir: beeline-params - url: https://github.com/flipstone/beeline/archive/e31206f52fec7e96c15de9a2bab9ef1876db137b.tar.gz + hackage: atomic-css-0.2.0 - completed: - name: beeline-routing + hackage: data-default-0.8.0.2@sha256:d4a8c9ed574a43315262666c75efe1080e3913a653844d2a9ff36051a6211bee,1110 pantry-tree: - sha256: 555ab8a55094ffa801fa8ee8e8fc9b11ec21c08cff29e5dc152ae7f171fa3ccd - size: 1119 - sha256: 93fff6138e28d8989741b4fc8622096d2211dad35f1d113a341d89d0d3235d8f - size: 36315 - subdir: beeline-routing - url: https://github.com/flipstone/beeline/archive/e31206f52fec7e96c15de9a2bab9ef1876db137b.tar.gz - version: 0.3.0.2 + sha256: 6f42bc6c080c5e1cb7894b03b2d1494a05b9056dcef477965205e9448d8889f8 + size: 382 original: - subdir: beeline-routing - url: https://github.com/flipstone/beeline/archive/e31206f52fec7e96c15de9a2bab9ef1876db137b.tar.gz + hackage: data-default-0.8.0.2 - completed: - name: shrubbery + hackage: effectful-2.4.0.0@sha256:a821150318cda9c9c8d17230de8b3c6df47d3be9aba6aeb9faaf28a80bf374c5,7670 pantry-tree: - sha256: d16c6b171d9b360098760d2c2269ded8eaae823ed9aa5c7a36598673e83fb9e3 - size: 2834 - sha256: 8bb3b52a8f9cb3f6edc5ee0c4584c81187b05966d59d718a247a6707479e2e33 - size: 30344 - url: https://github.com/flipstone/shrubbery/archive/a064ede07e01b753a6eb310fc24d9fd8da1ad826.tar.gz - version: 0.2.3.1 + sha256: 2debfdcf5f46f02ce8c9f4cbed19496bf92dcfbd198eb319a0c0269af0db425f + size: 3409 original: - url: https://github.com/flipstone/shrubbery/archive/a064ede07e01b753a6eb310fc24d9fd8da1ad826.tar.gz + hackage: effectful-2.4.0.0 - completed: - name: json-fleece-aeson + hackage: effectful-core-2.4.0.0@sha256:fd799704b5a8bc3a7b7709a5ffa33584602b98e5f3b8b1e9c770816dd9f8ccc3,4395 pantry-tree: - sha256: 1519042c7af52c169b4543d0de5639d344f3ea8652461fdc8d85f26b0d318f5a - size: 628 - sha256: 534fdb939c428db16fc6c07d3fe1c709ebc0b5b43c490f89639d6093ea12d8f3 - size: 3095867 - subdir: json-fleece-aeson - url: https://github.com/flipstone/json-fleece/archive/77813eac694f937b6e013230825f03aba224f866.tar.gz - version: 0.5.1.0 + sha256: 49af204868918943e05f709f9cf9c5c93c60f5614a0ee1d31cd29f678bf960ce + size: 2473 original: - subdir: json-fleece-aeson - url: https://github.com/flipstone/json-fleece/archive/77813eac694f937b6e013230825f03aba224f866.tar.gz + hackage: effectful-core-2.4.0.0 - completed: - name: json-fleece-core + hackage: string-conversions-0.4.0.1@sha256:9af49d61d1dcbc8b90b66f1b6580996b7927f745273edb59141ad6744aef7cbc,1693 pantry-tree: - sha256: 87d6a45a9b470843d28d1c2927b8f12ad4f687d987bad630e04ead9e824ee0a9 - size: 491 - sha256: 534fdb939c428db16fc6c07d3fe1c709ebc0b5b43c490f89639d6093ea12d8f3 - size: 3095867 - subdir: json-fleece-core - url: https://github.com/flipstone/json-fleece/archive/77813eac694f937b6e013230825f03aba224f866.tar.gz - version: 0.12.0.0 + sha256: 95b5bc46689b408ad3c898388bc55fe36612451d521c6cdd5beeb93a033d4848 + size: 442 original: - subdir: json-fleece-core - url: https://github.com/flipstone/json-fleece/archive/77813eac694f937b6e013230825f03aba224f866.tar.gz + hackage: string-conversions-0.4.0.1 - completed: - name: bounded-text + hackage: attoparsec-aeson-2.2.2.0@sha256:08948f45b892c5758d2c42e22fe2fbd41a4f6dc395fb0a43c2bf458a1f295736,1664 pantry-tree: - sha256: e98540b1877ae4709420472f83e8fd04b987eaeb914df72bb33b0bbe55debac2 - size: 2162 - sha256: 29c500737d8e481fe2e3325fe643a9cafc565ffd06b754bf14219f579d927f5d - size: 11885 - url: https://github.com/flipstone/bounded-text/archive/3ef94eeda5402857423284d0c4e021a8c8032498.tar.gz - version: 0.1.2.0 + sha256: da131689cab810d63fefbca44bb40aa96be6ab5981e11308eef73b57edfe26c6 + size: 404 original: - url: https://github.com/flipstone/bounded-text/archive/3ef94eeda5402857423284d0c4e021a8c8032498.tar.gz + hackage: attoparsec-aeson-2.2.2.0 - completed: - name: orb + hackage: string-interpolate-0.3.4.0@sha256:b58f8d4f2d591878b3e632dc36b210582d41e72f5e6484a2e42a647a57b85a18,4274 pantry-tree: - sha256: 8888da81f391b551df85ce50b9f8ec7349dcf87b3a062780cf71d915c8c7e0e1 - size: 6804 - sha256: 47bc481b103d86fe38bd0b94d09d88f242e657073108018a2e4652e695636f0f - size: 1194518 - url: https://github.com/flipstone/orb/archive/74cceef9d0db9ac3ef1856613e7605750c8c0a2a.tar.gz - version: 0.7.1.0 + sha256: 73130fdccd3de97e38971a0dc002fd303fc83db3019ccebf739fe4bc45735822 + size: 1248 original: - url: https://github.com/flipstone/orb/archive/74cceef9d0db9ac3ef1856613e7605750c8c0a2a.tar.gz -- completed: - hackage: template-haskell-lift-0.1.0.0@sha256:f6cd3ee45b0c68480c400bfca9f08f39e8e87a5eb823f206dbe06ab1923a4f1c,1136 - pantry-tree: - sha256: 56ab994094c839bebb643ce5fc58dfae6269517ebe91f380e259adaf1def08bf - size: 243 - original: - hackage: template-haskell-lift-0.1.0.0 -- completed: - hackage: template-haskell-quasiquoter-0.1.0.0@sha256:71027c432c0fb1a293d0f2b1d46dd5be42b9703b7c4b2233ea8076bfc6f84aae,1181 - pantry-tree: - sha256: f9f5177a522cc273c001dd5bd749e4f7ed841910c6136711b9b9825bc0bc9c56 - size: 257 - original: - hackage: template-haskell-quasiquoter-0.1.0.0 + hackage: string-interpolate-0.3.4.0 snapshots: - completed: sha256: abc790b571e0c70e929db74b329e3c18d7e76a6e173e8bdf94f1ba20770d4c24