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