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
This commit is contained in:
@@ -12,3 +12,5 @@ __pycache__
|
||||
.superpowers/
|
||||
node_modules/
|
||||
frontend/dist/
|
||||
hyperbole-local/
|
||||
hyperbole-local/
|
||||
|
||||
@@ -19,7 +19,6 @@ library
|
||||
Sis
|
||||
Sis.Auth
|
||||
Sis.Database
|
||||
Sis.Server
|
||||
Sis.Types
|
||||
other-modules:
|
||||
Paths_sis_server
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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"
|
||||
+52
-382
@@ -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)
|
||||
|
||||
+2
-3
@@ -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
|
||||
|
||||
+28
-78
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user