jbrechtel/sis
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix: add static file serving with custom middleware

Browse Source 
- Replaced wai-app-static with lightweight inline static file server
- Static files served from frontend/static/ under /static/ path
- Fixed ByteString/FilePath type mismatches for GHC 9.10
- Verified: CSS, manifest, login, signup, dashboard all HTTP 200
This commit is contained in:
James Brechtel
2026-07-16 07:00:41 -04:00
parent df9ad3d7c4
commit a99c239852
10 changed files with 290 additions and 165 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Sis/Database.hs
+165 -135
View File
@@ -5,36 +5,35 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{- | SQLite database support for Sis using the effectful effect system.
-}
module Sis.Database
( -- * Effect
DB (..)
, runDB
, openDatabase
, runMigrations
-- | SQLite database support for Sis using the effectful effect system.
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
-- * 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)
@@ -43,13 +42,13 @@ 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 Database.SQLite.Simple qualified as SQL
import Effectful
import Effectful.Dispatch.Dynamic
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)
import Text.Read (readMaybe)
import Sis.Types
@@ -88,83 +87,96 @@ type instance DispatchOf DB = 'Dynamic
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)
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
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)
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)
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)
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
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]
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]
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
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)
@@ -172,123 +184,142 @@ runDB conn = interpret $ \_ -> \case
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
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)
[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)]
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)]
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
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)]
[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
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)]
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)]
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
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)]
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
@@ -351,8 +382,7 @@ generateTokenIO = do
-- Database open helper
----------------------------------------------------------------------
{- | Open (or create) a SQLite database at the given path.
-}
-- | Open (or create) a SQLite database at the given path.
openDatabase :: FilePath -> IO SQL.Connection
openDatabase path = do
createDirectoryIfMissing True (takeDirectory path)