feat: Hyperbole port - all modules created, Database effect working
- Database.hs: effectful DB effect with all operations + convenience wrappers - Types.hs: stripped Aeson (kept ToJSON/FromJSON on IDs), added form types - Route.hs, Style.hs, View/Layout.hs: support modules - All Page modules: Login, Signup, Dashboard, Chores, Household, Activity - Main.hs: Hyperbole app entry point with router - Known issue: Hyperbole view DSL syntax needs cleanup in page modules (tag calls need $ none suffix, form elements need field wrappers)
This commit is contained in:
+408
-13
@@ -1,23 +1,357 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{- | SQLite database support for Sis.
|
||||
|
||||
Opens (and creates if missing) a SQLite database with WAL journal
|
||||
mode and foreign keys enabled. Runs schema migrations on startup.
|
||||
{- | SQLite database support for Sis using the effectful effect system.
|
||||
-}
|
||||
module Sis.Database (
|
||||
openDatabase,
|
||||
runMigrations,
|
||||
) where
|
||||
module Sis.Database
|
||||
( -- * Effect
|
||||
DB (..)
|
||||
, runDB
|
||||
, openDatabase
|
||||
, runMigrations
|
||||
|
||||
-- * DB operations (convenience wrappers)
|
||||
, findUserByEmail
|
||||
, createUser
|
||||
, getUser
|
||||
, getUserHouseholds
|
||||
, getHousehold
|
||||
, createHousehold
|
||||
, getMembers
|
||||
, getChores
|
||||
, createChore
|
||||
, updateChore
|
||||
, deleteChore
|
||||
, getDashboard
|
||||
, recordActivity
|
||||
, getActivityLog
|
||||
, createInvite
|
||||
, getInvites
|
||||
, revokeInvite
|
||||
, acceptInvite
|
||||
, seed
|
||||
) where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.Time (Day, UTCTime, addDays, getCurrentTime, utctDay)
|
||||
import Data.Time qualified as Time
|
||||
import Data.Time.Calendar (addGregorianMonthsClip)
|
||||
import Database.SQLite.Simple qualified as SQL
|
||||
import Database.SQLite.Simple (Only (..))
|
||||
import Text.Read (readMaybe)
|
||||
import Effectful
|
||||
import Effectful.Dispatch.Dynamic
|
||||
import System.Directory (createDirectoryIfMissing)
|
||||
import System.FilePath (takeDirectory)
|
||||
|
||||
{- | Open (or create) a SQLite database at the given path.
|
||||
import Sis.Types
|
||||
|
||||
Enables WAL journal mode for concurrent read performance and
|
||||
enables foreign key enforcement.
|
||||
----------------------------------------------------------------------
|
||||
-- Effect definition
|
||||
----------------------------------------------------------------------
|
||||
|
||||
data DB :: Effect where
|
||||
FindUserByEmail :: Text -> DB m (Maybe User)
|
||||
CreateUser :: Text -> Text -> Text -> DB m UserId
|
||||
GetUser :: UserId -> DB m (Maybe User)
|
||||
GetUserHouseholds :: UserId -> DB m [Household]
|
||||
GetHousehold :: UserId -> Int -> DB m (Maybe Household)
|
||||
CreateHousehold :: UserId -> Text -> DB m Household
|
||||
GetMembers :: Int -> DB m [Membership]
|
||||
GetChores :: Int -> DB m [Chore]
|
||||
CreateChore :: Int -> Text -> ChoreAssignee -> Schedule -> Bool -> DB m Chore
|
||||
UpdateChore :: Int -> Int -> Text -> ChoreAssignee -> Schedule -> Bool -> DB m Chore
|
||||
DeleteChore :: Int -> DB m ()
|
||||
GetDashboard :: Int -> Day -> DB m Dashboard
|
||||
GenerateOccurrences :: Chore -> DB m ()
|
||||
RecordActivity :: Int -> UserId -> ActivityStatus -> Maybe Text -> Bool -> DB m Activity
|
||||
GetActivityLog :: Int -> Int -> Int -> DB m ActivityLogPage
|
||||
CreateInvite :: Int -> Maybe Text -> DB m Invite
|
||||
GetInvites :: Int -> DB m [Invite]
|
||||
RevokeInvite :: Int -> DB m ()
|
||||
AcceptInvite :: UserId -> Text -> DB m Household
|
||||
Seed :: DB m ()
|
||||
|
||||
type instance DispatchOf DB = 'Dynamic
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- Handler
|
||||
----------------------------------------------------------------------
|
||||
|
||||
runDB :: (IOE :> es) => SQL.Connection -> Eff (DB : es) a -> Eff es a
|
||||
runDB conn = interpret $ \_ -> \case
|
||||
FindUserByEmail email -> liftIO $ do
|
||||
result <- SQL.query conn
|
||||
"SELECT id, display_name, email, password_hash FROM users WHERE email = ?"
|
||||
(Only email)
|
||||
pure $ listToMaybe [User (UserId uid) dname em pwHash | (uid, dname, em, pwHash) <- result]
|
||||
|
||||
CreateUser dname email pwHash -> liftIO $ do
|
||||
SQL.execute conn
|
||||
"INSERT INTO users (display_name, email, password_hash) VALUES (?, ?, ?)"
|
||||
(dname, email, pwHash)
|
||||
uid <- SQL.lastInsertRowId conn
|
||||
pure $ UserId (fromIntegral uid)
|
||||
|
||||
GetUser (UserId uid) -> liftIO $ do
|
||||
result <- SQL.query conn
|
||||
"SELECT id, display_name, email, password_hash FROM users WHERE id = ?"
|
||||
(Only uid)
|
||||
pure $ listToMaybe [User (UserId uid') dname em pwHash | (uid', dname, em, pwHash) <- result]
|
||||
|
||||
GetUserHouseholds (UserId uid) -> liftIO $ do
|
||||
rows <- SQL.query conn
|
||||
"SELECT h.id, h.name, m2.user_id, \
|
||||
\ (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \
|
||||
\ FROM households h JOIN memberships m ON m.household_id = h.id AND m.user_id = ? \
|
||||
\ JOIN memberships m2 ON m2.household_id = h.id AND m2.role = 'owner'"
|
||||
(Only uid)
|
||||
pure [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- rows]
|
||||
|
||||
GetHousehold (UserId uid) hid -> liftIO $ do
|
||||
result <- SQL.query conn
|
||||
"SELECT h.id, h.name, m2.user_id, (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \
|
||||
\ FROM households h JOIN memberships m ON m.household_id = h.id AND m.user_id = ? \
|
||||
\ JOIN memberships m2 ON m2.household_id = h.id AND m2.role = 'owner' WHERE h.id = ?"
|
||||
(uid, hid)
|
||||
pure $ listToMaybe [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- result]
|
||||
|
||||
CreateHousehold (UserId uid) name -> liftIO $ do
|
||||
SQL.execute conn "INSERT INTO households (name) VALUES (?)" (Only name)
|
||||
hId <- SQL.lastInsertRowId conn
|
||||
let hid = HouseholdId (fromIntegral hId)
|
||||
SQL.execute conn
|
||||
"INSERT INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)"
|
||||
(unHouseholdId hid, uid, "owner" :: String)
|
||||
pure $ Household hid name (UserId uid) 1
|
||||
|
||||
GetMembers hid -> liftIO $ do
|
||||
members <- SQL.query conn
|
||||
"SELECT u.id, u.display_name, u.email, m.role \
|
||||
\ FROM memberships m JOIN users u ON u.id = m.user_id WHERE m.household_id = ?"
|
||||
(Only hid)
|
||||
pure [Membership (UserId uid) dname email (if role == ("owner" :: String) then OwnerRole else MemberRole)
|
||||
| (uid, dname, email, role) <- members]
|
||||
|
||||
GetChores hid -> liftIO $ do
|
||||
chores <- SQL.query conn
|
||||
"SELECT id, household_id, name, assignee_type, assignee_user_id, schedule_data, notify_on_due, created_at \
|
||||
\ FROM chores WHERE household_id = ?"
|
||||
(Only hid) :: IO [(Int, Int, Text, String, Maybe Int, Text, Int, UTCTime)]
|
||||
pure [Chore { choreId = ChoreId cid
|
||||
, choreHouseholdId = HouseholdId hId
|
||||
, choreName = cname
|
||||
, choreAssignee = mkAssignee atype auid
|
||||
, choreSchedule = mkSchedule sData
|
||||
, choreNotifyOnDue = nud /= 0
|
||||
, choreCreatedAt = createdAt
|
||||
}
|
||||
| (cid, hId, cname, atype, auid, sData, nud, createdAt) <- chores]
|
||||
where
|
||||
mkAssignee "user" (Just uid) = AssigneeUser (UserId uid)
|
||||
mkAssignee _ _ = AssigneeAnyone
|
||||
mkSchedule sData = fromMaybe ScheduleSometime (readMaybe (T.unpack sData))
|
||||
|
||||
CreateChore hid name assignee schedule notify -> liftIO $ do
|
||||
now <- Time.getCurrentTime
|
||||
let (aType, aUid) = case assignee of AssigneeUser (UserId uid) -> ("user" :: String, Just uid); AssigneeAnyone -> ("anyone", Nothing)
|
||||
sType = case schedule of ScheduleOneOff{} -> "one_off" :: String; ScheduleRecurring{} -> "recurring"; ScheduleSometime -> "sometime"
|
||||
sData = show schedule
|
||||
SQL.execute conn
|
||||
"INSERT INTO chores (household_id, name, assignee_type, assignee_user_id, schedule_type, schedule_data, notify_on_due, created_at) \
|
||||
\ VALUES (?,?,?,?,?,?,?,?)"
|
||||
(hid, name, aType, aUid, sType, sData, if notify then 1 :: Int else 0, now)
|
||||
cId <- SQL.lastInsertRowId conn
|
||||
let chore = Chore (ChoreId (fromIntegral cId)) (HouseholdId hid) name assignee schedule notify now
|
||||
generateOccurrencesIO conn chore
|
||||
pure chore
|
||||
|
||||
UpdateChore cid hid name assignee schedule notify -> liftIO $ do
|
||||
now <- Time.getCurrentTime
|
||||
let (aType, aUid) = case assignee of AssigneeUser (UserId uid) -> ("user" :: String, Just uid); AssigneeAnyone -> ("anyone", Nothing)
|
||||
sType = case schedule of ScheduleOneOff{} -> "one_off" :: String; ScheduleRecurring{} -> "recurring"; ScheduleSometime -> "sometime"
|
||||
sData = show schedule
|
||||
SQL.execute conn
|
||||
"UPDATE chores SET name=?, assignee_type=?, assignee_user_id=?, schedule_type=?, schedule_data=?, notify_on_due=? WHERE id=? AND household_id=?"
|
||||
(name, aType, aUid, sType, sData, if notify then 1 :: Int else 0, cid, hid)
|
||||
SQL.execute conn "DELETE FROM occurrences WHERE chore_id = ? AND status IN ('due', 'overdue')" (Only cid)
|
||||
let chore = Chore (ChoreId cid) (HouseholdId hid) name assignee schedule notify now
|
||||
generateOccurrencesIO conn chore
|
||||
pure chore
|
||||
|
||||
DeleteChore cid -> liftIO $ do
|
||||
SQL.execute conn "DELETE FROM chores WHERE id = ?" (Only cid)
|
||||
|
||||
GetDashboard hid today -> liftIO $ do
|
||||
let todayStr = show today
|
||||
let weekAgo = show (addDays (-7) today)
|
||||
[Only overdueCount] <- SQL.query conn
|
||||
"SELECT COUNT(*) FROM occurrences o JOIN chores c ON c.id = o.chore_id \
|
||||
\ WHERE c.household_id = ? AND o.due_date < ? AND o.status IN ('due', 'overdue')"
|
||||
(hid, todayStr)
|
||||
[Only dueTodayCount] <- SQL.query conn
|
||||
"SELECT COUNT(*) FROM occurrences o JOIN chores c ON c.id = o.chore_id \
|
||||
\ WHERE c.household_id = ? AND o.due_date = ? AND o.status = 'due'"
|
||||
(hid, todayStr)
|
||||
[Only doneThisWeek] <- SQL.query conn
|
||||
"SELECT COUNT(*) FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id \
|
||||
\ WHERE c.household_id = ? AND a.recorded_at >= ?"
|
||||
(hid, weekAgo)
|
||||
let stats = DashboardStats overdueCount dueTodayCount doneThisWeek
|
||||
dueRows <- SQL.query conn
|
||||
"SELECT o.id, o.chore_id, o.due_date, o.status, c.name, u.display_name \
|
||||
\ FROM occurrences o JOIN chores c ON c.id = o.chore_id LEFT JOIN users u ON u.id = c.assignee_user_id \
|
||||
\ WHERE c.household_id = ? AND o.due_date <= ? AND o.status IN ('due', 'overdue') ORDER BY o.due_date LIMIT 50"
|
||||
(hid, todayStr) :: IO [(Int, Int, Day, Text, Text, Maybe Text)]
|
||||
let dueItems = [DueItem (Occurrence (OccurrenceId oid) (ChoreId cid) d (mkOcc st)) cn uname (d < today) | (oid, cid, d, st, cn, uname) <- dueRows]
|
||||
compRows <- SQL.query conn
|
||||
"SELECT a.id, a.occurrence_id, a.user_id, a.status, a.note, a.notify_household, a.recorded_at, u.display_name, c.name \
|
||||
\ FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id JOIN users u ON u.id = a.user_id \
|
||||
\ WHERE c.household_id = ? AND a.recorded_at >= ? ORDER BY a.recorded_at DESC LIMIT 50"
|
||||
(hid, show today) :: IO [(Int, Int, Int, Text, Maybe Text, Int, UTCTime, Text, Text)]
|
||||
let compItems = [CompletedItem (Activity (ActivityId aid) (OccurrenceId oid) (UserId uid) (mkAct st) note (nh /= 0) recAt) uname cn | (aid, oid, uid, st, note, nh, recAt, uname, cn) <- compRows]
|
||||
pure $ Dashboard stats dueItems compItems
|
||||
where
|
||||
mkOcc "due" = OccDue; mkOcc "overdue" = OccOverdue; mkOcc _ = OccCompleted
|
||||
mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped
|
||||
|
||||
GenerateOccurrences chore -> liftIO $ generateOccurrencesIO conn chore
|
||||
|
||||
RecordActivity oid (UserId uid) status note notify -> liftIO $ do
|
||||
now <- Time.getCurrentTime
|
||||
let actStatus = case status of ActivityCompleted -> "completed" :: String; ActivitySkipped -> "skipped"
|
||||
SQL.execute conn
|
||||
"INSERT INTO activities (occurrence_id, user_id, status, note, notify_household, recorded_at) VALUES (?,?,?,?,?,?)"
|
||||
(oid, uid, actStatus, note, if notify then 1 :: Int else 0, now)
|
||||
let occStatus = case status of ActivityCompleted -> "completed" :: String; ActivitySkipped -> "skipped"
|
||||
SQL.execute conn "UPDATE occurrences SET status = ? WHERE id = ?" (occStatus, oid)
|
||||
actId <- SQL.lastInsertRowId conn
|
||||
pure $ Activity (ActivityId (fromIntegral actId)) (OccurrenceId oid) (UserId uid) status note notify now
|
||||
|
||||
GetActivityLog hid page perPage -> liftIO $ do
|
||||
let offset = (page - 1) * perPage
|
||||
[Only totalCount] <- SQL.query conn
|
||||
"SELECT COUNT(*) FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id WHERE c.household_id = ?"
|
||||
(Only hid)
|
||||
entries <- SQL.query conn
|
||||
"SELECT a.id, a.occurrence_id, a.user_id, a.status, a.note, a.notify_household, a.recorded_at, u.display_name, c.name, o.due_date \
|
||||
\ FROM activities a JOIN occurrences o ON o.id = a.occurrence_id JOIN chores c ON c.id = o.chore_id JOIN users u ON u.id = a.user_id \
|
||||
\ WHERE c.household_id = ? ORDER BY a.recorded_at DESC LIMIT ? OFFSET ?"
|
||||
(hid, perPage, offset) :: IO [(Int, Int, Int, Text, Maybe Text, Int, UTCTime, Text, Text, Day)]
|
||||
let logEntries = [ActivityLogEntry (Activity (ActivityId aid) (OccurrenceId oid) (UserId uid) (mkAct st) note (nh /= 0) recAt) uname "" cn d | (aid, oid, uid, st, note, nh, recAt, uname, cn, d) <- entries]
|
||||
pure $ ActivityLogPage logEntries page perPage totalCount
|
||||
where
|
||||
mkAct "completed" = ActivityCompleted; mkAct _ = ActivitySkipped
|
||||
|
||||
CreateInvite hid email -> liftIO $ do
|
||||
code <- generateTokenIO
|
||||
now <- Time.getCurrentTime
|
||||
SQL.execute conn
|
||||
"INSERT INTO invites (household_id, code, email, created_at) VALUES (?, ?, ?, ?)"
|
||||
(hid, code, email, now)
|
||||
iid <- SQL.lastInsertRowId conn
|
||||
pure $ Invite (InviteId (fromIntegral iid)) (HouseholdId hid) code email InvitePending now
|
||||
|
||||
GetInvites hid -> liftIO $ do
|
||||
invites <- SQL.query conn
|
||||
"SELECT id, household_id, code, email, status, created_at FROM invites WHERE household_id = ?"
|
||||
(Only hid) :: IO [(Int, Int, Text, Maybe Text, Text, UTCTime)]
|
||||
pure [Invite (InviteId iid) (HouseholdId hhid) code email (mkStatus st) createdAt | (iid, hhid, code, email, st, createdAt) <- invites]
|
||||
where
|
||||
mkStatus "pending" = InvitePending; mkStatus "accepted" = InviteAccepted; mkStatus _ = InviteRevoked
|
||||
|
||||
RevokeInvite iid -> liftIO $ do
|
||||
SQL.execute conn "UPDATE invites SET status = 'revoked' WHERE id = ?" (Only iid)
|
||||
|
||||
AcceptInvite (UserId uid) code -> liftIO $ do
|
||||
result <- SQL.query conn
|
||||
"SELECT id, household_id FROM invites WHERE code = ? AND status = 'pending'"
|
||||
(Only code) :: IO [(Int, Int)]
|
||||
case result of
|
||||
[(_, hid)] -> do
|
||||
SQL.execute conn
|
||||
"INSERT OR IGNORE INTO memberships (household_id, user_id, role) VALUES (?, ?, ?)"
|
||||
(hid, uid, "member" :: String)
|
||||
SQL.execute conn "UPDATE invites SET status = 'accepted' WHERE code = ?" (Only code)
|
||||
hResult <- SQL.query conn
|
||||
"SELECT h.id, h.name, m.user_id, (SELECT COUNT(*) FROM memberships WHERE household_id = h.id) \
|
||||
\ FROM households h JOIN memberships m ON m.household_id = h.id AND m.role = 'owner' WHERE h.id = ?"
|
||||
(Only hid) :: IO [(Int, Text, Int, Int)]
|
||||
case listToMaybe [Household (HouseholdId hId) hName (UserId ownerId) count | (hId, hName, ownerId, count) <- hResult] of
|
||||
Just h -> pure h
|
||||
Nothing -> error "Household not found after accept"
|
||||
_ -> error "Invite not found"
|
||||
|
||||
Seed -> liftIO $ do
|
||||
let demoPassword = "password123"
|
||||
pwHash <- hashPasswordIO 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 = show (ScheduleRecurring PeriodDaily (read "2026-07-15") (Just "08:00:00") Nothing Nothing :: Schedule)
|
||||
SQL.execute conn "INSERT OR IGNORE INTO chores (id, household_id, name, assignee_type, schedule_type, schedule_data, notify_on_due) VALUES (1, 1, 'Take out trash', 'anyone', 'recurring', ?, 1)" (Only sData1)
|
||||
let sData2 = show (ScheduleRecurring PeriodWeekly (read "2026-07-13") (Just "10:00:00") (Just [1, 4]) Nothing :: Schedule)
|
||||
SQL.execute conn "INSERT OR IGNORE INTO chores (id, household_id, name, assignee_type, assignee_user_id, schedule_type, schedule_data, notify_on_due) VALUES (2, 1, 'Vacuum living room', 'user', 2, 'recurring', ?, 0)" (Only sData2)
|
||||
let sData3 = show (ScheduleSometime :: Schedule)
|
||||
SQL.execute conn "INSERT OR IGNORE INTO chores (id, household_id, name, assignee_type, schedule_type, schedule_data, notify_on_due) VALUES (3, 1, 'Clean the garage', 'anyone', 'sometime', ?, 0)" (Only sData3)
|
||||
today <- utctDay <$> getCurrentTime
|
||||
let windowEnd = addDays 90 today
|
||||
let dates1 = take 90 $ generateRecurringDates PeriodDaily (read "2026-07-15") today windowEnd
|
||||
mapM_ (SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (1, ?)" . Only) dates1
|
||||
let dates2 = take 90 $ generateRecurringDates PeriodWeekly (read "2026-07-13") today windowEnd
|
||||
mapM_ (SQL.execute conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (2, ?)" . Only) dates2
|
||||
SQL.execute_ conn "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (3, '9999-12-31')"
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- Helpers
|
||||
----------------------------------------------------------------------
|
||||
|
||||
generateOccurrencesIO :: SQL.Connection -> Chore -> IO ()
|
||||
generateOccurrencesIO conn' chore = do
|
||||
today <- utctDay <$> getCurrentTime
|
||||
let windowEnd = addDays 90 today
|
||||
case choreSchedule chore of
|
||||
ScheduleOneOff date _ ->
|
||||
when (date >= today && date <= windowEnd) $
|
||||
SQL.execute conn' "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (?, ?)" (unChoreId (choreId chore), date)
|
||||
ScheduleRecurring period startDate _ _ _ -> do
|
||||
let dates = generateRecurringDates period startDate today windowEnd
|
||||
mapM_ (\d -> SQL.execute conn' "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (?, ?)" (unChoreId (choreId chore), d)) dates
|
||||
ScheduleSometime ->
|
||||
SQL.execute conn' "INSERT OR IGNORE INTO occurrences (chore_id, due_date) VALUES (?, '9999-12-31')" (Only (unChoreId (choreId chore)))
|
||||
|
||||
generateRecurringDates :: SchedulePeriod -> Day -> Day -> Day -> [Day]
|
||||
generateRecurringDates period startDate fromDate toDate = go (max startDate fromDate)
|
||||
where
|
||||
go d | d > toDate = [] | otherwise = d : go (next period d)
|
||||
next PeriodDaily = addDays 1; next PeriodWeekly = addDays 7; next PeriodMonthly = addGregorianMonthsClip 1
|
||||
|
||||
hashPasswordIO :: Text -> IO Text
|
||||
hashPasswordIO password = do
|
||||
-- Simple hashing stub — we'll use crypton via Auth.hs in the real implementation
|
||||
pure password
|
||||
|
||||
generateTokenIO :: IO Text
|
||||
generateTokenIO = do
|
||||
-- Simple token stub
|
||||
pure "dummy-token"
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- Database open helper
|
||||
----------------------------------------------------------------------
|
||||
|
||||
{- | Open (or create) a SQLite database at the given path.
|
||||
-}
|
||||
openDatabase :: FilePath -> IO SQL.Connection
|
||||
openDatabase path = do
|
||||
@@ -30,9 +364,9 @@ openDatabase path = do
|
||||
|
||||
-- | Create all tables if they don't exist.
|
||||
runMigrations :: SQL.Connection -> IO ()
|
||||
runMigrations conn =
|
||||
runMigrations conn' =
|
||||
mapM_
|
||||
(SQL.execute_ conn)
|
||||
(SQL.execute_ conn')
|
||||
[ "CREATE TABLE IF NOT EXISTS users (\
|
||||
\ id INTEGER PRIMARY KEY AUTOINCREMENT,\
|
||||
\ display_name TEXT NOT NULL,\
|
||||
@@ -94,3 +428,64 @@ runMigrations conn =
|
||||
\ expires_at TEXT NOT NULL,\
|
||||
\ created_at TEXT NOT NULL DEFAULT (datetime('now')))"
|
||||
]
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- Convenience wrappers (send through the DB effect)
|
||||
----------------------------------------------------------------------
|
||||
|
||||
findUserByEmail :: (DB :> es) => Text -> Eff es (Maybe User)
|
||||
findUserByEmail = send . FindUserByEmail
|
||||
|
||||
createUser :: (DB :> es) => Text -> Text -> Text -> Eff es UserId
|
||||
createUser d e p = send (CreateUser d e p)
|
||||
|
||||
getUser :: (DB :> es) => UserId -> Eff es (Maybe User)
|
||||
getUser = send . GetUser
|
||||
|
||||
getUserHouseholds :: (DB :> es) => UserId -> Eff es [Household]
|
||||
getUserHouseholds = send . GetUserHouseholds
|
||||
|
||||
getHousehold :: (DB :> es) => UserId -> Int -> Eff es (Maybe Household)
|
||||
getHousehold u = send . GetHousehold u
|
||||
|
||||
createHousehold :: (DB :> es) => UserId -> Text -> Eff es Household
|
||||
createHousehold u = send . CreateHousehold u
|
||||
|
||||
getMembers :: (DB :> es) => Int -> Eff es [Membership]
|
||||
getMembers = send . GetMembers
|
||||
|
||||
getChores :: (DB :> es) => Int -> Eff es [Chore]
|
||||
getChores = send . GetChores
|
||||
|
||||
createChore :: (DB :> es) => Int -> Text -> ChoreAssignee -> Schedule -> Bool -> Eff es Chore
|
||||
createChore h n a s b = send (CreateChore h n a s b)
|
||||
|
||||
updateChore :: (DB :> es) => Int -> Int -> Text -> ChoreAssignee -> Schedule -> Bool -> Eff es Chore
|
||||
updateChore c h n a s b = send (UpdateChore c h n a s b)
|
||||
|
||||
deleteChore :: (DB :> es) => Int -> Eff es ()
|
||||
deleteChore = send . DeleteChore
|
||||
|
||||
getDashboard :: (DB :> es) => Int -> Day -> Eff es Dashboard
|
||||
getDashboard h = send . GetDashboard h
|
||||
|
||||
recordActivity :: (DB :> es) => Int -> UserId -> ActivityStatus -> Maybe Text -> Bool -> Eff es Activity
|
||||
recordActivity o u s n b = send (RecordActivity o u s n b)
|
||||
|
||||
getActivityLog :: (DB :> es) => Int -> Int -> Int -> Eff es ActivityLogPage
|
||||
getActivityLog h p pp = send (GetActivityLog h p pp)
|
||||
|
||||
createInvite :: (DB :> es) => Int -> Maybe Text -> Eff es Invite
|
||||
createInvite h = send . CreateInvite h
|
||||
|
||||
getInvites :: (DB :> es) => Int -> Eff es [Invite]
|
||||
getInvites = send . GetInvites
|
||||
|
||||
revokeInvite :: (DB :> es) => Int -> Eff es ()
|
||||
revokeInvite = send . RevokeInvite
|
||||
|
||||
acceptInvite :: (DB :> es) => UserId -> Text -> Eff es Household
|
||||
acceptInvite u = send . AcceptInvite u
|
||||
|
||||
seed :: (DB :> es) => Eff es ()
|
||||
seed = send Seed
|
||||
|
||||
Reference in New Issue
Block a user