Compare commits
35 Commits
loops/drea
...
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 | |||
| b74eecfdd3 | |||
| 768e745076 | |||
| 94f6ab9f2f | |||
| c9a8f05244 | |||
| bf8d0bf245 | |||
| 9051f52f53 | |||
| 4d889716a3 | |||
| 2f626173d9 | |||
| 92c0c853a9 | |||
| 94b889c911 |
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
|
| _ -> raise (Eval_error "http-listen: (port handler)") in
|
||||||
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
||||||
Unix.setsockopt sock Unix.SO_REUSEADDR true;
|
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.bind sock
|
||||||
(Unix.ADDR_INET (Unix.inet_addr_loopback, port));
|
(Unix.ADDR_INET (bind_addr, port));
|
||||||
Unix.listen sock 64;
|
Unix.listen sock 64;
|
||||||
(* SX runtime is shared across threads — serialize handler calls. *)
|
(* SX runtime is shared across threads — serialize handler calls. *)
|
||||||
let mtx = Mutex.create () in
|
let mtx = Mutex.create () in
|
||||||
@@ -807,7 +814,15 @@ let setup_evaluator_bridge env =
|
|||||||
Hashtbl.replace req "body" (String body);
|
Hashtbl.replace req "body" (String body);
|
||||||
Mutex.lock mtx;
|
Mutex.lock mtx;
|
||||||
let resp =
|
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
|
with e -> Mutex.unlock mtx; raise e) in
|
||||||
Mutex.unlock mtx;
|
Mutex.unlock mtx;
|
||||||
let getk k = match resp with
|
let getk k = match resp with
|
||||||
@@ -4854,6 +4869,14 @@ let () =
|
|||||||
else begin
|
else begin
|
||||||
(* Normal persistent server mode *)
|
(* Normal persistent server mode *)
|
||||||
let env = make_server_env () in
|
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)";
|
send "(ready)";
|
||||||
(* Main command loop *)
|
(* Main command loop *)
|
||||||
try
|
try
|
||||||
|
|||||||
@@ -25,8 +25,13 @@
|
|||||||
(define content/append doc-append)
|
(define content/append doc-append)
|
||||||
(define content/blocks doc-blocks)
|
(define content/blocks doc-blocks)
|
||||||
(define content/count doc-count)
|
(define content/count doc-count)
|
||||||
(define content/find doc-find)
|
;; find / has? are TREE-WIDE by id (descend into sections) — so the facade reads
|
||||||
(define content/has? doc-has?)
|
;; back any block content/edit can update or delete. content/find-top / has-top?
|
||||||
|
;; keep the top-level-only lookup for callers that mean the ordered sequence.
|
||||||
|
(define content/find doc-find-deep)
|
||||||
|
(define content/has? doc-has-deep?)
|
||||||
|
(define content/find-top doc-find)
|
||||||
|
(define content/has-top? doc-has?)
|
||||||
(define content/ids doc-ids)
|
(define content/ids doc-ids)
|
||||||
(define content/types doc-types)
|
(define content/types doc-types)
|
||||||
|
|
||||||
|
|||||||
@@ -5,14 +5,19 @@
|
|||||||
;; and returns a NEW document — the input is never mutated, so any version is the
|
;; and returns a NEW document — the input is never mutated, so any version is the
|
||||||
;; head of an op stream (replay-friendly for persist + CRDT merge).
|
;; head of an op stream (replay-friendly for persist + CRDT merge).
|
||||||
;;
|
;;
|
||||||
;; CtDoc also carries optional metadata (title/slug/tags) — see meta.sx for the
|
;; By-id ops (update/delete) and by-id lookup (doc-find-deep/doc-has-deep?) are
|
||||||
;; ergonomic API; they default nil and do not affect block operations.
|
;; TREE-WIDE: they descend into any block carrying a `children` list (i.e.
|
||||||
|
;; sections), since ids are unique across the tree. This keeps the persist
|
||||||
|
;; op-log, content/edit and content/find correct for nested documents.
|
||||||
|
;; insert/move are positional and act at the top level.
|
||||||
|
;;
|
||||||
|
;; CtDoc also carries optional metadata (title/slug/tags) — see meta.sx.
|
||||||
;;
|
;;
|
||||||
;; Op shapes (data, not objects — they are the persist event payload):
|
;; Op shapes (data, not objects — they are the persist event payload):
|
||||||
;; {:op "insert" :block <blk> :after <id|nil>} ; after nil = prepend
|
;; {:op "insert" :block <blk> :after <id|nil>} ; after nil = prepend (top level)
|
||||||
;; {:op "update" :id <id> :field <name> :value <v>}
|
;; {:op "update" :id <id> :field <name> :value <v>} ; tree-wide by id
|
||||||
;; {:op "move" :id <id> :index <n>}
|
;; {:op "move" :id <id> :index <n>} ; top level
|
||||||
;; {:op "delete" :id <id>}
|
;; {:op "delete" :id <id>} ; tree-wide by id
|
||||||
|
|
||||||
(define
|
(define
|
||||||
content-bootstrap-doc!
|
content-bootstrap-doc!
|
||||||
@@ -76,17 +81,58 @@
|
|||||||
(first blocks)
|
(first blocks)
|
||||||
(ct-insert-at (rest blocks) (- i 1) x))))))
|
(ct-insert-at (rest blocks) (- i 1) x))))))
|
||||||
|
|
||||||
|
;; tree-wide remove by id: drop matches at this level, recurse into children
|
||||||
|
;; (blocks carrying a `children` list, i.e. sections).
|
||||||
(define
|
(define
|
||||||
ct-remove-id
|
ct-remove-id
|
||||||
(fn
|
(fn
|
||||||
(blocks id)
|
(blocks id)
|
||||||
(filter (fn (b) (if (= (blk-id b) id) false true)) blocks)))
|
(map
|
||||||
|
(fn
|
||||||
|
(b)
|
||||||
|
(let
|
||||||
|
((ch (st-iv-get b "children")))
|
||||||
|
(if (list? ch) (st-iv-set! b "children" (ct-remove-id ch id)) b)))
|
||||||
|
(filter (fn (b) (if (= (blk-id b) id) false true)) blocks))))
|
||||||
|
|
||||||
|
;; tree-wide replace by id: apply f to the match wherever it sits in the tree.
|
||||||
(define
|
(define
|
||||||
ct-replace-id
|
ct-replace-id
|
||||||
(fn
|
(fn
|
||||||
(blocks id f)
|
(blocks id f)
|
||||||
(map (fn (b) (if (= (blk-id b) id) (f b) b)) blocks)))
|
(map
|
||||||
|
(fn
|
||||||
|
(b)
|
||||||
|
(if
|
||||||
|
(= (blk-id b) id)
|
||||||
|
(f b)
|
||||||
|
(let
|
||||||
|
((ch (st-iv-get b "children")))
|
||||||
|
(if
|
||||||
|
(list? ch)
|
||||||
|
(st-iv-set! b "children" (ct-replace-id ch id f))
|
||||||
|
b))))
|
||||||
|
blocks)))
|
||||||
|
|
||||||
|
;; tree-wide find by id: first block matching id anywhere in the tree, or nil.
|
||||||
|
;; Descends into any `children` list, mirroring ct-replace-id/ct-remove-id.
|
||||||
|
(define
|
||||||
|
ct-find-id
|
||||||
|
(fn
|
||||||
|
(blocks id)
|
||||||
|
(if
|
||||||
|
(= (len blocks) 0)
|
||||||
|
nil
|
||||||
|
(let
|
||||||
|
((b (first blocks)))
|
||||||
|
(if
|
||||||
|
(= (blk-id b) id)
|
||||||
|
b
|
||||||
|
(let
|
||||||
|
((ch (st-iv-get b "children")))
|
||||||
|
(let
|
||||||
|
((nested (if (list? ch) (ct-find-id ch id) nil)))
|
||||||
|
(if (= nested nil) (ct-find-id (rest blocks) id) nested))))))))
|
||||||
|
|
||||||
;; ── query ──
|
;; ── query ──
|
||||||
(define doc-index-of (fn (doc id) (ct-index-of (doc-blocks doc) id)))
|
(define doc-index-of (fn (doc id) (ct-index-of (doc-blocks doc) id)))
|
||||||
@@ -103,6 +149,14 @@
|
|||||||
doc-has?
|
doc-has?
|
||||||
(fn (doc id) (if (= (doc-index-of doc id) -1) false true)))
|
(fn (doc id) (if (= (doc-index-of doc id) -1) false true)))
|
||||||
|
|
||||||
|
;; tree-wide lookup by id — reads a nested block by the same id content/edit can
|
||||||
|
;; update/delete (no section.sx dependency; uses the generic children descent).
|
||||||
|
(define doc-find-deep (fn (doc id) (ct-find-id (doc-blocks doc) id)))
|
||||||
|
|
||||||
|
(define
|
||||||
|
doc-has-deep?
|
||||||
|
(fn (doc id) (if (= (doc-find-deep doc id) nil) false true)))
|
||||||
|
|
||||||
;; ── structural edits (each returns a new document) ──
|
;; ── structural edits (each returns a new document) ──
|
||||||
(define doc-with-blocks (fn (doc blocks) (st-iv-set! doc "blocks" blocks)))
|
(define doc-with-blocks (fn (doc blocks) (st-iv-set! doc "blocks" blocks)))
|
||||||
|
|
||||||
|
|||||||
@@ -1,10 +1,17 @@
|
|||||||
;; content-on-sx — global find/replace across text-bearing blocks.
|
;; content-on-sx — global find/replace across every text-bearing field.
|
||||||
;;
|
;;
|
||||||
;; Replaces every occurrence of `from` with `to` in the text field of text /
|
;; Replaces every occurrence of `from` with `to` in the text-bearing fields of
|
||||||
;; heading / code / quote blocks, tree-wide (via the transform layer). For
|
;; a document, tree-wide (via the transform layer):
|
||||||
;; renaming a term throughout a document. Immutable; case-sensitive.
|
;; - the `text` of text / heading / code / quote / callout blocks
|
||||||
|
;; - the `alt` of image blocks
|
||||||
|
;; - each item of list blocks
|
||||||
|
;; - every header and cell of table blocks
|
||||||
|
;; This is exactly the set asText / stats / summary draw prose from, so a rename
|
||||||
|
;; via content/find-replace and a word count over asText stay consistent.
|
||||||
|
;; Immutable; case-sensitive.
|
||||||
;;
|
;;
|
||||||
;; Requires (loaded by harness): block.sx, transform.sx (content/map-blocks).
|
;; Requires (loaded by harness): block.sx, transform.sx (content/map-blocks),
|
||||||
|
;; table.sx (CtTable ivars).
|
||||||
|
|
||||||
(define
|
(define
|
||||||
fr-in?
|
fr-in?
|
||||||
@@ -15,17 +22,54 @@
|
|||||||
((= (first xs) x) true)
|
((= (first xs) x) true)
|
||||||
(else (fr-in? x (rest xs))))))
|
(else (fr-in? x (rest xs))))))
|
||||||
|
|
||||||
|
(define fr-rep (fn (s from to) (replace (str s) from to)))
|
||||||
|
|
||||||
|
;; Blocks whose prose content find/replace rewrites (matches asText's set).
|
||||||
(define
|
(define
|
||||||
fr-has-text?
|
fr-has-text?
|
||||||
(fn (b) (fr-in? (blk-type b) (list "text" "heading" "code" "quote"))))
|
(fn
|
||||||
|
(b)
|
||||||
|
(fr-in?
|
||||||
|
(blk-type b)
|
||||||
|
(list "text" "heading" "code" "quote" "callout" "image" "list" "table"))))
|
||||||
|
|
||||||
|
;; Per-type field rewrite. Each branch returns a new (copy-on-write) block.
|
||||||
|
(define
|
||||||
|
fr-rewrite
|
||||||
|
(fn
|
||||||
|
(b from to)
|
||||||
|
(let
|
||||||
|
((t (blk-type b)))
|
||||||
|
(cond
|
||||||
|
((= t "image")
|
||||||
|
(blk-set b "alt" (fr-rep (blk-get b "alt") from to)))
|
||||||
|
((= t "list")
|
||||||
|
(let
|
||||||
|
((items (blk-get b "items")))
|
||||||
|
(if
|
||||||
|
(list? items)
|
||||||
|
(blk-set b "items" (map (fn (it) (fr-rep it from to)) items))
|
||||||
|
b)))
|
||||||
|
((= t "table")
|
||||||
|
(let
|
||||||
|
((hs (blk-get b "headers")) (rs (blk-get b "rows")))
|
||||||
|
(let
|
||||||
|
((b1 (if (list? hs) (blk-set b "headers" (map (fn (h) (fr-rep h from to)) hs)) b)))
|
||||||
|
(if
|
||||||
|
(list? rs)
|
||||||
|
(blk-set
|
||||||
|
b1
|
||||||
|
"rows"
|
||||||
|
(map
|
||||||
|
(fn
|
||||||
|
(r)
|
||||||
|
(if (list? r) (map (fn (c) (fr-rep c from to)) r) r))
|
||||||
|
rs))
|
||||||
|
b1))))
|
||||||
|
(else (blk-set b "text" (fr-rep (blk-get b "text") from to)))))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
content/find-replace
|
content/find-replace
|
||||||
(fn
|
(fn
|
||||||
(doc from to)
|
(doc from to)
|
||||||
(content/map-blocks
|
(content/map-blocks doc fr-has-text? (fn (b) (fr-rewrite b from to)))))
|
||||||
doc
|
|
||||||
fr-has-text?
|
|
||||||
(fn
|
|
||||||
(b)
|
|
||||||
(blk-set b "text" (replace (str (blk-get b "text")) from to))))))
|
|
||||||
|
|||||||
@@ -1,10 +1,10 @@
|
|||||||
;; content-on-sx — block query + table of contents.
|
;; content-on-sx — block query + table of contents.
|
||||||
;;
|
;;
|
||||||
;; Collect blocks across the whole tree (descending into sections) by predicate
|
;; Collect blocks across the whole tree (descending into sections) by predicate
|
||||||
;; or type, and derive a table of contents from headings. Tree detection is
|
;; or type, search them by prose, and derive a table of contents from headings.
|
||||||
;; inline (class + st-iv-get) so this needs no section.sx.
|
;; Tree detection is inline (class + st-iv-get) so this needs no section.sx.
|
||||||
;;
|
;;
|
||||||
;; Requires (loaded by harness): block.sx, doc.sx.
|
;; Requires (loaded by harness): block.sx, doc.sx, text.sx (asText for search).
|
||||||
|
|
||||||
(define
|
(define
|
||||||
qry-section?
|
qry-section?
|
||||||
@@ -45,6 +45,30 @@
|
|||||||
content/select-ids
|
content/select-ids
|
||||||
(fn (doc pred) (map (fn (b) (blk-id b)) (content/select doc pred))))
|
(fn (doc pred) (map (fn (b) (blk-id b)) (content/select doc pred))))
|
||||||
|
|
||||||
|
;; Blocks (tree-wide, excluding section containers) whose own prose contains
|
||||||
|
;; `term`. "Prose" is (asText b), so search covers exactly what every block
|
||||||
|
;; exposes as text — text/heading/code/quote/callout text, image alt, list
|
||||||
|
;; items, table headers+cells — with no separate field list to drift from
|
||||||
|
;; asText / find-replace / stats. Case-sensitive substring match.
|
||||||
|
(define
|
||||||
|
content/search-text
|
||||||
|
(fn
|
||||||
|
(doc term)
|
||||||
|
(content/select
|
||||||
|
doc
|
||||||
|
(fn
|
||||||
|
(b)
|
||||||
|
(and
|
||||||
|
(not (qry-section? b))
|
||||||
|
(>= (index-of (asText b) term) 0))))))
|
||||||
|
|
||||||
|
;; Same search, returning matching block ids in document order.
|
||||||
|
(define
|
||||||
|
content/search-text-ids
|
||||||
|
(fn
|
||||||
|
(doc term)
|
||||||
|
(map (fn (b) (blk-id b)) (content/search-text doc term))))
|
||||||
|
|
||||||
;; table of contents: {:id :level :text} for every heading, in document order.
|
;; table of contents: {:id :level :text} for every heading, in document order.
|
||||||
(define
|
(define
|
||||||
content/headings
|
content/headings
|
||||||
|
|||||||
@@ -3,7 +3,7 @@
|
|||||||
"block": {"pass": 38, "fail": 0},
|
"block": {"pass": 38, "fail": 0},
|
||||||
"doc": {"pass": 40, "fail": 0},
|
"doc": {"pass": 40, "fail": 0},
|
||||||
"render": {"pass": 42, "fail": 0},
|
"render": {"pass": 42, "fail": 0},
|
||||||
"api": {"pass": 26, "fail": 0},
|
"api": {"pass": 32, "fail": 0},
|
||||||
"meta": {"pass": 27, "fail": 0},
|
"meta": {"pass": 27, "fail": 0},
|
||||||
"page": {"pass": 7, "fail": 0},
|
"page": {"pass": 7, "fail": 0},
|
||||||
"page-full": {"pass": 4, "fail": 0},
|
"page-full": {"pass": 4, "fail": 0},
|
||||||
@@ -14,14 +14,14 @@
|
|||||||
"tree-edit": {"pass": 17, "fail": 0},
|
"tree-edit": {"pass": 17, "fail": 0},
|
||||||
"move": {"pass": 11, "fail": 0},
|
"move": {"pass": 11, "fail": 0},
|
||||||
"clone": {"pass": 10, "fail": 0},
|
"clone": {"pass": 10, "fail": 0},
|
||||||
"query": {"pass": 13, "fail": 0},
|
"query": {"pass": 20, "fail": 0},
|
||||||
"toc": {"pass": 8, "fail": 0},
|
"toc": {"pass": 8, "fail": 0},
|
||||||
"anchor": {"pass": 6, "fail": 0},
|
"anchor": {"pass": 6, "fail": 0},
|
||||||
"outline": {"pass": 14, "fail": 0},
|
"outline": {"pass": 14, "fail": 0},
|
||||||
"flatten": {"pass": 10, "fail": 0},
|
"flatten": {"pass": 10, "fail": 0},
|
||||||
"transform": {"pass": 12, "fail": 0},
|
"transform": {"pass": 12, "fail": 0},
|
||||||
"normalize": {"pass": 11, "fail": 0},
|
"normalize": {"pass": 11, "fail": 0},
|
||||||
"find-replace": {"pass": 10, "fail": 0},
|
"find-replace": {"pass": 16, "fail": 0},
|
||||||
"stats": {"pass": 17, "fail": 0},
|
"stats": {"pass": 17, "fail": 0},
|
||||||
"summary": {"pass": 14, "fail": 0},
|
"summary": {"pass": 14, "fail": 0},
|
||||||
"index": {"pass": 13, "fail": 0},
|
"index": {"pass": 13, "fail": 0},
|
||||||
@@ -31,7 +31,7 @@
|
|||||||
"data": {"pass": 25, "fail": 0},
|
"data": {"pass": 25, "fail": 0},
|
||||||
"wire": {"pass": 11, "fail": 0},
|
"wire": {"pass": 11, "fail": 0},
|
||||||
"validate": {"pass": 23, "fail": 0},
|
"validate": {"pass": 23, "fail": 0},
|
||||||
"store": {"pass": 33, "fail": 0},
|
"store": {"pass": 46, "fail": 0},
|
||||||
"snapshot": {"pass": 20, "fail": 0},
|
"snapshot": {"pass": 20, "fail": 0},
|
||||||
"crdt": {"pass": 34, "fail": 0},
|
"crdt": {"pass": 34, "fail": 0},
|
||||||
"crdt-tree": {"pass": 21, "fail": 0},
|
"crdt-tree": {"pass": 21, "fail": 0},
|
||||||
@@ -42,7 +42,7 @@
|
|||||||
"md-doc": {"pass": 12, "fail": 0},
|
"md-doc": {"pass": 12, "fail": 0},
|
||||||
"fed": {"pass": 20, "fail": 0}
|
"fed": {"pass": 20, "fail": 0}
|
||||||
},
|
},
|
||||||
"total_pass": 746,
|
"total_pass": 778,
|
||||||
"total_fail": 0,
|
"total_fail": 0,
|
||||||
"total": 746
|
"total": 778
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -7,7 +7,7 @@ _Generated by `lib/content/conformance.sh`_
|
|||||||
| block | 38 | 0 | 38 |
|
| block | 38 | 0 | 38 |
|
||||||
| doc | 40 | 0 | 40 |
|
| doc | 40 | 0 | 40 |
|
||||||
| render | 42 | 0 | 42 |
|
| render | 42 | 0 | 42 |
|
||||||
| api | 26 | 0 | 26 |
|
| api | 32 | 0 | 32 |
|
||||||
| meta | 27 | 0 | 27 |
|
| meta | 27 | 0 | 27 |
|
||||||
| page | 7 | 0 | 7 |
|
| page | 7 | 0 | 7 |
|
||||||
| page-full | 4 | 0 | 4 |
|
| page-full | 4 | 0 | 4 |
|
||||||
@@ -18,14 +18,14 @@ _Generated by `lib/content/conformance.sh`_
|
|||||||
| tree-edit | 17 | 0 | 17 |
|
| tree-edit | 17 | 0 | 17 |
|
||||||
| move | 11 | 0 | 11 |
|
| move | 11 | 0 | 11 |
|
||||||
| clone | 10 | 0 | 10 |
|
| clone | 10 | 0 | 10 |
|
||||||
| query | 13 | 0 | 13 |
|
| query | 20 | 0 | 20 |
|
||||||
| toc | 8 | 0 | 8 |
|
| toc | 8 | 0 | 8 |
|
||||||
| anchor | 6 | 0 | 6 |
|
| anchor | 6 | 0 | 6 |
|
||||||
| outline | 14 | 0 | 14 |
|
| outline | 14 | 0 | 14 |
|
||||||
| flatten | 10 | 0 | 10 |
|
| flatten | 10 | 0 | 10 |
|
||||||
| transform | 12 | 0 | 12 |
|
| transform | 12 | 0 | 12 |
|
||||||
| normalize | 11 | 0 | 11 |
|
| normalize | 11 | 0 | 11 |
|
||||||
| find-replace | 10 | 0 | 10 |
|
| find-replace | 16 | 0 | 16 |
|
||||||
| stats | 17 | 0 | 17 |
|
| stats | 17 | 0 | 17 |
|
||||||
| summary | 14 | 0 | 14 |
|
| summary | 14 | 0 | 14 |
|
||||||
| index | 13 | 0 | 13 |
|
| index | 13 | 0 | 13 |
|
||||||
@@ -35,7 +35,7 @@ _Generated by `lib/content/conformance.sh`_
|
|||||||
| data | 25 | 0 | 25 |
|
| data | 25 | 0 | 25 |
|
||||||
| wire | 11 | 0 | 11 |
|
| wire | 11 | 0 | 11 |
|
||||||
| validate | 23 | 0 | 23 |
|
| validate | 23 | 0 | 23 |
|
||||||
| store | 33 | 0 | 33 |
|
| store | 46 | 0 | 46 |
|
||||||
| snapshot | 20 | 0 | 20 |
|
| snapshot | 20 | 0 | 20 |
|
||||||
| crdt | 34 | 0 | 34 |
|
| crdt | 34 | 0 | 34 |
|
||||||
| crdt-tree | 21 | 0 | 21 |
|
| crdt-tree | 21 | 0 | 21 |
|
||||||
@@ -45,4 +45,4 @@ _Generated by `lib/content/conformance.sh`_
|
|||||||
| md-import | 38 | 0 | 38 |
|
| md-import | 38 | 0 | 38 |
|
||||||
| md-doc | 12 | 0 | 12 |
|
| md-doc | 12 | 0 | 12 |
|
||||||
| fed | 20 | 0 | 20 |
|
| fed | 20 | 0 | 20 |
|
||||||
| **Total** | **746** | **0** | **746** |
|
| **Total** | **778** | **0** | **778** |
|
||||||
|
|||||||
@@ -5,9 +5,10 @@
|
|||||||
;; replay of its op stream up to a sequence number; the materialised doc is a
|
;; replay of its op stream up to a sequence number; the materialised doc is a
|
||||||
;; cache, never primary state.
|
;; cache, never primary state.
|
||||||
;;
|
;;
|
||||||
;; Requires (loaded by the harness): block.sx, doc.sx, and persist
|
;; Requires (loaded by the harness): block.sx, doc.sx, section.sx (doc-deep-find
|
||||||
;; (event/backend/log/kv/api). The persist backend `b` is opened by the caller
|
;; + doc-tree-ids, for the tree-wide diff), plus persist (event/backend/log/kv/
|
||||||
;; via (persist/open) and injected — content knows nothing about which backend.
|
;; api). The persist backend `b` is opened by the caller via (persist/open) and
|
||||||
|
;; injected — content knows nothing about which backend.
|
||||||
|
|
||||||
(define content/-stream (fn (doc-id) (str "content:" doc-id)))
|
(define content/-stream (fn (doc-id) (str "content:" doc-id)))
|
||||||
|
|
||||||
@@ -69,11 +70,18 @@
|
|||||||
(fn (b doc-id) (map (fn (ev) {:type (persist/event-type ev) :at (persist/event-at ev) :seq (persist/event-seq ev)}) (content/log b doc-id))))
|
(fn (b doc-id) (map (fn (ev) {:type (persist/event-type ev) :at (persist/event-at ev) :seq (persist/event-seq ev)}) (content/log b doc-id))))
|
||||||
|
|
||||||
;; ── diff between two materialised document versions ──
|
;; ── diff between two materialised document versions ──
|
||||||
;; Returns {:added (ids) :removed (ids) :changed (ids)} where changed = ids
|
;; Tree-wide: ids are enumerated across the whole block tree (descending into
|
||||||
;; present in both whose block content differs.
|
;; sections), so nested-block adds/removes/changes are detected, not just
|
||||||
(define
|
;; top-level ones. Returns {:added :removed :changed} (lists of ids):
|
||||||
content/-missing?
|
;; :added — ids present (anywhere) in `new` but not in `old`
|
||||||
(fn (doc id) (= (ct-index-of (doc-blocks doc) id) -1)))
|
;; :removed — ids present (anywhere) in `old` but not in `new`
|
||||||
|
;; :changed — content blocks present in both whose block value differs
|
||||||
|
;; Section containers never appear in :changed (they hold no own content — a
|
||||||
|
;; child change surfaces as that child's own entry); a whole section appearing
|
||||||
|
;; or disappearing shows up in :added / :removed by its id.
|
||||||
|
(define content/-all-ids (fn (doc) (doc-tree-ids doc)))
|
||||||
|
|
||||||
|
(define content/-missing? (fn (doc id) (= (doc-deep-find doc id) nil)))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
content/-changed
|
content/-changed
|
||||||
@@ -83,15 +91,16 @@
|
|||||||
(fn
|
(fn
|
||||||
(id)
|
(id)
|
||||||
(let
|
(let
|
||||||
((bo (doc-find old id)) (bn (doc-find new id)))
|
((bo (doc-deep-find old id)) (bn (doc-deep-find new id)))
|
||||||
(cond
|
(cond
|
||||||
((= bo nil) false)
|
((= bo nil) false)
|
||||||
((= bn nil) false)
|
((= bn nil) false)
|
||||||
|
((= (blk-type bo) "section") false)
|
||||||
((= bo bn) false)
|
((= bo bn) false)
|
||||||
(else true))))
|
(else true))))
|
||||||
(doc-ids old))))
|
(content/-all-ids old))))
|
||||||
|
|
||||||
(define content/diff (fn (old new) {:changed (content/-changed old new) :removed (filter (fn (id) (content/-missing? new id)) (doc-ids old)) :added (filter (fn (id) (content/-missing? old id)) (doc-ids new))}))
|
(define content/diff (fn (old new) {:changed (content/-changed old new) :removed (filter (fn (id) (content/-missing? new id)) (content/-all-ids old)) :added (filter (fn (id) (content/-missing? old id)) (content/-all-ids new))}))
|
||||||
|
|
||||||
;; convenience: diff two persisted versions by seq.
|
;; convenience: diff two persisted versions by seq.
|
||||||
(define
|
(define
|
||||||
|
|||||||
@@ -97,3 +97,37 @@
|
|||||||
"render original unchanged"
|
"render original unchanged"
|
||||||
(content/render d1 "html")
|
(content/render d1 "html")
|
||||||
"<h1>Hi</h1><p>World</p>")
|
"<h1>Hi</h1><p>World</p>")
|
||||||
|
|
||||||
|
;; ── facade find/has? are TREE-WIDE (reach into sections); find-top/has-top?
|
||||||
|
;; keep the top-level-only lookup. This makes the read-by-id surface consistent
|
||||||
|
;; with content/edit, whose update/delete are already tree-wide. ──
|
||||||
|
(content-bootstrap-section!)
|
||||||
|
(define
|
||||||
|
nd
|
||||||
|
(content/append
|
||||||
|
(content/empty "nested")
|
||||||
|
(mk-section
|
||||||
|
"sec"
|
||||||
|
(list (content/block "text" "inner" (list (list "text" "deep")))))))
|
||||||
|
(content-test
|
||||||
|
"find nested (deep)"
|
||||||
|
(blk-id (content/find nd "inner"))
|
||||||
|
"inner")
|
||||||
|
(content-test "has? nested (deep)" (content/has? nd "inner") true)
|
||||||
|
(content-test "find-top misses nested" (content/find-top nd "inner") nil)
|
||||||
|
(content-test "has-top? misses nested" (content/has-top? nd "inner") false)
|
||||||
|
(content-test
|
||||||
|
"find-top sees top-level"
|
||||||
|
(blk-id (content/find-top nd "sec"))
|
||||||
|
"sec")
|
||||||
|
;; a nested block updated by id via content/edit is now readable by id via
|
||||||
|
;; content/find (was impossible when find was top-level-only).
|
||||||
|
(content-test
|
||||||
|
"edit-then-find nested round-trip"
|
||||||
|
(str
|
||||||
|
(blk-send
|
||||||
|
(content/find
|
||||||
|
(content/edit nd (content/update "inner" "text" "edited"))
|
||||||
|
"inner")
|
||||||
|
"text"))
|
||||||
|
"edited")
|
||||||
|
|||||||
@@ -1,8 +1,10 @@
|
|||||||
;; Extension — global find/replace across text-bearing blocks.
|
;; Extension — global find/replace across every text-bearing field.
|
||||||
|
|
||||||
(st-bootstrap-classes!)
|
(st-bootstrap-classes!)
|
||||||
(content/bootstrap!)
|
(content/bootstrap!)
|
||||||
(content-bootstrap-section!)
|
(content-bootstrap-section!)
|
||||||
|
(content-bootstrap-callout!)
|
||||||
|
(content-bootstrap-table!)
|
||||||
|
|
||||||
(define
|
(define
|
||||||
d
|
d
|
||||||
@@ -30,11 +32,12 @@
|
|||||||
(str (blk-send (doc-deep-find r "n") "text"))
|
(str (blk-send (doc-deep-find r "n") "text"))
|
||||||
"nested Bar")
|
"nested Bar")
|
||||||
|
|
||||||
;; ── does NOT touch image alt/src (not a text field) ──
|
;; ── image alt IS a text field (asText ^ alt), so it is rewritten ──
|
||||||
(content-test
|
(content-test
|
||||||
"image alt untouched"
|
"image alt replaced"
|
||||||
(str (blk-send (doc-deep-find r "img") "alt"))
|
(str (blk-send (doc-deep-find r "img") "alt"))
|
||||||
"Foo alt")
|
"Bar alt")
|
||||||
|
;; ── but src is a URL, not prose, so it stays put ──
|
||||||
(content-test
|
(content-test
|
||||||
"image src untouched"
|
"image src untouched"
|
||||||
(str (blk-send (doc-deep-find r "img") "src"))
|
(str (blk-send (doc-deep-find r "img") "src"))
|
||||||
@@ -76,6 +79,68 @@
|
|||||||
(str (blk-send (doc-find r2 "q") "text"))
|
(str (blk-send (doc-find r2 "q") "text"))
|
||||||
"new saying")
|
"new saying")
|
||||||
|
|
||||||
|
;; ── callout text is covered (consistency with asText/stats/summary) ──
|
||||||
|
(content-test
|
||||||
|
"replace callout text"
|
||||||
|
(str
|
||||||
|
(blk-send
|
||||||
|
(doc-find
|
||||||
|
(content/find-replace
|
||||||
|
(doc-append (doc-empty "d") (mk-callout "co" "note" "Foo here"))
|
||||||
|
"Foo"
|
||||||
|
"Bar")
|
||||||
|
"co")
|
||||||
|
"text"))
|
||||||
|
"Bar here")
|
||||||
|
(content-test
|
||||||
|
"callout kind untouched by text replace"
|
||||||
|
(str
|
||||||
|
(blk-send
|
||||||
|
(doc-find
|
||||||
|
(content/find-replace
|
||||||
|
(doc-append (doc-empty "d") (mk-callout "co" "note" "x"))
|
||||||
|
"note"
|
||||||
|
"X")
|
||||||
|
"co")
|
||||||
|
"kind"))
|
||||||
|
"note")
|
||||||
|
|
||||||
|
;; ── list items are rewritten (asText folds items) ──
|
||||||
|
(define
|
||||||
|
rl
|
||||||
|
(content/find-replace
|
||||||
|
(doc-append
|
||||||
|
(doc-empty "d")
|
||||||
|
(mk-list "l" false (list "Foo one" "two Foo")))
|
||||||
|
"Foo"
|
||||||
|
"Bar"))
|
||||||
|
(content-test
|
||||||
|
"replace first list item"
|
||||||
|
(str (first (blk-send (doc-find rl "l") "items")))
|
||||||
|
"Bar one")
|
||||||
|
(content-test
|
||||||
|
"replace second list item"
|
||||||
|
(str (first (rest (blk-send (doc-find rl "l") "items"))))
|
||||||
|
"two Bar")
|
||||||
|
|
||||||
|
;; ── table headers + cells are rewritten (asText folds rows) ──
|
||||||
|
(define
|
||||||
|
rt
|
||||||
|
(content/find-replace
|
||||||
|
(doc-append
|
||||||
|
(doc-empty "d")
|
||||||
|
(mk-table "t" (list "Foo head") (list (list "a Foo" "b"))))
|
||||||
|
"Foo"
|
||||||
|
"Bar"))
|
||||||
|
(content-test
|
||||||
|
"replace table header"
|
||||||
|
(str (first (table-headers (doc-find rt "t"))))
|
||||||
|
"Bar head")
|
||||||
|
(content-test
|
||||||
|
"replace table cell"
|
||||||
|
(str (first (first (table-rows (doc-find rt "t")))))
|
||||||
|
"a Bar")
|
||||||
|
|
||||||
;; ── no match → unchanged render ──
|
;; ── no match → unchanged render ──
|
||||||
(content-test
|
(content-test
|
||||||
"no match"
|
"no match"
|
||||||
|
|||||||
@@ -1,8 +1,11 @@
|
|||||||
;; Extension — block query + table of contents.
|
;; Extension — block query + table of contents + prose search.
|
||||||
|
|
||||||
(st-bootstrap-classes!)
|
(st-bootstrap-classes!)
|
||||||
(content/bootstrap!)
|
(content/bootstrap!)
|
||||||
|
(content-bootstrap-text!)
|
||||||
(content-bootstrap-section!)
|
(content-bootstrap-section!)
|
||||||
|
(content-bootstrap-table!)
|
||||||
|
(content-bootstrap-callout!)
|
||||||
|
|
||||||
(define
|
(define
|
||||||
d
|
d
|
||||||
@@ -87,3 +90,49 @@
|
|||||||
"deep toc level"
|
"deep toc level"
|
||||||
(get (first (content/headings deep)) :level)
|
(get (first (content/headings deep)) :level)
|
||||||
3)
|
3)
|
||||||
|
|
||||||
|
;; ── prose search (content/search-text) ──
|
||||||
|
;; "cat" appears in text, image alt, a list item, a table cell, and a callout
|
||||||
|
;; — every text-bearing field — so search must find all five via asText.
|
||||||
|
(define
|
||||||
|
sd
|
||||||
|
(doc-append
|
||||||
|
(doc-append
|
||||||
|
(doc-append
|
||||||
|
(doc-append
|
||||||
|
(doc-append
|
||||||
|
(doc-empty "sd")
|
||||||
|
(mk-heading "sh" 1 "Welcome aboard"))
|
||||||
|
(mk-text "st" "the cat sat"))
|
||||||
|
(mk-image "si" "/x.png" "a cat photo"))
|
||||||
|
(mk-list "sl" false (list "first cat" "second dog")))
|
||||||
|
(mk-section
|
||||||
|
"sec"
|
||||||
|
(list
|
||||||
|
(mk-table "stb" (list "Animal") (list (list "cat") (list "fish")))
|
||||||
|
(mk-callout "sc" "note" "beware of cat")))))
|
||||||
|
|
||||||
|
(content-test
|
||||||
|
"search across every text-bearing field"
|
||||||
|
(content/search-text-ids sd "cat")
|
||||||
|
(list "st" "si" "sl" "stb" "sc"))
|
||||||
|
(content-test "search count" (len (content/search-text sd "cat")) 5)
|
||||||
|
(content-test
|
||||||
|
"search heading text"
|
||||||
|
(content/search-text-ids sd "Welcome")
|
||||||
|
(list "sh"))
|
||||||
|
(content-test
|
||||||
|
"search list item only"
|
||||||
|
(content/search-text-ids sd "dog")
|
||||||
|
(list "sl"))
|
||||||
|
(content-test "search no match" (content/search-text-ids sd "zzz") (list))
|
||||||
|
;; section containers are excluded — a term living only inside a section's
|
||||||
|
;; children returns the child, never the section wrapper.
|
||||||
|
(content-test
|
||||||
|
"search excludes section wrapper"
|
||||||
|
(content/search-text-ids sd "fish")
|
||||||
|
(list "stb"))
|
||||||
|
(content-test
|
||||||
|
"search returns block objects"
|
||||||
|
(blk-id (first (content/search-text sd "Welcome")))
|
||||||
|
"sh")
|
||||||
|
|||||||
@@ -151,3 +151,58 @@
|
|||||||
"op-log media type"
|
"op-log media type"
|
||||||
(blk-type (doc-find (content/head B3 "rich") "v"))
|
(blk-type (doc-find (content/head B3 "rich") "v"))
|
||||||
"media")
|
"media")
|
||||||
|
|
||||||
|
;; ── op-log update/delete reach NESTED blocks (tree-wide by id) ──
|
||||||
|
(content-bootstrap-section!)
|
||||||
|
(define B4 (persist/open))
|
||||||
|
(content/commit!
|
||||||
|
B4
|
||||||
|
"nest"
|
||||||
|
(op-insert (mk-section "sec" (list (mk-text "n" "orig"))) nil)
|
||||||
|
1)
|
||||||
|
(content/commit! B4 "nest" (op-update "n" "text" "edited") 2)
|
||||||
|
(content-test
|
||||||
|
"op-log nested update"
|
||||||
|
(str (blk-send (doc-deep-find (content/head B4 "nest") "n") "text"))
|
||||||
|
"edited")
|
||||||
|
(content-test
|
||||||
|
"op-log nested update tree intact"
|
||||||
|
(doc-tree-ids (content/head B4 "nest"))
|
||||||
|
(list "sec" "n"))
|
||||||
|
(content/commit! B4 "nest" (op-delete "n") 3)
|
||||||
|
(content-test
|
||||||
|
"op-log nested delete"
|
||||||
|
(doc-tree-ids (content/head B4 "nest"))
|
||||||
|
(list "sec"))
|
||||||
|
(content-test
|
||||||
|
"op-log nested delete via content/at seq2"
|
||||||
|
(doc-tree-ids (content/at B4 "nest" 2))
|
||||||
|
(list "sec" "n"))
|
||||||
|
|
||||||
|
;; ── diff is TREE-WIDE: nested-block add/change/remove are detected, and
|
||||||
|
;; section containers never appear in :changed (a top-level-only diff would miss
|
||||||
|
;; "n" entirely and instead flag the section). ──
|
||||||
|
(define dn01 (content/diff-versions B4 "nest" 0 1))
|
||||||
|
(content-test
|
||||||
|
"diff nested added (section + child)"
|
||||||
|
(get dn01 :added)
|
||||||
|
(list "sec" "n"))
|
||||||
|
(content-test "diff nested added removed empty" (get dn01 :removed) (list))
|
||||||
|
(content-test "diff nested added changed empty" (get dn01 :changed) (list))
|
||||||
|
|
||||||
|
(define dn12 (content/diff-versions B4 "nest" 1 2))
|
||||||
|
(content-test
|
||||||
|
"diff nested changed child only"
|
||||||
|
(get dn12 :changed)
|
||||||
|
(list "n"))
|
||||||
|
(content-test "diff nested changed no add" (get dn12 :added) (list))
|
||||||
|
(content-test "diff nested changed no remove" (get dn12 :removed) (list))
|
||||||
|
|
||||||
|
(define dn23 (content/diff-versions B4 "nest" 2 3))
|
||||||
|
(content-test "diff nested removed child" (get dn23 :removed) (list "n"))
|
||||||
|
(content-test "diff nested removed no change" (get dn23 :changed) (list))
|
||||||
|
|
||||||
|
(content-test
|
||||||
|
"diff nested no-op"
|
||||||
|
(get (content/diff-versions B4 "nest" 1 1) :changed)
|
||||||
|
(list))
|
||||||
|
|||||||
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}))
|
||||||
594
plans/abstractions.md
Normal file
594
plans/abstractions.md
Normal file
@@ -0,0 +1,594 @@
|
|||||||
|
# Abstraction Radar — backlog
|
||||||
|
|
||||||
|
Maintained by the read-only `radar` loop (see `plans/agent-briefings/radar-loop.md`).
|
||||||
|
Detection only — implementation is a separate, coordinated step owned by the
|
||||||
|
relevant subsystem loop, never by radar.
|
||||||
|
|
||||||
|
**AHA gate to reach _Proposed_:** ≥3 real consumers · all past Phase 2 & API-stable ·
|
||||||
|
structurally identical (file:line evidence) · a natural home (usually NOT lib/guest).
|
||||||
|
Anything short → _Watching_ (what's missing) or _Rejected_ (why).
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## Last scan
|
||||||
|
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 32)
|
||||||
|
- **Pass 32 — A1 DONE.** `loops/conformance` merged to architecture (`db76cc8c`); 13 adopters
|
||||||
|
now on the shared driver; radar spot-checked common-lisp = 487/487 green post-merge →
|
||||||
|
coordination flag CLEARED. A1 moved to a new **Done** section. New nascent subsystems
|
||||||
|
`dream` + `maude` (0 files), `fed-prims` resumed (mutex-deadlock fix). The idle
|
||||||
|
`a1-conformance` loop can be retired (worklist complete).
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 31)
|
||||||
|
- **Pass 31 — A1 conformance loop WORKLIST COMPLETE.** tcl excluded (foreign `*.tcl`); final:
|
||||||
|
4 migrated (common-lisp/erlang/feed/go) + 5 excluded (forth/js/ocaml/smalltalk/tcl). A1 =
|
||||||
|
**12 on shared driver + 6 excluded**; only the parity-gated merge to architecture remains.
|
||||||
|
commerce shipped a refund saga on flow (2nd flow use) + finished Phase 5 → going quiescent.
|
||||||
|
relations building graph algos (all-paths) — still unconsumed (W9 unchanged).
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 30)
|
||||||
|
- **Pass 30:** conformance loop near done — `ocaml` + `smalltalk` excluded (both foreign
|
||||||
|
`test.sh`/corpus runners, as predicted). Tally: 4 migrated, 4 excluded, **tcl only** left.
|
||||||
|
Next A1 milestone = the `loops/conformance`→architecture merge under adopter-parity. No
|
||||||
|
new candidate; relations/artdag steady (no new W9 delegation).
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 29)
|
||||||
|
- **Pass 29:** conformance loop excluded `js` (test262 fixtures) → 4 migrated + 2 excluded,
|
||||||
|
3 remain (ocaml/smalltalk/tcl). New subsystems advancing fast: `relations` → Phase 4
|
||||||
|
federation, `artdag` → Phase 6 federation → both fold into W1 (now 7 federation modules,
|
||||||
|
theme-not-shape holds) and W9 (relations past Phase 2 but not yet consumed by anyone).
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 28)
|
||||||
|
- **Pass 28 — fleet expanding again.** Conformance loop: `go` migrated 609/609; **`forth`
|
||||||
|
excluded** (foreign Forth corpus — classify-then-exclude working). 4 migrated +1 excluded
|
||||||
|
on the branch; js/ocaml/smalltalk/tcl remain. **2 new subsystems:** `relations` (Phase 1,
|
||||||
|
parent/child rel facts → new W9 nascent watch) and `artdag` (nascent, 0 files). `events`
|
||||||
|
MERGED to architecture (its persist+flow adoption now integrated — W4/W8 landed). Briefing
|
||||||
|
commit hints more incoming: `dream`, `host`, +5 language chisels.
|
||||||
|
- **Date:** 2026-06-07 (radar loop, passes 26–27)
|
||||||
|
- **Passes 26–27 (routine tracking):** conformance loop steady at ~1 migration/iteration —
|
||||||
|
erlang 761/761, then feed 189/189. A1 = 8 on architecture + 3 on the branch; 6 remain.
|
||||||
|
W4 still gated (host-persist adapter not landed); no new subsystem; app loops on
|
||||||
|
incremental domain work (commerce Phase 5 payment envelope, content/events/identity/fed-sx).
|
||||||
|
Nothing new to discover; merge-time adopter-parity flag still open.
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 25)
|
||||||
|
- **Pass 25:** A1 → **8 adopters** (events via its own loop) + common-lisp 487/487 on the
|
||||||
|
conformance branch. The conformance loop **extended the shared `lib/guest` driver**
|
||||||
|
(per-suite counters/preloads) to do it → raised a **coordination flag in A1**: verify the
|
||||||
|
branch is non-regressive against all 8 adopters before merging to architecture. commerce
|
||||||
|
drafting Phase 5 provider-neutral payment envelope. No new candidate; A1 advancing fast.
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 24)
|
||||||
|
- **Pass 24 — three real updates.** (1) **A1 → 7 adopters** (search migrated, counters mode
|
||||||
|
— corrects the earlier exclusion). (2) The dedicated `conformance` loop ran its 1st
|
||||||
|
iteration: refused to force-migrate common-lisp (parity gate worked) and surfaced a
|
||||||
|
**driver feature-gap** (per-suite counters + preloads) gating the complex multi-suite
|
||||||
|
candidates → A1 now splits simple-now vs gated-on-driver-enhancement. (3) **W8 commerce
|
||||||
|
is LIVE** ("order lifecycle as a durable flow-on-sx flow, Phase 3 done") → 2 live flow
|
||||||
|
consumers. events shipped TZ/DST; mod reverted its extraction note (declined on re-read).
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 23)
|
||||||
|
- **Pass 23 — trigger fired (empty streak ends at 19–22).** commerce recorded a Phase 3
|
||||||
|
**flow-integration design** (order saga as a flow-on-sx flow, payment suspended until
|
||||||
|
webhook resume) → 2nd durable-flow consumer; **W8 broadened** from "delivery" to
|
||||||
|
"externally-resumed orchestration on lib/flow." events made its federation transport
|
||||||
|
**fed-sx-ready** (injected) → reinforces W1's 5/5 inject-fed-sx seam. acl left tmux
|
||||||
|
(now fully quiescent). host-persist adapter still not landed (W4 migration still gated).
|
||||||
|
- **Empty-discovery streak: passes 19–22** (last verified pass 22). Fleet at steady state —
|
||||||
|
active loops (content CvRDT, events recurrence/reschedule, identity grant-mgmt, fed-sx
|
||||||
|
outbox internals) are building *inside* their domains, not cross-cutting infra. Census
|
||||||
|
exhausted (p17); all gates re-tested (W1 p18, W2 p19). No new candidate clears any gate.
|
||||||
|
- **Radar is now trigger-driven.** The next substantive pass needs one of: **(a)** a new
|
||||||
|
subsystem worktree spawning (auto-joins scan), or **(b)** host-persist's durable adapter
|
||||||
|
landing → unblocks the W4 acl/mod→persist/log migration, or **(c)** a quiescent
|
||||||
|
subsystem (acl/mod/search/commerce, static ~9–16 passes) resuming. Polling ~hourly until
|
||||||
|
one fires; will tighten cadence then.
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 20)
|
||||||
|
- **Pass 20 — honest empty pass.** 3 new census recurrences since p17 (normalize/index ×2,
|
||||||
|
query ×3) — all **name collisions** (same noun, domain-specific op), added to the table.
|
||||||
|
Recorded the meta-pattern: the fleet shares vocabulary, not structure. Most subsystems
|
||||||
|
quiescent (acl/mod/search/commerce static ~9-15 passes = API-stable); only events/
|
||||||
|
identity/content/fed-sx still committing domain features. No new gate-clearer.
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 19)
|
||||||
|
- **Pass 19 — honest empty pass.** Scanned 10 active subsystems. content/index.sx is a
|
||||||
|
blog index/tag-cloud listing (presentation, not full-text search — no search reinvention)
|
||||||
|
and content/multi-doc indexing adds no per-viewer filter. **W2 re-tested: still 2**
|
||||||
|
(feed, search) — acl's `permit?`-like matches are its own authZ *engine* (the home),
|
||||||
|
not a downstream read filter. No new candidate cleared any gate.
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 18)
|
||||||
|
- **Pass 18 — W1 gate re-test.** events shipped Phase 4 federation (5th consumer): a 5th
|
||||||
|
divergent merge (sorted agenda + `:origin` provenance), trust-gate = runtime list
|
||||||
|
membership (shares mod's mechanism, not acl's). Reinforces W1's "theme not shape" — but
|
||||||
|
the **inject-fed-sx-transport seam is now 5/5**, strengthening "all are fed-sx
|
||||||
|
consumers-in-waiting." Trust sub-pattern refined: mod+events (runtime set) vs acl (rule).
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 17)
|
||||||
|
- **Pass 17 — filename census declared EXHAUSTED** (see the Census-status table above).
|
||||||
|
Examined the last unswept ≥2 recurrences (schema/engine = acl⇄mod substrate twins;
|
||||||
|
catalog/batch = name collisions; store = divergent). No new candidate. Incremental churn
|
||||||
|
elsewhere (content 621/621, identity PAR, events reminders). Future passes pivot from
|
||||||
|
censusing to re-testing gates as consumers mature.
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 16)
|
||||||
|
- **Pass 16:** events started Phase 3 — **durable notification delivery on `lib/flow`**
|
||||||
|
(new W8: at-least-once + idempotency exemplar; fed-sx/mod roll their own outbox). The two
|
||||||
|
`notify.sx` (feed vs events) are a name collision (read-side digest vs delivery), noted
|
||||||
|
in W8. Substrate-adoption story deepening: app domains now consume persist (content/
|
||||||
|
commerce/events), flow (events), commerce (events), acl-authZ (identity).
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 15)
|
||||||
|
- **Pass 15:** added the **scanning-method note** above after `query.sx` again proved to
|
||||||
|
be merged-lib copies (lib/prolog + lib/persist in every worktree). Corrected census
|
||||||
|
surfaced `wire`×2 (content+mod) → Rejected (shared role, divergent structure: generic SX
|
||||||
|
serializer vs bespoke pipe-format under a Prolog-env string-prim constraint). events↔
|
||||||
|
commerce integration appeared (paid tickets); acl/mod/search quiescent ~7 passes (now
|
||||||
|
API-stable). No new gate-clearer.
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 14)
|
||||||
|
- **Pass 14:** filename census flagged `snapshot`×?? — but the `*/lib/persist/snapshot.sx`
|
||||||
|
copies are just the merged `lib/persist` in each worktree, NOT consumers (same artifact
|
||||||
|
as `lib/feed/rank.sx` everywhere). The one distinct file, `content/snapshot.sx`,
|
||||||
|
reimplements persist's projection-checkpoint on raw KV instead of using `persist/snapshot`
|
||||||
|
→ new W7 (persist-adoption nudge). `audit`×3 = the W4 fakes (acl/mod/identity), known.
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 13)
|
||||||
|
- **Pass 13 — honest re-test, no gate-clearer.** Re-tested the two longest-waiting gates
|
||||||
|
against the maturing app-domain loops: **W2** (per-viewer visibility) still 2 consumers
|
||||||
|
(feed, search) — commerce/content/events/identity add no per-viewer read filter; **W3**
|
||||||
|
(pagination) still 2 (feed, search) — `content/page.sx` is an HTML wrapper, not
|
||||||
|
pagination (filename collision, noted in W3). Incremental churn only elsewhere.
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 12)
|
||||||
|
- **Pass 12:** `events` shipped **transactional booking on persist** (3rd live persist
|
||||||
|
consumer) using `persist/append-expect` (optimistic-concurrency CAS, lock-free capacity
|
||||||
|
safety). W4 ledger now shows a persist feature-ladder append → append-once → append-expect
|
||||||
|
that the hand-rolled fakes can't match. No new candidate; W4 reinforced.
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 11)
|
||||||
|
- **Pass 11 — W4 sharpened with a consumer ledger.** commerce built an **order ledger on
|
||||||
|
persist** (2nd live exemplar; uses `persist/append-once` for webhook idempotency) and
|
||||||
|
identity a **grant audit ledger** (in-memory Erlang fake, gated on an Erlang↔persist
|
||||||
|
bridge). The append-only monotonic-seq event-log pattern is now validated across 4
|
||||||
|
domains, 2 live on persist + 3 fakes flagged for adoption. See W4 table.
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 10)
|
||||||
|
- **Pass 10:** commerce/content/events/identity advancing (content 238/238). Probed a
|
||||||
|
shape outside the routing table — **guarded lifecycle state machines** (mod/lifecycle +
|
||||||
|
identity/membership) → new W6: shared *design principle*, divergent *structure*
|
||||||
|
(SX transition-table vs Erlang gen_server), NOT an extraction target. No gate-clearer.
|
||||||
|
- **Date:** 2026-06-07 (radar loop, pass 9)
|
||||||
|
- **Pass 9:** `commerce` + `content` reached Phase 2 (`content` 162/162). **Key find:
|
||||||
|
`content` built its op log directly on `persist/log`** (backend-injected, append+replay-
|
||||||
|
to-seq) — the live reference exemplar for W4 (see W4). `events` MONTHLY RRULE,
|
||||||
|
`identity` OAuth2 auth-code + PKCE, search boolean-filtered ranked. A1 still 6 adopters.
|
||||||
|
- **Date:** 2026-06-06 (radar loop, pass 8)
|
||||||
|
- **Pass 8 — fleet expanded by 4 app-domain loops** (the briefing's anticipated
|
||||||
|
`commerce`/`identity` arrivals, auto-picked up by dynamic discovery). All early-stage,
|
||||||
|
**pre-Phase-2 → moving targets, none count toward any gate yet**:
|
||||||
|
- `commerce` (Phase 1: `api/cart/catalog/price`). Its "per-line audit" is a cost
|
||||||
|
*breakdown view* (`api.sx:44`), **not** an append-only decision log → NOT a W4
|
||||||
|
consumer.
|
||||||
|
- `events` (Phase 1: `calendar.sx`, RRULE expansion).
|
||||||
|
- `identity` (early: `session/token`). Defers authZ to acl (`token.sx:15`) — reinforces
|
||||||
|
W2's "delegate `permit?` to acl-on-sx" routing; identity = authN, acl = authZ.
|
||||||
|
- `content` (just-started: `block.sx`).
|
||||||
|
These are the future consumers W2/W3 are waiting on — re-check their per-viewer filters
|
||||||
|
/ pagination once each clears Phase 2. No new gate-clearer this pass.
|
||||||
|
- **Pass 7:** **A1 jumped 4→6 adopters** — `acl` + `mod` migrated to the shared
|
||||||
|
conformance driver (first app-domain adopters; proves it generalizes past substrates).
|
||||||
|
`host-persist` closed its blob-adapter blocker (durable storage adapter now landing →
|
||||||
|
W4 migration path opening). search shipped proximity/NEAR; flow + persist quiescent.
|
||||||
|
- **Pass 6:** new worktree **`host-persist`** (active — building persist's durable host
|
||||||
|
adapter); `feed` went quiescent (left tmux). acl shipped hardening (+25), fed-sx-m1 at
|
||||||
|
Step 6c. **mod loop independently wrote a shared-plumbing note** (`mod-on-sx.md`,
|
||||||
|
538b8a53) corroborating W4/W5 — folded its claims + home disagreements into W1/W4/W5.
|
||||||
|
No new gate-clearer (audit log still 2 consumers), but consumers are now API-stable.
|
||||||
|
- **Pass 5:** search (+highlight/snippet) and fed-sx-m1 (+follower_graph) moved; rest
|
||||||
|
unchanged. Filename census: `api`×6, `fed`×3, then `schema/rank/query/page/explain/
|
||||||
|
engine/batch/audit`×2. Examined the ×6 `api.sx` → Rejected (shared name, divergent
|
||||||
|
structure incl. implicit-vs-explicit-state contract). rank/batch/engine all ≤2 +
|
||||||
|
substrate/domain-divergent → no new gate-clearer.
|
||||||
|
- **Pass 4:** no churn vs pass 3 (same worktrees/tmux/HEADs/adopters). Swept audit+explain
|
||||||
|
surfaces: acl/mod share an append-only-log shape (→ sharpened W4 with persist/log API
|
||||||
|
evidence) and a proof-explain shape (→ new W5, substrate-bound). No new gate-clearer.
|
||||||
|
- **Pass 3 (earlier today):** subsystem set + tmux + A1 adopters (4) all unchanged vs pass 2. Loops
|
||||||
|
advanced: acl shipped Phase 4 federation; search shipped Phase 4 + pagination; feed
|
||||||
|
shipped pagination/threading; mod at Ext 19 (capstone); persist did a worked acl-grants
|
||||||
|
migration (W4). New shape found: offset/limit pagination → folded into W3.
|
||||||
|
- **Subsystem set discovered:** loop worktrees `acl, erlang, fed-prims, fed-sx-m1,
|
||||||
|
feed, flow, go, kernel, mod, ocaml, persist, radar, ruby, search,
|
||||||
|
sx-vm-extensions`; main-repo `lib/*` incl. merged `feed` + substrates (`apl,
|
||||||
|
common-lisp, datalog, erlang, forth, go, haskell, hyperscript, js, lua, minikanren,
|
||||||
|
ocaml, prolog, scheme, smalltalk, tcl`) + `lib/guest`.
|
||||||
|
Actively looping (tmux): `acl, fed-sx-m1, feed, flow, mod, persist, search`
|
||||||
|
(+ radar).
|
||||||
|
- **New since pass 1:** worktrees `kernel` (empty/unset — not yet a repo) and `ocaml`
|
||||||
|
(`lib/ocaml/baseline` only). Both early-stage, pre–Phase 2 → out of proposal scope.
|
||||||
|
- Re-enumerate every pass; new loops (e.g. a future `commerce`/`identity`) auto-join.
|
||||||
|
|
||||||
|
**Census status (pass 17): EXHAUSTED.** Every own-namespace filename recurring ≥2× has
|
||||||
|
been examined and dispositioned — further filename-censusing is low-yield until new
|
||||||
|
subsystems/modules appear. Map:
|
||||||
|
| filename | owners | verdict |
|
||||||
|
|---|---|---|
|
||||||
|
| `api` ×10 | all | Rejected — shared role, divergent state contract |
|
||||||
|
| `fed`/`federation` | feed/search/mod/acl(+content) | W1 — theme not shape |
|
||||||
|
| `audit` ×3 | acl/mod/identity | W4 — append-only log → persist/log |
|
||||||
|
| `page` ×3 | feed/search (pagination) + content (HTML wrapper) | W3 + collision noted |
|
||||||
|
| `explain` ×2 | acl/mod | W5 — proof tree, substrate-bound |
|
||||||
|
| `snapshot` ×2 | persist(facet) + content(reinvents) | W7 |
|
||||||
|
| `wire` ×2 | content(SX serializer) / mod(pipe-format) | Rejected — divergent |
|
||||||
|
| `schema`,`engine` ×2 | acl/mod | substrate-twin parallels (Datalog vs Prolog); only audit (W4) is liftable |
|
||||||
|
| `catalog`,`batch` ×2 | commerce/persist, mod/persist | name collisions, unrelated |
|
||||||
|
| `normalize` ×2 | content(tree-prune)/feed(record-coerce) | name collision (pass 20) |
|
||||||
|
| `index` ×2 | content(listing)/search(inverted index) | name collision (pass 20) |
|
||||||
|
| `query` ×3 | content(doc-block)/search(bool AST)/persist(stream-read) | 3-way name collision (pass 20) |
|
||||||
|
| `store` ×2 | content(on persist) / flow(workflow records) | related concept, divergent |
|
||||||
|
| `rank` ×2 | feed/search | different domains (activities vs docs), ≤2 |
|
||||||
|
**acl⇄mod are structural twins** (decision engine over a logic substrate, Datalog vs
|
||||||
|
Prolog) — they parallel across engine/schema/explain/audit/fed, but only the *audit log*
|
||||||
|
is substrate-agnostic and liftable (→ W4); the rest are substrate-idiomatic. Next passes:
|
||||||
|
re-test gates (W2/W3/W8) as consumers mature, watch new modules — not re-census.
|
||||||
|
|
||||||
|
**Meta-pattern (pass 20):** new module names keep *recurring* but the operations keep
|
||||||
|
*colliding* — same noun, domain-specific op (normalize, index, query, catalog, batch,
|
||||||
|
notify, page, store all proved to be collisions). This is *why* genuine extraction
|
||||||
|
candidates are rare: the fleet shares vocabulary, not structure. The real shared assets
|
||||||
|
are the **substrate subsystems** (persist, flow, acl, fed-sx) that app domains *adopt*
|
||||||
|
(W1/W2/W4/W7/W8), not hand-rolled libs to extract.
|
||||||
|
|
||||||
|
**Scanning-method note (learned the hard way, passes 5/12/14/15):** a filename census
|
||||||
|
for *cross-subsystem* recurrence MUST restrict to each subsystem's OWN namespace —
|
||||||
|
`X/lib/X/*.sx` — never `X/lib/*/`. The merged substrate libs (`lib/prolog`, `lib/persist`,
|
||||||
|
`lib/feed`, `lib/datalog`, …) are checked out inside *every* worktree, so a naive census
|
||||||
|
reports e.g. `query.sx`/`snapshot.sx`/`rank.sx` ×N as phantom recurrences that are really
|
||||||
|
one merged file copied N times. Correct one-liner:
|
||||||
|
`for w in <subsystems>; do for f in $w/lib/$w/*.sx; do basename $f .sx; done; done | sort | uniq -c | sort -rn`.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## Done
|
||||||
|
|
||||||
|
### A1 · Shared conformance driver — ✅ COMPLETE (merged `db76cc8c`, pass 32)
|
||||||
|
Full closed loop: radar detected it → dedicated `conformance` loop implemented it
|
||||||
|
(classify-then-migrate-or-exclude, hard parity gate) → **merged to architecture**
|
||||||
|
(`db76cc8c Merge loops/conformance into architecture: A1 conformance-driver migration`)
|
||||||
|
→ radar spot-verified post-merge (**common-lisp 487/487 green** on architecture — exercises
|
||||||
|
the new per-suite-counters/preloads driver feature, the riskiest change). Final state:
|
||||||
|
- **13 on the shared driver:** acl, apl, common-lisp, datalog, erlang, events, feed, go,
|
||||||
|
haskell, mod, prolog, relations, search.
|
||||||
|
- **6 correctly excluded** (foreign-program runners — a legitimately different harness):
|
||||||
|
forth, js, ocaml, smalltalk, tcl, lua.
|
||||||
|
- The shared driver gained per-suite counters + per-suite preloads (backward-compatible);
|
||||||
|
spot-check confirms existing adopters unaffected. Coordination flag CLEARED.
|
||||||
|
Detail of the migration arc retained under the original entry below.
|
||||||
|
|
||||||
|
## Proposed (cleared the gate)
|
||||||
|
|
||||||
|
_(empty — A1 graduated to Done, pass 32.)_
|
||||||
|
|
||||||
|
### A1 · Adopt the shared conformance driver across subsystems
|
||||||
|
- **Pattern:** every subsystem hand-rolls a near-identical `conformance.sh`
|
||||||
|
(epoch-load → eval → scoreboard emit) and an inline `<x>-test name got expected`
|
||||||
|
pass/fail counter.
|
||||||
|
- **Consumers (≥3, overwhelming):** 15 `lib/*/conformance.sh` — `apl, feed, datalog,
|
||||||
|
flow, mod, lua, erlang, forth, go, common-lisp, haskell, js, ocaml, prolog,
|
||||||
|
smalltalk, tcl`.
|
||||||
|
- **Home:** `lib/guest` — the one legitimate exception (the shared driver
|
||||||
|
`lib/guest/conformance.sh` + `lib/guest/conformance.sx` already exist; modes
|
||||||
|
`dict` and `counters`).
|
||||||
|
- **Status: IN PROGRESS — 6 adopters (pass 7).** `prolog` (dict), `haskell` (counters),
|
||||||
|
`apl` (dict), `datalog` (dict), and **`acl` (dict) + `mod` (dict), newly migrated this
|
||||||
|
pass** — all 3-line exec shims into `lib/guest/conformance.sh` with a `conformance.conf`.
|
||||||
|
**acl + mod are the first *app-domain* adopters** (not language substrates) — strong
|
||||||
|
evidence the driver generalizes beyond the substrate layer, which was the open question.
|
||||||
|
The `apl` migration earlier *surfaced a latent bug*: the old awk extractor
|
||||||
|
under-counted `pipeline` (40 vs the real 152 assertions); true apl total is **562**,
|
||||||
|
not 450 — evidence that adopting the driver also improves correctness.
|
||||||
|
- **Not a target (different harness shape):** `lua/conformance.sh` is a Python runner
|
||||||
|
(`lib/lua/conformance.py`) that walks real `*.lua` source files via `lua-eval-ast`
|
||||||
|
and classifies pass/fail/timeout — it does not run SX `deftest` suites with a
|
||||||
|
counter/dict scoreboard, so the shared driver does not fit. Excluded, not pending.
|
||||||
|
- **Remaining hand-rolled candidates (~120–220 lines each):** `common-lisp, erlang,
|
||||||
|
feed, forth, go, js, ocaml, smalltalk, tcl` — now being worked by the dedicated
|
||||||
|
`conformance` loop (above). (`lua` excluded: walks real `*.lua` files via Python.
|
||||||
|
`smalltalk` likely excludes too — runs `*.st` via its own `test.sh`. `search` was
|
||||||
|
thought to be excluded but DID migrate via counters mode — see the 7-adopter note.)
|
||||||
|
- **Action:** each remaining subsystem's OWN loop migrates when quiescent — add a
|
||||||
|
`conformance.conf` (+ a `test-harness.sx` preload defining its counters) and
|
||||||
|
replace `conformance.sh` with the 1-line exec shim
|
||||||
|
(`exec bash …/guest/conformance.sh …/conformance.conf "$@"`). Recipe template:
|
||||||
|
`lib/haskell/conformance.conf` (counters) or `lib/prolog/conformance.conf` (dict).
|
||||||
|
Keep the `bash lib/X/conformance.sh` entry point so no loop is disrupted.
|
||||||
|
- **Priority: HIGH** (15 consumers, low risk, interface-preserving, additive).
|
||||||
|
- **8 adopters on architecture** (pass 25): acl, apl, datalog, **events**, haskell, mod,
|
||||||
|
prolog, search — `events` migrated via its OWN loop; `search` via counters mode (which
|
||||||
|
corrects the earlier "search excluded" note). **+4 on the `loops/conformance` branch:
|
||||||
|
`common-lisp` 487/487, `erlang` 761/761, `feed` 189/189, `go` 609/609** — pending merge.
|
||||||
|
**5 EXCLUDED — all foreign-runner harnesses** (correctly, not force-migrated): `forth`
|
||||||
|
(Hayes core.fr via awk+python), `js` (test262 `.js`/`.expected`), `ocaml` (scrapes
|
||||||
|
`test.sh` + `.ml` baseline), `smalltalk` (scrapes `test.sh` + `*.st` corpus), `tcl`
|
||||||
|
(foreign `*.tcl` vs `# expected:` annotations).
|
||||||
|
- **✅ CONFORMANCE LOOP WORKLIST COMPLETE (pass 31).** Final A1 picture:
|
||||||
|
- **12 on the shared driver:** acl, apl, datalog, events, haskell, mod, prolog, search
|
||||||
|
(on architecture) + common-lisp, erlang, feed, go (on `loops/conformance`, pending merge).
|
||||||
|
- **6 correctly excluded** (foreign-program runners — testing a language impl against an
|
||||||
|
external corpus is legitimately a different harness): forth, js, ocaml, smalltalk, tcl, lua.
|
||||||
|
- **Honest finding:** the driver's reach is narrower than the raw "15 conformance.sh"
|
||||||
|
count implied — language substrates that run real `.lua/.st/.ml/.tcl/.js/.fr` programs
|
||||||
|
*should* keep their foreign runners. ~half migrate, ~half don't, and that's correct.
|
||||||
|
- **One step left:** merge `loops/conformance` → architecture under the **adopter-parity
|
||||||
|
check** (the coordination flag above — the shared `lib/guest` driver change must be
|
||||||
|
proven non-regressive against all existing adopters first). The loop is now idle.
|
||||||
|
- **NOW IN PROGRESS — dedicated loop (2026-06-07).** A human-triggered `conformance` loop
|
||||||
|
(worktree `/root/rose-ash-loops/conformance`, branch `loops/conformance`, tmux session
|
||||||
|
`a1-conformance`, briefing `plans/agent-briefings/conformance-loop.md`) is working the
|
||||||
|
remaining candidates (common-lisp, erlang, feed, forth, go, js, ocaml, smalltalk, tcl)
|
||||||
|
one per iteration, **classify-then-migrate-or-exclude with a hard test-count parity gate**
|
||||||
|
(reverts on any mismatch; never pushes to main/architecture). Radar tracks; it implements.
|
||||||
|
- **Driver-capability boundary found (pass 24, first iteration).** The loop did NOT
|
||||||
|
force-migrate `common-lisp` (baseline 305/0 across 12 suites) — the shared driver can't
|
||||||
|
reproduce it: `MODE=counters` supports only ONE global pass/fail counter pair + ONE fixed
|
||||||
|
preload set, but common-lisp needs **per-suite counter names** (8 distinct pairs) and
|
||||||
|
**per-suite preload chains**. It logged a precise blocker + unblock path (extend the
|
||||||
|
`SUITES` entry format with optional per-suite counters/preloads) and moved on.
|
||||||
|
- **Driver gap RESOLVED next iteration (pass 25) — but it touched the shared driver.** The
|
||||||
|
loop extended `lib/guest/conformance.sh` (+38 lines: optional per-suite counters + per-suite
|
||||||
|
preloads in the `SUITES` format, backward-compatible) and then migrated common-lisp at
|
||||||
|
**487/487** (above the 305 baseline — likely another extractor under-count correction, à la
|
||||||
|
apl's `pipeline`). The parity gate held throughout.
|
||||||
|
- **⚠ COORDINATION FLAG (radar): the `loops/conformance` branch now carries a change to the
|
||||||
|
SHARED `lib/guest` driver** used by all 8 adopters. It's additive by design, but **before
|
||||||
|
this branch merges to `architecture`, re-run the existing adopters' suites under the new
|
||||||
|
driver to confirm zero regression** (acl/apl/datalog/events/haskell/mod/prolog/search).
|
||||||
|
This is the one cross-cutting risk in an otherwise per-subsystem-isolated effort — surfaced
|
||||||
|
here so the merge is gated on adopter-parity, not assumed.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## Watching (real but not yet through the gate)
|
||||||
|
|
||||||
|
### W1 · Federation scaffold (merge / ingest / backfill / trust-gate)
|
||||||
|
- **FAILS the structural-identity gate (deep-dived 2026-06-06, all 4 read).** Consumer
|
||||||
|
count is met (4) but they are *superficially* similar, not structurally identical —
|
||||||
|
the federated unit and merge op differ fundamentally:
|
||||||
|
|
||||||
|
| Subsystem (file) | Federated unit | Merge op | Trust gate | Injected transport |
|
||||||
|
|---|---|---|---|---|
|
||||||
|
| feed (`fed.sx:14,18,40`) | activity streams | dedupe by `(actor verb object)` | none (visibility via `permit?` separately) | `send-fn`, `fetch-fn` |
|
||||||
|
| search (`fed.sx:8`) | inverted indices | relabel DocId `peer*1000+local` + union posting lists | none | none (pure merge fn) |
|
||||||
|
| mod (`fed.sx:11-14,99`) | moderation decisions | advisory-list vs applied-list; bind iff `mod/trusted?` | **yes — runtime list** `mod/trusted? peer scope` | mock outbox / `fed-send!` |
|
||||||
|
| acl (`federation.sx:43,56`) | Datalog delegate facts | pull facts, gate by `trust`/`level_covers` rule, re-saturate | **yes — Datalog rule** at query time | `transport` dict |
|
||||||
|
| events (`federation.sx`) | calendar agendas | fold trusted peers' agendas into one sorted agenda + `:origin` provenance | **yes — runtime list** `ev/trusts?` (peer-id ∈ trust-set) | injected behind `ev/peer-agenda` |
|
||||||
|
|
||||||
|
- **The ONLY real commonality is the injection seam** (now 5/5, pass 18), not extractable
|
||||||
|
code: every one says "the real transport is `fed-sx`'s job; inject `send-fn`/`fetch-fn`/
|
||||||
|
`transport`/`peer-agenda` and mock it in tests." That is an architectural *convention the
|
||||||
|
fleet already follows*. The merge op diverges 5 ways (dedupe / index-union / advisory /
|
||||||
|
fact-saturation / agenda-sort). The trust gate, where present, splits: **mod + events use
|
||||||
|
a runtime trust-set membership check; acl uses a declarative Datalog rule** — so even the
|
||||||
|
trust sub-pattern is 2-of-3, and the membership check is a trivial one-liner (below the
|
||||||
|
extraction threshold). No shared merge, no single shared trust mechanism.
|
||||||
|
- **Disposition:** do NOT extract a shared "federation lib." When `fed-sx` ships its
|
||||||
|
real transport, these 4 become its *consumers* (wiring `send-fn`/`fetch-fn`/`transport`
|
||||||
|
to it) — that work belongs to each subsystem's loop + the `fed-sx` loop, not a
|
||||||
|
cross-cutting extraction. Stop re-proposing on the shared name. Home: `fed-sx`.
|
||||||
|
- **Now 7 federation modules (pass 29):** + `relations` (Phase 4: erel trust-gating,
|
||||||
|
peer_rel/trust, fed-sx mock transport — Datalog-rule trust like acl) and `artdag`
|
||||||
|
(Phase 6: content-addressed cache + trust + **invalidation** — a merge shape unlike any
|
||||||
|
other). Each new one reinforces "theme not shape": 7 divergent merges, all sharing only
|
||||||
|
the inject-fed-sx-transport seam. Verdict unchanged — they're fed-sx consumers-in-waiting.
|
||||||
|
- **Narrower sub-claim (mod note, pass 6; refined pass 18):** mod asserts the *fed
|
||||||
|
trust/outbox* shape shares between mod+acl. Radar evidence refines this: the trust gate
|
||||||
|
splits by mechanism, not by subsystem pair — **mod + events** both use a runtime
|
||||||
|
trust-set membership check (`mod/trusted?`, `ev/trusts?`), while **acl** uses a Datalog
|
||||||
|
rule. So a "trust-set membership" helper has 2 consumers (mod, events) — but it's a
|
||||||
|
one-line `member?` and the merge it gates diverges, so still not worth extracting.
|
||||||
|
Resolve at the architecture-merge point if a heavier shared trust-set surface emerges.
|
||||||
|
|
||||||
|
### W2 · Per-viewer visibility / permission filter
|
||||||
|
- **2 shipped consumers, same shape** — `filter <injected-permit> <ranked/candidate stream>`:
|
||||||
|
- `feed/lib/feed/acl.sx:27` `feed/visible = (feed/filter stream (fn (a) (permit? viewer a)))`,
|
||||||
|
capstone at `:34` (stream → ACL → rank → top-N). `permit?` injected, sig `(viewer activity)→bool`.
|
||||||
|
- `search/lib/search/fed.sx:16` `aclFilter permit docs = filter permit docs`;
|
||||||
|
`topNTfIdfAcl n permit ts idx = take n (aclFilter permit (rankTfIdf ts idx))`.
|
||||||
|
`permit` injected, sig `DocId→Bool` (viewer baked in by caller).
|
||||||
|
- **NOT a consumer:** `mod/lib/mod/policy.sx` is moderation policy (reviewer actions),
|
||||||
|
no per-viewer read filter. So mod won't be the 3rd.
|
||||||
|
- **Missing:** (a) only 2 consumers, need ≥3; (b) the two interfaces *diverge* —
|
||||||
|
feed passes `(viewer, item)`, search bakes the viewer in — so any shared form must
|
||||||
|
pick a convention; (c) both already **inject** the predicate, and the filter body is
|
||||||
|
literally one line (`filter permit xs`). Leaning toward: the predicate's home is
|
||||||
|
`acl-on-sx` (`permit?`), and the one-line filter is too thin to extract.
|
||||||
|
- **Home when ripe:** delegate `permit?` to `acl-on-sx`; do NOT extract the filter.
|
||||||
|
Re-check if a 3rd genuine per-viewer read filter ships (e.g. events/commerce).
|
||||||
|
|
||||||
|
### W3 · Collection helpers (group-by, dedupe-by-key, stable top-N, distinct-order, offset/limit page)
|
||||||
|
- feed built all of these on APL primitives. search/commerce/events will want
|
||||||
|
group-by / top-N.
|
||||||
|
- **NEW (2026-06-06): offset/limit pagination shipped in 2 subsystems, identical shape**
|
||||||
|
`take limit (drop offset xs)`:
|
||||||
|
- `feed/lib/feed/page.sx:9` `feed/page` (offset/limit window over a stream).
|
||||||
|
- `search/lib/search/page.sx:9` `paginate off lim docs = take lim (drop off docs)`.
|
||||||
|
- NOT a 3rd: `persist/lib/persist/query.sx:5` has a *since-cursor* for incremental log
|
||||||
|
consumption — resumable-stream semantics, not result windowing. Different shape.
|
||||||
|
- feed *also* has cursor-by-`:at` recency pagination (`page.sx:21-44`); search has no
|
||||||
|
cursor. So only the plain offset/limit window is shared, and it is a literal 1-liner.
|
||||||
|
- **Missing:** ≥3 stable consumers; AND every item here is collection math that belongs
|
||||||
|
in the **substrate** (APL/Haskell already expose grade/sort/unique/take/drop), not a
|
||||||
|
shared lib. A 1-line `take/drop` window is far below the extraction threshold. Watch;
|
||||||
|
revisit only if a non-substrate subsystem needs the same windowing without take/drop.
|
||||||
|
- **Filename-collision caution (pass 13):** `content/lib/content/page.sx` is an **HTML
|
||||||
|
page wrapper** (full HTML5 doc), NOT pagination — do not count it as a 3rd pagination
|
||||||
|
consumer. `page.sx` now means two unrelated things across the fleet. Re-tested pass 13:
|
||||||
|
pagination still only feed + search (2).
|
||||||
|
|
||||||
|
### W4 · In-memory store fakes → `persist-on-sx`
|
||||||
|
- Not an abstraction to extract — a migration target. Every subsystem fakes its
|
||||||
|
store with a mutable list (`feed/-log`, flow store, mod audit, …).
|
||||||
|
- **Owner:** `persist-on-sx` (in progress). Tracked there, listed here for visibility.
|
||||||
|
- **Concrete instance (file:line, found pass 4): the append-only decision/audit log.**
|
||||||
|
`acl/lib/acl/audit.sx` and `mod/lib/mod/audit.sx` are the SAME hand-rolled shape, and
|
||||||
|
`persist/lib/persist/log.sx` (the persist *log facet*) already implements it durably:
|
||||||
|
|
||||||
|
| role | acl/audit.sx | mod/audit.sx | persist/log.sx (target) |
|
||||||
|
|---|---|---|---|
|
||||||
|
| log var | `acl-audit-log` :9 | `mod/*audit-log*` :10 | backend stream |
|
||||||
|
| monotonic seq | `acl-audit-seq` :10 | `mod/*audit-seq*` :11 | per-stream high-water :1 |
|
||||||
|
| append (auto-seq) | `acl-audit-decide!` | commit :32 | `persist/append` :17 |
|
||||||
|
| count | `acl-audit-count` :51 | `mod/audit-count` :44 | `persist/count` :12 |
|
||||||
|
| read-all oldest-first | snapshot/tail :73 | `mod/audit-all` :43 | `persist/read` :29 |
|
||||||
|
| read seq≥from | — | by-seq | `persist/read-from` :31 |
|
||||||
|
|
||||||
|
Both deliberately use a monotonic seq with **no wall-clock** (deterministic/testable) —
|
||||||
|
identical to persist/log's design. Action when persist's host adapter lands: acl + mod
|
||||||
|
loops swap their in-memory log for `persist/log`. 2 consumers today; not a new lib —
|
||||||
|
the home already exists. Belongs to acl/mod loops × persist loop, not an extraction.
|
||||||
|
- **Cross-loop corroboration (pass 6):** the mod loop independently reached the same
|
||||||
|
conclusion — `mod/plans/mod-on-sx.md` (commit 538b8a53): *"mod-sx (Prolog) and acl-sx
|
||||||
|
(Datalog) converged on the same module shape … only the audit log + fed trust/outbox
|
||||||
|
shapes truly share; extract at the architecture-merge point, refactoring both consumers
|
||||||
|
atomically, not unilaterally from a loop branch."* Confirms the shape AND the
|
||||||
|
do-not-extract-unilaterally stance.
|
||||||
|
- **Home disagreement to resolve at merge:** mod's note proposes lifting the audit-log
|
||||||
|
primitives into **`lib/guest/`**. Radar routing disagrees: a durable append-only log is
|
||||||
|
a **`persist-on-sx`** concern (the log facet already exists), not language-impl plumbing.
|
||||||
|
Hold the line — `lib/guest` is lexer/parser/AST/HM/test-runner, not an event log.
|
||||||
|
- **Migration is becoming concrete:** new `host-persist` loop (worktree + tmux, pass 6)
|
||||||
|
is building the durable-storage host adapter persist was blocked on — once it lands,
|
||||||
|
acl/mod can actually swap to `persist/log`.
|
||||||
|
- **LIVE REFERENCE EXEMPLAR (pass 9): `content` already does it right.** `content`
|
||||||
|
(Phase 2 complete, 162/162) built its op log directly on `persist/log` instead of
|
||||||
|
faking it — `content/lib/content/store.sx`: backend injected via `(persist/open)`
|
||||||
|
("content knows nothing about which backend", :10); append op as event
|
||||||
|
`persist/append b (content/-stream doc-id) …` (:20); read `persist/read` (:36);
|
||||||
|
`persist/last-seq` (:47); **version = replay op stream up to a seq**
|
||||||
|
(filter `persist/event-seq ev <= seq`, :61). "The op log is the source of truth …
|
||||||
|
the materialised doc is a cache, never primary state."
|
||||||
|
This proves the W4 target is real, not hypothetical: acl + mod's hand-rolled
|
||||||
|
monotonic-seq logs should adopt exactly content's `persist/log` pattern.
|
||||||
|
- **Consumer ledger of the append-only monotonic-seq event log (pass 11):**
|
||||||
|
|
||||||
|
| consumer | what | backing | note |
|
||||||
|
|---|---|---|---|
|
||||||
|
| content (`store.sx`) | doc op log | **persist/log ✓ live** | plain append + replay-to-seq |
|
||||||
|
| commerce (`ledger.sx`) | order ledger | **persist/log ✓ live** | `persist/append-once` — idempotent, webhook-replay-safe :40,58 |
|
||||||
|
| events (`booking.sx`) | booking roster | **persist/log ✓ live** | `persist/append-expect` — optimistic-concurrency CAS, capacity-safe, lock-free |
|
||||||
|
| acl (`audit.sx`) | decision log | in-memory fake (SX) | migrate directly when host adapter lands |
|
||||||
|
| mod (`audit.sx`) | decision log | in-memory fake (SX) | migrate directly |
|
||||||
|
| identity (`audit.sx`) | grant ledger | in-memory fake (**Erlang**) | `{Seq,Subject,Action}`; needs an **Erlang↔persist bridge** first — author scoped it out until persist lands ("queryable semantics identical") |
|
||||||
|
|
||||||
|
- **Two takeaways:** (1) the pattern is **validated across domains** — CRDT doc ops,
|
||||||
|
financial orders, event bookings, rule decisions, OAuth grants all reduce to the same
|
||||||
|
append-only monotonic-seq stream; (2) migrating to `persist/log` is strictly *better*
|
||||||
|
than the fakes — persist exposes a **feature ladder the fakes don't have**:
|
||||||
|
`append` (content) → `append-once`/idempotency (commerce) → `append-expect`/optimistic-
|
||||||
|
concurrency (events). Every fake would have to reinvent a weaker version of these.
|
||||||
|
This is an **adoption** item (the home already exists), NOT a new extraction — owned by
|
||||||
|
persist/host-persist × each consumer loop. The SX fakes (acl, mod) migrate directly;
|
||||||
|
the Erlang fake (identity) is gated on an Erlang↔persist bridge.
|
||||||
|
|
||||||
|
### W5 · Proof-tree explanation over a logic-program derivation
|
||||||
|
- `acl/lib/acl/explain.sx` (reconstructs a canonical proof by goal-directed search over a
|
||||||
|
saturated Datalog db) and `mod/lib/mod/explain.sx` (renders a Prolog-style proof tree
|
||||||
|
goal-by-goal with proved/unproved marks + unification bindings) are the same *idea*.
|
||||||
|
- **Missing / disposition:** only 2 consumers, and they sit on **different substrates**
|
||||||
|
(acl→`lib/datalog`, mod→`lib/prolog`). Proof reconstruction/rendering is logic-engine
|
||||||
|
machinery → it belongs in each **substrate** (datalog/prolog), not a shared app lib.
|
||||||
|
Watch; revisit only if a 3rd logic-backed subsystem reimplements proof explanation.
|
||||||
|
- **Cross-loop note (pass 6):** mod's note calls `mod/proof-goals` (re-query-each-goal)
|
||||||
|
generic and proposes lifting it into **`lib/guest/`**. Radar caveat: proof-tree
|
||||||
|
reconstruction *is* engine-agnostic logic machinery, but `lib/guest` is for
|
||||||
|
lexer/parser/AST/HM/match/test-runner — a logic-engine proof helper is a poor fit there.
|
||||||
|
If genuinely shared by ≥3 engines, a `lib/logic`-style substrate helper is the better
|
||||||
|
home than `lib/guest`. Still 2 consumers → stays Watching either way.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
### W9 · Parent/child relationship tracking → the new `relations` subsystem (nascent)
|
||||||
|
- **New subsystem (pass 28):** `relations` (loops/relations, Phase 1 — `schema.sx`+`api.sx`,
|
||||||
|
rel facts + `relate`/`unrelate`/`children`/`parents`/`related`, 22 tests). Per CLAUDE.md
|
||||||
|
it's the canonical "cross-domain parent/child relationship tracking."
|
||||||
|
- **Why watch:** several subsystems already track parent/child *locally* — feed reply-to
|
||||||
|
threading (`thread`/`replies`), content nested block trees, events occurrence/RECURRENCE-ID
|
||||||
|
links. If `relations` becomes the shared home, those are candidate *delegators* (like
|
||||||
|
acl=authZ, persist=log). But it's **Phase 1, pre-Phase-2, moving target** — and each
|
||||||
|
local impl is currently domain-specific (different keys/semantics). Do NOT propose yet.
|
||||||
|
Re-check when relations is past Phase 2 AND ≥3 subsystems' relationship logic could
|
||||||
|
genuinely delegate to it. `artdag` also just spawned (nascent, 0 files) — tracking only.
|
||||||
|
(pass 32: `dream` + `maude` also spawned, nascent 0-files; `fed-prims` resumed.)
|
||||||
|
- **Update pass 29:** relations rocketed to **Phase 4** (one gate — past Phase 2 — now met),
|
||||||
|
but it's building ITSELF out (schema/federation), **not yet being consumed** by anyone.
|
||||||
|
The blocker is the other gate: 0 subsystems currently *delegate* their parent/child logic
|
||||||
|
to it (feed/content/events still track locally). Watch for the first real delegation.
|
||||||
|
(artdag also raced to Phase 6 — these ports advance fast; treat committed state as truth.)
|
||||||
|
|
||||||
|
### W8 · Durable externally-resumed orchestration on `lib/flow` (suspend→host-IO→resume)
|
||||||
|
- **The shared shape:** a durable `flow` that `request`s an external action (a suspend
|
||||||
|
point), the **host** performs the IO, then `flow/resume`s the flow with the outcome;
|
||||||
|
flow's deterministic replay means a completed step never re-runs on recovery.
|
||||||
|
- **Consumers (pass 24): 2 LIVE** (events delivery, commerce order saga).
|
||||||
|
- `events/lib/events/notify.sx` (**live**) — reminders/digests as durable flows;
|
||||||
|
suspend on delivery `dispatch`, resume with send outcome. At-least-once + idempotency key.
|
||||||
|
- `commerce` (**LIVE** as of pass 24 — "order lifecycle as a durable flow-on-sx flow,
|
||||||
|
21 tests, Phase 3 done") — order saga `(defflow ordf … (request 'reserve oid) … )`:
|
||||||
|
reserve→pay→fulfil as a flow, **payment stays suspended until the payment webhook calls
|
||||||
|
`flow/resume`**. Carries only the order-id; pure orchestration over `ledger.sx`.
|
||||||
|
- **Now 2 LIVE consumers** of the *same* pattern: long-running process, external resume
|
||||||
|
(delivery dispatch vs payment webhook). fed-sx/mod still roll their own outbox (watch
|
||||||
|
for convergence). Strengthens "lib/flow is the home"; still adoption, not extraction.
|
||||||
|
- **Disposition:** `lib/flow` IS the abstraction (events proves it, commerce adopts it) →
|
||||||
|
this is an **adoption** observation like W4, NOT an extraction. Home = `lib/flow`.
|
||||||
|
- **Flow-onboarding friction (light signal):** commerce's note logs real gotchas adopting
|
||||||
|
flow — `flow-make-env` returns a large likely-cyclic env (don't print it), env build is
|
||||||
|
slow (budget ~540s like flow's own suite). If ≥3 subsystems hit the same onboarding
|
||||||
|
gotchas, that's a signal to smooth `lib/flow`'s adopter API — flow's concern, flagged here.
|
||||||
|
- **Name-collision caveat:** `notify.sx` means two unrelated things — `feed/notify.sx` is
|
||||||
|
a *read-side digest* (group inbox by verb+object), NOT delivery. Do not pair them.
|
||||||
|
|
||||||
|
### W7 · Snapshot/projection-checkpoint reimplemented vs `persist/snapshot` (delegate)
|
||||||
|
- `persist/lib/persist/snapshot.sx` already provides a **generic** projection checkpoint:
|
||||||
|
store `{:value :seq}` in the kv facet under a namespaced key; the headline property is
|
||||||
|
**snapshot + tail == full replay** (pure, clock-free).
|
||||||
|
- `content/lib/content/snapshot.sx` **reimplements that same pattern on raw persist KV**
|
||||||
|
rather than delegating: `persist/kv-put b (content/-snap-key doc-id) {:doc … :seq seq}`
|
||||||
|
(:20), `persist/kv-has?`/`kv-get` (:27-28), and its own tail-replay (:53-59). It never
|
||||||
|
calls `persist/snapshot-*`. content's doc-materialisation *is* a projection fold over
|
||||||
|
its op stream — exactly what `persist/snapshot` checkpoints generically.
|
||||||
|
- **Disposition:** persist-adoption nudge (like W4): content could delegate to
|
||||||
|
`persist/snapshot` (its projection = "fold ops → doc"), dropping the duplicated
|
||||||
|
KV+replay code. Home already exists → NOT an extraction; owned by content × persist
|
||||||
|
loops. Only 1 reinventor today; watch whether commerce/events/identity also hand-roll a
|
||||||
|
snapshot on raw KV instead of using the facet (would strengthen the nudge). NB timeline:
|
||||||
|
unclear if `persist/snapshot` predated content's — flag, don't blame.
|
||||||
|
|
||||||
|
### W6 · Guarded lifecycle state machine (illegal transition = explicit error)
|
||||||
|
- Recurs as a **design principle**, NOT a shared structure (found pass 10):
|
||||||
|
- `mod/lib/mod/lifecycle.sx` — pure SX: immutable case `{:state :error :history …}`,
|
||||||
|
explicit transition table `mod/lc-transitions` (:31), illegal transition returns the
|
||||||
|
case unchanged with `:error` set. States open→triaged→decided→appealed→final.
|
||||||
|
- `identity/lib/identity/membership.sx` — an **Erlang `gen_server`** fragment (identity
|
||||||
|
runs on erlang-on-sx): a `receive` loop with `case find(...) of … {error, St}` guards.
|
||||||
|
States none→pending→active→lapsed→revoked.
|
||||||
|
- **Both share the guideline** ("invalid transitions are explicit errors, never silent
|
||||||
|
no-ops") but **implement it substrate-idiomatically** — SX transition-table over
|
||||||
|
immutable values vs an Erlang process loop with per-message case guards. Same W1/`api.sx`
|
||||||
|
trap: shared *idea*, divergent *structure*.
|
||||||
|
- **Disposition:** not an extraction target — the FSM mechanism is ~10 substrate-specific
|
||||||
|
lines; the value is in each domain's state graph, not the plumbing. At most a **design
|
||||||
|
guideline** ("model lifecycle as a guarded FSM with explicit-error transitions"). Watch
|
||||||
|
whether commerce-checkout / events-booking add their own — if so it confirms the
|
||||||
|
*guideline*, still not a lib. Do not propose extracting a shared state-machine lib.
|
||||||
|
|
||||||
|
## Rejected (considered, declined — do not re-propose)
|
||||||
|
|
||||||
|
- **"Continuous auto-implementing abstractor loop."** Rejected at design time: an
|
||||||
|
agent writing across `lib/<x>/**` breaks the worktree isolation that makes the
|
||||||
|
fleet safe, and is rewarded for manufacturing premature/wrong abstractions. The
|
||||||
|
radar is read-only by design. (This file is the alternative.)
|
||||||
|
- **Shared `api.sx` "public boundary" module (×6).** Rejected pass 4-5: every subsystem
|
||||||
|
has an `api.sx` (acl, feed, flow, mod, persist, search — a 100% filename match), but it
|
||||||
|
is a naming *convention for the public entry point*, not a shared structure. They
|
||||||
|
disagree on the most basic contract: acl/feed use **implicit module state**
|
||||||
|
(`acl/api.sx` "implicit current db", `feed/api.sx` "single mutable log") while
|
||||||
|
`persist/api.sx` threads an **explicit backend as every call's first arg**; flow's api
|
||||||
|
*builds a Scheme env*, search's api *concatenates a Haskell source string*, mod's is a
|
||||||
|
*lifecycle state-machine façade* (17 defs vs persist's 1). Same role, no common shape —
|
||||||
|
the W1 coincidental-resemblance trap. Do not re-propose on the filename.
|
||||||
|
- **Shared `wire.sx` "serialization" module (×2).** Rejected pass 15: content + mod both
|
||||||
|
have a `wire.sx`, but `content/wire.sx` uses the **generic SX serializer**
|
||||||
|
(`serialize`/`parse`, full-fidelity round-trip) while `mod/wire.sx` is a **bespoke
|
||||||
|
versioned pipe-delimited line** (subset of fields, `split` hand-built over slice/len
|
||||||
|
because mod's Prolog-loaded env strips string prims). Shared role (wire format),
|
||||||
|
divergent structure + substrate constraint → not a candidate; the SX serializer is
|
||||||
|
already the shared tool for SX-substrate subsystems, and mod can't use it. (Same family
|
||||||
|
as the `api.sx` rejection above.)
|
||||||
|
- **Dumping app-domain plumbing into `lib/guest`.** Rejected: `lib/guest` is for
|
||||||
|
language-implementation plumbing. App patterns route to acl/fed-sx/persist/
|
||||||
|
substrate/host instead (see the routing rule in the briefing).
|
||||||
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`.
|
||||||
@@ -19,7 +19,7 @@ injected adapter, not core.
|
|||||||
|
|
||||||
## Status (rolling)
|
## Status (rolling)
|
||||||
|
|
||||||
`bash lib/content/conformance.sh` → **746/746** (Phases 1–4 COMPLETE + ~34 extensions, hardened: HTML/SX escaping, Markdown render + import/export incl. tables & frontmatter (full round-trip), CvRDT flat + nested-tree + durable replication, tree-aware validation, snapshot cache, doc metadata, plain-text render, nested block trees + deep editing + flatten + relative reorder, doc stats + summary + multi-doc index, table + callout + media blocks, HTML page wrapper + SEO page, doc composition + id-remap, portable data + wire serialization, block query + transforms + find/replace, TOC + anchored headings + outline, normalization)
|
`bash lib/content/conformance.sh` → **778/778** (Phases 1–4 COMPLETE + ~34 extensions, hardened: HTML/SX escaping, Markdown render + import/export incl. tables & frontmatter (full round-trip), CvRDT flat + nested-tree + durable replication, tree-aware validation, snapshot cache, doc metadata, plain-text render, nested block trees + deep editing + flatten + relative reorder, doc stats + summary + multi-doc index, table + callout + media blocks, HTML page wrapper + SEO page, doc composition + id-remap, portable data + wire serialization, block query + transforms + find/replace, TOC + anchored headings + outline, normalization)
|
||||||
|
|
||||||
## Ground rules
|
## Ground rules
|
||||||
|
|
||||||
@@ -113,6 +113,66 @@ lib/content/api.sx ── (content/edit) (content/render) (content/history) ─
|
|||||||
|
|
||||||
## Progress log
|
## Progress log
|
||||||
|
|
||||||
|
- 2026-06-07 — Hardening (tree-wide audit): the public facade `content/find` /
|
||||||
|
`content/has?` were top-level-only (`doc-find`/`doc-has?`), so you could
|
||||||
|
`content/edit` an update/delete to a nested block by id (those ops are
|
||||||
|
tree-wide) but couldn't read that same block back by id through the facade — a
|
||||||
|
concrete read/write asymmetry. Added a generic `ct-find-id` to doc.sx (descends
|
||||||
|
into any `children` list, mirroring ct-replace-id/ct-remove-id, no section.sx
|
||||||
|
dependency) plus `doc-find-deep`/`doc-has-deep?`; `content/find`/`content/has?`
|
||||||
|
now point at them. Kept `content/find-top`/`content/has-top?` for the
|
||||||
|
top-level-only lookup. Audited all `doc-find`/`doc-ids`/`ct-index-of` callers:
|
||||||
|
the remaining ones are insert/move (positional, top-level by design) — no other
|
||||||
|
seams. +6 api tests (nested deep find/has, top variants miss nested,
|
||||||
|
edit-then-find round-trip). 778/778.
|
||||||
|
|
||||||
|
- 2026-06-07 — Hardening: `content/diff` (and `content/diff-versions`) are now
|
||||||
|
TREE-WIDE. They enumerated ids via `doc-ids`/`doc-find` (top-level only), so a
|
||||||
|
diff between two versions of a document containing sections silently missed
|
||||||
|
every nested-block add/remove/change — the same class of seam as the by-id
|
||||||
|
op-log bug. Now ids come from `doc-tree-ids` and lookups from `doc-deep-find`,
|
||||||
|
so nested changes surface precisely. Section containers are excluded from
|
||||||
|
`:changed` (they hold no own content; a child change reports as that child),
|
||||||
|
while whole-section add/remove still shows in `:added`/`:removed`. Flat-doc
|
||||||
|
diffs are unchanged (deep == top-level with no sections). +9 store tests
|
||||||
|
(nested add = section+child, nested change = child only, nested remove,
|
||||||
|
no-op). 772/772.
|
||||||
|
|
||||||
|
- 2026-06-07 — Feature: in-document prose search. `content/search-text` (and
|
||||||
|
`content/search-text-ids`) return every content block, tree-wide, whose
|
||||||
|
`(asText b)` contains a term — so search spans text/heading/code/quote/callout
|
||||||
|
text, image alt, list items and table cells **by construction**: it reuses the
|
||||||
|
one canonical "prose of a block" projection (asText) rather than re-listing
|
||||||
|
fields, so it can't drift from stats/find-replace. Section containers are
|
||||||
|
excluded (a term living only in a section's children returns the child, not the
|
||||||
|
wrapper). +7 query tests (cross-field match, count, single-field, no-match,
|
||||||
|
section exclusion, object return). 763/763.
|
||||||
|
|
||||||
|
- 2026-06-07 — Consistency: `find-replace` now rewrites **every** text-bearing
|
||||||
|
field, not just `text`. New `fr-rewrite` dispatches per block type — `alt` of
|
||||||
|
image blocks, each item of list blocks, and every header/cell of table blocks
|
||||||
|
now get rewritten alongside text/heading/code/quote/callout. This closes a real
|
||||||
|
seam: `asText`/stats/word-count already fold image alt, list items, and table
|
||||||
|
cells into a document's prose, so a `content/find-replace` rename that skipped
|
||||||
|
them was inconsistent (a renamed term would still show up in word counts and
|
||||||
|
exports). Flipped the two `image alt untouched` tests to `image alt replaced`;
|
||||||
|
+4 tests (list items ×2, table header + cell). find-replace 16/16, 756/756.
|
||||||
|
|
||||||
|
- 2026-06-07 — Consistency: `find-replace` now covers `callout` text. `fr-has-text?`
|
||||||
|
(find-replace.sx) added `callout` to its text-bearing block kinds, matching
|
||||||
|
`asText`/stats/summary which already treat callout bodies as prose. Previously a
|
||||||
|
`content/find-replace` over a doc containing callouts silently skipped them. +2
|
||||||
|
find-replace tests (replace callout text; callout kind untouched by text replace).
|
||||||
|
752/752 (41 suites).
|
||||||
|
|
||||||
|
- 2026-06-07 — Hardening: fixed a real layer seam (surfaced in the architecture
|
||||||
|
review) — by-id ops (update/delete) now act TREE-WIDE. `ct-replace-id` /
|
||||||
|
`ct-remove-id` (doc.sx) descend into any block carrying a `children` list, so
|
||||||
|
the persist op-log and `content/edit` correctly reach blocks nested in
|
||||||
|
sections (previously a silent no-op). `doc-move` stays top-level (guarded by
|
||||||
|
doc-find); insert/move remain positional. Inline section detection (no
|
||||||
|
section.sx dep). +4 store regression tests (nested update/delete via op-log +
|
||||||
|
replay-to-seq). Full gate over foundational doc.sx: 750/750.
|
||||||
- 2026-06-07 — Hardening: audit confirmed the persist op-log (store.sx) carries
|
- 2026-06-07 — Hardening: audit confirmed the persist op-log (store.sx) carries
|
||||||
every block type through commit → replay (op-insert carries the block
|
every block type through commit → replay (op-insert carries the block
|
||||||
instance; updates apply by id). Locked with +4 store tests (callout/media
|
instance; updates apply by id). Locked with +4 store tests (callout/media
|
||||||
|
|||||||
@@ -264,6 +264,25 @@ should leave `httpc`/`sqlite` BIFs blocked with that note.
|
|||||||
|
|
||||||
_Newest first._
|
_Newest first._
|
||||||
|
|
||||||
|
- 2026-06-07 — Investigated fed-sx-m2 Blockers #4 ("handler-mutex
|
||||||
|
deadlock") per `plans/agent-briefings/fed-prims-mutex-fix.md`.
|
||||||
|
**Outcome: not a mutex bug; no OCaml change — handed back to m2.**
|
||||||
|
Reproduced deterministically (single kernel-route request fails with
|
||||||
|
empty reply while `/` returns 200; also a 3-line minimal echo
|
||||||
|
gen_server reproduces it). Root cause: native `http-listen` runs the
|
||||||
|
handler on a fresh `Thread.create` outside the Erlang scheduler, so
|
||||||
|
`gen_server:call` → `receive` (which `raise`s `er-suspend-marker`
|
||||||
|
expecting an enclosing `er-sched-step-alive!` guard + `er-sched-run-all!`
|
||||||
|
pump) can never complete. Pattern A is inapplicable (single-request
|
||||||
|
failure ⇒ no contention; the mutex is required and must stay) and
|
||||||
|
`Sx_runtime.sx_call` is fully synchronous; no OCaml symbol can reach
|
||||||
|
the SX-level scheduler. Correct fix is Pattern B done purely in
|
||||||
|
`er-bif-http-listen` (`lib/erlang/runtime.sx`): spawn the handler as an
|
||||||
|
er-process and `er-sched-run-all!` to completion, returning the
|
||||||
|
process's `:exit-result`. That file is m2 / `loops/erlang` scope, so
|
||||||
|
this loop made no code change. Full diagnosis + a concrete patch
|
||||||
|
sketch recorded under Blockers below. `bin/sx_server.ml` unchanged;
|
||||||
|
builds untouched.
|
||||||
- 2026-05-26 — Phase J: `http-request` primitive in `bin/sx_server.ml`
|
- 2026-05-26 — Phase J: `http-request` primitive in `bin/sx_server.ml`
|
||||||
(NATIVE ONLY — `Unix.gethostbyname` + `Unix.connect`; HTTP/1.1 with
|
(NATIVE ONLY — `Unix.gethostbyname` + `Unix.connect`; HTTP/1.1 with
|
||||||
inline `http://` URL parser; sends Connection: close + Host +
|
inline `http://` URL parser; sends Connection: close + Host +
|
||||||
@@ -339,4 +358,73 @@ _Newest first._
|
|||||||
|
|
||||||
## Blockers
|
## Blockers
|
||||||
|
|
||||||
- _(none yet)_
|
- 2026-06-07 — **fed-sx-m2 Blockers #4 (handler-mutex deadlock) is NOT a
|
||||||
|
mutex bug — root cause is in the Erlang substrate, so the fix is m2
|
||||||
|
scope, not OCaml.** Investigated per `plans/agent-briefings/
|
||||||
|
fed-prims-mutex-fix.md`. Reproduced deterministically (m2 worktree
|
||||||
|
binary + `next/kernel/*.erl`, port 51920): a **single** request — no
|
||||||
|
concurrency, no prior request — to `/actors/alice/outbox` returns an
|
||||||
|
empty reply (curl exit 52) while the non-kernel control route `/`
|
||||||
|
returns 200 `fed-sx kernel m1`. Also reproduced with a 3-line minimal
|
||||||
|
echo gen_server + a handler that does `gen_server:call(echo, ping)`
|
||||||
|
(no kernel needed; boots in ~20s vs ~7min for the full kernel here).
|
||||||
|
|
||||||
|
Diagnosis: native `http-listen` (`bin/sx_server.ml:743-840`) runs each
|
||||||
|
connection's handler on a fresh `Thread.create` **outside any Erlang
|
||||||
|
scheduler step**. The handler closure (`er-bif-http-listen`'s
|
||||||
|
`sx-handler`, `lib/erlang/runtime.sx`) calls `er-apply-fun handler`
|
||||||
|
directly, so when the route reaches `gen_server:call` →
|
||||||
|
`receive` (`lib/erlang/transpile.sx:1132`), the `receive` captures a
|
||||||
|
`call/cc` and `raise`s `er-suspend-marker` expecting an enclosing
|
||||||
|
`er-sched-step-alive!` guard **and** a scheduler pump
|
||||||
|
(`er-sched-run-all!`). On the native handler thread neither is on the
|
||||||
|
stack: with no guard the suspend either propagates out (→ empty reply,
|
||||||
|
minimal case) or is caught by an Erlang `try`/guard in the route and
|
||||||
|
the request stalls (→ "hang" the m2 loop observed). The kernel
|
||||||
|
gen_server can never be stepped because the only scheduler driver
|
||||||
|
(the boot thread that ran `erlang-eval-ast`) is parked forever in the
|
||||||
|
native `Unix.accept` loop.
|
||||||
|
|
||||||
|
Why Pattern A (release/rescope the runtime mutex) does NOT apply: the
|
||||||
|
failure reproduces on a **single request with zero contention**, so it
|
||||||
|
is not a mutex-contention deadlock. Releasing the mutex cannot help and
|
||||||
|
would be actively harmful — the mutex is *required* to serialise the
|
||||||
|
shared single-threaded SX runtime / scheduler across handler threads.
|
||||||
|
`Sx_runtime.sx_call` (`lib/sx_runtime.ml:102`) is fully synchronous
|
||||||
|
(it just dispatches into the CEK evaluator), which is exactly the
|
||||||
|
briefing's stated condition for falling back from Pattern A to
|
||||||
|
Pattern B. There is also no OCaml-only fix: `grep` confirms nothing in
|
||||||
|
`hosts/ocaml/{lib,bin}` references `er-sched*`/the Erlang scheduler —
|
||||||
|
`er-sched-run-all!` is a pure-SX symbol in `lib/erlang/runtime.sx`, so
|
||||||
|
OCaml cannot pump it. Running the handler synchronously on the accept
|
||||||
|
thread (no `Thread.create`) does not help either: the `er-suspend-marker`
|
||||||
|
`raise` would unwind the native `handle` frame that writes the HTTP
|
||||||
|
response, losing the response across the suspension.
|
||||||
|
|
||||||
|
Recommended fix (Pattern B, **m2 / `loops/erlang` scope — entirely in
|
||||||
|
`er-bif-http-listen`, no OCaml change**): have `sx-handler` run the
|
||||||
|
handler as a scheduled er-process and pump the scheduler to completion,
|
||||||
|
e.g.
|
||||||
|
|
||||||
|
```
|
||||||
|
(sx-handler
|
||||||
|
(fn (req-dict)
|
||||||
|
(let ((req-pl (er-request-dict-to-proplist req-dict)))
|
||||||
|
(let ((pid (er-spawn-fun
|
||||||
|
(fn () (er-apply-fun handler (list req-pl))))))
|
||||||
|
(er-sched-run-all!) ; drains: handler →
|
||||||
|
; kernel reply → handler
|
||||||
|
(er-proplist-to-dict
|
||||||
|
(er-proc-field pid :exit-result)))))) ; handler's return value
|
||||||
|
```
|
||||||
|
|
||||||
|
This keeps every suspend/resume inside the SX scheduler; the native
|
||||||
|
side only ever sees the final response dict. The existing native
|
||||||
|
per-connection `Thread.create` + `Mutex` stay as-is and remain correct
|
||||||
|
(they serialise the single pump across concurrent connections — the
|
||||||
|
mutex must NOT be removed). Verified by reasoning through the full
|
||||||
|
step trace (handler suspends on `receive` → kernel `handle_call`
|
||||||
|
replies → handler resumes → dies with `:exit-result`); the m2 loop
|
||||||
|
should implement + run `next/tests/http_server_tcp.sh` plus a
|
||||||
|
kernel-route smoke. No OCaml or `bin/sx_server.ml` change was made or
|
||||||
|
is needed.
|
||||||
|
|||||||
@@ -36,7 +36,43 @@ host — no `ocaml-on-sx` dependency.
|
|||||||
|
|
||||||
## Status (rolling)
|
## 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
|
## Ground rules
|
||||||
|
|
||||||
@@ -73,28 +109,319 @@ lib/host/sxtp.sx subsystem APIs (feed/search/commerce/…
|
|||||||
```
|
```
|
||||||
|
|
||||||
## Phase 1 — Router + handler + one real endpoint
|
## Phase 1 — Router + handler + one real endpoint
|
||||||
- [ ] `router.sx` — route table, (method,path) match
|
- [x] `router.sx` — `host/make-app` assembles per-domain route groups + a built-in
|
||||||
- [ ] `handler.sx` — request/response model, subsystem dispatch
|
`/health` probe into one Dream router (reuses Dream's `dr/flatten-routes`)
|
||||||
- [ ] migrate ONE read endpoint (e.g. a feed timeline) end-to-end, golden test
|
- [x] `handler.sx` — JSON envelope (`host/ok`/`host/ok-status`/`host/error`),
|
||||||
- [ ] `conformance.sh` + scoreboard
|
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
|
## Phase 2 — Middleware + SXTP
|
||||||
- [ ] `middleware.sx` — composable auth/acl/mute/error layers
|
- [x] `middleware.sx` — composable layers as `handler->handler`: `host/wrap-errors`
|
||||||
- [ ] `sxtp.sx` — host↔subsystem wire format (align with existing spec)
|
(JSON 500), `host/require-auth` (bearer -> principal, JSON 401, INJECTED token
|
||||||
- [ ] migrate a write endpoint (auth + permission + action)
|
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
|
## 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
|
- [ ] 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)
|
## Phase 4 — Live wiring + Dream framework layer
|
||||||
- [ ] gate: `ocaml-on-sx` Phases 1–5 + minimal stdlib green
|
- [x] native `http-listen` ↔ Dream-app bridge (`lib/host/server.sx`:
|
||||||
- [ ] adopt `dream-on-sx` routing/middleware/session ergonomics over the same handlers
|
`host/native-handler`/`host/serve`) + `lib/host/serve.sh` launcher. Serves
|
||||||
- [ ] re-home external adapters as native where replacements land
|
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
|
## 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
|
## 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.
|
||||||
|
|||||||
170
plans/rose-ash-on-sx-migration.md
Normal file
170
plans/rose-ash-on-sx-migration.md
Normal file
@@ -0,0 +1,170 @@
|
|||||||
|
# Re-implementing rose-ash on SX — migration strategy
|
||||||
|
|
||||||
|
Status: **strategy proposal** (drafted by the `radar` loop, 2026-06-07). Not a
|
||||||
|
unilateral architecture decision — a starting point for the fleet to refine. Radar's
|
||||||
|
role here is detection: the `*-on-sx` subsystems have converged into a host-agnostic
|
||||||
|
re-implementation of rose-ash's domain logic, so this doc proposes *when* and *how* to
|
||||||
|
wire them to production.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 1. Premise: we are ~70% into a re-implementation already
|
||||||
|
|
||||||
|
The fleet of `lib/<x>` SX subsystems is not a set of experiments — it is rose-ash's
|
||||||
|
domain logic, re-expressed substrate-by-substrate, deliberately **host-agnostic**:
|
||||||
|
|
||||||
|
| SX subsystem (`lib/`) | rose-ash production domain |
|
||||||
|
|---|---|
|
||||||
|
| content-on-sx (CRDT docs, versioning, `page.sx` HTML render) | **blog** |
|
||||||
|
| commerce-on-sx (catalog, pricing, cart, order + refund sagas) | **market + cart + orders** |
|
||||||
|
| events-on-sx (calendar, ticketing, booking) | **events** |
|
||||||
|
| feed-on-sx (activity streams, AP-shaped, threading) | **federation** |
|
||||||
|
| identity-on-sx (OAuth2, sessions, grants, membership) | **account** |
|
||||||
|
| acl-on-sx (permissions) | cross-cutting authZ |
|
||||||
|
| relations / likes | **relations / likes** (internal) |
|
||||||
|
| persist-on-sx (log / kv / snapshot facets) | per-service Postgres layer |
|
||||||
|
| flow-on-sx (durable sagas) | order/refund/delivery workflows |
|
||||||
|
| mod-on-sx, search-on-sx | new capabilities |
|
||||||
|
|
||||||
|
**The architectural enabler:** every core was built with *injected seams* — `permit?`,
|
||||||
|
`send-fn`/`fetch-fn`, `transport`, `dispatch`, `backend`. That is ports-and-adapters
|
||||||
|
(hexagonal) on purpose. Evidence from the radar backlog (`plans/abstractions.md`):
|
||||||
|
W1 (7/7 federation modules inject the fed-sx transport), W4 (content/commerce/events run
|
||||||
|
live on `persist/log`), W8 (events+commerce run sagas on `lib/flow`). **The cores do not
|
||||||
|
depend on how they're hosted, persisted, or federated.**
|
||||||
|
|
||||||
|
**Corollary that makes the whole migration tractable:** because logic is separated from
|
||||||
|
rendering and storage, we can hold the **domain logic to parity** while **freely
|
||||||
|
redesigning the presentation** — the two are different layers with different rules.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 2. The gating insight: the cores are *ahead of the host*
|
||||||
|
|
||||||
|
The domain logic is mature. What is *not* yet production-grade is the **host trio** — and
|
||||||
|
that is the real critical path:
|
||||||
|
|
||||||
|
- **host-on-sx** — HTTP / request-response / session host (briefing exists; the OCaml SX
|
||||||
|
HTTP server already serves `sx.rose-ash.com`).
|
||||||
|
- **host-persist** — durable storage adapter (real disk/pg/ipfs) under `persist`'s
|
||||||
|
facets (content-addressed blob blocker recently closed).
|
||||||
|
- **fed-sx** — the real ActivityPub transport every core injects (well into m2).
|
||||||
|
|
||||||
|
> **So "when do we start?" answers itself: start when the host trio is production-grade,
|
||||||
|
> not when the cores are done — they mostly already are.** Prioritise the host loops over
|
||||||
|
> further domain features.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 3. The model: duplicate → cut over → diverge (per slice)
|
||||||
|
|
||||||
|
This is the "duplicate first, then change" approach, made precise. Each domain slice goes
|
||||||
|
through three phases independently:
|
||||||
|
|
||||||
|
**Phase A — Duplicate (hold logic to parity).** Stand the SX implementation of the slice
|
||||||
|
up *in parallel*, behind the existing edge, serving no users yet. Get its **domain/data
|
||||||
|
behaviour** to match Python (see §4 on how). Presentation can start as a rough port or an
|
||||||
|
early new design — it doesn't have to match.
|
||||||
|
|
||||||
|
**Phase B — Cut over (strangler flip).** Point the edge route for that slice at the SX
|
||||||
|
host. Python stays as instant rollback. The slice is now live on SX.
|
||||||
|
|
||||||
|
**Phase C — Diverge (change freely).** With the slice live and validated, evolve the
|
||||||
|
look/feel and functionality on the SX side. The validated domain logic underneath is
|
||||||
|
untouched, so UX/feature changes can't silently corrupt data.
|
||||||
|
|
||||||
|
You never rewrite the whole platform at once; you walk slices through A→B→C, oldest tree
|
||||||
|
strangled last.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 4. The two techniques, and how "we'll change things" reshapes them
|
||||||
|
|
||||||
|
### Strangler edge
|
||||||
|
The edge (Caddy) is the front door every request hits. Add routing rules so **one route
|
||||||
|
at a time** goes to the SX host while everything else still goes to Python. Properties:
|
||||||
|
the site is never half-broken; any single route flips back to Python instantly; the old
|
||||||
|
app is strangled route-by-route. (Opposite of big-bang swap, which is how these die.)
|
||||||
|
|
||||||
|
### Shadow diff — split by layer
|
||||||
|
Run the new version on real traffic in the background, discard its output, and **log how
|
||||||
|
it differs** from Python. Flip the edge only when diffs are zero/intended.
|
||||||
|
|
||||||
|
But because we *intend* to change look/feel + functionality, parity is a tool we apply
|
||||||
|
**only where we want sameness**, not a straitjacket:
|
||||||
|
|
||||||
|
| Layer | Want parity? | Oracle |
|
||||||
|
|---|---|---|
|
||||||
|
| **Domain/data** (totals, tax, permissions, what's stored, who-sees-what) | **YES — silent difference = data corruption** | shadow-diff at the *core* boundary; deterministic cores → replay real request logs through the harness and diff |
|
||||||
|
| **Presentation/UX** (HTML, layout, look, feel, flows) | **NO — this is what we're changing** | manual QA + design review; this is the Phase-C divergence |
|
||||||
|
|
||||||
|
Practical shape: shadow-diff hits the **domain core's output** (the computed order, the
|
||||||
|
visible-activity set, the permission decision) — not the rendered HTML. The deterministic,
|
||||||
|
harness-replayable cores are the single biggest advantage we have here; it's the same
|
||||||
|
parity discipline that made the A1 conformance migration safe (one reference slice, hard
|
||||||
|
parity gate, revert on mismatch).
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 5. Readiness gates (start the production migration when ALL hold)
|
||||||
|
|
||||||
|
1. **Host trio production-grade** — host-on-sx (HTTP/session), host-persist (durable
|
||||||
|
adapter), fed-sx (AP transport) — each conformance-green.
|
||||||
|
2. **Data-migration story exists** — a way to get existing production Postgres state into
|
||||||
|
`persist` event streams (event-source the current state, or dual-write during overlap).
|
||||||
|
This is the honest long-pole; it is *not* domain logic and nobody has built it yet.
|
||||||
|
3. **One vertical slice proven end-to-end** at data-parity in production — the reference
|
||||||
|
migration, the way the conformance loop migrated one subsystem before the rest.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 6. Sequencing
|
||||||
|
|
||||||
|
1. **Host trio first** (critical path — it's behind the cores).
|
||||||
|
2. **Build the strangler edge + shadow-diff harness** as first-class tooling: edge routing
|
||||||
|
rules + a dual-run logger that diffs *core outputs* (not HTML) and stores discrepancies.
|
||||||
|
3. **First slice = lowest risk × highest readiness × cleanest data oracle.**
|
||||||
|
Recommended: **the blog read path (content-on-sx)** or **the feed read path**
|
||||||
|
— read-heavy, no money, CRDT/versioning + `page.sx` HTML already exist, and the data
|
||||||
|
oracle is clean. *Avoid cart/orders/payments first* (transactional + SumUp webhooks =
|
||||||
|
highest blast radius).
|
||||||
|
4. **Persistence-first, federation-last.** Land host-persist + migrate per-domain event
|
||||||
|
stores before any cutover. Do fed-sx federation as a *coordinated* cut near the end —
|
||||||
|
W1 shows all 7 cores light up federation together once the shared transport ships.
|
||||||
|
5. **Walk the remaining slices A→B→C**, retiring Python routes as each cuts over.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 7. The honest long tail (mostly host + adapters, not cores)
|
||||||
|
|
||||||
|
The cores are pure domain logic; the production *tail* is not in them yet and is most of
|
||||||
|
the remaining real effort:
|
||||||
|
|
||||||
|
- Auth: first-party cookies / Safari-ITP, CSRF, silent SSO, grant caching.
|
||||||
|
- Cross-cutting: rate limiting, observability/metrics, error pages, caching.
|
||||||
|
- Integrations: SumUp payment + webhooks, Ghost CMS sync.
|
||||||
|
- Presentation: the actual HTMX templates + CSS (this is also where the redesign happens).
|
||||||
|
- **Live data migration** — the single biggest non-core workstream.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 8. Concrete next steps
|
||||||
|
|
||||||
|
1. Treat the **host trio** as the fleet's critical path; prioritise over more domain features.
|
||||||
|
2. Stand up the **strangler edge + core-level shadow-diff harness** as a tool.
|
||||||
|
3. Prove **one slice** (blog/content read path) end-to-end in production as the reference.
|
||||||
|
4. **Spec the Postgres → persist data migration** (the long-pole nobody has started).
|
||||||
|
5. Then walk slices through duplicate → cut over → diverge, redesigning UX in Phase C.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 9. Why this is low-risk despite being a platform rewrite
|
||||||
|
|
||||||
|
- It's **wiring host-agnostic cores to a host**, not rewriting domain logic from scratch.
|
||||||
|
- The **strangler edge** means the site always works and any route reverts in seconds.
|
||||||
|
- **Deterministic cores** make data-parity *mechanically checkable* (replay + diff), so
|
||||||
|
correctness isn't a matter of faith.
|
||||||
|
- **Logic/presentation separation** lets us change look/feel + functionality (Phase C)
|
||||||
|
*without* re-risking the validated domain logic.
|
||||||
|
- It's the **same discipline that just shipped A1**: one reference migration, a hard
|
||||||
|
parity gate, honest exclusions, verify-before-merge.
|
||||||
Reference in New Issue
Block a user