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

Add SPA static file serving from backend

Browse Source 
Backend (Server.hs):
- serveStaticOrSpa: serves static files from --static-dir
- SPA fallback: extensionless paths serve index.html
- MIME type mapping for html/css/js/png/svg/ico/woff2

Frontend:
- ES module imports with import map for Mithril CDN
- Build script: tsc + copy index.html + static assets

CLI:
- --static-dir flag (default: frontend/dist)
- scripts/run passes through extra args
- Dockerfile CMD points at /usr/local/share/sis/static
This commit is contained in:
James Brechtel
2026-07-15 14:59:31 -04:00
parent 5075ef2718
commit 72b1ee1d3d
12 changed files with 1297 additions and 114 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Dockerfile
+2 -3
View File
@@ -10,12 +10,11 @@ RUN mkdir -p /build && date -u '+%Y-%m-%d %H:%M UTC' > /build/build-time
ADD build/sis-server /usr/local/bin/sis-server ADD build/sis-server /usr/local/bin/sis-server
RUN chmod +x /usr/local/bin/sis-server RUN chmod +x /usr/local/bin/sis-server
# Frontend static files are served separately (e.g. nginx, CDN, or # Frontend SPA static files, served by sis-server via --static-dir.
# a simple static file server). In development, use `npx serve`.
ADD frontend/dist /usr/local/share/sis/static ADD frontend/dist /usr/local/share/sis/static
ENTRYPOINT ["/usr/bin/tini", "-s", "--"] ENTRYPOINT ["/usr/bin/tini", "-s", "--"]
EXPOSE 8080 EXPOSE 8080
CMD ["/usr/local/bin/sis-server", "--port", "8080"] CMD ["/usr/local/bin/sis-server", "--port", "8080", "--static-dir", "/usr/local/share/sis/static"]
app/Main.hs
+25 -14
View File
@@ -2,7 +2,7 @@
{- | Entry point for the Sis chore tracker server. {- | Entry point for the Sis chore tracker server.
Starts a Warp HTTP server and serves the JSON API. Starts a Warp HTTP server, serves the JSON API and the SPA frontend.
-} -}
module Main (main) where module Main (main) where
@@ -14,6 +14,7 @@ import Sis.Server qualified as Sis
data Options = Options data Options = Options
{ optPort :: Int { optPort :: Int
, optStaticDir :: FilePath
} }
optionsParser :: Opt.Parser Options optionsParser :: Opt.Parser Options
@@ -28,26 +29,36 @@ optionsParser =
<> Opt.value 8080 <> Opt.value 8080
<> Opt.showDefault <> 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
)
main :: IO () main :: IO ()
main = do main = do
opts <- Opt.execParser $ opts <-
Opt.info (optionsParser Opt.<**> Opt.helper) $ Opt.execParser $
Opt.fullDesc Opt.info (optionsParser Opt.<**> Opt.helper) $
<> Opt.progDesc "Sis — shared household chore tracker" Opt.fullDesc
<> Opt.header "sis-server" <> Opt.progDesc "Sis — shared household chore tracker"
<> Opt.header "sis-server"
-- Install a SIGTERM handler so Docker stop works cleanly. -- Install a SIGTERM handler so Docker stop works cleanly.
_ <- Signals.installHandler _ <-
Signals.sigTERM Signals.installHandler
(Signals.Catch (putStrLn "[sis] shutting down")) Signals.sigTERM
Nothing (Signals.Catch (putStrLn "[sis] shutting down"))
Nothing
let waiApp = Sis.app let waiApp = Sis.app (optStaticDir opts)
let settings = let settings =
Warp.setPort (optPort opts) Warp.setPort (optPort opts) $
$ Warp.setBeforeMainLoop (putStrLn $ "[sis] listening on port " ++ show (optPort opts)) Warp.setBeforeMainLoop
Warp.defaultSettings (putStrLn $ "[sis] listening on port " ++ show (optPort opts))
Warp.defaultSettings
Warp.runSettings settings waiApp Warp.runSettings settings waiApp
frontend/index.html
+8 -1
View File
@@ -6,9 +6,16 @@
<title>Sis — Chore Tracker</title> <title>Sis — Chore Tracker</title>
<link rel="stylesheet" href="https://unpkg.com/neobrutalismcss@latest"> <link rel="stylesheet" href="https://unpkg.com/neobrutalismcss@latest">
<link rel="stylesheet" href="/style.css"> <link rel="stylesheet" href="/style.css">
<script type="importmap">
{
"imports": {
"mithril": "https://unpkg.com/mithril@2.2.13/mithril.min.js"
}
}
</script>
</head> </head>
<body> <body>
<div id="app"></div> <div id="app"></div>
<script src="/index.js"></script> <script type="module" src="/index.js"></script>
</body> </body>
</html> </html>
frontend/package-lock.json
Generated
+1089
View File
File diff suppressed because it is too large Load Diff
frontend/package.json
+1 -1
View File
@@ -4,7 +4,7 @@
"private": true, "private": true,
"description": "Sis chore tracker SPA frontend", "description": "Sis chore tracker SPA frontend",
"scripts": { "scripts": {
"build": "tsc && cp -r public/* dist/", "build": "tsc && cp index.html dist/ && cp -r public/* dist/",
"dev": "tsc --watch", "dev": "tsc --watch",
"serve": "npx serve dist" "serve": "npx serve dist"
}, },
package.yaml
+2
View File
@@ -35,6 +35,8 @@ dependencies:
- beeline-routing - beeline-routing
- bytestring - bytestring
- containers - containers
- directory
- filepath
- http-types - http-types
- json-fleece-aeson - json-fleece-aeson
- json-fleece-core - json-fleece-core
scripts/run
+7 -5
View File
@@ -1,19 +1,21 @@
#!/usr/bin/env bash #!/usr/bin/env bash
# Run the sis-server in Docker. # Run the sis-server in Docker.
# #
# Usage: ./scripts/run [--port PORT] # Usage: ./scripts/run [--port PORT] [--static-dir DIR] [-- ... extra server args]
# #
# The server listens on port 8080 inside the container, mapped to PORT # The server listens on port 8080 inside the container, mapped to PORT
# on the host (default 8080). Pass --port to change the host-side port. # on the host (default 8080).
# #
# Examples: # Examples:
# ./scripts/run # ./scripts/run
# ./scripts/run --port 9090 # ./scripts/run --port 9090
# ./scripts/run --static-dir frontend/dist
set -euo pipefail set -euo pipefail
PROJECT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")/.." && pwd)" PROJECT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")/.." && pwd)"
HOST_PORT=8080 HOST_PORT=8080
SERVER_ARGS=()
while [ $# -gt 0 ]; do while [ $# -gt 0 ]; do
case "$1" in case "$1" in
--port) --port)
@@ -21,8 +23,8 @@ while [ $# -gt 0 ]; do
shift 2 shift 2
;; ;;
*) *)
echo "Unknown option: $1" >&2 SERVER_ARGS+=("$1")
exit 1 shift
;; ;;
esac esac
done done
@@ -40,4 +42,4 @@ exec docker run --rm -i $([ -t 0 ] && printf -- -t) \
-w /work \ -w /work \
-p "${HOST_PORT}:8080" \ -p "${HOST_PORT}:8080" \
"${IMAGE}" \ "${IMAGE}" \
stack exec sis-server -- --port 8080 stack exec sis-server -- --port 8080 "${SERVER_ARGS[@]}"
sis-server.cabal
+6
View File
@@ -39,6 +39,8 @@ library
, beeline-routing , beeline-routing
, bytestring , bytestring
, containers , containers
, directory
, filepath
, http-types , http-types
, json-fleece-aeson , json-fleece-aeson
, json-fleece-core , json-fleece-core
@@ -75,6 +77,8 @@ executable sis-server
, beeline-routing , beeline-routing
, bytestring , bytestring
, containers , containers
, directory
, filepath
, http-types , http-types
, json-fleece-aeson , json-fleece-aeson
, json-fleece-core , json-fleece-core
@@ -114,6 +118,8 @@ test-suite sis-server-test
, beeline-routing , beeline-routing
, bytestring , bytestring
, containers , containers
, directory
, filepath
, hspec , hspec
, http-types , http-types
, json-fleece-aeson , json-fleece-aeson
src/Sis.hs
+4 -5
View File
@@ -1,8 +1,7 @@
{- | Top-level re-exports for the Sis server library. -- | Top-level re-exports for the Sis server library.
-} module Sis (
module Sis module X,
( module X ) where
) where
import Sis.Server as X import Sis.Server as X
import Sis.Types as X import Sis.Types as X
src/Sis/Server.hs
+77 -7
View File
@@ -1,10 +1,13 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{- | Orb-based HTTP server for Sis. {- | Orb-based HTTP server for Sis.
Defines the API routes and wires them into a WAI 'Wai.Application'. 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 module Sis.Server
( app ( app
@@ -17,16 +20,23 @@ import Beeline.Routing qualified as R
import Control.Exception.Safe qualified as Safe import Control.Exception.Safe qualified as Safe
import Control.Monad.IO.Class qualified as MIO 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.Map.Strict qualified as Map
import Data.Text qualified as T
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.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 Orb qualified import Orb qualified
-- | The top-level WAI application as a WAI 'Wai.Application'. -- | The top-level WAI application, serving both the API and the SPA frontend.
app :: Wai.Application app :: FilePath -> Wai.Application
app = app staticDir =
Orb.orbAppToWai sisOrbApp 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)
@@ -34,14 +44,14 @@ sisOrbApp =
Orb.OrbApp Orb.OrbApp
{ Orb.router = sisRouter { Orb.router = sisRouter
, Orb.dispatcher = sisDispatcher , Orb.dispatcher = sisDispatcher
, Orb.handleNotFound = Orb.defaultHandleNotFound , 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.
@@ -50,11 +60,71 @@ 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
-- | MIME type lookup by file extension.
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
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")
]
{- | Serve a static file from @staticDir@.
For paths without a file extension (SPA client-side routes), serves
@index.html@ instead so the SPA can handle routing.
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
hasExtension :: FilePath -> Bool
hasExtension = elem '.' . takeFileName
takeFileName :: FilePath -> FilePath
takeFileName = reverse . takeWhile (/= '/') . reverse
notFoundResponse :: Wai.Response
notFoundResponse =
Wai.responseLBS HTTP.status404 [("Content-Type", "text/plain")] "Not Found"
-- Internal WAI dispatch monad -- Internal WAI dispatch monad
data SisDispatchEnv = SisDispatchEnv data SisDispatchEnv = SisDispatchEnv
src/Sis/Types.hs
+71 -73
View File
@@ -4,27 +4,26 @@ Sis tracks tasks (chores, responsibilities) that are shared among
members of a household or group. Any user can complete a task, and members of a household or group. Any user can complete a task, and
completion is visible to all. completion is visible to all.
-} -}
module Sis.Types module Sis.Types (
( -- * Task -- * Task
Task (..) Task (..),
, TaskId TaskId,
, TaskName TaskName,
, TaskStatus (..) TaskStatus (..),
-- * User -- * User
, User (..) User (..),
, UserId UserId,
, UserName UserName,
-- * Task completion -- * Task completion
, TaskCompletion (..) TaskCompletion (..),
) where ) where
import Data.Aeson qualified as A import Data.Aeson qualified as A
import Data.Text (Text) import Data.Text (Text)
import Data.Time (UTCTime) import Data.Time (UTCTime)
-- | Unique identifier for a task. -- | Unique identifier for a task.
type TaskId = Int type TaskId = Int
@@ -33,19 +32,19 @@ type TaskName = Text
-- | Whether a task is pending or done. -- | Whether a task is pending or done.
data TaskStatus data TaskStatus
= TaskPending = TaskPending
| TaskDone | TaskDone
deriving stock (Show, Eq) deriving stock (Show, Eq)
-- | A chore or responsibility that needs to be completed. -- | A chore or responsibility that needs to be completed.
data Task = Task data Task = Task
{ taskId :: TaskId { taskId :: TaskId
, taskName :: TaskName , taskName :: TaskName
, taskStatus :: TaskStatus , taskStatus :: TaskStatus
, taskAssignedTo :: Maybe UserId , taskAssignedTo :: Maybe UserId
, taskLastCompleted :: Maybe UTCTime , taskLastCompleted :: Maybe UTCTime
} }
deriving stock (Show, Eq) deriving stock (Show, Eq)
-- | Unique identifier for a user. -- | Unique identifier for a user.
type UserId = Int type UserId = Int
@@ -55,75 +54,74 @@ type UserName = Text
-- | A user who can complete tasks. -- | A user who can complete tasks.
data User = User data User = User
{ userId :: UserId { userId :: UserId
, userName :: UserName , userName :: UserName
} }
deriving stock (Show, Eq) deriving stock (Show, Eq)
-- | Records when a user completed a task. -- | Records when a user completed a task.
data TaskCompletion = TaskCompletion data TaskCompletion = TaskCompletion
{ completionTaskId :: TaskId { completionTaskId :: TaskId
, completionUserId :: UserId , completionUserId :: UserId
, completionTime :: UTCTime , completionTime :: UTCTime
} }
deriving stock (Show, Eq) deriving stock (Show, Eq)
-- JSON instances -- JSON instances
instance A.ToJSON TaskStatus where instance A.ToJSON TaskStatus where
toJSON TaskPending = A.String "pending" toJSON TaskPending = A.String "pending"
toJSON TaskDone = A.String "done" toJSON TaskDone = A.String "done"
instance A.FromJSON TaskStatus where instance A.FromJSON TaskStatus where
parseJSON = A.withText "TaskStatus" $ \case parseJSON = A.withText "TaskStatus" $ \case
"pending" -> pure TaskPending "pending" -> pure TaskPending
"done" -> pure TaskDone "done" -> pure TaskDone
other -> fail $ "Unknown TaskStatus: " <> show other other -> fail $ "Unknown TaskStatus: " <> show other
instance A.ToJSON Task where instance A.ToJSON Task where
toJSON Task{..} = toJSON Task{..} =
A.object A.object
[ "id" A..= taskId [ "id" A..= taskId
, "name" A..= taskName , "name" A..= taskName
, "status" A..= taskStatus , "status" A..= taskStatus
, "assignedTo" A..= taskAssignedTo , "assignedTo" A..= taskAssignedTo
, "lastCompleted" A..= taskLastCompleted , "lastCompleted" A..= taskLastCompleted
] ]
instance A.FromJSON Task where instance A.FromJSON Task where
parseJSON = A.withObject "Task" $ \o -> parseJSON = A.withObject "Task" $ \o ->
Task Task
<$> o A..: "id" <$> o A..: "id"
<*> o A..: "name" <*> o A..: "name"
<*> o A..: "status" <*> o A..: "status"
<*> o A..: "assignedTo" <*> o A..: "assignedTo"
<*> o A..: "lastCompleted" <*> o A..: "lastCompleted"
instance A.ToJSON User where instance A.ToJSON User where
toJSON User{..} = toJSON User{..} =
A.object A.object
[ "id" A..= userId [ "id" A..= userId
, "name" A..= userName , "name" A..= userName
] ]
instance A.FromJSON User where instance A.FromJSON User where
parseJSON = A.withObject "User" $ \o -> parseJSON = A.withObject "User" $ \o ->
User User
<$> o A..: "id" <$> o A..: "id"
<*> o A..: "name" <*> o A..: "name"
instance A.ToJSON TaskCompletion where instance A.ToJSON TaskCompletion where
toJSON TaskCompletion{..} = toJSON TaskCompletion{..} =
A.object A.object
[ "taskId" A..= completionTaskId [ "taskId" A..= completionTaskId
, "userId" A..= completionUserId , "userId" A..= completionUserId
, "time" A..= completionTime , "time" A..= completionTime
] ]
instance A.FromJSON TaskCompletion where instance A.FromJSON TaskCompletion where
parseJSON = A.withObject "TaskCompletion" $ \o -> parseJSON = A.withObject "TaskCompletion" $ \o ->
TaskCompletion TaskCompletion
<$> o A..: "taskId" <$> o A..: "taskId"
<*> o A..: "userId" <*> o A..: "userId"
<*> o A..: "time" <*> o A..: "time"
test/Spec.hs
+5 -5
View File
@@ -1,5 +1,4 @@
{- | Test entry point for sis-server. -- | Test entry point for sis-server.
-}
module Main (main) where module Main (main) where
import Test.Hspec (Spec, describe, hspec, it, shouldBe) import Test.Hspec (Spec, describe, hspec, it, shouldBe)
@@ -8,6 +7,7 @@ main :: IO ()
main = hspec spec main = hspec spec
spec :: Spec spec :: Spec
spec = describe "Sis.Server" $ spec =
it "health check returns ok" $ describe "Sis.Server" $
True `shouldBe` True it "health check returns ok" $
True `shouldBe` True