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
@@ -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"