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

feat: add SQLite database support

Browse Source 
- 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:
James Brechtel
2026-07-15 15:57:44 -04:00
parent 715889a72a
commit d4f839c491
5 changed files with 199 additions and 147 deletions
Download Patch File Download Diff File Expand all files Collapse all files
FEATURES.org
+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
app/Main.hs
+48 -48
View File
@@ -14,62 +14,62 @@ import Sis.Database qualified as Database
import Sis.Server qualified as Sis import Sis.Server qualified as Sis
data Options = Options data Options = Options
{ optPort :: Int { optPort :: Int
, optStaticDir :: FilePath , optStaticDir :: FilePath
, optDbPath :: FilePath , optDbPath :: FilePath
} }
optionsParser :: Opt.Parser Options optionsParser :: Opt.Parser Options
optionsParser = optionsParser =
Options Options
<$> Opt.option <$> Opt.option
Opt.auto Opt.auto
( Opt.long "port" ( Opt.long "port"
<> Opt.short 'p' <> Opt.short 'p'
<> Opt.metavar "PORT" <> Opt.metavar "PORT"
<> Opt.help "Listen port" <> Opt.help "Listen port"
<> Opt.value 8080 <> Opt.value 8080
<> Opt.showDefault <> Opt.showDefault
) )
<*> Opt.strOption <*> Opt.strOption
( Opt.long "static-dir" ( Opt.long "static-dir"
<> Opt.metavar "DIR" <> Opt.metavar "DIR"
<> Opt.help "Directory containing the SPA frontend static files" <> Opt.help "Directory containing the SPA frontend static files"
<> Opt.value "frontend/dist" <> Opt.value "frontend/dist"
<> Opt.showDefault <> Opt.showDefault
) )
<*> Opt.strOption <*> Opt.strOption
( Opt.long "db-path" ( Opt.long "db-path"
<> Opt.metavar "PATH" <> Opt.metavar "PATH"
<> Opt.help "Path to the SQLite database file" <> Opt.help "Path to the SQLite database file"
<> Opt.value "data/sis.db" <> Opt.value "data/sis.db"
<> Opt.showDefault <> Opt.showDefault
) )
main :: IO () main :: IO ()
main = do main = do
opts <- opts <-
Opt.execParser $ Opt.execParser $
Opt.info (optionsParser Opt.<**> Opt.helper) $ Opt.info (optionsParser Opt.<**> Opt.helper) $
Opt.fullDesc Opt.fullDesc
<> Opt.progDesc "Sis — shared household chore tracker" <> Opt.progDesc "Sis — shared household chore tracker"
<> Opt.header "sis-server" <> Opt.header "sis-server"
_db <- Database.openDatabase (optDbPath opts) _db <- Database.openDatabase (optDbPath opts)
-- Install a SIGTERM handler so Docker stop works cleanly. -- Install a SIGTERM handler so Docker stop works cleanly.
_ <- _ <-
Signals.installHandler Signals.installHandler
Signals.sigTERM Signals.sigTERM
(Signals.Catch (putStrLn "[sis] shutting down")) (Signals.Catch (putStrLn "[sis] shutting down"))
Nothing Nothing
let waiApp = Sis.app (optStaticDir opts) let waiApp = Sis.app (optStaticDir opts)
let settings = let settings =
Warp.setPort (optPort opts) $ Warp.setPort (optPort opts) $
Warp.setBeforeMainLoop Warp.setBeforeMainLoop
(putStrLn $ "[sis] listening on port " ++ show (optPort opts)) (putStrLn $ "[sis] listening on port " ++ show (optPort opts))
Warp.defaultSettings Warp.defaultSettings
Warp.runSettings settings waiApp Warp.runSettings settings waiApp
sis-server.cabal
+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:
src/Sis/Database.hs
+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"
src/Sis/Server.hs
+97 -95
View File
@@ -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 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 ((/-), (/:))
import Beeline.Routing qualified as R 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 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
-- | The top-level WAI application, serving both the API and the SPA frontend. -- | The top-level WAI application, serving both the API and the SPA frontend.
app :: FilePath -> Wai.Application app :: FilePath -> Wai.Application
app staticDir = 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. -- | Full Orb application wiring routes to a WAI dispatcher.
sisOrbApp :: Orb.OrbApp (S.Union Routes) sisOrbApp :: Orb.OrbApp (S.Union Routes)
sisOrbApp = sisOrbApp =
Orb.OrbApp Orb.OrbApp
{ Orb.router = sisRouter { Orb.router = sisRouter
, Orb.dispatcher = sisDispatcher , Orb.dispatcher = sisDispatcher
, Orb.handleNotFound = Orb.defaultHandleNotFound -- overridden in 'app' , Orb.handleNotFound = Orb.defaultHandleNotFound -- overridden in 'app'
} }
-- | The route recognizer for all sis routes. -- | The route recognizer for all sis routes.
sisRouter :: R.RouteRecognizer (S.Union Routes) sisRouter :: R.RouteRecognizer (S.Union Routes)
sisRouter = sisRouter =
R.routeList $ R.routeList $
Orb.get (R.make HealthCheck /- "api" /- "health") Orb.get (R.make HealthCheck /- "api" /- "health")
/: R.emptyRoutes /: R.emptyRoutes
-- | Dispatch a recognized route to its handler via the 'SisDispatchM' monad. -- | Dispatch a recognized route to its handler via the 'SisDispatchM' monad.
sisDispatcher :: S.Union Routes -> Wai.Application sisDispatcher :: S.Union Routes -> Wai.Application
sisDispatcher route request respond = do sisDispatcher route request respond = do
let env = SisDispatchEnv request respond let env = SisDispatchEnv request respond
let SisDispatchM action = Orb.dispatch route let SisDispatchM action = Orb.dispatch route
Reader.runReaderT action env Reader.runReaderT action env
-- | The union of all route types in the application. -- | The union of all route types in the application.
type Routes = type Routes =
'[ HealthCheck '[ HealthCheck
] ]
-- Static file + SPA fallback -- Static file + SPA fallback
@@ -73,21 +74,21 @@ mimeType :: FilePath -> Maybe BS.ByteString
mimeType path = Map.lookup (takeExtensionLower path) mimeTypes mimeType path = Map.lookup (takeExtensionLower path) mimeTypes
where where
takeExtensionLower p = takeExtensionLower p =
let ext = reverse $ takeWhile (/= '.') $ reverse p let ext = reverse $ takeWhile (/= '.') $ reverse p
in T.toLower $ T.pack ext in T.toLower $ T.pack ext
mimeTypes :: Map.Map T.Text BS.ByteString mimeTypes :: Map.Map T.Text BS.ByteString
mimeTypes = mimeTypes =
Map.fromList Map.fromList
[ ("html", "text/html") [ ("html", "text/html")
, ("css", "text/css") , ("css", "text/css")
, ("js", "application/javascript") , ("js", "application/javascript")
, ("json", "application/json") , ("json", "application/json")
, ("png", "image/png") , ("png", "image/png")
, ("svg", "image/svg+xml") , ("svg", "image/svg+xml")
, ("ico", "image/x-icon") , ("ico", "image/x-icon")
, ("woff2", "font/woff2") , ("woff2", "font/woff2")
] ]
{- | Serve a static file from @staticDir@. {- | 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 :: FilePath -> Wai.Application
serveStaticOrSpa staticDir request respond = do serveStaticOrSpa staticDir request respond = do
let path = T.unpack $ TE.decodeUtf8 $ Wai.rawPathInfo request let path = T.unpack $ TE.decodeUtf8 $ Wai.rawPathInfo request
-- Drop leading slash for filesystem lookup. -- Drop leading slash for filesystem lookup.
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 =
then "index.html" if null relPath || not (hasExtension relPath)
else relPath then "index.html"
let filePath = staticDir </> candidate else relPath
exists <- doesFileExist filePath let filePath = staticDir </> candidate
if exists exists <- doesFileExist filePath
then do if exists
let mime = maybe "application/octet-stream" id (mimeType candidate) then do
respond $ Wai.responseFile HTTP.status200 [("Content-Type", mime)] filePath Nothing let mime = fromMaybe "application/octet-stream" (mimeType candidate)
else respond $ Wai.responseFile HTTP.status200 [("Content-Type", mime)] filePath Nothing
respond notFoundResponse else
respond notFoundResponse
hasExtension :: FilePath -> Bool hasExtension :: FilePath -> Bool
hasExtension = elem '.' . takeFileName hasExtension = elem '.' . takeFileName
@@ -123,34 +125,34 @@ takeFileName = reverse . takeWhile (/= '/') . reverse
notFoundResponse :: Wai.Response notFoundResponse :: Wai.Response
notFoundResponse = 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 -- Internal WAI dispatch monad
data SisDispatchEnv = SisDispatchEnv data SisDispatchEnv = SisDispatchEnv
{ sisRequest :: Wai.Request { sisRequest :: Wai.Request
, sisRespond :: Wai.Response -> IO Wai.ResponseReceived , sisRespond :: Wai.Response -> IO Wai.ResponseReceived
} }
newtype SisDispatchM a newtype SisDispatchM a
= SisDispatchM (Reader.ReaderT SisDispatchEnv IO a) = SisDispatchM (Reader.ReaderT SisDispatchEnv IO a)
deriving deriving
( Functor ( Functor
, Applicative , Applicative
, Monad , Monad
, MIO.MonadIO , MIO.MonadIO
, Safe.MonadThrow , Safe.MonadThrow
, Safe.MonadCatch , Safe.MonadCatch
) )
instance Orb.HasRequest SisDispatchM where instance Orb.HasRequest SisDispatchM where
request = SisDispatchM (Reader.asks sisRequest) request = SisDispatchM (Reader.asks sisRequest)
instance Orb.HasRespond SisDispatchM where instance Orb.HasRespond SisDispatchM where
respond = SisDispatchM (Reader.asks sisRespond) respond = SisDispatchM (Reader.asks sisRespond)
instance Orb.HasLogger SisDispatchM where instance Orb.HasLogger SisDispatchM where
log = MIO.liftIO . putStrLn . Safe.displayException log = MIO.liftIO . putStrLn . Safe.displayException
-- Health check route -- Health check route
@@ -161,52 +163,52 @@ Returns a simple health-check response.
data HealthCheck = HealthCheck data HealthCheck = HealthCheck
instance Orb.HasHandler HealthCheck where instance Orb.HasHandler HealthCheck where
type HandlerResponses HealthCheck = HealthCheckResponses type HandlerResponses HealthCheck = HealthCheckResponses
type HandlerPermissionAction HealthCheck = NoPermissions type HandlerPermissionAction HealthCheck = NoPermissions
type HandlerMonad HealthCheck = SisDispatchM type HandlerMonad HealthCheck = SisDispatchM
routeHandler = healthCheckHandler routeHandler = healthCheckHandler
type HealthCheckResponses = type HealthCheckResponses =
'[ Orb.Response200 Orb.SuccessMessage '[ Orb.Response200 Orb.SuccessMessage
, Orb.Response500 Orb.InternalServerError , Orb.Response500 Orb.InternalServerError
] ]
healthCheckHandler :: Orb.Handler HealthCheck healthCheckHandler :: Orb.Handler HealthCheck
healthCheckHandler = healthCheckHandler =
Orb.Handler Orb.Handler
{ Orb.handlerId = "healthCheck" { Orb.handlerId = "healthCheck"
, Orb.requestBody = Orb.EmptyRequestBody , Orb.requestBody = Orb.EmptyRequestBody
, Orb.requestQuery = Orb.EmptyRequestQuery , Orb.requestQuery = Orb.EmptyRequestQuery
, Orb.requestHeaders = Orb.EmptyRequestHeaders , Orb.requestHeaders = Orb.EmptyRequestHeaders
, Orb.handlerResponseBodies = , Orb.handlerResponseBodies =
Orb.responseBodies Orb.responseBodies
. Orb.addResponseSchema200 Orb.successMessageSchema . Orb.addResponseSchema200 Orb.successMessageSchema
. 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")
} }
-- NoPermissions — all routes are public for now. -- NoPermissions — all routes are public for now.
data NoPermissions = NoPermissions data NoPermissions = NoPermissions
instance Orb.PermissionAction NoPermissions where instance Orb.PermissionAction NoPermissions where
type PermissionActionMonad NoPermissions = SisDispatchM type PermissionActionMonad NoPermissions = SisDispatchM
type PermissionActionError NoPermissions = NoError type PermissionActionError NoPermissions = NoError
type PermissionActionResult NoPermissions = () type PermissionActionResult NoPermissions = ()
checkPermissionAction _ = checkPermissionAction _ =
pure (Right ()) pure (Right ())
newtype NoError = NoError Void newtype NoError = NoError Void
instance Orb.PermissionError NoError where instance Orb.PermissionError NoError where
type PermissionErrorConstraints NoError _tags = () type PermissionErrorConstraints NoError _tags = ()
type PermissionErrorMonad NoError = SisDispatchM type PermissionErrorMonad NoError = SisDispatchM
returnPermissionError (NoError v) = returnPermissionError (NoError v) =
absurd v absurd v