Add SPA static file serving from backend

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
2026-07-15 14:59:31 -04:00
parent 5075ef2718
commit 72b1ee1d3d
12 changed files with 1297 additions and 114 deletions
@@ -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
 RUN chmod +x /usr/local/bin/sis-server

-# Frontend static files are served separately (e.g. nginx, CDN, or
-# a simple static file server). In development, use `npx serve`.
+# Frontend SPA static files, served by sis-server via --static-dir.
 ADD frontend/dist /usr/local/share/sis/static

 ENTRYPOINT ["/usr/bin/tini", "-s", "--"]

 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"]
@@ -2,7 +2,7 @@

 {- | 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

@@ -14,6 +14,7 @@ import Sis.Server qualified as Sis

 data Options = Options
  { optPort :: Int
+  , optStaticDir :: FilePath
  }

 optionsParser :: Opt.Parser Options
@@ -28,26 +29,36 @@ optionsParser =
          <> 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
+      )

 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"

  -- Install a SIGTERM handler so Docker stop works cleanly.
-  _ <- Signals.installHandler
-    Signals.sigTERM
-    (Signals.Catch (putStrLn "[sis] shutting down"))
-    Nothing
+  _ <-
+    Signals.installHandler
+      Signals.sigTERM
+      (Signals.Catch (putStrLn "[sis] shutting down"))
+      Nothing

-  let waiApp = Sis.app
+  let waiApp = Sis.app (optStaticDir opts)

  let settings =
-        Warp.setPort (optPort opts)
-          $ Warp.setBeforeMainLoop (putStrLn $ "[sis] listening on port " ++ show (optPort opts))
-          Warp.defaultSettings
+        Warp.setPort (optPort opts) $
+          Warp.setBeforeMainLoop
+            (putStrLn $ "[sis] listening on port " ++ show (optPort opts))
+            Warp.defaultSettings

  Warp.runSettings settings waiApp
@@ -6,9 +6,16 @@
  <title>Sis — Chore Tracker</title>
  <link rel="stylesheet" href="https://unpkg.com/neobrutalismcss@latest">
  <link rel="stylesheet" href="/style.css">
+  <script type="importmap">
+    {
+      "imports": {
+        "mithril": "https://unpkg.com/mithril@2.2.13/mithril.min.js"
+      }
+    }
+  </script>
 </head>
 <body>
  <div id="app"></div>
-  <script src="/index.js"></script>
+  <script type="module" src="/index.js"></script>
 </body>
 </html>
@@ -4,7 +4,7 @@
  "private": true,
  "description": "Sis chore tracker SPA frontend",
  "scripts": {
-    "build": "tsc && cp -r public/* dist/",
+    "build": "tsc && cp index.html dist/ && cp -r public/* dist/",
    "dev": "tsc --watch",
    "serve": "npx serve dist"
  },
@@ -35,6 +35,8 @@ dependencies:
  - beeline-routing
  - bytestring
  - containers
+  - directory
+  - filepath
  - http-types
  - json-fleece-aeson
  - json-fleece-core
@@ -1,19 +1,21 @@
 #!/usr/bin/env bash
 # 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
-# on the host (default 8080).  Pass --port to change the host-side port.
+# on the host (default 8080).
 #
 # Examples:
 #   ./scripts/run
 #   ./scripts/run --port 9090
+#   ./scripts/run --static-dir frontend/dist
 set -euo pipefail

 PROJECT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")/.." && pwd)"

 HOST_PORT=8080
+SERVER_ARGS=()
 while [ $# -gt 0 ]; do
    case "$1" in
        --port)
@@ -21,8 +23,8 @@ while [ $# -gt 0 ]; do
            shift 2
            ;;
        *)
-            echo "Unknown option: $1" >&2
-            exit 1
+            SERVER_ARGS+=("$1")
+            shift
            ;;
    esac
 done
@@ -40,4 +42,4 @@ exec docker run --rm -i $([ -t 0 ] && printf -- -t) \
    -w /work \
    -p "${HOST_PORT}:8080" \
    "${IMAGE}" \
-    stack exec sis-server -- --port 8080
+    stack exec sis-server -- --port 8080 "${SERVER_ARGS[@]}"
@@ -39,6 +39,8 @@ library
    , beeline-routing
    , bytestring
    , containers
+    , directory
+    , filepath
    , http-types
    , json-fleece-aeson
    , json-fleece-core
@@ -75,6 +77,8 @@ executable sis-server
    , beeline-routing
    , bytestring
    , containers
+    , directory
+    , filepath
    , http-types
    , json-fleece-aeson
    , json-fleece-core
@@ -114,6 +118,8 @@ test-suite sis-server-test
    , beeline-routing
    , bytestring
    , containers
+    , directory
+    , filepath
    , hspec
    , http-types
    , json-fleece-aeson
@@ -1,8 +1,7 @@
-{- | Top-level re-exports for the Sis server library.
-}
-module Sis
-  ( module X
-  ) where
+-- | Top-level re-exports for the Sis server library.
+module Sis (
+    module X,
+) where

 import Sis.Server as X
 import Sis.Types as X
@@ -1,10 +1,13 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}

 {- | Orb-based HTTP server for Sis.

 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
@@ -17,16 +20,23 @@ import Beeline.Routing qualified as R
 import Control.Exception.Safe qualified as Safe
 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.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 Orb qualified

-- | The top-level WAI application as a WAI 'Wai.Application'.
-app :: Wai.Application
-app =
-  Orb.orbAppToWai sisOrbApp
+-- | 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}

 -- | Full Orb application wiring routes to a WAI dispatcher.
 sisOrbApp :: Orb.OrbApp (S.Union Routes)
@@ -34,14 +44,14 @@ sisOrbApp =
  Orb.OrbApp
    { Orb.router = sisRouter
    , Orb.dispatcher = sisDispatcher
-    , Orb.handleNotFound = Orb.defaultHandleNotFound
+    , 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.routeList $
+    Orb.get (R.make HealthCheck /- "api" /- "health")
      /: R.emptyRoutes

 -- | 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 SisDispatchM action = Orb.dispatch route
  Reader.runReaderT action env
+
 -- | The union of all route types in the application.
 type Routes =
  '[ 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

 data SisDispatchEnv = SisDispatchEnv
@@ -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
 completion is visible to all.
 -}
-module Sis.Types
-  ( -- * Task
-    Task (..)
-  , TaskId
-  , TaskName
-  , TaskStatus (..)
+module Sis.Types (
+    -- * Task
+    Task (..),
+    TaskId,
+    TaskName,
+    TaskStatus (..),

    -- * User
-  , User (..)
-  , UserId
-  , UserName
+    User (..),
+    UserId,
+    UserName,

    -- * Task completion
-  , TaskCompletion (..)
-  ) where
+    TaskCompletion (..),
+) where

 import Data.Aeson qualified as A
 import Data.Text (Text)
 import Data.Time (UTCTime)

-
 -- | Unique identifier for a task.
 type TaskId = Int

@@ -33,19 +32,19 @@ type TaskName = Text

 -- | Whether a task is pending or done.
 data TaskStatus
-  = TaskPending
-  | TaskDone
-  deriving stock (Show, Eq)
+    = TaskPending
+    | TaskDone
+    deriving stock (Show, Eq)

 -- | A chore or responsibility that needs to be completed.
 data Task = Task
-  { taskId :: TaskId
-  , taskName :: TaskName
-  , taskStatus :: TaskStatus
-  , taskAssignedTo :: Maybe UserId
-  , taskLastCompleted :: Maybe UTCTime
-  }
-  deriving stock (Show, Eq)
+    { taskId :: TaskId
+    , taskName :: TaskName
+    , taskStatus :: TaskStatus
+    , taskAssignedTo :: Maybe UserId
+    , taskLastCompleted :: Maybe UTCTime
+    }
+    deriving stock (Show, Eq)

 -- | Unique identifier for a user.
 type UserId = Int
@@ -55,75 +54,74 @@ type UserName = Text

 -- | A user who can complete tasks.
 data User = User
-  { userId :: UserId
-  , userName :: UserName
-  }
-  deriving stock (Show, Eq)
+    { userId :: UserId
+    , userName :: UserName
+    }
+    deriving stock (Show, Eq)

 -- | Records when a user completed a task.
 data TaskCompletion = TaskCompletion
-  { completionTaskId :: TaskId
-  , completionUserId :: UserId
-  , completionTime :: UTCTime
-  }
-  deriving stock (Show, Eq)
+    { completionTaskId :: TaskId
+    , completionUserId :: UserId
+    , completionTime :: UTCTime
+    }
+    deriving stock (Show, Eq)

 -- JSON instances

 instance A.ToJSON TaskStatus where
-  toJSON TaskPending = A.String "pending"
-  toJSON TaskDone = A.String "done"
+    toJSON TaskPending = A.String "pending"
+    toJSON TaskDone = A.String "done"

 instance A.FromJSON TaskStatus where
-  parseJSON = A.withText "TaskStatus" $ \case
-    "pending" -> pure TaskPending
-    "done" -> pure TaskDone
-    other -> fail $ "Unknown TaskStatus: " <> show other
-
+    parseJSON = A.withText "TaskStatus" $ \case
+        "pending" -> pure TaskPending
+        "done" -> pure TaskDone
+        other -> fail $ "Unknown TaskStatus: " <> show other

 instance A.ToJSON Task where
-  toJSON Task{..} =
-    A.object
-      [ "id" A..= taskId
-      , "name" A..= taskName
-      , "status" A..= taskStatus
-      , "assignedTo" A..= taskAssignedTo
-      , "lastCompleted" A..= taskLastCompleted
-      ]
+    toJSON Task{..} =
+        A.object
+            [ "id" A..= taskId
+            , "name" A..= taskName
+            , "status" A..= taskStatus
+            , "assignedTo" A..= taskAssignedTo
+            , "lastCompleted" A..= taskLastCompleted
+            ]

 instance A.FromJSON Task where
-  parseJSON = A.withObject "Task" $ \o ->
-    Task
-      <$> o A..: "id"
-      <*> o A..: "name"
-      <*> o A..: "status"
-      <*> o A..: "assignedTo"
-      <*> o A..: "lastCompleted"
+    parseJSON = A.withObject "Task" $ \o ->
+        Task
+            <$> o A..: "id"
+            <*> o A..: "name"
+            <*> o A..: "status"
+            <*> o A..: "assignedTo"
+            <*> o A..: "lastCompleted"

 instance A.ToJSON User where
-  toJSON User{..} =
-    A.object
-      [ "id" A..= userId
-      , "name" A..= userName
-      ]
+    toJSON User{..} =
+        A.object
+            [ "id" A..= userId
+            , "name" A..= userName
+            ]

 instance A.FromJSON User where
-  parseJSON = A.withObject "User" $ \o ->
-    User
-      <$> o A..: "id"
-      <*> o A..: "name"
+    parseJSON = A.withObject "User" $ \o ->
+        User
+            <$> o A..: "id"
+            <*> o A..: "name"

 instance A.ToJSON TaskCompletion where
-  toJSON TaskCompletion{..} =
-    A.object
-      [ "taskId" A..= completionTaskId
-      , "userId" A..= completionUserId
-      , "time" A..= completionTime
-      ]
+    toJSON TaskCompletion{..} =
+        A.object
+            [ "taskId" A..= completionTaskId
+            , "userId" A..= completionUserId
+            , "time" A..= completionTime
+            ]

 instance A.FromJSON TaskCompletion where
-  parseJSON = A.withObject "TaskCompletion" $ \o ->
-    TaskCompletion
-      <$> o A..: "taskId"
-      <*> o A..: "userId"
-      <*> o A..: "time"
+    parseJSON = A.withObject "TaskCompletion" $ \o ->
+        TaskCompletion
+            <$> o A..: "taskId"
+            <*> o A..: "userId"
+            <*> o A..: "time"
@@ -1,5 +1,4 @@
-{- | Test entry point for sis-server.
-}
+-- | Test entry point for sis-server.
 module Main (main) where

 import Test.Hspec (Spec, describe, hspec, it, shouldBe)
@@ -8,6 +7,7 @@ main :: IO ()
 main = hspec spec

 spec :: Spec
-spec = describe "Sis.Server" $
-  it "health check returns ok" $
-    True `shouldBe` True
+spec =
+    describe "Sis.Server" $
+        it "health check returns ok" $
+            True `shouldBe` True