Initial project skeleton

Haskell backend: Orb HTTP framework, JSON-only API
Frontend: Mithril.js SPA with TypeScript, Neo Brutalism CSS
Dockerized build via flipstone/haskell-tools image

Routes:
  GET /api/health — health check

Build: ./hs stack build
Test:  ./hs stack test
Run:   ./scripts/run

src/Sis.hs

@@ -0,0 +1,8 @@
+{- | Top-level re-exports for the Sis server library.
+-}
+module Sis
+  ( module X
+  ) where
+
+import Sis.Server as X
+import Sis.Types as X

src/Sis/Server.hs

@@ -0,0 +1,142 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{- | Orb-based HTTP server for Sis.
+
+Defines the API routes and wires them into a WAI 'Wai.Application'.
+-}
+module Sis.Server
+  ( app
+  , sisRouter
+  , HealthCheck (..)
+  ) where
+
+import Beeline.Routing ((/-), (/:))
+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.Void (Void, absurd)
+import Network.Wai qualified as Wai
+import Shrubbery qualified as S
+
+import Orb qualified
+
+-- | The top-level WAI application as a WAI 'Wai.Application'.
+app :: Wai.Application
+app =
+  Orb.orbAppToWai sisOrbApp
+
+-- | 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
+    }
+
+-- | 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
+
+-- | 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
+-- | The union of all route types in the application.
+type Routes =
+  '[ HealthCheck
+   ]
+
+-- Internal WAI dispatch monad
+
+data SisDispatchEnv = SisDispatchEnv
+  { 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
+    )
+
+instance Orb.HasRequest SisDispatchM where
+  request = SisDispatchM (Reader.asks sisRequest)
+
+instance Orb.HasRespond SisDispatchM where
+  respond = SisDispatchM (Reader.asks sisRespond)
+
+instance Orb.HasLogger SisDispatchM where
+  log = MIO.liftIO . putStrLn . Safe.displayException
+
+-- Health check route
+
+{- | GET \/api\/health
+
+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
+
+  routeHandler = healthCheckHandler
+
+type HealthCheckResponses =
+  '[ 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")
+    }
+
+-- 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 = ()
+
+  checkPermissionAction _ =
+    pure (Right ())
+
+newtype NoError = NoError Void
+
+instance Orb.PermissionError NoError where
+  type PermissionErrorConstraints NoError _tags = ()
+  type PermissionErrorMonad NoError = SisDispatchM
+
+  returnPermissionError (NoError v) =
+    absurd v

src/Sis/Types.hs

@@ -0,0 +1,129 @@
+{- | Core domain types for Sis.
+
+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 (..)
+
+    -- * User
+  , User (..)
+  , UserId
+  , UserName
+
+    -- * Task completion
+  , TaskCompletion (..)
+  ) where
+
+import Data.Aeson qualified as A
+import Data.Text (Text)
+import Data.Time (UTCTime)
+
+
+-- | Unique identifier for a task.
+type TaskId = Int
+
+-- | Human-readable task name.
+type TaskName = Text
+
+-- | Whether a task is pending or done.
+data TaskStatus
+  = 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)
+
+-- | Unique identifier for a user.
+type UserId = Int
+
+-- | Display name for a user.
+type UserName = Text
+
+-- | A user who can complete tasks.
+data User = User
+  { 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)
+
+-- JSON instances
+
+instance A.ToJSON TaskStatus where
+  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
+
+
+instance A.ToJSON Task where
+  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"
+
+instance A.ToJSON User where
+  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"
+
+instance A.ToJSON TaskCompletion where
+  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"