Compare commits
47 Commits
architectu
...
loops/host
| Author | SHA1 | Date | |
|---|---|---|---|
| 2713636e36 | |||
| c16924a991 | |||
| 962cb1b43e | |||
| 3369166a03 | |||
| b4974db25f | |||
| 11bb8c058c | |||
| 70759d6ab1 | |||
| 8e817e974f | |||
| e201eef686 | |||
| 6ed9e7dbe6 | |||
| 64985ff6f7 | |||
| 85e0af83f6 | |||
| 7c11d4edaa | |||
| 4e79b010b2 | |||
| e2a90e3bbd | |||
| 2217a704a6 | |||
| 014dd06d2b | |||
| d917a5f92f | |||
| bac80f6c0b | |||
| 11aba081f4 | |||
| ef7de817bb | |||
| 065fd248da | |||
| 2ffdd6f078 | |||
| d5a1c8370c | |||
| fe958bda69 | |||
| bd1e78c40f | |||
| 0366373c8a | |||
| 85aea61f3c | |||
| 7fb833f54c | |||
| 6b9df03d01 | |||
| 7d2d8478cc | |||
| b061442c06 | |||
| 30aece839b | |||
| 17ef5f50b3 | |||
| 078872728e | |||
| b1be3a36ec | |||
| 2551109ffa | |||
| 2b42aabe6b | |||
| 04b44401fb | |||
| b67709dab5 | |||
| fbc0c03f3a | |||
| 9a67ced748 | |||
| edff7735e7 | |||
| 55ec0b8f64 | |||
| b5a273cc99 | |||
| 66226b332b | |||
| 8fc7469a3c |
44
docker-compose.dev-sx-host.yml
Normal file
44
docker-compose.dev-sx-host.yml
Normal file
@@ -0,0 +1,44 @@
|
||||
# host-on-sx live service — the SX web host (lib/host) served by the native
|
||||
# http-listen server via lib/host/serve.sh. Joins the sx-dev project + externalnet
|
||||
# so Caddy can reverse_proxy a subdomain to it (blog.rose-ash.com). Isolated from
|
||||
# the sx_docs server: separate container, separate port.
|
||||
#
|
||||
# Usage:
|
||||
# docker compose -p sx-dev -f docker-compose.dev-sx-host.yml up -d sx_host
|
||||
# docker compose -p sx-dev -f docker-compose.dev-sx-host.yml logs -f sx_host
|
||||
# docker compose -p sx-dev -f docker-compose.dev-sx-host.yml down
|
||||
|
||||
services:
|
||||
sx_host:
|
||||
image: registry.rose-ash.com:5000/sx_docs:latest
|
||||
container_name: sx-dev-sx_host-1
|
||||
entrypoint: ["bash", "/app/lib/host/serve.sh"]
|
||||
working_dir: /app
|
||||
environment:
|
||||
SX_PROJECT_DIR: /app
|
||||
SX_SERVER: /app/bin/sx_server
|
||||
HOST_PORT: "8000"
|
||||
# Bind all interfaces so Caddy (on externalnet) can reach it.
|
||||
SX_HTTP_HOST: "0.0.0.0"
|
||||
# Durable persist store root — on a named volume so data survives restarts.
|
||||
SX_PERSIST_DIR: /data/persist
|
||||
OCAMLRUNPARAM: "b"
|
||||
volumes:
|
||||
# SX source (hot-reload on container restart)
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
# OCaml server binary — this worktree's build (has the SX_HTTP_HOST bind fix)
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
# Durable persist store (the SX op-log/kv on disk) — survives restarts.
|
||||
# Host dir, chowned to the image's appuser (uid 10001) so the non-root
|
||||
# server can write: sudo mkdir -p /root/sx-host-persist && sudo chown 10001:10001 /root/sx-host-persist
|
||||
- /root/sx-host-persist:/data/persist
|
||||
networks:
|
||||
- externalnet
|
||||
- default
|
||||
restart: unless-stopped
|
||||
|
||||
networks:
|
||||
externalnet:
|
||||
external: true
|
||||
@@ -745,8 +745,15 @@ let setup_evaluator_bridge env =
|
||||
| _ -> raise (Eval_error "http-listen: (port handler)") in
|
||||
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
||||
Unix.setsockopt sock Unix.SO_REUSEADDR true;
|
||||
(* Bind host: loopback by default (safe for tests + local runs); set
|
||||
SX_HTTP_HOST=0.0.0.0 to expose on the network (container/Caddy). *)
|
||||
let bind_addr =
|
||||
match Sys.getenv_opt "SX_HTTP_HOST" with
|
||||
| Some h -> (try Unix.inet_addr_of_string h
|
||||
with _ -> Unix.inet_addr_loopback)
|
||||
| None -> Unix.inet_addr_loopback in
|
||||
Unix.bind sock
|
||||
(Unix.ADDR_INET (Unix.inet_addr_loopback, port));
|
||||
(Unix.ADDR_INET (bind_addr, port));
|
||||
Unix.listen sock 64;
|
||||
(* SX runtime is shared across threads — serialize handler calls. *)
|
||||
let mtx = Mutex.create () in
|
||||
@@ -807,7 +814,15 @@ let setup_evaluator_bridge env =
|
||||
Hashtbl.replace req "body" (String body);
|
||||
Mutex.lock mtx;
|
||||
let resp =
|
||||
(try Sx_runtime.sx_call handler [Dict req]
|
||||
(* Run the handler through the IO-aware CEK runner (not bare
|
||||
sx_call) so request handlers can perform per-request IO —
|
||||
durable store reads/writes resolve via cek_run_with_io's
|
||||
suspension loop instead of returning an unresolved suspension. *)
|
||||
(try
|
||||
let st = Sx_ref.continue_with_call handler
|
||||
(List [Dict req]) (Env (Sx_types.make_env ()))
|
||||
(List [Dict req]) (List []) in
|
||||
cek_run_with_io st
|
||||
with e -> Mutex.unlock mtx; raise e) in
|
||||
Mutex.unlock mtx;
|
||||
let getk k = match resp with
|
||||
@@ -4854,6 +4869,14 @@ let () =
|
||||
else begin
|
||||
(* Normal persistent server mode *)
|
||||
let env = make_server_env () in
|
||||
(* render-page: render an (unevaluated) SX page/component expression to HTML
|
||||
using the server env, so http-listen handlers can serve interactive SX
|
||||
pages. render-to-html expands components + collects keyword attrs itself;
|
||||
SX handlers can't reach the server env, so this primitive supplies it. *)
|
||||
ignore (env_bind env "render-page" (NativeFn ("render-page", fun args ->
|
||||
match args with
|
||||
| expr :: _ -> String (sx_render_to_html expr env)
|
||||
| _ -> raise (Eval_error "render-page: (expr)"))));
|
||||
send "(ready)";
|
||||
(* Main command loop *)
|
||||
try
|
||||
|
||||
79
lib/dream/README.md
Normal file
79
lib/dream/README.md
Normal file
@@ -0,0 +1,79 @@
|
||||
# dream-on-sx
|
||||
|
||||
OCaml's [Dream](https://aantron.github.io/dream/) web framework, reimplemented in
|
||||
**plain SX** on the CEK evaluator. Dream is the cleanest middleware-shaped HTTP
|
||||
framework in any language, and it maps onto SX with almost no impedance:
|
||||
|
||||
| Dream | SX |
|
||||
|-------|-----|
|
||||
| `handler = request -> response promise` | `(fn (req) … (perform …))` |
|
||||
| `middleware = handler -> handler` | `(fn (next) (fn (req) …))` |
|
||||
| `m1 @@ m2 @@ handler` | `(m1 (m2 handler))` — left fold |
|
||||
| `Dream.run handler` | `(dream-run handler)` → `(perform (:http/listen …))` |
|
||||
|
||||
There are five types — **request, response, route**, and (as plain functions)
|
||||
**handler** and **middleware**. Everything else is a function over them.
|
||||
|
||||
## Quickstart
|
||||
|
||||
```lisp
|
||||
(dream-run
|
||||
(dream-make-app
|
||||
(list
|
||||
(dream-get "/" (fn (req) (dream-html "<h1>Hello, World!</h1>")))
|
||||
(dream-get "/hello/:name"
|
||||
(fn (req) (dream-text (str "Hi, " (dream-param req "name"))))))))
|
||||
```
|
||||
|
||||
`dream-make-app` wraps the router in the default stack (error catch + content-type).
|
||||
`dream-run` installs the root handler on the existing SX HTTP server — it does **not**
|
||||
open its own socket.
|
||||
|
||||
## Public surface
|
||||
|
||||
- **types** — `dream-request`/`dream-response`/`dream-route`, accessors
|
||||
(`dream-method`/`-path`/`-body`/`-header`/`-query-param`/`-param`), smart
|
||||
constructors (`dream-html`/`-text`/`-json`/`-empty`/`-not-found`/`-redirect`),
|
||||
convenience (`dream-queries`, `*-or` defaults, `dream-accepts?`/`dream-wants-json?`).
|
||||
- **router** — `dream-get`/`-post`/`-put`/`-delete`/`-patch`/`-head`/`-options`/`-any`,
|
||||
`dream-router`, `dream-scope` (prefix + middleware), `:name` params + `**` catch-all,
|
||||
405 + `Allow`, automatic HEAD.
|
||||
- **middleware** — `dream-pipeline`, `dream-no-middleware`, `dream-logger`,
|
||||
`dream-content-type`, `dream-set-header`, `dream-tap-request`.
|
||||
- **session** — `dream-sessions` / `dream-sessions-signed`, `dream-session-field` /
|
||||
`dream-set-session-field` / `dream-session-all` / `dream-invalidate-session`; cookie
|
||||
helpers (`dream-cookie`, `dream-set-cookie`, `dream-cookie-sign`/`-unsign`).
|
||||
- **flash** — `dream-flash`, `dream-add-flash-message`, `dream-flash-messages`.
|
||||
- **form** — `dream-form` (Ok/Err), `dream-form-fields`, `dream-multipart`, CSRF
|
||||
(`dream-csrf` / `dream-csrf-protect` / `dream-csrf-token` / `dream-csrf-tag`).
|
||||
- **websocket** — `dream-websocket`, `dream-send`/`-receive`/`-close`/`-broadcast`.
|
||||
- **static** — `dream-static` (mime, ETags, 304, ranges, traversal guard).
|
||||
- **error** — `dream-catch`, `dream-status-text`/`-line`, `dream-status-page`.
|
||||
- **cors** — `dream-cors`, `dream-cors-origin`, `dream-cors-with`.
|
||||
- **json** — `dream-json-encode`/`-parse`, `dream-json-value`, `dream-json-body`.
|
||||
- **run / api** — `dream-run`/`-port`/`-opts`, `dream-app`, `dream-make-app`,
|
||||
`dream-serve`.
|
||||
|
||||
## Testing story
|
||||
|
||||
Every effectful concern is **dependency-injected**, so the whole framework is testable
|
||||
without a running host:
|
||||
|
||||
- sessions take a backend `(fn (op) …)` — `dream-memory-sessions` for tests,
|
||||
`dream-perform-sessions` in production;
|
||||
- static files take an fs — `dream-memory-fs` vs `dream-static-perform-fs`;
|
||||
- websockets take an io — `dream-mock-ws` vs `dream-ws-perform-io`;
|
||||
- `dream-run` takes a listen transport (`dream-run-with`).
|
||||
|
||||
Run the suite: `bash lib/dream/conformance.sh` (367 tests, 14 suites).
|
||||
|
||||
## Notes & caveats
|
||||
|
||||
- Headers are dicts with **lowercased string keys** (in SX keywords *are* strings, so
|
||||
`:content-type` == `"content-type"`).
|
||||
- Outgoing cookies accumulate in a `:set-cookies` list on the response so multiple
|
||||
`Set-Cookie` headers don't collide.
|
||||
- The CSRF/cookie/ETag signing uses a pure-SX keyed hash — **not cryptographic**.
|
||||
Production should inject a host HMAC (`dream-csrf-with`, and the signed-session
|
||||
secret path).
|
||||
- JSON and multipart are in-memory (not streaming).
|
||||
33
lib/dream/api.sx
Normal file
33
lib/dream/api.sx
Normal file
@@ -0,0 +1,33 @@
|
||||
;; lib/dream/api.sx — Dream-on-SX public facade.
|
||||
;; Loaded last; bundles the modules into a batteries-included surface. The full
|
||||
;; public API is the `dream-*` functions across types/router/middleware/session/
|
||||
;; flash/form/websocket/static/error/cors/json/run; this file adds convenience
|
||||
;; app builders. Depends on all other dream modules.
|
||||
|
||||
(define dream-version "0.1.0")
|
||||
|
||||
;; standard middleware stack (pure — no IO): error catch outermost, then
|
||||
;; content-type sniffing. Logger is opt-in since it performs host IO.
|
||||
(define
|
||||
dream-defaults
|
||||
(fn
|
||||
(handler)
|
||||
(dream-pipeline (list dream-catch dream-content-type) handler)))
|
||||
|
||||
;; build a complete app handler from a route list with the default stack
|
||||
(define
|
||||
dream-make-app
|
||||
(fn (routes) (dream-defaults (dream-router routes))))
|
||||
|
||||
;; build an app and wrap it with extra middleware (outermost first)
|
||||
(define
|
||||
dream-make-app-with
|
||||
(fn
|
||||
(middlewares routes)
|
||||
(dream-pipeline middlewares (dream-make-app routes))))
|
||||
|
||||
;; one-call serve: routes + opts -> installed on the host
|
||||
(define
|
||||
dream-serve
|
||||
(fn (routes opts) (dream-run-opts (dream-make-app routes) opts)))
|
||||
(define dream-serve-port (fn (routes port) (dream-serve routes {:port port})))
|
||||
172
lib/dream/auth.sx
Normal file
172
lib/dream/auth.sx
Normal file
@@ -0,0 +1,172 @@
|
||||
;; lib/dream/auth.sx — Dream-on-SX authentication helpers.
|
||||
;; HTTP Basic auth (with a pure-SX base64 codec) and Bearer-token guards.
|
||||
;; Depends on types.sx.
|
||||
|
||||
;; ── base64 (pure SX; arithmetic, no bitwise) ───────────────────────
|
||||
(define
|
||||
dr/b64-alpha
|
||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
|
||||
(define dr/b64-char (fn (n) (char-at dr/b64-alpha n)))
|
||||
(define dr/b64-index (fn (c) (index-of dr/b64-alpha c)))
|
||||
|
||||
(define
|
||||
dr/b64-encode-loop
|
||||
(fn
|
||||
(s i n acc)
|
||||
(if
|
||||
(>= i n)
|
||||
acc
|
||||
(let
|
||||
((b0 (char-code (char-at s i))) (rem (- n i)))
|
||||
(cond
|
||||
((>= rem 3)
|
||||
(let
|
||||
((triple (+ (* b0 65536) (* (char-code (char-at s (+ i 1))) 256) (char-code (char-at s (+ i 2))))))
|
||||
(dr/b64-encode-loop
|
||||
s
|
||||
(+ i 3)
|
||||
n
|
||||
(str
|
||||
acc
|
||||
(dr/b64-char (mod (quotient triple 262144) 64))
|
||||
(dr/b64-char (mod (quotient triple 4096) 64))
|
||||
(dr/b64-char (mod (quotient triple 64) 64))
|
||||
(dr/b64-char (mod triple 64))))))
|
||||
((= rem 2)
|
||||
(let
|
||||
((triple (+ (* b0 65536) (* (char-code (char-at s (+ i 1))) 256))))
|
||||
(str
|
||||
acc
|
||||
(dr/b64-char (mod (quotient triple 262144) 64))
|
||||
(dr/b64-char (mod (quotient triple 4096) 64))
|
||||
(dr/b64-char (mod (quotient triple 64) 64))
|
||||
"=")))
|
||||
(else
|
||||
(let
|
||||
((triple (* b0 65536)))
|
||||
(str
|
||||
acc
|
||||
(dr/b64-char (mod (quotient triple 262144) 64))
|
||||
(dr/b64-char (mod (quotient triple 4096) 64))
|
||||
"=="))))))))
|
||||
|
||||
(define
|
||||
dream-base64-encode
|
||||
(fn (s) (dr/b64-encode-loop s 0 (string-length s) "")))
|
||||
|
||||
(define
|
||||
dr/b64-decode-loop
|
||||
(fn
|
||||
(s i n acc)
|
||||
(if
|
||||
(>= i n)
|
||||
acc
|
||||
(let
|
||||
((p2 (char-at s (+ i 2)))
|
||||
(p3 (char-at s (+ i 3))))
|
||||
(let
|
||||
((c0 (dr/b64-index (char-at s i)))
|
||||
(c1 (dr/b64-index (char-at s (+ i 1))))
|
||||
(c2 (if (= p2 "=") 0 (dr/b64-index p2)))
|
||||
(c3 (if (= p3 "=") 0 (dr/b64-index p3))))
|
||||
(let
|
||||
((triple (+ (* c0 262144) (* c1 4096) (* c2 64) c3)))
|
||||
(dr/b64-decode-loop
|
||||
s
|
||||
(+ i 4)
|
||||
n
|
||||
(str
|
||||
acc
|
||||
(char-from-code
|
||||
(mod (quotient triple 65536) 256))
|
||||
(if
|
||||
(= p2 "=")
|
||||
""
|
||||
(char-from-code
|
||||
(mod (quotient triple 256) 256)))
|
||||
(if (= p3 "=") "" (char-from-code (mod triple 256)))))))))))
|
||||
|
||||
(define
|
||||
dream-base64-decode
|
||||
(fn
|
||||
(s)
|
||||
(if (= s "") "" (dr/b64-decode-loop s 0 (string-length s) ""))))
|
||||
|
||||
;; ── Authorization header parsing ───────────────────────────────────
|
||||
(define dream-authorization (fn (req) (dream-header req "authorization")))
|
||||
|
||||
(define
|
||||
dream-bearer-token
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((a (dream-authorization req)))
|
||||
(if (and a (starts-with? a "Bearer ")) (substr a 7) nil))))
|
||||
|
||||
(define
|
||||
dream-basic-credentials
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((a (dream-authorization req)))
|
||||
(if
|
||||
(and a (starts-with? a "Basic "))
|
||||
(let
|
||||
((decoded (dream-base64-decode (substr a 6))))
|
||||
(let
|
||||
((colon (index-of decoded ":")))
|
||||
(if (< colon 0) nil {:pass (substr decoded (+ colon 1)) :user (substr decoded 0 colon)})))
|
||||
nil))))
|
||||
|
||||
;; ── Basic auth middleware ──────────────────────────────────────────
|
||||
;; check is (fn (user pass) -> bool). On success the request gains :dream-user.
|
||||
(define
|
||||
dr/www-authenticate
|
||||
(fn
|
||||
(realm)
|
||||
(dream-add-header
|
||||
(dream-response 401 {:content-type "text/plain; charset=utf-8"} "Unauthorized")
|
||||
"www-authenticate"
|
||||
(str "Basic realm=\"" realm "\""))))
|
||||
|
||||
(define
|
||||
dream-basic-auth
|
||||
(fn
|
||||
(realm check)
|
||||
(fn
|
||||
(next)
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((creds (dream-basic-credentials req)))
|
||||
(if
|
||||
(and creds (check (get creds :user) (get creds :pass)))
|
||||
(next (assoc req :dream-user (get creds :user)))
|
||||
(dr/www-authenticate realm)))))))
|
||||
|
||||
(define dream-user (fn (req) (get req :dream-user)))
|
||||
|
||||
;; ── Bearer-token middleware ────────────────────────────────────────
|
||||
;; check is (fn (token) -> principal | nil). On success the request gains
|
||||
;; :dream-principal. Missing/invalid -> 401.
|
||||
(define
|
||||
dream-require-bearer
|
||||
(fn
|
||||
(check)
|
||||
(fn
|
||||
(next)
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((tok (dream-bearer-token req)))
|
||||
(let
|
||||
((principal (if tok (check tok) nil)))
|
||||
(if
|
||||
(nil? principal)
|
||||
(dream-add-header
|
||||
(dream-response 401 {:content-type "text/plain; charset=utf-8"} "Unauthorized")
|
||||
"www-authenticate"
|
||||
"Bearer")
|
||||
(next (assoc req :dream-principal principal)))))))))
|
||||
|
||||
(define dream-principal (fn (req) (get req :dream-principal)))
|
||||
122
lib/dream/conformance.sh
Normal file
122
lib/dream/conformance.sh
Normal file
@@ -0,0 +1,122 @@
|
||||
#!/usr/bin/env bash
|
||||
# dream-on-sx conformance runner — loads all dream modules + test suites in one
|
||||
# sx_server process and reports pass/fail per suite.
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/dream/conformance.sh # run all suites
|
||||
# bash lib/dream/conformance.sh -v # verbose (list each suite)
|
||||
|
||||
set -uo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
fi
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
echo "ERROR: sx_server.exe not found." >&2
|
||||
exit 1
|
||||
fi
|
||||
|
||||
VERBOSE="${1:-}"
|
||||
|
||||
# Dream library modules loaded before any test suite.
|
||||
MODULES=(
|
||||
"lib/dream/types.sx"
|
||||
"lib/dream/router.sx"
|
||||
"lib/dream/middleware.sx"
|
||||
"lib/dream/session.sx"
|
||||
"lib/dream/flash.sx"
|
||||
"lib/dream/form.sx"
|
||||
"lib/dream/websocket.sx"
|
||||
"lib/dream/static.sx"
|
||||
"lib/dream/error.sx"
|
||||
"lib/dream/cors.sx"
|
||||
"lib/dream/json.sx"
|
||||
"lib/dream/auth.sx"
|
||||
"lib/dream/html.sx"
|
||||
"lib/dream/headers.sx"
|
||||
"lib/dream/run.sx"
|
||||
"lib/dream/api.sx"
|
||||
"lib/dream/demos/hello.sx"
|
||||
"lib/dream/demos/counter.sx"
|
||||
"lib/dream/demos/chat.sx"
|
||||
"lib/dream/demos/todo.sx"
|
||||
)
|
||||
|
||||
# Suites: NAME RUNNER-FN PATH
|
||||
SUITES=(
|
||||
"types dream-ty-tests-run! lib/dream/tests/types.sx"
|
||||
"router dream-rt-tests-run! lib/dream/tests/router.sx"
|
||||
"middleware dream-mw-tests-run! lib/dream/tests/middleware.sx"
|
||||
"session dream-ss-tests-run! lib/dream/tests/session.sx"
|
||||
"flash dream-fl-tests-run! lib/dream/tests/flash.sx"
|
||||
"form dream-fo-tests-run! lib/dream/tests/form.sx"
|
||||
"websocket dream-ws-tests-run! lib/dream/tests/websocket.sx"
|
||||
"static dream-st-tests-run! lib/dream/tests/static.sx"
|
||||
"error dream-er-tests-run! lib/dream/tests/error.sx"
|
||||
"cors dream-co-tests-run! lib/dream/tests/cors.sx"
|
||||
"json dream-js-tests-run! lib/dream/tests/json.sx"
|
||||
"auth dream-au-tests-run! lib/dream/tests/auth.sx"
|
||||
"html dream-ht-tests-run! lib/dream/tests/html.sx"
|
||||
"headers dream-hd-tests-run! lib/dream/tests/headers.sx"
|
||||
"run dream-rn-tests-run! lib/dream/tests/run.sx"
|
||||
"api dream-ap-tests-run! lib/dream/tests/api.sx"
|
||||
"demos dream-dm-tests-run! lib/dream/tests/demos.sx"
|
||||
)
|
||||
|
||||
TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
|
||||
EPOCH=1
|
||||
emit_load () { echo "(epoch $EPOCH)"; echo "(load \"$1\")"; EPOCH=$((EPOCH+1)); }
|
||||
emit_eval () { echo "(epoch $EPOCH)"; echo "(eval \"$1\")"; EPOCH=$((EPOCH+1)); }
|
||||
|
||||
{
|
||||
for M in "${MODULES[@]}"; do emit_load "$M"; done
|
||||
for SUITE in "${SUITES[@]}"; do
|
||||
read -r _NAME _RUNNER FILE <<< "$SUITE"
|
||||
emit_load "$FILE"
|
||||
emit_eval "($_RUNNER)"
|
||||
done
|
||||
} > "$TMPFILE"
|
||||
|
||||
OUTPUT=$(timeout 540 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
|
||||
|
||||
TOTAL_PASS=0
|
||||
TOTAL_FAIL=0
|
||||
FAILED_SUITES=()
|
||||
LAST_DICT_LINES=$(echo "$OUTPUT" | grep -E '^\{:' || true)
|
||||
|
||||
I=0
|
||||
while read -r LINE; do
|
||||
[ -z "$LINE" ] && continue
|
||||
P=$(echo "$LINE" | grep -oE ':passed [0-9]+' | awk '{print $2}')
|
||||
F=$(echo "$LINE" | grep -oE ':failed [0-9]+' | awk '{print $2}')
|
||||
[ -z "$P" ] && P=0
|
||||
[ -z "$F" ] && F=0
|
||||
SUITE_INFO="${SUITES[$I]}"
|
||||
SUITE_NAME=$(echo "$SUITE_INFO" | awk '{print $1}')
|
||||
TOTAL_PASS=$((TOTAL_PASS + P))
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + F))
|
||||
if [ "$F" -gt 0 ]; then
|
||||
FAILED_SUITES+=("$SUITE_NAME: $P/$((P+F))")
|
||||
printf 'X %-12s %d/%d\n' "$SUITE_NAME" "$P" "$((P+F))"
|
||||
echo "$LINE" | grep -oE ':name "[^"]*"' | sed 's/:name / fail: /'
|
||||
elif [ "$VERBOSE" = "-v" ]; then
|
||||
printf 'ok %-12s %d passed\n' "$SUITE_NAME" "$P"
|
||||
fi
|
||||
I=$((I+1))
|
||||
done <<< "$LAST_DICT_LINES"
|
||||
|
||||
TOTAL=$((TOTAL_PASS + TOTAL_FAIL))
|
||||
if [ "$TOTAL" -eq 0 ]; then
|
||||
echo "ERROR: no suite results parsed. Raw output:" >&2
|
||||
echo "$OUTPUT" >&2
|
||||
exit 1
|
||||
fi
|
||||
if [ $TOTAL_FAIL -eq 0 ]; then
|
||||
echo "ok $TOTAL_PASS/$TOTAL dream-on-sx tests passed (${#SUITES[@]} suites)"
|
||||
else
|
||||
echo "FAIL $TOTAL_PASS/$TOTAL passed, $TOTAL_FAIL failed:"
|
||||
for S in "${FAILED_SUITES[@]}"; do echo " $S"; done
|
||||
exit 1
|
||||
fi
|
||||
51
lib/dream/cors.sx
Normal file
51
lib/dream/cors.sx
Normal file
@@ -0,0 +1,51 @@
|
||||
;; lib/dream/cors.sx — Dream-on-SX CORS middleware.
|
||||
;; Decorates responses with Access-Control-Allow-* headers and short-circuits
|
||||
;; preflight OPTIONS requests with a 204. Depends on types.sx.
|
||||
|
||||
(define dream-cors-defaults {:methods "GET, POST, PUT, PATCH, DELETE, OPTIONS" :headers "Content-Type" :max-age 86400 :credentials false :origin "*"})
|
||||
|
||||
(define
|
||||
dr/cors-origin-headers
|
||||
(fn
|
||||
(opts resp)
|
||||
(let
|
||||
((r1 (dream-add-header resp "access-control-allow-origin" (get opts :origin))))
|
||||
(if
|
||||
(get opts :credentials)
|
||||
(dream-add-header r1 "access-control-allow-credentials" "true")
|
||||
r1))))
|
||||
|
||||
(define
|
||||
dr/cors-preflight
|
||||
(fn
|
||||
(opts)
|
||||
(dr/cors-origin-headers
|
||||
opts
|
||||
(dream-add-header
|
||||
(dream-add-header
|
||||
(dream-add-header
|
||||
(dream-empty 204)
|
||||
"access-control-allow-methods"
|
||||
(get opts :methods))
|
||||
"access-control-allow-headers"
|
||||
(get opts :headers))
|
||||
"access-control-max-age"
|
||||
(str (get opts :max-age))))))
|
||||
|
||||
(define
|
||||
dream-cors-with
|
||||
(fn
|
||||
(opts)
|
||||
(fn
|
||||
(next)
|
||||
(fn
|
||||
(req)
|
||||
(if
|
||||
(= (dream-method req) "OPTIONS")
|
||||
(dr/cors-preflight opts)
|
||||
(dr/cors-origin-headers opts (next req)))))))
|
||||
|
||||
(define dream-cors (dream-cors-with dream-cors-defaults))
|
||||
(define
|
||||
dream-cors-origin
|
||||
(fn (origin) (dream-cors-with (assoc dream-cors-defaults :origin origin))))
|
||||
46
lib/dream/demos/chat.sx
Normal file
46
lib/dream/demos/chat.sx
Normal file
@@ -0,0 +1,46 @@
|
||||
;; lib/dream/demos/chat.sx — multi-room WebSocket chat (chat.ml).
|
||||
;; A room registry holds the live connections per room; each ws session joins its
|
||||
;; room, broadcasts every received message to the room, and leaves on close.
|
||||
|
||||
(define dream-chat-rooms (fn () (let ((rooms {})) {:join (fn (room ws) (set! rooms (assoc rooms room (concat (or (get rooms room) (list)) (list ws))))) :broadcast (fn (room msg) (for-each (fn (w) (dream-send w msg)) (or (get rooms room) (list)))) :members (fn (room) (or (get rooms room) (list))) :leave (fn (room ws) (set! rooms (assoc rooms room (filter (fn (w) (not (= w ws))) (or (get rooms room) (list))))))})))
|
||||
|
||||
(define
|
||||
dream-chat-loop
|
||||
(fn
|
||||
(rooms room ws)
|
||||
(let
|
||||
((m (dream-receive ws)))
|
||||
(if
|
||||
(nil? m)
|
||||
(begin ((get rooms :leave) room ws) (dream-close ws))
|
||||
(begin
|
||||
((get rooms :broadcast) room m)
|
||||
(dream-chat-loop rooms room ws))))))
|
||||
|
||||
(define
|
||||
dream-chat-session
|
||||
(fn
|
||||
(rooms room)
|
||||
(fn
|
||||
(ws)
|
||||
(begin ((get rooms :join) room ws) (dream-chat-loop rooms room ws)))))
|
||||
|
||||
(define
|
||||
dream-chat-route
|
||||
(fn
|
||||
(rooms)
|
||||
(fn
|
||||
(req)
|
||||
((dream-websocket (dream-chat-session rooms (dream-param req "room")))
|
||||
req))))
|
||||
|
||||
(define
|
||||
dream-chat-app-with
|
||||
(fn
|
||||
(rooms)
|
||||
(dream-router
|
||||
(list
|
||||
(dream-get "/" (fn (req) (dream-html "<h1>Rooms</h1>")))
|
||||
(dream-get "/chat/:room" (dream-chat-route rooms))))))
|
||||
|
||||
;; entry point: (dream-run (dream-chat-app-with (dream-chat-rooms)))
|
||||
35
lib/dream/demos/counter.sx
Normal file
35
lib/dream/demos/counter.sx
Normal file
@@ -0,0 +1,35 @@
|
||||
;; lib/dream/demos/counter.sx — per-session visit counter (counter.ml).
|
||||
;; Demonstrates the session middleware: each browser session keeps its own count.
|
||||
|
||||
(define
|
||||
dream-counter-handler
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((n (+ 1 (or (dream-session-field req "count") 0))))
|
||||
(begin
|
||||
(dream-set-session-field req "count" n)
|
||||
(dream-html (str "<p>You have visited this page " n " time(s).</p>"))))))
|
||||
|
||||
;; reset clears the session counter
|
||||
(define
|
||||
dream-counter-reset
|
||||
(fn
|
||||
(req)
|
||||
(begin
|
||||
(dream-set-session-field req "count" 0)
|
||||
(dream-redirect "/"))))
|
||||
|
||||
(define
|
||||
dream-counter-app-with
|
||||
(fn
|
||||
(backend)
|
||||
((dream-sessions backend)
|
||||
(dream-router
|
||||
(list
|
||||
(dream-get "/" dream-counter-handler)
|
||||
(dream-post "/reset" dream-counter-reset))))))
|
||||
|
||||
(define dream-counter-app (dream-counter-app-with (dream-memory-sessions)))
|
||||
|
||||
;; entry point: (dream-run (dream-counter-app-with (dream-memory-sessions)))
|
||||
16
lib/dream/demos/hello.sx
Normal file
16
lib/dream/demos/hello.sx
Normal file
@@ -0,0 +1,16 @@
|
||||
;; lib/dream/demos/hello.sx — the canonical Dream "Hello, World!" (hello.ml).
|
||||
;; Dream.run (Dream.router [Dream.get "/" (fun _ -> Dream.html "Hello!")]).
|
||||
|
||||
(define
|
||||
dream-hello-app
|
||||
(dream-router
|
||||
(list
|
||||
(dream-get "/" (fn (req) (dream-html "<h1>Hello, World!</h1>")))
|
||||
(dream-get
|
||||
"/hello/:name"
|
||||
(fn
|
||||
(req)
|
||||
(dream-html (str "<h1>Hello, " (dream-param req "name") "!</h1>")))))))
|
||||
|
||||
;; entry point (installs the handler on the host):
|
||||
;; (dream-run dream-hello-app)
|
||||
96
lib/dream/demos/todo.sx
Normal file
96
lib/dream/demos/todo.sx
Normal file
@@ -0,0 +1,96 @@
|
||||
;; lib/dream/demos/todo.sx — CRUD todo list with forms + CSRF (todo.ml).
|
||||
;; An in-memory store holds items; add/toggle/delete go through POST forms guarded
|
||||
;; by the CSRF middleware. User text is HTML-escaped on render (dream-escape).
|
||||
;; Wires session -> csrf -> router.
|
||||
|
||||
(define
|
||||
dream-todo-store
|
||||
(fn () (let ((items (list)) (next-id 0)) {:all (fn () items) :add (fn (text) (begin (set! next-id (+ next-id 1)) (set! items (concat items (list {:id next-id :text text :done false}))) next-id)) :delete (fn (id) (set! items (filter (fn (it) (not (= (get it :id) id))) items))) :toggle (fn (id) (set! items (map (fn (it) (if (= (get it :id) id) (assoc it :done (not (get it :done))) it)) items)))})))
|
||||
|
||||
(define
|
||||
dr/todo-render
|
||||
(fn
|
||||
(store req)
|
||||
(str
|
||||
"<ul>"
|
||||
(reduce
|
||||
(fn
|
||||
(acc it)
|
||||
(str
|
||||
acc
|
||||
"<li>"
|
||||
(if (get it :done) "[x] " "[ ] ")
|
||||
(dream-escape (get it :text))
|
||||
"</li>"))
|
||||
""
|
||||
((get store :all)))
|
||||
"</ul>"
|
||||
"<form method=\"post\" action=\"/add\">"
|
||||
(dream-csrf-tag req)
|
||||
"<input name=\"text\"><button>Add</button></form>")))
|
||||
|
||||
(define
|
||||
dream-todo-index
|
||||
(fn (store) (fn (req) (dream-html (dr/todo-render store req)))))
|
||||
|
||||
(define
|
||||
dream-todo-add
|
||||
(fn
|
||||
(store)
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((r (dream-form req)))
|
||||
(if
|
||||
(dream-ok? r)
|
||||
(begin
|
||||
((get store :add) (get (dream-ok-value r) "text"))
|
||||
(dream-redirect "/"))
|
||||
(dream-html-status
|
||||
403
|
||||
(str "Rejected: " (dream-err-reason r))))))))
|
||||
|
||||
(define
|
||||
dream-todo-toggle
|
||||
(fn
|
||||
(store)
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((r (dream-form req)))
|
||||
(if
|
||||
(dream-ok? r)
|
||||
(begin
|
||||
((get store :toggle) (parse-int (dream-param req "id")))
|
||||
(dream-redirect "/"))
|
||||
(dream-html-status 403 "Rejected"))))))
|
||||
|
||||
(define
|
||||
dream-todo-delete
|
||||
(fn
|
||||
(store)
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((r (dream-form req)))
|
||||
(if
|
||||
(dream-ok? r)
|
||||
(begin
|
||||
((get store :delete) (parse-int (dream-param req "id")))
|
||||
(dream-redirect "/"))
|
||||
(dream-html-status 403 "Rejected"))))))
|
||||
|
||||
(define
|
||||
dream-todo-app-with
|
||||
(fn
|
||||
(store backend secret)
|
||||
((dream-sessions backend)
|
||||
((dream-csrf secret)
|
||||
(dream-router
|
||||
(list
|
||||
(dream-get "/" (dream-todo-index store))
|
||||
(dream-post "/add" (dream-todo-add store))
|
||||
(dream-post "/toggle/:id" (dream-todo-toggle store))
|
||||
(dream-post "/delete/:id" (dream-todo-delete store))))))))
|
||||
|
||||
;; entry: (dream-run (dream-todo-app-with (dream-todo-store) (dream-memory-sessions) "change-me"))
|
||||
41
lib/dream/error.sx
Normal file
41
lib/dream/error.sx
Normal file
@@ -0,0 +1,41 @@
|
||||
;; lib/dream/error.sx — Dream-on-SX status phrases + error-handling middleware.
|
||||
;; dream-catch wraps a handler and turns a raised error into a 500 response (or a
|
||||
;; custom page). Depends on types.sx.
|
||||
|
||||
;; ── status reason phrases ──────────────────────────────────────────
|
||||
(define dr/status-texts {:206 "Partial Content" :202 "Accepted" :422 "Unprocessable Entity" :400 "Bad Request" :302 "Found" :204 "No Content" :502 "Bad Gateway" :429 "Too Many Requests" :301 "Moved Permanently" :415 "Unsupported Media Type" :405 "Method Not Allowed" :303 "See Other" :401 "Unauthorized" :304 "Not Modified" :503 "Service Unavailable" :404 "Not Found" :308 "Permanent Redirect" :504 "Gateway Timeout" :416 "Range Not Satisfiable" :500 "Internal Server Error" :307 "Temporary Redirect" :201 "Created" :501 "Not Implemented" :409 "Conflict" :200 "OK" :410 "Gone" :403 "Forbidden"})
|
||||
|
||||
(define
|
||||
dream-status-text
|
||||
(fn (status) (or (get dr/status-texts (str status)) "Unknown")))
|
||||
(define
|
||||
dream-status-line
|
||||
(fn (status) (str status " " (dream-status-text status))))
|
||||
|
||||
;; ── error-handling middleware ──────────────────────────────────────
|
||||
(define
|
||||
dream-default-error-page
|
||||
(fn
|
||||
(req e)
|
||||
(dream-html-status
|
||||
500
|
||||
(str "<h1>" (dream-status-line 500) "</h1>"))))
|
||||
|
||||
(define
|
||||
dream-catch-with
|
||||
(fn
|
||||
(on-error)
|
||||
(fn
|
||||
(next)
|
||||
(fn (req) (guard (e (true (on-error req e))) (next req))))))
|
||||
|
||||
(define dream-catch (dream-catch-with dream-default-error-page))
|
||||
|
||||
;; a fallback handler that renders a status page for any code
|
||||
(define
|
||||
dream-status-page
|
||||
(fn
|
||||
(status)
|
||||
(dream-html-status
|
||||
status
|
||||
(str "<h1>" (dream-status-line status) "</h1>"))))
|
||||
91
lib/dream/flash.sx
Normal file
91
lib/dream/flash.sx
Normal file
@@ -0,0 +1,91 @@
|
||||
;; lib/dream/flash.sx — Dream-on-SX flash messages.
|
||||
;; A single-request cookie store: messages added during one request are read on
|
||||
;; the NEXT request, then the cookie is cleared. Depends on types.sx + session.sx
|
||||
;; (shared cookie helpers). A message is {:category c :message m}.
|
||||
|
||||
;; ── cookie codec ───────────────────────────────────────────────────
|
||||
;; escape the field separators so categories/messages round-trip safely
|
||||
(define
|
||||
dr/flash-esc
|
||||
(fn (s) (replace (replace (replace s "%" "%25") "|" "%7C") "~" "%7E")))
|
||||
(define
|
||||
dr/flash-unesc
|
||||
(fn (s) (replace (replace (replace s "%7E" "~") "%7C" "|") "%25" "%")))
|
||||
|
||||
(define
|
||||
dr/flash-encode
|
||||
(fn
|
||||
(msgs)
|
||||
(join
|
||||
"~"
|
||||
(map
|
||||
(fn
|
||||
(m)
|
||||
(str
|
||||
(dr/flash-esc (get m :category))
|
||||
"|"
|
||||
(dr/flash-esc (get m :message))))
|
||||
msgs))))
|
||||
|
||||
(define
|
||||
dr/flash-decode
|
||||
(fn
|
||||
(s)
|
||||
(if
|
||||
(= s "")
|
||||
(list)
|
||||
(map
|
||||
(fn (part) (let ((i (index-of part "|"))) {:message (dr/flash-unesc (substr part (+ i 1))) :category (dr/flash-unesc (substr part 0 i))}))
|
||||
(split s "~")))))
|
||||
|
||||
;; ── mutable outbox cell ────────────────────────────────────────────
|
||||
(define dr/flash-box (fn () (let ((items (list))) {:add (fn (x) (set! items (concat items (list x)))) :get (fn () items)})))
|
||||
|
||||
;; ── middleware ─────────────────────────────────────────────────────
|
||||
(define dream-flash-cookie-name "dream.flash")
|
||||
|
||||
(define
|
||||
dream-flash
|
||||
(fn
|
||||
(next)
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((incoming (dr/flash-decode (or (dream-cookie req dream-flash-cookie-name) "")))
|
||||
(box (dr/flash-box)))
|
||||
(let
|
||||
((resp (next (assoc req :dream-flash {:box box :incoming incoming}))))
|
||||
(let
|
||||
((out ((get box :get))))
|
||||
(cond
|
||||
((not (empty? out))
|
||||
(dream-set-cookie
|
||||
resp
|
||||
dream-flash-cookie-name
|
||||
(dr/flash-encode out)
|
||||
{:path "/" :http-only true :same-site "Lax"}))
|
||||
((not (empty? incoming))
|
||||
(dream-drop-cookie resp dream-flash-cookie-name))
|
||||
(else resp))))))))
|
||||
|
||||
;; ── handler-facing API ─────────────────────────────────────────────
|
||||
(define
|
||||
dream-add-flash-message
|
||||
(fn
|
||||
(req category msg)
|
||||
(begin ((get (get (get req :dream-flash) :box) :add) {:message msg :category category}) req)))
|
||||
|
||||
(define
|
||||
dream-flash-messages
|
||||
(fn (req) (get (get req :dream-flash) :incoming)))
|
||||
(define dream-flash-category (fn (m) (get m :category)))
|
||||
(define dream-flash-message (fn (m) (get m :message)))
|
||||
|
||||
;; convenience: only messages of a given category
|
||||
(define
|
||||
dream-flash-of
|
||||
(fn
|
||||
(req category)
|
||||
(filter
|
||||
(fn (m) (= (get m :category) category))
|
||||
(dream-flash-messages req))))
|
||||
366
lib/dream/form.sx
Normal file
366
lib/dream/form.sx
Normal file
@@ -0,0 +1,366 @@
|
||||
;; lib/dream/form.sx — Dream-on-SX forms + CSRF.
|
||||
;; Parses application/x-www-form-urlencoded bodies; CSRF tokens are stateless,
|
||||
;; signed, and session-scoped. The signing function is injectable (a pure-SX keyed
|
||||
;; hash by default — production should swap in a host HMAC). Depends on types.sx +
|
||||
;; session.sx. dream-form returns an Ok/Err result value.
|
||||
|
||||
;; ── Result (Ok/Err) ────────────────────────────────────────────────
|
||||
(define dream-ok (fn (v) {:value v :result "ok"}))
|
||||
(define dream-err (fn (r) {:reason r :result "err"}))
|
||||
(define dream-ok? (fn (x) (= (get x :result) "ok")))
|
||||
(define dream-err? (fn (x) (= (get x :result) "err")))
|
||||
(define dream-ok-value (fn (x) (get x :value)))
|
||||
(define dream-err-reason (fn (x) (get x :reason)))
|
||||
|
||||
;; ── percent decoding ───────────────────────────────────────────────
|
||||
(define
|
||||
dr/hex-digit
|
||||
(fn
|
||||
(c)
|
||||
(let
|
||||
((n (char-code c)))
|
||||
(cond
|
||||
((and (>= n 48) (<= n 57)) (- n 48))
|
||||
((and (>= n 65) (<= n 70))
|
||||
(+ 10 (- n 65)))
|
||||
((and (>= n 97) (<= n 102))
|
||||
(+ 10 (- n 97)))
|
||||
(else 0)))))
|
||||
|
||||
(define
|
||||
dr/url-decode-loop
|
||||
(fn
|
||||
(s i n acc)
|
||||
(if
|
||||
(>= i n)
|
||||
acc
|
||||
(let
|
||||
((c (char-at s i)))
|
||||
(if
|
||||
(and (= c "%") (< (+ i 2) n))
|
||||
(dr/url-decode-loop
|
||||
s
|
||||
(+ i 3)
|
||||
n
|
||||
(str
|
||||
acc
|
||||
(char-from-code
|
||||
(+
|
||||
(* 16 (dr/hex-digit (char-at s (+ i 1))))
|
||||
(dr/hex-digit (char-at s (+ i 2)))))))
|
||||
(dr/url-decode-loop s (+ i 1) n (str acc c)))))))
|
||||
|
||||
(define
|
||||
dr/url-decode
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((s2 (replace s "+" " ")))
|
||||
(dr/url-decode-loop s2 0 (string-length s2) ""))))
|
||||
|
||||
;; ── substring splitter (split primitive is char-class based) ───────
|
||||
(define
|
||||
dr/split-on
|
||||
(fn
|
||||
(s sep)
|
||||
(let
|
||||
((i (index-of s sep)))
|
||||
(if
|
||||
(< i 0)
|
||||
(list s)
|
||||
(cons
|
||||
(substr s 0 i)
|
||||
(dr/split-on (substr s (+ i (string-length sep))) sep))))))
|
||||
|
||||
;; ── urlencoded body parsing ────────────────────────────────────────
|
||||
(define
|
||||
dr/parse-form-body
|
||||
(fn
|
||||
(body)
|
||||
(if
|
||||
(= body "")
|
||||
{}
|
||||
(reduce
|
||||
(fn
|
||||
(acc pair)
|
||||
(if
|
||||
(= pair "")
|
||||
acc
|
||||
(let
|
||||
((j (index-of pair "=")))
|
||||
(if
|
||||
(< j 0)
|
||||
(assoc acc (dr/url-decode pair) "")
|
||||
(assoc
|
||||
acc
|
||||
(dr/url-decode (substr pair 0 j))
|
||||
(dr/url-decode (substr pair (+ j 1))))))))
|
||||
{}
|
||||
(split body "&")))))
|
||||
|
||||
;; raw fields, no CSRF check
|
||||
(define dream-form-fields (fn (req) (dr/parse-form-body (dream-body req))))
|
||||
(define
|
||||
dream-form-field
|
||||
(fn (req name) (get (dream-form-fields req) name)))
|
||||
|
||||
;; ── CSRF signing (injectable; pure-SX keyed hash default) ──────────
|
||||
(define
|
||||
dr/poly-hash
|
||||
(fn (s base seed) (dr/poly-loop s 0 (string-length s) seed base)))
|
||||
(define
|
||||
dr/poly-loop
|
||||
(fn
|
||||
(s i n h base)
|
||||
(if
|
||||
(>= i n)
|
||||
h
|
||||
(dr/poly-loop
|
||||
s
|
||||
(+ i 1)
|
||||
n
|
||||
(mod (+ (* h base) (char-code (char-at s i))) 2147483647)
|
||||
base))))
|
||||
|
||||
;; NOTE: not cryptographic — adequate to demonstrate stateless CSRF; production
|
||||
;; should inject a real HMAC via dream-csrf-with.
|
||||
(define
|
||||
dream-csrf-sign-default
|
||||
(fn
|
||||
(secret msg)
|
||||
(let
|
||||
((m (str secret "|" msg)))
|
||||
(str
|
||||
(dr/poly-hash m 131 7)
|
||||
"-"
|
||||
(dr/poly-hash m 137 13)))))
|
||||
|
||||
(define dream-csrf-field-name "dream.csrf")
|
||||
|
||||
(define
|
||||
dr/csrf-make-token
|
||||
(fn (sign secret sid) (str sid "." (sign secret sid))))
|
||||
|
||||
(define
|
||||
dr/csrf-valid?
|
||||
(fn
|
||||
(sign secret sid token)
|
||||
(if
|
||||
(or (nil? token) (= token ""))
|
||||
false
|
||||
(let
|
||||
((dot (index-of token ".")))
|
||||
(if
|
||||
(< dot 0)
|
||||
false
|
||||
(let
|
||||
((tsid (substr token 0 dot))
|
||||
(tsig (substr token (+ dot 1))))
|
||||
(and (= tsid sid) (= tsig (sign secret sid)))))))))
|
||||
|
||||
;; ── CSRF middleware: attach signing context (needs session upstream) ──
|
||||
(define
|
||||
dream-csrf-with
|
||||
(fn
|
||||
(secret sign)
|
||||
(fn (next) (fn (req) (next (assoc req :dream-csrf {:sign sign :sid (dream-session-id req) :secret secret}))))))
|
||||
|
||||
(define
|
||||
dream-csrf
|
||||
(fn (secret) (dream-csrf-with secret dream-csrf-sign-default)))
|
||||
|
||||
(define dr/csrf-of (fn (req) (get req :dream-csrf)))
|
||||
|
||||
;; current token + hidden-input tag for templates
|
||||
(define
|
||||
dream-csrf-token
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((c (dr/csrf-of req)))
|
||||
(dr/csrf-make-token (get c :sign) (get c :secret) (get c :sid)))))
|
||||
|
||||
(define
|
||||
dream-csrf-tag
|
||||
(fn
|
||||
(req)
|
||||
(str
|
||||
"<input type=\"hidden\" name=\""
|
||||
dream-csrf-field-name
|
||||
"\" value=\""
|
||||
(dream-csrf-token req)
|
||||
"\">")))
|
||||
|
||||
;; ── dream-form: parse + verify CSRF -> Ok fields | Err reason ──────
|
||||
(define
|
||||
dream-form
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((c (dr/csrf-of req)))
|
||||
(if
|
||||
(nil? c)
|
||||
(dream-err :csrf-context-missing)
|
||||
(let
|
||||
((fields (dream-form-fields req)))
|
||||
(if
|
||||
(dr/csrf-valid?
|
||||
(get c :sign)
|
||||
(get c :secret)
|
||||
(get c :sid)
|
||||
(get fields dream-csrf-field-name))
|
||||
(dream-ok fields)
|
||||
(dream-err :csrf-token-invalid)))))))
|
||||
|
||||
;; ── CSRF auto-rejecting middleware (unsafe methods need a valid token) ──
|
||||
(define
|
||||
dr/csrf-safe-method?
|
||||
(fn (m) (or (= m "GET") (= m "HEAD") (= m "OPTIONS"))))
|
||||
|
||||
(define
|
||||
dream-csrf-protect-with
|
||||
(fn
|
||||
(secret sign)
|
||||
(fn
|
||||
(next)
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((req2 (assoc req :dream-csrf {:sign sign :sid (dream-session-id req) :secret secret})))
|
||||
(if
|
||||
(dr/csrf-safe-method? (dream-method req2))
|
||||
(next req2)
|
||||
(let
|
||||
((token (get (dream-form-fields req2) dream-csrf-field-name)))
|
||||
(if
|
||||
(dr/csrf-valid? sign secret (dream-session-id req2) token)
|
||||
(next req2)
|
||||
(dream-html-status 403 "CSRF token invalid")))))))))
|
||||
|
||||
(define
|
||||
dream-csrf-protect
|
||||
(fn (secret) (dream-csrf-protect-with secret dream-csrf-sign-default)))
|
||||
|
||||
;; ── multipart/form-data parsing ────────────────────────────────────
|
||||
;; In-memory (not yet streaming): parses the whole body into parts, each
|
||||
;; {:name :filename :content-type :content}. Returns Ok parts | Err :not-multipart.
|
||||
(define
|
||||
dr/multipart-boundary
|
||||
(fn
|
||||
(ctype)
|
||||
(let
|
||||
((i (index-of ctype "boundary=")))
|
||||
(if
|
||||
(< i 0)
|
||||
""
|
||||
(let
|
||||
((raw (trim (substr ctype (+ i 9)))))
|
||||
(if
|
||||
(starts-with? raw "\"")
|
||||
(substr raw 1 (- (string-length raw) 2))
|
||||
raw))))))
|
||||
|
||||
;; strip one leading and one trailing CRLF
|
||||
(define
|
||||
dr/strip-edges
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((s1 (if (starts-with? s "\r\n") (substr s 2) s)))
|
||||
(if
|
||||
(ends-with? s1 "\r\n")
|
||||
(substr s1 0 (- (string-length s1) 2))
|
||||
s1))))
|
||||
|
||||
;; value of attr="..." within a header block
|
||||
(define
|
||||
dr/cd-attr
|
||||
(fn
|
||||
(block attr)
|
||||
(let
|
||||
((key (str attr "=\"")))
|
||||
(let
|
||||
((i (index-of block key)))
|
||||
(if
|
||||
(< i 0)
|
||||
nil
|
||||
(let
|
||||
((rest (substr block (+ i (string-length key)))))
|
||||
(substr rest 0 (index-of rest "\""))))))))
|
||||
|
||||
;; value of a named header line within a header block
|
||||
(define
|
||||
dr/block-header
|
||||
(fn
|
||||
(block name)
|
||||
(reduce
|
||||
(fn
|
||||
(acc line)
|
||||
(if
|
||||
(and
|
||||
(nil? acc)
|
||||
(starts-with? (lower line) (str (lower name) ":")))
|
||||
(trim (substr line (+ (index-of line ":") 1)))
|
||||
acc))
|
||||
nil
|
||||
(dr/split-on block "\r\n"))))
|
||||
|
||||
(define
|
||||
dr/parse-part
|
||||
(fn
|
||||
(seg)
|
||||
(let
|
||||
((s (dr/strip-edges seg)))
|
||||
(let
|
||||
((sp (index-of s "\r\n\r\n")))
|
||||
(if
|
||||
(< sp 0)
|
||||
nil
|
||||
(let
|
||||
((block (substr s 0 sp))
|
||||
(content (substr s (+ sp 4))))
|
||||
{:name (dr/cd-attr block "name") :filename (dr/cd-attr block "filename") :content-type (dr/block-header block "content-type") :content content}))))))
|
||||
|
||||
(define
|
||||
dream-multipart
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((boundary (dr/multipart-boundary (or (dream-header req "content-type") ""))))
|
||||
(if
|
||||
(= boundary "")
|
||||
(dream-err :not-multipart)
|
||||
(let
|
||||
((segs (dr/split-on (dream-body req) (str "--" boundary))))
|
||||
(dream-ok
|
||||
(filter
|
||||
(fn (p) (not (nil? p)))
|
||||
(map
|
||||
dr/parse-part
|
||||
(filter (fn (seg) (starts-with? seg "\r\n")) segs)))))))))
|
||||
|
||||
;; accessors over a parts list
|
||||
(define
|
||||
dream-multipart-field
|
||||
(fn
|
||||
(parts name)
|
||||
(reduce
|
||||
(fn
|
||||
(acc p)
|
||||
(if (and (nil? acc) (= (get p :name) name)) (get p :content) acc))
|
||||
nil
|
||||
parts)))
|
||||
|
||||
(define
|
||||
dream-multipart-file
|
||||
(fn
|
||||
(parts name)
|
||||
(reduce
|
||||
(fn
|
||||
(acc p)
|
||||
(if
|
||||
(and (nil? acc) (= (get p :name) name) (get p :filename))
|
||||
p
|
||||
acc))
|
||||
nil
|
||||
parts)))
|
||||
54
lib/dream/headers.sx
Normal file
54
lib/dream/headers.sx
Normal file
@@ -0,0 +1,54 @@
|
||||
;; lib/dream/headers.sx — Dream-on-SX security headers + cache-control helpers.
|
||||
;; Depends on types.sx.
|
||||
|
||||
;; ── security headers middleware ────────────────────────────────────
|
||||
(define dream-security-defaults {:x-frame-options "DENY" :referrer-policy "no-referrer" :x-content-type-options "nosniff" :hsts false})
|
||||
|
||||
(define
|
||||
dr/apply-security
|
||||
(fn
|
||||
(opts resp)
|
||||
(let
|
||||
((r1 (dream-add-header (dream-add-header (dream-add-header resp "x-content-type-options" (get opts :x-content-type-options)) "x-frame-options" (get opts :x-frame-options)) "referrer-policy" (get opts :referrer-policy))))
|
||||
(if
|
||||
(get opts :hsts)
|
||||
(dream-add-header
|
||||
r1
|
||||
"strict-transport-security"
|
||||
"max-age=31536000; includeSubDomains")
|
||||
r1))))
|
||||
|
||||
(define
|
||||
dream-security-headers-with
|
||||
(fn (opts) (fn (next) (fn (req) (dr/apply-security opts (next req))))))
|
||||
(define
|
||||
dream-security-headers
|
||||
(dream-security-headers-with dream-security-defaults))
|
||||
|
||||
;; ── cache-control response helpers ─────────────────────────────────
|
||||
(define
|
||||
dream-cache
|
||||
(fn
|
||||
(resp seconds)
|
||||
(dream-add-header resp "cache-control" (str "public, max-age=" seconds))))
|
||||
(define
|
||||
dream-private-cache
|
||||
(fn
|
||||
(resp seconds)
|
||||
(dream-add-header resp "cache-control" (str "private, max-age=" seconds))))
|
||||
(define
|
||||
dream-no-store
|
||||
(fn (resp) (dream-add-header resp "cache-control" "no-store")))
|
||||
(define
|
||||
dream-no-cache
|
||||
(fn
|
||||
(resp)
|
||||
(dream-add-header
|
||||
resp
|
||||
"cache-control"
|
||||
"no-cache, no-store, must-revalidate")))
|
||||
|
||||
;; cache-control middleware: stamp a max-age on every response
|
||||
(define
|
||||
dream-cache-for
|
||||
(fn (seconds) (fn (next) (fn (req) (dream-cache (next req) seconds)))))
|
||||
24
lib/dream/html.sx
Normal file
24
lib/dream/html.sx
Normal file
@@ -0,0 +1,24 @@
|
||||
;; lib/dream/html.sx — Dream-on-SX HTML escaping for safe templating.
|
||||
;; Interpolating user input into HTML without escaping is an XSS hole; dream-escape
|
||||
;; neutralises it. Depends on nothing (pure string ops).
|
||||
|
||||
;; escape text for HTML element content / double-quoted attributes
|
||||
(define
|
||||
dream-escape
|
||||
(fn
|
||||
(s)
|
||||
(replace
|
||||
(replace
|
||||
(replace (replace (replace s "&" "&") "<" "<") ">" ">")
|
||||
"\""
|
||||
""")
|
||||
"'"
|
||||
"'")))
|
||||
|
||||
;; build a single attribute: name="escaped-value"
|
||||
(define dream-attr (fn (name val) (str name "=\"" (dream-escape val) "\"")))
|
||||
|
||||
;; join escaped text with a separator, escaping each piece
|
||||
(define
|
||||
dream-escape-join
|
||||
(fn (sep pieces) (join sep (map dream-escape pieces))))
|
||||
183
lib/dream/json.sx
Normal file
183
lib/dream/json.sx
Normal file
@@ -0,0 +1,183 @@
|
||||
;; lib/dream/json.sx — Dream-on-SX JSON encode/parse (pure SX).
|
||||
;; The host JSON primitives live in the ocaml-on-sx runtime, not the base env, so
|
||||
;; Dream ships its own. Depends on types.sx. (number? is unreliable in this env —
|
||||
;; type-of "number" is used instead.)
|
||||
|
||||
;; ── encoding ───────────────────────────────────────────────────────
|
||||
(define
|
||||
dr/json-escape
|
||||
(fn
|
||||
(s)
|
||||
(replace
|
||||
(replace
|
||||
(replace (replace (replace s "\\" "\\\\") "\"" "\\\"") "\n" "\\n")
|
||||
"\r"
|
||||
"\\r")
|
||||
"\t"
|
||||
"\\t")))
|
||||
(define dr/json-quote (fn (s) (str "\"" (dr/json-escape s) "\"")))
|
||||
|
||||
(define
|
||||
dream-json-encode
|
||||
(fn
|
||||
(v)
|
||||
(cond
|
||||
((nil? v) "null")
|
||||
((boolean? v) (if v "true" "false"))
|
||||
((= (type-of v) "number") (str v))
|
||||
((string? v) (dr/json-quote v))
|
||||
((list? v) (str "[" (join "," (map dream-json-encode v)) "]"))
|
||||
((dict? v)
|
||||
(str
|
||||
"{"
|
||||
(join
|
||||
","
|
||||
(map
|
||||
(fn
|
||||
(k)
|
||||
(str (dr/json-quote k) ":" (dream-json-encode (get v k))))
|
||||
(keys v)))
|
||||
"}"))
|
||||
(else (dr/json-quote (str v))))))
|
||||
|
||||
;; ── parsing (recursive descent; returns {:val :pos}) ───────────────
|
||||
(define
|
||||
dr/json-space?
|
||||
(fn (c) (or (= c " ") (= c "\n") (= c "\r") (= c "\t"))))
|
||||
(define
|
||||
dr/json-ws
|
||||
(fn
|
||||
(s i)
|
||||
(if
|
||||
(and (< i (string-length s)) (dr/json-space? (char-at s i)))
|
||||
(dr/json-ws s (+ i 1))
|
||||
i)))
|
||||
|
||||
(define
|
||||
dr/json-digit?
|
||||
(fn
|
||||
(c)
|
||||
(let ((n (char-code c))) (and (>= n 48) (<= n 57)))))
|
||||
(define
|
||||
dr/json-num-char?
|
||||
(fn
|
||||
(c)
|
||||
(or
|
||||
(dr/json-digit? c)
|
||||
(= c "-")
|
||||
(= c "+")
|
||||
(= c ".")
|
||||
(= c "e")
|
||||
(= c "E"))))
|
||||
(define
|
||||
dr/json-num-end
|
||||
(fn
|
||||
(s i)
|
||||
(if
|
||||
(and (< i (string-length s)) (dr/json-num-char? (char-at s i)))
|
||||
(dr/json-num-end s (+ i 1))
|
||||
i)))
|
||||
(define
|
||||
dr/json-to-number
|
||||
(fn
|
||||
(str-val)
|
||||
(if
|
||||
(or
|
||||
(contains? str-val ".")
|
||||
(contains? str-val "e")
|
||||
(contains? str-val "E"))
|
||||
(parse-float str-val)
|
||||
(parse-int str-val))))
|
||||
|
||||
(define
|
||||
dr/json-str
|
||||
(fn
|
||||
(s i acc)
|
||||
(let
|
||||
((c (char-at s i)))
|
||||
(cond
|
||||
((= c "\"") {:val acc :pos (+ i 1)})
|
||||
((= c "\\")
|
||||
(let
|
||||
((e (char-at s (+ i 1))))
|
||||
(cond
|
||||
((= e "n") (dr/json-str s (+ i 2) (str acc "\n")))
|
||||
((= e "r") (dr/json-str s (+ i 2) (str acc "\r")))
|
||||
((= e "t") (dr/json-str s (+ i 2) (str acc "\t")))
|
||||
(else (dr/json-str s (+ i 2) (str acc e))))))
|
||||
(else (dr/json-str s (+ i 1) (str acc c)))))))
|
||||
|
||||
(define
|
||||
dr/json-num
|
||||
(fn (s i) (let ((j (dr/json-num-end s i))) {:val (dr/json-to-number (substr s i (- j i))) :pos j})))
|
||||
|
||||
(define
|
||||
dr/json-arr
|
||||
(fn
|
||||
(s i acc)
|
||||
(let
|
||||
((i (dr/json-ws s i)))
|
||||
(if
|
||||
(= (char-at s i) "]")
|
||||
{:val acc :pos (+ i 1)}
|
||||
(let
|
||||
((r (dr/json-val s i)))
|
||||
(let
|
||||
((i2 (dr/json-ws s (get r :pos))))
|
||||
(if
|
||||
(= (char-at s i2) ",")
|
||||
(dr/json-arr
|
||||
s
|
||||
(+ i2 1)
|
||||
(concat acc (list (get r :val))))
|
||||
{:val (concat acc (list (get r :val))) :pos (+ i2 1)})))))))
|
||||
|
||||
(define
|
||||
dr/json-obj
|
||||
(fn
|
||||
(s i acc)
|
||||
(let
|
||||
((i (dr/json-ws s i)))
|
||||
(if
|
||||
(= (char-at s i) "}")
|
||||
{:val acc :pos (+ i 1)}
|
||||
(let
|
||||
((kr (dr/json-str s (+ i 1) "")))
|
||||
(let
|
||||
((i2 (dr/json-ws s (get kr :pos))))
|
||||
(let
|
||||
((vr (dr/json-val s (+ i2 1))))
|
||||
(let
|
||||
((i3 (dr/json-ws s (get vr :pos))))
|
||||
(if
|
||||
(= (char-at s i3) ",")
|
||||
(dr/json-obj
|
||||
s
|
||||
(+ i3 1)
|
||||
(assoc acc (get kr :val) (get vr :val)))
|
||||
{:val (assoc acc (get kr :val) (get vr :val)) :pos (+ i3 1)})))))))))
|
||||
|
||||
(define
|
||||
dr/json-val
|
||||
(fn
|
||||
(s i)
|
||||
(let
|
||||
((i (dr/json-ws s i)))
|
||||
(let
|
||||
((c (char-at s i)))
|
||||
(cond
|
||||
((= c "{") (dr/json-obj s (+ i 1) {}))
|
||||
((= c "[") (dr/json-arr s (+ i 1) (list)))
|
||||
((= c "\"") (dr/json-str s (+ i 1) ""))
|
||||
((= c "t") {:val true :pos (+ i 4)})
|
||||
((= c "f") {:val false :pos (+ i 5)})
|
||||
((= c "n") {:val nil :pos (+ i 4)})
|
||||
(else (dr/json-num s i)))))))
|
||||
|
||||
(define dream-json-parse (fn (s) (get (dr/json-val s 0) :val)))
|
||||
|
||||
;; ── responses ──────────────────────────────────────────────────────
|
||||
;; encode a value into a JSON response (dream-json takes a raw string body)
|
||||
(define dream-json-value (fn (v) (dream-json (dream-json-encode v))))
|
||||
;; read + parse the request body as JSON
|
||||
(define dream-json-body (fn (req) (dream-json-parse (dream-body req))))
|
||||
92
lib/dream/middleware.sx
Normal file
92
lib/dream/middleware.sx
Normal file
@@ -0,0 +1,92 @@
|
||||
;; lib/dream/middleware.sx — Dream-on-SX middleware.
|
||||
;; A middleware is handler->handler. Composition is plain function composition:
|
||||
;; m1 @@ m2 @@ handler = (m1 (m2 handler)). Depends on types.sx + router.sx
|
||||
;; (reuses dr/apply-middlewares for the fold).
|
||||
|
||||
;; ── composition ────────────────────────────────────────────────────
|
||||
;; (dream-pipeline (list m1 m2 m3) handler) = (m1 (m2 (m3 handler))).
|
||||
(define
|
||||
dream-pipeline
|
||||
(fn (middlewares handler) (dr/apply-middlewares middlewares handler)))
|
||||
|
||||
;; identity middleware
|
||||
(define dream-no-middleware (fn (next) next))
|
||||
|
||||
;; ── logger ─────────────────────────────────────────────────────────
|
||||
;; Parameterised on a clock and a sink so it is testable without IO.
|
||||
;; sink receives {:method :path :status :elapsed}.
|
||||
(define
|
||||
dream-logger-with
|
||||
(fn
|
||||
(clock sink)
|
||||
(fn
|
||||
(next)
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((t0 (clock)))
|
||||
(let ((resp (next req))) (begin (sink {:path (dream-path req) :status (dream-status resp) :method (dream-method req) :elapsed (- (clock) t0)}) resp)))))))
|
||||
|
||||
;; default logger performs host effects for the clock and the log sink
|
||||
(define
|
||||
dream-logger
|
||||
(dream-logger-with
|
||||
(fn () (perform (:dream-clock)))
|
||||
(fn (entry) (perform (:dream-log entry)))))
|
||||
|
||||
;; format a log entry as a one-line string (apache-ish)
|
||||
(define
|
||||
dream-log-line
|
||||
(fn
|
||||
(entry)
|
||||
(str
|
||||
(get entry :method)
|
||||
" "
|
||||
(get entry :path)
|
||||
" -> "
|
||||
(get entry :status)
|
||||
" ("
|
||||
(get entry :elapsed)
|
||||
"ms)")))
|
||||
|
||||
;; ── content-type sniffer ───────────────────────────────────────────
|
||||
(define
|
||||
dr/sniff-content-type
|
||||
(fn
|
||||
(body)
|
||||
(cond
|
||||
((= body "") "text/plain; charset=utf-8")
|
||||
((starts-with? body "<") "text/html; charset=utf-8")
|
||||
((starts-with? body "{") "application/json")
|
||||
((starts-with? body "[") "application/json")
|
||||
(else "text/plain; charset=utf-8"))))
|
||||
|
||||
;; sets Content-Type from the body only when the handler left it unset
|
||||
(define
|
||||
dream-content-type
|
||||
(fn
|
||||
(next)
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((resp (next req)))
|
||||
(if
|
||||
(dream-resp-header resp "content-type")
|
||||
resp
|
||||
(dream-add-header
|
||||
resp
|
||||
"content-type"
|
||||
(dr/sniff-content-type (dream-resp-body resp))))))))
|
||||
|
||||
;; ── small reusable middlewares ─────────────────────────────────────
|
||||
;; always attach a response header
|
||||
(define
|
||||
dream-set-header
|
||||
(fn
|
||||
(name val)
|
||||
(fn (next) (fn (req) (dream-add-header (next req) name val)))))
|
||||
|
||||
;; rewrite/observe the request before the handler sees it
|
||||
(define
|
||||
dream-tap-request
|
||||
(fn (f) (fn (next) (fn (req) (next (f req))))))
|
||||
170
lib/dream/router.sx
Normal file
170
lib/dream/router.sx
Normal file
@@ -0,0 +1,170 @@
|
||||
;; lib/dream/router.sx — Dream-on-SX routing.
|
||||
;; Routes are dicts {:method :path :handler}; a router is a handler that
|
||||
;; dispatches request -> response by method + path, extracting :name path
|
||||
;; params and binding a ** catch-all. No path match -> 404; path matches but
|
||||
;; method doesn't -> 405 + Allow. HEAD falls back to the GET handler with an
|
||||
;; empty body. Depends on types.sx.
|
||||
|
||||
;; ── route constructors (one per HTTP method) ───────────────────────
|
||||
(define dream-get (fn (path handler) (dream-route "GET" path handler)))
|
||||
(define dream-post (fn (path handler) (dream-route "POST" path handler)))
|
||||
(define dream-put (fn (path handler) (dream-route "PUT" path handler)))
|
||||
(define
|
||||
dream-delete
|
||||
(fn (path handler) (dream-route "DELETE" path handler)))
|
||||
(define dream-patch (fn (path handler) (dream-route "PATCH" path handler)))
|
||||
(define dream-head (fn (path handler) (dream-route "HEAD" path handler)))
|
||||
(define
|
||||
dream-options
|
||||
(fn (path handler) (dream-route "OPTIONS" path handler)))
|
||||
(define dream-any (fn (path handler) (dream-route "ANY" path handler)))
|
||||
|
||||
;; ── path segmentation ──────────────────────────────────────────────
|
||||
;; "/users/42/" -> ("users" "42"); "/" -> ()
|
||||
(define
|
||||
dr/segs
|
||||
(fn (path) (filter (fn (s) (not (= s ""))) (split path "/"))))
|
||||
|
||||
(define
|
||||
dr/join-path
|
||||
(fn
|
||||
(prefix path)
|
||||
(str "/" (join "/" (concat (dr/segs prefix) (dr/segs path))))))
|
||||
|
||||
;; ── segment matching ───────────────────────────────────────────────
|
||||
;; Returns a params dict on match (possibly empty {}), nil on no match.
|
||||
(define
|
||||
dr/match-segs
|
||||
(fn
|
||||
(pat path params)
|
||||
(cond
|
||||
((and (empty? pat) (empty? path)) params)
|
||||
((empty? pat) nil)
|
||||
(else
|
||||
(let
|
||||
((ps (first pat)))
|
||||
(cond
|
||||
((= ps "**") (assoc params "**" (join "/" path)))
|
||||
((empty? path) nil)
|
||||
((starts-with? ps ":")
|
||||
(dr/match-segs
|
||||
(rest pat)
|
||||
(rest path)
|
||||
(assoc params (substr ps 1) (first path))))
|
||||
((= ps (first path))
|
||||
(dr/match-segs (rest pat) (rest path) params))
|
||||
(else nil)))))))
|
||||
|
||||
;; path-only match: returns params dict or nil
|
||||
(define
|
||||
dr/route-params
|
||||
(fn
|
||||
(r req)
|
||||
(dr/match-segs
|
||||
(dr/segs (dream-route-path r))
|
||||
(dr/segs (dream-path req))
|
||||
{})))
|
||||
|
||||
;; method acceptance: exact, ANY, or HEAD served by a GET route
|
||||
(define
|
||||
dr/method-accepts?
|
||||
(fn
|
||||
(route-method req-method)
|
||||
(or
|
||||
(= route-method "ANY")
|
||||
(= route-method req-method)
|
||||
(and (= req-method "HEAD") (= route-method "GET")))))
|
||||
|
||||
;; ── middleware pipeline (shared with middleware.sx) ────────────────
|
||||
;; m1 @@ m2 @@ handler = (m1 (m2 handler)); first in list is outermost.
|
||||
(define
|
||||
dr/apply-middlewares
|
||||
(fn (mws handler) (reduce (fn (h mw) (mw h)) handler (reverse mws))))
|
||||
|
||||
;; ── scope: prefix mount + middleware chain ─────────────────────────
|
||||
;; Returns a flat list of routes; nested scopes flatten correctly.
|
||||
(define
|
||||
dr/flatten-routes
|
||||
(fn
|
||||
(items)
|
||||
(reduce
|
||||
(fn
|
||||
(acc it)
|
||||
(if
|
||||
(dream-route? it)
|
||||
(concat acc (list it))
|
||||
(concat acc (dr/flatten-routes it))))
|
||||
(list)
|
||||
items)))
|
||||
|
||||
(define
|
||||
dream-scope
|
||||
(fn
|
||||
(prefix middlewares routes)
|
||||
(map
|
||||
(fn
|
||||
(r)
|
||||
(dream-route
|
||||
(dream-route-method r)
|
||||
(dr/join-path prefix (dream-route-path r))
|
||||
(dr/apply-middlewares middlewares (dream-route-handler r))))
|
||||
(dr/flatten-routes routes))))
|
||||
|
||||
;; ── dispatch ───────────────────────────────────────────────────────
|
||||
;; allowed = methods of routes whose PATH matched (for 405 + Allow).
|
||||
(define
|
||||
dr/dispatch
|
||||
(fn
|
||||
(routes req allowed)
|
||||
(if
|
||||
(empty? routes)
|
||||
(if
|
||||
(empty? allowed)
|
||||
(dream-not-found)
|
||||
(dream-method-not-allowed allowed))
|
||||
(let
|
||||
((r (first routes)))
|
||||
(let
|
||||
((params (dr/route-params r req)))
|
||||
(if
|
||||
(nil? params)
|
||||
(dr/dispatch (rest routes) req allowed)
|
||||
(if
|
||||
(dr/method-accepts? (dream-route-method r) (dream-method req))
|
||||
(dr/run-route r req params)
|
||||
(dr/dispatch
|
||||
(rest routes)
|
||||
req
|
||||
(concat allowed (list (dream-route-method r)))))))))))
|
||||
|
||||
;; run a matched route; blank the body for an auto-HEAD on a GET route
|
||||
(define
|
||||
dr/run-route
|
||||
(fn
|
||||
(r req params)
|
||||
(let
|
||||
((resp (dream-coerce-response ((dream-route-handler r) (dream-with-params req params)))))
|
||||
(if
|
||||
(and
|
||||
(= (dream-method req) "HEAD")
|
||||
(not (= (dream-route-method r) "HEAD")))
|
||||
(dream-response (dream-status resp) (dream-headers resp) "")
|
||||
resp))))
|
||||
|
||||
;; 405 response with an Allow header listing the path's methods
|
||||
(define
|
||||
dream-method-not-allowed
|
||||
(fn
|
||||
(allowed)
|
||||
(dream-add-header
|
||||
(dream-response 405 {:content-type "text/plain; charset=utf-8"} "Method Not Allowed")
|
||||
"allow"
|
||||
(join ", " allowed))))
|
||||
|
||||
(define
|
||||
dream-router
|
||||
(fn
|
||||
(routes)
|
||||
(let
|
||||
((flat (dr/flatten-routes routes)))
|
||||
(fn (req) (dr/dispatch flat req (list))))))
|
||||
42
lib/dream/run.sx
Normal file
42
lib/dream/run.sx
Normal file
@@ -0,0 +1,42 @@
|
||||
;; lib/dream/run.sx — Dream-on-SX entry point.
|
||||
;; dream-run installs a root handler into the existing SX HTTP server via
|
||||
;; (perform (:http/listen …)) — it does NOT implement its own socket loop. The
|
||||
;; host invokes the installed app per request with a raw request dict; the app
|
||||
;; adapts it to a dream-request, runs the handler, and serialises the response
|
||||
;; (status/headers/body/set-cookies, or a websocket upgrade). Depends on types.sx
|
||||
;; + websocket.sx. The listen transport is injectable for testing.
|
||||
|
||||
;; ── response serialisation for the host ────────────────────────────
|
||||
(define
|
||||
dr/serialize-response
|
||||
(fn (resp) (if (dream-websocket? resp) {:websocket (dream-ws-handler resp) :body "" :headers (dream-headers resp) :status 101 :set-cookies (list)} {:body (dream-resp-body resp) :headers (dream-headers resp) :status (dream-status resp) :set-cookies (dream-resp-cookies resp)})))
|
||||
|
||||
;; ── the app: raw host request -> serialised response ───────────────
|
||||
(define
|
||||
dream-app
|
||||
(fn
|
||||
(handler)
|
||||
(fn
|
||||
(raw)
|
||||
(let
|
||||
((req (dream-request (or (get raw :method) "GET") (or (get raw :target) (or (get raw :path) "/")) (or (get raw :headers) {}) (or (get raw :body) ""))))
|
||||
(dr/serialize-response (dream-coerce-response (handler req)))))))
|
||||
|
||||
;; ── dream-run ──────────────────────────────────────────────────────
|
||||
(define dream-default-port 8080)
|
||||
|
||||
(define dream-run-with (fn (listen handler opts) (listen {:op "http/listen" :port (or (get opts :port) dream-default-port) :app (dream-app handler) :host (or (get opts :host) "0.0.0.0")})))
|
||||
|
||||
(define dream-perform-listen (fn (op) (perform op)))
|
||||
|
||||
(define
|
||||
dream-run
|
||||
(fn (handler) (dream-run-with dream-perform-listen handler {})))
|
||||
(define
|
||||
dream-run-port
|
||||
(fn
|
||||
(handler port)
|
||||
(dream-run-with dream-perform-listen handler {:port port})))
|
||||
(define
|
||||
dream-run-opts
|
||||
(fn (handler opts) (dream-run-with dream-perform-listen handler opts)))
|
||||
238
lib/dream/session.sx
Normal file
238
lib/dream/session.sx
Normal file
@@ -0,0 +1,238 @@
|
||||
;; lib/dream/session.sx — Dream-on-SX cookie-backed sessions.
|
||||
;; The session cookie carries only a session id; fields live in a back-end store.
|
||||
;; The store is injectable: production wires it to (perform op); tests pass an
|
||||
;; in-memory store. Depends on types.sx. Also hosts shared cookie helpers reused
|
||||
;; by flash.sx and form.sx.
|
||||
|
||||
;; ── cookie helpers (shared) ────────────────────────────────────────
|
||||
(define
|
||||
dr/parse-cookies
|
||||
(fn
|
||||
(header)
|
||||
(if
|
||||
(or (nil? header) (= header ""))
|
||||
{}
|
||||
(reduce
|
||||
(fn
|
||||
(acc part)
|
||||
(let
|
||||
((kv (trim part)))
|
||||
(let
|
||||
((j (index-of kv "=")))
|
||||
(if
|
||||
(< j 0)
|
||||
acc
|
||||
(assoc
|
||||
acc
|
||||
(substr kv 0 j)
|
||||
(substr kv (+ j 1)))))))
|
||||
{}
|
||||
(split header ";")))))
|
||||
|
||||
(define
|
||||
dream-cookie
|
||||
(fn (req name) (get (dr/parse-cookies (dream-header req "cookie")) name)))
|
||||
(define
|
||||
dream-cookies
|
||||
(fn (req) (dr/parse-cookies (dream-header req "cookie"))))
|
||||
|
||||
(define
|
||||
dr/build-cookie
|
||||
(fn
|
||||
(name val opts)
|
||||
(let
|
||||
((o (if (nil? opts) {} opts)))
|
||||
(str
|
||||
name
|
||||
"="
|
||||
val
|
||||
"; Path="
|
||||
(or (get o :path) "/")
|
||||
(if (get o :http-only) "; HttpOnly" "")
|
||||
(if (get o :secure) "; Secure" "")
|
||||
(if (get o :same-site) (str "; SameSite=" (get o :same-site)) "")
|
||||
(if (get o :max-age) (str "; Max-Age=" (get o :max-age)) "")))))
|
||||
|
||||
(define
|
||||
dream-set-cookie
|
||||
(fn
|
||||
(resp name val opts)
|
||||
(assoc
|
||||
resp
|
||||
:set-cookies (concat
|
||||
(or (get resp :set-cookies) (list))
|
||||
(list (dr/build-cookie name val opts))))))
|
||||
|
||||
(define
|
||||
dream-resp-cookies
|
||||
(fn (resp) (or (get resp :set-cookies) (list))))
|
||||
|
||||
;; expire a cookie on the client
|
||||
(define
|
||||
dream-drop-cookie
|
||||
(fn (resp name) (dream-set-cookie resp name "" {:max-age 0})))
|
||||
|
||||
;; ── signed cookie values (tamper-evident) ──────────────────────────
|
||||
;; NOTE: pure-SX keyed hash — not cryptographic; production should inject a host
|
||||
;; HMAC. Value carries no "." so the first "." splits value from signature.
|
||||
(define
|
||||
dr/sess-hash
|
||||
(fn (s) (dr/sess-hash-loop s 0 (string-length s) 7)))
|
||||
(define
|
||||
dr/sess-hash-loop
|
||||
(fn
|
||||
(s i n h)
|
||||
(if
|
||||
(>= i n)
|
||||
h
|
||||
(dr/sess-hash-loop
|
||||
s
|
||||
(+ i 1)
|
||||
n
|
||||
(mod (+ (* h 131) (char-code (char-at s i))) 2147483647)))))
|
||||
(define
|
||||
dr/sess-sig
|
||||
(fn (secret val) (str (dr/sess-hash (str secret "|" val)))))
|
||||
|
||||
(define
|
||||
dream-cookie-sign
|
||||
(fn (secret val) (str val "." (dr/sess-sig secret val))))
|
||||
(define
|
||||
dream-cookie-unsign
|
||||
(fn
|
||||
(secret signed)
|
||||
(if
|
||||
(or (nil? signed) (= signed ""))
|
||||
nil
|
||||
(let
|
||||
((dot (index-of signed ".")))
|
||||
(if
|
||||
(< dot 0)
|
||||
nil
|
||||
(let
|
||||
((val (substr signed 0 dot))
|
||||
(sig (substr signed (+ dot 1))))
|
||||
(if (= sig (dr/sess-sig secret val)) val nil)))))))
|
||||
|
||||
;; ── in-memory session store (tests + demos) ────────────────────────
|
||||
;; A backend is (fn (op) result) where op is a dict {:op ... :sid ... :key ...}.
|
||||
(define
|
||||
dream-memory-sessions
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((store {}) (counter 0))
|
||||
(fn
|
||||
(op)
|
||||
(let
|
||||
((kind (get op :op)))
|
||||
(cond
|
||||
((= kind "session/create")
|
||||
(begin
|
||||
(set! counter (+ counter 1))
|
||||
(let
|
||||
((sid (str "s" counter)))
|
||||
(begin (set! store (assoc store sid {})) sid))))
|
||||
((= kind "session/exists") (has-key? store (get op :sid)))
|
||||
((= kind "session/get")
|
||||
(get (or (get store (get op :sid)) {}) (get op :key)))
|
||||
((= kind "session/set")
|
||||
(let
|
||||
((sid (get op :sid)))
|
||||
(set!
|
||||
store
|
||||
(assoc
|
||||
store
|
||||
sid
|
||||
(assoc
|
||||
(or (get store sid) {})
|
||||
(get op :key)
|
||||
(get op :val))))))
|
||||
((= kind "session/load")
|
||||
(or (get store (get op :sid)) {}))
|
||||
((= kind "session/clear")
|
||||
(set! store (dissoc store (get op :sid))))
|
||||
(else nil)))))))
|
||||
|
||||
;; production back-end: every op suspends to the host
|
||||
(define dream-perform-sessions (fn (op) (perform op)))
|
||||
|
||||
;; ── session middleware ─────────────────────────────────────────────
|
||||
(define dream-session-cookie-name "dream.session")
|
||||
|
||||
(define
|
||||
dream-sessions
|
||||
(fn
|
||||
(backend)
|
||||
(fn
|
||||
(next)
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((sid0 (dream-cookie req dream-session-cookie-name)))
|
||||
(let
|
||||
((have (and sid0 (backend {:op "session/exists" :sid sid0}))))
|
||||
(let
|
||||
((sid (if have sid0 (backend {:op "session/create"}))))
|
||||
(let
|
||||
((resp (next (assoc req :dream-session {:io backend :sid sid}))))
|
||||
(if
|
||||
have
|
||||
resp
|
||||
(dream-set-cookie
|
||||
resp
|
||||
dream-session-cookie-name
|
||||
sid
|
||||
{:path "/" :http-only true :same-site "Lax"}))))))))))
|
||||
|
||||
;; signed variant: the cookie value is signed so a guessed/forged sid is rejected
|
||||
(define
|
||||
dream-sessions-signed
|
||||
(fn
|
||||
(backend secret)
|
||||
(fn
|
||||
(next)
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((sid0 (dream-cookie-unsign secret (dream-cookie req dream-session-cookie-name))))
|
||||
(let
|
||||
((have (and sid0 (backend {:op "session/exists" :sid sid0}))))
|
||||
(let
|
||||
((sid (if have sid0 (backend {:op "session/create"}))))
|
||||
(let
|
||||
((resp (next (assoc req :dream-session {:io backend :sid sid}))))
|
||||
(if
|
||||
have
|
||||
resp
|
||||
(dream-set-cookie
|
||||
resp
|
||||
dream-session-cookie-name
|
||||
(dream-cookie-sign secret sid)
|
||||
{:path "/" :http-only true :same-site "Lax"}))))))))))
|
||||
|
||||
;; ── handler-facing session API ─────────────────────────────────────
|
||||
(define dr/session-of (fn (req) (get req :dream-session)))
|
||||
(define dream-session-id (fn (req) (get (dr/session-of req) :sid)))
|
||||
|
||||
(define
|
||||
dream-session-field
|
||||
(fn
|
||||
(req key)
|
||||
(let ((s (dr/session-of req))) ((get s :io) {:key key :op "session/get" :sid (get s :sid)}))))
|
||||
|
||||
(define
|
||||
dream-set-session-field
|
||||
(fn
|
||||
(req key val)
|
||||
(let ((s (dr/session-of req))) (begin ((get s :io) {:val val :key key :op "session/set" :sid (get s :sid)}) req))))
|
||||
|
||||
(define
|
||||
dream-session-all
|
||||
(fn (req) (let ((s (dr/session-of req))) ((get s :io) {:op "session/load" :sid (get s :sid)}))))
|
||||
|
||||
(define
|
||||
dream-invalidate-session
|
||||
(fn
|
||||
(req)
|
||||
(let ((s (dr/session-of req))) (begin ((get s :io) {:op "session/clear" :sid (get s :sid)}) req))))
|
||||
182
lib/dream/static.sx
Normal file
182
lib/dream/static.sx
Normal file
@@ -0,0 +1,182 @@
|
||||
;; lib/dream/static.sx — Dream-on-SX static file serving.
|
||||
;; dream-static mounts at a ** route and serves files under a root: content-type by
|
||||
;; extension, ETags + If-None-Match (304), and Range requests (206). The filesystem
|
||||
;; is injectable: production reads via (perform op); tests pass an in-memory map.
|
||||
;; Depends on types.sx.
|
||||
|
||||
;; ── filesystem backends ────────────────────────────────────────────
|
||||
;; An fs is (fn (op) result); op {:op "file/read" :path p} -> content | nil.
|
||||
(define dream-static-perform-fs (fn (op) (perform op)))
|
||||
|
||||
;; in-memory fs over a {path -> content} dict (tests + demos)
|
||||
(define
|
||||
dream-memory-fs
|
||||
(fn
|
||||
(files)
|
||||
(fn
|
||||
(op)
|
||||
(if (= (get op :op) "file/read") (get files (get op :path)) nil))))
|
||||
|
||||
;; ── content-type by extension ──────────────────────────────────────
|
||||
(define dr/mime-types {:js "application/javascript" :jpeg "image/jpeg" :css "text/css; charset=utf-8" :ico "image/x-icon" :mjs "application/javascript" :html "text/html; charset=utf-8" :pdf "application/pdf" :jpg "image/jpeg" :json "application/json" :htm "text/html; charset=utf-8" :wasm "application/wasm" :webp "image/webp" :gif "image/gif" :png "image/png" :svg "image/svg+xml" :md "text/markdown; charset=utf-8" :xml "application/xml" :sx "text/plain; charset=utf-8" :txt "text/plain; charset=utf-8"})
|
||||
|
||||
(define
|
||||
dr/ext-of
|
||||
(fn
|
||||
(path)
|
||||
(let
|
||||
((segs (split path ".")))
|
||||
(if
|
||||
(> (len segs) 1)
|
||||
(lower (nth segs (- (len segs) 1)))
|
||||
""))))
|
||||
|
||||
(define
|
||||
dream-content-type-for
|
||||
(fn
|
||||
(path)
|
||||
(or (get dr/mime-types (dr/ext-of path)) "application/octet-stream")))
|
||||
|
||||
;; ── ETag (weak content hash) ───────────────────────────────────────
|
||||
(define
|
||||
dr/static-hash
|
||||
(fn (s) (dr/static-hash-loop s 0 (string-length s) 7)))
|
||||
(define
|
||||
dr/static-hash-loop
|
||||
(fn
|
||||
(s i n h)
|
||||
(if
|
||||
(>= i n)
|
||||
h
|
||||
(dr/static-hash-loop
|
||||
s
|
||||
(+ i 1)
|
||||
n
|
||||
(mod (+ (* h 131) (char-code (char-at s i))) 2147483647)))))
|
||||
(define
|
||||
dr/etag-of
|
||||
(fn
|
||||
(content)
|
||||
(str "\"" (dr/static-hash content) "-" (string-length content) "\"")))
|
||||
(define
|
||||
dr/etag-match?
|
||||
(fn (inm etag) (and (not (nil? inm)) (or (= inm "*") (= inm etag)))))
|
||||
|
||||
;; ── path safety ────────────────────────────────────────────────────
|
||||
(define
|
||||
dr/static-relpath
|
||||
(fn
|
||||
(req)
|
||||
(or (dream-param req "**") (substr (dream-path req) 1))))
|
||||
(define
|
||||
dr/unsafe-path?
|
||||
(fn (rel) (or (contains? rel "..") (starts-with? rel "/"))))
|
||||
(define
|
||||
dr/path-join
|
||||
(fn
|
||||
(root rel)
|
||||
(if (ends-with? root "/") (str root rel) (str root "/" rel))))
|
||||
|
||||
;; ── range requests ─────────────────────────────────────────────────
|
||||
(define
|
||||
dr/parse-range
|
||||
(fn
|
||||
(header total)
|
||||
(let
|
||||
((eq (index-of header "=")))
|
||||
(if
|
||||
(< eq 0)
|
||||
nil
|
||||
(let
|
||||
((spec (substr header (+ eq 1))))
|
||||
(let
|
||||
((dash (index-of spec "-")))
|
||||
(if
|
||||
(< dash 0)
|
||||
nil
|
||||
(let
|
||||
((s (substr spec 0 dash))
|
||||
(e (substr spec (+ dash 1))))
|
||||
(let
|
||||
((start (if (= s "") 0 (parse-int s)))
|
||||
(end (if (= e "") (- total 1) (parse-int e))))
|
||||
(if
|
||||
(or
|
||||
(< start 0)
|
||||
(>= start total)
|
||||
(> end (- total 1))
|
||||
(> start end))
|
||||
nil
|
||||
{:start start :end end}))))))))))
|
||||
|
||||
(define
|
||||
dr/serve-range
|
||||
(fn
|
||||
(req content etag ctype)
|
||||
(let
|
||||
((total (string-length content)))
|
||||
(let
|
||||
((r (dr/parse-range (dream-header req "range") total)))
|
||||
(if
|
||||
(nil? r)
|
||||
(dream-add-header
|
||||
(dream-response 416 {:content-type ctype} "")
|
||||
"content-range"
|
||||
(str "bytes */" total))
|
||||
(let
|
||||
((start (get r :start)) (end (get r :end)))
|
||||
(dream-add-header
|
||||
(dream-add-header
|
||||
(dream-response
|
||||
206
|
||||
{:content-type ctype}
|
||||
(substr content start (+ 1 (- end start))))
|
||||
"content-range"
|
||||
(str "bytes " start "-" end "/" total))
|
||||
"etag"
|
||||
etag)))))))
|
||||
|
||||
;; ── serving ────────────────────────────────────────────────────────
|
||||
(define
|
||||
dr/serve-file
|
||||
(fn
|
||||
(req content)
|
||||
(let
|
||||
((rel (dr/static-relpath req)))
|
||||
(let
|
||||
((etag (dr/etag-of content)) (ctype (dream-content-type-for rel)))
|
||||
(cond
|
||||
((dr/etag-match? (dream-header req "if-none-match") etag)
|
||||
(dream-add-header (dream-empty 304) "etag" etag))
|
||||
((dream-header req "range")
|
||||
(dr/serve-range req content etag ctype))
|
||||
(else
|
||||
(dream-add-header
|
||||
(dream-add-header
|
||||
(dream-response 200 {:content-type ctype} content)
|
||||
"etag"
|
||||
etag)
|
||||
"accept-ranges"
|
||||
"bytes")))))))
|
||||
|
||||
(define
|
||||
dream-static-with
|
||||
(fn
|
||||
(root fs)
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((rel (dr/static-relpath req)))
|
||||
(if
|
||||
(dr/unsafe-path? rel)
|
||||
(dream-html-status 403 "Forbidden")
|
||||
(let
|
||||
((content (fs {:path (dr/path-join root rel) :op "file/read"})))
|
||||
(if
|
||||
(nil? content)
|
||||
(dream-not-found)
|
||||
(dr/serve-file req content))))))))
|
||||
|
||||
(define
|
||||
dream-static
|
||||
(fn (root) (dream-static-with root dream-static-perform-fs)))
|
||||
77
lib/dream/tests/api.sx
Normal file
77
lib/dream/tests/api.sx
Normal file
@@ -0,0 +1,77 @@
|
||||
;; lib/dream/tests/api.sx — facade: app builders + default stack.
|
||||
|
||||
(define dream-ap-pass 0)
|
||||
(define dream-ap-fail 0)
|
||||
(define dream-ap-fails (list))
|
||||
|
||||
(define
|
||||
dream-ap-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-ap-pass (+ dream-ap-pass 1))
|
||||
(begin
|
||||
(set! dream-ap-fail (+ dream-ap-fail 1))
|
||||
(append! dream-ap-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(dream-ap-test "version is a string" (string? dream-version) true)
|
||||
|
||||
;; ── dream-make-app: routes -> handler with default stack ───────────
|
||||
(define
|
||||
dream-ap-routes
|
||||
(list
|
||||
(dream-get "/" (fn (req) (dream-html "<h1>hi</h1>")))
|
||||
(dream-get "/boom" (fn (req) (error "kaboom")))
|
||||
(dream-get
|
||||
"/raw"
|
||||
(fn (req) (dream-response 200 {} "plain words")))))
|
||||
(define dream-ap-app (dream-make-app dream-ap-routes))
|
||||
|
||||
(dream-ap-test
|
||||
"app serves"
|
||||
(dream-resp-body (dream-ap-app (dream-request "GET" "/" {} "")))
|
||||
"<h1>hi</h1>")
|
||||
(dream-ap-test
|
||||
"app catches errors -> 500"
|
||||
(dream-status (dream-ap-app (dream-request "GET" "/boom" {} "")))
|
||||
500)
|
||||
(dream-ap-test
|
||||
"app 404 for unknown"
|
||||
(dream-status (dream-ap-app (dream-request "GET" "/nope" {} "")))
|
||||
404)
|
||||
(dream-ap-test
|
||||
"app sniffs content-type"
|
||||
(dream-resp-header
|
||||
(dream-ap-app (dream-request "GET" "/raw" {} ""))
|
||||
"content-type")
|
||||
"text/plain; charset=utf-8")
|
||||
|
||||
;; ── dream-make-app-with: extra outer middleware ────────────────────
|
||||
(define
|
||||
dream-ap-tag
|
||||
(fn (next) (fn (req) (dream-add-header (next req) "X-App" "1"))))
|
||||
(define
|
||||
dream-ap-app2
|
||||
(dream-make-app-with (list dream-ap-tag) dream-ap-routes))
|
||||
(dream-ap-test
|
||||
"extra middleware header"
|
||||
(dream-resp-header
|
||||
(dream-ap-app2 (dream-request "GET" "/" {} ""))
|
||||
"x-app")
|
||||
"1")
|
||||
|
||||
;; ── dream-serve wires through dream-run ────────────────────────────
|
||||
(define dream-ap-captured nil)
|
||||
(define dream-ap-listen (fn (op) (begin (set! dream-ap-captured op) :ok)))
|
||||
(define
|
||||
dream-ap-served
|
||||
(dream-run-with dream-ap-listen (dream-make-app dream-ap-routes) {:port 7000}))
|
||||
(dream-ap-test "serve listens" dream-ap-served :ok)
|
||||
(dream-ap-test "serve port" (get dream-ap-captured :port) 7000)
|
||||
(dream-ap-test
|
||||
"served app runs"
|
||||
(get ((get dream-ap-captured :app) {:method "GET" :target "/"}) :body)
|
||||
"<h1>hi</h1>")
|
||||
|
||||
(define dream-ap-tests-run! (fn () {:total (+ dream-ap-pass dream-ap-fail) :passed dream-ap-pass :failed dream-ap-fail :fails dream-ap-fails}))
|
||||
109
lib/dream/tests/auth.sx
Normal file
109
lib/dream/tests/auth.sx
Normal file
@@ -0,0 +1,109 @@
|
||||
;; lib/dream/tests/auth.sx — base64, basic auth, bearer tokens.
|
||||
|
||||
(define dream-au-pass 0)
|
||||
(define dream-au-fail 0)
|
||||
(define dream-au-fails (list))
|
||||
|
||||
(define
|
||||
dream-au-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-au-pass (+ dream-au-pass 1))
|
||||
(begin
|
||||
(set! dream-au-fail (+ dream-au-fail 1))
|
||||
(append! dream-au-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── base64 ─────────────────────────────────────────────────────────
|
||||
(dream-au-test "encode Man" (dream-base64-encode "Man") "TWFu")
|
||||
(dream-au-test "encode Ma" (dream-base64-encode "Ma") "TWE=")
|
||||
(dream-au-test "encode M" (dream-base64-encode "M") "TQ==")
|
||||
(dream-au-test
|
||||
"encode user:pass"
|
||||
(dream-base64-encode "user:pass")
|
||||
"dXNlcjpwYXNz")
|
||||
(dream-au-test "decode Man" (dream-base64-decode "TWFu") "Man")
|
||||
(dream-au-test "decode Ma" (dream-base64-decode "TWE=") "Ma")
|
||||
(dream-au-test "decode M" (dream-base64-decode "TQ==") "M")
|
||||
(dream-au-test
|
||||
"decode user:pass"
|
||||
(dream-base64-decode "dXNlcjpwYXNz")
|
||||
"user:pass")
|
||||
(dream-au-test
|
||||
"roundtrip phrase"
|
||||
(dream-base64-decode (dream-base64-encode "Hello, World!"))
|
||||
"Hello, World!")
|
||||
(dream-au-test
|
||||
"roundtrip empty"
|
||||
(dream-base64-decode (dream-base64-encode ""))
|
||||
"")
|
||||
|
||||
;; ── header parsing ─────────────────────────────────────────────────
|
||||
(dream-au-test
|
||||
"bearer token"
|
||||
(dream-bearer-token (dream-request "GET" "/" {:Authorization "Bearer abc.123"} ""))
|
||||
"abc.123")
|
||||
(dream-au-test
|
||||
"no bearer"
|
||||
(dream-bearer-token (dream-request "GET" "/" {} ""))
|
||||
nil)
|
||||
(dream-au-test
|
||||
"basic creds"
|
||||
(dream-basic-credentials (dream-request "GET" "/" {:Authorization "Basic dXNlcjpwYXNz"} ""))
|
||||
{:pass "pass" :user "user"})
|
||||
(dream-au-test
|
||||
"no basic"
|
||||
(dream-basic-credentials (dream-request "GET" "/" {} ""))
|
||||
nil)
|
||||
|
||||
;; ── basic auth middleware ──────────────────────────────────────────
|
||||
(define dream-au-check (fn (u p) (and (= u "admin") (= p "secret"))))
|
||||
(define
|
||||
dream-au-app
|
||||
((dream-basic-auth "Admin Area" dream-au-check)
|
||||
(fn (req) (dream-text (str "hi " (dream-user req))))))
|
||||
|
||||
(define dream-au-ok (dream-au-app (dream-request "GET" "/" {:Authorization (str "Basic " (dream-base64-encode "admin:secret"))} "")))
|
||||
(dream-au-test "basic ok reaches" (dream-resp-body dream-au-ok) "hi admin")
|
||||
(dream-au-test "basic ok status" (dream-status dream-au-ok) 200)
|
||||
|
||||
(define dream-au-bad (dream-au-app (dream-request "GET" "/" {:Authorization (str "Basic " (dream-base64-encode "admin:wrong"))} "")))
|
||||
(dream-au-test "basic wrong 401" (dream-status dream-au-bad) 401)
|
||||
(dream-au-test
|
||||
"basic wrong www-authenticate"
|
||||
(contains? (dream-resp-header dream-au-bad "www-authenticate") "Admin Area")
|
||||
true)
|
||||
(dream-au-test
|
||||
"basic missing 401"
|
||||
(dream-status (dream-au-app (dream-request "GET" "/" {} "")))
|
||||
401)
|
||||
|
||||
;; ── bearer middleware ──────────────────────────────────────────────
|
||||
(define dream-au-tokens {:t-ada "ada" :t-bob "bob"})
|
||||
(define dream-au-lookup (fn (tok) (get dream-au-tokens tok)))
|
||||
(define
|
||||
dream-au-bapp
|
||||
((dream-require-bearer dream-au-lookup)
|
||||
(fn (req) (dream-text (dream-principal req)))))
|
||||
|
||||
(dream-au-test
|
||||
"bearer valid principal"
|
||||
(dream-resp-body (dream-au-bapp (dream-request "GET" "/" {:Authorization "Bearer t-ada"} "")))
|
||||
"ada")
|
||||
(dream-au-test
|
||||
"bearer invalid 401"
|
||||
(dream-status (dream-au-bapp (dream-request "GET" "/" {:Authorization "Bearer nope"} "")))
|
||||
401)
|
||||
(dream-au-test
|
||||
"bearer missing 401"
|
||||
(dream-status (dream-au-bapp (dream-request "GET" "/" {} "")))
|
||||
401)
|
||||
(dream-au-test
|
||||
"bearer 401 header"
|
||||
(dream-resp-header
|
||||
(dream-au-bapp (dream-request "GET" "/" {} ""))
|
||||
"www-authenticate")
|
||||
"Bearer")
|
||||
|
||||
(define dream-au-tests-run! (fn () {:total (+ dream-au-pass dream-au-fail) :passed dream-au-pass :failed dream-au-fail :fails dream-au-fails}))
|
||||
93
lib/dream/tests/cors.sx
Normal file
93
lib/dream/tests/cors.sx
Normal file
@@ -0,0 +1,93 @@
|
||||
;; lib/dream/tests/cors.sx — CORS decoration + preflight.
|
||||
|
||||
(define dream-co-pass 0)
|
||||
(define dream-co-fail 0)
|
||||
(define dream-co-fails (list))
|
||||
|
||||
(define
|
||||
dream-co-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-co-pass (+ dream-co-pass 1))
|
||||
(begin
|
||||
(set! dream-co-fail (+ dream-co-fail 1))
|
||||
(append! dream-co-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(define dream-co-h (fn (req) (dream-text "payload")))
|
||||
(define dream-co-app (dream-cors dream-co-h))
|
||||
|
||||
;; ── decoration of normal responses ─────────────────────────────────
|
||||
(define dream-co-get (dream-co-app (dream-request "GET" "/" {} "")))
|
||||
(dream-co-test
|
||||
"allow-origin star"
|
||||
(dream-resp-header dream-co-get "access-control-allow-origin")
|
||||
"*")
|
||||
(dream-co-test "body preserved" (dream-resp-body dream-co-get) "payload")
|
||||
(dream-co-test "status preserved" (dream-status dream-co-get) 200)
|
||||
(dream-co-test
|
||||
"no credentials by default"
|
||||
(dream-resp-header dream-co-get "access-control-allow-credentials")
|
||||
nil)
|
||||
|
||||
;; ── preflight OPTIONS ──────────────────────────────────────────────
|
||||
(define
|
||||
dream-co-pre
|
||||
(dream-co-app (dream-request "OPTIONS" "/" {} "")))
|
||||
(dream-co-test "preflight 204" (dream-status dream-co-pre) 204)
|
||||
(dream-co-test
|
||||
"preflight origin"
|
||||
(dream-resp-header dream-co-pre "access-control-allow-origin")
|
||||
"*")
|
||||
(dream-co-test
|
||||
"preflight methods"
|
||||
(contains?
|
||||
(dream-resp-header dream-co-pre "access-control-allow-methods")
|
||||
"POST")
|
||||
true)
|
||||
(dream-co-test
|
||||
"preflight headers"
|
||||
(dream-resp-header dream-co-pre "access-control-allow-headers")
|
||||
"Content-Type")
|
||||
(dream-co-test
|
||||
"preflight max-age"
|
||||
(dream-resp-header dream-co-pre "access-control-max-age")
|
||||
"86400")
|
||||
|
||||
;; ── custom origin ──────────────────────────────────────────────────
|
||||
(define
|
||||
dream-co-custom
|
||||
((dream-cors-origin "https://app.example.com") dream-co-h))
|
||||
(dream-co-test
|
||||
"custom origin"
|
||||
(dream-resp-header
|
||||
(dream-co-custom (dream-request "GET" "/" {} ""))
|
||||
"access-control-allow-origin")
|
||||
"https://app.example.com")
|
||||
|
||||
;; ── credentials enabled ────────────────────────────────────────────
|
||||
(define
|
||||
dream-co-cred
|
||||
((dream-cors-with (assoc dream-cors-defaults :credentials true))
|
||||
dream-co-h))
|
||||
(dream-co-test
|
||||
"credentials header"
|
||||
(dream-resp-header
|
||||
(dream-co-cred (dream-request "GET" "/" {} ""))
|
||||
"access-control-allow-credentials")
|
||||
"true")
|
||||
|
||||
;; ── composes around a router ───────────────────────────────────────
|
||||
(define
|
||||
dream-co-router
|
||||
(dream-cors
|
||||
(dream-router (list (dream-get "/api" (fn (req) (dream-json "{}")))))))
|
||||
(dream-co-test
|
||||
"router cors origin"
|
||||
(dream-resp-header
|
||||
(dream-co-router (dream-request "GET" "/api" {} ""))
|
||||
"access-control-allow-origin")
|
||||
"*")
|
||||
|
||||
(define dream-co-tests-run! (fn () {:total (+ dream-co-pass dream-co-fail) :passed dream-co-pass :failed dream-co-fail :fails dream-co-fails}))
|
||||
198
lib/dream/tests/demos.sx
Normal file
198
lib/dream/tests/demos.sx
Normal file
@@ -0,0 +1,198 @@
|
||||
;; lib/dream/tests/demos.sx — end-to-end demo apps exercising the full stack.
|
||||
|
||||
(define dream-dm-pass 0)
|
||||
(define dream-dm-fail 0)
|
||||
(define dream-dm-fails (list))
|
||||
|
||||
(define
|
||||
dream-dm-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-dm-pass (+ dream-dm-pass 1))
|
||||
(begin
|
||||
(set! dream-dm-fail (+ dream-dm-fail 1))
|
||||
(append! dream-dm-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(define
|
||||
dream-dm-req
|
||||
(fn (method target headers) (dream-request method target headers "")))
|
||||
|
||||
;; ── hello ──────────────────────────────────────────────────────────
|
||||
(dream-dm-test
|
||||
"hello root"
|
||||
(dream-resp-body (dream-hello-app (dream-dm-req "GET" "/" {})))
|
||||
"<h1>Hello, World!</h1>")
|
||||
(dream-dm-test
|
||||
"hello name"
|
||||
(dream-resp-body
|
||||
(dream-hello-app (dream-dm-req "GET" "/hello/Ada" {})))
|
||||
"<h1>Hello, Ada!</h1>")
|
||||
(dream-dm-test
|
||||
"hello content-type"
|
||||
(dream-resp-header
|
||||
(dream-hello-app (dream-dm-req "GET" "/" {}))
|
||||
"content-type")
|
||||
"text/html; charset=utf-8")
|
||||
|
||||
;; ── counter (sessions) ─────────────────────────────────────────────
|
||||
(define dream-dm-cbackend (dream-memory-sessions))
|
||||
(define dream-dm-capp (dream-counter-app-with dream-dm-cbackend))
|
||||
|
||||
(define dream-dm-c1 (dream-dm-capp (dream-dm-req "GET" "/" {})))
|
||||
(dream-dm-test
|
||||
"counter first visit"
|
||||
(dream-resp-body dream-dm-c1)
|
||||
"<p>You have visited this page 1 time(s).</p>")
|
||||
(dream-dm-test
|
||||
"counter sets cookie"
|
||||
(len (dream-resp-cookies dream-dm-c1))
|
||||
1)
|
||||
(dream-dm-test
|
||||
"counter second visit"
|
||||
(dream-resp-body (dream-dm-capp (dream-dm-req "GET" "/" {:Cookie "dream.session=s1"})))
|
||||
"<p>You have visited this page 2 time(s).</p>")
|
||||
(dream-dm-test
|
||||
"counter third visit"
|
||||
(dream-resp-body (dream-dm-capp (dream-dm-req "GET" "/" {:Cookie "dream.session=s1"})))
|
||||
"<p>You have visited this page 3 time(s).</p>")
|
||||
(define
|
||||
dream-dm-reset
|
||||
(dream-dm-capp (dream-dm-req "POST" "/reset" {:Cookie "dream.session=s1"})))
|
||||
(dream-dm-test
|
||||
"counter reset redirects"
|
||||
(dream-status dream-dm-reset)
|
||||
303)
|
||||
(dream-dm-test
|
||||
"counter after reset"
|
||||
(dream-resp-body (dream-dm-capp (dream-dm-req "GET" "/" {:Cookie "dream.session=s1"})))
|
||||
"<p>You have visited this page 1 time(s).</p>")
|
||||
(dream-dm-test
|
||||
"counter distinct session"
|
||||
(dream-resp-body (dream-dm-capp (dream-dm-req "GET" "/" {})))
|
||||
"<p>You have visited this page 1 time(s).</p>")
|
||||
|
||||
;; ── chat (websocket rooms) ─────────────────────────────────────────
|
||||
(define dream-dm-rooms (dream-chat-rooms))
|
||||
(define dream-dm-wsB (dream-mock-ws (list)))
|
||||
(define dream-dm-wsC (dream-mock-ws (list)))
|
||||
((get dream-dm-rooms :join) "general" dream-dm-wsB)
|
||||
((get dream-dm-rooms :join) "general" dream-dm-wsC)
|
||||
(dream-dm-test
|
||||
"room has two members"
|
||||
(len ((get dream-dm-rooms :members) "general"))
|
||||
2)
|
||||
|
||||
;; client A joins, sends two messages, then disconnects
|
||||
(define dream-dm-wsA (dream-mock-ws (list "hi" "again")))
|
||||
((dream-chat-session dream-dm-rooms "general") dream-dm-wsA)
|
||||
(dream-dm-test
|
||||
"B got broadcasts"
|
||||
(dream-ws-sent dream-dm-wsB)
|
||||
(list "hi" "again"))
|
||||
(dream-dm-test
|
||||
"C got broadcasts"
|
||||
(dream-ws-sent dream-dm-wsC)
|
||||
(list "hi" "again"))
|
||||
(dream-dm-test
|
||||
"A echoed own messages"
|
||||
(dream-ws-sent dream-dm-wsA)
|
||||
(list "hi" "again"))
|
||||
(dream-dm-test
|
||||
"A left on disconnect"
|
||||
(len ((get dream-dm-rooms :members) "general"))
|
||||
2)
|
||||
(dream-dm-test "A closed" (dream-ws-closed? dream-dm-wsA) true)
|
||||
|
||||
;; route produces an upgrade response
|
||||
(define dream-dm-chat-app (dream-chat-app-with (dream-chat-rooms)))
|
||||
(dream-dm-test
|
||||
"chat route upgrades"
|
||||
(dream-websocket?
|
||||
(dream-dm-chat-app (dream-dm-req "GET" "/chat/lobby" {})))
|
||||
true)
|
||||
(dream-dm-test
|
||||
"chat index html"
|
||||
(dream-resp-body (dream-dm-chat-app (dream-dm-req "GET" "/" {})))
|
||||
"<h1>Rooms</h1>")
|
||||
|
||||
;; ── todo (forms + CSRF) ────────────────────────────────────────────
|
||||
(define dream-dm-todo-store (dream-todo-store))
|
||||
(define dream-dm-todo-backend (dream-memory-sessions))
|
||||
(define
|
||||
dream-dm-todo-app
|
||||
(dream-todo-app-with dream-dm-todo-store dream-dm-todo-backend "topsecret"))
|
||||
(define
|
||||
dream-dm-todo-tok
|
||||
(dr/csrf-make-token dream-csrf-sign-default "topsecret" "s1"))
|
||||
|
||||
;; establish session s1
|
||||
(dream-dm-todo-app (dream-request "GET" "/" {} ""))
|
||||
(define
|
||||
dream-dm-add1
|
||||
(dream-dm-todo-app
|
||||
(dream-request
|
||||
"POST"
|
||||
"/add"
|
||||
{:Cookie "dream.session=s1"}
|
||||
(str "text=Buy+milk&dream.csrf=" dream-dm-todo-tok))))
|
||||
(dream-dm-test "todo add redirects" (dream-status dream-dm-add1) 303)
|
||||
(dream-dm-test
|
||||
"todo store has item"
|
||||
(len ((get dream-dm-todo-store :all)))
|
||||
1)
|
||||
|
||||
(define
|
||||
dream-dm-todo-page
|
||||
(dream-resp-body
|
||||
(dream-dm-todo-app (dream-request "GET" "/" {:Cookie "dream.session=s1"} ""))))
|
||||
(dream-dm-test
|
||||
"todo lists item"
|
||||
(contains? dream-dm-todo-page "Buy milk")
|
||||
true)
|
||||
(dream-dm-test
|
||||
"todo has csrf tag"
|
||||
(contains? dream-dm-todo-page "dream.csrf")
|
||||
true)
|
||||
(dream-dm-test
|
||||
"todo item not done"
|
||||
(contains? dream-dm-todo-page "[ ] Buy milk")
|
||||
true)
|
||||
|
||||
(dream-dm-todo-app
|
||||
(dream-request
|
||||
"POST"
|
||||
"/toggle/1"
|
||||
{:Cookie "dream.session=s1"}
|
||||
(str "dream.csrf=" dream-dm-todo-tok)))
|
||||
(dream-dm-test
|
||||
"todo toggled done"
|
||||
(contains?
|
||||
(dream-resp-body
|
||||
(dream-dm-todo-app (dream-request "GET" "/" {:Cookie "dream.session=s1"} "")))
|
||||
"[x] Buy milk")
|
||||
true)
|
||||
|
||||
(dream-dm-test
|
||||
"todo add without token 403"
|
||||
(dream-status
|
||||
(dream-dm-todo-app (dream-request "POST" "/add" {:Cookie "dream.session=s1"} "text=Sneaky")))
|
||||
403)
|
||||
(dream-dm-test
|
||||
"todo unchanged after reject"
|
||||
(len ((get dream-dm-todo-store :all)))
|
||||
1)
|
||||
|
||||
(dream-dm-todo-app
|
||||
(dream-request
|
||||
"POST"
|
||||
"/delete/1"
|
||||
{:Cookie "dream.session=s1"}
|
||||
(str "dream.csrf=" dream-dm-todo-tok)))
|
||||
(dream-dm-test
|
||||
"todo deleted"
|
||||
(len ((get dream-dm-todo-store :all)))
|
||||
0)
|
||||
|
||||
(define dream-dm-tests-run! (fn () {:total (+ dream-dm-pass dream-dm-fail) :passed dream-dm-pass :failed dream-dm-fail :fails dream-dm-fails}))
|
||||
90
lib/dream/tests/error.sx
Normal file
90
lib/dream/tests/error.sx
Normal file
@@ -0,0 +1,90 @@
|
||||
;; lib/dream/tests/error.sx — status phrases + dream-catch.
|
||||
|
||||
(define dream-er-pass 0)
|
||||
(define dream-er-fail 0)
|
||||
(define dream-er-fails (list))
|
||||
|
||||
(define
|
||||
dream-er-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-er-pass (+ dream-er-pass 1))
|
||||
(begin
|
||||
(set! dream-er-fail (+ dream-er-fail 1))
|
||||
(append! dream-er-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── status phrases ─────────────────────────────────────────────────
|
||||
(dream-er-test "200 OK" (dream-status-text 200) "OK")
|
||||
(dream-er-test "404 Not Found" (dream-status-text 404) "Not Found")
|
||||
(dream-er-test
|
||||
"405 phrase"
|
||||
(dream-status-text 405)
|
||||
"Method Not Allowed")
|
||||
(dream-er-test
|
||||
"500 phrase"
|
||||
(dream-status-text 500)
|
||||
"Internal Server Error")
|
||||
(dream-er-test "unknown phrase" (dream-status-text 599) "Unknown")
|
||||
(dream-er-test "status line" (dream-status-line 404) "404 Not Found")
|
||||
(dream-er-test
|
||||
"status page status"
|
||||
(dream-status (dream-status-page 403))
|
||||
403)
|
||||
(dream-er-test
|
||||
"status page body"
|
||||
(dream-resp-body (dream-status-page 403))
|
||||
"<h1>403 Forbidden</h1>")
|
||||
|
||||
;; ── dream-catch ────────────────────────────────────────────────────
|
||||
(define dream-er-boom (fn (req) (error "kaboom")))
|
||||
(define dream-er-ok (fn (req) (dream-text "fine")))
|
||||
|
||||
(dream-er-test
|
||||
"catch normal passes through"
|
||||
(dream-resp-body
|
||||
((dream-catch dream-er-ok) (dream-request "GET" "/" {} "")))
|
||||
"fine")
|
||||
(dream-er-test
|
||||
"catch error -> 500"
|
||||
(dream-status
|
||||
((dream-catch dream-er-boom) (dream-request "GET" "/" {} "")))
|
||||
500)
|
||||
(dream-er-test
|
||||
"catch 500 body"
|
||||
(dream-resp-body
|
||||
((dream-catch dream-er-boom) (dream-request "GET" "/" {} "")))
|
||||
"<h1>500 Internal Server Error</h1>")
|
||||
|
||||
;; custom error page receives the error
|
||||
(define
|
||||
dream-er-custom
|
||||
(dream-catch-with (fn (req e) (dream-text (str "ERR:" e)))))
|
||||
(dream-er-test
|
||||
"custom error page"
|
||||
(dream-resp-body
|
||||
((dream-er-custom dream-er-boom) (dream-request "GET" "/" {} "")))
|
||||
"ERR:kaboom")
|
||||
(dream-er-test
|
||||
"custom passes normal through"
|
||||
(dream-resp-body
|
||||
((dream-er-custom dream-er-ok) (dream-request "GET" "/" {} "")))
|
||||
"fine")
|
||||
|
||||
;; catch composes around a router
|
||||
(define
|
||||
dream-er-app
|
||||
(dream-catch
|
||||
(dream-router
|
||||
(list (dream-get "/boom" dream-er-boom) (dream-get "/ok" dream-er-ok)))))
|
||||
(dream-er-test
|
||||
"router error caught"
|
||||
(dream-status (dream-er-app (dream-request "GET" "/boom" {} "")))
|
||||
500)
|
||||
(dream-er-test
|
||||
"router ok intact"
|
||||
(dream-resp-body (dream-er-app (dream-request "GET" "/ok" {} "")))
|
||||
"fine")
|
||||
|
||||
(define dream-er-tests-run! (fn () {:total (+ dream-er-pass dream-er-fail) :passed dream-er-pass :failed dream-er-fail :fails dream-er-fails}))
|
||||
129
lib/dream/tests/flash.sx
Normal file
129
lib/dream/tests/flash.sx
Normal file
@@ -0,0 +1,129 @@
|
||||
;; lib/dream/tests/flash.sx — codec + read-after-write across requests.
|
||||
|
||||
(define dream-fl-pass 0)
|
||||
(define dream-fl-fail 0)
|
||||
(define dream-fl-fails (list))
|
||||
|
||||
(define
|
||||
dream-fl-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-fl-pass (+ dream-fl-pass 1))
|
||||
(begin
|
||||
(set! dream-fl-fail (+ dream-fl-fail 1))
|
||||
(append! dream-fl-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── codec ──────────────────────────────────────────────────────────
|
||||
(dream-fl-test "encode one" (dr/flash-encode (list {:message "saved" :category "info"})) "info|saved")
|
||||
(dream-fl-test
|
||||
"encode two"
|
||||
(dr/flash-encode (list {:message "a" :category "info"} {:message "b" :category "error"}))
|
||||
"info|a~error|b")
|
||||
(dream-fl-test "decode one" (dr/flash-decode "info|saved") (list {:message "saved" :category "info"}))
|
||||
(dream-fl-test "decode empty" (dr/flash-decode "") (list))
|
||||
(dream-fl-test
|
||||
"roundtrip special chars"
|
||||
(dr/flash-decode (dr/flash-encode (list {:message "a~b%c" :category "x|y"})))
|
||||
(list {:message "a~b%c" :category "x|y"}))
|
||||
(dream-fl-test "escape pipe" (dr/flash-encode (list {:message "a|b" :category "c"})) "c|a%7Cb")
|
||||
|
||||
;; extract a cookie value from a Set-Cookie string
|
||||
(define
|
||||
dream-fl-cookie-val
|
||||
(fn
|
||||
(setc)
|
||||
(let
|
||||
((after (substr setc (+ (index-of setc "=") 1))))
|
||||
(substr after 0 (index-of after ";")))))
|
||||
|
||||
;; ── read-after-write across requests ───────────────────────────────
|
||||
(define
|
||||
dream-fl-set-h
|
||||
(fn
|
||||
(req)
|
||||
(begin (dream-add-flash-message req "info" "Saved!") (dream-text "done"))))
|
||||
(define dream-fl-set-app (dream-flash dream-fl-set-h))
|
||||
|
||||
;; request 1: add a flash, no incoming -> sets the flash cookie
|
||||
(define
|
||||
dream-fl-r1
|
||||
(dream-fl-set-app (dream-request "POST" "/save" {} "")))
|
||||
(dream-fl-test "writer body" (dream-resp-body dream-fl-r1) "done")
|
||||
(dream-fl-test
|
||||
"writer sets flash cookie"
|
||||
(len (dream-resp-cookies dream-fl-r1))
|
||||
1)
|
||||
(dream-fl-test
|
||||
"writer has no incoming"
|
||||
(dream-flash-messages
|
||||
(assoc (dream-request "GET" "/" {} "") :dream-flash {:box (dr/flash-box) :incoming (list)}))
|
||||
(list))
|
||||
|
||||
;; request 2: carries the flash cookie -> handler reads it, cookie cleared
|
||||
(define
|
||||
dream-fl-cval
|
||||
(dream-fl-cookie-val (first (dream-resp-cookies dream-fl-r1))))
|
||||
(define
|
||||
dream-fl-read-h
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((msgs (dream-flash-messages req)))
|
||||
(dream-text
|
||||
(if (empty? msgs) "none" (dream-flash-message (first msgs)))))))
|
||||
(define dream-fl-read-app (dream-flash dream-fl-read-h))
|
||||
(define
|
||||
dream-fl-r2
|
||||
(dream-fl-read-app (dream-request "GET" "/" {:Cookie (str "dream.flash=" dream-fl-cval)} "")))
|
||||
(dream-fl-test "reader sees message" (dream-resp-body dream-fl-r2) "Saved!")
|
||||
(dream-fl-test
|
||||
"reader clears cookie (Max-Age=0)"
|
||||
(contains? (first (dream-resp-cookies dream-fl-r2)) "Max-Age=0")
|
||||
true)
|
||||
|
||||
;; request 3: no flash cookie -> nothing to read, no cookie set
|
||||
(define
|
||||
dream-fl-r3
|
||||
(dream-fl-read-app (dream-request "GET" "/" {} "")))
|
||||
(dream-fl-test "no flash -> none" (dream-resp-body dream-fl-r3) "none")
|
||||
(dream-fl-test
|
||||
"no flash -> no cookie"
|
||||
(len (dream-resp-cookies dream-fl-r3))
|
||||
0)
|
||||
|
||||
;; ── multiple categories ────────────────────────────────────────────
|
||||
(define
|
||||
dream-fl-multi-h
|
||||
(fn
|
||||
(req)
|
||||
(begin
|
||||
(dream-add-flash-message req "info" "i1")
|
||||
(dream-add-flash-message req "error" "e1")
|
||||
(dream-add-flash-message req "info" "i2")
|
||||
(dream-text "ok"))))
|
||||
(define
|
||||
dream-fl-multi-r1
|
||||
((dream-flash dream-fl-multi-h) (dream-request "GET" "/" {} "")))
|
||||
(define
|
||||
dream-fl-multi-val
|
||||
(dream-fl-cookie-val (first (dream-resp-cookies dream-fl-multi-r1))))
|
||||
(define
|
||||
dream-fl-count-h
|
||||
(fn
|
||||
(req)
|
||||
(dream-text
|
||||
(str
|
||||
(len (dream-flash-messages req))
|
||||
"/"
|
||||
(len (dream-flash-of req "info"))))))
|
||||
(define
|
||||
dream-fl-multi-r2
|
||||
((dream-flash dream-fl-count-h) (dream-request "GET" "/" {:Cookie (str "dream.flash=" dream-fl-multi-val)} "")))
|
||||
(dream-fl-test
|
||||
"multi: all + filtered counts"
|
||||
(dream-resp-body dream-fl-multi-r2)
|
||||
"3/2")
|
||||
|
||||
(define dream-fl-tests-run! (fn () {:total (+ dream-fl-pass dream-fl-fail) :passed dream-fl-pass :failed dream-fl-fail :fails dream-fl-fails}))
|
||||
226
lib/dream/tests/form.sx
Normal file
226
lib/dream/tests/form.sx
Normal file
@@ -0,0 +1,226 @@
|
||||
;; lib/dream/tests/form.sx — urlencoded parsing, Ok/Err, CSRF accept/reject, multipart.
|
||||
|
||||
(define dream-fo-pass 0)
|
||||
(define dream-fo-fail 0)
|
||||
(define dream-fo-fails (list))
|
||||
|
||||
(define
|
||||
dream-fo-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-fo-pass (+ dream-fo-pass 1))
|
||||
(begin
|
||||
(set! dream-fo-fail (+ dream-fo-fail 1))
|
||||
(append! dream-fo-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── Result ─────────────────────────────────────────────────────────
|
||||
(dream-fo-test "ok? on ok" (dream-ok? (dream-ok 5)) true)
|
||||
(dream-fo-test "err? on ok" (dream-err? (dream-ok 5)) false)
|
||||
(dream-fo-test "ok value" (dream-ok-value (dream-ok {:a 1})) {:a 1})
|
||||
(dream-fo-test "err reason" (dream-err-reason (dream-err :bad)) "bad")
|
||||
|
||||
;; ── urlencoded parsing ─────────────────────────────────────────────
|
||||
(define
|
||||
dream-fo-req
|
||||
(fn (body) (dream-request "POST" "/f" {:Content-Type "application/x-www-form-urlencoded"} body)))
|
||||
|
||||
(dream-fo-test
|
||||
"parse two fields"
|
||||
(dream-form-fields (dream-fo-req "a=1&b=2"))
|
||||
{:a "1" :b "2"})
|
||||
(dream-fo-test
|
||||
"url-decoded value"
|
||||
(dream-form-field (dream-fo-req "name=Ada+Lovelace") "name")
|
||||
"Ada Lovelace")
|
||||
(dream-fo-test
|
||||
"percent decode"
|
||||
(dream-form-field (dream-fo-req "x=a%20b%21") "x")
|
||||
"a b!")
|
||||
(dream-fo-test "empty body" (dream-form-fields (dream-fo-req "")) {})
|
||||
(dream-fo-test
|
||||
"valueless key"
|
||||
(dream-form-field (dream-fo-req "flag") "flag")
|
||||
"")
|
||||
(dream-fo-test
|
||||
"decoded key"
|
||||
(dream-form-field (dream-fo-req "first%20name=x") "first name")
|
||||
"x")
|
||||
|
||||
;; ── CSRF sign + verify ─────────────────────────────────────────────
|
||||
(dream-fo-test
|
||||
"sign deterministic"
|
||||
(=
|
||||
(dream-csrf-sign-default "secret" "s1")
|
||||
(dream-csrf-sign-default "secret" "s1"))
|
||||
true)
|
||||
(dream-fo-test
|
||||
"sign secret-sensitive"
|
||||
(=
|
||||
(dream-csrf-sign-default "secret" "s1")
|
||||
(dream-csrf-sign-default "other" "s1"))
|
||||
false)
|
||||
(dream-fo-test
|
||||
"sign session-sensitive"
|
||||
(=
|
||||
(dream-csrf-sign-default "secret" "s1")
|
||||
(dream-csrf-sign-default "secret" "s2"))
|
||||
false)
|
||||
(dream-fo-test
|
||||
"token valid for own session"
|
||||
(dr/csrf-valid?
|
||||
dream-csrf-sign-default
|
||||
"k"
|
||||
"s1"
|
||||
(dr/csrf-make-token dream-csrf-sign-default "k" "s1"))
|
||||
true)
|
||||
(dream-fo-test
|
||||
"token invalid for other session"
|
||||
(dr/csrf-valid?
|
||||
dream-csrf-sign-default
|
||||
"k"
|
||||
"s2"
|
||||
(dr/csrf-make-token dream-csrf-sign-default "k" "s1"))
|
||||
false)
|
||||
(dream-fo-test
|
||||
"tampered token invalid"
|
||||
(dr/csrf-valid? dream-csrf-sign-default "k" "s1" "s1.deadbeef")
|
||||
false)
|
||||
(dream-fo-test
|
||||
"empty token invalid"
|
||||
(dr/csrf-valid? dream-csrf-sign-default "k" "s1" "")
|
||||
false)
|
||||
(dream-fo-test
|
||||
"nil token invalid"
|
||||
(dr/csrf-valid? dream-csrf-sign-default "k" "s1" nil)
|
||||
false)
|
||||
|
||||
;; ── full stack: session -> csrf -> handler ─────────────────────────
|
||||
(define dream-fo-backend (dream-memory-sessions))
|
||||
(define dream-fo-sid (dream-fo-backend {:op "session/create"})) ;; s1
|
||||
|
||||
(define
|
||||
dream-fo-stack
|
||||
(fn
|
||||
(handler)
|
||||
((dream-sessions dream-fo-backend) ((dream-csrf "topsecret") handler))))
|
||||
|
||||
(define
|
||||
dream-fo-tag-out
|
||||
(dream-resp-body
|
||||
((dream-fo-stack (fn (req) (dream-text (dream-csrf-tag req))))
|
||||
(dream-request "GET" "/form" {:Cookie "dream.session=s1"} ""))))
|
||||
(dream-fo-test
|
||||
"csrf-tag is hidden input"
|
||||
(contains? dream-fo-tag-out "type=\"hidden\"")
|
||||
true)
|
||||
(dream-fo-test
|
||||
"csrf-tag names field"
|
||||
(contains? dream-fo-tag-out "name=\"dream.csrf\"")
|
||||
true)
|
||||
|
||||
(define
|
||||
dream-fo-good-token
|
||||
(dr/csrf-make-token dream-csrf-sign-default "topsecret" "s1"))
|
||||
(define
|
||||
dream-fo-submit
|
||||
(fn
|
||||
(token)
|
||||
((dream-fo-stack (fn (req) (let ((r (dream-form req))) (if (dream-ok? r) (dream-text (str "ok:" (get (dream-ok-value r) "msg"))) (dream-text (str "err:" (dream-err-reason r)))))))
|
||||
(dream-request
|
||||
"POST"
|
||||
"/form"
|
||||
{:Cookie "dream.session=s1"}
|
||||
(str "msg=hello&dream.csrf=" token)))))
|
||||
|
||||
(dream-fo-test
|
||||
"valid csrf -> Ok fields"
|
||||
(dream-resp-body (dream-fo-submit dream-fo-good-token))
|
||||
"ok:hello")
|
||||
(dream-fo-test
|
||||
"bad csrf -> Err"
|
||||
(dream-resp-body (dream-fo-submit "s1.wrong"))
|
||||
"err:csrf-token-invalid")
|
||||
(dream-fo-test
|
||||
"missing csrf -> Err"
|
||||
(dream-resp-body (dream-fo-submit ""))
|
||||
"err:csrf-token-invalid")
|
||||
|
||||
;; ── csrf-protect middleware auto-rejects ───────────────────────────
|
||||
(define
|
||||
dream-fo-protected
|
||||
(fn
|
||||
(handler)
|
||||
((dream-sessions dream-fo-backend)
|
||||
((dream-csrf-protect "topsecret") handler))))
|
||||
(define dream-fo-ph (dream-fo-protected (fn (req) (dream-text "reached"))))
|
||||
|
||||
(dream-fo-test
|
||||
"GET passes without token"
|
||||
(dream-resp-body (dream-fo-ph (dream-request "GET" "/x" {:Cookie "dream.session=s1"} "")))
|
||||
"reached")
|
||||
(dream-fo-test
|
||||
"POST without token 403"
|
||||
(dream-status (dream-fo-ph (dream-request "POST" "/x" {:Cookie "dream.session=s1"} "")))
|
||||
403)
|
||||
(dream-fo-test
|
||||
"POST with valid token reaches"
|
||||
(dream-resp-body
|
||||
(dream-fo-ph
|
||||
(dream-request
|
||||
"POST"
|
||||
"/x"
|
||||
{:Cookie "dream.session=s1"}
|
||||
(str "dream.csrf=" dream-fo-good-token))))
|
||||
"reached")
|
||||
|
||||
;; ── multipart/form-data ────────────────────────────────────────────
|
||||
(define
|
||||
dream-fo-mp-body
|
||||
(str
|
||||
"--B1\r\n"
|
||||
"Content-Disposition: form-data; name=\"title\"\r\n\r\n"
|
||||
"Hello\r\n"
|
||||
"--B1\r\n"
|
||||
"Content-Disposition: form-data; name=\"file\"; filename=\"a.txt\"\r\nContent-Type: text/plain\r\n\r\n"
|
||||
"line1\r\nline2\r\n"
|
||||
"--B1--\r\n"))
|
||||
(define
|
||||
dream-fo-mp-req
|
||||
(dream-request "POST" "/upload" {:Content-Type "multipart/form-data; boundary=B1"} dream-fo-mp-body))
|
||||
(define dream-fo-mp (dream-multipart dream-fo-mp-req))
|
||||
(dream-fo-test "multipart is Ok" (dream-ok? dream-fo-mp) true)
|
||||
(define dream-fo-parts (dream-ok-value dream-fo-mp))
|
||||
(dream-fo-test "two parts" (len dream-fo-parts) 2)
|
||||
(dream-fo-test
|
||||
"field value"
|
||||
(dream-multipart-field dream-fo-parts "title")
|
||||
"Hello")
|
||||
(dream-fo-test
|
||||
"file part filename"
|
||||
(get (dream-multipart-file dream-fo-parts "file") :filename)
|
||||
"a.txt")
|
||||
(dream-fo-test
|
||||
"file content-type"
|
||||
(get (dream-multipart-file dream-fo-parts "file") :content-type)
|
||||
"text/plain")
|
||||
(dream-fo-test
|
||||
"file content keeps inner CRLF"
|
||||
(get (dream-multipart-file dream-fo-parts "file") :content)
|
||||
"line1\r\nline2")
|
||||
(dream-fo-test
|
||||
"field is not a file"
|
||||
(get (dream-multipart-file dream-fo-parts "title") :filename)
|
||||
nil)
|
||||
(dream-fo-test
|
||||
"non-multipart is Err"
|
||||
(dream-err? (dream-multipart (dream-request "POST" "/x" {:Content-Type "text/plain"} "hi")))
|
||||
true)
|
||||
(dream-fo-test
|
||||
"quoted boundary parsed"
|
||||
(dream-ok?
|
||||
(dream-multipart (dream-request "POST" "/u" {:Content-Type "multipart/form-data; boundary=\"B1\""} dream-fo-mp-body)))
|
||||
true)
|
||||
|
||||
(define dream-fo-tests-run! (fn () {:total (+ dream-fo-pass dream-fo-fail) :passed dream-fo-pass :failed dream-fo-fail :fails dream-fo-fails}))
|
||||
94
lib/dream/tests/headers.sx
Normal file
94
lib/dream/tests/headers.sx
Normal file
@@ -0,0 +1,94 @@
|
||||
;; lib/dream/tests/headers.sx — security headers + cache-control.
|
||||
|
||||
(define dream-hd-pass 0)
|
||||
(define dream-hd-fail 0)
|
||||
(define dream-hd-fails (list))
|
||||
|
||||
(define
|
||||
dream-hd-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-hd-pass (+ dream-hd-pass 1))
|
||||
(begin
|
||||
(set! dream-hd-fail (+ dream-hd-fail 1))
|
||||
(append! dream-hd-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(define dream-hd-h (fn (req) (dream-text "body")))
|
||||
(define dream-hd-req (dream-request "GET" "/" {} ""))
|
||||
|
||||
;; ── security headers ───────────────────────────────────────────────
|
||||
(define dream-hd-sec ((dream-security-headers dream-hd-h) dream-hd-req))
|
||||
(dream-hd-test
|
||||
"nosniff"
|
||||
(dream-resp-header dream-hd-sec "x-content-type-options")
|
||||
"nosniff")
|
||||
(dream-hd-test
|
||||
"frame deny"
|
||||
(dream-resp-header dream-hd-sec "x-frame-options")
|
||||
"DENY")
|
||||
(dream-hd-test
|
||||
"referrer policy"
|
||||
(dream-resp-header dream-hd-sec "referrer-policy")
|
||||
"no-referrer")
|
||||
(dream-hd-test
|
||||
"no hsts by default"
|
||||
(dream-resp-header dream-hd-sec "strict-transport-security")
|
||||
nil)
|
||||
(dream-hd-test "body preserved" (dream-resp-body dream-hd-sec) "body")
|
||||
|
||||
(define
|
||||
dream-hd-hsts
|
||||
((dream-security-headers-with (assoc dream-security-defaults :hsts true))
|
||||
dream-hd-h))
|
||||
(dream-hd-test
|
||||
"hsts when enabled"
|
||||
(contains?
|
||||
(dream-resp-header
|
||||
(dream-hd-hsts dream-hd-req)
|
||||
"strict-transport-security")
|
||||
"max-age=31536000")
|
||||
true)
|
||||
|
||||
;; ── cache-control ──────────────────────────────────────────────────
|
||||
(dream-hd-test
|
||||
"cache public"
|
||||
(dream-resp-header
|
||||
(dream-cache (dream-text "x") 60)
|
||||
"cache-control")
|
||||
"public, max-age=60")
|
||||
(dream-hd-test
|
||||
"private cache"
|
||||
(dream-resp-header
|
||||
(dream-private-cache (dream-text "x") 30)
|
||||
"cache-control")
|
||||
"private, max-age=30")
|
||||
(dream-hd-test
|
||||
"no-store"
|
||||
(dream-resp-header (dream-no-store (dream-text "x")) "cache-control")
|
||||
"no-store")
|
||||
(dream-hd-test
|
||||
"no-cache"
|
||||
(dream-resp-header (dream-no-cache (dream-text "x")) "cache-control")
|
||||
"no-cache, no-store, must-revalidate")
|
||||
|
||||
;; ── cache middleware ───────────────────────────────────────────────
|
||||
(define dream-hd-capp ((dream-cache-for 300) dream-hd-h))
|
||||
(dream-hd-test
|
||||
"cache-for stamps"
|
||||
(dream-resp-header (dream-hd-capp dream-hd-req) "cache-control")
|
||||
"public, max-age=300")
|
||||
|
||||
;; ── composes around a router ───────────────────────────────────────
|
||||
(define
|
||||
dream-hd-app
|
||||
(dream-security-headers
|
||||
(dream-router
|
||||
(list (dream-get "/" (fn (req) (dream-html "<p>hi</p>")))))))
|
||||
(dream-hd-test
|
||||
"router security header"
|
||||
(dream-resp-header (dream-hd-app dream-hd-req) "x-frame-options")
|
||||
"DENY")
|
||||
|
||||
(define dream-hd-tests-run! (fn () {:total (+ dream-hd-pass dream-hd-fail) :passed dream-hd-pass :failed dream-hd-fail :fails dream-hd-fails}))
|
||||
59
lib/dream/tests/html.sx
Normal file
59
lib/dream/tests/html.sx
Normal file
@@ -0,0 +1,59 @@
|
||||
;; lib/dream/tests/html.sx — HTML escaping (+ demo XSS regression).
|
||||
|
||||
(define dream-ht-pass 0)
|
||||
(define dream-ht-fail 0)
|
||||
(define dream-ht-fails (list))
|
||||
|
||||
(define
|
||||
dream-ht-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-ht-pass (+ dream-ht-pass 1))
|
||||
(begin
|
||||
(set! dream-ht-fail (+ dream-ht-fail 1))
|
||||
(append! dream-ht-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(dream-ht-test "escape ampersand" (dream-escape "a & b") "a & b")
|
||||
(dream-ht-test "escape lt gt" (dream-escape "<b>") "<b>")
|
||||
(dream-ht-test "escape quote" (dream-escape "say \"hi\"") "say "hi"")
|
||||
(dream-ht-test "escape apostrophe" (dream-escape "it's") "it's")
|
||||
(dream-ht-test
|
||||
"escape script tag"
|
||||
(dream-escape "<script>alert(1)</script>")
|
||||
"<script>alert(1)</script>")
|
||||
(dream-ht-test
|
||||
"ampersand first (no double-escape)"
|
||||
(dream-escape "<")
|
||||
"&lt;")
|
||||
(dream-ht-test
|
||||
"safe string unchanged"
|
||||
(dream-escape "hello world")
|
||||
"hello world")
|
||||
(dream-ht-test
|
||||
"attr escapes value"
|
||||
(dream-attr "title" "a\"b")
|
||||
"title=\"a"b\"")
|
||||
(dream-ht-test
|
||||
"escape-join"
|
||||
(dream-escape-join " " (list "<a>" "<b>"))
|
||||
"<a> <b>")
|
||||
|
||||
;; ── todo demo escapes user input (XSS regression) ──────────────────
|
||||
(define dream-ht-store (dream-todo-store))
|
||||
((get dream-ht-store :add) "<script>alert(1)</script>")
|
||||
(define
|
||||
dream-ht-ctx
|
||||
(assoc (dream-request "GET" "/" {} "") :dream-csrf {:sign dream-csrf-sign-default :sid "s1" :secret "k"}))
|
||||
(define dream-ht-rendered (dr/todo-render dream-ht-store dream-ht-ctx))
|
||||
(dream-ht-test
|
||||
"todo escapes script"
|
||||
(contains? dream-ht-rendered "<script>")
|
||||
true)
|
||||
(dream-ht-test
|
||||
"todo has no raw script"
|
||||
(contains? dream-ht-rendered "<script>")
|
||||
false)
|
||||
|
||||
(define dream-ht-tests-run! (fn () {:total (+ dream-ht-pass dream-ht-fail) :passed dream-ht-pass :failed dream-ht-fail :fails dream-ht-fails}))
|
||||
105
lib/dream/tests/json.sx
Normal file
105
lib/dream/tests/json.sx
Normal file
@@ -0,0 +1,105 @@
|
||||
;; lib/dream/tests/json.sx — JSON encode/parse round-trips.
|
||||
|
||||
(define dream-js-pass 0)
|
||||
(define dream-js-fail 0)
|
||||
(define dream-js-fails (list))
|
||||
|
||||
(define
|
||||
dream-js-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-js-pass (+ dream-js-pass 1))
|
||||
(begin
|
||||
(set! dream-js-fail (+ dream-js-fail 1))
|
||||
(append! dream-js-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── encoding scalars ───────────────────────────────────────────────
|
||||
(dream-js-test "encode int" (dream-json-encode 42) "42")
|
||||
(dream-js-test "encode float" (dream-json-encode 1.5) "1.5")
|
||||
(dream-js-test "encode true" (dream-json-encode true) "true")
|
||||
(dream-js-test "encode false" (dream-json-encode false) "false")
|
||||
(dream-js-test "encode nil" (dream-json-encode nil) "null")
|
||||
(dream-js-test "encode string" (dream-json-encode "hi") "\"hi\"")
|
||||
(dream-js-test
|
||||
"encode string escapes quote"
|
||||
(dream-json-encode "a\"b")
|
||||
"\"a\\\"b\"")
|
||||
(dream-js-test
|
||||
"encode list"
|
||||
(dream-json-encode (list 1 2 3))
|
||||
"[1,2,3]")
|
||||
(dream-js-test
|
||||
"encode list of strings"
|
||||
(dream-json-encode (list "a" "b"))
|
||||
"[\"a\",\"b\"]")
|
||||
(dream-js-test
|
||||
"encode single-key dict"
|
||||
(dream-json-encode {:a 1})
|
||||
"{\"a\":1}")
|
||||
(dream-js-test "encode empty list" (dream-json-encode (list)) "[]")
|
||||
(dream-js-test "encode empty dict" (dream-json-encode {}) "{}")
|
||||
|
||||
;; ── parsing scalars ────────────────────────────────────────────────
|
||||
(dream-js-test "parse int" (dream-json-parse "5") 5)
|
||||
(dream-js-test "parse negative" (dream-json-parse "-7") -7)
|
||||
(dream-js-test "parse float" (dream-json-parse "1.5") 1.5)
|
||||
(dream-js-test "parse true" (dream-json-parse "true") true)
|
||||
(dream-js-test "parse false" (dream-json-parse "false") false)
|
||||
(dream-js-test "parse null" (dream-json-parse "null") nil)
|
||||
(dream-js-test "parse string" (dream-json-parse "\"hello\"") "hello")
|
||||
(dream-js-test "parse string escape" (dream-json-parse "\"a\\nb\"") "a\nb")
|
||||
(dream-js-test
|
||||
"parse array"
|
||||
(dream-json-parse "[1,2,3]")
|
||||
(list 1 2 3))
|
||||
(dream-js-test "parse empty array" (dream-json-parse "[]") (list))
|
||||
(dream-js-test
|
||||
"parse with whitespace"
|
||||
(dream-json-parse " [ 1 , 2 ] ")
|
||||
(list 1 2))
|
||||
|
||||
;; ── parsing objects ────────────────────────────────────────────────
|
||||
(define dream-js-obj (dream-json-parse "{\"x\":5,\"y\":\"hi\"}"))
|
||||
(dream-js-test "parse obj number" (get dream-js-obj "x") 5)
|
||||
(dream-js-test "parse obj string" (get dream-js-obj "y") "hi")
|
||||
(dream-js-test "parse empty obj" (dream-json-parse "{}") {})
|
||||
|
||||
;; ── nested ─────────────────────────────────────────────────────────
|
||||
(define dream-js-nested (dream-json-parse "{\"a\":[1,{\"b\":2}],\"c\":true}"))
|
||||
(dream-js-test
|
||||
"nested array first"
|
||||
(first (get dream-js-nested "a"))
|
||||
1)
|
||||
(dream-js-test
|
||||
"nested object in array"
|
||||
(get (nth (get dream-js-nested "a") 1) "b")
|
||||
2)
|
||||
(dream-js-test "nested bool" (get dream-js-nested "c") true)
|
||||
|
||||
;; ── round-trips ────────────────────────────────────────────────────
|
||||
(define dream-js-v {:name "Ada" :age 36 :tags (list "math" "engine")})
|
||||
(define dream-js-rt (dream-json-parse (dream-json-encode dream-js-v)))
|
||||
(dream-js-test "roundtrip name" (get dream-js-rt "name") "Ada")
|
||||
(dream-js-test "roundtrip age" (get dream-js-rt "age") 36)
|
||||
(dream-js-test
|
||||
"roundtrip tags"
|
||||
(get dream-js-rt "tags")
|
||||
(list "math" "engine"))
|
||||
|
||||
;; ── response + request helpers ─────────────────────────────────────
|
||||
(dream-js-test
|
||||
"json-value content-type"
|
||||
(dream-resp-header (dream-json-value {:ok true}) "content-type")
|
||||
"application/json")
|
||||
(dream-js-test
|
||||
"json-value body"
|
||||
(dream-resp-body (dream-json-value {:ok true}))
|
||||
"{\"ok\":true}")
|
||||
(dream-js-test
|
||||
"json-body parses request"
|
||||
(get (dream-json-body (dream-request "POST" "/" {} "{\"n\":9}")) "n")
|
||||
9)
|
||||
|
||||
(define dream-js-tests-run! (fn () {:total (+ dream-js-pass dream-js-fail) :passed dream-js-pass :failed dream-js-fail :fails dream-js-fails}))
|
||||
150
lib/dream/tests/middleware.sx
Normal file
150
lib/dream/tests/middleware.sx
Normal file
@@ -0,0 +1,150 @@
|
||||
;; lib/dream/tests/middleware.sx — composition, logger, content-type sniffer.
|
||||
|
||||
(define dream-mw-pass 0)
|
||||
(define dream-mw-fail 0)
|
||||
(define dream-mw-fails (list))
|
||||
|
||||
(define
|
||||
dream-mw-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-mw-pass (+ dream-mw-pass 1))
|
||||
(begin
|
||||
(set! dream-mw-fail (+ dream-mw-fail 1))
|
||||
(append! dream-mw-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(define dream-mw-req (dream-request "GET" "/p" {} ""))
|
||||
|
||||
;; ── pipeline composition order ─────────────────────────────────────
|
||||
(define
|
||||
dream-mw-wrap
|
||||
(fn
|
||||
(tag)
|
||||
(fn
|
||||
(next)
|
||||
(fn
|
||||
(req)
|
||||
(dream-html (str tag "(" (dream-resp-body (next req)) ")"))))))
|
||||
(define dream-mw-h (fn (req) (dream-html "h")))
|
||||
|
||||
(dream-mw-test
|
||||
"pipeline empty is identity"
|
||||
(dream-resp-body ((dream-pipeline (list) dream-mw-h) dream-mw-req))
|
||||
"h")
|
||||
(dream-mw-test
|
||||
"pipeline single"
|
||||
(dream-resp-body
|
||||
((dream-pipeline (list (dream-mw-wrap "a")) dream-mw-h) dream-mw-req))
|
||||
"a(h)")
|
||||
(dream-mw-test
|
||||
"pipeline first is outermost"
|
||||
(dream-resp-body
|
||||
((dream-pipeline (list (dream-mw-wrap "a") (dream-mw-wrap "b")) dream-mw-h)
|
||||
dream-mw-req))
|
||||
"a(b(h))")
|
||||
(dream-mw-test
|
||||
"no-middleware is identity"
|
||||
(dream-resp-body ((dream-no-middleware dream-mw-h) dream-mw-req))
|
||||
"h")
|
||||
|
||||
;; ── logger ─────────────────────────────────────────────────────────
|
||||
(define dream-mw-clock-n 0)
|
||||
(define
|
||||
dream-mw-clock
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(set! dream-mw-clock-n (+ dream-mw-clock-n 1))
|
||||
dream-mw-clock-n)))
|
||||
(define dream-mw-entries (list))
|
||||
(define dream-mw-sink (fn (e) (append! dream-mw-entries e)))
|
||||
(define
|
||||
dream-mw-logged
|
||||
((dream-logger-with dream-mw-clock dream-mw-sink)
|
||||
(fn (req) (dream-html-status 201 "ok"))))
|
||||
(define
|
||||
dream-mw-lresp
|
||||
(dream-mw-logged (dream-request "POST" "/log/path" {} "")))
|
||||
|
||||
(dream-mw-test
|
||||
"logger passes response through"
|
||||
(dream-resp-body dream-mw-lresp)
|
||||
"ok")
|
||||
(dream-mw-test "logger records one entry" (len dream-mw-entries) 1)
|
||||
(dream-mw-test
|
||||
"logger entry method"
|
||||
(get (first dream-mw-entries) :method)
|
||||
"POST")
|
||||
(dream-mw-test
|
||||
"logger entry path"
|
||||
(get (first dream-mw-entries) :path)
|
||||
"/log/path")
|
||||
(dream-mw-test
|
||||
"logger entry status"
|
||||
(get (first dream-mw-entries) :status)
|
||||
201)
|
||||
(dream-mw-test
|
||||
"logger entry elapsed"
|
||||
(get (first dream-mw-entries) :elapsed)
|
||||
1)
|
||||
(dream-mw-test
|
||||
"log-line format"
|
||||
(dream-log-line {:path "/x" :status 200 :method "GET" :elapsed 4})
|
||||
"GET /x -> 200 (4ms)")
|
||||
|
||||
;; ── content-type sniffer ───────────────────────────────────────────
|
||||
(define dream-mw-ct (fn (handler) (dream-content-type handler)))
|
||||
(define
|
||||
dream-mw-sniff
|
||||
(fn
|
||||
(body)
|
||||
(dream-resp-header
|
||||
((dream-content-type (fn (req) (dream-response 200 {} body)))
|
||||
dream-mw-req)
|
||||
"content-type")))
|
||||
|
||||
(dream-mw-test
|
||||
"sniff html"
|
||||
(dream-mw-sniff "<p>hi</p>")
|
||||
"text/html; charset=utf-8")
|
||||
(dream-mw-test
|
||||
"sniff doctype"
|
||||
(dream-mw-sniff "<!doctype html>")
|
||||
"text/html; charset=utf-8")
|
||||
(dream-mw-test
|
||||
"sniff json object"
|
||||
(dream-mw-sniff "{\"a\":1}")
|
||||
"application/json")
|
||||
(dream-mw-test "sniff json array" (dream-mw-sniff "[1,2]") "application/json")
|
||||
(dream-mw-test
|
||||
"sniff plain text"
|
||||
(dream-mw-sniff "just words")
|
||||
"text/plain; charset=utf-8")
|
||||
(dream-mw-test
|
||||
"sniff empty body"
|
||||
(dream-mw-sniff "")
|
||||
"text/plain; charset=utf-8")
|
||||
(dream-mw-test
|
||||
"sniff does not override existing"
|
||||
(dream-resp-header
|
||||
((dream-content-type (fn (req) (dream-json "{}"))) dream-mw-req)
|
||||
"content-type")
|
||||
"application/json")
|
||||
|
||||
;; ── small middlewares ──────────────────────────────────────────────
|
||||
(dream-mw-test
|
||||
"set-header attaches"
|
||||
(dream-resp-header
|
||||
(((dream-set-header "X-A" "1") dream-mw-h) dream-mw-req)
|
||||
"x-a")
|
||||
"1")
|
||||
(dream-mw-test
|
||||
"tap-request rewrites"
|
||||
(dream-resp-body
|
||||
(((dream-tap-request (fn (req) (dream-set-body req "tapped"))) (fn (req) (dream-html (dream-body req))))
|
||||
(dream-request "GET" "/" {} "orig")))
|
||||
"tapped")
|
||||
|
||||
(define dream-mw-tests-run! (fn () {:total (+ dream-mw-pass dream-mw-fail) :passed dream-mw-pass :failed dream-mw-fail :fails dream-mw-fails}))
|
||||
272
lib/dream/tests/router.sx
Normal file
272
lib/dream/tests/router.sx
Normal file
@@ -0,0 +1,272 @@
|
||||
;; lib/dream/tests/router.sx — routing dispatch, path params, scopes, 405/HEAD.
|
||||
|
||||
(define dream-rt-pass 0)
|
||||
(define dream-rt-fail 0)
|
||||
(define dream-rt-fails (list))
|
||||
|
||||
(define
|
||||
dream-rt-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-rt-pass (+ dream-rt-pass 1))
|
||||
(begin
|
||||
(set! dream-rt-fail (+ dream-rt-fail 1))
|
||||
(append! dream-rt-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(define
|
||||
dream-rt-req
|
||||
(fn (method target) (dream-request method target {} "")))
|
||||
|
||||
;; ── basic dispatch ─────────────────────────────────────────────────
|
||||
(define
|
||||
dream-rt-app
|
||||
(dream-router
|
||||
(list
|
||||
(dream-get "/" (fn (req) (dream-text "home")))
|
||||
(dream-get "/about" (fn (req) (dream-text "about")))
|
||||
(dream-post "/submit" (fn (req) (dream-text "posted"))))))
|
||||
|
||||
(dream-rt-test
|
||||
"GET / -> home"
|
||||
(dream-resp-body (dream-rt-app (dream-rt-req "GET" "/")))
|
||||
"home")
|
||||
(dream-rt-test
|
||||
"GET /about"
|
||||
(dream-resp-body (dream-rt-app (dream-rt-req "GET" "/about")))
|
||||
"about")
|
||||
(dream-rt-test
|
||||
"POST /submit"
|
||||
(dream-resp-body (dream-rt-app (dream-rt-req "POST" "/submit")))
|
||||
"posted")
|
||||
(dream-rt-test
|
||||
"unknown path 404"
|
||||
(dream-status (dream-rt-app (dream-rt-req "GET" "/nope")))
|
||||
404)
|
||||
(dream-rt-test
|
||||
"wrong method 405"
|
||||
(dream-status (dream-rt-app (dream-rt-req "GET" "/submit")))
|
||||
405)
|
||||
(dream-rt-test
|
||||
"trailing slash equiv"
|
||||
(dream-resp-body (dream-rt-app (dream-rt-req "GET" "/about/")))
|
||||
"about")
|
||||
(dream-rt-test
|
||||
"query ignored for routing"
|
||||
(dream-resp-body (dream-rt-app (dream-rt-req "GET" "/about?x=1")))
|
||||
"about")
|
||||
|
||||
;; ── path params ────────────────────────────────────────────────────
|
||||
(define
|
||||
dream-rt-papp
|
||||
(dream-router
|
||||
(list
|
||||
(dream-get
|
||||
"/users/:id"
|
||||
(fn (req) (dream-text (dream-param req "id"))))
|
||||
(dream-get
|
||||
"/users/:id/posts/:pid"
|
||||
(fn
|
||||
(req)
|
||||
(dream-text
|
||||
(str (dream-param req "id") "-" (dream-param req "pid")))))
|
||||
(dream-get
|
||||
"/files/**"
|
||||
(fn (req) (dream-text (dream-param req "**")))))))
|
||||
|
||||
(dream-rt-test
|
||||
"single param"
|
||||
(dream-resp-body (dream-rt-papp (dream-rt-req "GET" "/users/42")))
|
||||
"42")
|
||||
(dream-rt-test
|
||||
"two params"
|
||||
(dream-resp-body (dream-rt-papp (dream-rt-req "GET" "/users/7/posts/9")))
|
||||
"7-9")
|
||||
(dream-rt-test
|
||||
"param no over-match"
|
||||
(dream-status (dream-rt-papp (dream-rt-req "GET" "/users/7/extra")))
|
||||
404)
|
||||
(dream-rt-test
|
||||
"catch-all captures rest"
|
||||
(dream-resp-body (dream-rt-papp (dream-rt-req "GET" "/files/a/b/c.txt")))
|
||||
"a/b/c.txt")
|
||||
(dream-rt-test
|
||||
"catch-all empty rest"
|
||||
(dream-resp-body (dream-rt-papp (dream-rt-req "GET" "/files/")))
|
||||
"")
|
||||
|
||||
;; ── route order: first match wins ──────────────────────────────────
|
||||
(define
|
||||
dream-rt-order
|
||||
(dream-router
|
||||
(list
|
||||
(dream-get "/x/specific" (fn (req) (dream-text "specific")))
|
||||
(dream-get "/x/:slug" (fn (req) (dream-text "generic"))))))
|
||||
(dream-rt-test
|
||||
"first match wins"
|
||||
(dream-resp-body (dream-rt-order (dream-rt-req "GET" "/x/specific")))
|
||||
"specific")
|
||||
(dream-rt-test
|
||||
"fallthrough to param"
|
||||
(dream-resp-body (dream-rt-order (dream-rt-req "GET" "/x/other")))
|
||||
"generic")
|
||||
|
||||
;; ── ANY method ─────────────────────────────────────────────────────
|
||||
(define
|
||||
dream-rt-any
|
||||
(dream-router
|
||||
(list (dream-any "/ping" (fn (req) (dream-text (dream-method req)))))))
|
||||
(dream-rt-test
|
||||
"ANY matches GET"
|
||||
(dream-resp-body (dream-rt-any (dream-rt-req "GET" "/ping")))
|
||||
"GET")
|
||||
(dream-rt-test
|
||||
"ANY matches DELETE"
|
||||
(dream-resp-body (dream-rt-any (dream-rt-req "DELETE" "/ping")))
|
||||
"DELETE")
|
||||
|
||||
;; ── handler returns bare string (coerced) ──────────────────────────
|
||||
(define
|
||||
dream-rt-coerce
|
||||
(dream-router (list (dream-get "/s" (fn (req) "bare")))))
|
||||
(dream-rt-test
|
||||
"string coerced to 200"
|
||||
(dream-status (dream-rt-coerce (dream-rt-req "GET" "/s")))
|
||||
200)
|
||||
(dream-rt-test
|
||||
"string coerced body"
|
||||
(dream-resp-body (dream-rt-coerce (dream-rt-req "GET" "/s")))
|
||||
"bare")
|
||||
|
||||
;; ── scope: prefix mount ────────────────────────────────────────────
|
||||
(define
|
||||
dream-rt-scoped
|
||||
(dream-router
|
||||
(list
|
||||
(dream-get "/" (fn (req) (dream-text "root")))
|
||||
(dream-scope
|
||||
"/api"
|
||||
(list)
|
||||
(list
|
||||
(dream-get "/users" (fn (req) (dream-text "api-users")))
|
||||
(dream-get
|
||||
"/users/:id"
|
||||
(fn
|
||||
(req)
|
||||
(dream-text (str "api-user-" (dream-param req "id"))))))))))
|
||||
(dream-rt-test
|
||||
"scope root still works"
|
||||
(dream-resp-body (dream-rt-scoped (dream-rt-req "GET" "/")))
|
||||
"root")
|
||||
(dream-rt-test
|
||||
"scope prefix path"
|
||||
(dream-resp-body (dream-rt-scoped (dream-rt-req "GET" "/api/users")))
|
||||
"api-users")
|
||||
(dream-rt-test
|
||||
"scope prefix param"
|
||||
(dream-resp-body (dream-rt-scoped (dream-rt-req "GET" "/api/users/5")))
|
||||
"api-user-5")
|
||||
(dream-rt-test
|
||||
"scope unprefixed 404"
|
||||
(dream-status (dream-rt-scoped (dream-rt-req "GET" "/users")))
|
||||
404)
|
||||
|
||||
;; ── scope: middleware applied to all routes ────────────────────────
|
||||
(define
|
||||
dream-rt-mw
|
||||
(fn (next) (fn (req) (dream-add-header (next req) "X-Scope" "on"))))
|
||||
(define
|
||||
dream-rt-mwapp
|
||||
(dream-router
|
||||
(list
|
||||
(dream-scope
|
||||
"/v1"
|
||||
(list dream-rt-mw)
|
||||
(list (dream-get "/a" (fn (req) (dream-text "a"))))))))
|
||||
(dream-rt-test
|
||||
"scope mw header"
|
||||
(dream-resp-header (dream-rt-mwapp (dream-rt-req "GET" "/v1/a")) "x-scope")
|
||||
"on")
|
||||
(dream-rt-test
|
||||
"scope mw body intact"
|
||||
(dream-resp-body (dream-rt-mwapp (dream-rt-req "GET" "/v1/a")))
|
||||
"a")
|
||||
|
||||
;; ── nested scopes ──────────────────────────────────────────────────
|
||||
(define
|
||||
dream-rt-outer
|
||||
(fn (next) (fn (req) (dream-add-header (next req) "X-Outer" "1"))))
|
||||
(define
|
||||
dream-rt-inner
|
||||
(fn (next) (fn (req) (dream-add-header (next req) "X-Inner" "1"))))
|
||||
(define
|
||||
dream-rt-nested
|
||||
(dream-router
|
||||
(list
|
||||
(dream-scope
|
||||
"/api"
|
||||
(list dream-rt-outer)
|
||||
(list
|
||||
(dream-scope
|
||||
"/v2"
|
||||
(list dream-rt-inner)
|
||||
(list (dream-get "/thing" (fn (req) (dream-text "thing"))))))))))
|
||||
(dream-rt-test
|
||||
"nested path"
|
||||
(dream-resp-body (dream-rt-nested (dream-rt-req "GET" "/api/v2/thing")))
|
||||
"thing")
|
||||
(dream-rt-test
|
||||
"nested outer mw"
|
||||
(dream-resp-header
|
||||
(dream-rt-nested (dream-rt-req "GET" "/api/v2/thing"))
|
||||
"x-outer")
|
||||
"1")
|
||||
(dream-rt-test
|
||||
"nested inner mw"
|
||||
(dream-resp-header
|
||||
(dream-rt-nested (dream-rt-req "GET" "/api/v2/thing"))
|
||||
"x-inner")
|
||||
"1")
|
||||
|
||||
;; ── 405 Method Not Allowed + Allow ─────────────────────────────────
|
||||
(define
|
||||
dream-rt-mapp
|
||||
(dream-router
|
||||
(list
|
||||
(dream-get "/r" (fn (req) (dream-text "get")))
|
||||
(dream-post "/r" (fn (req) (dream-text "post")))
|
||||
(dream-get "/only" (fn (req) (dream-html "<p>hi</p>"))))))
|
||||
(define dream-rt-405 (dream-rt-mapp (dream-rt-req "DELETE" "/r")))
|
||||
(dream-rt-test "405 status" (dream-status dream-rt-405) 405)
|
||||
(dream-rt-test
|
||||
"405 Allow has GET"
|
||||
(contains? (dream-resp-header dream-rt-405 "allow") "GET")
|
||||
true)
|
||||
(dream-rt-test
|
||||
"405 Allow has POST"
|
||||
(contains? (dream-resp-header dream-rt-405 "allow") "POST")
|
||||
true)
|
||||
(dream-rt-test
|
||||
"matching method still works"
|
||||
(dream-resp-body (dream-rt-mapp (dream-rt-req "POST" "/r")))
|
||||
"post")
|
||||
(dream-rt-test
|
||||
"no path is 404 not 405"
|
||||
(dream-status (dream-rt-mapp (dream-rt-req "DELETE" "/absent")))
|
||||
404)
|
||||
|
||||
;; ── automatic HEAD (serve GET, empty body) ─────────────────────────
|
||||
(define dream-rt-head (dream-rt-mapp (dream-rt-req "HEAD" "/only")))
|
||||
(dream-rt-test "HEAD status 200" (dream-status dream-rt-head) 200)
|
||||
(dream-rt-test "HEAD empty body" (dream-resp-body dream-rt-head) "")
|
||||
(dream-rt-test
|
||||
"HEAD keeps content-type"
|
||||
(dream-resp-header dream-rt-head "content-type")
|
||||
"text/html; charset=utf-8")
|
||||
(dream-rt-test
|
||||
"HEAD on missing path 404"
|
||||
(dream-status (dream-rt-mapp (dream-rt-req "HEAD" "/none")))
|
||||
404)
|
||||
|
||||
(define dream-rt-tests-run! (fn () {:total (+ dream-rt-pass dream-rt-fail) :passed dream-rt-pass :failed dream-rt-fail :fails dream-rt-fails}))
|
||||
123
lib/dream/tests/run.sx
Normal file
123
lib/dream/tests/run.sx
Normal file
@@ -0,0 +1,123 @@
|
||||
;; lib/dream/tests/run.sx — app adapter + dream-run wiring.
|
||||
|
||||
(define dream-rn-pass 0)
|
||||
(define dream-rn-fail 0)
|
||||
(define dream-rn-fails (list))
|
||||
|
||||
(define
|
||||
dream-rn-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-rn-pass (+ dream-rn-pass 1))
|
||||
(begin
|
||||
(set! dream-rn-fail (+ dream-rn-fail 1))
|
||||
(append! dream-rn-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── app adapter: raw -> serialised response ────────────────────────
|
||||
(define
|
||||
dream-rn-router
|
||||
(dream-router
|
||||
(list
|
||||
(dream-get "/" (fn (req) (dream-text "home")))
|
||||
(dream-get
|
||||
"/u/:id"
|
||||
(fn (req) (dream-text (str "u=" (dream-param req "id")))))
|
||||
(dream-post "/echo" (fn (req) (dream-text (dream-body req)))))))
|
||||
(define dream-rn-app (dream-app dream-rn-router))
|
||||
|
||||
(define dream-rn-r1 (dream-rn-app {:method "GET" :target "/"}))
|
||||
(dream-rn-test "serialised status" (get dream-rn-r1 :status) 200)
|
||||
(dream-rn-test "serialised body" (get dream-rn-r1 :body) "home")
|
||||
(dream-rn-test
|
||||
"serialised content-type"
|
||||
(get (get dream-rn-r1 :headers) "content-type")
|
||||
"text/plain; charset=utf-8")
|
||||
(dream-rn-test
|
||||
"serialised set-cookies empty"
|
||||
(get dream-rn-r1 :set-cookies)
|
||||
(list))
|
||||
|
||||
(dream-rn-test
|
||||
"adapts target+params"
|
||||
(get (dream-rn-app {:method "GET" :target "/u/42"}) :body)
|
||||
"u=42")
|
||||
(dream-rn-test "adapts body" (get (dream-rn-app {:body "ping" :method "POST" :target "/echo"}) :body) "ping")
|
||||
(dream-rn-test
|
||||
"method defaults to GET"
|
||||
(get (dream-rn-app {:target "/"}) :body)
|
||||
"home")
|
||||
(dream-rn-test
|
||||
"missing target -> /"
|
||||
(get (dream-rn-app {:method "GET"}) :status)
|
||||
200)
|
||||
(dream-rn-test
|
||||
"unknown route 404"
|
||||
(get (dream-rn-app {:method "GET" :target "/nope"}) :status)
|
||||
404)
|
||||
|
||||
;; bare-string handler is coerced
|
||||
(define dream-rn-bare (dream-app (fn (req) "plain")))
|
||||
(dream-rn-test
|
||||
"coerces bare string status"
|
||||
(get (dream-rn-bare {:target "/"}) :status)
|
||||
200)
|
||||
(dream-rn-test
|
||||
"coerces bare string body"
|
||||
(get (dream-rn-bare {:target "/"}) :body)
|
||||
"plain")
|
||||
|
||||
;; ── set-cookies flow through (session middleware) ──────────────────
|
||||
(define
|
||||
dream-rn-sess-app
|
||||
(dream-app
|
||||
((dream-sessions (dream-memory-sessions))
|
||||
(fn (req) (dream-text "ok")))))
|
||||
(define dream-rn-sess-r (dream-rn-sess-app {:method "GET" :target "/"}))
|
||||
(dream-rn-test
|
||||
"session set-cookie present"
|
||||
(len (get dream-rn-sess-r :set-cookies))
|
||||
1)
|
||||
(dream-rn-test
|
||||
"session cookie content"
|
||||
(contains? (first (get dream-rn-sess-r :set-cookies)) "dream.session=")
|
||||
true)
|
||||
|
||||
;; ── websocket upgrade serialisation ────────────────────────────────
|
||||
(define
|
||||
dream-rn-ws-app
|
||||
(dream-app (dream-websocket (fn (ws) (dream-close ws)))))
|
||||
(define dream-rn-ws-r (dream-rn-ws-app {:method "GET" :target "/ws"}))
|
||||
(dream-rn-test "ws upgrade status 101" (get dream-rn-ws-r :status) 101)
|
||||
(dream-rn-test
|
||||
"ws handler carried"
|
||||
(not (nil? (get dream-rn-ws-r :websocket)))
|
||||
true)
|
||||
|
||||
;; ── dream-run wiring (mock listen captures the op) ─────────────────
|
||||
(define dream-rn-captured nil)
|
||||
(define
|
||||
dream-rn-listen
|
||||
(fn (op) (begin (set! dream-rn-captured op) :listening)))
|
||||
(define
|
||||
dream-rn-result
|
||||
(dream-run-with dream-rn-listen dream-rn-router {:port 9000}))
|
||||
(dream-rn-test "listen returns" dream-rn-result :listening)
|
||||
(dream-rn-test "listen op kind" (get dream-rn-captured :op) "http/listen")
|
||||
(dream-rn-test "listen port" (get dream-rn-captured :port) 9000)
|
||||
(dream-rn-test
|
||||
"default port"
|
||||
(get
|
||||
(begin
|
||||
(dream-run-with dream-rn-listen dream-rn-router {})
|
||||
dream-rn-captured)
|
||||
:port)
|
||||
8080)
|
||||
;; the captured app is runnable
|
||||
(dream-rn-test
|
||||
"captured app serves"
|
||||
(get ((get dream-rn-captured :app) {:method "GET" :target "/"}) :body)
|
||||
"home")
|
||||
|
||||
(define dream-rn-tests-run! (fn () {:total (+ dream-rn-pass dream-rn-fail) :passed dream-rn-pass :failed dream-rn-fail :fails dream-rn-fails}))
|
||||
197
lib/dream/tests/session.sx
Normal file
197
lib/dream/tests/session.sx
Normal file
@@ -0,0 +1,197 @@
|
||||
;; lib/dream/tests/session.sx — cookies, store, session round-trip, signed cookies.
|
||||
|
||||
(define dream-ss-pass 0)
|
||||
(define dream-ss-fail 0)
|
||||
(define dream-ss-fails (list))
|
||||
|
||||
(define
|
||||
dream-ss-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-ss-pass (+ dream-ss-pass 1))
|
||||
(begin
|
||||
(set! dream-ss-fail (+ dream-ss-fail 1))
|
||||
(append! dream-ss-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── cookie parsing ─────────────────────────────────────────────────
|
||||
(define dream-ss-creq (dream-request "GET" "/" {:Cookie "a=1; b=2; dream.session=s9"} ""))
|
||||
(dream-ss-test "parse cookie a" (dream-cookie dream-ss-creq "a") "1")
|
||||
(dream-ss-test "parse cookie b" (dream-cookie dream-ss-creq "b") "2")
|
||||
(dream-ss-test
|
||||
"parse session cookie"
|
||||
(dream-cookie dream-ss-creq "dream.session")
|
||||
"s9")
|
||||
(dream-ss-test "missing cookie nil" (dream-cookie dream-ss-creq "z") nil)
|
||||
(dream-ss-test
|
||||
"no cookie header"
|
||||
(dream-cookie (dream-request "GET" "/" {} "") "a")
|
||||
nil)
|
||||
|
||||
;; ── cookie building ────────────────────────────────────────────────
|
||||
(dream-ss-test
|
||||
"build basic cookie"
|
||||
(dr/build-cookie "k" "v" {})
|
||||
"k=v; Path=/")
|
||||
(dream-ss-test
|
||||
"build httponly samesite"
|
||||
(dr/build-cookie "sid" "x" {:http-only true :same-site "Lax"})
|
||||
"sid=x; Path=/; HttpOnly; SameSite=Lax")
|
||||
(dream-ss-test
|
||||
"build max-age"
|
||||
(dr/build-cookie "k" "v" {:max-age 0})
|
||||
"k=v; Path=/; Max-Age=0")
|
||||
(dream-ss-test
|
||||
"set-cookie appends"
|
||||
(len
|
||||
(dream-resp-cookies
|
||||
(dream-set-cookie (dream-html "x") "k" "v" {})))
|
||||
1)
|
||||
(dream-ss-test
|
||||
"set-cookie two"
|
||||
(len
|
||||
(dream-resp-cookies
|
||||
(dream-set-cookie
|
||||
(dream-set-cookie (dream-html "x") "a" "1" {})
|
||||
"b"
|
||||
"2"
|
||||
{})))
|
||||
2)
|
||||
(dream-ss-test
|
||||
"drop cookie max-age 0"
|
||||
(contains?
|
||||
(first (dream-resp-cookies (dream-drop-cookie (dream-html "x") "k")))
|
||||
"Max-Age=0")
|
||||
true)
|
||||
|
||||
;; ── signed cookie values ───────────────────────────────────────────
|
||||
(dream-ss-test
|
||||
"sign/unsign roundtrip"
|
||||
(dream-cookie-unsign "k" (dream-cookie-sign "k" "s5"))
|
||||
"s5")
|
||||
(dream-ss-test
|
||||
"unsign wrong secret"
|
||||
(dream-cookie-unsign "k2" (dream-cookie-sign "k" "s5"))
|
||||
nil)
|
||||
(dream-ss-test "unsign tampered" (dream-cookie-unsign "k" "s5.999") nil)
|
||||
(dream-ss-test "unsign no dot" (dream-cookie-unsign "k" "s5") nil)
|
||||
(dream-ss-test "unsign nil" (dream-cookie-unsign "k" nil) nil)
|
||||
|
||||
;; ── in-memory store ────────────────────────────────────────────────
|
||||
(define dream-ss-store (dream-memory-sessions))
|
||||
(define dream-ss-sid (dream-ss-store {:op "session/create"}))
|
||||
(dream-ss-test "create returns id" dream-ss-sid "s1")
|
||||
(dream-ss-test "new session exists" (dream-ss-store {:op "session/exists" :sid "s1"}) true)
|
||||
(dream-ss-test "absent session not exists" (dream-ss-store {:op "session/exists" :sid "s99"}) false)
|
||||
(dream-ss-test "get missing key nil" (dream-ss-store {:key "k" :op "session/get" :sid "s1"}) nil)
|
||||
(dream-ss-store {:val "ada" :key "user" :op "session/set" :sid "s1"})
|
||||
(dream-ss-test "set then get" (dream-ss-store {:key "user" :op "session/get" :sid "s1"}) "ada")
|
||||
(dream-ss-store {:val "admin" :key "role" :op "session/set" :sid "s1"})
|
||||
(dream-ss-test "load all fields" (dream-ss-store {:op "session/load" :sid "s1"}) {:role "admin" :user "ada"})
|
||||
(dream-ss-test "second create distinct" (dream-ss-store {:op "session/create"}) "s2")
|
||||
(dream-ss-store {:op "session/clear" :sid "s1"})
|
||||
(dream-ss-test "clear removes" (dream-ss-store {:op "session/exists" :sid "s1"}) false)
|
||||
|
||||
;; ── middleware round-trip ──────────────────────────────────────────
|
||||
(define dream-ss-backend (dream-memory-sessions))
|
||||
(define
|
||||
dream-ss-counter-h
|
||||
(fn
|
||||
(req)
|
||||
(let
|
||||
((n (or (dream-session-field req "count") 0)))
|
||||
(begin
|
||||
(dream-set-session-field req "count" (+ n 1))
|
||||
(dream-text (str "count=" (+ n 1)))))))
|
||||
(define dream-ss-app ((dream-sessions dream-ss-backend) dream-ss-counter-h))
|
||||
|
||||
(define dream-ss-r1 (dream-ss-app (dream-request "GET" "/" {} "")))
|
||||
(dream-ss-test "first body count=1" (dream-resp-body dream-ss-r1) "count=1")
|
||||
(dream-ss-test
|
||||
"first sets one cookie"
|
||||
(len (dream-resp-cookies dream-ss-r1))
|
||||
1)
|
||||
(dream-ss-test
|
||||
"session cookie name+id"
|
||||
(contains? (first (dream-resp-cookies dream-ss-r1)) "dream.session=s1")
|
||||
true)
|
||||
(dream-ss-test
|
||||
"session cookie httponly"
|
||||
(contains? (first (dream-resp-cookies dream-ss-r1)) "HttpOnly")
|
||||
true)
|
||||
|
||||
(define dream-ss-r2 (dream-ss-app (dream-request "GET" "/" {:Cookie "dream.session=s1"} "")))
|
||||
(dream-ss-test "second body count=2" (dream-resp-body dream-ss-r2) "count=2")
|
||||
(dream-ss-test
|
||||
"second sets no cookie"
|
||||
(len (dream-resp-cookies dream-ss-r2))
|
||||
0)
|
||||
|
||||
(define dream-ss-r3 (dream-ss-app (dream-request "GET" "/" {:Cookie "dream.session=s1"} "")))
|
||||
(dream-ss-test "third body count=3" (dream-resp-body dream-ss-r3) "count=3")
|
||||
|
||||
(define dream-ss-r4 (dream-ss-app (dream-request "GET" "/" {:Cookie "dream.session=bogus"} "")))
|
||||
(dream-ss-test
|
||||
"bogus id starts fresh"
|
||||
(dream-resp-body dream-ss-r4)
|
||||
"count=1")
|
||||
(dream-ss-test
|
||||
"bogus id gets new cookie"
|
||||
(len (dream-resp-cookies dream-ss-r4))
|
||||
1)
|
||||
|
||||
;; ── session-all + invalidate via middleware ────────────────────────
|
||||
(dream-ss-test
|
||||
"session-all shows count"
|
||||
(dream-session-all
|
||||
(assoc (dream-request "GET" "/" {} "") :dream-session {:io dream-ss-backend :sid "s1"}))
|
||||
{:count 3})
|
||||
|
||||
(define
|
||||
dream-ss-invalidate-h
|
||||
(fn (req) (begin (dream-invalidate-session req) (dream-text "bye"))))
|
||||
(define
|
||||
dream-ss-app3
|
||||
((dream-sessions dream-ss-backend) dream-ss-invalidate-h))
|
||||
(dream-ss-app3 (dream-request "GET" "/" {:Cookie "dream.session=s1"} ""))
|
||||
(dream-ss-test "invalidate clears store" (dream-ss-backend {:op "session/exists" :sid "s1"}) false)
|
||||
|
||||
;; ── signed session middleware ──────────────────────────────────────
|
||||
(define dream-ss-sbackend (dream-memory-sessions))
|
||||
(define
|
||||
dream-ss-sapp
|
||||
((dream-sessions-signed dream-ss-sbackend "topsecret")
|
||||
(fn (req) (dream-text (dream-session-id req)))))
|
||||
|
||||
(define dream-ss-sr1 (dream-ss-sapp (dream-request "GET" "/" {} "")))
|
||||
(dream-ss-test "signed first sid" (dream-resp-body dream-ss-sr1) "s1")
|
||||
(dream-ss-test
|
||||
"signed cookie is signed"
|
||||
(contains? (first (dream-resp-cookies dream-ss-sr1)) "dream.session=s1.")
|
||||
true)
|
||||
|
||||
;; forged plaintext sid (no signature) is rejected -> a fresh session is made
|
||||
(dream-ss-test
|
||||
"forged plaintext rejected -> new session"
|
||||
(dream-resp-body (dream-ss-sapp (dream-request "GET" "/" {:Cookie "dream.session=s1"} "")))
|
||||
"s2")
|
||||
|
||||
;; a validly-signed cookie reuses the session
|
||||
(define dream-ss-signed-val (dream-cookie-sign "topsecret" "s1"))
|
||||
(define dream-ss-sr3 (dream-ss-sapp (dream-request "GET" "/" {:Cookie (str "dream.session=" dream-ss-signed-val)} "")))
|
||||
(dream-ss-test "valid signed reuses s1" (dream-resp-body dream-ss-sr3) "s1")
|
||||
(dream-ss-test
|
||||
"valid signed sets no new cookie"
|
||||
(len (dream-resp-cookies dream-ss-sr3))
|
||||
0)
|
||||
|
||||
;; a cookie signed with the wrong secret is rejected
|
||||
(dream-ss-test
|
||||
"wrong-secret signed rejected"
|
||||
(=
|
||||
(dream-resp-body (dream-ss-sapp (dream-request "GET" "/" {:Cookie (str "dream.session=" (dream-cookie-sign "other" "s1"))} "")))
|
||||
"s1")
|
||||
false)
|
||||
|
||||
(define dream-ss-tests-run! (fn () {:total (+ dream-ss-pass dream-ss-fail) :passed dream-ss-pass :failed dream-ss-fail :fails dream-ss-fails}))
|
||||
125
lib/dream/tests/static.sx
Normal file
125
lib/dream/tests/static.sx
Normal file
@@ -0,0 +1,125 @@
|
||||
;; lib/dream/tests/static.sx — content types, etags, 304, ranges, traversal.
|
||||
|
||||
(define dream-st-pass 0)
|
||||
(define dream-st-fail 0)
|
||||
(define dream-st-fails (list))
|
||||
|
||||
(define
|
||||
dream-st-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-st-pass (+ dream-st-pass 1))
|
||||
(begin
|
||||
(set! dream-st-fail (+ dream-st-fail 1))
|
||||
(append! dream-st-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── content type + ext ─────────────────────────────────────────────
|
||||
(dream-st-test "ext css" (dr/ext-of "a/b/style.css") "css")
|
||||
(dream-st-test "ext multi-dot" (dr/ext-of "a.min.js") "js")
|
||||
(dream-st-test "ext none" (dr/ext-of "README") "")
|
||||
(dream-st-test
|
||||
"ctype css"
|
||||
(dream-content-type-for "x.css")
|
||||
"text/css; charset=utf-8")
|
||||
(dream-st-test
|
||||
"ctype html"
|
||||
(dream-content-type-for "x.html")
|
||||
"text/html; charset=utf-8")
|
||||
(dream-st-test "ctype png" (dream-content-type-for "x.png") "image/png")
|
||||
(dream-st-test
|
||||
"ctype unknown"
|
||||
(dream-content-type-for "x.bin")
|
||||
"application/octet-stream")
|
||||
|
||||
;; ── etag ───────────────────────────────────────────────────────────
|
||||
(dream-st-test
|
||||
"etag deterministic"
|
||||
(= (dr/etag-of "abc") (dr/etag-of "abc"))
|
||||
true)
|
||||
(dream-st-test
|
||||
"etag content-sensitive"
|
||||
(= (dr/etag-of "abc") (dr/etag-of "abd"))
|
||||
false)
|
||||
(dream-st-test
|
||||
"etag length-sensitive"
|
||||
(= (dr/etag-of "ab") (dr/etag-of "abc"))
|
||||
false)
|
||||
|
||||
;; ── serving via router mount ───────────────────────────────────────
|
||||
(define dream-st-files {:/srv/app.css "body{color:red}" :/srv/index.html "<h1>Hi</h1>"})
|
||||
(define dream-st-fs (dream-memory-fs dream-st-files))
|
||||
(define
|
||||
dream-st-app
|
||||
(dream-router
|
||||
(list (dream-get "/static/**" (dream-static-with "/srv" dream-st-fs)))))
|
||||
(define
|
||||
dream-st-get
|
||||
(fn
|
||||
(target headers)
|
||||
(dream-st-app (dream-request "GET" target headers ""))))
|
||||
|
||||
(define dream-st-css (dream-st-get "/static/app.css" {}))
|
||||
(dream-st-test "serve status 200" (dream-status dream-st-css) 200)
|
||||
(dream-st-test "serve body" (dream-resp-body dream-st-css) "body{color:red}")
|
||||
(dream-st-test
|
||||
"serve content-type"
|
||||
(dream-resp-header dream-st-css "content-type")
|
||||
"text/css; charset=utf-8")
|
||||
(dream-st-test
|
||||
"serve accept-ranges"
|
||||
(dream-resp-header dream-st-css "accept-ranges")
|
||||
"bytes")
|
||||
(dream-st-test
|
||||
"serve has etag"
|
||||
(not (nil? (dream-resp-header dream-st-css "etag")))
|
||||
true)
|
||||
(dream-st-test
|
||||
"missing file 404"
|
||||
(dream-status (dream-st-get "/static/nope.txt" {}))
|
||||
404)
|
||||
(dream-st-test
|
||||
"traversal blocked 403"
|
||||
(dream-status (dream-st-get "/static/../secret" {}))
|
||||
403)
|
||||
|
||||
;; ── conditional: If-None-Match -> 304 ──────────────────────────────
|
||||
(define dream-st-etag (dream-resp-header dream-st-css "etag"))
|
||||
(define dream-st-304 (dream-st-get "/static/app.css" {:If-None-Match dream-st-etag}))
|
||||
(dream-st-test "matching etag 304" (dream-status dream-st-304) 304)
|
||||
(dream-st-test "304 empty body" (dream-resp-body dream-st-304) "")
|
||||
(dream-st-test
|
||||
"stale etag 200"
|
||||
(dream-status (dream-st-get "/static/app.css" {:If-None-Match "\"stale\""}))
|
||||
200)
|
||||
(dream-st-test
|
||||
"star etag 304"
|
||||
(dream-status (dream-st-get "/static/app.css" {:If-None-Match "*"}))
|
||||
304)
|
||||
|
||||
;; ── range requests ─────────────────────────────────────────────────
|
||||
(define dream-st-range (dream-st-get "/static/app.css" {:Range "bytes=0-3"}))
|
||||
(dream-st-test "range status 206" (dream-status dream-st-range) 206)
|
||||
(dream-st-test "range body slice" (dream-resp-body dream-st-range) "body")
|
||||
(dream-st-test
|
||||
"range content-range"
|
||||
(dream-resp-header dream-st-range "content-range")
|
||||
"bytes 0-3/15")
|
||||
(define dream-st-open (dream-st-get "/static/app.css" {:Range "bytes=5-"}))
|
||||
(dream-st-test "open range body" (dream-resp-body dream-st-open) "color:red}")
|
||||
(dream-st-test
|
||||
"open range header"
|
||||
(dream-resp-header dream-st-open "content-range")
|
||||
"bytes 5-14/15")
|
||||
(define dream-st-bad (dream-st-get "/static/app.css" {:Range "bytes=20-30"}))
|
||||
(dream-st-test
|
||||
"unsatisfiable range 416"
|
||||
(dream-status dream-st-bad)
|
||||
416)
|
||||
(dream-st-test
|
||||
"416 content-range"
|
||||
(dream-resp-header dream-st-bad "content-range")
|
||||
"bytes */15")
|
||||
|
||||
(define dream-st-tests-run! (fn () {:total (+ dream-st-pass dream-st-fail) :passed dream-st-pass :failed dream-st-fail :fails dream-st-fails}))
|
||||
199
lib/dream/tests/types.sx
Normal file
199
lib/dream/tests/types.sx
Normal file
@@ -0,0 +1,199 @@
|
||||
;; lib/dream/tests/types.sx — request/response/route records + convenience.
|
||||
|
||||
(define dream-ty-pass 0)
|
||||
(define dream-ty-fail 0)
|
||||
(define dream-ty-fails (list))
|
||||
|
||||
(define
|
||||
dream-ty-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-ty-pass (+ dream-ty-pass 1))
|
||||
(begin
|
||||
(set! dream-ty-fail (+ dream-ty-fail 1))
|
||||
(append! dream-ty-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── request construction + accessors ───────────────────────────────
|
||||
(define
|
||||
dream-ty-req
|
||||
(dream-request "get" "/users/42?tab=info&x=1" {:X-Token "abc" :Content-Type "text/html"} "hello"))
|
||||
|
||||
(dream-ty-test "method uppercased" (dream-method dream-ty-req) "GET")
|
||||
(dream-ty-test "path strips query" (dream-path dream-ty-req) "/users/42")
|
||||
(dream-ty-test
|
||||
"target keeps query"
|
||||
(dream-target dream-ty-req)
|
||||
"/users/42?tab=info&x=1")
|
||||
(dream-ty-test "body" (dream-body dream-ty-req) "hello")
|
||||
(dream-ty-test
|
||||
"header case-insensitive"
|
||||
(dream-header dream-ty-req "content-type")
|
||||
"text/html")
|
||||
(dream-ty-test
|
||||
"header mixed case"
|
||||
(dream-header dream-ty-req "X-Token")
|
||||
"abc")
|
||||
(dream-ty-test
|
||||
"missing header is nil"
|
||||
(dream-header dream-ty-req "absent")
|
||||
nil)
|
||||
(dream-ty-test
|
||||
"query param tab"
|
||||
(dream-query-param dream-ty-req "tab")
|
||||
"info")
|
||||
(dream-ty-test "query param x" (dream-query-param dream-ty-req "x") "1")
|
||||
(dream-ty-test "params empty by default" (dream-param dream-ty-req "id") nil)
|
||||
(dream-ty-test "is a request" (dream-request? dream-ty-req) true)
|
||||
(dream-ty-test "string is not a request" (dream-request? "x") false)
|
||||
|
||||
;; ── query edge cases ───────────────────────────────────────────────
|
||||
(dream-ty-test
|
||||
"no query is empty"
|
||||
(dream-query-param (dream-request "GET" "/plain" {} "") "k")
|
||||
nil)
|
||||
(dream-ty-test
|
||||
"valueless query param"
|
||||
(dream-query-param (dream-request "GET" "/p?flag" {} "") "flag")
|
||||
"")
|
||||
|
||||
;; ── path params ────────────────────────────────────────────────────
|
||||
(define dream-ty-req2 (dream-with-param dream-ty-req "id" "42"))
|
||||
(dream-ty-test "with-param sets" (dream-param dream-ty-req2 "id") "42")
|
||||
(dream-ty-test "with-param immutable" (dream-param dream-ty-req "id") nil)
|
||||
(define dream-ty-req3 (dream-with-params dream-ty-req {:a "1" :b "2"}))
|
||||
(dream-ty-test "with-params a" (dream-param dream-ty-req3 "a") "1")
|
||||
(dream-ty-test "with-params b" (dream-param dream-ty-req3 "b") "2")
|
||||
|
||||
;; ── request convenience ────────────────────────────────────────────
|
||||
(dream-ty-test "queries dict" (dream-queries dream-ty-req) {:x "1" :tab "info"})
|
||||
(dream-ty-test
|
||||
"query-or present"
|
||||
(dream-query-param-or dream-ty-req "tab" "def")
|
||||
"info")
|
||||
(dream-ty-test
|
||||
"query-or default"
|
||||
(dream-query-param-or dream-ty-req "missing" "def")
|
||||
"def")
|
||||
(dream-ty-test "has-query yes" (dream-has-query? dream-ty-req "tab") true)
|
||||
(dream-ty-test "has-query no" (dream-has-query? dream-ty-req "nope") false)
|
||||
(dream-ty-test
|
||||
"header-or present"
|
||||
(dream-header-or dream-ty-req "x-token" "d")
|
||||
"abc")
|
||||
(dream-ty-test
|
||||
"header-or default"
|
||||
(dream-header-or dream-ty-req "x-absent" "d")
|
||||
"d")
|
||||
(dream-ty-test
|
||||
"has-header yes"
|
||||
(dream-has-header? dream-ty-req "Content-Type")
|
||||
true)
|
||||
(dream-ty-test
|
||||
"has-header no"
|
||||
(dream-has-header? dream-ty-req "x-absent")
|
||||
false)
|
||||
(dream-ty-test "param-or default" (dream-param-or dream-ty-req "id" "0") "0")
|
||||
(dream-ty-test
|
||||
"param-or present"
|
||||
(dream-param-or dream-ty-req2 "id" "0")
|
||||
"42")
|
||||
(dream-ty-test
|
||||
"content-type-of"
|
||||
(dream-content-type-of dream-ty-req)
|
||||
"text/html")
|
||||
(dream-ty-test "method-is yes" (dream-method-is? dream-ty-req "get") true)
|
||||
(dream-ty-test "method-is no" (dream-method-is? dream-ty-req "post") false)
|
||||
(define dream-ty-jreq (dream-request "GET" "/" {:Accept "application/json, text/html"} ""))
|
||||
(dream-ty-test
|
||||
"accepts json"
|
||||
(dream-accepts? dream-ty-jreq "application/json")
|
||||
true)
|
||||
(dream-ty-test
|
||||
"accepts missing"
|
||||
(dream-accepts? dream-ty-req "application/json")
|
||||
false)
|
||||
(dream-ty-test "wants-json yes" (dream-wants-json? dream-ty-jreq) true)
|
||||
(dream-ty-test "wants-json no" (dream-wants-json? dream-ty-req) false)
|
||||
|
||||
;; ── response construction ──────────────────────────────────────────
|
||||
(dream-ty-test "html status" (dream-status (dream-html "<p>")) 200)
|
||||
(dream-ty-test "html body" (dream-resp-body (dream-html "<p>")) "<p>")
|
||||
(dream-ty-test
|
||||
"html content-type"
|
||||
(dream-resp-header (dream-html "<p>") "content-type")
|
||||
"text/html; charset=utf-8")
|
||||
(dream-ty-test
|
||||
"text content-type"
|
||||
(dream-resp-header (dream-text "hi") "content-type")
|
||||
"text/plain; charset=utf-8")
|
||||
(dream-ty-test
|
||||
"json content-type"
|
||||
(dream-resp-header (dream-json "{}") "content-type")
|
||||
"application/json")
|
||||
(dream-ty-test
|
||||
"html-status code"
|
||||
(dream-status (dream-html-status 201 "ok"))
|
||||
201)
|
||||
(dream-ty-test
|
||||
"not-found status"
|
||||
(dream-status (dream-not-found))
|
||||
404)
|
||||
(dream-ty-test
|
||||
"empty status"
|
||||
(dream-status (dream-empty 204))
|
||||
204)
|
||||
(dream-ty-test "empty body" (dream-resp-body (dream-empty 204)) "")
|
||||
(dream-ty-test
|
||||
"redirect status"
|
||||
(dream-status (dream-redirect "/home"))
|
||||
303)
|
||||
(dream-ty-test
|
||||
"redirect location"
|
||||
(dream-resp-header (dream-redirect "/home") "location")
|
||||
"/home")
|
||||
(dream-ty-test
|
||||
"redirect-status code"
|
||||
(dream-status (dream-redirect-status 301 "/x"))
|
||||
301)
|
||||
(dream-ty-test "is a response" (dream-response? (dream-html "x")) true)
|
||||
|
||||
;; ── response mutation ──────────────────────────────────────────────
|
||||
(define dream-ty-resp (dream-add-header (dream-html "x") "X-Custom" "yes"))
|
||||
(dream-ty-test
|
||||
"add-header"
|
||||
(dream-resp-header dream-ty-resp "x-custom")
|
||||
"yes")
|
||||
(dream-ty-test "add-header keeps body" (dream-resp-body dream-ty-resp) "x")
|
||||
(dream-ty-test
|
||||
"set-status"
|
||||
(dream-status (dream-set-status (dream-html "x") 500))
|
||||
500)
|
||||
|
||||
;; ── coercion ───────────────────────────────────────────────────────
|
||||
(dream-ty-test
|
||||
"coerce string"
|
||||
(dream-status (dream-coerce-response "hi"))
|
||||
200)
|
||||
(dream-ty-test
|
||||
"coerce string body"
|
||||
(dream-resp-body (dream-coerce-response "hi"))
|
||||
"hi")
|
||||
(dream-ty-test
|
||||
"coerce response passthrough"
|
||||
(dream-status (dream-coerce-response (dream-empty 204)))
|
||||
204)
|
||||
|
||||
;; ── route ──────────────────────────────────────────────────────────
|
||||
(define dream-ty-h (fn (req) (dream-text "ok")))
|
||||
(define dream-ty-route (dream-route "post" "/submit" dream-ty-h))
|
||||
(dream-ty-test "route method" (dream-route-method dream-ty-route) "POST")
|
||||
(dream-ty-test "route path" (dream-route-path dream-ty-route) "/submit")
|
||||
(dream-ty-test "route is route" (dream-route? dream-ty-route) true)
|
||||
(dream-ty-test
|
||||
"route handler invokes"
|
||||
(dream-resp-body ((dream-route-handler dream-ty-route) dream-ty-req))
|
||||
"ok")
|
||||
|
||||
(define dream-ty-tests-run! (fn () {:total (+ dream-ty-pass dream-ty-fail) :passed dream-ty-pass :failed dream-ty-fail :fails dream-ty-fails}))
|
||||
94
lib/dream/tests/websocket.sx
Normal file
94
lib/dream/tests/websocket.sx
Normal file
@@ -0,0 +1,94 @@
|
||||
;; lib/dream/tests/websocket.sx — upgrade, send/receive/close, broadcast.
|
||||
|
||||
(define dream-ws-pass 0)
|
||||
(define dream-ws-fail 0)
|
||||
(define dream-ws-fails (list))
|
||||
|
||||
(define
|
||||
dream-ws-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! dream-ws-pass (+ dream-ws-pass 1))
|
||||
(begin
|
||||
(set! dream-ws-fail (+ dream-ws-fail 1))
|
||||
(append! dream-ws-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── upgrade response ───────────────────────────────────────────────
|
||||
(define dream-ws-echo (fn (ws) (dream-text "unused")))
|
||||
(define
|
||||
dream-ws-up
|
||||
((dream-websocket dream-ws-echo) (dream-request "GET" "/ws" {} "")))
|
||||
(dream-ws-test "upgrade status 101" (dream-status dream-ws-up) 101)
|
||||
(dream-ws-test "is a websocket response" (dream-websocket? dream-ws-up) true)
|
||||
(dream-ws-test
|
||||
"plain response is not ws"
|
||||
(dream-websocket? (dream-html "x"))
|
||||
false)
|
||||
(dream-ws-test
|
||||
"upgrade header"
|
||||
(dream-resp-header dream-ws-up "upgrade")
|
||||
"websocket")
|
||||
|
||||
;; ── basic send / receive / close on a mock ─────────────────────────
|
||||
(define dream-ws-w1 (dream-mock-ws (list "hi" "there")))
|
||||
(dream-ws-test "open initially" (dream-ws-open? dream-ws-w1) true)
|
||||
(dream-ws-test "receive first" (dream-receive dream-ws-w1) "hi")
|
||||
(dream-ws-test "receive second" (dream-receive dream-ws-w1) "there")
|
||||
(dream-ws-test "receive empty -> nil" (dream-receive dream-ws-w1) nil)
|
||||
(dream-send dream-ws-w1 "out1")
|
||||
(dream-send dream-ws-w1 "out2")
|
||||
(dream-ws-test
|
||||
"sent recorded"
|
||||
(dream-ws-sent dream-ws-w1)
|
||||
(list "out1" "out2"))
|
||||
(dream-close dream-ws-w1)
|
||||
(dream-ws-test "closed flag" (dream-ws-closed? dream-ws-w1) true)
|
||||
(dream-ws-test "open? false after close" (dream-ws-open? dream-ws-w1) false)
|
||||
|
||||
;; ── echo handler driven over the upgrade response ──────────────────
|
||||
(define
|
||||
dream-ws-echo-h
|
||||
(fn
|
||||
(ws)
|
||||
(let
|
||||
((m (dream-receive ws)))
|
||||
(if
|
||||
(nil? m)
|
||||
(dream-close ws)
|
||||
(begin (dream-send ws (str "echo:" m)) (dream-ws-echo-h ws))))))
|
||||
(define
|
||||
dream-ws-echo-up
|
||||
((dream-websocket dream-ws-echo-h)
|
||||
(dream-request "GET" "/ws" {} "")))
|
||||
(define dream-ws-echo-conn (dream-mock-ws (list "a" "b" "c")))
|
||||
(dream-ws-run dream-ws-echo-up dream-ws-echo-conn)
|
||||
(dream-ws-test
|
||||
"echo all messages"
|
||||
(dream-ws-sent dream-ws-echo-conn)
|
||||
(list "echo:a" "echo:b" "echo:c"))
|
||||
(dream-ws-test
|
||||
"echo closes at end"
|
||||
(dream-ws-closed? dream-ws-echo-conn)
|
||||
true)
|
||||
|
||||
;; ── broadcast to a room ────────────────────────────────────────────
|
||||
(define dream-ws-c1 (dream-mock-ws (list)))
|
||||
(define dream-ws-c2 (dream-mock-ws (list)))
|
||||
(define dream-ws-c3 (dream-mock-ws (list)))
|
||||
(dream-ws-broadcast (list dream-ws-c1 dream-ws-c2 dream-ws-c3) "hello room")
|
||||
(dream-ws-test
|
||||
"broadcast c1"
|
||||
(dream-ws-sent dream-ws-c1)
|
||||
(list "hello room"))
|
||||
(dream-ws-test
|
||||
"broadcast c2"
|
||||
(dream-ws-sent dream-ws-c2)
|
||||
(list "hello room"))
|
||||
(dream-ws-test
|
||||
"broadcast c3"
|
||||
(dream-ws-sent dream-ws-c3)
|
||||
(list "hello room"))
|
||||
|
||||
(define dream-ws-tests-run! (fn () {:total (+ dream-ws-pass dream-ws-fail) :passed dream-ws-pass :failed dream-ws-fail :fails dream-ws-fails}))
|
||||
175
lib/dream/types.sx
Normal file
175
lib/dream/types.sx
Normal file
@@ -0,0 +1,175 @@
|
||||
;; lib/dream/types.sx — Dream-on-SX core types.
|
||||
;; The five types: request, response, route. handler = request->response and
|
||||
;; middleware = handler->handler are plain SX functions (no records needed).
|
||||
;; request/response/route are dicts. Headers are dicts with lowercased string
|
||||
;; keys; keywords are strings in SX, so :content-type == "content-type".
|
||||
|
||||
;; ── internal helpers ───────────────────────────────────────────────
|
||||
(define
|
||||
dr/normalize-headers
|
||||
(fn
|
||||
(h)
|
||||
(reduce
|
||||
(fn (acc k) (assoc acc (lower k) (get h k)))
|
||||
{}
|
||||
(keys h))))
|
||||
|
||||
(define
|
||||
dr/path-of
|
||||
(fn
|
||||
(target)
|
||||
(let
|
||||
((i (index-of target "?")))
|
||||
(if (< i 0) target (substr target 0 i)))))
|
||||
|
||||
(define
|
||||
dr/query-of
|
||||
(fn
|
||||
(target)
|
||||
(let
|
||||
((i (index-of target "?")))
|
||||
(if (< i 0) "" (substr target (+ i 1))))))
|
||||
|
||||
(define
|
||||
dr/parse-pair
|
||||
(fn
|
||||
(acc pair)
|
||||
(if
|
||||
(= pair "")
|
||||
acc
|
||||
(let
|
||||
((j (index-of pair "=")))
|
||||
(if
|
||||
(< j 0)
|
||||
(assoc acc pair "")
|
||||
(assoc
|
||||
acc
|
||||
(substr pair 0 j)
|
||||
(substr pair (+ j 1))))))))
|
||||
|
||||
(define
|
||||
dr/parse-query
|
||||
(fn
|
||||
(target)
|
||||
(let
|
||||
((q (dr/query-of target)))
|
||||
(if
|
||||
(= q "")
|
||||
{}
|
||||
(reduce dr/parse-pair {} (split q "&"))))))
|
||||
|
||||
;; ── request ────────────────────────────────────────────────────────
|
||||
(define dream-request (fn (method target headers body) {:path (dr/path-of target) :params {} :query (dr/parse-query target) :body body :headers (dr/normalize-headers headers) :method (upper method) :target target}))
|
||||
|
||||
(define
|
||||
dream-request?
|
||||
(fn (x) (and (dict? x) (has-key? x :method) (has-key? x :path))))
|
||||
(define dream-method (fn (req) (get req :method)))
|
||||
(define dream-target (fn (req) (get req :target)))
|
||||
(define dream-path (fn (req) (get req :path)))
|
||||
(define dream-body (fn (req) (get req :body)))
|
||||
(define
|
||||
dream-header
|
||||
(fn (req name) (get (get req :headers) (lower name))))
|
||||
(define dream-query-param (fn (req name) (get (get req :query) name)))
|
||||
(define dream-param (fn (req name) (get (get req :params) name)))
|
||||
(define dream-params (fn (req) (get req :params)))
|
||||
|
||||
;; router fills path params during dispatch
|
||||
(define
|
||||
dream-with-param
|
||||
(fn
|
||||
(req name val)
|
||||
(assoc req :params (assoc (get req :params) name val))))
|
||||
(define
|
||||
dream-with-params
|
||||
(fn
|
||||
(req more)
|
||||
(assoc
|
||||
req
|
||||
:params (reduce
|
||||
(fn (acc k) (assoc acc k (get more k)))
|
||||
(get req :params)
|
||||
(keys more)))))
|
||||
(define dream-set-body (fn (req body) (assoc req :body body)))
|
||||
|
||||
;; ── request convenience ────────────────────────────────────────────
|
||||
(define dream-queries (fn (req) (get req :query)))
|
||||
(define
|
||||
dream-query-param-or
|
||||
(fn (req name default) (or (dream-query-param req name) default)))
|
||||
(define dream-has-query? (fn (req name) (has-key? (get req :query) name)))
|
||||
(define
|
||||
dream-header-or
|
||||
(fn (req name default) (or (dream-header req name) default)))
|
||||
(define
|
||||
dream-has-header?
|
||||
(fn (req name) (has-key? (get req :headers) (lower name))))
|
||||
(define
|
||||
dream-param-or
|
||||
(fn (req name default) (or (dream-param req name) default)))
|
||||
(define dream-has-param? (fn (req name) (has-key? (get req :params) name)))
|
||||
(define dream-content-type-of (fn (req) (dream-header req "content-type")))
|
||||
(define dream-method-is? (fn (req m) (= (dream-method req) (upper m))))
|
||||
(define
|
||||
dream-accepts?
|
||||
(fn
|
||||
(req mime)
|
||||
(let
|
||||
((a (dream-header req "accept")))
|
||||
(if a (contains? a mime) false))))
|
||||
(define
|
||||
dream-wants-json?
|
||||
(fn (req) (dream-accepts? req "application/json")))
|
||||
|
||||
;; ── response ───────────────────────────────────────────────────────
|
||||
(define dream-response (fn (status headers body) {:body body :headers (dr/normalize-headers headers) :status status}))
|
||||
|
||||
(define
|
||||
dream-response?
|
||||
(fn (x) (and (dict? x) (has-key? x :status) (has-key? x :body))))
|
||||
(define dream-status (fn (resp) (get resp :status)))
|
||||
(define
|
||||
dream-resp-header
|
||||
(fn (resp name) (get (get resp :headers) (lower name))))
|
||||
(define dream-resp-body (fn (resp) (get resp :body)))
|
||||
(define dream-headers (fn (resp) (get resp :headers)))
|
||||
|
||||
(define
|
||||
dream-add-header
|
||||
(fn
|
||||
(resp name val)
|
||||
(assoc resp :headers (assoc (get resp :headers) (lower name) val))))
|
||||
(define dream-set-status (fn (resp status) (assoc resp :status status)))
|
||||
|
||||
;; smart constructors
|
||||
(define dream-html (fn (body) (dream-response 200 {:content-type "text/html; charset=utf-8"} body)))
|
||||
(define
|
||||
dream-html-status
|
||||
(fn (status body) (dream-response status {:content-type "text/html; charset=utf-8"} body)))
|
||||
(define dream-text (fn (body) (dream-response 200 {:content-type "text/plain; charset=utf-8"} body)))
|
||||
(define dream-json (fn (body) (dream-response 200 {:content-type "application/json"} body)))
|
||||
(define dream-empty (fn (status) (dream-response status {} "")))
|
||||
(define
|
||||
dream-not-found
|
||||
(fn () (dream-response 404 {:content-type "text/plain; charset=utf-8"} "Not Found")))
|
||||
(define
|
||||
dream-redirect
|
||||
(fn (location) (dream-response 303 {:location location} "")))
|
||||
(define
|
||||
dream-redirect-status
|
||||
(fn (status location) (dream-response status {:location location} "")))
|
||||
|
||||
;; coerce a handler result: strings become 200 text/html responses
|
||||
(define
|
||||
dream-coerce-response
|
||||
(fn (x) (if (dream-response? x) x (dream-html x))))
|
||||
|
||||
;; ── route ──────────────────────────────────────────────────────────
|
||||
(define dream-route (fn (method path handler) {:path path :handler handler :method (upper method)}))
|
||||
(define
|
||||
dream-route?
|
||||
(fn (x) (and (dict? x) (has-key? x :handler) (has-key? x :path))))
|
||||
(define dream-route-method (fn (r) (get r :method)))
|
||||
(define dream-route-path (fn (r) (get r :path)))
|
||||
(define dream-route-handler (fn (r) (get r :handler)))
|
||||
42
lib/dream/websocket.sx
Normal file
42
lib/dream/websocket.sx
Normal file
@@ -0,0 +1,42 @@
|
||||
;; lib/dream/websocket.sx — Dream-on-SX WebSockets.
|
||||
;; dream-websocket wraps a (fn (ws) ...) handler into an ordinary handler that
|
||||
;; returns a 101 upgrade response carrying the ws handler. The host detects the
|
||||
;; upgrade, builds a ws backed by host IO, and runs the handler. The ws carries an
|
||||
;; injectable io fn — a mock in-memory ws for tests, (perform op) in production.
|
||||
;; Depends on types.sx.
|
||||
|
||||
;; ── upgrade response ───────────────────────────────────────────────
|
||||
(define dream-websocket (fn (handler) (fn (req) {:websocket handler :body "" :headers {:connection "Upgrade" :upgrade "websocket"} :status 101})))
|
||||
|
||||
(define
|
||||
dream-websocket?
|
||||
(fn (resp) (and (dict? resp) (has-key? resp :websocket))))
|
||||
(define dream-ws-handler (fn (resp) (get resp :websocket)))
|
||||
|
||||
;; ── ws operations (over an injectable io) ──────────────────────────
|
||||
(define dream-send (fn (ws msg) ((get ws :io) {:op "ws/send" :msg msg})))
|
||||
(define dream-receive (fn (ws) ((get ws :io) {:op "ws/receive"})))
|
||||
(define dream-close (fn (ws) ((get ws :io) {:op "ws/close"})))
|
||||
(define dream-ws-open? (fn (ws) ((get ws :io) {:op "ws/open?"})))
|
||||
(define
|
||||
dream-ws-broadcast
|
||||
(fn (wss msg) (for-each (fn (ws) (dream-send ws msg)) wss)))
|
||||
|
||||
;; production io: every op suspends to the host
|
||||
(define dream-ws-perform-io (fn (op) (perform op)))
|
||||
(define dream-ws-from-io (fn (io) {:io io}))
|
||||
|
||||
;; ── in-memory mock ws (tests + demos) ──────────────────────────────
|
||||
;; incoming is a list of messages dream-receive will yield in order.
|
||||
(define
|
||||
dream-mock-ws
|
||||
(fn
|
||||
(incoming)
|
||||
(let ((inbox incoming) (outbox (list)) (closed false)) {:closed? (fn () closed) :outbox (fn () outbox) :io (fn (op) (cond ((= (get op :op) "ws/send") (begin (set! outbox (concat outbox (list (get op :msg)))) true)) ((= (get op :op) "ws/receive") (if (empty? inbox) nil (let ((m (first inbox))) (begin (set! inbox (rest inbox)) m)))) ((= (get op :op) "ws/close") (begin (set! closed true) true)) ((= (get op :op) "ws/open?") (not closed)) (else nil)))})))
|
||||
|
||||
;; test/demo introspection
|
||||
(define dream-ws-sent (fn (ws) ((get ws :outbox))))
|
||||
(define dream-ws-closed? (fn (ws) ((get ws :closed?))))
|
||||
|
||||
;; drive a ws handler (from an upgrade response) against a ws
|
||||
(define dream-ws-run (fn (resp ws) ((dream-ws-handler resp) ws)))
|
||||
254
lib/host/blog.sx
Normal file
254
lib/host/blog.sx
Normal file
@@ -0,0 +1,254 @@
|
||||
;; lib/host/blog.sx — Blog domain on the host, on the EDITOR's content model.
|
||||
;; The SX post editor (blog/sx/editor.sx) emits `sx_content`: SX element markup
|
||||
;; (e.g. "(article (h1 \"T\") (p \"body\" (strong \"x\")))"), NOT content-on-sx
|
||||
;; CtDoc blocks. So a post here is a record {slug,title,sx_content,status} stored
|
||||
;; in the durable persist KV, and a post page is `render-to-html (parse sx_content)`
|
||||
;; — server-side, static, no client runtime needed to view a published post.
|
||||
;;
|
||||
;; GET / HTML index of posts (public)
|
||||
;; GET /<slug>/ rendered post (public) -> HTML / 404
|
||||
;; GET /posts JSON list (public) -> [{slug,title,status}]
|
||||
;; GET /new HTML create form (public chrome)
|
||||
;; POST /new form-urlencoded ingest from the editor (guarded)
|
||||
;; POST /posts JSON create (guarded)
|
||||
;; PUT /posts/<slug> JSON update (guarded)
|
||||
;; DELETE /posts/<slug> delete (guarded)
|
||||
;; Reads anonymous; writes behind the auth+ACL pipeline ("edit" on "blog").
|
||||
;; Depends on spec/render + web/adapter-html (render-to-html), lib/persist/*
|
||||
;; (durable KV), lib/dream/* (+ form), lib/host/{handler,middleware}.sx.
|
||||
|
||||
;; ── store (durable persist KV, injectable) ──────────────────────────
|
||||
(define host/blog-store (persist/open))
|
||||
(define host/blog-use-store! (fn (b) (set! host/blog-store b)))
|
||||
(define host/blog--key (fn (slug) (str "blog:" slug)))
|
||||
|
||||
;; slug from a title: lowercase, words joined by '-'. (Punctuation kept simple.)
|
||||
(define host/blog-slugify
|
||||
(fn (title)
|
||||
(join "-" (filter (fn (w) (not (= w ""))) (split (lower title) " ")))))
|
||||
|
||||
;; ── records ─────────────────────────────────────────────────────────
|
||||
(define host/blog-get
|
||||
(fn (slug) (persist/backend-kv-get host/blog-store (host/blog--key slug))))
|
||||
(define host/blog-exists?
|
||||
(fn (slug) (persist/backend-kv-has? host/blog-store (host/blog--key slug))))
|
||||
(define host/blog-put!
|
||||
(fn (slug title sx-content status)
|
||||
(persist/backend-kv-put host/blog-store (host/blog--key slug)
|
||||
{:slug slug :title title :sx-content sx-content :status status})))
|
||||
(define host/blog-delete!
|
||||
(fn (slug) (persist/backend-kv-delete host/blog-store (host/blog--key slug))))
|
||||
(define host/blog-seed!
|
||||
(fn (slug title sx-content status)
|
||||
(when (not (host/blog-exists? slug)) (host/blog-put! slug title sx-content status))))
|
||||
|
||||
;; all blog slugs (kv keys are "blog:<slug>")
|
||||
(define host/blog-slugs
|
||||
(fn ()
|
||||
(reduce
|
||||
(fn (acc k)
|
||||
(if (starts-with? k "blog:") (append acc (list (substr k 5))) acc))
|
||||
(list)
|
||||
(persist/backend-kv-keys host/blog-store))))
|
||||
(define host/blog-list
|
||||
(fn ()
|
||||
(map
|
||||
(fn (slug)
|
||||
(let ((r (host/blog-get slug)))
|
||||
{:slug slug :title (get r :title) :status (get r :status)}))
|
||||
(host/blog-slugs))))
|
||||
|
||||
;; ── render ──────────────────────────────────────────────────────────
|
||||
;; A post's sx_content is SX element markup -> HTML via render-page (which supplies
|
||||
;; the server env so components resolve + keyword attrs are kept).
|
||||
;;
|
||||
;; Rendered PER BLOCK and guarded: the editor wraps content in a (<> ...) fragment
|
||||
;; of blocks, some of which the host can't render (the legacy editor emits bare
|
||||
;; ~kg-md cards while the components are ~kg_cards/kg-md — drift we don't paper over
|
||||
;; with aliases). Rendering each block under its own guard means the real prose
|
||||
;; (p/h1/ul/...) shows and only the unsupported block degrades to a placeholder —
|
||||
;; and a bad block never crashes the handler (-> 502).
|
||||
(define host/blog--render-node
|
||||
(fn (node)
|
||||
(guard (e (true "<div class=\"blk-unsupported\"><em>(unsupported block)</em></div>"))
|
||||
(render-page node))))
|
||||
(define host/blog-render
|
||||
(fn (record)
|
||||
(let ((sx (get record :sx-content)))
|
||||
(if (and sx (not (= sx "")))
|
||||
(let ((tree (guard (e (true nil)) (parse sx))))
|
||||
(cond
|
||||
((nil? tree) "<p><em>(unparseable content)</em></p>")
|
||||
((and (= (type-of tree) "list") (> (len tree) 0)
|
||||
(= (str (first tree)) "<>"))
|
||||
(join "" (map host/blog--render-node (rest tree))))
|
||||
(else (host/blog--render-node tree))))
|
||||
(str "<p>(empty post)</p>")))))
|
||||
;; ── page shell ──────────────────────────────────────────────────────
|
||||
;; A page is an SX element tree, rendered via render-page (5.1). The handler
|
||||
;; builds the tree (running any dynamic logic in the full evaluator, e.g. a posts
|
||||
;; loop) and render-page renders the static result — no embedded HTML strings,
|
||||
;; only the doctype prefix render-to-html doesn't emit. `body` is an SX node.
|
||||
(define host/blog--page
|
||||
(fn (title body)
|
||||
(str "<!doctype html>"
|
||||
(render-page
|
||||
(quasiquote
|
||||
(html
|
||||
(head (meta :charset "utf-8") (title (unquote title)))
|
||||
(body (unquote body))))))))
|
||||
|
||||
;; ── read handlers ───────────────────────────────────────────────────
|
||||
;; Post body is rendered per-block (a guarded HTML string) then injected raw.
|
||||
(define host/blog-post
|
||||
(fn (req)
|
||||
(let ((slug (dream-param req "slug")))
|
||||
(let ((r (host/blog-get slug)))
|
||||
(if r
|
||||
(dream-html
|
||||
(host/blog--page (get r :title)
|
||||
(quasiquote (article (raw! (unquote (host/blog-render r)))))))
|
||||
(dream-html-status 404
|
||||
(host/blog--page "Not found"
|
||||
(quasiquote
|
||||
(div (h1 "404")
|
||||
(p (unquote (str "No published post: " slug))))))))))))
|
||||
|
||||
(define host/blog-home
|
||||
(fn (req)
|
||||
(let ((posts (host/blog-list)))
|
||||
(let ((items
|
||||
(map
|
||||
(fn (p)
|
||||
(quasiquote
|
||||
(li (a :href (unquote (str "/" (get p :slug) "/"))
|
||||
(unquote (get p :title))))))
|
||||
posts)))
|
||||
(let ((listing (if (> (len posts) 0)
|
||||
(list (quote ul) items)
|
||||
(quote (p "No posts yet.")))))
|
||||
(dream-html
|
||||
(host/blog--page "Blog"
|
||||
(quasiquote
|
||||
(div (h1 "Posts")
|
||||
(unquote listing)
|
||||
(p (a :href "/new" "+ New post")))))))))))
|
||||
|
||||
(define host/blog-index (fn (req) (host/ok (host/blog-list))))
|
||||
|
||||
;; ── create page (GET /new) — clean minimal form as an SX tree ───────
|
||||
;; No legacy JS editor, no external assets, no shims. The rich WYSIWYG is a
|
||||
;; future native SX-island editor (Phase 5.2+). Posts to /new.
|
||||
(define host/blog-new-form
|
||||
(fn (req)
|
||||
(dream-html
|
||||
(host/blog--page "New post"
|
||||
(quasiquote
|
||||
(div
|
||||
(h1 "New post")
|
||||
(form :method "post" :action "/new"
|
||||
(p (input :name "title" :placeholder "Title"
|
||||
:style "font-size:1.4em;width:100%"))
|
||||
(p (textarea :name "sx_content" :rows "12"
|
||||
:style "width:100%;font-family:monospace"
|
||||
:placeholder "(p \"Your post as SX markup\")"))
|
||||
(p (select :name "status"
|
||||
(option :value "draft" "Draft")
|
||||
(option :value "published" "Published"))
|
||||
" "
|
||||
(button :type "submit" "Publish")))
|
||||
(p (a :href "/" "all posts"))))))))
|
||||
|
||||
;; ── write handlers ──────────────────────────────────────────────────
|
||||
;; POST /new — form-urlencoded ingest (the editor's submit shape: title,
|
||||
;; sx_content, status, custom_excerpt, csrf_token). Slug derived from the title.
|
||||
;; Redirects to the new post on success.
|
||||
(define host/blog-form-submit
|
||||
(fn (req)
|
||||
(let ((title (dream-form-field req "title"))
|
||||
(sx-content (dream-form-field req "sx_content"))
|
||||
(status (or (dream-form-field req "status") "published")))
|
||||
(if (and title (not (= title "")))
|
||||
(let ((slug (host/blog-slugify title)))
|
||||
(begin
|
||||
(host/blog-put! slug title (or sx-content "") status)
|
||||
(dream-redirect (str "/" slug "/"))))
|
||||
(dream-html-status 400
|
||||
(host/blog--page "Error" "<p>Title is required. <a href=\"/new\">back</a></p>"))))))
|
||||
|
||||
;; POST /posts — JSON create {slug?,title,sx_content,status}. 409 if slug exists.
|
||||
(define host/blog-create
|
||||
(fn (req)
|
||||
(let ((p (dream-json-body req)))
|
||||
(if (= (type-of p) "dict")
|
||||
(let ((title (get p :title)))
|
||||
(if (and title (not (= title "")))
|
||||
(let ((slug (or (get p :slug) (host/blog-slugify title))))
|
||||
(if (host/blog-exists? slug)
|
||||
(host/error 409 "post already exists")
|
||||
(begin
|
||||
(host/blog-put! slug title (or (get p :sx_content) "")
|
||||
(or (get p :status) "published"))
|
||||
(host/ok-status 201 {:slug slug :title title}))))
|
||||
(host/error 400 "title required")))
|
||||
(host/error 400 "invalid payload")))))
|
||||
|
||||
;; PUT /posts/<slug> — JSON update {title?,sx_content?,status?}. 404 if absent.
|
||||
(define host/blog-update-handler
|
||||
(fn (req)
|
||||
(let ((slug (dream-param req "slug")) (p (dream-json-body req)))
|
||||
(if (= (type-of p) "dict")
|
||||
(let ((r (host/blog-get slug)))
|
||||
(if r
|
||||
(begin
|
||||
(host/blog-put! slug
|
||||
(or (get p :title) (get r :title))
|
||||
(or (get p :sx_content) (get r :sx-content))
|
||||
(or (get p :status) (get r :status)))
|
||||
(host/ok {:slug slug :updated true}))
|
||||
(host/error 404 "no such post")))
|
||||
(host/error 400 "invalid payload")))))
|
||||
|
||||
;; DELETE /posts/<slug>
|
||||
(define host/blog-delete-handler
|
||||
(fn (req)
|
||||
(let ((slug (dream-param req "slug")))
|
||||
(if (host/blog-exists? slug)
|
||||
(begin (host/blog-delete! slug) (host/ok {:slug slug :deleted true}))
|
||||
(host/error 404 "no such post")))))
|
||||
|
||||
;; ── routes ──────────────────────────────────────────────────────────
|
||||
;; Public reads + the create form. /, /posts, /new BEFORE /:slug (catch-all).
|
||||
;; MUST be mounted LAST in the app so domain routes (/feed, /health) win.
|
||||
(define host/blog-routes
|
||||
(list
|
||||
(dream-get "/" host/blog-home)
|
||||
(dream-get "/posts" host/blog-index)
|
||||
(dream-get "/new" host/blog-new-form)
|
||||
(dream-get "/:slug" host/blog-post)))
|
||||
|
||||
;; Guarded writes: form ingest + JSON create/update/delete behind auth+ACL.
|
||||
;; NB: helper is host/blog--protect, NOT `guard` (reserved special form).
|
||||
(define host/blog--protect
|
||||
(fn (resolve h)
|
||||
(host/pipeline
|
||||
(list
|
||||
host/wrap-errors
|
||||
(host/require-auth resolve)
|
||||
(host/require-permission "edit" (fn (req) "blog")))
|
||||
h)))
|
||||
(define host/blog-write-routes
|
||||
(fn (resolve)
|
||||
(list
|
||||
(dream-post "/new" (host/blog--protect resolve host/blog-form-submit))
|
||||
(dream-post "/posts" (host/blog--protect resolve host/blog-create))
|
||||
(dream-put "/posts/:slug" (host/blog--protect resolve host/blog-update-handler))
|
||||
(dream-delete "/posts/:slug" (host/blog--protect resolve host/blog-delete-handler)))))
|
||||
|
||||
;; EXPERIMENTAL: create-only, UNGUARDED — POST /new form ingest with error
|
||||
;; trapping but NO auth, for validating the editor->host publish loop on the
|
||||
;; experimental subdomain. Create-only by design (no PUT/DELETE), so the worst
|
||||
;; case is junk posts, not overwrite/delete. GATE before any real use.
|
||||
(define host/blog-open-create-routes
|
||||
(list
|
||||
(dream-post "/new" (host/pipeline (list host/wrap-errors) host/blog-form-submit))))
|
||||
163
lib/host/conformance.sh
Executable file
163
lib/host/conformance.sh
Executable file
@@ -0,0 +1,163 @@
|
||||
#!/usr/bin/env bash
|
||||
# host-on-sx conformance runner — loads the kernel stdlib, the subsystem
|
||||
# libraries the host wires to, the host modules, and the host test suites in one
|
||||
# sx_server process, then reports pass/fail per suite. Mirrors lib/dream's runner.
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/host/conformance.sh # run all suites
|
||||
# bash lib/host/conformance.sh -v # verbose (list each suite)
|
||||
|
||||
set -uo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
fi
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
echo "ERROR: sx_server.exe not found." >&2
|
||||
exit 1
|
||||
fi
|
||||
|
||||
VERBOSE="${1:-}"
|
||||
|
||||
# Kernel + subsystem dependencies, then the host modules. Order matters:
|
||||
# stdlib/r7rs first; the Datalog engine + ACL subsystem (authorisation); the feed
|
||||
# subsystem (the first migrated domain); Dream (types/json/auth/error/router) the
|
||||
# host builds on; then the host layer itself.
|
||||
MODULES=(
|
||||
"spec/stdlib.sx"
|
||||
"lib/r7rs.sx"
|
||||
"lib/apl/runtime.sx"
|
||||
"lib/datalog/tokenizer.sx"
|
||||
"lib/datalog/parser.sx"
|
||||
"lib/datalog/unify.sx"
|
||||
"lib/datalog/db.sx"
|
||||
"lib/datalog/builtins.sx"
|
||||
"lib/datalog/aggregates.sx"
|
||||
"lib/datalog/strata.sx"
|
||||
"lib/datalog/eval.sx"
|
||||
"lib/datalog/api.sx"
|
||||
"lib/datalog/magic.sx"
|
||||
"lib/acl/schema.sx"
|
||||
"lib/acl/facts.sx"
|
||||
"lib/acl/engine.sx"
|
||||
"lib/acl/explain.sx"
|
||||
"lib/acl/audit.sx"
|
||||
"lib/acl/federation.sx"
|
||||
"lib/acl/api.sx"
|
||||
"lib/relations/schema.sx"
|
||||
"lib/relations/engine.sx"
|
||||
"lib/relations/api.sx"
|
||||
"lib/relations/explain.sx"
|
||||
"lib/relations/federation.sx"
|
||||
"lib/relations/tree.sx"
|
||||
"lib/feed/normalize.sx"
|
||||
"lib/feed/stream.sx"
|
||||
"lib/feed/api.sx"
|
||||
"lib/persist/event.sx"
|
||||
"lib/persist/backend.sx"
|
||||
"lib/persist/log.sx"
|
||||
"lib/persist/kv.sx"
|
||||
"lib/persist/api.sx"
|
||||
"lib/persist/durable.sx"
|
||||
"spec/render.sx"
|
||||
"web/adapter-html.sx"
|
||||
"lib/dream/types.sx"
|
||||
"lib/dream/json.sx"
|
||||
"lib/dream/auth.sx"
|
||||
"lib/dream/error.sx"
|
||||
"lib/dream/form.sx"
|
||||
"lib/dream/router.sx"
|
||||
"lib/host/handler.sx"
|
||||
"lib/host/middleware.sx"
|
||||
"lib/host/sxtp.sx"
|
||||
"lib/host/router.sx"
|
||||
"lib/host/feed.sx"
|
||||
"lib/host/relations.sx"
|
||||
"lib/host/blog.sx"
|
||||
"lib/host/page.sx"
|
||||
"lib/host/server.sx"
|
||||
"lib/host/ledger.sx"
|
||||
)
|
||||
|
||||
# Suites: NAME RUNNER-FN PATH
|
||||
SUITES=(
|
||||
"handler host-hd-tests-run! lib/host/tests/handler.sx"
|
||||
"middleware host-mw-tests-run! lib/host/tests/middleware.sx"
|
||||
"sxtp host-sx-tests-run! lib/host/tests/sxtp.sx"
|
||||
"router host-rt-tests-run! lib/host/tests/router.sx"
|
||||
"feed host-fd-tests-run! lib/host/tests/feed.sx"
|
||||
"relations host-rl-tests-run! lib/host/tests/relations.sx"
|
||||
"blog host-bl-tests-run! lib/host/tests/blog.sx"
|
||||
"page host-pg-tests-run! lib/host/tests/page.sx"
|
||||
"server host-sv-tests-run! lib/host/tests/server.sx"
|
||||
"ledger host-lg-tests-run! lib/host/tests/ledger.sx"
|
||||
)
|
||||
|
||||
TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
|
||||
EPOCH=1
|
||||
emit_load () { echo "(epoch $EPOCH)"; echo "(load \"$1\")"; EPOCH=$((EPOCH+1)); }
|
||||
emit_eval () { echo "(epoch $EPOCH)"; echo "(eval \"$1\")"; EPOCH=$((EPOCH+1)); }
|
||||
|
||||
{
|
||||
for M in "${MODULES[@]}"; do emit_load "$M"; done
|
||||
for SUITE in "${SUITES[@]}"; do
|
||||
read -r _NAME _RUNNER FILE <<< "$SUITE"
|
||||
emit_load "$FILE"
|
||||
emit_eval "($_RUNNER)"
|
||||
done
|
||||
} > "$TMPFILE"
|
||||
|
||||
OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
|
||||
|
||||
# Fail LOUD on any load/eval error. A test file that errors mid-load silently
|
||||
# truncates its suite — the runner returns only the tests that ran before the
|
||||
# error, so the suite reports a false green (e.g. "blog 13 passed, 0 failed"
|
||||
# when 16 CRUD tests never ran). Catch the error markers and abort before the
|
||||
# pass/fail tally can hide them.
|
||||
if echo "$OUTPUT" | grep -qE 'Undefined symbol|Unhandled exception|\[load\][^|]*[Ee]rror|expected list, got|: error '; then
|
||||
echo "FAIL: load/eval error detected — a suite may be silently truncated:" >&2
|
||||
echo "$OUTPUT" | grep -nE 'Undefined symbol|Unhandled exception|\[load\]|expected list, got|: error ' | head -20 >&2
|
||||
exit 1
|
||||
fi
|
||||
|
||||
TOTAL_PASS=0
|
||||
TOTAL_FAIL=0
|
||||
FAILED_SUITES=()
|
||||
LAST_DICT_LINES=$(echo "$OUTPUT" | grep -E '^\{:' || true)
|
||||
|
||||
I=0
|
||||
while read -r LINE; do
|
||||
[ -z "$LINE" ] && continue
|
||||
P=$(echo "$LINE" | grep -oE ':passed [0-9]+' | awk '{print $2}')
|
||||
F=$(echo "$LINE" | grep -oE ':failed [0-9]+' | awk '{print $2}')
|
||||
[ -z "$P" ] && P=0
|
||||
[ -z "$F" ] && F=0
|
||||
SUITE_INFO="${SUITES[$I]}"
|
||||
SUITE_NAME=$(echo "$SUITE_INFO" | awk '{print $1}')
|
||||
TOTAL_PASS=$((TOTAL_PASS + P))
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + F))
|
||||
if [ "$F" -gt 0 ]; then
|
||||
FAILED_SUITES+=("$SUITE_NAME: $P/$((P+F))")
|
||||
printf 'X %-12s %d/%d\n' "$SUITE_NAME" "$P" "$((P+F))"
|
||||
echo "$LINE" | grep -oE ':name "[^"]*"' | sed 's/:name / fail: /'
|
||||
elif [ "$VERBOSE" = "-v" ]; then
|
||||
printf 'ok %-12s %d passed\n' "$SUITE_NAME" "$P"
|
||||
fi
|
||||
I=$((I+1))
|
||||
done <<< "$LAST_DICT_LINES"
|
||||
|
||||
TOTAL=$((TOTAL_PASS + TOTAL_FAIL))
|
||||
if [ "$TOTAL" -eq 0 ]; then
|
||||
echo "ERROR: no suite results parsed. Raw output:" >&2
|
||||
echo "$OUTPUT" >&2
|
||||
exit 1
|
||||
fi
|
||||
if [ $TOTAL_FAIL -eq 0 ]; then
|
||||
echo "ok $TOTAL_PASS/$TOTAL host-on-sx tests passed (${#SUITES[@]} suites)"
|
||||
else
|
||||
echo "FAIL $TOTAL_PASS/$TOTAL passed, $TOTAL_FAIL failed:"
|
||||
for S in "${FAILED_SUITES[@]}"; do echo " $S"; done
|
||||
exit 1
|
||||
fi
|
||||
49
lib/host/feed.sx
Normal file
49
lib/host/feed.sx
Normal file
@@ -0,0 +1,49 @@
|
||||
;; lib/host/feed.sx — Feed domain endpoints on the host. The first domain migrated
|
||||
;; onto the SX host: read the activity timeline (GET /feed) and create activities
|
||||
;; (POST /feed). Both go straight through the feed subsystem's public API; the
|
||||
;; write path runs behind the host middleware stack (auth + ACL). Depends on
|
||||
;; lib/feed/* + lib/host/handler.sx + lib/host/middleware.sx (write routes only).
|
||||
|
||||
;; ── read ───────────────────────────────────────────────────────────
|
||||
|
||||
;; GET /feed -> recent-first activities as a JSON envelope.
|
||||
;; Query: ?actor=<id> (filter) ?limit=<n> (cap, applied after filtering).
|
||||
(define host/feed-timeline
|
||||
(fn (req)
|
||||
(let ((base (feed/recent (feed/all)))
|
||||
(actor (dream-query-param req "actor")))
|
||||
(let ((filtered (if actor (feed/by-actor base actor) base))
|
||||
(limit (dream-query-param req "limit")))
|
||||
(let ((capped
|
||||
(if limit (feed/take filtered (string->number limit)) filtered)))
|
||||
(host/ok (feed/items capped)))))))
|
||||
|
||||
;; Public read route group.
|
||||
(define host/feed-routes
|
||||
(list
|
||||
(dream-get "/feed" host/feed-timeline)))
|
||||
|
||||
;; ── write ──────────────────────────────────────────────────────────
|
||||
|
||||
;; POST /feed -> create an activity from the JSON body. Returns 201 + the created
|
||||
;; (normalised) activity. Body must be a JSON object; anything else -> 400.
|
||||
(define host/feed-create
|
||||
(fn (req)
|
||||
(let ((raw (dream-json-body req)))
|
||||
(if (= (type-of raw) "dict")
|
||||
(host/ok-status 201 (feed/post raw))
|
||||
(host/error 400 "invalid activity")))))
|
||||
|
||||
;; Guarded write route group: POST /feed behind auth + ACL ("post" on "feed").
|
||||
;; resolve : token -> principal | nil (injected auth policy, e.g. token lookup
|
||||
;; against the identity subsystem). Errors thrown downstream become a JSON 500.
|
||||
(define host/feed-write-routes
|
||||
(fn (resolve)
|
||||
(list
|
||||
(dream-post "/feed"
|
||||
(host/pipeline
|
||||
(list
|
||||
host/wrap-errors
|
||||
(host/require-auth resolve)
|
||||
(host/require-permission "post" (fn (req) "feed")))
|
||||
host/feed-create)))))
|
||||
39
lib/host/handler.sx
Normal file
39
lib/host/handler.sx
Normal file
@@ -0,0 +1,39 @@
|
||||
;; lib/host/handler.sx — Host handler layer: the bridge from a Dream request to a
|
||||
;; subsystem call and back to a Dream response. A host handler IS a Dream handler
|
||||
;; (request -> response); these helpers build the JSON envelope every host
|
||||
;; endpoint shares: {"ok":true,"data":...} on success, {"ok":false,"error":...}
|
||||
;; on failure. Plus a status-carrying JSON constructor that Dream's own dream-json
|
||||
;; (200-only) lacks, and a couple of request-reading conveniences.
|
||||
;; Depends on lib/dream/types.sx + lib/dream/json.sx.
|
||||
|
||||
;; ── responses ──────────────────────────────────────────────────────
|
||||
|
||||
;; JSON response at an arbitrary status (dream-json is 200-only).
|
||||
(define host/json-status
|
||||
(fn (status value)
|
||||
(dream-response status {:content-type "application/json"}
|
||||
(dream-json-encode value))))
|
||||
|
||||
;; Success envelope: 200 {"ok":true,"data":<value>}.
|
||||
(define host/ok
|
||||
(fn (value)
|
||||
(host/json-status 200 {:ok true :data value})))
|
||||
|
||||
;; Success envelope at a chosen status (e.g. 201 for a created resource).
|
||||
(define host/ok-status
|
||||
(fn (status value)
|
||||
(host/json-status status {:ok true :data value})))
|
||||
|
||||
;; Error envelope: {"ok":false,"error":<message>} at the given status.
|
||||
(define host/error
|
||||
(fn (status message)
|
||||
(host/json-status status {:ok false :error message})))
|
||||
|
||||
;; ── request reading ────────────────────────────────────────────────
|
||||
|
||||
;; Integer query param with a fallback (query params arrive as strings).
|
||||
;; Absent param -> fallback; present -> parsed number.
|
||||
(define host/query-int
|
||||
(fn (req name fallback)
|
||||
(let ((raw (dream-query-param req name)))
|
||||
(if raw (string->number raw) fallback))))
|
||||
89
lib/host/ledger.sx
Normal file
89
lib/host/ledger.sx
Normal file
@@ -0,0 +1,89 @@
|
||||
;; lib/host/ledger.sx — the strangler migration ledger. A catalogue of every
|
||||
;; rose-ash HTTP endpoint with its Quart original and its current host status, so
|
||||
;; the cut-over from Quart to the SX host is tracked endpoint-by-endpoint rather
|
||||
;; than big-bang. Status is one of:
|
||||
;; :native — born on the host, has no Quart original (e.g. /health probe)
|
||||
;; :migrated — moved off Quart, now served by an SX handler
|
||||
;; :proxied — still on Quart; the host forwards until cut over
|
||||
;; Coverage (how far the strangler has progressed = how much is OFF Quart) is
|
||||
;; computed from the catalogue. Pure data + queries — no IO, fully conformable.
|
||||
|
||||
;; ── entry constructor ───────────────────────────────────────────────
|
||||
;; quart is a "service:handler" ref string (nil for :native endpoints); handler
|
||||
;; is the SX handler name serving it (nil while still :proxied).
|
||||
(define host/ledger-entry
|
||||
(fn (domain method path quart status handler)
|
||||
{:domain domain :method method :path path
|
||||
:quart quart :status status :handler handler}))
|
||||
|
||||
;; ── the catalogue ───────────────────────────────────────────────────
|
||||
;; Reflects the live host: feed reads+writes migrated, /health native, the
|
||||
;; relations container endpoints migrated onto lib/relations (reads get-children/
|
||||
;; get-parents + writes attach-child/detach-child — see lib/host/relations.sx).
|
||||
;; The TYPED relations actions (relate/unrelate/can-relate) stay proxied: they
|
||||
;; carry registry + cardinality validation lib/relations does not implement. The
|
||||
;; internal-only likes data+action endpoints stay proxied too — likes has no SX
|
||||
;; subsystem to dispatch to.
|
||||
(define host/ledger
|
||||
(list
|
||||
(host/ledger-entry "host" "GET" "/health" nil "native" "host/health-route")
|
||||
(host/ledger-entry "blog" "GET" "/:slug" "blog:post_detail" "migrated" "host/blog-post")
|
||||
(host/ledger-entry "feed" "GET" "/feed" "feed:timeline" "migrated" "host/feed-timeline")
|
||||
(host/ledger-entry "feed" "POST" "/feed" "feed:create" "migrated" "host/feed-create")
|
||||
(host/ledger-entry "relations" "GET" "/internal/data/get-children" "relations:get_children" "migrated" "host/relations-children")
|
||||
(host/ledger-entry "relations" "GET" "/internal/data/get-parents" "relations:get_parents" "migrated" "host/relations-parents")
|
||||
(host/ledger-entry "relations" "POST" "/internal/actions/attach-child" "relations:attach_child" "migrated" "host/relations-attach")
|
||||
(host/ledger-entry "relations" "POST" "/internal/actions/detach-child" "relations:detach_child" "migrated" "host/relations-detach")
|
||||
(host/ledger-entry "relations" "POST" "/internal/actions/relate" "relations:relate" "proxied" nil)
|
||||
(host/ledger-entry "relations" "POST" "/internal/actions/unrelate" "relations:unrelate" "proxied" nil)
|
||||
(host/ledger-entry "relations" "POST" "/internal/actions/can-relate" "relations:can_relate" "proxied" nil)
|
||||
(host/ledger-entry "likes" "GET" "/internal/data/is-liked" "likes:is_liked" "proxied" nil)
|
||||
(host/ledger-entry "likes" "GET" "/internal/data/liked-slugs" "likes:liked_slugs" "proxied" nil)
|
||||
(host/ledger-entry "likes" "GET" "/internal/data/liked-ids" "likes:liked_ids" "proxied" nil)
|
||||
(host/ledger-entry "likes" "POST" "/internal/actions/toggle" "likes:toggle" "proxied" nil)))
|
||||
|
||||
;; ── status / domain queries ─────────────────────────────────────────
|
||||
(define host/ledger-by-status
|
||||
(fn (ledger status) (filter (fn (e) (= (get e :status) status)) ledger)))
|
||||
(define host/ledger-migrated (fn (ledger) (host/ledger-by-status ledger "migrated")))
|
||||
(define host/ledger-proxied (fn (ledger) (host/ledger-by-status ledger "proxied")))
|
||||
(define host/ledger-native (fn (ledger) (host/ledger-by-status ledger "native")))
|
||||
(define host/ledger-by-domain
|
||||
(fn (ledger domain) (filter (fn (e) (= (get e :domain) domain)) ledger)))
|
||||
|
||||
;; An endpoint is OFF Quart (served by the host) iff native or migrated.
|
||||
(define host/ledger-served?
|
||||
(fn (e) (or (= (get e :status) "native") (= (get e :status) "migrated"))))
|
||||
|
||||
;; First entry matching (method, path), or nil.
|
||||
(define host/ledger-find
|
||||
(fn (ledger method path)
|
||||
(let ((hits (filter
|
||||
(fn (e) (and (= (get e :method) method) (= (get e :path) path)))
|
||||
ledger)))
|
||||
(if (> (len hits) 0) (first hits) nil))))
|
||||
|
||||
;; Distinct domains in the catalogue (order: first-seen, reversed by cons).
|
||||
(define host/ledger-domains
|
||||
(fn (ledger)
|
||||
(reduce
|
||||
(fn (acc e)
|
||||
(let ((d (get e :domain)))
|
||||
(if (some (fn (x) (= x d)) acc) acc (cons d acc))))
|
||||
(list)
|
||||
ledger)))
|
||||
|
||||
;; ── coverage ────────────────────────────────────────────────────────
|
||||
;; served = off Quart (migrated + native); percent = served / total, floored.
|
||||
(define host/ledger-coverage
|
||||
(fn (ledger)
|
||||
(let ((total (len ledger))
|
||||
(migrated (len (host/ledger-migrated ledger)))
|
||||
(proxied (len (host/ledger-proxied ledger)))
|
||||
(native (len (host/ledger-native ledger))))
|
||||
{:total total
|
||||
:migrated migrated
|
||||
:proxied proxied
|
||||
:native native
|
||||
:served (+ migrated native)
|
||||
:percent (if (= total 0) 0 (quotient (* 100 (+ migrated native)) total))})))
|
||||
54
lib/host/middleware.sx
Normal file
54
lib/host/middleware.sx
Normal file
@@ -0,0 +1,54 @@
|
||||
;; lib/host/middleware.sx — Host middleware: composable handler->handler layers
|
||||
;; for the cross-cutting concerns every write endpoint shares — error trapping
|
||||
;; (JSON 500), authentication (bearer token -> principal), and authorisation
|
||||
;; (ACL permit?). Middleware is plain function composition; host/pipeline threads a
|
||||
;; list onto a handler, FIRST middleware outermost (so it runs first). Auth and
|
||||
;; permission policy are INJECTED — the token resolver and the resource extractor —
|
||||
;; so this layer carries no hardcoded policy. Reuses Dream's bearer/error helpers
|
||||
;; and lib/acl's public acl/permit?.
|
||||
;; Depends on lib/dream/{auth,error,router}.sx + lib/acl/api.sx + lib/host/handler.sx.
|
||||
|
||||
;; Compose a list of middlewares onto a handler (first = outermost).
|
||||
(define host/pipeline
|
||||
(fn (middlewares handler)
|
||||
(dr/apply-middlewares middlewares handler)))
|
||||
|
||||
;; The authenticated principal attached by host/require-auth.
|
||||
(define host/principal (fn (req) (dream-principal req)))
|
||||
|
||||
;; ── error trapping ─────────────────────────────────────────────────
|
||||
;; Any error thrown downstream becomes a JSON 500 envelope.
|
||||
(define host/-on-error
|
||||
(fn (req e) (host/error 500 "internal error")))
|
||||
(define host/wrap-errors (dream-catch-with host/-on-error))
|
||||
|
||||
;; ── authentication ─────────────────────────────────────────────────
|
||||
;; resolve : token -> principal | nil. Missing/invalid token -> JSON 401 with a
|
||||
;; WWW-Authenticate: Bearer challenge; success attaches :dream-principal so
|
||||
;; downstream layers (and host/principal) can read it.
|
||||
(define host/require-auth
|
||||
(fn (resolve)
|
||||
(fn (next)
|
||||
(fn (req)
|
||||
(let ((tok (dream-bearer-token req)))
|
||||
(let ((principal (if tok (resolve tok) nil)))
|
||||
(if (nil? principal)
|
||||
(dream-add-header
|
||||
(host/error 401 "unauthorized")
|
||||
"www-authenticate"
|
||||
"Bearer")
|
||||
(next (assoc req :dream-principal principal)))))))))
|
||||
|
||||
;; ── authorisation ──────────────────────────────────────────────────
|
||||
;; Gate on ACL: the authed principal must be permitted `action` on the resource
|
||||
;; computed by res-fn from the request. Denied -> JSON 403. Assumes the ACL fact
|
||||
;; db was loaded (acl/load!) at startup. Place AFTER host/require-auth.
|
||||
(define host/require-permission
|
||||
(fn (action res-fn)
|
||||
(fn (next)
|
||||
(fn (req)
|
||||
(let ((subject (host/principal req))
|
||||
(resource (res-fn req)))
|
||||
(if (acl/permit? subject action resource)
|
||||
(next req)
|
||||
(host/error 403 "forbidden")))))))
|
||||
22
lib/host/page.sx
Normal file
22
lib/host/page.sx
Normal file
@@ -0,0 +1,22 @@
|
||||
;; lib/host/page.sx — serve interactive SX component/island pages on the host
|
||||
;; (Phase 5: the generic interactive-SX-page capability).
|
||||
;;
|
||||
;; The bare `render-to-html` path mangles an EVALUATED component tree's keyword
|
||||
;; attributes ((form :id ..) -> "<form>idpost-new-form..."), because evaluating a
|
||||
;; defcomp body turns `:id` into a child. The kernel `render-page` primitive
|
||||
;; instead renders an UNEVALUATED expression with the server env: render-to-html
|
||||
;; expands the components itself and collects keyword args as attributes. SX
|
||||
;; handlers can't reach the server env, so render-page supplies it.
|
||||
;;
|
||||
;; host/page wraps a rendered expression as an HTML response; host/page-route
|
||||
;; mounts it on a GET path. This is the component-render step (5.1); the full page
|
||||
;; shell (inlined component defs + CSS + client runtime + hydration) and static
|
||||
;; asset serving (5.2–5.4) build on top to make the page interactive.
|
||||
;; Depends on the kernel `render-page` primitive + lib/dream/types.sx (dream-html).
|
||||
|
||||
;; Render an unevaluated SX page/component expression to an HTML response.
|
||||
(define host/page (fn (expr) (dream-html (render-page expr))))
|
||||
|
||||
;; Mount a GET route that renders a fixed page expression.
|
||||
(define host/page-route
|
||||
(fn (path expr) (dream-get path (fn (req) (host/page expr)))))
|
||||
132
lib/host/relations.sx
Normal file
132
lib/host/relations.sx
Normal file
@@ -0,0 +1,132 @@
|
||||
;; lib/host/relations.sx — Relations domain endpoints on the host. The relations
|
||||
;; service is internal-only (no public routes): Quart exposes it as signed
|
||||
;; /internal/data/{query} reads + /internal/actions/{action} writes. This migrates
|
||||
;; the two READ queries — get-children, get-parents — straight onto the SX host,
|
||||
;; dispatching to the lib/relations subsystem (a saturating Datalog graph).
|
||||
;;
|
||||
;; Node model: the Quart relations API keys nodes by a (type, id) pair; the graph
|
||||
;; subsystem keys them by an opaque atom. We bridge by composing the atom as the
|
||||
;; symbol "type:id", with the relation-type as the edge kind. Optional child-type
|
||||
;; / parent-type params filter the result by that "type:" prefix — matching the
|
||||
;; Quart queries' optional type narrowing.
|
||||
;; Depends on lib/relations/* + lib/host/handler.sx + lib/dream/* (query params).
|
||||
|
||||
;; ── node helpers ────────────────────────────────────────────────────
|
||||
(define host/-rel-node
|
||||
(fn (type id) (string->symbol (str type ":" id))))
|
||||
(define host/-rel-node-type?
|
||||
(fn (node type) (starts-with? (symbol->string node) (str type ":"))))
|
||||
(define host/-rel-strings
|
||||
(fn (nodes) (map (fn (n) (symbol->string n)) nodes)))
|
||||
|
||||
;; ── GET /internal/data/get-children ─────────────────────────────────
|
||||
;; query: parent-type, parent-id, relation-type (required); child-type (optional
|
||||
;; filter). Returns the child node ids ("type:id") for the parent under that kind.
|
||||
(define host/relations-children
|
||||
(fn (req)
|
||||
(let ((ptype (dream-query-param req "parent-type"))
|
||||
(pid (dream-query-param req "parent-id"))
|
||||
(kind (dream-query-param req "relation-type")))
|
||||
(if (and ptype pid kind)
|
||||
(let ((kids (relations/children (host/-rel-node ptype pid) (string->symbol kind)))
|
||||
(ctype (dream-query-param req "child-type")))
|
||||
(let ((sel (if ctype (filter (fn (k) (host/-rel-node-type? k ctype)) kids) kids)))
|
||||
(host/ok (host/-rel-strings sel))))
|
||||
(host/error 400 "missing parameter")))))
|
||||
|
||||
;; ── GET /internal/data/get-parents ──────────────────────────────────
|
||||
;; query: child-type, child-id, relation-type (required); parent-type (optional
|
||||
;; filter). Returns the parent node ids ("type:id") for the child under that kind.
|
||||
(define host/relations-parents
|
||||
(fn (req)
|
||||
(let ((ctype (dream-query-param req "child-type"))
|
||||
(cid (dream-query-param req "child-id"))
|
||||
(kind (dream-query-param req "relation-type")))
|
||||
(if (and ctype cid kind)
|
||||
(let ((ps (relations/parents (host/-rel-node ctype cid) (string->symbol kind)))
|
||||
(ptype (dream-query-param req "parent-type")))
|
||||
(let ((sel (if ptype (filter (fn (p) (host/-rel-node-type? p ptype)) ps) ps)))
|
||||
(host/ok (host/-rel-strings sel))))
|
||||
(host/error 400 "missing parameter")))))
|
||||
|
||||
;; ── read route group ────────────────────────────────────────────────
|
||||
;; Internal data reads (the signed-internal-auth gate is a separate middleware
|
||||
;; concern, like the feed reads); these dispatch straight to the subsystem.
|
||||
(define host/relations-routes
|
||||
(list
|
||||
(dream-get "/internal/data/get-children" host/relations-children)
|
||||
(dream-get "/internal/data/get-parents" host/relations-parents)))
|
||||
|
||||
;; ── writes: container relations (attach-child / detach-child) ────────
|
||||
;; The write side of get-children/get-parents: a container edge between a parent
|
||||
;; (type,id) and child (type,id) under a relation kind. Maps to relations/relate
|
||||
;; and relations/unrelate over the same "type:id" node model, so an attach is
|
||||
;; immediately visible through get-children. (The TYPED relate/unrelate/can-relate
|
||||
;; actions stay on Quart — they carry registry + cardinality validation that
|
||||
;; lib/relations does not implement.) Body is the action's JSON params dict.
|
||||
|
||||
;; Pull the four node coordinates + kind from a payload; nil if any are absent.
|
||||
(define host/-rel-edge
|
||||
(fn (p)
|
||||
(let ((pt (get p :parent-type)) (pid (get p :parent-id))
|
||||
(ct (get p :child-type)) (cid (get p :child-id))
|
||||
(kind (get p :relation-type)))
|
||||
(if (and pt pid ct cid kind)
|
||||
{:parent (host/-rel-node pt pid)
|
||||
:child (host/-rel-node ct cid)
|
||||
:kind (string->symbol kind)
|
||||
:parent-id (str pt ":" pid)
|
||||
:child-id (str ct ":" cid)
|
||||
:relation kind}
|
||||
nil))))
|
||||
|
||||
;; POST /internal/actions/attach-child — create the container edge. 201 on success.
|
||||
(define host/relations-attach
|
||||
(fn (req)
|
||||
(let ((p (dream-json-body req)))
|
||||
(if (= (type-of p) "dict")
|
||||
(let ((e (host/-rel-edge p)))
|
||||
(if e
|
||||
(begin
|
||||
(relations/relate (get e :parent) (get e :child) (get e :kind))
|
||||
(host/ok-status 201
|
||||
{:parent (get e :parent-id) :child (get e :child-id)
|
||||
:relation (get e :relation)}))
|
||||
(host/error 400 "missing parameter")))
|
||||
(host/error 400 "invalid payload")))))
|
||||
|
||||
;; POST /internal/actions/detach-child — remove the container edge. 200 on success.
|
||||
(define host/relations-detach
|
||||
(fn (req)
|
||||
(let ((p (dream-json-body req)))
|
||||
(if (= (type-of p) "dict")
|
||||
(let ((e (host/-rel-edge p)))
|
||||
(if e
|
||||
(begin
|
||||
(relations/unrelate (get e :parent) (get e :child) (get e :kind))
|
||||
(host/ok
|
||||
{:parent (get e :parent-id) :child (get e :child-id)
|
||||
:relation (get e :relation) :detached true}))
|
||||
(host/error 400 "missing parameter")))
|
||||
(host/error 400 "invalid payload")))))
|
||||
|
||||
;; Guarded write route group: each action behind auth + ACL. attach needs
|
||||
;; ("relate","relations"); detach needs ("unrelate","relations"). resolve is the
|
||||
;; injected token->principal auth policy (same shape as host/feed-write-routes).
|
||||
(define host/relations-write-routes
|
||||
(fn (resolve)
|
||||
(list
|
||||
(dream-post "/internal/actions/attach-child"
|
||||
(host/pipeline
|
||||
(list
|
||||
host/wrap-errors
|
||||
(host/require-auth resolve)
|
||||
(host/require-permission "relate" (fn (req) "relations")))
|
||||
host/relations-attach))
|
||||
(dream-post "/internal/actions/detach-child"
|
||||
(host/pipeline
|
||||
(list
|
||||
host/wrap-errors
|
||||
(host/require-auth resolve)
|
||||
(host/require-permission "unrelate" (fn (req) "relations")))
|
||||
host/relations-detach)))))
|
||||
19
lib/host/router.sx
Normal file
19
lib/host/router.sx
Normal file
@@ -0,0 +1,19 @@
|
||||
;; lib/host/router.sx — Host application assembly. A host app is a single Dream
|
||||
;; router built from per-domain route groups, with a built-in health endpoint and
|
||||
;; a JSON 404 fallback so the native OCaml HTTP server has one entry point:
|
||||
;; request -> response. Each subsystem contributes a list of Dream routes (see
|
||||
;; lib/host/feed.sx); host/make-app concatenates them under one router.
|
||||
;; dr/flatten-routes (Dream) flattens the nested groups, so a group is just a list
|
||||
;; of routes. Depends on lib/dream/router.sx + lib/host/handler.sx.
|
||||
|
||||
;; Liveness probe — GET /health -> 200 {"ok":true,"data":"healthy"}.
|
||||
(define host/health-route
|
||||
(dream-get "/health" (fn (req) (host/ok "healthy"))))
|
||||
|
||||
;; Build the host app from a list of route groups (each a list of Dream routes).
|
||||
;; The health route is always mounted first; Dream's router returns a JSON-free
|
||||
;; 404 for unmatched paths, which host endpoints override per-domain as needed.
|
||||
(define host/make-app
|
||||
(fn (groups)
|
||||
(dream-router
|
||||
(cons host/health-route groups))))
|
||||
110
lib/host/serve.sh
Executable file
110
lib/host/serve.sh
Executable file
@@ -0,0 +1,110 @@
|
||||
#!/usr/bin/env bash
|
||||
# host-on-sx live server launcher. Loads the kernel stdlib, the subsystem
|
||||
# libraries, and the host modules into one sx_server process, then calls
|
||||
# (host/serve PORT ...) which binds the native http-listen server to the
|
||||
# Dream-shaped host app. Runs in the FOREGROUND (http-listen blocks), so this
|
||||
# doubles as a container entrypoint and a local launcher.
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/host/serve.sh # serve on $HOST_PORT (default 8910)
|
||||
# HOST_PORT=8920 bash lib/host/serve.sh # pick a port
|
||||
#
|
||||
# The module list is kept identical to lib/host/conformance.sh so what serves is
|
||||
# exactly what the suites verify.
|
||||
|
||||
set -uo pipefail
|
||||
# Project root: SX_PROJECT_DIR in containers (set to /app by the compose stack),
|
||||
# else the git toplevel for local runs.
|
||||
cd "${SX_PROJECT_DIR:-$(git rev-parse --show-toplevel 2>/dev/null || echo .)}"
|
||||
|
||||
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
fi
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
echo "ERROR: sx_server.exe not found." >&2
|
||||
exit 1
|
||||
fi
|
||||
|
||||
PORT="${HOST_PORT:-8910}"
|
||||
|
||||
# Modules: every load line from conformance.sh's MODULES list, minus the ledger
|
||||
# (not needed to serve). server.sx supplies host/serve.
|
||||
MODULES=(
|
||||
"spec/stdlib.sx"
|
||||
"lib/r7rs.sx"
|
||||
"lib/apl/runtime.sx"
|
||||
"lib/datalog/tokenizer.sx"
|
||||
"lib/datalog/parser.sx"
|
||||
"lib/datalog/unify.sx"
|
||||
"lib/datalog/db.sx"
|
||||
"lib/datalog/builtins.sx"
|
||||
"lib/datalog/aggregates.sx"
|
||||
"lib/datalog/strata.sx"
|
||||
"lib/datalog/eval.sx"
|
||||
"lib/datalog/api.sx"
|
||||
"lib/datalog/magic.sx"
|
||||
"lib/acl/schema.sx"
|
||||
"lib/acl/facts.sx"
|
||||
"lib/acl/engine.sx"
|
||||
"lib/acl/explain.sx"
|
||||
"lib/acl/audit.sx"
|
||||
"lib/acl/federation.sx"
|
||||
"lib/acl/api.sx"
|
||||
"lib/relations/schema.sx"
|
||||
"lib/relations/engine.sx"
|
||||
"lib/relations/api.sx"
|
||||
"lib/relations/explain.sx"
|
||||
"lib/relations/federation.sx"
|
||||
"lib/relations/tree.sx"
|
||||
"lib/feed/normalize.sx"
|
||||
"lib/feed/stream.sx"
|
||||
"lib/feed/api.sx"
|
||||
"lib/persist/event.sx"
|
||||
"lib/persist/backend.sx"
|
||||
"lib/persist/log.sx"
|
||||
"lib/persist/kv.sx"
|
||||
"lib/persist/api.sx"
|
||||
"lib/persist/durable.sx"
|
||||
"spec/render.sx"
|
||||
"web/adapter-html.sx"
|
||||
"lib/dream/types.sx"
|
||||
"lib/dream/json.sx"
|
||||
"lib/dream/auth.sx"
|
||||
"lib/dream/error.sx"
|
||||
"lib/dream/form.sx"
|
||||
"lib/dream/router.sx"
|
||||
"lib/host/handler.sx"
|
||||
"lib/host/middleware.sx"
|
||||
"lib/host/sxtp.sx"
|
||||
"lib/host/router.sx"
|
||||
"lib/host/feed.sx"
|
||||
"lib/host/relations.sx"
|
||||
"lib/host/blog.sx"
|
||||
"lib/host/server.sx"
|
||||
)
|
||||
|
||||
EPOCH=1
|
||||
{
|
||||
for M in "${MODULES[@]}"; do
|
||||
echo "(epoch $EPOCH)"; echo "(load \"$M\")"; EPOCH=$((EPOCH+1))
|
||||
done
|
||||
# Point the blog at the DURABLE file backend (persists under $SX_PERSIST_DIR),
|
||||
# then idempotently seed a welcome post (sx_content = SX element markup, the
|
||||
# editor's content model). Re-seeding is a no-op if the slug already exists.
|
||||
echo "(epoch $EPOCH)"
|
||||
echo "(eval \"(host/blog-use-store! (persist/durable-backend))\")"
|
||||
EPOCH=$((EPOCH+1))
|
||||
echo "(epoch $EPOCH)"
|
||||
echo "(eval \"(host/blog-seed! \\\"welcome\\\" \\\"Welcome to the SX host\\\" \\\"(article (h1 \\\\\\\"Welcome to the SX host\\\\\\\") (p \\\\\\\"Rendered by lib/host via render-to-html, from the durable SX store.\\\\\\\"))\\\" \\\"published\\\")\")"
|
||||
EPOCH=$((EPOCH+1))
|
||||
echo "(epoch $EPOCH)"
|
||||
# Anonymous read endpoints: feed timeline + relations container reads + blog
|
||||
# post detail (blog-routes LAST — the :slug catch-all must not shadow the rest).
|
||||
# Guarded write groups (auth/ACL or internal-HMAC) are added here once their
|
||||
# injected policy is supplied at wiring time.
|
||||
# EXPERIMENTAL: host/blog-open-create-routes mounts POST /new UNGUARDED (no
|
||||
# auth) so the editor can publish end-to-end on the experimental subdomain.
|
||||
# Create-only (no PUT/DELETE). GATE (Caddy basicauth / sessions) before real use.
|
||||
echo "(eval \"(host/serve $PORT (list host/feed-routes host/relations-routes host/blog-open-create-routes host/blog-routes))\")"
|
||||
} | exec "$SX_SERVER"
|
||||
44
lib/host/server.sx
Normal file
44
lib/host/server.sx
Normal file
@@ -0,0 +1,44 @@
|
||||
;; lib/host/server.sx — the live wiring: bridge the native OCaml http-listen
|
||||
;; server to the Dream-shaped host app, and serve. The native server hands a
|
||||
;; handler a STRING-keyed request dict {"method" "path" "query" "headers" "body"}
|
||||
;; and expects back {:status :headers :body}. The host app (host/make-app ->
|
||||
;; dream-router) is a fn dream-request -> dream-response. This module adapts
|
||||
;; between the two shapes and calls http-listen.
|
||||
;; Depends on lib/dream/* (dream-request/response accessors) + lib/host/router.sx
|
||||
;; + the kernel http-listen primitive.
|
||||
|
||||
;; ── native request -> dream request ─────────────────────────────────
|
||||
;; Reassemble path + query into the target string dream-request parses, and carry
|
||||
;; method/headers/body. Missing fields default empty.
|
||||
(define host/-native->dream
|
||||
(fn (req)
|
||||
(let ((path (or (get req "path") "/"))
|
||||
(query (or (get req "query") ""))
|
||||
(method (or (get req "method") "GET"))
|
||||
(headers (or (get req "headers") {}))
|
||||
(body (or (get req "body") "")))
|
||||
(let ((target (if (> (len query) 0) (str path "?" query) path)))
|
||||
(dream-request method target headers body)))))
|
||||
|
||||
;; ── dream response -> native response ───────────────────────────────
|
||||
;; dream-response is already {:body :headers :status}; the native server wants
|
||||
;; {:status :headers :body}. Same keys — normalise the shape explicitly so the
|
||||
;; contract is visible (and headers/body never nil).
|
||||
(define host/-dream->native
|
||||
(fn (resp)
|
||||
{:status (dream-status resp)
|
||||
:headers (or (dream-headers resp) {})
|
||||
:body (or (dream-resp-body resp) "")}))
|
||||
|
||||
;; ── adapter + serve ─────────────────────────────────────────────────
|
||||
;; Wrap a Dream app as a native http-listen handler.
|
||||
(define host/native-handler
|
||||
(fn (app)
|
||||
(fn (req)
|
||||
(host/-dream->native (app (host/-native->dream req))))))
|
||||
|
||||
;; Build the app from route groups and start the native server on `port`.
|
||||
;; Blocks (the http-listen primitive runs the server loop).
|
||||
(define host/serve
|
||||
(fn (port groups)
|
||||
(http-listen port (host/native-handler (host/make-app groups)))))
|
||||
173
lib/host/sxtp.sx
Normal file
173
lib/host/sxtp.sx
Normal file
@@ -0,0 +1,173 @@
|
||||
;; lib/host/sxtp.sx — SXTP, the host<->subsystem wire format. SXTP messages are
|
||||
;; SX s-expressions (content-type text/sx): a request/response/condition/event is
|
||||
;; a tagged list `(request :verb navigate :path "/x" ...)`. See the protocol spec
|
||||
;; at applications/sxtp/spec.sx.
|
||||
;;
|
||||
;; Representation: internally a message is a plain dict tagged by :msg ("request"
|
||||
;; /"response"/"condition"/"event"), with string keys so the keyword==string rule
|
||||
;; makes construction and access trivial. verb/status/type are stored as SYMBOLS
|
||||
;; (they ride the wire bare, not quoted). The wire LIST form is produced/consumed
|
||||
;; only at the serialise/parse boundary:
|
||||
;; sxtp/serialize : msg-dict -> text/sx string
|
||||
;; sxtp/parse : text/sx string -> msg-dict
|
||||
;; A Dream HTTP request/response bridges to/from SXTP via sxtp/from-dream and
|
||||
;; sxtp/to-dream, so the host can speak SXTP to subsystems while serving HTTP.
|
||||
;; Depends on lib/dream/types.sx (dream-response + request/response accessors).
|
||||
|
||||
;; ── helpers ────────────────────────────────────────────────────────
|
||||
(define sxtp/-sym
|
||||
(fn (x) (if (= (type-of x) "symbol") x (string->symbol x))))
|
||||
(define sxtp/-name
|
||||
(fn (x) (if (= (type-of x) "symbol") (symbol->string x) x)))
|
||||
|
||||
;; ── constructors ───────────────────────────────────────────────────
|
||||
;; opts is a dict of optional fields (e.g. {:headers .. :params .. :body ..}).
|
||||
(define sxtp/request
|
||||
(fn (verb path opts)
|
||||
(merge {:msg "request" :verb (sxtp/-sym verb) :path path} opts)))
|
||||
(define sxtp/response
|
||||
(fn (status opts)
|
||||
(merge {:msg "response" :status (sxtp/-sym status)} opts)))
|
||||
(define sxtp/condition
|
||||
(fn (ctype opts)
|
||||
(merge {:msg "condition" :type (sxtp/-sym ctype)} opts)))
|
||||
(define sxtp/event
|
||||
(fn (etype opts)
|
||||
(merge {:msg "event" :type (sxtp/-sym etype)} opts)))
|
||||
|
||||
;; ── predicates ─────────────────────────────────────────────────────
|
||||
(define sxtp/-is?
|
||||
(fn (m tag) (and (= (type-of m) "dict") (= (get m :msg) tag))))
|
||||
(define sxtp/request? (fn (m) (sxtp/-is? m "request")))
|
||||
(define sxtp/response? (fn (m) (sxtp/-is? m "response")))
|
||||
(define sxtp/condition? (fn (m) (sxtp/-is? m "condition")))
|
||||
(define sxtp/event? (fn (m) (sxtp/-is? m "event")))
|
||||
|
||||
;; ── accessors ──────────────────────────────────────────────────────
|
||||
(define sxtp/verb (fn (m) (get m :verb)))
|
||||
(define sxtp/path (fn (m) (get m :path)))
|
||||
(define sxtp/req-headers (fn (m) (get m :headers)))
|
||||
(define sxtp/params (fn (m) (get m :params)))
|
||||
(define sxtp/param (fn (m name) (get (get m :params) name)))
|
||||
(define sxtp/body (fn (m) (get m :body)))
|
||||
(define sxtp/capabilities (fn (m) (get m :capabilities)))
|
||||
(define sxtp/status (fn (m) (get m :status)))
|
||||
(define sxtp/resp-headers (fn (m) (get m :headers)))
|
||||
(define sxtp/stream? (fn (m) (= (get m :stream) true)))
|
||||
(define sxtp/cond-type (fn (m) (get m :type)))
|
||||
(define sxtp/cond-message (fn (m) (get m :message)))
|
||||
|
||||
;; ── status helpers (build responses) ───────────────────────────────
|
||||
(define sxtp/ok (fn (body) (sxtp/response "ok" {:body body})))
|
||||
(define sxtp/created (fn (body) (sxtp/response "created" {:body body})))
|
||||
(define sxtp/no-content (fn () (sxtp/response "no-content" {})))
|
||||
(define sxtp/not-found
|
||||
(fn (path message)
|
||||
(sxtp/response "not-found"
|
||||
{:body (sxtp/condition "resource-not-found"
|
||||
{:path path :message message :retry false})})))
|
||||
(define sxtp/forbidden
|
||||
(fn (message)
|
||||
(sxtp/response "forbidden"
|
||||
{:body (sxtp/condition "forbidden" {:message message})})))
|
||||
(define sxtp/invalid
|
||||
(fn (message)
|
||||
(sxtp/response "invalid"
|
||||
{:body (sxtp/condition "invalid" {:message message})})))
|
||||
(define sxtp/fail
|
||||
(fn (message)
|
||||
(sxtp/response "error"
|
||||
{:body (sxtp/condition "error" {:message message})})))
|
||||
|
||||
;; ── HTTP <-> SXTP mappings ─────────────────────────────────────────
|
||||
(define sxtp/-method-verbs
|
||||
{:GET "fetch" :HEAD "fetch" :POST "create"
|
||||
:PUT "mutate" :PATCH "mutate" :DELETE "delete" :OPTIONS "inspect"})
|
||||
(define sxtp/verb-for-method
|
||||
(fn (method) (sxtp/-sym (get sxtp/-method-verbs (upper method) "fetch"))))
|
||||
|
||||
(define sxtp/-status-http
|
||||
{:ok 200 :created 201 :accepted 202 :no-content 204 :redirect 302
|
||||
:not-modified 304 :error 500 :not-found 404 :forbidden 403
|
||||
:invalid 400 :conflict 409 :unavailable 503})
|
||||
(define sxtp/http-status
|
||||
(fn (status) (get sxtp/-status-http (sxtp/-name status) 200)))
|
||||
|
||||
;; ── Dream bridge ───────────────────────────────────────────────────
|
||||
;; HTTP request -> SXTP request: method->verb, query->params, headers/body carry.
|
||||
(define sxtp/from-dream
|
||||
(fn (req)
|
||||
(sxtp/request
|
||||
(sxtp/verb-for-method (get req :method))
|
||||
(get req :path)
|
||||
{:headers (get req :headers)
|
||||
:params (get req :query)
|
||||
:body (get req :body)})))
|
||||
|
||||
;; SXTP response -> HTTP response: status->code, body serialised to text/sx.
|
||||
(define sxtp/-body-text
|
||||
(fn (b) (if (nil? b) "" (serialize b))))
|
||||
(define sxtp/to-dream
|
||||
(fn (resp)
|
||||
(dream-response
|
||||
(sxtp/http-status (sxtp/status resp))
|
||||
(merge {:content-type "text/sx"} (or (sxtp/resp-headers resp) {}))
|
||||
(sxtp/-body-text (sxtp/body resp)))))
|
||||
|
||||
;; ── wire serialise (msg-dict -> text/sx) ───────────────────────────
|
||||
;; Top-level field order is fixed per message type so output is deterministic;
|
||||
;; nested dict/value order follows the serialize primitive.
|
||||
(define sxtp/-field-order
|
||||
{:request (list :verb :path :headers :cookies :params :capabilities :body)
|
||||
:response (list :status :headers :set-cookie :body :stream)
|
||||
:condition (list :type :message :path :retry :detail)
|
||||
:event (list :type :id :body :time)})
|
||||
;; A nested SXTP message (a condition/event in a :body) serialises in its own
|
||||
;; list form; plain data values go through the serialize primitive.
|
||||
(define sxtp/-emit-value
|
||||
(fn (v)
|
||||
(if (and (= (type-of v) "dict") (has-key? v :msg))
|
||||
(sxtp/serialize v)
|
||||
(serialize v))))
|
||||
(define sxtp/serialize
|
||||
(fn (msg)
|
||||
(let ((head (get msg :msg)))
|
||||
(let ((order (get sxtp/-field-order head)))
|
||||
(str "("
|
||||
head
|
||||
(reduce
|
||||
(fn (acc k)
|
||||
(if (has-key? msg k)
|
||||
(str acc " :" k " " (sxtp/-emit-value (get msg k)))
|
||||
acc))
|
||||
""
|
||||
order)
|
||||
")")))))
|
||||
|
||||
;; ── wire parse (text/sx -> msg-dict) ───────────────────────────────
|
||||
;; parse yields a list with keyword-token keys and possibly keyword-token dict
|
||||
;; keys; sxtp/-normalize deep-converts those tokens to strings so the result is
|
||||
;; the same string-keyed shape the constructors produce.
|
||||
(define sxtp/-normalize
|
||||
(fn (v)
|
||||
(let ((t (type-of v)))
|
||||
(cond
|
||||
((= t "keyword") (str v))
|
||||
((= t "dict")
|
||||
(reduce
|
||||
(fn (acc k) (assoc acc (str k) (sxtp/-normalize (get v k))))
|
||||
{}
|
||||
(keys v)))
|
||||
((= t "list") (map sxtp/-normalize v))
|
||||
(true v)))))
|
||||
(define sxtp/-pairs->dict
|
||||
(fn (kvs acc)
|
||||
(if (< (len kvs) 2)
|
||||
acc
|
||||
(sxtp/-pairs->dict
|
||||
(rest (rest kvs))
|
||||
(assoc acc (str (first kvs)) (sxtp/-normalize (first (rest kvs))))))))
|
||||
(define sxtp/parse
|
||||
(fn (text)
|
||||
(let ((lst (parse text)))
|
||||
(sxtp/-pairs->dict (rest lst) {:msg (symbol->string (first lst))}))))
|
||||
142
lib/host/tests/blog.sx
Normal file
142
lib/host/tests/blog.sx
Normal file
@@ -0,0 +1,142 @@
|
||||
;; lib/host/tests/blog.sx — blog on the editor's content model. Posts are
|
||||
;; {slug,title,sx_content,status} records in the durable KV; a post page is
|
||||
;; render-to-html(parse sx_content). Covers read/render, home index, JSON list,
|
||||
;; slugify, the form-urlencoded editor ingest, and JSON CRUD (auth+ACL guarded).
|
||||
|
||||
(define host-bl-pass 0)
|
||||
(define host-bl-fail 0)
|
||||
(define host-bl-fails (list))
|
||||
(define
|
||||
host-bl-test
|
||||
(fn (name actual expected)
|
||||
(if (= actual expected)
|
||||
(set! host-bl-pass (+ host-bl-pass 1))
|
||||
(begin
|
||||
(set! host-bl-fail (+ host-bl-fail 1))
|
||||
(append! host-bl-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(define host-bl-req (fn (target) (dream-request "GET" target {} "")))
|
||||
(define host-bl-app (host/make-app (list host/feed-routes host/blog-routes)))
|
||||
|
||||
;; ── slugify ─────────────────────────────────────────────────────────
|
||||
(host-bl-test "slugify" (host/blog-slugify "Hello World") "hello-world")
|
||||
(host-bl-test "slugify trims spaces" (host/blog-slugify " A B ") "a-b")
|
||||
|
||||
;; ── render a stored post ────────────────────────────────────────────
|
||||
(host/blog-use-store! (persist/open))
|
||||
(host/blog-put! "hello" "Hello World"
|
||||
"(article (h1 \"Hello World\") (p \"A \" (strong \"bold\") \" word.\"))" "published")
|
||||
|
||||
(host-bl-test "post 200" (dream-status (host-bl-app (host-bl-req "/hello/"))) 200)
|
||||
(host-bl-test "post content-type html"
|
||||
(contains? (dream-resp-header (host-bl-app (host-bl-req "/hello/")) "content-type") "text/html")
|
||||
true)
|
||||
(host-bl-test "post renders sx_content markup"
|
||||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/hello/"))) "<strong>bold</strong>")
|
||||
true)
|
||||
(host-bl-test "post title in page"
|
||||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/hello/"))) "<title>Hello World</title>")
|
||||
true)
|
||||
|
||||
;; ── home + list ─────────────────────────────────────────────────────
|
||||
(host-bl-test "home lists post"
|
||||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/"))) "href=\"/hello/\"")
|
||||
true)
|
||||
(host-bl-test "json list shows post"
|
||||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/posts"))) "\"slug\":\"hello\"")
|
||||
true)
|
||||
(host-bl-test "GET /new shows form"
|
||||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/new"))) "<form")
|
||||
true)
|
||||
|
||||
;; ── unknown + precedence ────────────────────────────────────────────
|
||||
(host-bl-test "unknown slug 404" (dream-status (host-bl-app (host-bl-req "/nope/"))) 404)
|
||||
(feed/reset!)
|
||||
(host-bl-test "/feed not captured by :slug"
|
||||
(contains? (dream-resp-body (host-bl-app (host-bl-req "/feed"))) "\"ok\":true")
|
||||
true)
|
||||
|
||||
;; ── writes: editor form ingest + JSON CRUD (auth+ACL) ───────────────
|
||||
(acl/load! (list (acl-grant "editor" "edit" "blog")))
|
||||
(define host-bl-resolve
|
||||
(fn (tok) (cond ((= tok "good") "editor") ((= tok "weak") "reader") (true nil))))
|
||||
(define host-bl-wapp
|
||||
(host/make-app (list (host/blog-write-routes host-bl-resolve) host/blog-routes)))
|
||||
(define host-bl-send
|
||||
(fn (method target auth ctype body)
|
||||
(dream-request method target
|
||||
(merge (if auth {:authorization auth} {}) (if ctype {:content-type ctype} {})) body)))
|
||||
|
||||
(host/blog-use-store! (persist/open))
|
||||
|
||||
;; -- editor form ingest (form-urlencoded, the editor's submit shape) --
|
||||
(host-bl-test "form ingest no auth -> 401"
|
||||
(dream-status (host-bl-wapp (host-bl-send "POST" "/new" nil
|
||||
"application/x-www-form-urlencoded" "title=X")))
|
||||
401)
|
||||
(host-bl-test "form ingest authed -> 303 redirect"
|
||||
(dream-status (host-bl-wapp (host-bl-send "POST" "/new" "Bearer good"
|
||||
"application/x-www-form-urlencoded"
|
||||
"title=My+First+Post&sx_content=(article+(h1+%22My+First+Post%22)+(p+%22Hi%22))&status=published")))
|
||||
303)
|
||||
(host-bl-test "form ingest set Location to the new slug"
|
||||
(dream-resp-header
|
||||
(host-bl-wapp (host-bl-send "POST" "/new" "Bearer good"
|
||||
"application/x-www-form-urlencoded"
|
||||
"title=Another+One&sx_content=(p+%22x%22)&status=published"))
|
||||
"location")
|
||||
"/another-one/")
|
||||
(host-bl-test "ingested post renders"
|
||||
(contains? (dream-resp-body (host-bl-wapp (host-bl-req "/my-first-post/"))) "<h1>My First Post</h1>")
|
||||
true)
|
||||
|
||||
;; -- JSON CRUD --
|
||||
(host-bl-test "json create -> 201"
|
||||
(dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer good" "application/json"
|
||||
"{\"title\":\"Json Post\",\"sx_content\":\"(p \\\"jp\\\")\",\"status\":\"draft\"}")))
|
||||
201)
|
||||
(host-bl-test "json create unpermitted -> 403"
|
||||
(dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer weak" "application/json"
|
||||
"{\"title\":\"Nope\"}")))
|
||||
403)
|
||||
(host-bl-test "json create duplicate -> 409"
|
||||
(dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer good" "application/json"
|
||||
"{\"slug\":\"json-post\",\"title\":\"Json Post\"}")))
|
||||
409)
|
||||
(host-bl-test "json create no title -> 400"
|
||||
(dream-status (host-bl-wapp (host-bl-send "POST" "/posts" "Bearer good" "application/json" "{}")))
|
||||
400)
|
||||
(host-bl-test "update -> 200"
|
||||
(dream-status (host-bl-wapp (host-bl-send "PUT" "/posts/json-post" "Bearer good" "application/json"
|
||||
"{\"sx_content\":\"(p \\\"edited\\\")\"}")))
|
||||
200)
|
||||
(host-bl-test "update changed content"
|
||||
(contains? (dream-resp-body (host-bl-wapp (host-bl-req "/json-post/"))) "edited")
|
||||
true)
|
||||
(host-bl-test "update missing -> 404"
|
||||
(dream-status (host-bl-wapp (host-bl-send "PUT" "/posts/ghost" "Bearer good" "application/json" "{}")))
|
||||
404)
|
||||
(host-bl-test "delete -> 200"
|
||||
(dream-status (host-bl-wapp (host-bl-send "DELETE" "/posts/json-post" "Bearer good" "" "")))
|
||||
200)
|
||||
(host-bl-test "deleted -> 404" (dream-status (host-bl-wapp (host-bl-req "/json-post/"))) 404)
|
||||
(host-bl-test "delete missing -> 404"
|
||||
(dream-status (host-bl-wapp (host-bl-send "DELETE" "/posts/ghost" "Bearer good" "" "")))
|
||||
404)
|
||||
|
||||
;; -- experimental unguarded create-only route (POST /new, no auth) --
|
||||
(define host-bl-oapp (host/make-app (list host/blog-open-create-routes host/blog-routes)))
|
||||
(host/blog-use-store! (persist/open))
|
||||
(host-bl-test "open create no auth -> 303"
|
||||
(dream-status (host-bl-oapp (host-bl-send "POST" "/new" nil
|
||||
"application/x-www-form-urlencoded" "title=Open+Post&sx_content=(p+%22o%22)&status=published")))
|
||||
303)
|
||||
(host-bl-test "open-created post renders"
|
||||
(contains? (dream-resp-body (host-bl-oapp (host-bl-req "/open-post/"))) "<p>o</p>")
|
||||
true)
|
||||
|
||||
(define
|
||||
host-bl-tests-run!
|
||||
(fn ()
|
||||
{:total (+ host-bl-pass host-bl-fail)
|
||||
:passed host-bl-pass :failed host-bl-fail :fails host-bl-fails}))
|
||||
139
lib/host/tests/feed.sx
Normal file
139
lib/host/tests/feed.sx
Normal file
@@ -0,0 +1,139 @@
|
||||
;; lib/host/tests/feed.sx — the migrated feed endpoints, GET /feed (read) and
|
||||
;; POST /feed (guarded write). Includes a golden test: the host read response
|
||||
;; body must equal the feed subsystem's own recent-first stream wrapped in the
|
||||
;; standard envelope — the endpoint adds the HTTP/JSON shell and nothing else.
|
||||
|
||||
(define host-fd-pass 0)
|
||||
(define host-fd-fail 0)
|
||||
(define host-fd-fails (list))
|
||||
|
||||
(define
|
||||
host-fd-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! host-fd-pass (+ host-fd-pass 1))
|
||||
(begin
|
||||
(set! host-fd-fail (+ host-fd-fail 1))
|
||||
(append! host-fd-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(define
|
||||
host-fd-req
|
||||
(fn (target) (dream-request "GET" target {} "")))
|
||||
|
||||
(define
|
||||
host-fd-app
|
||||
(host/make-app (list host/feed-routes)))
|
||||
|
||||
;; ── empty feed ─────────────────────────────────────────────────────
|
||||
(feed/reset!)
|
||||
(host-fd-test
|
||||
"empty feed 200"
|
||||
(dream-status (host-fd-app (host-fd-req "/feed")))
|
||||
200)
|
||||
(host-fd-test
|
||||
"empty feed data:[]"
|
||||
(contains? (dream-resp-body (host-fd-app (host-fd-req "/feed"))) "\"data\":[]")
|
||||
true)
|
||||
|
||||
;; ── seeded feed ────────────────────────────────────────────────────
|
||||
(feed/reset!)
|
||||
(feed/post {:actor "alice" :verb "post" :object "p1" :at 1})
|
||||
(feed/post {:actor "bob" :verb "post" :object "p2" :at 2})
|
||||
(feed/post {:actor "alice" :verb "like" :object "p2" :at 3})
|
||||
|
||||
;; recent-first: newest activity (at 3) leads, so its marker precedes the oldest.
|
||||
(host-fd-test
|
||||
"timeline recent-first"
|
||||
(let ((body (dream-resp-body (host-fd-app (host-fd-req "/feed")))))
|
||||
(< (index-of body "\"at\":3") (index-of body "\"at\":1")))
|
||||
true)
|
||||
|
||||
;; actor filter: only alice's two activities.
|
||||
(host-fd-test
|
||||
"actor filter count"
|
||||
(feed/count
|
||||
(feed/by-actor (feed/recent (feed/all)) "alice"))
|
||||
2)
|
||||
(host-fd-test
|
||||
"actor filter excludes bob"
|
||||
(contains?
|
||||
(dream-resp-body (host-fd-app (host-fd-req "/feed?actor=alice")))
|
||||
"bob")
|
||||
false)
|
||||
|
||||
;; limit: cap to a single activity (the most recent).
|
||||
(host-fd-test
|
||||
"limit caps results"
|
||||
(contains?
|
||||
(dream-resp-body (host-fd-app (host-fd-req "/feed?limit=1")))
|
||||
"\"at\":1")
|
||||
false)
|
||||
|
||||
;; ── golden: endpoint = subsystem recent stream + envelope ───────────
|
||||
(host-fd-test
|
||||
"golden full timeline"
|
||||
(dream-resp-body (host-fd-app (host-fd-req "/feed")))
|
||||
(str
|
||||
"{\"ok\":true,\"data\":"
|
||||
(dream-json-encode (feed/items (feed/recent (feed/all))))
|
||||
"}"))
|
||||
(host-fd-test
|
||||
"golden actor-filtered"
|
||||
(dream-resp-body (host-fd-app (host-fd-req "/feed?actor=alice")))
|
||||
(str
|
||||
"{\"ok\":true,\"data\":"
|
||||
(dream-json-encode
|
||||
(feed/items (feed/by-actor (feed/recent (feed/all)) "alice")))
|
||||
"}"))
|
||||
|
||||
;; ── write: POST /feed (auth + ACL + action) ────────────────────────
|
||||
(acl/load! (list (acl-grant "alice" "post" "feed")))
|
||||
(define host-fd-resolve (fn (tok) (if (= tok "good") "alice" nil)))
|
||||
(define
|
||||
host-fd-wapp
|
||||
(host/make-app
|
||||
(list host/feed-routes (host/feed-write-routes host-fd-resolve))))
|
||||
(define
|
||||
host-fd-post
|
||||
(fn (auth body)
|
||||
(dream-request "POST" "/feed" (if auth {:authorization auth} {}) body)))
|
||||
|
||||
(feed/reset!)
|
||||
(host-fd-test
|
||||
"post no auth -> 401"
|
||||
(dream-status (host-fd-wapp (host-fd-post nil "{}")))
|
||||
401)
|
||||
(host-fd-test
|
||||
"post unchanged feed after 401"
|
||||
(feed/size)
|
||||
0)
|
||||
(host-fd-test
|
||||
"post authed+permitted -> 201"
|
||||
(dream-status
|
||||
(host-fd-wapp
|
||||
(host-fd-post
|
||||
"Bearer good"
|
||||
"{\"actor\":\"alice\",\"verb\":\"post\",\"object\":\"p9\",\"at\":9}")))
|
||||
201)
|
||||
(host-fd-test "post grew feed" (feed/size) 1)
|
||||
(host-fd-test
|
||||
"created activity visible in timeline"
|
||||
(contains?
|
||||
(dream-resp-body (host-fd-wapp (host-fd-req "/feed")))
|
||||
"p9")
|
||||
true)
|
||||
(host-fd-test
|
||||
"post non-object body -> 400"
|
||||
(dream-status (host-fd-wapp (host-fd-post "Bearer good" "[1,2]")))
|
||||
400)
|
||||
|
||||
(define
|
||||
host-fd-tests-run!
|
||||
(fn
|
||||
()
|
||||
{:total (+ host-fd-pass host-fd-fail)
|
||||
:passed host-fd-pass
|
||||
:failed host-fd-fail
|
||||
:fails host-fd-fails}))
|
||||
86
lib/host/tests/handler.sx
Normal file
86
lib/host/tests/handler.sx
Normal file
@@ -0,0 +1,86 @@
|
||||
;; lib/host/tests/handler.sx — host JSON envelope + request-reading helpers.
|
||||
|
||||
(define host-hd-pass 0)
|
||||
(define host-hd-fail 0)
|
||||
(define host-hd-fails (list))
|
||||
|
||||
(define
|
||||
host-hd-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! host-hd-pass (+ host-hd-pass 1))
|
||||
(begin
|
||||
(set! host-hd-fail (+ host-hd-fail 1))
|
||||
(append! host-hd-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── host/ok ────────────────────────────────────────────────────────
|
||||
(host-hd-test "ok status 200" (dream-status (host/ok "x")) 200)
|
||||
(host-hd-test
|
||||
"ok content-type json"
|
||||
(dream-resp-header (host/ok "x") "content-type")
|
||||
"application/json")
|
||||
(host-hd-test
|
||||
"ok envelope ok:true"
|
||||
(contains? (dream-resp-body (host/ok "x")) "\"ok\":true")
|
||||
true)
|
||||
(host-hd-test
|
||||
"ok envelope carries data"
|
||||
(contains? (dream-resp-body (host/ok "hi")) "\"data\":\"hi\"")
|
||||
true)
|
||||
|
||||
;; ── host/ok-status ─────────────────────────────────────────────────
|
||||
(host-hd-test "ok-status custom" (dream-status (host/ok-status 201 "y")) 201)
|
||||
(host-hd-test
|
||||
"ok-status data"
|
||||
(contains? (dream-resp-body (host/ok-status 201 "y")) "\"data\":\"y\"")
|
||||
true)
|
||||
|
||||
;; ── host/error ─────────────────────────────────────────────────────
|
||||
(host-hd-test "error status" (dream-status (host/error 404 "nope")) 404)
|
||||
(host-hd-test
|
||||
"error ok:false"
|
||||
(contains? (dream-resp-body (host/error 404 "nope")) "\"ok\":false")
|
||||
true)
|
||||
(host-hd-test
|
||||
"error message"
|
||||
(contains? (dream-resp-body (host/error 404 "nope")) "\"error\":\"nope\"")
|
||||
true)
|
||||
(host-hd-test
|
||||
"error content-type json"
|
||||
(dream-resp-header (host/error 500 "boom") "content-type")
|
||||
"application/json")
|
||||
|
||||
;; ── host/json-status ───────────────────────────────────────────────
|
||||
(host-hd-test
|
||||
"json-status arbitrary status"
|
||||
(dream-status (host/json-status 418 {:a 1}))
|
||||
418)
|
||||
(host-hd-test
|
||||
"json-status encodes body"
|
||||
(contains? (dream-resp-body (host/json-status 200 {:a 1})) "\"a\":1")
|
||||
true)
|
||||
|
||||
;; ── host/query-int ─────────────────────────────────────────────────
|
||||
(define
|
||||
host-hd-req
|
||||
(fn (target) (dream-request "GET" target {} "")))
|
||||
|
||||
(host-hd-test
|
||||
"query-int present"
|
||||
(host/query-int (host-hd-req "/x?limit=5") "limit" 10)
|
||||
5)
|
||||
(host-hd-test
|
||||
"query-int absent -> fallback"
|
||||
(host/query-int (host-hd-req "/x") "limit" 10)
|
||||
10)
|
||||
|
||||
(define
|
||||
host-hd-tests-run!
|
||||
(fn
|
||||
()
|
||||
{:total (+ host-hd-pass host-hd-fail)
|
||||
:passed host-hd-pass
|
||||
:failed host-hd-fail
|
||||
:fails host-hd-fails}))
|
||||
106
lib/host/tests/ledger.sx
Normal file
106
lib/host/tests/ledger.sx
Normal file
@@ -0,0 +1,106 @@
|
||||
;; lib/host/tests/ledger.sx — the strangler migration ledger: entry shape,
|
||||
;; status/domain queries, find, distinct domains, and coverage maths.
|
||||
|
||||
(define host-lg-pass 0)
|
||||
(define host-lg-fail 0)
|
||||
(define host-lg-fails (list))
|
||||
|
||||
(define
|
||||
host-lg-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! host-lg-pass (+ host-lg-pass 1))
|
||||
(begin
|
||||
(set! host-lg-fail (+ host-lg-fail 1))
|
||||
(append! host-lg-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── entry constructor ───────────────────────────────────────────────
|
||||
(define host-lg-e (host/ledger-entry "feed" "GET" "/feed" "feed:timeline" "migrated" "host/feed-timeline"))
|
||||
(host-lg-test "entry domain" (get host-lg-e :domain) "feed")
|
||||
(host-lg-test "entry path" (get host-lg-e :path) "/feed")
|
||||
(host-lg-test "entry status" (get host-lg-e :status) "migrated")
|
||||
(host-lg-test "entry handler" (get host-lg-e :handler) "host/feed-timeline")
|
||||
|
||||
;; ── find ────────────────────────────────────────────────────────────
|
||||
(host-lg-test
|
||||
"find GET /feed -> migrated"
|
||||
(get (host/ledger-find host/ledger "GET" "/feed") :status)
|
||||
"migrated")
|
||||
(host-lg-test
|
||||
"find GET /feed -> handler"
|
||||
(get (host/ledger-find host/ledger "GET" "/feed") :handler)
|
||||
"host/feed-timeline")
|
||||
(host-lg-test
|
||||
"find POST /feed -> create"
|
||||
(get (host/ledger-find host/ledger "POST" "/feed") :handler)
|
||||
"host/feed-create")
|
||||
(host-lg-test "find missing -> nil" (host/ledger-find host/ledger "GET" "/nope") nil)
|
||||
(host-lg-test
|
||||
"find migrated relations read -> handler"
|
||||
(get (host/ledger-find host/ledger "GET" "/internal/data/get-children") :handler)
|
||||
"host/relations-children")
|
||||
(host-lg-test
|
||||
"find migrated relations write -> handler"
|
||||
(get (host/ledger-find host/ledger "POST" "/internal/actions/attach-child") :handler)
|
||||
"host/relations-attach")
|
||||
(host-lg-test
|
||||
"typed relate still proxied"
|
||||
(get (host/ledger-find host/ledger "POST" "/internal/actions/relate") :status)
|
||||
"proxied")
|
||||
|
||||
(host-lg-test
|
||||
"find migrated blog post -> handler"
|
||||
(get (host/ledger-find host/ledger "GET" "/:slug") :handler)
|
||||
"host/blog-post")
|
||||
|
||||
;; ── status queries ──────────────────────────────────────────────────
|
||||
(host-lg-test "migrated count" (len (host/ledger-migrated host/ledger)) 7)
|
||||
(host-lg-test "native count" (len (host/ledger-native host/ledger)) 1)
|
||||
(host-lg-test "proxied count" (len (host/ledger-proxied host/ledger)) 7)
|
||||
|
||||
;; ── served? predicate ───────────────────────────────────────────────
|
||||
(host-lg-test
|
||||
"served? migrated"
|
||||
(host/ledger-served? (host/ledger-find host/ledger "GET" "/feed"))
|
||||
true)
|
||||
(host-lg-test
|
||||
"served? native"
|
||||
(host/ledger-served? (host/ledger-find host/ledger "GET" "/health"))
|
||||
true)
|
||||
(host-lg-test
|
||||
"served? proxied false"
|
||||
(host/ledger-served? (host/ledger-find host/ledger "POST" "/internal/actions/relate"))
|
||||
false)
|
||||
|
||||
;; ── domain queries ──────────────────────────────────────────────────
|
||||
(host-lg-test "relations domain count" (len (host/ledger-by-domain host/ledger "relations")) 7)
|
||||
(host-lg-test "likes domain count" (len (host/ledger-by-domain host/ledger "likes")) 4)
|
||||
(host-lg-test "domains count" (len (host/ledger-domains host/ledger)) 5)
|
||||
(host-lg-test
|
||||
"domains has relations"
|
||||
(some (fn (d) (= d "relations")) (host/ledger-domains host/ledger))
|
||||
true)
|
||||
(host-lg-test
|
||||
"domains has feed"
|
||||
(some (fn (d) (= d "feed")) (host/ledger-domains host/ledger))
|
||||
true)
|
||||
|
||||
;; ── coverage ────────────────────────────────────────────────────────
|
||||
(define host-lg-cov (host/ledger-coverage host/ledger))
|
||||
(host-lg-test "coverage total" (get host-lg-cov :total) 15)
|
||||
(host-lg-test "coverage migrated" (get host-lg-cov :migrated) 7)
|
||||
(host-lg-test "coverage proxied" (get host-lg-cov :proxied) 7)
|
||||
(host-lg-test "coverage native" (get host-lg-cov :native) 1)
|
||||
(host-lg-test "coverage served" (get host-lg-cov :served) 8)
|
||||
(host-lg-test "coverage percent" (get host-lg-cov :percent) 53)
|
||||
|
||||
(define
|
||||
host-lg-tests-run!
|
||||
(fn
|
||||
()
|
||||
{:total (+ host-lg-pass host-lg-fail)
|
||||
:passed host-lg-pass
|
||||
:failed host-lg-fail
|
||||
:fails host-lg-fails}))
|
||||
107
lib/host/tests/middleware.sx
Normal file
107
lib/host/tests/middleware.sx
Normal file
@@ -0,0 +1,107 @@
|
||||
;; lib/host/tests/middleware.sx — auth (bearer -> principal), ACL gate, and error
|
||||
;; trapping, composed via host/pipeline. ACL facts: alice may "post" on "feed".
|
||||
|
||||
(define host-mw-pass 0)
|
||||
(define host-mw-fail 0)
|
||||
(define host-mw-fails (list))
|
||||
|
||||
(define
|
||||
host-mw-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! host-mw-pass (+ host-mw-pass 1))
|
||||
(begin
|
||||
(set! host-mw-fail (+ host-mw-fail 1))
|
||||
(append! host-mw-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── fixtures ───────────────────────────────────────────────────────
|
||||
(acl/load! (list (acl-grant "alice" "post" "feed")))
|
||||
|
||||
(define host-mw-resolve
|
||||
(fn (tok) (if (= tok "good") "alice" nil)))
|
||||
|
||||
(define host-mw-handler
|
||||
(fn (req) (host/ok-status 201 (host/principal req))))
|
||||
|
||||
;; protected: needs auth + post/feed permission
|
||||
(define host-mw-protected
|
||||
(host/pipeline
|
||||
(list
|
||||
(host/require-auth host-mw-resolve)
|
||||
(host/require-permission "post" (fn (req) "feed")))
|
||||
host-mw-handler))
|
||||
|
||||
;; protected with an action alice is NOT granted
|
||||
(define host-mw-protected-del
|
||||
(host/pipeline
|
||||
(list
|
||||
(host/require-auth host-mw-resolve)
|
||||
(host/require-permission "delete" (fn (req) "feed")))
|
||||
host-mw-handler))
|
||||
|
||||
(define
|
||||
host-mw-req
|
||||
(fn (auth)
|
||||
(dream-request "POST" "/feed"
|
||||
(if auth {:authorization auth} {})
|
||||
"")))
|
||||
|
||||
;; ── auth ───────────────────────────────────────────────────────────
|
||||
(host-mw-test
|
||||
"no token -> 401"
|
||||
(dream-status (host-mw-protected (host-mw-req nil)))
|
||||
401)
|
||||
(host-mw-test
|
||||
"401 has www-authenticate"
|
||||
(dream-resp-header (host-mw-protected (host-mw-req nil)) "www-authenticate")
|
||||
"Bearer")
|
||||
(host-mw-test
|
||||
"bad token -> 401"
|
||||
(dream-status (host-mw-protected (host-mw-req "Bearer wrong")))
|
||||
401)
|
||||
|
||||
;; ── authz ──────────────────────────────────────────────────────────
|
||||
(host-mw-test
|
||||
"authed + permitted -> 201"
|
||||
(dream-status (host-mw-protected (host-mw-req "Bearer good")))
|
||||
201)
|
||||
(host-mw-test
|
||||
"principal threaded to handler"
|
||||
(contains?
|
||||
(dream-resp-body (host-mw-protected (host-mw-req "Bearer good")))
|
||||
"\"data\":\"alice\"")
|
||||
true)
|
||||
(host-mw-test
|
||||
"authed but not permitted -> 403"
|
||||
(dream-status (host-mw-protected-del (host-mw-req "Bearer good")))
|
||||
403)
|
||||
(host-mw-test
|
||||
"403 envelope"
|
||||
(contains?
|
||||
(dream-resp-body (host-mw-protected-del (host-mw-req "Bearer good")))
|
||||
"\"error\":\"forbidden\"")
|
||||
true)
|
||||
|
||||
;; ── error trapping ─────────────────────────────────────────────────
|
||||
(define host-mw-boom (fn (req) (error "kaboom")))
|
||||
(host-mw-test
|
||||
"wrap-errors -> 500"
|
||||
(dream-status ((host/wrap-errors host-mw-boom) (host-mw-req nil)))
|
||||
500)
|
||||
(host-mw-test
|
||||
"500 envelope"
|
||||
(contains?
|
||||
(dream-resp-body ((host/wrap-errors host-mw-boom) (host-mw-req nil)))
|
||||
"\"ok\":false")
|
||||
true)
|
||||
|
||||
(define
|
||||
host-mw-tests-run!
|
||||
(fn
|
||||
()
|
||||
{:total (+ host-mw-pass host-mw-fail)
|
||||
:passed host-mw-pass
|
||||
:failed host-mw-fail
|
||||
:fails host-mw-fails}))
|
||||
60
lib/host/tests/page.sx
Normal file
60
lib/host/tests/page.sx
Normal file
@@ -0,0 +1,60 @@
|
||||
;; lib/host/tests/page.sx — the host's interactive-SX-page capability (Phase 5.1).
|
||||
;; A defcomp component tree (with keyword attributes + nesting) renders to correct
|
||||
;; HTML through host/page / render-page, served by a host route. This is the
|
||||
;; capability the legacy editor (and any future island UI) needs — proven on a
|
||||
;; small component so it's not editor-specific.
|
||||
|
||||
(define host-pg-pass 0)
|
||||
(define host-pg-fail 0)
|
||||
(define host-pg-fails (list))
|
||||
(define
|
||||
host-pg-test
|
||||
(fn (name actual expected)
|
||||
(if (= actual expected)
|
||||
(set! host-pg-pass (+ host-pg-pass 1))
|
||||
(begin
|
||||
(set! host-pg-fail (+ host-pg-fail 1))
|
||||
(append! host-pg-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; A component with keyword attributes (the case bare render-to-html mangles) and
|
||||
;; a nested component (expansion must recurse).
|
||||
(defcomp ~pg-badge (&key (label :as string))
|
||||
(span :class "badge" :data-kind "tag" label))
|
||||
(defcomp ~pg-card (&key (title :as string))
|
||||
(div :class "card"
|
||||
(h2 :class "card-title" title)
|
||||
(~pg-badge :label "new")))
|
||||
|
||||
(define host-pg-req (fn (target) (dream-request "GET" target {} "")))
|
||||
(define host-pg-app
|
||||
(host/make-app (list (list (host/page-route "/card" (quote (~pg-card :title "Hello")))))))
|
||||
|
||||
(define host-pg-body (dream-resp-body (host-pg-app (host-pg-req "/card"))))
|
||||
|
||||
(host-pg-test "page 200"
|
||||
(dream-status (host-pg-app (host-pg-req "/card"))) 200)
|
||||
(host-pg-test "page is html"
|
||||
(contains? (dream-resp-header (host-pg-app (host-pg-req "/card")) "content-type") "text/html")
|
||||
true)
|
||||
;; attributes survive (the whole point) — class on the outer div
|
||||
(host-pg-test "outer div class attr"
|
||||
(contains? host-pg-body "class=\"card\"") true)
|
||||
;; nested component expanded + its attrs survive
|
||||
(host-pg-test "nested component expanded"
|
||||
(contains? host-pg-body "class=\"badge\"") true)
|
||||
(host-pg-test "nested data attr"
|
||||
(contains? host-pg-body "data-kind=\"tag\"") true)
|
||||
;; keyword param values rendered as text content, not attrs
|
||||
(host-pg-test "title text rendered"
|
||||
(contains? host-pg-body "Hello") true)
|
||||
(host-pg-test "badge label text rendered"
|
||||
(contains? host-pg-body ">new<") true)
|
||||
;; NOT mangled — the keyword ":class" must not leak as text content
|
||||
(host-pg-test "no mangled keyword text"
|
||||
(contains? host-pg-body ">classcard") false)
|
||||
|
||||
(define
|
||||
host-pg-tests-run!
|
||||
(fn ()
|
||||
{:total (+ host-pg-pass host-pg-fail)
|
||||
:passed host-pg-pass :failed host-pg-fail :fails host-pg-fails}))
|
||||
180
lib/host/tests/relations.sx
Normal file
180
lib/host/tests/relations.sx
Normal file
@@ -0,0 +1,180 @@
|
||||
;; lib/host/tests/relations.sx — the migrated relations read endpoints,
|
||||
;; GET /internal/data/get-children and /get-parents, dispatching to lib/relations.
|
||||
;; Golden tests pin each endpoint to "subsystem call + standard envelope": the
|
||||
;; host adds the HTTP/JSON shell over relations/children|parents and nothing else
|
||||
;; (golden derived from the same subsystem call, so result order matches).
|
||||
|
||||
(define host-rl-pass 0)
|
||||
(define host-rl-fail 0)
|
||||
(define host-rl-fails (list))
|
||||
|
||||
(define
|
||||
host-rl-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! host-rl-pass (+ host-rl-pass 1))
|
||||
(begin
|
||||
(set! host-rl-fail (+ host-rl-fail 1))
|
||||
(append! host-rl-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(define host-rl-req (fn (target) (dream-request "GET" target {} "")))
|
||||
(define host-rl-app (host/make-app (list host/relations-routes)))
|
||||
(define host-rl-sym (fn (s) (string->symbol s)))
|
||||
|
||||
;; ── seed a known graph ──────────────────────────────────────────────
|
||||
;; org:1 --member--> list:7, list:8 ; org:1 --owner--> page:9
|
||||
(relations/load! (list))
|
||||
(relations/relate (host-rl-sym "org:1") (host-rl-sym "list:7") (host-rl-sym "member"))
|
||||
(relations/relate (host-rl-sym "org:1") (host-rl-sym "list:8") (host-rl-sym "member"))
|
||||
(relations/relate (host-rl-sym "org:1") (host-rl-sym "page:9") (host-rl-sym "owner"))
|
||||
|
||||
;; ── get-children ────────────────────────────────────────────────────
|
||||
(define host-rl-kids
|
||||
"/internal/data/get-children?parent-type=org&parent-id=1&relation-type=member")
|
||||
(host-rl-test "children 200" (dream-status (host-rl-app (host-rl-req host-rl-kids))) 200)
|
||||
(host-rl-test
|
||||
"children has list:7"
|
||||
(contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-kids))) "list:7")
|
||||
true)
|
||||
(host-rl-test
|
||||
"children has list:8"
|
||||
(contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-kids))) "list:8")
|
||||
true)
|
||||
(host-rl-test
|
||||
"children excludes other-kind page:9"
|
||||
(contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-kids))) "page:9")
|
||||
false)
|
||||
(host-rl-test
|
||||
"children count via subsystem"
|
||||
(len (relations/children (host-rl-sym "org:1") (host-rl-sym "member")))
|
||||
2)
|
||||
|
||||
;; child-type filter narrows by node prefix.
|
||||
(host-rl-test
|
||||
"children child-type=list keeps both"
|
||||
(contains?
|
||||
(dream-resp-body (host-rl-app (host-rl-req (str host-rl-kids "&child-type=list"))))
|
||||
"list:8")
|
||||
true)
|
||||
(host-rl-test
|
||||
"children child-type=page filters all out"
|
||||
(contains?
|
||||
(dream-resp-body (host-rl-app (host-rl-req (str host-rl-kids "&child-type=page"))))
|
||||
"list:7")
|
||||
false)
|
||||
|
||||
;; ── get-parents ─────────────────────────────────────────────────────
|
||||
(define host-rl-par
|
||||
"/internal/data/get-parents?child-type=list&child-id=7&relation-type=member")
|
||||
(host-rl-test "parents 200" (dream-status (host-rl-app (host-rl-req host-rl-par))) 200)
|
||||
(host-rl-test
|
||||
"parents has org:1"
|
||||
(contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-par))) "org:1")
|
||||
true)
|
||||
|
||||
;; ── missing required params -> 400 ──────────────────────────────────
|
||||
(host-rl-test
|
||||
"children missing param -> 400"
|
||||
(dream-status (host-rl-app (host-rl-req "/internal/data/get-children?parent-type=org")))
|
||||
400)
|
||||
(host-rl-test
|
||||
"parents missing param -> 400"
|
||||
(dream-status (host-rl-app (host-rl-req "/internal/data/get-parents?child-type=list")))
|
||||
400)
|
||||
|
||||
;; ── golden: endpoint = subsystem call + envelope ────────────────────
|
||||
(host-rl-test
|
||||
"golden children"
|
||||
(dream-resp-body (host-rl-app (host-rl-req host-rl-kids)))
|
||||
(str
|
||||
"{\"ok\":true,\"data\":"
|
||||
(dream-json-encode
|
||||
(host/-rel-strings (relations/children (host-rl-sym "org:1") (host-rl-sym "member"))))
|
||||
"}"))
|
||||
(host-rl-test
|
||||
"golden parents"
|
||||
(dream-resp-body (host-rl-app (host-rl-req host-rl-par)))
|
||||
(str
|
||||
"{\"ok\":true,\"data\":"
|
||||
(dream-json-encode
|
||||
(host/-rel-strings (relations/parents (host-rl-sym "list:7") (host-rl-sym "member"))))
|
||||
"}"))
|
||||
|
||||
;; ── writes: attach-child / detach-child (auth + ACL + closed loop) ──
|
||||
(acl/load!
|
||||
(list
|
||||
(acl-grant "carol" "relate" "relations")
|
||||
(acl-grant "carol" "unrelate" "relations")))
|
||||
;; carol is permitted; dave authenticates but has no grant.
|
||||
(define host-rl-resolve
|
||||
(fn (tok)
|
||||
(cond ((= tok "good") "carol") ((= tok "weak") "dave") (true nil))))
|
||||
(define host-rl-wapp
|
||||
(host/make-app
|
||||
(list host/relations-routes (host/relations-write-routes host-rl-resolve))))
|
||||
(define host-rl-post
|
||||
(fn (action auth body)
|
||||
(dream-request "POST" (str "/internal/actions/" action)
|
||||
(if auth {:authorization auth} {}) body)))
|
||||
(define host-rl-edge
|
||||
"{\"parent-type\":\"org\",\"parent-id\":\"2\",\"child-type\":\"list\",\"child-id\":\"5\",\"relation-type\":\"member\"}")
|
||||
(define host-rl-org2
|
||||
"/internal/data/get-children?parent-type=org&parent-id=2&relation-type=member")
|
||||
|
||||
(relations/load! (list))
|
||||
|
||||
;; auth gate
|
||||
(host-rl-test
|
||||
"attach no auth -> 401"
|
||||
(dream-status (host-rl-wapp (host-rl-post "attach-child" nil "{}")))
|
||||
401)
|
||||
(host-rl-test
|
||||
"attach authed-but-unpermitted -> 403"
|
||||
(dream-status (host-rl-wapp (host-rl-post "attach-child" "Bearer weak" host-rl-edge)))
|
||||
403)
|
||||
(host-rl-test
|
||||
"graph unchanged after 403"
|
||||
(len (relations/children (host-rl-sym "org:2") (host-rl-sym "member")))
|
||||
0)
|
||||
|
||||
;; permitted attach -> 201, and visible through the migrated read
|
||||
(host-rl-test
|
||||
"attach authed+permitted -> 201"
|
||||
(dream-status (host-rl-wapp (host-rl-post "attach-child" "Bearer good" host-rl-edge)))
|
||||
201)
|
||||
(host-rl-test
|
||||
"attached edge visible via get-children"
|
||||
(contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-org2))) "list:5")
|
||||
true)
|
||||
|
||||
;; detach -> 200, and gone from the read
|
||||
(host-rl-test
|
||||
"detach authed+permitted -> 200"
|
||||
(dream-status (host-rl-wapp (host-rl-post "detach-child" "Bearer good" host-rl-edge)))
|
||||
200)
|
||||
(host-rl-test
|
||||
"detached edge gone from get-children"
|
||||
(contains? (dream-resp-body (host-rl-app (host-rl-req host-rl-org2))) "list:5")
|
||||
false)
|
||||
|
||||
;; bad payloads
|
||||
(host-rl-test
|
||||
"attach non-object body -> 400"
|
||||
(dream-status (host-rl-wapp (host-rl-post "attach-child" "Bearer good" "[1,2]")))
|
||||
400)
|
||||
(host-rl-test
|
||||
"attach missing param -> 400"
|
||||
(dream-status
|
||||
(host-rl-wapp (host-rl-post "attach-child" "Bearer good" "{\"parent-type\":\"org\"}")))
|
||||
400)
|
||||
|
||||
(define
|
||||
host-rl-tests-run!
|
||||
(fn
|
||||
()
|
||||
{:total (+ host-rl-pass host-rl-fail)
|
||||
:passed host-rl-pass
|
||||
:failed host-rl-fail
|
||||
:fails host-rl-fails}))
|
||||
75
lib/host/tests/router.sx
Normal file
75
lib/host/tests/router.sx
Normal file
@@ -0,0 +1,75 @@
|
||||
;; lib/host/tests/router.sx — host app assembly: health endpoint, group mounting,
|
||||
;; 404 fallback.
|
||||
|
||||
(define host-rt-pass 0)
|
||||
(define host-rt-fail 0)
|
||||
(define host-rt-fails (list))
|
||||
|
||||
(define
|
||||
host-rt-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! host-rt-pass (+ host-rt-pass 1))
|
||||
(begin
|
||||
(set! host-rt-fail (+ host-rt-fail 1))
|
||||
(append! host-rt-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(define
|
||||
host-rt-req
|
||||
(fn (method target) (dream-request method target {} "")))
|
||||
|
||||
;; An app built from one domain group of two routes.
|
||||
(define
|
||||
host-rt-app
|
||||
(host/make-app
|
||||
(list
|
||||
(list
|
||||
(dream-get "/ping" (fn (req) (host/ok "pong")))
|
||||
(dream-get "/widgets/:id" (fn (req) (host/ok (dream-param req "id"))))))))
|
||||
|
||||
;; ── health ─────────────────────────────────────────────────────────
|
||||
(host-rt-test
|
||||
"health status 200"
|
||||
(dream-status (host-rt-app (host-rt-req "GET" "/health")))
|
||||
200)
|
||||
(host-rt-test
|
||||
"health body healthy"
|
||||
(contains?
|
||||
(dream-resp-body (host-rt-app (host-rt-req "GET" "/health")))
|
||||
"healthy")
|
||||
true)
|
||||
|
||||
;; ── group routes mounted ───────────────────────────────────────────
|
||||
(host-rt-test
|
||||
"group route ping"
|
||||
(contains?
|
||||
(dream-resp-body (host-rt-app (host-rt-req "GET" "/ping")))
|
||||
"pong")
|
||||
true)
|
||||
(host-rt-test
|
||||
"group path param"
|
||||
(contains?
|
||||
(dream-resp-body (host-rt-app (host-rt-req "GET" "/widgets/42")))
|
||||
"\"data\":\"42\"")
|
||||
true)
|
||||
|
||||
;; ── fallback ───────────────────────────────────────────────────────
|
||||
(host-rt-test
|
||||
"unknown path 404"
|
||||
(dream-status (host-rt-app (host-rt-req "GET" "/nope")))
|
||||
404)
|
||||
(host-rt-test
|
||||
"wrong method 405"
|
||||
(dream-status (host-rt-app (host-rt-req "POST" "/ping")))
|
||||
405)
|
||||
|
||||
(define
|
||||
host-rt-tests-run!
|
||||
(fn
|
||||
()
|
||||
{:total (+ host-rt-pass host-rt-fail)
|
||||
:passed host-rt-pass
|
||||
:failed host-rt-fail
|
||||
:fails host-rt-fails}))
|
||||
88
lib/host/tests/server.sx
Normal file
88
lib/host/tests/server.sx
Normal file
@@ -0,0 +1,88 @@
|
||||
;; lib/host/tests/server.sx — the native<->dream bridge. Pure-function coverage of
|
||||
;; host/-native->dream, host/-dream->native, and the host/native-handler adapter
|
||||
;; over a real host app (no socket — the http-listen call itself is exercised live
|
||||
;; via lib/host/serve.sx, not here).
|
||||
|
||||
(define host-sv-pass 0)
|
||||
(define host-sv-fail 0)
|
||||
(define host-sv-fails (list))
|
||||
|
||||
(define
|
||||
host-sv-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! host-sv-pass (+ host-sv-pass 1))
|
||||
(begin
|
||||
(set! host-sv-fail (+ host-sv-fail 1))
|
||||
(append! host-sv-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
(define host-sv-native
|
||||
(fn (method path query body)
|
||||
{"method" method "path" path "query" query "body" body "headers" {}}))
|
||||
|
||||
;; ── native request -> dream request ─────────────────────────────────
|
||||
(define host-sv-dreq (host/-native->dream (host-sv-native "post" "/feed" "actor=alice" "hi")))
|
||||
(host-sv-test "n->d method upcased" (get host-sv-dreq :method) "POST")
|
||||
(host-sv-test "n->d path" (get host-sv-dreq :path) "/feed")
|
||||
(host-sv-test "n->d query param" (dream-query-param host-sv-dreq "actor") "alice")
|
||||
(host-sv-test "n->d body" (get host-sv-dreq :body) "hi")
|
||||
;; empty query -> bare path, no trailing "?"
|
||||
(host-sv-test
|
||||
"n->d empty query -> bare path"
|
||||
(get (host/-native->dream (host-sv-native "GET" "/health" "" "")) :path)
|
||||
"/health")
|
||||
|
||||
;; ── dream response -> native response ───────────────────────────────
|
||||
(define host-sv-nresp
|
||||
(host/-dream->native (dream-response 201 {:content-type "application/json"} "{}")))
|
||||
(host-sv-test "d->n status" (get host-sv-nresp :status) 201)
|
||||
(host-sv-test "d->n body" (get host-sv-nresp :body) "{}")
|
||||
(host-sv-test "d->n headers is dict" (= (type-of (get host-sv-nresp :headers)) "dict") true)
|
||||
|
||||
;; ── adapter over a real host app ────────────────────────────────────
|
||||
(feed/reset!)
|
||||
(define host-sv-app (host/native-handler (host/make-app (list host/feed-routes))))
|
||||
(host-sv-test
|
||||
"health -> 200"
|
||||
(get (host-sv-app (host-sv-native "GET" "/health" "" "")) :status)
|
||||
200)
|
||||
(host-sv-test
|
||||
"health body healthy"
|
||||
(contains? (get (host-sv-app (host-sv-native "GET" "/health" "" "")) :body) "healthy")
|
||||
true)
|
||||
(host-sv-test
|
||||
"feed read -> 200"
|
||||
(get (host-sv-app (host-sv-native "GET" "/feed" "" "")) :status)
|
||||
200)
|
||||
;; native response shape is exactly {:status :headers :body}
|
||||
(host-sv-test
|
||||
"native resp keys"
|
||||
(let ((r (host-sv-app (host-sv-native "GET" "/health" "" ""))))
|
||||
(and (has-key? r :status) (has-key? r :headers) (has-key? r :body)))
|
||||
true)
|
||||
|
||||
;; ── relations read through the bridge (end-to-end shape) ────────────
|
||||
(relations/load! (list))
|
||||
(relations/relate (string->symbol "org:1") (string->symbol "list:7") (string->symbol "member"))
|
||||
(define host-sv-rapp (host/native-handler (host/make-app (list host/relations-routes))))
|
||||
(host-sv-test
|
||||
"relations read via bridge"
|
||||
(contains?
|
||||
(get
|
||||
(host-sv-rapp
|
||||
(host-sv-native "GET" "/internal/data/get-children"
|
||||
"parent-type=org&parent-id=1&relation-type=member" ""))
|
||||
:body)
|
||||
"list:7")
|
||||
true)
|
||||
|
||||
(define
|
||||
host-sv-tests-run!
|
||||
(fn
|
||||
()
|
||||
{:total (+ host-sv-pass host-sv-fail)
|
||||
:passed host-sv-pass
|
||||
:failed host-sv-fail
|
||||
:fails host-sv-fails}))
|
||||
129
lib/host/tests/sxtp.sx
Normal file
129
lib/host/tests/sxtp.sx
Normal file
@@ -0,0 +1,129 @@
|
||||
;; lib/host/tests/sxtp.sx — SXTP message algebra, wire serialise/parse round-trip,
|
||||
;; and the Dream HTTP <-> SXTP bridge.
|
||||
|
||||
(define host-sx-pass 0)
|
||||
(define host-sx-fail 0)
|
||||
(define host-sx-fails (list))
|
||||
|
||||
(define
|
||||
host-sx-test
|
||||
(fn
|
||||
(name actual expected)
|
||||
(if
|
||||
(= actual expected)
|
||||
(set! host-sx-pass (+ host-sx-pass 1))
|
||||
(begin
|
||||
(set! host-sx-fail (+ host-sx-fail 1))
|
||||
(append! host-sx-fails {:name name :actual actual :expected expected})))))
|
||||
|
||||
;; ── constructors + predicates ──────────────────────────────────────
|
||||
(define host-sx-req (sxtp/request "navigate" "/x" {:headers {:host "h"}}))
|
||||
(define host-sx-resp (sxtp/ok {:id "e1"}))
|
||||
|
||||
(host-sx-test "request?" (sxtp/request? host-sx-req) true)
|
||||
(host-sx-test "request not response" (sxtp/response? host-sx-req) false)
|
||||
(host-sx-test "response?" (sxtp/response? host-sx-resp) true)
|
||||
(host-sx-test "condition?" (sxtp/condition? (sxtp/condition "x" {})) true)
|
||||
|
||||
;; ── accessors (verb/status are symbols) ────────────────────────────
|
||||
(host-sx-test "verb" (symbol->string (sxtp/verb host-sx-req)) "navigate")
|
||||
(host-sx-test "path" (sxtp/path host-sx-req) "/x")
|
||||
(host-sx-test "req header" (get (sxtp/req-headers host-sx-req) :host) "h")
|
||||
(host-sx-test "status" (symbol->string (sxtp/status host-sx-resp)) "ok")
|
||||
(host-sx-test "body" (get (sxtp/body host-sx-resp) :id) "e1")
|
||||
|
||||
;; ── status helpers ─────────────────────────────────────────────────
|
||||
(host-sx-test "created status" (symbol->string (sxtp/status (sxtp/created {}))) "created")
|
||||
(host-sx-test
|
||||
"not-found status"
|
||||
(symbol->string (sxtp/status (sxtp/not-found "/p" "gone")))
|
||||
"not-found")
|
||||
(host-sx-test
|
||||
"not-found body is condition"
|
||||
(sxtp/condition? (sxtp/body (sxtp/not-found "/p" "gone")))
|
||||
true)
|
||||
(host-sx-test
|
||||
"forbidden message"
|
||||
(sxtp/cond-message (sxtp/body (sxtp/forbidden "no")))
|
||||
"no")
|
||||
|
||||
;; ── serialise (deterministic top-level field order) ────────────────
|
||||
(host-sx-test
|
||||
"serialize request"
|
||||
(sxtp/serialize host-sx-req)
|
||||
"(request :verb navigate :path \"/x\" :headers {:host \"h\"})")
|
||||
(host-sx-test
|
||||
"serialize ok"
|
||||
(sxtp/serialize (sxtp/ok {:id "e1"}))
|
||||
"(response :status ok :body {:id \"e1\"})")
|
||||
;; nested condition rides the wire in its (condition ...) list form, no :msg leak.
|
||||
(host-sx-test
|
||||
"serialize nested condition as list"
|
||||
(contains?
|
||||
(sxtp/serialize (sxtp/not-found "/p" "gone"))
|
||||
"(condition :type resource-not-found")
|
||||
true)
|
||||
(host-sx-test
|
||||
"serialize no :msg leak"
|
||||
(contains? (sxtp/serialize host-sx-resp) ":msg")
|
||||
false)
|
||||
|
||||
;; ── parse + round-trip ─────────────────────────────────────────────
|
||||
(define host-sx-parsed
|
||||
(sxtp/parse "(request :verb query :path \"/events\" :headers {:host \"h\"})"))
|
||||
(host-sx-test "parse msg type" (sxtp/request? host-sx-parsed) true)
|
||||
(host-sx-test "parse verb" (symbol->string (sxtp/verb host-sx-parsed)) "query")
|
||||
(host-sx-test "parse path" (sxtp/path host-sx-parsed) "/events")
|
||||
(host-sx-test
|
||||
"parse nested header normalised"
|
||||
(get (sxtp/req-headers host-sx-parsed) :host)
|
||||
"h")
|
||||
|
||||
(define host-sx-rt (sxtp/parse (sxtp/serialize (sxtp/ok {:id "e1" :n 3}))))
|
||||
(host-sx-test "round-trip status" (symbol->string (sxtp/status host-sx-rt)) "ok")
|
||||
(host-sx-test "round-trip body id" (get (sxtp/body host-sx-rt) :id) "e1")
|
||||
(host-sx-test "round-trip body n" (get (sxtp/body host-sx-rt) :n) 3)
|
||||
|
||||
;; ── HTTP <-> SXTP mappings ─────────────────────────────────────────
|
||||
(host-sx-test "verb GET->fetch" (symbol->string (sxtp/verb-for-method "GET")) "fetch")
|
||||
(host-sx-test "verb POST->create" (symbol->string (sxtp/verb-for-method "POST")) "create")
|
||||
(host-sx-test "verb DELETE->delete" (symbol->string (sxtp/verb-for-method "DELETE")) "delete")
|
||||
(host-sx-test "verb unknown->fetch" (symbol->string (sxtp/verb-for-method "WIBBLE")) "fetch")
|
||||
(host-sx-test "http ok->200" (sxtp/http-status (string->symbol "ok")) 200)
|
||||
(host-sx-test "http not-found->404" (sxtp/http-status (string->symbol "not-found")) 404)
|
||||
|
||||
;; ── Dream bridge ───────────────────────────────────────────────────
|
||||
(define host-sx-from
|
||||
(sxtp/from-dream (dream-request "POST" "/feed?a=1" {} "hi")))
|
||||
(host-sx-test "from-dream verb" (symbol->string (sxtp/verb host-sx-from)) "create")
|
||||
(host-sx-test "from-dream path" (sxtp/path host-sx-from) "/feed")
|
||||
(host-sx-test "from-dream param" (sxtp/param host-sx-from "a") "1")
|
||||
(host-sx-test "from-dream body" (sxtp/body host-sx-from) "hi")
|
||||
|
||||
(define host-sx-tod (sxtp/to-dream (sxtp/ok {:id "e1"})))
|
||||
(host-sx-test "to-dream status" (dream-status host-sx-tod) 200)
|
||||
(host-sx-test
|
||||
"to-dream content-type text/sx"
|
||||
(dream-resp-header host-sx-tod "content-type")
|
||||
"text/sx")
|
||||
(host-sx-test
|
||||
"to-dream body is sx text"
|
||||
(dream-resp-body host-sx-tod)
|
||||
"{:id \"e1\"}")
|
||||
(host-sx-test
|
||||
"to-dream not-found->404"
|
||||
(dream-status (sxtp/to-dream (sxtp/not-found "/p" "gone")))
|
||||
404)
|
||||
(host-sx-test
|
||||
"to-dream forbidden->403"
|
||||
(dream-status (sxtp/to-dream (sxtp/forbidden "no")))
|
||||
403)
|
||||
|
||||
(define
|
||||
host-sx-tests-run!
|
||||
(fn
|
||||
()
|
||||
{:total (+ host-sx-pass host-sx-fail)
|
||||
:passed host-sx-pass
|
||||
:failed host-sx-fail
|
||||
:fails host-sx-fails}))
|
||||
75
plans/blog-editor-island.md
Normal file
75
plans/blog-editor-island.md
Normal file
@@ -0,0 +1,75 @@
|
||||
# Handoff: native SX-island blog editor
|
||||
|
||||
> Handed off from the **host-on-sx** loop (2026-06-19). Build this in a
|
||||
> **browser-capable session** (Playwright installed) — a reactive island only
|
||||
> proves out when it hydrates in a browser; this worktree has no Playwright.
|
||||
|
||||
## Goal
|
||||
|
||||
A native **SX reactive island** WYSIWYG block editor for blog posts — replacing
|
||||
the legacy `shared/static/scripts/sx-editor.js` (Koenig-era JS, ~2500 lines).
|
||||
It edits blocks reactively and, on publish, emits **`sx_content`** (SX element
|
||||
markup) + a title + status, and submits to the host's create endpoint.
|
||||
|
||||
## Architecture (decided this session)
|
||||
|
||||
- The editor is the **interactivity layer**, so it lives on the **`--http`
|
||||
island pipeline** (`sx.rose-ash.com`, which already SSRs + hydrates islands),
|
||||
**NOT** in the `http-listen` host (the host deliberately doesn't do island
|
||||
hydration — see `plans/host-on-sx.md` Phase 5).
|
||||
- It **publishes to the host**: the host serves `blog.rose-ash.com` and owns the
|
||||
durable store + create/render. The editor is a docs-side island that talks to
|
||||
the host's API. Two cooperating SX servers: host = content/API/state, `--http`
|
||||
= interactive UI.
|
||||
|
||||
## The host contract (already live + proven)
|
||||
|
||||
`POST /new` on the host (`blog.rose-ash.com`) — **works today**:
|
||||
- Body: **form-urlencoded** `title`, `sx_content`, `status` (`draft`/`published`).
|
||||
- Behaviour: slug derived from title, post stored in the durable KV, **303
|
||||
redirect** to `/<slug>/`.
|
||||
- `host/blog-form-submit` in `lib/host/blog.sx`; route `host/blog-open-create-routes`
|
||||
(currently UNGUARDED experimental — gate before real use).
|
||||
- A **form POST** (303 redirect) needs **no CORS**. If the editor uses `fetch`
|
||||
instead, the host needs CORS on `/new` — the host loop can add `dream-cors-with`
|
||||
(`lib/dream/cors.sx`) in minutes; just ask.
|
||||
|
||||
## `sx_content` format — what to emit
|
||||
|
||||
SX **element markup**, rendered host-side by `render-page` → `render-to-html`,
|
||||
**per block, guarded** (`host/blog-render` in `lib/host/blog.sx`). So:
|
||||
- Top level is a fragment: `(<> (h2 "Title") (p "para " (strong "bold")) (ul (li "a") (li "b")))`.
|
||||
- **Use standard tags `render-to-html` knows**: `p h1..h6 ul ol li blockquote
|
||||
code pre strong em a img figure hr br span div`. These render cleanly + fast.
|
||||
- **AVOID the legacy `~kg-*` card components** — they show as `(unsupported
|
||||
block)` placeholders (the legacy editor emits bare `~kg-md` but the components
|
||||
are `~kg_cards/kg-md` — name drift we deliberately did NOT alias). If cards are
|
||||
wanted, define **canonical** card components the host loads (no bare-name shim).
|
||||
- A bad/unknown block degrades to a placeholder, never crashes the page — but
|
||||
aim to emit only renderable markup.
|
||||
|
||||
## Build notes
|
||||
|
||||
- It's a `defisland` served as a `defpage` on `--http`. Example island:
|
||||
`sx/sx/home/stepper.sx`. Reactive primitives: `signal`/`deref`/`computed`/
|
||||
`effect` (see the signals spec).
|
||||
- **SX island authoring gotchas** (CLAUDE.md "SX Island Authoring Rules"):
|
||||
multi-expr bodies need `(do …)`; `let` is parallel (nest for sequencing);
|
||||
reactive text needs `(deref (computed …))`; effects go in an inner `let`.
|
||||
- A reasonable MVP: title input (signal) + an ordered list of block signals
|
||||
(type + text), add/remove/reorder, a few block types (paragraph, heading,
|
||||
list, quote, code), a **live preview** (computed → rendered), and a Publish
|
||||
that serialises blocks → `sx_content` and form-POSTs to the host's `/new`.
|
||||
- **Test with `sx_playwright`** (inspect / hydrate / interact / trace-boot) —
|
||||
hydrate the island, simulate typing, assert the serialized `sx_content` and
|
||||
the live preview. Don't ship an island you haven't hydrated in a browser.
|
||||
|
||||
## Pointers
|
||||
|
||||
- Host ingest + render + page shell: `lib/host/blog.sx` (the `/new` POST is the
|
||||
target; `host/blog-render` shows exactly which markup renders).
|
||||
- `render-page` (host's component renderer) + the static-page pattern:
|
||||
`lib/host/page.sx`, `plans/host-on-sx.md` Phase 5.
|
||||
- Island example: `sx/sx/home/stepper.sx`. HTML renderer (tags it knows):
|
||||
`web/adapter-html.sx`. Legacy editor (reference only, being replaced):
|
||||
`shared/static/scripts/sx-editor.js`.
|
||||
@@ -44,42 +44,127 @@ The user-facing story: rose-ash users who'd never touch s-expressions might writ
|
||||
|
||||
The five types: `request`, `response`, `handler = request -> response`, `middleware = handler -> handler`, `route`. Everything else is a function over these.
|
||||
|
||||
- [ ] **Core types** in `lib/dream/types.sx`: request/response records, route record.
|
||||
- [ ] **Router** in `lib/dream/router.sx`:
|
||||
- [x] **Core types** in `lib/dream/types.sx`: request/response records, route record.
|
||||
- [x] **Router** in `lib/dream/router.sx`:
|
||||
- `dream-get path handler`, `dream-post path handler`, etc. for all HTTP methods.
|
||||
- `dream-scope prefix middlewares routes` — prefix mount with middleware chain.
|
||||
- `dream-router routes` — dispatch tree, returns handler; no match → 404.
|
||||
- Path param extraction: `:name` segments, `**` wildcard.
|
||||
- `dream-param req name` — retrieve matched path param.
|
||||
- [ ] **Middleware** in `lib/dream/middleware.sx`:
|
||||
- [x] **Middleware** in `lib/dream/middleware.sx`:
|
||||
- `dream-pipeline middlewares handler` — compose middleware left-to-right.
|
||||
- `dream-no-middleware` — identity.
|
||||
- Logger: `(dream-logger next req)` — logs method, path, status, timing.
|
||||
- Content-type sniffer.
|
||||
- [ ] **Sessions** in `lib/dream/session.sx`:
|
||||
- [x] **Sessions** in `lib/dream/session.sx`:
|
||||
- Cookie-backed session middleware.
|
||||
- `dream-session-field req key`, `dream-set-session-field req key val`.
|
||||
- `dream-invalidate-session req`.
|
||||
- [ ] **Flash messages** in `lib/dream/flash.sx`:
|
||||
- [x] **Flash messages** in `lib/dream/flash.sx`:
|
||||
- `dream-flash-middleware` — single-request cookie store.
|
||||
- `dream-add-flash-message req category msg`.
|
||||
- `dream-flash-messages req` — returns list of `(category, msg)`.
|
||||
- [ ] **Forms + CSRF** in `lib/dream/form.sx`:
|
||||
- `dream-form req` — returns `(Ok fields)` or `(Err :csrf-token-invalid)`.
|
||||
- `dream-multipart req` — streaming multipart form data.
|
||||
- CSRF middleware: stateless signed tokens, session-scoped.
|
||||
- `dream-csrf-tag req` — returns hidden input fragment for SX templates.
|
||||
- [ ] **WebSockets** in `lib/dream/websocket.sx`:
|
||||
- [x] **Forms + CSRF** in `lib/dream/form.sx`:
|
||||
- [x] `dream-form req` — returns `(Ok fields)` or `(Err :csrf-token-invalid)`.
|
||||
- [x] `dream-multipart req` — multipart form data (in-memory, not yet streaming).
|
||||
- [x] CSRF middleware: stateless signed tokens, session-scoped.
|
||||
- [x] `dream-csrf-tag req` — returns hidden input fragment for SX templates.
|
||||
- [x] **WebSockets** in `lib/dream/websocket.sx`:
|
||||
- `dream-websocket handler` — upgrades request; handler `(fn (ws) ...)`.
|
||||
- `dream-send ws msg`, `dream-receive ws`, `dream-close ws`.
|
||||
- [ ] **Static files:** `dream-static root-path` — serves files, ETags, range requests.
|
||||
- [ ] **`dream-run`**: wires root handler into SX's `perform (:http-listen ...)`.
|
||||
- [ ] **Demos** in `lib/dream/demos/`:
|
||||
- `hello.ml` → `lib/dream/demos/hello.sx`: "Hello, World!" route.
|
||||
- `counter.ml` → `lib/dream/demos/counter.sx`: in-memory counter with sessions.
|
||||
- `chat.ml` → `lib/dream/demos/chat.sx`: multi-room WebSocket chat.
|
||||
- `todo.ml` → `lib/dream/demos/todo.sx`: CRUD list with forms + CSRF.
|
||||
- [ ] Tests in `lib/dream/tests/`: routing dispatch, middleware composition, session round-trip, CSRF accept/reject, flash read-after-write — 60+ tests.
|
||||
- [x] **Static files:** `dream-static root-path` — serves files, ETags, range requests.
|
||||
- [x] **`dream-run`**: wires root handler into SX's `perform (:http-listen ...)`.
|
||||
- [x] **Demos** in `lib/dream/demos/`:
|
||||
- [x] `hello.ml` → `lib/dream/demos/hello.sx`: "Hello, World!" route.
|
||||
- [x] `counter.ml` → `lib/dream/demos/counter.sx`: in-memory counter with sessions.
|
||||
- [x] `chat.ml` → `lib/dream/demos/chat.sx`: multi-room WebSocket chat.
|
||||
- [x] `todo.ml` → `lib/dream/demos/todo.sx`: CRUD list with forms + CSRF.
|
||||
- [x] Tests in `lib/dream/tests/`: routing dispatch, middleware composition, session round-trip, CSRF accept/reject, flash read-after-write — **258 tests across 10 suites** (well past the 60+ target). Runner: `lib/dream/conformance.sh`.
|
||||
|
||||
**Roadmap complete (2026-06-07): all boxes ticked, 258/258 green.** Loop continues
|
||||
with extensions + hardening below.
|
||||
- **2026-06-07 — Ext: router HTTP correctness** (router suite 27→36, 267 total).
|
||||
Dispatch now tracks which routes' *paths* matched: path matched + method didn't →
|
||||
`405 Method Not Allowed` with an `Allow` header listing the path's methods (was a
|
||||
blanket 404); genuinely-absent paths stay 404. `HEAD` falls back to the matching
|
||||
`GET` handler with the body blanked but headers kept. `dr/route-params` (path-only
|
||||
match) + `dr/method-accepts?` (ANY / HEAD→GET) + `dream-method-not-allowed`. NOTE:
|
||||
in this worktree every `sx-tree` *edit* tool (`sx_replace_node`,
|
||||
`sx_replace_by_pattern`, `sx_insert_near`) raises a yojson `Expected string, got
|
||||
null` error — only `sx_write_file` works, so edits rewrite the whole file.
|
||||
- **2026-06-07 — Ext: error handling + status phrases** (`lib/dream/error.sx`, 15
|
||||
tests, 282 total). `dream-status-text` / `dream-status-line` reason-phrase map (string
|
||||
keys); `dream-status-page` renders a status page. `dream-catch` is a `guard`-based
|
||||
middleware that turns a raised error into a 500 (`dream-catch-with on-error` for a
|
||||
custom page receiving `(req e)`); normal responses pass through untouched, composes
|
||||
around a router. (`guard` catches explicit `(error …)` raises; `e` stringifies to the
|
||||
message.)
|
||||
- **2026-06-07 — Ext: CORS** (`lib/dream/cors.sx`, 12 tests, 294 total). `dream-cors`
|
||||
decorates responses with `Access-Control-Allow-Origin` (+ credentials), and
|
||||
short-circuits preflight `OPTIONS` with a 204 carrying Allow-Methods/Headers/Max-Age.
|
||||
`dream-cors-origin` for a specific origin, `dream-cors-with opts` for full control
|
||||
(origin/methods/headers/credentials/max-age). Composes around a router.
|
||||
- **2026-06-07 — Ext: JSON** (`lib/dream/json.sx`, 35 tests, 329 total). Host JSON
|
||||
primitives live in the ocaml-on-sx runtime (not the base env), so Dream ships its own
|
||||
pure-SX `dream-json-encode` (scalars/list/dict, string escaping) + `dream-json-parse`
|
||||
(recursive-descent over chars, objects/arrays/strings/numbers/true/false/null,
|
||||
whitespace-tolerant). `dream-json-value` (encode → application/json response) and
|
||||
`dream-json-body` (parse request body). GOTCHA: `number?` is unreliable in this env —
|
||||
used `(= (type-of v) "number")`; `parse-float` handles decimals. Multi-key dict
|
||||
encode order follows `keys` (non-deterministic) so tests assert via parse round-trip.
|
||||
- **2026-06-07 — Ext: signed session cookies** (`lib/dream/session.sx`, session suite
|
||||
30→41, 340 total). The default store uses guessable sids (`s1`, `s2`), so
|
||||
`dream-sessions-signed backend secret` signs the cookie value (`sid.signature`) and
|
||||
rejects any cookie whose signature doesn't verify — a forged plaintext `s1` or a
|
||||
wrong-secret cookie yields a fresh session instead of a hijack. `dream-cookie-sign` /
|
||||
`dream-cookie-unsign` (keyed hash; same not-cryptographic caveat — inject a host HMAC
|
||||
in production). Plain `dream-sessions` unchanged for the no-secret case.
|
||||
- **2026-06-07 — Ext: query/header convenience** (`lib/dream/types.sx`, types suite
|
||||
41→59, 358 total). `dream-queries`, `dream-query-param-or` / `dream-header-or` /
|
||||
`dream-param-or` (defaults), `dream-has-query?` / `-header?` / `-param?`,
|
||||
`dream-content-type-of`, `dream-method-is?`, `dream-accepts?` / `dream-wants-json?`
|
||||
(Accept-header content negotiation).
|
||||
- **2026-06-07 — Ext: api.sx facade + README** (`lib/dream/api.sx`, 9 tests, 367 total).
|
||||
`dream-version`, `dream-defaults` (pure stack: error-catch + content-type; logger is
|
||||
opt-in since it performs IO), `dream-make-app routes`, `dream-make-app-with`,
|
||||
`dream-serve`/`dream-serve-port`. `lib/dream/README.md` documents the full public
|
||||
surface, quickstart, the dependency-injection testing story, and caveats. **All
|
||||
planned extensions complete — 367/367 across 14 suites.**
|
||||
- **2026-06-07 — Ext: auth** (`lib/dream/auth.sx`, 23 tests, 390 total). Pure-SX base64
|
||||
codec (`dream-base64-encode`/`-decode`, arithmetic via `quotient`/`mod` — no bitwise),
|
||||
verified against RFC vectors (Man/Ma/M padding). `dream-basic-auth realm check` →
|
||||
401 + `WWW-Authenticate: Basic realm=…`, attaches `:dream-user` on success;
|
||||
`dream-basic-credentials` / `dream-authorization` accessors. `dream-require-bearer
|
||||
check` → attaches `:dream-principal` or 401; `dream-bearer-token` accessor.
|
||||
- **2026-06-07 — Ext: HTML escaping** (`lib/dream/html.sx`, 11 tests, 401 total).
|
||||
`dream-escape` (&/</>/"/' entities, ampersand first to avoid double-escape),
|
||||
`dream-attr`, `dream-escape-join`. Fixed a real **XSS hole** in the todo demo, which
|
||||
interpolated user text into `<li>` unescaped — now `(dream-escape (get it :text))`;
|
||||
regression test asserts `<script>` renders as `<script>`. 16 suites, 401/401.
|
||||
- **2026-06-07 — Ext: security headers + cache-control** (`lib/dream/headers.sx`, 12
|
||||
tests, 413 total). `dream-security-headers` middleware (X-Content-Type-Options
|
||||
nosniff, X-Frame-Options DENY, Referrer-Policy no-referrer; opt-in HSTS via
|
||||
`dream-security-headers-with`). Cache helpers `dream-cache`/`dream-private-cache`/
|
||||
`dream-no-store`/`dream-no-cache` + `dream-cache-for` middleware. **dream-on-sx is
|
||||
feature-complete: roadmap + 10 extensions, 413/413 across 17 suites. SATURATED —
|
||||
remaining work is host-on-sx's job to consume `dream-run` (don't edit hosts/).**
|
||||
|
||||
## Extensions (post-roadmap)
|
||||
|
||||
The five-types core is complete; these harden it toward a production HTTP front door.
|
||||
|
||||
- [x] **Router HTTP correctness**: 405 Method Not Allowed + `Allow` header; automatic
|
||||
HEAD (serve the GET handler with an empty body).
|
||||
- [x] **Status reason phrases** + `dream-status-text` (`lib/dream/error.sx`).
|
||||
- [x] **CORS middleware** (`dream-cors`).
|
||||
- [x] **Error-handling middleware** (`dream-catch` / custom 500 templates; `guard`-based).
|
||||
- [x] **Signed session cookies** (`dream-sessions-signed` — tamper-evident sid).
|
||||
- [x] **JSON helpers** (encode + recursive-descent parse, pure SX).
|
||||
- [x] **Query/header convenience** (`dream-queries`, `*-or` defaults, `dream-accepts?`).
|
||||
- [x] **`api.sx` facade + README** — `dream-make-app` / `dream-serve` + `README.md`.
|
||||
- [x] **Auth** — base64 (pure SX), HTTP Basic auth + Bearer-token middleware.
|
||||
- [x] **HTML escaping** (`dream-escape`/`dream-attr`) — fixed an XSS hole in the todo demo.
|
||||
- [x] **Security headers + cache-control** (`dream-security-headers`, `dream-cache`/`-no-store`).
|
||||
|
||||
## Stdlib additions Dream will need
|
||||
|
||||
@@ -104,8 +189,114 @@ Confirm scope before starting; some of these may be addable as Dream-internal he
|
||||
|
||||
## Progress log
|
||||
|
||||
_(awaiting activation conditions)_
|
||||
- **2026-06-07 — Core types** (`lib/dream/types.sx`, 41 tests). OCaml gate verified
|
||||
green (scoreboard 480/480, Phases 1–5 + Phase 6 stdlib). Dream is implemented in
|
||||
plain SX over the CEK — keywords are strings, so headers are dicts with lowercased
|
||||
string keys (`:content-type` == `"content-type"`). request (method/target/path/
|
||||
query/headers/body/params), response (status/headers/body), route records with
|
||||
constructors + accessors; smart response constructors (html/text/json/empty/
|
||||
not-found/redirect); `dream-coerce-response` wraps bare strings; query-string
|
||||
parsing. Conformance runner `lib/dream/conformance.sh` modelled on flow's.
|
||||
- **2026-06-07 — Router** (`lib/dream/router.sx`, 27 tests). `dream-get/post/put/
|
||||
delete/patch/head/options/any` route constructors; `dream-router` flattens routes
|
||||
(incl. nested scopes) and dispatches by method+path, first-match-wins, 404 on no
|
||||
match. Path matching is recursive over `/`-split segments: literal, `:name` binds
|
||||
a param, `**` catch-all binds remaining path under key `"**"`. Trailing slashes and
|
||||
query strings are ignored for routing. `dream-scope prefix mws routes` prepends the
|
||||
prefix and folds the middleware chain (`m1 @@ m2 @@ h`, first = outermost) onto each
|
||||
route's handler; nests correctly (inner mw innermost). Shared `dr/apply-middlewares`
|
||||
fold will back `dream-pipeline`.
|
||||
- **2026-06-07 — Middleware** (`lib/dream/middleware.sx`, 20 tests). `dream-pipeline`
|
||||
(reuses `dr/apply-middlewares`), `dream-no-middleware` identity. `dream-logger-with
|
||||
clock sink` is the testable core (records `{:method :path :status :elapsed}`);
|
||||
`dream-logger` wires it to `(perform (:dream-clock))` / `(perform (:dream-log …))`;
|
||||
`dream-log-line` formats one line. `dream-content-type` sniffs body (`<`→html,
|
||||
`{`/`[`→json, else text) only when the handler left Content-Type unset. Bonus
|
||||
`dream-set-header` and `dream-tap-request` combinators.
|
||||
- **2026-06-07 — Sessions** (`lib/dream/session.sx`, 30 tests). Solved the
|
||||
request→response mutation-visibility problem the way Dream does: the cookie carries
|
||||
only a session id; fields live in an injectable back-end store (the mapping table's
|
||||
`(perform (:session-get …))`). `dream-memory-sessions` is an in-memory store built
|
||||
on a `set!`-mutated captured `let` binding (no `ref`/`atom` in base env);
|
||||
`dream-perform-sessions` is the production back-end. `dream-sessions backend`
|
||||
middleware reads/creates the id, attaches `{:sid :io}` to the request, and emits a
|
||||
`Set-Cookie` (HttpOnly, SameSite=Lax) only for new sessions. Handler API:
|
||||
`dream-session-field` / `dream-set-session-field` / `dream-session-all` /
|
||||
`dream-invalidate-session` / `dream-session-id`. Also added shared cookie infra
|
||||
(`dr/parse-cookies`, `dream-cookie(s)`, `dr/build-cookie`, `dream-set-cookie`,
|
||||
`dream-resp-cookies`, `dream-drop-cookie`) — outgoing cookies accumulate in a
|
||||
`:set-cookies` list on the response so multiple Set-Cookie headers don't collide;
|
||||
reused by flash + CSRF. Full counter round-trip verified across three requests.
|
||||
- **2026-06-07 — Flash** (`lib/dream/flash.sx`, 14 tests). `dream-flash` middleware:
|
||||
decodes the incoming `dream.flash` cookie into the request, gives the handler a
|
||||
mutable outbox cell (`dr/flash-box`, the same `set!`-captured-`let` trick), then on
|
||||
response writes the outbox as a fresh flash cookie, or drops the cookie (Max-Age=0)
|
||||
when there were incoming messages but no new ones — so messages show exactly once.
|
||||
Handler API: `dream-add-flash-message` / `dream-flash-messages` (returns the
|
||||
PREVIOUS request's messages) / `dream-flash-of` (by category) / accessors. Cookie
|
||||
codec percent-escapes the `|`/`~`/`%` separators so categories/messages round-trip.
|
||||
Read-after-write verified across request boundaries incl. multi-category.
|
||||
- **2026-06-07 — Forms + CSRF (urlencoded)** (`lib/dream/form.sx`, 26 tests). Ok/Err
|
||||
result values (`dream-ok`/`dream-err` + predicates/accessors). `dream-form-fields`
|
||||
parses `application/x-www-form-urlencoded` with a full percent-decoder
|
||||
(`%XX` via `char-from-code`, `+`→space). CSRF is stateless + signed + session-
|
||||
scoped: token = `sid.signature`, verified by recomputing the signature and checking
|
||||
the session id — no server storage. Signing is **injectable** (`dream-csrf-with`);
|
||||
the default `dream-csrf-sign-default` is a pure-SX dual-base polynomial keyed hash
|
||||
(NOT cryptographic — production should inject a host HMAC). `dream-csrf` attaches
|
||||
context (needs the session middleware upstream for the sid); `dream-csrf-token` /
|
||||
`dream-csrf-tag` (hidden input for templates); `dream-form` returns `Ok fields` or
|
||||
`Err :csrf-token-invalid`; `dream-csrf-protect` auto-rejects unsafe methods (403)
|
||||
lacking a valid token. Full session→csrf→form stack verified accept + reject.
|
||||
Multipart deferred to the next commit.
|
||||
- **2026-06-07 — Multipart** (`lib/dream/form.sx` +9 tests, 35 total). `dream-multipart
|
||||
req` parses `multipart/form-data` into parts `{:name :filename :content-type
|
||||
:content}`, returns `Ok parts | Err :not-multipart`. Needed a substring splitter
|
||||
`dr/split-on` because the `split` primitive is **character-class** based (multi-char
|
||||
separators split on every char) — important gotcha. Boundary from the Content-Type
|
||||
(handles quoted form); segments filtered to those starting with CRLF; each split on
|
||||
the first `\r\n\r\n` into headers/content with one edge CRLF stripped (inner CRLFs
|
||||
in file content preserved). `dream-multipart-field` / `dream-multipart-file`
|
||||
accessors. In-memory, not streaming (noted for future). `\r`/`\n` string escapes
|
||||
work in SX literals.
|
||||
- **2026-06-07 — WebSockets** (`lib/dream/websocket.sx`, 16 tests). `dream-websocket
|
||||
handler` wraps a `(fn (ws) …)` into an ordinary handler returning a 101 upgrade
|
||||
response carrying the ws handler (`dream-websocket?` / `dream-ws-handler` for the
|
||||
host to detect + dispatch). `dream-send` / `dream-receive` / `dream-close` /
|
||||
`dream-ws-open?` / `dream-ws-broadcast` operate over an injectable io; production io
|
||||
is `(perform op)`, tests use `dream-mock-ws` (in-memory inbox/outbox/closed via the
|
||||
cell pattern) with `dream-ws-sent` / `dream-ws-closed?` introspection and
|
||||
`dream-ws-run` to drive a handler. Echo loop + room broadcast verified.
|
||||
- **2026-06-07 — Static files** (`lib/dream/static.sx`, 28 tests). `dream-static root`
|
||||
mounts at a `**` route and serves files: content-type by extension (mime map),
|
||||
weak ETag (`"hash-length"`) with `If-None-Match` → 304 (incl. `*`), and `Range:
|
||||
bytes=` requests → 206 with `Content-Range` (open-ended `bytes=N-` supported,
|
||||
unsatisfiable → 416). `..`/absolute path traversal → 403; missing → 404; full
|
||||
responses advertise `Accept-Ranges`. Filesystem is injectable —
|
||||
`dream-static-perform-fs` (host) vs `dream-memory-fs` (in-memory map for tests).
|
||||
- **2026-06-07 — dream-run** (`lib/dream/run.sx`, 20 tests). `dream-run handler`
|
||||
installs the root handler via `(perform (:http/listen {:port :host :app …}))` — no
|
||||
socket code, it wraps the existing server. `dream-app handler` is the adapter the
|
||||
host invokes per request: raw `{:method :target :headers :body}` → `dream-request`
|
||||
→ handler → serialised `{:status :headers :body :set-cookies}`, or a `{:status 101
|
||||
:websocket …}` upgrade. Bare-string handlers coerced; method defaults to GET;
|
||||
set-cookies (from session/flash) flow through. Listen transport injectable
|
||||
(`dream-run-with`) so the full wiring is tested with a mock that captures the op and
|
||||
re-runs the captured app. `dream-run-port` / `dream-run-opts` variants.
|
||||
- **2026-06-07 — Demos: hello + counter** (`lib/dream/demos/`, 10 tests). `hello.sx`
|
||||
is the canonical router with a `:name` param route. `counter.sx` is a per-session
|
||||
visit counter on the session middleware (+ a `/reset` POST that redirects),
|
||||
demonstrating session isolation across browsers. End-to-end tests drive both apps
|
||||
as the host would. chat (ws) + todo (forms+CSRF) next.
|
||||
- **2026-06-07 — Demos: chat + todo** (`lib/dream/demos/`, demos suite now 27 tests).
|
||||
`chat.sx` is a multi-room WebSocket chat over a room registry (join/leave/members/
|
||||
broadcast on the cell pattern); verified three clients see each other's broadcasts
|
||||
and a disconnect leaves the room. `todo.sx` is a CRUD list wiring session→csrf→
|
||||
router: add/toggle/delete go through `dream-form` (CSRF-guarded), an in-memory store
|
||||
holds items, pages render the list + `dream-csrf-tag`; verified the full
|
||||
add→render→toggle→delete cycle plus a 403 on a token-less POST. ws object equality
|
||||
is by reference, so the `:leave` filter removes exactly the right connection.
|
||||
|
||||
## Blockers
|
||||
|
||||
_(none yet — plan is cold)_
|
||||
_(none — gate green, loop active)_
|
||||
|
||||
@@ -36,7 +36,43 @@ host — no `ocaml-on-sx` dependency.
|
||||
|
||||
## Status (rolling)
|
||||
|
||||
`bash lib/host/conformance.sh` → **0/0** (not yet started)
|
||||
`bash lib/host/conformance.sh` → **171/171** (9 suites: handler, middleware, sxtp,
|
||||
router, feed, relations, blog, server, ledger). **Blog now runs on the EDITOR's
|
||||
content model** (`sx_content` = SX element markup, what `blog/sx/editor.sx`
|
||||
emits), NOT content-on-sx CtDoc: a post is a `{slug,title,sx_content,status}`
|
||||
record in the durable persist **KV**, and a post page is `render-to-html (parse
|
||||
sx_content)`. Full CRUD + an editor form-ingest endpoint (`POST /new`,
|
||||
form-urlencoded) + JSON API, writes auth+ACL guarded. **`render-to-html` is fast
|
||||
(~0ms)** — it doesn't hit the JIT-miscompiled Smalltalk path, so blog rendering
|
||||
is no longer the 2s problem (that was content-on-sx's `asHTML`).
|
||||
|
||||
> **Per-request IO (kernel) — FIXED.** `http-listen` handlers used to run via
|
||||
> `Sx_runtime.sx_call` (bare CEK, no IO resolution), so a handler doing a durable
|
||||
> `persist/read` returned an unresolved suspension. Fixed in `sx_server.ml`: the
|
||||
> handler now runs through `cek_run_with_io` (`Sx_ref.continue_with_call` →
|
||||
> `cek_run_with_io`), the same IO-driving runner the REPL uses — it resolves
|
||||
> persist ops via `Sx_persist_store.handle_op` between CEK steps. Verified:
|
||||
> handlers do per-request durable reads + writes (incl. 10 concurrent, 15 events
|
||||
> on disk, no corruption); handler errors don't crash the server. NOTE: this is
|
||||
> the per-request *IO* fix; it does NOT speed up the interpreted Smalltalk render
|
||||
> (`/welcome/` still ~2s) — that's a separate concern, addressed by caching the
|
||||
> rendered HTML at boot. (Pre-existing: an erroring handler closes the connection
|
||||
> with no response instead of a 500 — worth improving later.)
|
||||
>
|
||||
> **Render speed (separate from IO) — NOT precompiled.** `/welcome/` is ~2s because
|
||||
> the interpreted Smalltalk-on-SX render runs on the tree-walking CEK: the JIT hook
|
||||
> (`register_jit_hook`) is installed only in `--http` page mode, not the epoch/
|
||||
> http-listen serving mode (`make_server_env`), so zero `[jit]` activity. Enabling
|
||||
> it in that mode breaks correctness (router 3/6, feed 4/11, … — the known JIT-
|
||||
> bytecode bug on complex nested ASTs, which the Smalltalk evaluator is). So the
|
||||
> render is slow until the JIT compiler is fixed (big win, broad payoff — its own
|
||||
> loop) or the Smalltalk interpreter is optimised. Blog is FULLY DYNAMIC (reads
|
||||
> store + renders per request, no cache) — slowness is honest, not hidden. Phases 1 & 2 DONE; Phase 3 cut-over
|
||||
landed (50% off Quart). **The host now serves live HTTP** — `lib/host/server.sx`
|
||||
bridges the native `http-listen` server to the Dream app and `lib/host/serve.sh`
|
||||
boots it (verified: GET /health, /feed, /feed?actor=, relations get-children/
|
||||
get-parents all serve real JSON on a host port; unknown→404). Remaining: golden
|
||||
harness vs live Quart, internal-HMAC middleware, docker stack + Caddy subdomain.
|
||||
|
||||
## Ground rules
|
||||
|
||||
@@ -73,28 +109,319 @@ lib/host/sxtp.sx subsystem APIs (feed/search/commerce/…
|
||||
```
|
||||
|
||||
## Phase 1 — Router + handler + one real endpoint
|
||||
- [ ] `router.sx` — route table, (method,path) match
|
||||
- [ ] `handler.sx` — request/response model, subsystem dispatch
|
||||
- [ ] migrate ONE read endpoint (e.g. a feed timeline) end-to-end, golden test
|
||||
- [ ] `conformance.sh` + scoreboard
|
||||
- [x] `router.sx` — `host/make-app` assembles per-domain route groups + a built-in
|
||||
`/health` probe into one Dream router (reuses Dream's `dr/flatten-routes`)
|
||||
- [x] `handler.sx` — JSON envelope (`host/ok`/`host/ok-status`/`host/error`),
|
||||
status-carrying `host/json-status` (Dream's `dream-json` is 200-only), and
|
||||
`host/query-int`. A host handler IS a Dream handler (request -> response).
|
||||
- [x] migrate ONE read endpoint: `GET /feed` (`lib/host/feed.sx`) reads
|
||||
`feed/all` + stream combinators, serialises recent-first; `?actor=` filter,
|
||||
`?limit=` cap. Golden test asserts body == subsystem recent stream + envelope.
|
||||
- [x] `conformance.sh` (mirrors `lib/dream`'s runner) — 28/28
|
||||
|
||||
## Phase 2 — Middleware + SXTP
|
||||
- [ ] `middleware.sx` — composable auth/acl/mute/error layers
|
||||
- [ ] `sxtp.sx` — host↔subsystem wire format (align with existing spec)
|
||||
- [ ] migrate a write endpoint (auth + permission + action)
|
||||
- [x] `middleware.sx` — composable layers as `handler->handler`: `host/wrap-errors`
|
||||
(JSON 500), `host/require-auth` (bearer -> principal, JSON 401, INJECTED token
|
||||
resolver), `host/require-permission` (ACL `acl/permit?` gate, JSON 403,
|
||||
INJECTED resource extractor), `host/pipeline` (first = outermost). Reuses
|
||||
Dream's `dream-bearer-token` + `dream-catch-with`; calls lib/acl public API.
|
||||
Mute/prefs layer deferred (no blocker, add when a domain needs it).
|
||||
- [x] `sxtp.sx` — host↔subsystem wire format (per `applications/sxtp/spec.sx`).
|
||||
Message algebra (`sxtp/request`/`response`/`condition`/`event` + status
|
||||
helpers `sxtp/ok`/`created`/`not-found`/`forbidden`/`invalid`/`fail`) as
|
||||
string-keyed dicts; verb/status/type as symbols (ride the wire bare). Codec:
|
||||
`sxtp/serialize` (dict → `text/sx` list form, deterministic field order,
|
||||
nested messages in their own list form, no `:msg` leak) and `sxtp/parse`
|
||||
(`text/sx` → dict, deep keyword-token→string normaliser). Dream bridge:
|
||||
`sxtp/from-dream` (HTTP req → SXTP req, method→verb, query→params) and
|
||||
`sxtp/to-dream` (SXTP resp → HTTP resp, status→code, body→`text/sx`).
|
||||
- [x] migrate a write endpoint (auth + permission + action): `POST /feed`
|
||||
(`host/feed-write-routes resolve`) — auth ∘ ACL("post","feed") ∘ wrap-errors
|
||||
over `host/feed-create`, which parses the JSON body and `feed/post`s it (201);
|
||||
non-object body -> 400. Created activity is readable back via `GET /feed`.
|
||||
|
||||
## Phase 3 — Strangler migration ledger
|
||||
- [ ] enumerate Quart endpoints; track migrated vs proxied
|
||||
- [x] enumerate Quart endpoints; track migrated vs proxied — `ledger.sx`: a
|
||||
catalogue of every endpoint (domain, method, path, Quart original, status
|
||||
`:native`/`:migrated`/`:proxied`, SX handler) + queries (by-status/by-domain,
|
||||
`host/ledger-find`, `host/ledger-served?`, distinct domains) and
|
||||
`host/ledger-coverage` (off-Quart % = (migrated+native)/total). Seeded with
|
||||
the live state: feed reads+writes migrated, `/health` native, the
|
||||
internal-only `relations`/`likes` data+action endpoints proxied.
|
||||
- [ ] golden-response harness vs the live Quart responses
|
||||
- [ ] cut over a whole domain (smallest: `likes` or `relations`) as proof
|
||||
- [x] cut over a whole domain (`relations`) as proof — the CONTAINER relations are
|
||||
fully on the host (`lib/host/relations.sx`): reads `GET .../get-children` +
|
||||
`/get-parents` → `relations/children`/`parents`; writes `POST
|
||||
.../attach-child` + `/detach-child` → `relations/relate`/`unrelate`, behind
|
||||
the auth+ACL pipeline (mirrors POST /feed). Node model: graph atom = symbol
|
||||
`"type:id"`, edge = relation-type; `child`/`parent-type` params filter by
|
||||
`"type:"` prefix. Closed-loop test: attach → visible via get-children →
|
||||
detach → gone. The TYPED actions (`relate`/`unrelate`/`can-relate`) stay
|
||||
proxied by design — registry + cardinality validation lib/relations lacks.
|
||||
|
||||
## Phase 4 — Dream framework layer (gated)
|
||||
- [ ] gate: `ocaml-on-sx` Phases 1–5 + minimal stdlib green
|
||||
- [ ] adopt `dream-on-sx` routing/middleware/session ergonomics over the same handlers
|
||||
- [ ] re-home external adapters as native where replacements land
|
||||
## Phase 4 — Live wiring + Dream framework layer
|
||||
- [x] native `http-listen` ↔ Dream-app bridge (`lib/host/server.sx`:
|
||||
`host/native-handler`/`host/serve`) + `lib/host/serve.sh` launcher. Serves
|
||||
real HTTP on a host port — verified live (health/feed/relations reads + 404).
|
||||
- [x] promote into the docker stack + a Caddy subdomain — **LIVE at
|
||||
`https://blog.rose-ash.com`** (reusing a down Quart subdomain). New compose
|
||||
service `sx_host` (`docker-compose.dev-sx-host.yml`, container
|
||||
`sx-dev-sx_host-1`) runs `serve.sh` on `externalnet`; Caddy reverse-proxies
|
||||
`blog.rose-ash.com` → `sx-dev-sx_host-1:8000`. Required a `hosts/` fix:
|
||||
`http-listen` bound `inet_addr_loopback` only — added `SX_HTTP_HOST` env
|
||||
(default loopback; stack sets `0.0.0.0`) in `sx_server.ml`, rebuilt this
|
||||
worktree's binary. Verified: `/health`, `/feed`, relations reads serve real
|
||||
JSON through Cloudflare→Caddy; `/` 404 (no root route yet). `rose-ash.com`
|
||||
untouched. (Inode-pinned bind-mount gotcha: editing `/root/caddy/Caddyfile`
|
||||
via a tool swaps its inode so the container kept the old content — loaded live
|
||||
via reload-from-non-bind-path, then RECONCILED by restarting Caddy so the
|
||||
bind re-points to the corrected file. Verified post-restart: blog serves, and
|
||||
`sx.rose-ash.com`/`rose-ash.com` survived.)
|
||||
- [x] blog published-post read endpoint — `lib/host/blog.sx`: `GET /<slug>/`
|
||||
renders a content-on-sx `CtDoc` to HTML via `content/html` (anonymous,
|
||||
world-visible). In-memory slug→doc registry now (swap `host/blog-lookup` for
|
||||
a persist-backed content stream later, handler/route unchanged). `:slug`
|
||||
catch-all mounted LAST so domain routes win. **LIVE**: `blog.rose-ash.com/
|
||||
welcome/` renders real HTML through Caddy. Needs Smalltalk+persist+content
|
||||
preloads + `(st-bootstrap-classes!)`+`(content/bootstrap!)` (self-bootstraps
|
||||
at load).
|
||||
- [ ] proxy-to-Quart fallback for un-migrated paths (strangler requirement before
|
||||
a real subdomain fronts users).
|
||||
- [ ] internal-HMAC middleware on `/internal/*` (service-to-service auth; protocol
|
||||
checks native, signature check needs an HMAC-SHA256 kernel prim — absent today).
|
||||
- [ ] (gated) adopt `dream-on-sx` session/CSRF ergonomics; re-home external
|
||||
adapters as native where replacements land.
|
||||
|
||||
## Phase 5 — Generic interactive SX-page serving (host SSR)
|
||||
|
||||
**The generic gap.** A host serves three classes: (1) JSON/data endpoints —
|
||||
DONE; (2) static content pages — DONE (`render-to-html` on *parsed* markup, e.g.
|
||||
blog post `sx_content`); (3) **interactive UI pages** — component/island trees
|
||||
with attributes + client behaviour — **the host cannot do this at all.** The
|
||||
"editor problem" is one instance; dashboards, account, market-browse, any admin
|
||||
screen are the same gap. The capability — not the editor — is the deliverable.
|
||||
|
||||
**Why `render-to-html` alone is insufficient (proven).** `render-to-html` on
|
||||
parsed markup handles attributes (`<div id="x">`); but an *evaluated* component
|
||||
tree mangles them (`(form :id ..)` → `<form>idpost-new-form…`) because in the
|
||||
host preload tags don't collect keyword args as attrs. The `--http` docs server
|
||||
already does this correctly via its component-render + shell pipeline. So: reuse
|
||||
that pipeline, don't reinvent or patch per-component.
|
||||
|
||||
**Reuse, don't rebuild.** The kernel already has: `~shared:shell/sx-page-shell`
|
||||
(emits `<!doctype>` + inlined component/island defs in `<script type="text/sx">`
|
||||
+ CSS + `sx-browser.js` + page SX for hydration), `http_inject_shell_statics`
|
||||
(gathers defs/CSS/asset-hashes into the env), and `http_render_page`. These power
|
||||
`sx.rose-ash.com`. The job is to make them reachable from the `http-listen`
|
||||
serving path.
|
||||
|
||||
Sub-steps (each independently gated/verified):
|
||||
- [x] **5.1 Page render from a host handler.** DONE. Kernel: a `render-page`
|
||||
primitive (sx_server.ml, persistent mode) renders an UNEVALUATED SX
|
||||
expression with the server env via `sx_render_to_html` — render-to-html
|
||||
expands defcomp components + collects keyword attrs itself; SX handlers
|
||||
can't reach the server env, so the prim supplies it. Host: `lib/host/page.sx`
|
||||
— `host/page` (expr → HTML response) + `host/page-route` (mount on a GET
|
||||
path). Gate MET: `~editor/form` renders correct HTML (`<form method="post"
|
||||
class=.. id="post-new-form">…`), and the `page` suite (8 tests) proves a
|
||||
generic attributed+nested component renders right (no `:class`-as-text
|
||||
mangling). Root cause confirmed: bare render-to-html on an *evaluated* tree
|
||||
mangles attrs; `render-page` renders the *unevaluated* expr so expansion +
|
||||
attr-collection happen in render-to-html.
|
||||
- [ ] **5.2 Shell statics + aser SSR (the real dynamic-page path).** `render-page`
|
||||
(5.1) renders STATIC component trees, but is NOT the full evaluator —
|
||||
dynamic-logic bodies fail (proven: a component doing `(map fn items)` over
|
||||
`(unquote data)` → "Not callable: nil"). Clean dynamic component pages
|
||||
(a posts loop) + island pages therefore need the **aser** pipeline (evaluate
|
||||
control flow, serialise tags) + `http_inject_shell_statics` (component defs /
|
||||
CSS / asset hashes) + `~shared:shell/sx-page-shell`. Gate: a page with a data
|
||||
loop renders, and a full shell emits with defs inlined.
|
||||
NOTE (2026-06-19): the legacy-editor stopgaps (kg-compat aliases, `./blog`
|
||||
mount, legacy `sx-editor.js` + hardcoded asset URLs at `/new`, the
|
||||
`~editor/sx-editor-styles` reuse) were REVERTED — they were debt to revive
|
||||
stale code. `/new` is now a clean minimal form; host pages still use minimal
|
||||
shell HTML until the aser path lands. Posts render via per-block guarded
|
||||
`render-page`; unsupported editor cards (e.g. `~kg-md`) show placeholders by
|
||||
design (no alias shim).
|
||||
- [ ] **5.3 Static-asset serving.** Serve `/scripts/*.js`, `/*.css`, `/wasm/*`
|
||||
from `shared/static`. Host has none today — needs a kernel file-serving
|
||||
route in the `http-listen` server (or a file-read prim + SX static handler).
|
||||
Interim option to defer: reference assets by absolute URL from the existing
|
||||
static host. Gate: `sx-browser.js`/CSS load for a host-served page.
|
||||
- [ ] **5.4 Island hydration.** Confirm a trivial island page boots + hydrates
|
||||
client-side (sx-browser.js) when served by the host. Gate: a counter island
|
||||
increments in the browser.
|
||||
- [~] **5.5 Editor POC — HANDED OFF.** The native SX-island editor is the
|
||||
interactivity layer; per the architecture it lives on the `--http` island
|
||||
pipeline (not the host) and needs browser/Playwright iteration (absent in
|
||||
this worktree). Handoff brief: `plans/blog-editor-island.md`. The host side
|
||||
is READY: `POST /new` ingest is live + proven (form-urlencoded
|
||||
title/sx_content/status → 303); CORS can be added on request if the editor
|
||||
uses fetch. Decision: don't port island hydration into the host; the editor
|
||||
is a docs-side island that publishes to the host.
|
||||
|
||||
**Note:** component SSR is interpreted → slow until the `sx-vm-extensions` JIT
|
||||
loop lands; correctness first, speed follows. Scope spans `hosts/` (page-render
|
||||
exposure + static serving) + `lib/host` (page route type + page handlers).
|
||||
|
||||
**Modern editor — language.** A WYSIWYG editor is a *reactive UI*, so it should be
|
||||
an **SX reactive island** (`defisland` + signals/lakes — the platform's native UI
|
||||
primitive), NOT a guest language (Datalog/Prolog/APL/Haskell are logic/data/array
|
||||
— wrong tool) and NOT a JS lib (Lexical/Koenig, the legacy baggage). The document
|
||||
*model* it edits is **content-on-sx** (structured blocks, CvRDT-ready for
|
||||
collaboration). So: **SX islands for the UI, content-on-sx for the model** — SX
|
||||
all the way down, dogfooding the reactive runtime + content-on-sx + this new
|
||||
page-serving capability. (Legacy `blog/sx/editor.sx` is Lexical/Koenig/Quart-CSRF
|
||||
era — replace, don't resurrect; the `POST /new` ingest already speaks the
|
||||
`sx_content` contract any new editor emits.)
|
||||
|
||||
## Progress log
|
||||
(loop fills this in)
|
||||
|
||||
- **Phase 1 (DONE, 28/28).** `lib/host/{handler,router,feed}.sx` + three test
|
||||
suites + `conformance.sh`. The host is a thin wiring layer: a host handler is a
|
||||
Dream handler that calls a subsystem public API and serialises the result via a
|
||||
shared JSON envelope. First migrated endpoint: `GET /feed`.
|
||||
- **Decision — build on Dream from Phase 1, not a throwaway native model.** The
|
||||
plan front-matter gated Dream to Phase 4, but `dream-on-sx` is merged
|
||||
(commit fe958bda) and its gate (`ocaml-on-sx` P1–5+P6) is green (480/480), so
|
||||
reinventing request/response + routing would be pure duplication. Host reuses
|
||||
Dream's `types.sx` (request/response dicts), `json.sx` (encode), and
|
||||
`router.sx` (`dream-router`/`dream-get`/`dr/flatten-routes`). Phase 4's
|
||||
"adopt Dream ergonomics" is therefore largely already satisfied; what remains
|
||||
for Phase 4 is the live wiring against the real OCaml HTTP server + session.
|
||||
- The OCaml server handing a `dream-request`-shaped dict to SX handlers is a
|
||||
`hosts/` change (out of scope) — tracked under Blockers as the eventual
|
||||
live-wiring step. For now the host layer is exercised purely via conformance.
|
||||
|
||||
- **Phase 2 (middleware + write endpoint DONE, 43/43).** `lib/host/middleware.sx`
|
||||
+ a guarded `POST /feed`. Middleware is plain function composition over Dream's
|
||||
primitives; auth/permission *policy* is injected (token resolver, resource
|
||||
extractor) so the layer is policy-free and testable. ACL authorisation runs
|
||||
against lib/acl's public `acl/permit?` (string atoms work — no symbol coercion
|
||||
needed). The write path proves the auth ∘ permission ∘ action stack end-to-end:
|
||||
401 unauth, 403 unpermitted, 201 + readback on success, 400 on bad body.
|
||||
- **Phase 2 COMPLETE (82/82).** `lib/host/sxtp.sx` adds the SXTP codec + Dream
|
||||
bridge (39-test suite). Key representation calls, learned by probing the runtime:
|
||||
keywords are strings at eval time but the `serialize` primitive renders
|
||||
string-keyed dicts back as `{:k v}` and symbols bare — so messages are
|
||||
string-keyed dicts with verb/status/type as symbols, and a small str-based
|
||||
emitter produces wire-faithful list form. `parse` needs a deep normaliser
|
||||
because parsed keyword tokens are a distinct type (not `=` to string literals).
|
||||
`unquote-splicing` is unreliable here, so the serializer is str-based, not
|
||||
quasiquote-based.
|
||||
- **Next: Phase 3 — strangler migration ledger.** Enumerate the Quart endpoints
|
||||
(use the `rose-ash-services` `svc_routes` MCP tool), track migrated vs proxied,
|
||||
and stand up a golden-response harness against the live Quart responses. Then
|
||||
cut over the smallest whole domain (`likes` or `relations`) as proof.
|
||||
|
||||
- **Phase 3 — ledger module (DONE, 107/107).** `lib/host/ledger.sx` + a 25-test
|
||||
suite. Enumerated the endpoint surface via the `rose-ash-services` MCP
|
||||
(`svc_routes`/`svc_queries`/`svc_actions`): `likes` and `relations` have **no
|
||||
public blueprint routes** — they're internal-only, exposed as
|
||||
`/internal/data/{query}` + `/internal/actions/{action}` (HMAC-signed). The
|
||||
ledger is a pure-data catalogue keyed by (domain, method, path) carrying each
|
||||
endpoint's Quart original, status, and serving SX handler; coverage reports the
|
||||
off-Quart percentage. Cut-over target chosen: **`relations`** (already has a real
|
||||
SX subsystem `lib/relations` — children/parents reads + relate/unrelate writes
|
||||
map straight onto its public API); `likes` stays proxied (no SX lib to dispatch
|
||||
to). NEXT: migrate the `relations` read endpoints onto host handlers (flip their
|
||||
ledger status to `:migrated`) with golden tests.
|
||||
|
||||
- **Phase 3 — relations READ cut-over (DONE, 121/121).** `lib/host/relations.sx`
|
||||
+ a 13-test golden suite; ledger flipped (off-Quart coverage 27% → 45%). The two
|
||||
internal read queries (`get-children`, `get-parents`) now dispatch to the
|
||||
`lib/relations` Datalog graph. Bridge: the Quart `(type, id)` node key maps to a
|
||||
graph atom `(string->symbol "type:id")` with relation-type as the edge kind;
|
||||
optional `child-type`/`parent-type` params filter the result list by `"type:"`
|
||||
prefix (verified live: composite-string nodes round-trip through
|
||||
`relations/relate` → `relations/children`). Golden discipline: `relations` is
|
||||
internal-only (no public Quart route — confirmed via `svc_routes`), so the golden
|
||||
is a **pinned fixture** (a known graph loaded in-test, asserted as
|
||||
`subsystem-call + envelope`) rather than a live Quart capture. Reads are
|
||||
unguarded for now — the signed-internal-auth gate is a separate middleware layer,
|
||||
same as the feed reads. NEXT: relations WRITE actions (`relate`/`unrelate`)
|
||||
behind the auth+ACL pipeline (mirroring POST /feed).
|
||||
|
||||
- **Phase 3 — relations WRITE cut-over (DONE, 132/132).** `lib/host/relations.sx`
|
||||
gains `host/relations-attach`/`-detach` (`POST .../attach-child` + `/detach-child`)
|
||||
and `host/relations-write-routes` — the write side of the container reads,
|
||||
dispatching to `relations/relate`/`unrelate` over the same `"type:id"` node
|
||||
model so an attach is immediately visible through `get-children`. Each runs
|
||||
behind the host pipeline `wrap-errors ∘ require-auth ∘ require-permission`
|
||||
(`"relate"`/`"unrelate"` on `"relations"`) — exactly the POST /feed stack. The
|
||||
relations test suite proves the closed loop end-to-end: 401 unauth, 403 authed-
|
||||
but-unpermitted (graph unchanged), 201 attach → child visible via the migrated
|
||||
read → 200 detach → child gone; 400 on bad/short payloads. The ledger now models
|
||||
the full relations surface (7 endpoints): container reads+writes `:migrated`,
|
||||
typed `relate`/`unrelate`/`can-relate` `:proxied` (registry/cardinality
|
||||
validation not in lib/relations). Off-Quart coverage 45% → **50%** (7/14).
|
||||
`relations` is the first whole *coherent feature* (container relations) fully
|
||||
off Quart. NEXT: golden-response harness vs live Quart, then survey the next
|
||||
domain (blog/likes proxied — likes needs an SX subsystem first).
|
||||
|
||||
- **Phase 4 — live wiring bridge (DONE, 145/145).** `lib/host/server.sx` adapts the
|
||||
native `http-listen` contract (string-keyed req `{"method" "path" "query"
|
||||
"headers" "body"}` → `{:status :headers :body}`) to the Dream app: `host/-native
|
||||
->dream` reassembles `path`+`query` into a target `dream-request` parses;
|
||||
`host/-dream->native` is near-identity (dream-response is already `{:body
|
||||
:headers :status}`). `host/serve port groups` = `http-listen` over
|
||||
`host/native-handler (host/make-app groups)`. `lib/host/serve.sh` boots the full
|
||||
module set (mirrors conformance) and serves in the foreground (container-entry
|
||||
shaped). **Verified live** on a host port: `/health` 200 JSON, `/feed` recent-
|
||||
first seeded activities, `/feed?actor=` filtered, relations `get-children`/`get-
|
||||
parents` real JSON, unknown→404. Demo run was a standalone `sx_server.exe`
|
||||
process (NOT the docker stack) — killed by its own PID, never `pkill` (siblings
|
||||
share the binary). The standing "live wiring is a hosts/ change" Blocker is
|
||||
resolved for the SX side: the bridge is pure SX in `lib/host`; only the *launch*
|
||||
(docker stack + Caddy) remains. NEXT: golden harness, internal-HMAC, then promote
|
||||
into the stack behind a fresh subdomain.
|
||||
|
||||
## SX gotchas + how this loop guards against them
|
||||
|
||||
The SX dev experience has real footguns. Most are statically detectable; the
|
||||
tools exist (`sx_validate`, `deps-check`, `sx_format_check`) but must be *gated*.
|
||||
Hit/relevant here:
|
||||
- **Reserved-name shadowing** — `guard`/`bind`/`conj`/`disj` are special forms or
|
||||
host primitives; a local binding of that name is silently shadowed by the form.
|
||||
(`(let ((guard ...)))` made `(guard handler)` invoke the R7RS `guard` special
|
||||
form → `first: expected list`.) Fix: namespace-prefix every helper
|
||||
(`host/blog--protect`, never `guard`).
|
||||
- **Silent test truncation** — a test file that errors mid-load returns only the
|
||||
tests that ran before the error, reporting a FALSE GREEN ("blog 13 passed, 0
|
||||
failed" while 16 CRUD tests never ran). **GUARDED**: `conformance.sh` now greps
|
||||
the run output for `Undefined symbol` / `Unhandled exception` / `expected list,
|
||||
got` / `[load] … error` and aborts loudly before the tally can hide it.
|
||||
- **`let` is parallel** (bindings can't see each other), **bodies need `(do …)`**
|
||||
(only the last expr evaluates), **`append!` no-ops on map/rest-derived lists**,
|
||||
**parsed keyword tokens ≠ string literals**. These produce wrong *results*, so
|
||||
test coverage catches them as red (not silent) — provided the runner is honest,
|
||||
which the truncation guard now ensures.
|
||||
|
||||
Prevention ladder: parse (`sx_validate` after every edit) → unresolved/shadowed
|
||||
symbols (`deps-check`, candidate pre-commit gate) → fail-loud runner (done) →
|
||||
behavioural tests. A `deps-check`-style "binding shadows a special form" lint
|
||||
would catch the reserved-name class before runtime — a worthwhile follow-up.
|
||||
|
||||
## ⚠ Experimental: unguarded create live on blog.rose-ash.com
|
||||
|
||||
`host/blog-open-create-routes` mounts **`POST /new` with NO auth** (create-only,
|
||||
error-trapped) so the SX editor can publish end-to-end. **Validated live**: an
|
||||
editor-style form POST → 303 → the post renders at `/<slug>/` and lists on `/`.
|
||||
This is a deliberate, short-lived public write hole (create-only — no PUT/DELETE
|
||||
exposed; obscure subdomain). **MUST be gated before real use** — Caddy basicauth
|
||||
on `/new` (the `/root/caddy/auth` dir exists) or session auth once identity lands.
|
||||
Swap `host/blog-open-create-routes` → `host/blog-write-routes <resolver>` to gate.
|
||||
|
||||
## Blockers
|
||||
(loop fills this in)
|
||||
|
||||
- **Live wiring to the native OCaml HTTP server** (Phase 3/4): the prod server in
|
||||
`hosts/` must hand SX handlers a `dream-request` dict and serialise the returned
|
||||
`dream-response`. That is a `hosts/` change (out of scope for this loop, which is
|
||||
`lib/host/**` only). Until then, endpoints are verified via `conformance.sh`, not
|
||||
HTTP. Not blocking Phase 2 (middleware + SXTP + a write endpoint).
|
||||
- **Worktree tooling:** in this `loops/host` worktree every sx-tree *write* tool
|
||||
(`sx_write_file`, `sx_replace_node`, …) raises `yojson "Expected string, got
|
||||
null"` at the MCP layer — same class as the `loops/dream` worktree gotcha, but
|
||||
here even `sx_write_file` fails. Read-side sx-tree tools work. New `.sx` files
|
||||
were created with the `Write` tool (the .sx hook is inactive in this worktree)
|
||||
and each validated afterwards with `sx_validate` to keep the parse guarantee.
|
||||
|
||||
Reference in New Issue
Block a user