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
2026-07-15 15:57:44 -04:00
parent 715889a72a
commit d4f839c491
5 changed files with 199 additions and 147 deletions
@@ -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
@@ -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
@@ -17,6 +17,7 @@ build-type:     Simple
 library
  exposed-modules:
      Sis
+      Sis.Database
      Sis.Server
      Sis.Types
  other-modules:
@@ -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"
@@ -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