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:
+8
-4
@@ -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"
|
||||
|
||||
+97
-95
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user