From d4f839c491944dba10effdddac1ea4d71757670e Mon Sep 17 00:00:00 2001 From: James Brechtel Date: Wed, 15 Jul 2026 15:57:44 -0400 Subject: [PATCH] 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 --- FEATURES.org | 45 +++++++++++ app/Main.hs | 96 +++++++++++----------- sis-server.cabal | 1 + src/Sis/Database.hs | 12 ++- src/Sis/Server.hs | 192 ++++++++++++++++++++++---------------------- 5 files changed, 199 insertions(+), 147 deletions(-) create mode 100644 FEATURES.org diff --git a/FEATURES.org b/FEATURES.org new file mode 100644 index 0000000..ed2ae17 --- /dev/null +++ b/FEATURES.org @@ -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 - " 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 diff --git a/app/Main.hs b/app/Main.hs index 29c709f..d4b560f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -14,62 +14,62 @@ import Sis.Database qualified as Database import Sis.Server qualified as Sis data Options = Options - { optPort :: Int - , optStaticDir :: FilePath - , optDbPath :: FilePath - } + { optPort :: Int + , optStaticDir :: FilePath + , optDbPath :: FilePath + } optionsParser :: Opt.Parser Options optionsParser = - Options - <$> Opt.option - Opt.auto - ( Opt.long "port" - <> Opt.short 'p' - <> Opt.metavar "PORT" - <> Opt.help "Listen port" - <> Opt.value 8080 - <> Opt.showDefault - ) - <*> Opt.strOption - ( Opt.long "static-dir" - <> Opt.metavar "DIR" - <> Opt.help "Directory containing the SPA frontend static files" - <> Opt.value "frontend/dist" - <> Opt.showDefault - ) - <*> Opt.strOption - ( Opt.long "db-path" - <> Opt.metavar "PATH" - <> Opt.help "Path to the SQLite database file" - <> Opt.value "data/sis.db" - <> Opt.showDefault - ) + Options + <$> Opt.option + Opt.auto + ( Opt.long "port" + <> Opt.short 'p' + <> Opt.metavar "PORT" + <> Opt.help "Listen port" + <> Opt.value 8080 + <> Opt.showDefault + ) + <*> Opt.strOption + ( Opt.long "static-dir" + <> Opt.metavar "DIR" + <> Opt.help "Directory containing the SPA frontend static files" + <> Opt.value "frontend/dist" + <> Opt.showDefault + ) + <*> Opt.strOption + ( Opt.long "db-path" + <> Opt.metavar "PATH" + <> Opt.help "Path to the SQLite database file" + <> Opt.value "data/sis.db" + <> Opt.showDefault + ) main :: IO () main = do - opts <- - Opt.execParser $ - Opt.info (optionsParser Opt.<**> Opt.helper) $ - Opt.fullDesc - <> Opt.progDesc "Sis — shared household chore tracker" - <> Opt.header "sis-server" + opts <- + Opt.execParser $ + Opt.info (optionsParser Opt.<**> Opt.helper) $ + Opt.fullDesc + <> Opt.progDesc "Sis — shared household chore tracker" + <> Opt.header "sis-server" - _db <- Database.openDatabase (optDbPath opts) + _db <- Database.openDatabase (optDbPath opts) - -- Install a SIGTERM handler so Docker stop works cleanly. - _ <- - Signals.installHandler - Signals.sigTERM - (Signals.Catch (putStrLn "[sis] shutting down")) - Nothing + -- Install a SIGTERM handler so Docker stop works cleanly. + _ <- + Signals.installHandler + Signals.sigTERM + (Signals.Catch (putStrLn "[sis] shutting down")) + Nothing - let waiApp = Sis.app (optStaticDir opts) + let waiApp = Sis.app (optStaticDir opts) - let settings = - Warp.setPort (optPort opts) $ - Warp.setBeforeMainLoop - (putStrLn $ "[sis] listening on port " ++ show (optPort opts)) - Warp.defaultSettings + let settings = + Warp.setPort (optPort opts) $ + Warp.setBeforeMainLoop + (putStrLn $ "[sis] listening on port " ++ show (optPort opts)) + Warp.defaultSettings - Warp.runSettings settings waiApp + Warp.runSettings settings waiApp diff --git a/sis-server.cabal b/sis-server.cabal index 5e84313..28bcd19 100644 --- a/sis-server.cabal +++ b/sis-server.cabal @@ -17,6 +17,7 @@ build-type: Simple library exposed-modules: Sis + Sis.Database Sis.Server Sis.Types other-modules: diff --git a/src/Sis/Database.hs b/src/Sis/Database.hs index 9b948e3..b01c7f7 100644 --- a/src/Sis/Database.hs +++ b/src/Sis/Database.hs @@ -8,13 +8,17 @@ module Sis.Database ( ) where 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. --- --- Enables WAL journal mode for concurrent read performance and --- enables foreign key enforcement. +{- | Open (or create) a SQLite database at the given path. + +Enables WAL journal mode for concurrent read performance and +enables foreign key enforcement. +-} openDatabase :: FilePath -> IO SQL.Connection openDatabase path = do + createDirectoryIfMissing True (takeDirectory path) conn <- SQL.open path SQL.execute_ conn "PRAGMA journal_mode=WAL" SQL.execute_ conn "PRAGMA foreign_keys=ON" diff --git a/src/Sis/Server.hs b/src/Sis/Server.hs index e32eb19..5023462 100644 --- a/src/Sis/Server.hs +++ b/src/Sis/Server.hs @@ -9,11 +9,11 @@ Defines the API routes and wires them into a WAI 'Wai.Application'. Serves the Mithril SPA frontend from a static directory for all non-API routes, with SPA-routing fallback to @index.html@. -} -module Sis.Server - ( app - , sisRouter - , HealthCheck (..) - ) where +module Sis.Server ( + app, + sisRouter, + HealthCheck (..), +) where import Beeline.Routing ((/-), (/:)) import Beeline.Routing qualified as R @@ -22,49 +22,50 @@ import Control.Monad.IO.Class qualified as MIO import Control.Monad.Reader qualified as Reader import Data.ByteString qualified as BS import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Text.Encoding qualified as TE import Data.Void (Void, absurd) import Network.HTTP.Types qualified as HTTP import Network.Wai qualified as Wai import Shrubbery qualified as S -import System.FilePath (()) import System.Directory (doesFileExist) +import System.FilePath (()) import Orb qualified -- | The top-level WAI application, serving both the API and the SPA frontend. app :: FilePath -> Wai.Application app staticDir = - Orb.orbAppToWai sisOrbApp{Orb.handleNotFound = serveStaticOrSpa staticDir} + Orb.orbAppToWai sisOrbApp{Orb.handleNotFound = serveStaticOrSpa staticDir} -- | Full Orb application wiring routes to a WAI dispatcher. sisOrbApp :: Orb.OrbApp (S.Union Routes) sisOrbApp = - Orb.OrbApp - { Orb.router = sisRouter - , Orb.dispatcher = sisDispatcher - , Orb.handleNotFound = Orb.defaultHandleNotFound -- overridden in 'app' - } + Orb.OrbApp + { Orb.router = sisRouter + , Orb.dispatcher = sisDispatcher + , Orb.handleNotFound = Orb.defaultHandleNotFound -- overridden in 'app' + } -- | The route recognizer for all sis routes. sisRouter :: R.RouteRecognizer (S.Union Routes) sisRouter = - R.routeList $ - Orb.get (R.make HealthCheck /- "api" /- "health") - /: R.emptyRoutes + R.routeList $ + Orb.get (R.make HealthCheck /- "api" /- "health") + /: R.emptyRoutes -- | Dispatch a recognized route to its handler via the 'SisDispatchM' monad. sisDispatcher :: S.Union Routes -> Wai.Application sisDispatcher route request respond = do - let env = SisDispatchEnv request respond - let SisDispatchM action = Orb.dispatch route - Reader.runReaderT action env + let env = SisDispatchEnv request respond + let SisDispatchM action = Orb.dispatch route + Reader.runReaderT action env -- | The union of all route types in the application. type Routes = - '[ HealthCheck - ] + '[ HealthCheck + ] -- Static file + SPA fallback @@ -73,21 +74,21 @@ mimeType :: FilePath -> Maybe BS.ByteString mimeType path = Map.lookup (takeExtensionLower path) mimeTypes where takeExtensionLower p = - let ext = reverse $ takeWhile (/= '.') $ reverse p - in T.toLower $ T.pack ext + let ext = reverse $ takeWhile (/= '.') $ reverse p + in T.toLower $ T.pack ext 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") - , ("svg", "image/svg+xml") - , ("ico", "image/x-icon") - , ("woff2", "font/woff2") - ] + Map.fromList + [ ("html", "text/html") + , ("css", "text/css") + , ("js", "application/javascript") + , ("json", "application/json") + , ("png", "image/png") + , ("svg", "image/svg+xml") + , ("ico", "image/x-icon") + , ("woff2", "font/woff2") + ] {- | Serve a static file from @staticDir@. @@ -98,22 +99,23 @@ Returns 'True' if a file was served, 'False' if nothing matched. -} serveStaticOrSpa :: FilePath -> Wai.Application serveStaticOrSpa staticDir request respond = do - let path = T.unpack $ TE.decodeUtf8 $ Wai.rawPathInfo request - -- Drop leading slash for filesystem lookup. - let relPath = case path of - '/' : rest -> rest - other -> other - let candidate = if null relPath || not (hasExtension relPath) - then "index.html" - else relPath - let filePath = staticDir candidate - exists <- doesFileExist filePath - if exists - then do - let mime = maybe "application/octet-stream" id (mimeType candidate) - respond $ Wai.responseFile HTTP.status200 [("Content-Type", mime)] filePath Nothing - else - respond notFoundResponse + let path = T.unpack $ TE.decodeUtf8 $ Wai.rawPathInfo request + -- Drop leading slash for filesystem lookup. + let relPath = case path of + '/' : rest -> rest + other -> other + let candidate = + if null relPath || not (hasExtension relPath) + then "index.html" + else relPath + let filePath = staticDir candidate + exists <- doesFileExist filePath + if exists + then do + let mime = fromMaybe "application/octet-stream" (mimeType candidate) + respond $ Wai.responseFile HTTP.status200 [("Content-Type", mime)] filePath Nothing + else + respond notFoundResponse hasExtension :: FilePath -> Bool hasExtension = elem '.' . takeFileName @@ -123,34 +125,34 @@ takeFileName = reverse . takeWhile (/= '/') . reverse notFoundResponse :: Wai.Response notFoundResponse = - Wai.responseLBS HTTP.status404 [("Content-Type", "text/plain")] "Not Found" + Wai.responseLBS HTTP.status404 [("Content-Type", "text/plain")] "Not Found" -- Internal WAI dispatch monad data SisDispatchEnv = SisDispatchEnv - { sisRequest :: Wai.Request - , sisRespond :: Wai.Response -> IO Wai.ResponseReceived - } + { sisRequest :: Wai.Request + , sisRespond :: Wai.Response -> IO Wai.ResponseReceived + } newtype SisDispatchM a - = SisDispatchM (Reader.ReaderT SisDispatchEnv IO a) - deriving - ( Functor - , Applicative - , Monad - , MIO.MonadIO - , Safe.MonadThrow - , Safe.MonadCatch - ) + = SisDispatchM (Reader.ReaderT SisDispatchEnv IO a) + deriving + ( Functor + , Applicative + , Monad + , MIO.MonadIO + , Safe.MonadThrow + , Safe.MonadCatch + ) instance Orb.HasRequest SisDispatchM where - request = SisDispatchM (Reader.asks sisRequest) + request = SisDispatchM (Reader.asks sisRequest) instance Orb.HasRespond SisDispatchM where - respond = SisDispatchM (Reader.asks sisRespond) + respond = SisDispatchM (Reader.asks sisRespond) instance Orb.HasLogger SisDispatchM where - log = MIO.liftIO . putStrLn . Safe.displayException + log = MIO.liftIO . putStrLn . Safe.displayException -- Health check route @@ -161,52 +163,52 @@ Returns a simple health-check response. data HealthCheck = HealthCheck instance Orb.HasHandler HealthCheck where - type HandlerResponses HealthCheck = HealthCheckResponses - type HandlerPermissionAction HealthCheck = NoPermissions - type HandlerMonad HealthCheck = SisDispatchM + type HandlerResponses HealthCheck = HealthCheckResponses + type HandlerPermissionAction HealthCheck = NoPermissions + type HandlerMonad HealthCheck = SisDispatchM - routeHandler = healthCheckHandler + routeHandler = healthCheckHandler type HealthCheckResponses = - '[ Orb.Response200 Orb.SuccessMessage - , Orb.Response500 Orb.InternalServerError - ] + '[ Orb.Response200 Orb.SuccessMessage + , Orb.Response500 Orb.InternalServerError + ] healthCheckHandler :: Orb.Handler HealthCheck healthCheckHandler = - Orb.Handler - { Orb.handlerId = "healthCheck" - , Orb.requestBody = Orb.EmptyRequestBody - , Orb.requestQuery = Orb.EmptyRequestQuery - , Orb.requestHeaders = Orb.EmptyRequestHeaders - , Orb.handlerResponseBodies = - Orb.responseBodies - . Orb.addResponseSchema200 Orb.successMessageSchema - . Orb.addResponseSchema500 Orb.internalServerErrorSchema - $ Orb.noResponseBodies - , Orb.mkPermissionAction = - \_request -> NoPermissions - , Orb.handleRequest = - \_request () -> Orb.return200 (Orb.SuccessMessage "ok") - } + Orb.Handler + { Orb.handlerId = "healthCheck" + , Orb.requestBody = Orb.EmptyRequestBody + , Orb.requestQuery = Orb.EmptyRequestQuery + , Orb.requestHeaders = Orb.EmptyRequestHeaders + , Orb.handlerResponseBodies = + Orb.responseBodies + . Orb.addResponseSchema200 Orb.successMessageSchema + . Orb.addResponseSchema500 Orb.internalServerErrorSchema + $ Orb.noResponseBodies + , Orb.mkPermissionAction = + const NoPermissions + , Orb.handleRequest = + \_request () -> Orb.return200 (Orb.SuccessMessage "ok") + } -- NoPermissions — all routes are public for now. data NoPermissions = NoPermissions instance Orb.PermissionAction NoPermissions where - type PermissionActionMonad NoPermissions = SisDispatchM - type PermissionActionError NoPermissions = NoError - type PermissionActionResult NoPermissions = () + type PermissionActionMonad NoPermissions = SisDispatchM + type PermissionActionError NoPermissions = NoError + type PermissionActionResult NoPermissions = () - checkPermissionAction _ = - pure (Right ()) + checkPermissionAction _ = + pure (Right ()) newtype NoError = NoError Void instance Orb.PermissionError NoError where - type PermissionErrorConstraints NoError _tags = () - type PermissionErrorMonad NoError = SisDispatchM + type PermissionErrorConstraints NoError _tags = () + type PermissionErrorMonad NoError = SisDispatchM - returnPermissionError (NoError v) = - absurd v + returnPermissionError (NoError v) = + absurd v