feat: add SQLite database support

- Add sqlite-simple dependency
- Create Sis.Database module with openDatabase (creates parent dir, enables WAL + FK)
- Add --db-path CLI option (default data/sis.db)
- Format all Haskell sources with fourmolu
- Fix hlint suggestions in Sis.Server
This commit is contained in:
2026-07-15 15:57:44 -04:00
parent 715889a72a
commit d4f839c491
5 changed files with 199 additions and 147 deletions
+45
View File
@@ -0,0 +1,45 @@
* TODO SQLite database support
Let's add database support using sqlite-simple . On startup we should
create a SQLite database if none exists. Right now we have no tables,
but we'll add one in the next task.
* TODO User signup and login
User signup should be basic sign-up. Ask the user their full name,
email and password. We'll send them a verification email to confirm
their email address and at that point ask for their password. We
should use standard encryption approaches for storing their hashed
password with the https://hackage.haskell.org/package/password
library.
We should support allowing users to log in and show them a basic
welcome page with "Welcome <full name> - <household>" and nothing else once they
sign in.
Otherwise, logged out users should be shown a sign-in form with a link to a separate sign-up form.
Logged in users should see a log out button, too.
We should create a rudimentary session infrastructure. Ensure we use http-only cookies for our session token.
** Households
When a user signs up, as part of sign-up we should ask them for the
name of their Household. All users will belong a single Household and
a Household may have more than one user.
The Household will ultimately be where tasks/chores are stored.
* TODO User invite
An existing user should be able to invite a new user by email to their household.
When the invited user signs up we should not ask them for a Household name but instead make them a member of the Household they were invited to.
* TODO Basic chores
We should create a new table to store chores in the database. Each chore belongs to a household, has a name and an optional assigned-to user.
We should allow users to create a new chore and view their existing chores.
When creating a chore we should ask users for the chore name and an optional user to assign to that chore.
* TODO Chore schedules
TBD
+1
View File
@@ -17,6 +17,7 @@ build-type: Simple
library library
exposed-modules: exposed-modules:
Sis Sis
Sis.Database
Sis.Server Sis.Server
Sis.Types Sis.Types
other-modules: other-modules:
+8 -4
View File
@@ -8,13 +8,17 @@ module Sis.Database (
) where ) where
import Database.SQLite.Simple qualified as SQL import Database.SQLite.Simple qualified as SQL
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory)
-- | Open (or create) a SQLite database at the given path. {- | Open (or create) a SQLite database at the given path.
--
-- Enables WAL journal mode for concurrent read performance and Enables WAL journal mode for concurrent read performance and
-- enables foreign key enforcement. enables foreign key enforcement.
-}
openDatabase :: FilePath -> IO SQL.Connection openDatabase :: FilePath -> IO SQL.Connection
openDatabase path = do openDatabase path = do
createDirectoryIfMissing True (takeDirectory path)
conn <- SQL.open path conn <- SQL.open path
SQL.execute_ conn "PRAGMA journal_mode=WAL" SQL.execute_ conn "PRAGMA journal_mode=WAL"
SQL.execute_ conn "PRAGMA foreign_keys=ON" SQL.execute_ conn "PRAGMA foreign_keys=ON"
+10 -8
View File
@@ -9,10 +9,10 @@ Defines the API routes and wires them into a WAI 'Wai.Application'.
Serves the Mithril SPA frontend from a static directory for all Serves the Mithril SPA frontend from a static directory for all
non-API routes, with SPA-routing fallback to @index.html@. non-API routes, with SPA-routing fallback to @index.html@.
-} -}
module Sis.Server module Sis.Server (
( app app,
, sisRouter sisRouter,
, HealthCheck (..) HealthCheck (..),
) where ) where
import Beeline.Routing ((/-), (/:)) import Beeline.Routing ((/-), (/:))
@@ -22,14 +22,15 @@ import Control.Monad.IO.Class qualified as MIO
import Control.Monad.Reader qualified as Reader import Control.Monad.Reader qualified as Reader
import Data.ByteString qualified as BS import Data.ByteString qualified as BS
import Data.Map.Strict qualified as Map import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe)
import Data.Text qualified as T import Data.Text qualified as T
import Data.Text.Encoding qualified as TE import Data.Text.Encoding qualified as TE
import Data.Void (Void, absurd) import Data.Void (Void, absurd)
import Network.HTTP.Types qualified as HTTP import Network.HTTP.Types qualified as HTTP
import Network.Wai qualified as Wai import Network.Wai qualified as Wai
import Shrubbery qualified as S import Shrubbery qualified as S
import System.FilePath ((</>))
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import System.FilePath ((</>))
import Orb qualified import Orb qualified
@@ -103,14 +104,15 @@ serveStaticOrSpa staticDir request respond = do
let relPath = case path of let relPath = case path of
'/' : rest -> rest '/' : rest -> rest
other -> other other -> other
let candidate = if null relPath || not (hasExtension relPath) let candidate =
if null relPath || not (hasExtension relPath)
then "index.html" then "index.html"
else relPath else relPath
let filePath = staticDir </> candidate let filePath = staticDir </> candidate
exists <- doesFileExist filePath exists <- doesFileExist filePath
if exists if exists
then do then do
let mime = maybe "application/octet-stream" id (mimeType candidate) let mime = fromMaybe "application/octet-stream" (mimeType candidate)
respond $ Wai.responseFile HTTP.status200 [("Content-Type", mime)] filePath Nothing respond $ Wai.responseFile HTTP.status200 [("Content-Type", mime)] filePath Nothing
else else
respond notFoundResponse respond notFoundResponse
@@ -185,7 +187,7 @@ healthCheckHandler =
. Orb.addResponseSchema500 Orb.internalServerErrorSchema . Orb.addResponseSchema500 Orb.internalServerErrorSchema
$ Orb.noResponseBodies $ Orb.noResponseBodies
, Orb.mkPermissionAction = , Orb.mkPermissionAction =
\_request -> NoPermissions const NoPermissions
, Orb.handleRequest = , Orb.handleRequest =
\_request () -> Orb.return200 (Orb.SuccessMessage "ok") \_request () -> Orb.return200 (Orb.SuccessMessage "ok")
} }