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
This commit is contained in:
+14
@@ -0,0 +1,14 @@
|
||||
build/
|
||||
.env
|
||||
*.db
|
||||
*.db-shm
|
||||
*.db-wal
|
||||
*.sqlite
|
||||
*.sqlite3
|
||||
.stack-root
|
||||
.pi/
|
||||
__pycache__
|
||||
.worktrees/
|
||||
.superpowers/
|
||||
node_modules/
|
||||
frontend/dist/
|
||||
+21
@@ -0,0 +1,21 @@
|
||||
FROM debian:bookworm-slim
|
||||
|
||||
RUN apt-get update && apt-get install -y --no-install-recommends \
|
||||
ca-certificates curl tini && \
|
||||
rm -rf /var/lib/apt/lists/*
|
||||
|
||||
# Build timestamp — read at runtime for diagnostics.
|
||||
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`.
|
||||
ADD frontend/dist /usr/local/share/sis/static
|
||||
|
||||
ENTRYPOINT ["/usr/bin/tini", "-s", "--"]
|
||||
|
||||
EXPOSE 8080
|
||||
|
||||
CMD ["/usr/local/bin/sis-server", "--port", "8080"]
|
||||
@@ -0,0 +1,17 @@
|
||||
# Sis
|
||||
|
||||
Sis (short for Sisyphus) is a todo tracker meant primarily for households, families or other groups of people with shared repeated responsibilities like chores.
|
||||
|
||||
The goal of Sis is to make it easy for users to keep track of which tasks need to be completed and when while allowing any user to complete a given task and provide visibility to other users that a task has been completed.
|
||||
|
||||
Sis is primarily a web application but includes push notification support for end users to notify them about upcoming/overdue tasks as well as task completion.
|
||||
|
||||
## Frontend
|
||||
|
||||
The Sis UI a single-page application written in Javascript using https://mithril.js.org/ and uses the "Neo Brutalism" CSS framework - https://unpkg.com/neobrutalismcss@latest
|
||||
|
||||
Sis uses Typescript for front-end code
|
||||
|
||||
## Backend
|
||||
|
||||
The Sis backend is written in Haskell using Orb for the HTTP framework - https://github.com/flipstone/orb
|
||||
+53
@@ -0,0 +1,53 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{- | Entry point for the Sis chore tracker server.
|
||||
|
||||
Starts a Warp HTTP server and serves the JSON API.
|
||||
-}
|
||||
module Main (main) where
|
||||
|
||||
import Network.Wai.Handler.Warp qualified as Warp
|
||||
import Options.Applicative qualified as Opt
|
||||
import System.Posix.Signals qualified as Signals
|
||||
|
||||
import Sis.Server qualified as Sis
|
||||
|
||||
data Options = Options
|
||||
{ optPort :: Int
|
||||
}
|
||||
|
||||
optionsParser :: Opt.Parser Options
|
||||
optionsParser =
|
||||
Options
|
||||
<$> Opt.option
|
||||
Opt.auto
|
||||
( Opt.long "port"
|
||||
<> Opt.short 'p'
|
||||
<> Opt.metavar "PORT"
|
||||
<> Opt.help "Listen port"
|
||||
<> Opt.value 8080
|
||||
<> 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"
|
||||
|
||||
-- Install a SIGTERM handler so Docker stop works cleanly.
|
||||
_ <- Signals.installHandler
|
||||
Signals.sigTERM
|
||||
(Signals.Catch (putStrLn "[sis] shutting down"))
|
||||
Nothing
|
||||
|
||||
let waiApp = Sis.app
|
||||
|
||||
let settings =
|
||||
Warp.setPort (optPort opts)
|
||||
$ Warp.setBeforeMainLoop (putStrLn $ "[sis] listening on port " ++ show (optPort opts))
|
||||
Warp.defaultSettings
|
||||
|
||||
Warp.runSettings settings waiApp
|
||||
@@ -0,0 +1,9 @@
|
||||
services:
|
||||
sis-server:
|
||||
image: git.roo.lol/jbrechtel/sis:latest
|
||||
restart: unless-stopped
|
||||
ports:
|
||||
- "127.0.0.1:8080:8080"
|
||||
volumes:
|
||||
# Writable app state (SQLite DB for tasks, users, completions).
|
||||
- /srv/sis/data:/data
|
||||
@@ -0,0 +1,14 @@
|
||||
<!DOCTYPE html>
|
||||
<html lang="en">
|
||||
<head>
|
||||
<meta charset="UTF-8">
|
||||
<meta name="viewport" content="width=device-width, initial-scale=1.0">
|
||||
<title>Sis — Chore Tracker</title>
|
||||
<link rel="stylesheet" href="https://unpkg.com/neobrutalismcss@latest">
|
||||
<link rel="stylesheet" href="/style.css">
|
||||
</head>
|
||||
<body>
|
||||
<div id="app"></div>
|
||||
<script src="/index.js"></script>
|
||||
</body>
|
||||
</html>
|
||||
@@ -0,0 +1,19 @@
|
||||
{
|
||||
"name": "sis-frontend",
|
||||
"version": "0.1.0",
|
||||
"private": true,
|
||||
"description": "Sis chore tracker SPA frontend",
|
||||
"scripts": {
|
||||
"build": "tsc && cp -r public/* dist/",
|
||||
"dev": "tsc --watch",
|
||||
"serve": "npx serve dist"
|
||||
},
|
||||
"dependencies": {
|
||||
"mithril": "^2.2.13"
|
||||
},
|
||||
"devDependencies": {
|
||||
"@types/mithril": "^2.2.7",
|
||||
"typescript": "^5.7.0",
|
||||
"serve": "^14.2.0"
|
||||
}
|
||||
}
|
||||
@@ -0,0 +1,9 @@
|
||||
/* Sis custom styles — layered on top of Neo Brutalism */
|
||||
|
||||
body {
|
||||
min-height: 100vh;
|
||||
}
|
||||
|
||||
#app {
|
||||
padding: 1rem;
|
||||
}
|
||||
@@ -0,0 +1,21 @@
|
||||
/**
|
||||
* Thin API client for the Sis backend.
|
||||
*/
|
||||
|
||||
const BASE = "/api";
|
||||
|
||||
async function request<T>(path: string): Promise<T> {
|
||||
const resp = await fetch(BASE + path);
|
||||
if (!resp.ok) {
|
||||
throw new Error(`HTTP ${resp.status}: ${resp.statusText}`);
|
||||
}
|
||||
return resp.json() as Promise<T>;
|
||||
}
|
||||
|
||||
export interface HealthResponse {
|
||||
message: string;
|
||||
}
|
||||
|
||||
export function checkHealth(): Promise<string> {
|
||||
return request<HealthResponse>("/health").then((r) => r.message);
|
||||
}
|
||||
@@ -0,0 +1,35 @@
|
||||
import m, { Vnode } from "mithril";
|
||||
|
||||
import { checkHealth } from "../api";
|
||||
|
||||
interface AppAttrs {}
|
||||
|
||||
interface AppState {
|
||||
health: string;
|
||||
}
|
||||
|
||||
export const App: m.Component<AppAttrs, AppState> = {
|
||||
oninit(vnode: Vnode<AppAttrs, AppState>) {
|
||||
vnode.state.health = "loading...";
|
||||
checkHealth()
|
||||
.then((msg) => {
|
||||
vnode.state.health = msg;
|
||||
m.redraw();
|
||||
})
|
||||
.catch((err) => {
|
||||
vnode.state.health = "error: " + String(err);
|
||||
m.redraw();
|
||||
});
|
||||
},
|
||||
|
||||
view(vnode: Vnode<AppAttrs, AppState>) {
|
||||
return m("main.container", { style: { maxWidth: "720px", margin: "2rem auto" } }, [
|
||||
m("h1", "Sis"),
|
||||
m("p", "Shared household chore tracker."),
|
||||
m("p", [
|
||||
m("strong", "API status: "),
|
||||
m("span", vnode.state.health),
|
||||
]),
|
||||
]);
|
||||
},
|
||||
};
|
||||
@@ -0,0 +1,8 @@
|
||||
import m from "mithril";
|
||||
|
||||
import { App } from "./components/App";
|
||||
|
||||
const root = document.getElementById("app");
|
||||
if (root) {
|
||||
m.mount(root, App);
|
||||
}
|
||||
@@ -0,0 +1,18 @@
|
||||
{
|
||||
"compilerOptions": {
|
||||
"target": "ES2020",
|
||||
"module": "ES2020",
|
||||
"moduleResolution": "bundler",
|
||||
"strict": true,
|
||||
"esModuleInterop": true,
|
||||
"skipLibCheck": true,
|
||||
"forceConsistentCasingInFileNames": true,
|
||||
"outDir": "dist",
|
||||
"rootDir": "src",
|
||||
"sourceMap": true,
|
||||
"jsx": "react",
|
||||
"jsxFactory": "m",
|
||||
"jsxFragmentFactory": "m.Fragment"
|
||||
},
|
||||
"include": ["src/**/*.ts"]
|
||||
}
|
||||
@@ -0,0 +1,23 @@
|
||||
#!/usr/bin/env bash
|
||||
# Thin wrapper to run Haskell tooling (stack, hpack, fourmolu, hlint, ...)
|
||||
# inside the flipstone/haskell-tools Docker image. Usage: ./hs <cmd> [args]
|
||||
# e.g. ./hs stack build, ./hs stack test, ./hs hpack, ./hs fourmolu
|
||||
set -euo pipefail
|
||||
|
||||
IMAGE="${HAWAT_HASKELL_TOOLS_IMAGE:-ghcr.io/flipstone/haskell-tools:debian-ghc-9.10.3-5d6640d}"
|
||||
PROJECT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)"
|
||||
|
||||
# Named Docker volume shared across all worktrees so cached
|
||||
# GHC/dependencies don't need rebuilding per worktree.
|
||||
STACK_ROOT_VOLUME="sis-stack-root"
|
||||
|
||||
docker volume inspect "${STACK_ROOT_VOLUME}" > /dev/null 2>&1 || \
|
||||
docker volume create "${STACK_ROOT_VOLUME}" > /dev/null
|
||||
|
||||
exec docker run --rm -i $([ -t 0 ] && printf -- -t) \
|
||||
-v "${PROJECT_DIR}:/work" \
|
||||
-v "${STACK_ROOT_VOLUME}:/stack-root" \
|
||||
-e STACK_ROOT=/stack-root \
|
||||
-w /work \
|
||||
"${IMAGE}" \
|
||||
"$@"
|
||||
@@ -0,0 +1,75 @@
|
||||
name: sis-server
|
||||
version: 0.1.0
|
||||
synopsis: Shared household chore/task tracker
|
||||
description: A todo tracker for households and groups with shared
|
||||
repeated responsibilities. JSON API backend for a
|
||||
Mithril.js SPA frontend.
|
||||
author: James Brechtel
|
||||
maintainer: james@flipstone.com
|
||||
copyright: 2026 James Brechtel
|
||||
license: BSD-3-Clause
|
||||
|
||||
default-extensions:
|
||||
- DerivingStrategies
|
||||
- ImportQualifiedPost
|
||||
- LambdaCase
|
||||
- OverloadedStrings
|
||||
- RecordWildCards
|
||||
- TupleSections
|
||||
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Werror
|
||||
- -Wcompat
|
||||
- -Widentities
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wmissing-export-lists
|
||||
- -Wmissing-home-modules
|
||||
- -Wpartial-fields
|
||||
- -Wredundant-constraints
|
||||
|
||||
dependencies:
|
||||
- base >= 4.7 && < 5
|
||||
- aeson
|
||||
- beeline-routing
|
||||
- bytestring
|
||||
- containers
|
||||
- http-types
|
||||
- json-fleece-aeson
|
||||
- json-fleece-core
|
||||
- mtl
|
||||
- optparse-applicative
|
||||
- safe-exceptions
|
||||
- shrubbery
|
||||
- text
|
||||
- time
|
||||
- wai
|
||||
- warp
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
dependencies:
|
||||
- orb
|
||||
|
||||
executables:
|
||||
sis-server:
|
||||
main: Main.hs
|
||||
source-dirs: app
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- optparse-applicative
|
||||
- orb
|
||||
- sis-server
|
||||
- unix
|
||||
|
||||
tests:
|
||||
sis-server-test:
|
||||
main: Spec.hs
|
||||
source-dirs: test
|
||||
dependencies:
|
||||
- hspec
|
||||
- sis-server
|
||||
Executable
+12
@@ -0,0 +1,12 @@
|
||||
#!/usr/bin/env bash
|
||||
set -euo pipefail
|
||||
cd "$(dirname "${BASH_SOURCE[0]}")/.."
|
||||
|
||||
echo "Formatting with fourmolu..."
|
||||
./hs fourmolu --mode inplace app/ src/ test/
|
||||
|
||||
echo "Linting with hlint..."
|
||||
./hs hlint app/ src/ test/
|
||||
|
||||
echo "Building..."
|
||||
./hs stack build --copy-bins --local-bin-path /work/build
|
||||
Executable
+43
@@ -0,0 +1,43 @@
|
||||
#!/usr/bin/env bash
|
||||
# Run the sis-server in Docker.
|
||||
#
|
||||
# Usage: ./scripts/run [--port 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.
|
||||
#
|
||||
# Examples:
|
||||
# ./scripts/run
|
||||
# ./scripts/run --port 9090
|
||||
set -euo pipefail
|
||||
|
||||
PROJECT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")/.." && pwd)"
|
||||
|
||||
HOST_PORT=8080
|
||||
while [ $# -gt 0 ]; do
|
||||
case "$1" in
|
||||
--port)
|
||||
HOST_PORT="$2"
|
||||
shift 2
|
||||
;;
|
||||
*)
|
||||
echo "Unknown option: $1" >&2
|
||||
exit 1
|
||||
;;
|
||||
esac
|
||||
done
|
||||
|
||||
IMAGE="${HAWAT_HASKELL_TOOLS_IMAGE:-ghcr.io/flipstone/haskell-tools:debian-ghc-9.10.3-5d6640d}"
|
||||
STACK_ROOT_HOST="${PROJECT_DIR}/.stack-root"
|
||||
mkdir -p "${STACK_ROOT_HOST}"
|
||||
|
||||
echo "[sis] listening on http://127.0.0.1:${HOST_PORT}/"
|
||||
|
||||
exec docker run --rm -i $([ -t 0 ] && printf -- -t) \
|
||||
-v "${PROJECT_DIR}:/work" \
|
||||
-v "${STACK_ROOT_HOST}:/stack-root" \
|
||||
-e STACK_ROOT=/stack-root \
|
||||
-w /work \
|
||||
-p "${HOST_PORT}:8080" \
|
||||
"${IMAGE}" \
|
||||
stack exec sis-server -- --port 8080
|
||||
Executable
+12
@@ -0,0 +1,12 @@
|
||||
#!/usr/bin/env bash
|
||||
set -euo pipefail
|
||||
cd "$(dirname "${BASH_SOURCE[0]}")/.."
|
||||
|
||||
echo "Checking formatting with fourmolu..."
|
||||
./hs fourmolu --mode check app/ src/ test/
|
||||
|
||||
echo "Linting with hlint..."
|
||||
./hs hlint app/ src/ test/
|
||||
|
||||
echo "Running tests..."
|
||||
./hs stack test
|
||||
@@ -0,0 +1,130 @@
|
||||
cabal-version: 2.2
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.38.1.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
name: sis-server
|
||||
version: 0.1.0
|
||||
synopsis: Shared household chore/task tracker
|
||||
description: A todo tracker for households and groups with shared repeated responsibilities. JSON API backend for a Mithril.js SPA frontend.
|
||||
author: James Brechtel
|
||||
maintainer: james@flipstone.com
|
||||
copyright: 2026 James Brechtel
|
||||
license: BSD-3-Clause
|
||||
build-type: Simple
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Sis
|
||||
Sis.Server
|
||||
Sis.Types
|
||||
other-modules:
|
||||
Paths_sis_server
|
||||
autogen-modules:
|
||||
Paths_sis_server
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions:
|
||||
DerivingStrategies
|
||||
ImportQualifiedPost
|
||||
LambdaCase
|
||||
OverloadedStrings
|
||||
RecordWildCards
|
||||
TupleSections
|
||||
ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
|
||||
build-depends:
|
||||
aeson
|
||||
, base >=4.7 && <5
|
||||
, beeline-routing
|
||||
, bytestring
|
||||
, containers
|
||||
, http-types
|
||||
, json-fleece-aeson
|
||||
, json-fleece-core
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
, orb
|
||||
, safe-exceptions
|
||||
, shrubbery
|
||||
, text
|
||||
, time
|
||||
, wai
|
||||
, warp
|
||||
default-language: Haskell2010
|
||||
|
||||
executable sis-server
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Paths_sis_server
|
||||
autogen-modules:
|
||||
Paths_sis_server
|
||||
hs-source-dirs:
|
||||
app
|
||||
default-extensions:
|
||||
DerivingStrategies
|
||||
ImportQualifiedPost
|
||||
LambdaCase
|
||||
OverloadedStrings
|
||||
RecordWildCards
|
||||
TupleSections
|
||||
ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
aeson
|
||||
, base >=4.7 && <5
|
||||
, beeline-routing
|
||||
, bytestring
|
||||
, containers
|
||||
, http-types
|
||||
, json-fleece-aeson
|
||||
, json-fleece-core
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
, orb
|
||||
, safe-exceptions
|
||||
, shrubbery
|
||||
, sis-server
|
||||
, text
|
||||
, time
|
||||
, unix
|
||||
, wai
|
||||
, warp
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite sis-server-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Paths_sis_server
|
||||
autogen-modules:
|
||||
Paths_sis_server
|
||||
hs-source-dirs:
|
||||
test
|
||||
default-extensions:
|
||||
DerivingStrategies
|
||||
ImportQualifiedPost
|
||||
LambdaCase
|
||||
OverloadedStrings
|
||||
RecordWildCards
|
||||
TupleSections
|
||||
ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
|
||||
build-depends:
|
||||
aeson
|
||||
, base >=4.7 && <5
|
||||
, beeline-routing
|
||||
, bytestring
|
||||
, containers
|
||||
, hspec
|
||||
, http-types
|
||||
, json-fleece-aeson
|
||||
, json-fleece-core
|
||||
, mtl
|
||||
, optparse-applicative
|
||||
, safe-exceptions
|
||||
, shrubbery
|
||||
, sis-server
|
||||
, text
|
||||
, time
|
||||
, wai
|
||||
, warp
|
||||
default-language: Haskell2010
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -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"
|
||||
+28
@@ -0,0 +1,28 @@
|
||||
resolver: lts-24.38
|
||||
|
||||
packages:
|
||||
- .
|
||||
|
||||
extra-deps:
|
||||
- github: flipstone/beeline
|
||||
commit: e31206f52fec7e96c15de9a2bab9ef1876db137b
|
||||
subdirs:
|
||||
- beeline-params
|
||||
- beeline-routing
|
||||
- github: flipstone/shrubbery
|
||||
commit: a064ede07e01b753a6eb310fc24d9fd8da1ad826
|
||||
- github: flipstone/json-fleece
|
||||
commit: 77813eac694f937b6e013230825f03aba224f866
|
||||
subdirs:
|
||||
- json-fleece-aeson
|
||||
- json-fleece-core
|
||||
- github: flipstone/bounded-text
|
||||
commit: 3ef94eeda5402857423284d0c4e021a8c8032498
|
||||
- github: flipstone/orb
|
||||
commit: 74cceef9d0db9ac3ef1856613e7605750c8c0a2a
|
||||
- template-haskell-lift-0.1.0.0
|
||||
- template-haskell-quasiquoter-0.1.0.0
|
||||
|
||||
flags:
|
||||
orb:
|
||||
ci: true
|
||||
+111
@@ -0,0 +1,111 @@
|
||||
# This file was autogenerated by Stack.
|
||||
# You should not edit this file by hand.
|
||||
# For more information, please see the documentation at:
|
||||
# https://docs.haskellstack.org/en/stable/topics/lock_files
|
||||
|
||||
packages:
|
||||
- completed:
|
||||
name: beeline-params
|
||||
pantry-tree:
|
||||
sha256: 44791687ad987b596ff02fd1776386bef293a27e097c7c589a3bb76a9a81f200
|
||||
size: 1210
|
||||
sha256: 93fff6138e28d8989741b4fc8622096d2211dad35f1d113a341d89d0d3235d8f
|
||||
size: 36315
|
||||
subdir: beeline-params
|
||||
url: https://github.com/flipstone/beeline/archive/e31206f52fec7e96c15de9a2bab9ef1876db137b.tar.gz
|
||||
version: 0.3.0.0
|
||||
original:
|
||||
subdir: beeline-params
|
||||
url: https://github.com/flipstone/beeline/archive/e31206f52fec7e96c15de9a2bab9ef1876db137b.tar.gz
|
||||
- completed:
|
||||
name: beeline-routing
|
||||
pantry-tree:
|
||||
sha256: 555ab8a55094ffa801fa8ee8e8fc9b11ec21c08cff29e5dc152ae7f171fa3ccd
|
||||
size: 1119
|
||||
sha256: 93fff6138e28d8989741b4fc8622096d2211dad35f1d113a341d89d0d3235d8f
|
||||
size: 36315
|
||||
subdir: beeline-routing
|
||||
url: https://github.com/flipstone/beeline/archive/e31206f52fec7e96c15de9a2bab9ef1876db137b.tar.gz
|
||||
version: 0.3.0.2
|
||||
original:
|
||||
subdir: beeline-routing
|
||||
url: https://github.com/flipstone/beeline/archive/e31206f52fec7e96c15de9a2bab9ef1876db137b.tar.gz
|
||||
- completed:
|
||||
name: shrubbery
|
||||
pantry-tree:
|
||||
sha256: d16c6b171d9b360098760d2c2269ded8eaae823ed9aa5c7a36598673e83fb9e3
|
||||
size: 2834
|
||||
sha256: 8bb3b52a8f9cb3f6edc5ee0c4584c81187b05966d59d718a247a6707479e2e33
|
||||
size: 30344
|
||||
url: https://github.com/flipstone/shrubbery/archive/a064ede07e01b753a6eb310fc24d9fd8da1ad826.tar.gz
|
||||
version: 0.2.3.1
|
||||
original:
|
||||
url: https://github.com/flipstone/shrubbery/archive/a064ede07e01b753a6eb310fc24d9fd8da1ad826.tar.gz
|
||||
- completed:
|
||||
name: json-fleece-aeson
|
||||
pantry-tree:
|
||||
sha256: 1519042c7af52c169b4543d0de5639d344f3ea8652461fdc8d85f26b0d318f5a
|
||||
size: 628
|
||||
sha256: 534fdb939c428db16fc6c07d3fe1c709ebc0b5b43c490f89639d6093ea12d8f3
|
||||
size: 3095867
|
||||
subdir: json-fleece-aeson
|
||||
url: https://github.com/flipstone/json-fleece/archive/77813eac694f937b6e013230825f03aba224f866.tar.gz
|
||||
version: 0.5.1.0
|
||||
original:
|
||||
subdir: json-fleece-aeson
|
||||
url: https://github.com/flipstone/json-fleece/archive/77813eac694f937b6e013230825f03aba224f866.tar.gz
|
||||
- completed:
|
||||
name: json-fleece-core
|
||||
pantry-tree:
|
||||
sha256: 87d6a45a9b470843d28d1c2927b8f12ad4f687d987bad630e04ead9e824ee0a9
|
||||
size: 491
|
||||
sha256: 534fdb939c428db16fc6c07d3fe1c709ebc0b5b43c490f89639d6093ea12d8f3
|
||||
size: 3095867
|
||||
subdir: json-fleece-core
|
||||
url: https://github.com/flipstone/json-fleece/archive/77813eac694f937b6e013230825f03aba224f866.tar.gz
|
||||
version: 0.12.0.0
|
||||
original:
|
||||
subdir: json-fleece-core
|
||||
url: https://github.com/flipstone/json-fleece/archive/77813eac694f937b6e013230825f03aba224f866.tar.gz
|
||||
- completed:
|
||||
name: bounded-text
|
||||
pantry-tree:
|
||||
sha256: e98540b1877ae4709420472f83e8fd04b987eaeb914df72bb33b0bbe55debac2
|
||||
size: 2162
|
||||
sha256: 29c500737d8e481fe2e3325fe643a9cafc565ffd06b754bf14219f579d927f5d
|
||||
size: 11885
|
||||
url: https://github.com/flipstone/bounded-text/archive/3ef94eeda5402857423284d0c4e021a8c8032498.tar.gz
|
||||
version: 0.1.2.0
|
||||
original:
|
||||
url: https://github.com/flipstone/bounded-text/archive/3ef94eeda5402857423284d0c4e021a8c8032498.tar.gz
|
||||
- completed:
|
||||
name: orb
|
||||
pantry-tree:
|
||||
sha256: 8888da81f391b551df85ce50b9f8ec7349dcf87b3a062780cf71d915c8c7e0e1
|
||||
size: 6804
|
||||
sha256: 47bc481b103d86fe38bd0b94d09d88f242e657073108018a2e4652e695636f0f
|
||||
size: 1194518
|
||||
url: https://github.com/flipstone/orb/archive/74cceef9d0db9ac3ef1856613e7605750c8c0a2a.tar.gz
|
||||
version: 0.7.1.0
|
||||
original:
|
||||
url: https://github.com/flipstone/orb/archive/74cceef9d0db9ac3ef1856613e7605750c8c0a2a.tar.gz
|
||||
- completed:
|
||||
hackage: template-haskell-lift-0.1.0.0@sha256:f6cd3ee45b0c68480c400bfca9f08f39e8e87a5eb823f206dbe06ab1923a4f1c,1136
|
||||
pantry-tree:
|
||||
sha256: 56ab994094c839bebb643ce5fc58dfae6269517ebe91f380e259adaf1def08bf
|
||||
size: 243
|
||||
original:
|
||||
hackage: template-haskell-lift-0.1.0.0
|
||||
- completed:
|
||||
hackage: template-haskell-quasiquoter-0.1.0.0@sha256:71027c432c0fb1a293d0f2b1d46dd5be42b9703b7c4b2233ea8076bfc6f84aae,1181
|
||||
pantry-tree:
|
||||
sha256: f9f5177a522cc273c001dd5bd749e4f7ed841910c6136711b9b9825bc0bc9c56
|
||||
size: 257
|
||||
original:
|
||||
hackage: template-haskell-quasiquoter-0.1.0.0
|
||||
snapshots:
|
||||
- completed:
|
||||
sha256: abc790b571e0c70e929db74b329e3c18d7e76a6e173e8bdf94f1ba20770d4c24
|
||||
size: 728990
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/38.yaml
|
||||
original: lts-24.38
|
||||
@@ -0,0 +1,13 @@
|
||||
{- | Test entry point for sis-server.
|
||||
-}
|
||||
module Main (main) where
|
||||
|
||||
import Test.Hspec (Spec, describe, hspec, it, shouldBe)
|
||||
|
||||
main :: IO ()
|
||||
main = hspec spec
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Sis.Server" $
|
||||
it "health check returns ok" $
|
||||
True `shouldBe` True
|
||||
Reference in New Issue
Block a user