coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'loops/host' into merge/host-arch

Browse Source 
# Conflicts:
#	lib/erlang/runtime.sx
This commit is contained in:
giles
2026-07-01 17:42:08 +00:00
parent 5968c0173f 62c9bdd270
commit 5535acf4e9
131 changed files with 24871 additions and 5830 deletions
Download Patch File Download Diff File Expand all files Collapse all files

37
lib/dream/form.sx
View File

@@ -58,6 +58,43 @@
((s2 (replace s "+" " ")))
(dr/url-decode-loop s2 0 (string-length s2) ""))))
;; ── percent encoding (symmetric with dr/url-decode) ────────────────
;; RFC3986 unreserved set passes through; everything else is %XX (uppercase
;; hex). Space becomes %20 (not +), so the result is safe in a query value.
(define dr/hex-chars "0123456789ABCDEF")
(define
dr/url-encode-char
(fn
(c)
(let
((n (char-code c)))
(if
(or
(and (>= n 48) (<= n 57)) ;; 0-9
(and (>= n 65) (<= n 90)) ;; A-Z
(and (>= n 97) (<= n 122)) ;; a-z
(= c "-") (= c "_") (= c ".") (= c "~"))
c
(str "%"
(char-at dr/hex-chars (quotient n 16))
(char-at dr/hex-chars (mod n 16)))))))
(define
dr/url-encode-loop
(fn
(s i n acc)
(if
(>= i n)
acc
(dr/url-encode-loop s (+ i 1) n
(str acc (dr/url-encode-char (char-at s i)))))))
(define
dr/url-encode
(fn
(s)
(dr/url-encode-loop (or s "") 0 (string-length (or s "")) "")))
;; ── substring splitter (split primitive is char-class based) ───────
(define
dr/split-on

153
lib/host/auth.sx Normal file
View File

@@ -0,0 +1,153 @@
;; lib/host/auth.sx — browser login on top of host sessions (lib/host/session.sx).
;; A login form posts credentials; on success the principal is written to the
;; session cookie. The guarded write routes then accept EITHER a logged-in session
;; OR a Bearer token (host/require-user), so the same routes serve browsers and API
;; clients. Single admin user; credentials come from $SX_ADMIN_USER / _PASSWORD
;; (set in serve.sh) — the in-source defaults are dev-only.
;;
;; Depends on lib/host/session.sx, lib/host/{handler,middleware}.sx, lib/dream/*
;; (form/types/session) + the kernel render-page primitive.
;; ── page shell (own copy; render-page renders the static SX tree) ───
(define host/-auth-page
(fn (title body)
(str "<!doctype html>"
(render-page
(quasiquote
(html
(head (meta :charset "utf-8") (title (unquote title)))
(body (unquote body))))))))
;; ── admin credential (override from env in serve.sh) ────────────────
(define host/admin-user "admin")
(define host/admin-password "letmein")
(define host/auth-set-admin!
(fn (u p) (begin (set! host/admin-user u) (set! host/admin-password p))))
(define host/-verify-cred
(fn (user pass)
(and (not (= pass ""))
(= user host/admin-user)
(= pass host/admin-password))))
;; A return-to target is only honoured if it's a same-site absolute PATH — guards
;; against an open-redirect (//evil.com, http://…) smuggled through ?next=.
(define host/-safe-next
(fn (n)
(if (and n (not (= n "")) (starts-with? n "/") (not (starts-with? n "//")))
n "/")))
;; The login form, parameterised by where to return after success.
(define host/-login-form
(fn (next-path message)
(host/-auth-page "Log in"
(quasiquote
(div
(h1 "Log in")
(unquote (if message (quasiquote (p :style "color:#b00" (unquote message))) ""))
(form :method "post" :action "/login"
(input :type "hidden" :name "next" :value (unquote next-path))
(p (input :name "username" :placeholder "username"))
(p (input :name "password" :type "password" :placeholder "password"))
(p (button :type "submit" "Log in")))
;; a way back into the app — the login shell is a standalone page (no persistent
;; nav), so without this a logged-out user who followed a guarded link is stranded.
(p :style "margin-top:1em" (a :href "/" "← Home")))))))
;; ── GET /login — login form, honouring ?next= (where to go after login) ─────
(define host/login-page
(fn (req)
(dream-html
(host/-login-form (host/-safe-next (dream-query-param req "next")) nil))))
;; ── POST /login — verify, write session principal, redirect to ?next ────────
;; The session middleware (host/sessions) has already created/loaded the session
;; and will set the cookie on this response, so writing :principal here lands on
;; the right sid and the browser keeps the cookie. On failure the form re-renders
;; with the same return target so the user lands where they were headed.
(define host/login-submit
(fn (req)
(let ((user (host/field req "username"))
(pass (host/field req "password"))
(next-path (host/-safe-next (host/field req "next"))))
(if (host/-verify-cred user pass)
(begin
(host/login! req user)
(dream-redirect next-path))
(dream-html-status 401
(host/-login-form next-path "Invalid credentials — try again."))))))
;; ── /logout — clear the session, redirect home. Allowed on GET too so a plain
;; footer link can log out (logout is low-harm, so GET is acceptable here). ─────
(define host/logout-submit
(fn (req)
(begin
(host/logout! req)
(dream-redirect "/"))))
;; ── login routes (mounted by host/make-app) ─────────────────────────
(define host/auth-routes
(list
(dream-get "/login" host/login-page)
(dream-post "/login" host/login-submit)
(dream-get "/logout" host/logout-submit)
(dream-post "/logout" host/logout-submit)))
;; ── auth footer fragment ────────────────────────────────────────────
;; A small SX node pages splice into their footer: "log in" when logged out,
;; "signed in as <user> · log out" when logged in. Guards a session-less request
;; (no middleware) so it's safe to call anywhere. Reads the session principal.
(define host/auth-footer
(fn (req)
(let ((who (if (get req :dream-session) (host/current-principal req) nil)))
(if (and who (not (= who "")))
(quasiquote
(span (unquote (str "signed in as " who)) " · "
(a :href "/logout" "log out")))
(quote (a :href "/login" "log in"))))))
;; The authenticated principal for a request, or nil: a logged-in session takes
;; precedence, else a Bearer token resolved by `resolve` (the API fallback).
(define host/-principal-of
(fn (req resolve)
(let ((sp (host/current-principal req)))
(if (and sp (not (= sp "")))
sp
(let ((tok (dream-bearer-token req)))
(if tok (resolve tok) nil))))))
;; ── auth middleware (API shape): session principal OR bearer token ──
;; Place AFTER the session middleware (so host/current-principal can read the
;; session) and BEFORE host/require-permission. On failure -> JSON 401 with a
;; Bearer challenge. For API/JSON routes; browser pages want host/require-login.
(define host/require-user
(fn (resolve)
(fn (next)
(fn (req)
(let ((principal (host/-principal-of req resolve)))
(if (or (nil? principal) (= principal ""))
(dream-add-header
(host/error 401 "unauthorized")
"www-authenticate" "Bearer")
(next (assoc req :dream-principal principal))))))))
;; ── auth middleware (browser shape): same check, but on failure REDIRECT to
;; the login page with a return-to, instead of a raw JSON 401. Use this for HTML
;; routes (an edit form, the create form) so an unauthenticated click lands on a
;; usable login page and returns to where it was headed after logging in. ──
(define host/require-login
(fn (resolve)
(fn (next)
(fn (req)
(let ((principal (host/-principal-of req resolve)))
(if (or (nil? principal) (= principal ""))
(let ((login-url (str "/login?next=" (host/-safe-next (dream-path req)))))
;; A BOOSTED (SX-Request) request can't be answered with a 303: the browser's
;; fetch follows the redirect WITHOUT the SX-Request header, so /login returns
;; the full HTML shell, which morphed into #content DESTROYS the SPA swap target
;; (every later boosted nav then has nowhere to swap — "nothing happens"). Return
;; an SX-Redirect header instead — the engine does a FULL navigation to /login (a
;; fresh shell). A non-boosted request still gets a plain 303.
(if (= (dream-header req "sx-request") "true")
(dream-response 200 {:sx-redirect login-url} "")
(dream-redirect login-url)))
(next (assoc req :dream-principal principal))))))))

2624
lib/host/blog.sx Normal file
View File

File diff suppressed because it is too large Load Diff

145
lib/host/compose.sx Normal file
View File

@@ -0,0 +1,145 @@
;; lib/host/compose.sx — the composition algebra + its render-fold (plans/composition-objects.md).
;;
;; An object's :body is a composition node — a tiny language over object refs:
;; (seq …) sequence (row/grid …) layout (alt (when P n)… (else n)) conditional
;; (each src tmpl) iteration + domain leaves + (tmpl NAME) recursion
;;
;; The combinator dispatch (seq/alt/each), the `when` predicate set, the context-environment,
;; the `each` source, and recursion are SHARED by every domain — they live in the CORE below
;; (host/comp-fold). A domain plugs in via a small dict {:empty :combine :leaf :overflow};
;; only the leaves and how results combine differ. The render-fold (render → HTML) is the
;; first such domain; the execute-fold (execute → effects, lib/host/execute.sx) is the second.
;; The object's CID is its DEFINITION; a fold is the EXECUTION (per context + data + domain).
;; Self-contained (no blog deps) so the model can be proven in isolation.
;; ── shared machinery (domain-agnostic) ──────────────────────────────
;; predicates for `when`, over the context environment.
(define host/comp--pred?
(fn (pred ctx)
(let ((op (str (first pred))))
(cond
((= op "has") (not (nil? (get ctx (str (first (rest pred)))))))
((= op "eq") (= (str (get ctx (str (first (rest pred))))) (str (first (rest (rest pred))))))
((= op "not") (not (host/comp--pred? (first (rest pred)) ctx)))
(else false)))))
;; the value of a field: the current :item's key, else the context's key.
(define host/comp--field
(fn (k ctx)
(let ((item (get ctx "item")) (key (str k)))
(if (and item (not (nil? (get item key))))
(str (get item key))
(str (or (get ctx key) ""))))))
;; the source collection for `each`: literal items, the :item's :children (trees), a named
;; list field on the :item, or a GRAPH QUERY. `(query REL TYPE)` is data-driven: it delegates
;; to a resolver bound in the context under "query" (the host injects one with graph access),
;; so compose.sx stays self-contained — it asks the context for the data.
(define host/comp--source
(fn (src ctx)
(let ((op (str (first src))) (item (get ctx "item")))
(cond
((= op "items") (rest src))
((= op "children") (if item (or (get item "children") (list)) (list)))
((= op "field") (if item (or (get item (str (first (rest src)))) (list)) (list)))
((= op "query") (let ((qfn (get ctx "query")))
(if qfn (qfn (rest src) ctx) (list))))
(else (list))))))
;; template registry (recursion: a template may reference itself by name).
(define host/comp--tmpls (dict))
(define host/comp--def-tmpl! (fn (name node) (dict-set! host/comp--tmpls name node)))
;; ── the CORE fold framework (build once, reuse per domain) ──────────
;; host/comp-fold walks seq/alt/each generically, parameterised by a DOMAIN dict:
;; :empty — the zero result ("" for render, (list) for execute)
;; :combine — merge two results (str for render, concat for execute)
;; :overflow — the depth-guard result (a string / an effect)
;; :leaf — (node ctx dom) -> result for any non-core head: the domain's leaves AND its
;; own extra combinators (e.g. render's row/grid), which may recurse via the core.
;; seq, alt+when, each+source, the context-environment, recursion, and the depth guard are
;; handled HERE, once. A new domain (render, execute, eval, …) is just a new dict.
(define host/comp--fold-all
(fn (nodes ctx dom)
(reduce (fn (acc n) ((get dom :combine) acc (host/comp-fold n ctx dom))) (get dom :empty) nodes)))
(define host/comp--fold-alt
(fn (branches ctx dom)
(if (empty? branches)
(get dom :empty)
(let ((br (first branches)) (bh (str (first (first branches)))))
(cond
((= bh "else") (host/comp-fold (first (rest br)) ctx dom))
((= bh "when") (if (host/comp--pred? (first (rest br)) ctx)
(host/comp-fold (first (rest (rest br))) ctx dom)
(host/comp--fold-alt (rest branches) ctx dom)))
(else (host/comp--fold-alt (rest branches) ctx dom)))))))
(define host/comp--fold-each
(fn (src body ctx dom)
(let ((depth (or (get ctx "depth") 0)))
(if (> depth 40)
(get dom :overflow)
(reduce
(fn (acc item)
((get dom :combine) acc (host/comp-fold body (merge ctx {"item" item "depth" (+ depth 1)}) dom)))
(get dom :empty) (host/comp--source src ctx))))))
(define host/comp-fold
(fn (node ctx dom)
(if (not (= (type-of node) "list"))
((get dom :leaf) node ctx dom)
(let ((h (str (first node))))
(cond
((= h "seq") (host/comp--fold-all (rest node) ctx dom))
((= h "alt") (host/comp--fold-alt (rest node) ctx dom))
((= h "each") (host/comp--fold-each (first (rest node)) (first (rest (rest node))) ctx dom))
(else ((get dom :leaf) node ctx dom)))))))
;; ── the RENDER domain (render → HTML): leaves + layout combinators ──
;; card leaf (proof: a labelled box; in the host this renders via the card-type's :template).
(define host/comp--card
(fn (ctype fields)
(str "<div class=\"card card-" ctype "\">"
(reduce (fn (acc k) (str acc "<b>" k ":</b> " (str (get fields k)) " ")) "" (keys fields))
"</div>")))
;; render-leaf handles everything that isn't a core combinator: the layout combinators
;; row/grid (which recurse via the core), the leaves field/val/text/card, transclusion (ref),
;; and named-template recursion (tmpl). `field` wraps its value in a <span>; `val` is the raw
;; value (no markup) for attributes (href/src).
(define host/comp--render-leaf
(fn (node ctx dom)
(if (not (= (type-of node) "list"))
(str node)
(let ((h (str (first node))) (args (rest node)))
(cond
((= h "row") (str "<div class=\"row\" style=\"display:flex;gap:1em\">" (host/comp--fold-all args ctx dom) "</div>"))
((= h "grid") (str "<div class=\"grid\" style=\"display:grid;gap:1em\">" (host/comp--fold-all args ctx dom) "</div>"))
((= h "field") (str "<span>" (host/comp--field (first args) ctx) "</span>"))
((= h "val") (host/comp--field (first args) ctx)) ;; raw value, no markup — for attributes
((= h "text") (str (first args)))
((= h "card") (host/comp--card (str (first args)) (first (rest args))))
;; ref: TRANSCLUDE another object by id/CID via a context resolver (the host supplies
;; graph access) so compose.sx stays self-contained; a join in the Merkle DAG is free.
((= h "ref") (let ((rfn (get ctx "ref"))) (if rfn (rfn (str (first args)) ctx) "")))
((= h "tmpl") (host/comp-fold (get host/comp--tmpls (str (first args))) ctx dom))
(else ""))))))
(define host/comp--render-dom
{:empty "" :combine str :overflow "<em>(max depth)</em>" :leaf host/comp--render-leaf})
;; public entry: render a composition node against a context environment -> HTML string.
(define host/comp-render (fn (node ctx) (host/comp-fold node ctx host/comp--render-dom)))
;; ── a THIRD domain (deps → the object ids a composition transcludes) ──
;; Proof of step 8's claim "a new domain is just a dict + leaf": no new control flow — seq/
;; alt/each come from the core unchanged; only the leaf + accumulator are new. The deps-leaf
;; collects `(ref ID)` ids; everything else contributes nothing. Useful in its own right: the
;; static transclusion set of a body (which card objects it pulls in — the contains DAG for a
;; (seq (ref c0) (each … (ref …))) body). Context-specific (alt picks the taken branch).
(define host/comp--deps-leaf
(fn (node ctx dom)
(if (and (= (type-of node) "list") (= (str (first node)) "ref"))
(list (str (first (rest node))))
(list))))
(define host/comp--deps-dom
{:empty (list) :combine concat :overflow (list) :leaf host/comp--deps-leaf})
(define host/comp-deps (fn (node ctx) (host/comp-fold node ctx host/comp--deps-dom)))

207
lib/host/conformance.sh Executable file
View File

@@ -0,0 +1,207 @@
#!/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 sxtp # run ONLY the sxtp suite (fast — skips
# # the Datalog-heavy blog suite)
# bash lib/host/conformance.sh blog -v # one suite, verbose
# bash lib/host/conformance.sh -v # all suites, verbose
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
# Args: an optional suite NAME runs just that suite (fast); -v is verbose per-suite.
VERBOSE=""
SUITE_FILTER=""
for arg in "$@"; do
case "$arg" in
-v|--verbose) VERBOSE="-v" ;;
*) SUITE_FILTER="$arg" ;;
esac
done
# 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/session.sx"
"lib/dream/router.sx"
"lib/host/handler.sx"
"lib/host/middleware.sx"
"lib/host/session.sx"
"lib/host/auth.sx"
"lib/host/sxtp.sx"
"lib/host/router.sx"
"lib/host/static.sx"
"lib/host/sx/relate-picker.sx"
"lib/host/sx/kg-cards.sx"
"lib/host/feed.sx"
"lib/host/relations.sx"
"lib/host/compose.sx"
"lib/host/execute.sx"
"lib/host/htmlsx.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"
"htmlsx host-ht-tests-run! lib/host/tests/htmlsx.sx"
"compose host-cp-tests-run! lib/host/tests/compose.sx"
"execute host-ex-tests-run! lib/host/tests/execute.sx"
"session host-se-tests-run! lib/host/tests/session.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"
)
# Filter to a single suite if a name was given (filter the array itself so its
# indices stay aligned with the result-parsing loop below). All MODULES still load
# — the host modules are interdependent; only the TEST suites are narrowed.
if [ -n "$SUITE_FILTER" ]; then
_FILTERED=()
for SUITE in "${SUITES[@]}"; do
[ "$(echo "$SUITE" | awk '{print $1}')" = "$SUITE_FILTER" ] && _FILTERED+=("$SUITE")
done
if [ "${#_FILTERED[@]}" -eq 0 ]; then
echo "ERROR: no suite named '$SUITE_FILTER'. Valid names:" >&2
for SUITE in "${SUITES[@]}"; do echo " $(echo "$SUITE" | awk '{print $1}')" >&2; done
exit 1
fi
SUITES=("${_FILTERED[@]}")
fi
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"
# 1200s: the blog suite drives the relations graph hard (every is-a/types-of/
# instances-of query re-saturates the Datalog db), so it's CPU-bound and much slower
# under shared-box contention (a sibling loop at load ~6 pushed it past 600s -> false
# "no suite results parsed" truncation). Override with SX_CONF_TIMEOUT for a tighter cap.
OUTPUT=$(timeout "${SX_CONF_TIMEOUT:-1200}" "$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

40
lib/host/execute.sx Normal file
View File

@@ -0,0 +1,40 @@
;; lib/host/execute.sx — the EXECUTE-fold: a SECOND domain over the SAME composition core
;; as the render-fold (lib/host/compose.sx), proving the algebra is domain-agnostic
;; (plans/composition-objects.md steps 7-8). Now that the core (host/comp-fold: the seq/alt/
;; each dispatch + when-predicates + each-source + context-environment + recursion) is shared,
;; a whole new domain is just a DOMAIN DICT + a leaf function:
;;
;; render {:empty "" :combine str …} leaf -> markup; fold -> HTML string
;; execute {:empty (list) :combine concat …} leaf -> effect; fold -> effect log
;;
;; seq = steps in order, alt+when = branch, each = for-each — all from the core, unchanged.
;; Only the leaf semantics (effect vs markup) and the accumulator (list vs string) are new.
;; So the behaviour model (Slice 9) is "an execute-fold over a composition object", not a
;; separate system — the same structure an author edits as a document.
;; resolve an effect argument against the context: (field K) reads the :item/ctx value via
;; the SAME resolver the render-fold uses; anything else is a literal.
(define host/exec--arg
(fn (a ctx)
(if (and (= (type-of a) "list") (= (str (first a)) "field"))
(host/comp--field (first (rest a)) ctx)
a)))
;; the execute-fold's LEAF: an (effect VERB ARG…) node records one effect {:verb :args};
;; anything else contributes no effects. (The core handles seq/alt/each.)
(define host/exec--leaf
(fn (node ctx dom)
(if (not (= (type-of node) "list"))
(list)
(let ((h (str (first node))) (args (rest node)))
(if (= h "effect")
(list {:verb (str (first args)) :args (map (fn (a) (host/exec--arg a ctx)) (rest args))})
(list))))))
;; the execute DOMAIN: effects concatenate into a log; the depth guard yields a max-depth
;; effect. host/comp-fold (compose.sx) supplies the seq/alt/each walk + when + each source.
(define host/exec--dom
{:empty (list) :combine concat :overflow (list {:verb "max-depth" :args (list)}) :leaf host/exec--leaf})
;; public entry: execute a composition node against a context -> the effect log (the run).
(define host/exec-run (fn (node ctx) (host/comp-fold node ctx host/exec--dom)))

49
lib/host/feed.sx Normal file
View 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 text/sx body. Returns 201 + the created
;; (normalised) activity. Body must be an SX dict; anything else -> 400.
(define host/feed-create
(fn (req)
(let ((raw (host/sx-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)))))

41
lib/host/handler.sx Normal file
View File

@@ -0,0 +1,41 @@
;; 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 SX-native envelope every host
;; endpoint shares — text/sx, serialized SX wire format (NOT JSON): {:ok true
;; :data ...} on success, {:ok false :error ...} on failure. The platform speaks
;; SX end to end; JSON lives only at the ActivityPub federation edge (JSON-LD).
;; Depends on lib/dream/types.sx.
;; ── responses ──────────────────────────────────────────────────────
;; SX response at an arbitrary status: content-type text/sx, body = the value
;; serialized to SX wire format (the same `serialize` SXTP uses). The SX engine /
;; WASM kernel parses this directly — NO JSON on the internal wire.
(define host/sx-status
(fn (status value)
(dream-response status {:content-type "text/sx; charset=utf-8"}
(serialize value))))
;; Success envelope: 200 {:ok true :data <value>}.
(define host/ok
(fn (value)
(host/sx-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/sx-status status {:ok true :data value})))
;; Error envelope: {:ok false :error <message>} at the given status.
(define host/error
(fn (status message)
(host/sx-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))))

116
lib/host/htmlsx.sx Normal file
View File

@@ -0,0 +1,116 @@
;; lib/host/htmlsx.sx — a pure-SX HTML → SX converter (the "radar migrator" core). Turns a
;; post's HTML content into an SX (article …) tree that host/blog--decompose! consumes: img,
;; p, figure/figcaption, iframe, headings, blockquote, lists, inline strong/em/a (kept nested;
;; decompose flattens them to text at the block level). Char-level tokenizer + a stack parser.
;; NOTE: substr is (string, start, LENGTH); index-of returns -1 when absent.
;; ── string helpers ──────────────────────────────────────────────────
(define host/html--at (fn (s i) (if (< i (len s)) (substr s i 1) "")))
(define host/html--from (fn (s i) (substr s i (- (len s) i)))) ;; s[i:]
(define host/html--slice (fn (s a b) (substr s a (- b a)))) ;; s[a:b)
(define host/html--replace-all
(fn (s old new)
(let ((i (index-of s old)))
(if (< i 0) s
(str (host/html--slice s 0 i) new
(host/html--replace-all (host/html--from s (+ i (len old))) old new))))))
;; ── entity decode (the common named + a few numeric entities → UTF-8) ──
(define host/html--entities
(list (list "&nbsp;" " ") (list "&amp;" "&") (list "&lt;" "<") (list "&gt;" ">")
(list "&quot;" "\"") (list "&#39;" "'") (list "&apos;" "'") (list "&#x27;" "'")
(list "&#x2019;" "’") (list "&#8217;" "’") (list "&#x2018;" "‘")
(list "&hellip;" "…") (list "&#x2026;" "…") (list "&mdash;" "—") (list "&ndash;" "–")
(list "&pound;" "£") (list "&#xA3;" "£") (list "&#163;" "£")))
(define host/html--decode
(fn (s) (reduce (fn (acc pair) (host/html--replace-all acc (first pair) (first (rest pair)))) s host/html--entities)))
;; ── tag classification + name/attr parsing ──────────────────────────
(define host/html--void?
(fn (n) (contains? (list "img" "br" "hr" "iframe" "input" "meta" "link" "source" "embed") n)))
;; the tag name from a tag's inner text ("img src=…" -> "img"): up to the first space or '/'.
(define host/html--tag-name
(fn (inner)
(let ((sp (index-of inner " ")))
(lower (trim (host/html--replace-all (if (< sp 0) inner (host/html--slice inner 0 sp)) "/" ""))))))
;; parse the attrs of a tag's inner text into a dict (quoted or unquoted values).
(define host/html--attrs-loop
(fn (rest acc)
(let ((r (trim rest)))
(if (or (= r "") (= r "/")) acc
(let ((eq (index-of r "=")))
(if (< eq 0) acc
(let ((name (lower (trim (host/html--slice r 0 eq))))
(after (trim (host/html--from r (+ eq 1)))))
(let ((q (host/html--at after 0)))
(if (or (= q "\"") (= q "'"))
(let ((close (index-of (host/html--from after 1) q)))
(if (< close 0) acc
(host/html--attrs-loop (host/html--from after (+ close 2))
(assoc acc name (host/html--decode (host/html--slice after 1 (+ 1 close)))))))
(let ((sp2 (index-of after " ")))
(host/html--attrs-loop (if (< sp2 0) "" (host/html--from after sp2))
(assoc acc name (if (< sp2 0) after (host/html--slice after 0 sp2))))))))))))))
(define host/html--parse-attrs
(fn (inner)
(let ((sp (index-of inner " ")))
(if (< sp 0) {} (host/html--attrs-loop (host/html--from inner (+ sp 1)) {})))))
;; ── tokenizer: HTML string → a list of {:t text|open|close|void …} tokens ──
(define host/html--tokens
(fn (s)
(let loop ((i 0) (acc (list)))
(if (>= i (len s)) acc
(if (= (host/html--at s i) "<")
(let ((rel (index-of (host/html--from s i) ">")))
(if (< rel 0) acc
(let ((gt (+ i rel)) (inner (host/html--slice s (+ i 1) (+ i rel))))
(cond
((starts-with? inner "!") (loop (+ gt 1) acc)) ;; comment / doctype
((starts-with? inner "/")
(loop (+ gt 1) (concat acc (list {:t "close" :name (host/html--tag-name (host/html--from inner 1))}))))
(else
(let ((name (host/html--tag-name inner)))
(loop (+ gt 1) (concat acc (list {:t (if (or (host/html--void? name) (ends-with? inner "/")) "void" "open")
:name name :attrs (host/html--parse-attrs inner)})))))))))
(let ((rel (index-of (host/html--from s i) "<")))
(let ((te (if (< rel 0) (len s) (+ i rel))))
(let ((txt (host/html--decode (host/html--slice s i te))))
(loop te (if (= (trim txt) "") acc (concat acc (list {:t "text" :text txt}))))))))))))
;; ── parser: tokens → a tree of {:name :attrs :kids} nodes (kids: node | string, in order).
;; A functional stack of open frames; a synthetic root frame collects the top-level nodes. ──
(define host/html--push-kid
(fn (stack kid)
(let ((top (first stack)))
(cons (assoc top :kids (concat (get top :kids) (list kid))) (rest stack)))))
(define host/html--parse
(fn (tokens)
(let loop ((ts tokens) (stack (list {:name "article" :attrs {} :kids (list)})))
(if (empty? ts) (get (first stack) :kids)
(let ((tok (first ts)))
(cond
((= (get tok :t) "text") (loop (rest ts) (host/html--push-kid stack (get tok :text))))
((= (get tok :t) "void") (loop (rest ts) (host/html--push-kid stack {:name (get tok :name) :attrs (get tok :attrs) :kids (list)})))
((= (get tok :t) "open") (loop (rest ts) (cons {:name (get tok :name) :attrs (get tok :attrs) :kids (list)} stack)))
((= (get tok :t) "close")
(if (> (len stack) 1)
(loop (rest ts) (host/html--push-kid (rest stack) (first stack)))
(loop (rest ts) stack)))
(else (loop (rest ts) stack))))))))
;; ── tree → SX. A node becomes (name :attr val … child …); text stays a string. Attr keys
;; become keywords via parse-safe (":src" -> the keyword :src) so decompose reads them. ──
(define host/html--attrs->sx
(fn (attrs)
(reduce (fn (acc k) (concat acc (list (parse-safe (str ":" k)) (get attrs k)))) (list) (keys attrs))))
(define host/html--node->sx
(fn (node)
(if (= (type-of node) "string") node
(cons (string->symbol (get node :name))
(concat (host/html--attrs->sx (get node :attrs))
(map host/html--node->sx (get node :kids)))))))
;; HTML content string → an (article …) SX tree, ready for host/blog--decompose!.
(define host/html->sx
(fn (html)
(cons (quote article) (map host/html--node->sx (host/html--parse (host/html--tokens html))))))

89
lib/host/ledger.sx Normal file
View 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))})))

74
lib/host/live-check.sh Executable file
View File

@@ -0,0 +1,74 @@
#!/usr/bin/env bash
# Non-browser live-check for the host: spins up an EPHEMERAL host server (this
# worktree's binary + lib + web, a temp persist dir), logs in, seeds one post, then
# runs a sequence of HTTP checks printing status | content-type | body-head for each.
# Catches what conformance can't — the real http-listen serving path (serving-JIT
# divergence, VmSuspended renders, content-type regressions) — without a browser and
# without touching live data. The non-Playwright counterpart to run-picker-check.sh.
#
# bash lib/host/live-check.sh # default smoke: /health /posts /feed / /<seeded>/
# bash lib/host/live-check.sh /tags /article/ # check specific GET paths instead
#
# Asserts: reads are text/sx (the SX-native wire), pages are non-empty, no 5xx.
# Requires the OCaml binary built (hosts/ocaml/_build/default/bin/sx_server.exe).
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
PORT="${LIVE_PORT:-8914}"
USER="admin"; PASS="live-check-pw"; SECRET="live-check-secret"
PDIR=$(mktemp -d); JAR=$(mktemp); LOG=$(mktemp); HDR=$(mktemp)
BASE="http://127.0.0.1:$PORT"
RC=0
cleanup() {
local pid
pid=$(ss -lptn "sport = :$PORT" 2>/dev/null | grep -oE 'pid=[0-9]+' | head -1 | cut -d= -f2)
[ -n "$pid" ] && kill "$pid" 2>/dev/null
rm -f "$JAR" "$LOG" "$HDR"; rm -rf "$PDIR"
}
trap cleanup EXIT
echo "== booting ephemeral host on :$PORT (persist=$PDIR) =="
# SX_SERVING_JIT=1 to MATCH THE CONTAINER: it gates the http-listen IO resolver, so
# without it perform-heavy paths (e.g. reach-down's BFS over the type graph — the is-a/
# tags picker) falsely raise VmSuspended -> 500. The live container sets it; the harness
# must too, or it reports false 500s the live site never shows.
SX_SERVING_JIT=1 HOST_PORT="$PORT" SX_PERSIST_DIR="$PDIR" \
SX_ADMIN_USER="$USER" SX_ADMIN_PASSWORD="$PASS" SX_SESSION_SECRET="$SECRET" \
bash lib/host/serve.sh >"$LOG" 2>&1 &
for i in $(seq 1 60); do
curl -sf -o /dev/null "$BASE/health" 2>/dev/null && break
sleep 1; [ "$i" = "60" ] && { echo "server never came up:"; cat "$LOG"; exit 1; }
done
echo "== up =="
# Log in + seed one post (also exercises the form-ingest write path).
curl -s -c "$JAR" -o /dev/null -X POST "$BASE/login" --data "username=$USER&password=$PASS"
curl -s -b "$JAR" -o /dev/null -X POST "$BASE/new" \
--data 'title=Live Check Post&sx_content=(article (h1 "Live Check Post") (p "ok"))&status=published'
# A GET check: prints "<status> <content-type> | <body-head>" and flags problems.
check() {
local path="$1" body ct code
body=$(curl -s -b "$JAR" -D "$HDR" "$BASE$path")
code=$(awk 'NR==1{print $2}' "$HDR")
ct=$(grep -i '^content-type:' "$HDR" | head -1 | tr -d '\r' | sed 's/content-type: *//I')
printf ' %-20s %s %-26s | %s\n' "$path" "${code:-???}" "${ct:-?}" "$(printf '%s' "$body" | tr '\n' ' ' | cut -c1-70)"
case "$code" in 5*) echo " !! 5xx"; RC=1 ;; esac
[ -z "$body" ] && { echo " !! empty body"; RC=1; }
# data endpoints must be SX, never JSON
case "$path" in
/posts|/feed) echo "$ct" | grep -qi 'text/sx' || { echo " !! expected text/sx, got '$ct'"; RC=1; }
printf '%s' "$body" | grep -q '"ok":' && { echo " !! JSON leaked"; RC=1; } ;;
esac
}
echo "== checks =="
if [ "$#" -gt 0 ]; then
for p in "$@"; do check "$p"; done
else
for p in /health /posts /feed / /live-check-post/; do check "$p"; done
fi
echo "== done (rc $RC) =="
exit $RC

54
lib/host/middleware.sx Normal file
View 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
View 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)))))

70
lib/host/playwright/block-editor.spec.js Normal file
View File

@@ -0,0 +1,70 @@
// Browser check for the BLOCK EDITOR (lib/host/blog.sx, composition step 6). Runs against
// an ephemeral host server seeded with one editable host post by run-block-check.sh, which
// copies this spec into the Playwright env and sets SX_TEST_URL.
//
// What needs a real boosted-SPA browser (the SX conformance tests cover the model ops +
// server routes; this covers the live SX-htmx swap the engine drives): adding, reordering,
// and removing blocks re-renders #block-editor IN PLACE (sx-post → outerHTML swap), and the
// controls RE-BIND on the content brought in by each swap (the case an inline script fails).
const { test, expect } = require('playwright/test');
const USER = process.env.SX_ADMIN_USER || 'admin';
const PASS = process.env.SX_ADMIN_PASSWORD || 'letmein';
const HOST = 'block-host'; // the post whose edit page we drive
const BE = '#block-editor';
const ROWS = `${BE} > ul > li`; // block rows (exclude the add form)
async function waitReady(page) {
await expect(page.locator('html[data-sx-ready="true"]')).toHaveCount(1, { timeout: 45000 });
}
async function loginTo(page, path) {
await page.goto(path);
await page.waitForURL(/\/login/);
await page.fill('input[name="username"]', USER);
await page.fill('input[name="password"]', PASS);
await page.click('button[type="submit"]');
await page.waitForURL((u) => !u.pathname.startsWith('/login'));
}
// add a block via the add-block form (select a card type, type text, submit).
async function addBlock(page, ctype, text) {
await page.selectOption(`${BE} select[name="ctype"]`, ctype);
await page.fill(`${BE} input[name="text"]`, text);
await page.click(`${BE} form[sx-post$="/blocks/add"] button`);
}
test.describe('block editor (browser-only, live SX-htmx swap)', () => {
test('add, reorder, and remove blocks re-render #block-editor in place', async ({ page }) => {
test.setTimeout(90000);
await loginTo(page, `/${HOST}/edit`);
await waitReady(page);
await page.evaluate(() => { window.__noReload = true; });
// a fresh post has no :body -> no blocks yet
await expect(page.locator(ROWS)).toHaveCount(0);
// ADD #1 (text) -> one row appears live, showing its preview
await addBlock(page, 'card-text', 'First block');
await expect.poll(() => page.locator(ROWS).count(), { timeout: 15000 }).toBe(1);
await expect(page.locator(BE)).toContainText('First block');
// ADD #2 (heading) -> a second row on the swapped-in editor (controls re-bound)
await addBlock(page, 'card-heading', 'A Heading');
await expect.poll(() => page.locator(ROWS).count(), { timeout: 15000 }).toBe(2);
// order is add-order: block 0 = First block, block 1 = A Heading
await expect(page.locator(`${ROWS}`).first()).toContainText('First block');
// REORDER: move the 2nd block (A Heading) UP -> it becomes the first row
await page.locator(`${ROWS}`).nth(1).locator('button', { hasText: '↑' }).click();
await expect.poll(
() => page.locator(`${ROWS}`).first().innerText(), { timeout: 15000 }
).toContain('A Heading');
await expect(page.locator(ROWS)).toHaveCount(2);
// REMOVE the first row (A Heading) -> one row remains (First block)
await page.locator(`${ROWS}`).first().locator('button', { hasText: 'remove' }).click();
await expect.poll(() => page.locator(ROWS).count(), { timeout: 15000 }).toBe(1);
await expect(page.locator(BE)).toContainText('First block');
await expect(page.locator(BE)).not.toContainText('A Heading');
});
});

107
lib/host/playwright/boost-nav.spec.js Normal file
View File

@@ -0,0 +1,107 @@
// Regression for the boosted-navigation link-rebinding bug (reported on blog.rose-ash.com):
// home --boosted nav--> a post --click "edit"--> lands on /tags (a HOME footer link),
// not /<slug>/edit. After a boost swap, the swapped-in links carry a STALE binding from
// the previous page. Run by run-boost-nav-check.sh against an ephemeral host server
// (serve.sh seeds /compose-demo + the home footer's /tags link).
const { test, expect } = require('playwright/test');
const BASE = process.env.SX_TEST_URL || 'http://127.0.0.1:8914';
const USER = process.env.SX_ADMIN_USER || 'admin';
const PASS = process.env.SX_ADMIN_PASSWORD || 'letmein';
async function waitReady(page) {
await expect(page.locator('html[data-sx-ready="true"]')).toHaveCount(1, { timeout: 45000 });
}
async function login(page) {
await page.goto(BASE + '/login');
await page.fill('input[name="username"]', USER);
await page.fill('input[name="password"]', PASS);
await page.click('button[type="submit"]');
await page.waitForURL((u) => !u.pathname.startsWith('/login'));
}
test.describe('boosted navigation (browser-only)', () => {
test('a post link clicked AFTER a boosted nav navigates to the right target (not a stale home link)', async ({ page }) => {
test.setTimeout(90000);
// 1) load HOME (its footer has a /tags link — the stale target the bug lands on)
await page.goto(BASE + '/');
await waitReady(page);
await expect(page.locator('a[href="/tags"]')).toHaveCount(1); // home has the /tags link
// 2) boosted nav HOME -> the composed post (no full reload)
await page.locator('a[href="/compose-demo/"]').first().click();
await expect(page.locator('body')).toContainText('composition object', { timeout: 15000 });
expect(page.url()).toContain('/compose-demo/');
// 3) click the post's "edit" link — brought in by the swap
await expect(page.locator('a[href="/compose-demo/edit"]')).toHaveCount(1);
await page.locator('a[href="/compose-demo/edit"]').click();
await page.waitForTimeout(3000);
// 4) it MUST navigate to the edit route (guarded -> the login view is fine, the URL is
// pushed to /compose-demo/edit), and MUST NOT land on the stale /tags link.
expect(page.url()).not.toContain('/tags');
expect(page.url()).toContain('/compose-demo/edit');
});
test('a guarded route reached via boost does a clean full-nav to /login (no clobbered SPA), and Home works from there', async ({ page }) => {
test.setTimeout(90000);
await page.goto(BASE + '/');
await waitReady(page);
// boosted nav home -> post
await page.locator('a[href="/compose-demo/"]').first().click();
await expect(page.locator('body')).toContainText('composition object', { timeout: 15000 });
// click "edit" (guarded, logged out). A 303 would be followed by the fetch WITHOUT the
// SX-Request header -> /login returns the full shell, which morphed into #content
// DESTROYS the swap target (then nothing navigates). The fix returns SX-Redirect, so the
// engine does a FULL navigation to a real /login page.
await page.locator('a[href="/compose-demo/edit"]').click();
await page.waitForTimeout(3500);
expect(new URL(page.url()).pathname).toBe('/login');
await expect(page.locator('body')).toContainText('Log in');
// and the login page offers a way back Home that works (the reported "Home does nothing").
await page.locator('a[href="/"]').first().click();
await page.waitForTimeout(3000);
await expect(page.locator('body')).toContainText('Posts', { timeout: 12000 });
expect(new URL(page.url()).pathname).toBe('/');
});
test('LOGGED IN: the Home nav works after a boosted nav to the edit page', async ({ page }) => {
test.setTimeout(90000);
await login(page); // authed session
await page.goto(BASE + '/');
await waitReady(page);
// boosted nav home -> post -> edit (authed, so the real edit form swaps into #content)
await page.locator('a[href="/compose-demo/"]').first().click();
await expect(page.locator('body')).toContainText('composition object', { timeout: 15000 });
// the footer "edit" link (there's also a "no relations — add some" link to edit when authed)
await page.locator('a[href="/compose-demo/edit"]').last().click();
await expect(page.locator('body')).toContainText('Edit:', { timeout: 15000 });
expect(new URL(page.url()).pathname).toBe('/compose-demo/edit');
// #content must SURVIVE the edit swap (an outerHTML swap would replace it, then no later
// nav can find a swap target — the reported "Home does nothing").
expect(await page.locator('#content').count()).toBe(1);
// the persistent top-nav Home link must still work on the edit page.
await page.locator('nav a[href="/"]').first().click();
await page.waitForTimeout(3000);
await expect(page.locator('body')).toContainText('Posts', { timeout: 12000 });
expect(new URL(page.url()).pathname).toBe('/');
});
test('LOGGED IN: the block-editor card-type dropdown populates after a boosted nav to edit', async ({ page }) => {
test.setTimeout(90000);
await login(page);
await page.goto(BASE + '/');
await waitReady(page);
await page.locator('a[href="/compose-demo/"]').first().click();
await expect(page.locator('body')).toContainText('composition object', { timeout: 15000 });
await page.locator('a[href="/compose-demo/edit"]').last().click();
await expect(page.locator('body')).toContainText('Edit:', { timeout: 15000 });
// the ctype <select> must have selectable <option> DIRECT children. A <span> wrapper
// leaves the dropdown empty when the DOM is built programmatically on a boosted swap
// (the HTML parser would hoist them out on a full load, hiding the bug there).
await expect(page.locator('#block-editor select[name="ctype"] > option')).toHaveCount(5, { timeout: 10000 });
await expect(page.locator('#block-editor select[name="ctype"] > option[value="card-heading"]')).toHaveCount(1);
});
});

118
lib/host/playwright/relate-picker.spec.js Normal file
View File

@@ -0,0 +1,118 @@
// Browser check for the relate picker (lib/host/blog.sx). Runs against an
// ephemeral host server seeded with a host post + 25 candidates by
// run-picker-check.sh, which copies this spec into the Playwright env and sets
// SX_TEST_URL.
//
// TRIMMED to the irreducibly-real-browser cases. The picker's interactive
// behaviours — populate-on-load, debounced filter, sentinel paging, relate→delete
// row, error/retry visible state — are now SX engine tests in
// web/tests/test-relate-picker.sx (they drive the SAME engine against a mock DOM,
// no Chromium). Its server contract + persistence are SX conformance tests in
// lib/host/tests/blog.sx. What remains here needs a live boosted-SPA browser:
// 1. a boosted form POST swaps in place (bind-boost-form regression), and
// 2. the picker re-binds its triggers on content brought in by a boosted SPA
// nav (the case an inline <script> picker silently failed).
const { test, expect } = require('playwright/test');
const USER = process.env.SX_ADMIN_USER || 'admin';
const PASS = process.env.SX_ADMIN_PASSWORD || 'letmein';
const HOST = 'picker-host'; // the post whose edit page we drive
// the Related picker box (the edit page now has one picker per kind)
const REL = '.relate-picker[data-kind="related"]';
const RELF = `${REL} .rp-filter`;
const RELR = `${REL} .rp-results`;
const RELROWS = `${RELR} li:not(.rp-more)`; // candidate rows (exclude the sentinel)
// boot-init marks <html data-sx-ready="true"> once the WASM kernel + web stack
// load. WASM compile + asset fetches, so allow generous time.
async function waitReady(page) {
await expect(page.locator('html[data-sx-ready="true"]')).toHaveCount(1, { timeout: 45000 });
}
// Navigate to a GUARDED path; the host redirects to /login?next=…, so fill the
// form and we should land back on the original path (exercises the auth flow).
async function loginTo(page, path) {
await page.goto(path);
await page.waitForURL(/\/login/);
await page.fill('input[name="username"]', USER);
await page.fill('input[name="password"]', PASS);
await page.click('button[type="submit"]');
await page.waitForURL((u) => !u.pathname.startsWith('/login'));
}
// Log in directly (for reaching PUBLIC pages while authenticated).
async function login(page) {
await page.goto('/login');
await page.fill('input[name="username"]', USER);
await page.fill('input[name="password"]', PASS);
await page.click('button[type="submit"]');
await page.waitForURL((u) => !u.pathname.startsWith('/login'));
}
test.describe('relate picker (browser-only)', () => {
test('relating a candidate adds it to the current list AND removing keeps the picker', async ({ page }) => {
// The whole in-page flow the user reported broken — no reloads. Relating a
// candidate re-renders the editor: the post moves into the current-relations
// list and the picker re-loads its candidates (it is NOT blanked). Removing it
// re-renders the editor back: the post leaves the current list and the picker
// still offers candidates.
test.setTimeout(75000);
await loginTo(page, `/${HOST}/edit`);
await waitReady(page);
await page.evaluate(() => { window.__noReload = true; });
// relate Item 13 from the picker
await page.fill(RELF, 'Item 13');
await expect.poll(() => page.locator(RELROWS).count(), { timeout: 10000 }).toBe(1);
await page.locator(`${RELROWS} button`).first().click();
const relLink = page.locator('a[href="/picker-item-13/"]');
// ISSUE 1: it now appears in the CURRENT relations list (added, not just removed)
await expect(relLink).toHaveCount(1, { timeout: 12000 });
// and the re-rendered picker still offers candidates (not blanked)
await expect.poll(() => page.locator(RELROWS).count(), { timeout: 12000 }).toBeGreaterThan(0);
// now remove it via its current-list remove button
await page.locator('li:has(a[href="/picker-item-13/"]) button').click();
await expect(relLink).toHaveCount(0, { timeout: 12000 }); // left the current list
// ISSUE 2: removing must NOT clear "the list of posts to relate"
await expect.poll(() => page.locator(RELROWS).count(), { timeout: 12000 }).toBeGreaterThan(0);
expect(await page.evaluate(() => window.__noReload)).toBe(true); // all in-page, no reload
// and the relation truly persisted gone (reload shows it not present)
await page.reload();
await waitReady(page);
await expect(page.locator('a[href="/picker-item-13/"]')).toHaveCount(0);
});
test('relating a candidate persists the relation', async ({ page }) => {
test.setTimeout(75000);
await loginTo(page, `/${HOST}/edit`);
await waitReady(page);
await page.fill(RELF, 'Item 07');
await expect.poll(() => page.locator(RELROWS).count(), { timeout: 10000 }).toBe(1);
await page.locator(`${RELROWS} button`).first().click();
await expect(page.locator('a[href="/picker-item-07/"]')).toHaveCount(1, { timeout: 12000 });
// persisted across a reload
await page.reload();
await waitReady(page);
await expect(page.locator('a[href="/picker-item-07/"]')).toHaveCount(1);
// and visible on the public post page
await page.goto(`/${HOST}/`);
await expect(page.getByRole('heading', { name: 'Related posts' })).toBeVisible();
await expect(page.locator('body')).toContainText('Picker Item 07');
});
test('picker populates after a boosted SPA nav to the edit page', async ({ page }) => {
// Reach the edit page by CLICKING its link (a boosted SPA nav), not page.goto.
// The old inline <script> picker never ran on swapped-in content, so the list
// stayed empty here. The declarative form's "load" trigger is re-bound by the
// engine on swap, so it populates — that's the regression this guards.
await login(page);
await page.goto(`/${HOST}/`); // public post page, logged in
await waitReady(page);
await page.evaluate(() => { window.__noReload = true; });
await page.locator(`a[href="/${HOST}/edit"]`).first().click();
await page.waitForURL((u) => u.pathname === `/${HOST}/edit`, { timeout: 15000 });
expect(await page.evaluate(() => window.__noReload)).toBe(true); // it was a SPA nav, no full reload
// the picker, brought in by the swap, loaded its first page of candidates
await expect.poll(() => page.locator(RELROWS).count(), { timeout: 12000 }).toBeGreaterThanOrEqual(1);
await expect(page.locator(RELR)).toContainText('Picker Item');
});
});

65
lib/host/playwright/run-block-check.sh Executable file
View File

@@ -0,0 +1,65 @@
#!/usr/bin/env bash
# Browser check for the BLOCK EDITOR (composition step 6). Spins up an EPHEMERAL host
# server (this worktree's binary + lib, a temp persist dir), seeds ONE editable host post,
# runs lib/host/playwright/block-editor.spec.js in the main worktree's Playwright, then
# tears everything down. No live-site dependency, no live-data pollution.
#
# bash lib/host/playwright/run-block-check.sh
#
# Requires: the OCaml binary built (hosts/ocaml/_build/default/bin/sx_server.exe)
# and Playwright + chromium in /root/rose-ash (the architecture worktree).
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
ROOT=$(pwd)
PORT="${BLOCK_PORT:-8913}"
PW_DIR="${PW_DIR:-/root/rose-ash}" # worktree that has node_modules + chromium
USER="admin"
PASS="block-check-pw"
SECRET="block-check-secret"
PDIR=$(mktemp -d)
JAR=$(mktemp)
SPEC_SRC="lib/host/playwright/block-editor.spec.js"
SPEC_DST="$PW_DIR/tests/playwright/_block-check.spec.js"
SERVE_LOG=$(mktemp)
cleanup() {
[ -n "${SVPID:-}" ] && kill "$SVPID" 2>/dev/null
local pid
pid=$(ss -lptn "sport = :$PORT" 2>/dev/null | grep -oE 'pid=[0-9]+' | head -1 | cut -d= -f2)
[ -n "$pid" ] && kill "$pid" 2>/dev/null
rm -f "$SPEC_DST" "$JAR" "$SERVE_LOG"
rm -rf "$PDIR"
}
trap cleanup EXIT
echo "== starting ephemeral host server on :$PORT (persist=$PDIR) =="
# SX_SERVING_JIT=1 matches the live container (gates the http-listen IO resolver).
SX_SERVING_JIT=1 HOST_PORT="$PORT" SX_PERSIST_DIR="$PDIR" \
SX_ADMIN_USER="$USER" SX_ADMIN_PASSWORD="$PASS" SX_SESSION_SECRET="$SECRET" \
bash lib/host/serve.sh >"$SERVE_LOG" 2>&1 &
SVPID=$!
for i in $(seq 1 60); do
curl -sf -o /dev/null "http://127.0.0.1:$PORT/health" 2>/dev/null && break
sleep 1
[ "$i" = "60" ] && { echo "server never came up:"; cat "$SERVE_LOG"; exit 1; }
done
echo "== server up =="
echo "== seeding 1 editable host post (block-host) =="
curl -s -c "$JAR" -o /dev/null -X POST "http://127.0.0.1:$PORT/login" \
--data "username=$USER&password=$PASS"
curl -s -b "$JAR" -o /dev/null -X POST "http://127.0.0.1:$PORT/new" \
--data 'title=Block Host&sx_content=(p "host")&status=published'
echo "== running Playwright =="
cp "$ROOT/$SPEC_SRC" "$SPEC_DST"
cd "$PW_DIR"
SX_TEST_URL="http://127.0.0.1:$PORT" SX_ADMIN_USER="$USER" SX_ADMIN_PASSWORD="$PASS" \
node_modules/.bin/playwright test _block-check.spec.js --workers=1 \
--config tests/playwright/playwright.config.js
RC=$?
echo "== done (exit $RC) =="
exit $RC

51
lib/host/playwright/run-boost-nav-check.sh Executable file
View File

@@ -0,0 +1,51 @@
#!/usr/bin/env bash
# Regression harness for the boosted-nav link-rebinding bug (composition step polish).
# Spins up an EPHEMERAL host server (this worktree's binary + lib + web + WASM), which on
# boot seeds /compose-demo and the home footer's /tags link, runs boost-nav.spec.js in the
# main worktree's Playwright, then tears down. No live-site dependency.
#
# bash lib/host/playwright/run-boost-nav-check.sh
#
# Requires: the OCaml binary built + Playwright + chromium in /root/rose-ash.
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
ROOT=$(pwd)
PORT="${BOOST_PORT:-8914}"
PW_DIR="${PW_DIR:-/root/rose-ash}"
USER="admin"; PASS="boost-check-pw"; SECRET="boost-check-secret"
PDIR=$(mktemp -d)
SPEC_SRC="lib/host/playwright/boost-nav.spec.js"
SPEC_DST="$PW_DIR/tests/playwright/_boost-nav-check.spec.js"
SERVE_LOG=$(mktemp)
cleanup() {
[ -n "${SVPID:-}" ] && kill "$SVPID" 2>/dev/null
local pid
pid=$(ss -lptn "sport = :$PORT" 2>/dev/null | grep -oE 'pid=[0-9]+' | head -1 | cut -d= -f2)
[ -n "$pid" ] && kill "$pid" 2>/dev/null
rm -f "$SPEC_DST" "$SERVE_LOG"; rm -rf "$PDIR"
}
trap cleanup EXIT
echo "== starting ephemeral host server on :$PORT (persist=$PDIR) =="
SX_SERVING_JIT=1 HOST_PORT="$PORT" SX_PERSIST_DIR="$PDIR" \
SX_ADMIN_USER="$USER" SX_ADMIN_PASSWORD="$PASS" SX_SESSION_SECRET="$SECRET" \
bash lib/host/serve.sh >"$SERVE_LOG" 2>&1 &
SVPID=$!
for i in $(seq 1 60); do
curl -sf -o /dev/null "http://127.0.0.1:$PORT/health" 2>/dev/null && break
sleep 1
[ "$i" = "60" ] && { echo "server never came up:"; cat "$SERVE_LOG"; exit 1; }
done
echo "== server up =="
echo "== running Playwright =="
cp "$ROOT/$SPEC_SRC" "$SPEC_DST"
cd "$PW_DIR"
SX_TEST_URL="http://127.0.0.1:$PORT" SX_ADMIN_USER="$USER" SX_ADMIN_PASSWORD="$PASS" \
node_modules/.bin/playwright test _boost-nav-check.spec.js --workers=1 \
--config tests/playwright/playwright.config.js
RC=$?
echo "== done (exit $RC) =="
exit $RC

72
lib/host/playwright/run-picker-check.sh Executable file
View File

@@ -0,0 +1,72 @@
#!/usr/bin/env bash
# Browser check for the relate picker. Spins up an EPHEMERAL host server (this
# worktree's binary + lib, a temp persist dir), seeds a host post + 25 candidates,
# runs lib/host/playwright/relate-picker.spec.js in the main worktree's Playwright,
# then tears everything down. No live-site dependency, no live-data pollution.
#
# bash lib/host/playwright/run-picker-check.sh
#
# Requires: the OCaml binary built (hosts/ocaml/_build/default/bin/sx_server.exe)
# and Playwright + chromium in /root/rose-ash (the architecture worktree).
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
ROOT=$(pwd)
PORT="${PICKER_PORT:-8912}"
PW_DIR="${PW_DIR:-/root/rose-ash}" # worktree that has node_modules + chromium
USER="admin"
PASS="picker-check-pw"
SECRET="picker-check-secret"
PDIR=$(mktemp -d)
JAR=$(mktemp)
SPEC_SRC="lib/host/playwright/relate-picker.spec.js"
SPEC_DST="$PW_DIR/tests/playwright/_picker-check.spec.js"
SERVE_LOG=$(mktemp)
cleanup() {
[ -n "${SVPID:-}" ] && kill "$SVPID" 2>/dev/null
# kill whatever is still bound to the port (serve.sh re-parents via `| exec`)
local pid
pid=$(ss -lptn "sport = :$PORT" 2>/dev/null | grep -oE 'pid=[0-9]+' | head -1 | cut -d= -f2)
[ -n "$pid" ] && kill "$pid" 2>/dev/null
rm -f "$SPEC_DST" "$JAR" "$SERVE_LOG"
rm -rf "$PDIR"
}
trap cleanup EXIT
echo "== starting ephemeral host server on :$PORT (persist=$PDIR) =="
# SX_SERVING_JIT=1 matches the live container (gates the http-listen IO resolver);
# without it, perform-heavy paths (e.g. the is-a/tags picker's reach-down) falsely 500.
SX_SERVING_JIT=1 HOST_PORT="$PORT" SX_PERSIST_DIR="$PDIR" \
SX_ADMIN_USER="$USER" SX_ADMIN_PASSWORD="$PASS" SX_SESSION_SECRET="$SECRET" \
bash lib/host/serve.sh >"$SERVE_LOG" 2>&1 &
SVPID=$!
for i in $(seq 1 60); do
curl -sf -o /dev/null "http://127.0.0.1:$PORT/health" 2>/dev/null && break
sleep 1
[ "$i" = "60" ] && { echo "server never came up:"; cat "$SERVE_LOG"; exit 1; }
done
echo "== server up =="
echo "== seeding 1 host post + 25 candidates =="
curl -s -c "$JAR" -o /dev/null -X POST "http://127.0.0.1:$PORT/login" \
--data "username=$USER&password=$PASS"
curl -s -b "$JAR" -o /dev/null -X POST "http://127.0.0.1:$PORT/new" \
--data 'title=Picker Host&sx_content=(p "host")&status=published'
for n in $(seq -w 1 25); do
curl -s -b "$JAR" -o /dev/null -X POST "http://127.0.0.1:$PORT/new" \
--data "title=Picker Item $n&sx_content=(p \"item $n\")&status=published"
done
echo "== seeded ($(curl -s "http://127.0.0.1:$PORT/posts" | grep -o '"slug"' | wc -l) posts) =="
echo "== running Playwright =="
cp "$ROOT/$SPEC_SRC" "$SPEC_DST"
cd "$PW_DIR"
SX_TEST_URL="http://127.0.0.1:$PORT" SX_ADMIN_USER="$USER" SX_ADMIN_PASSWORD="$PASS" \
node_modules/.bin/playwright test _picker-check.spec.js --workers=1 \
--config tests/playwright/playwright.config.js
RC=$?
echo "== done (exit $RC) =="
exit $RC

68
lib/host/playwright/run-spa-check.sh Normal file
View File

@@ -0,0 +1,68 @@
#!/usr/bin/env bash
# Browser check for the blog SPA. Spins up an EPHEMERAL host server (this
# worktree's binary + lib, a temp persist dir), seeds a couple of posts, runs
# lib/host/playwright/spa-check.spec.js in the main worktree's Playwright, then
# tears everything down. Verifies the WASM OCaml kernel boots in-browser and
# sx-boost turns the blog into a SPA. No live-site dependency.
#
# bash lib/host/playwright/run-spa-check.sh
#
# Requires: the OCaml binary built (hosts/ocaml/_build/default/bin/sx_server.exe)
# and Playwright + chromium in /root/rose-ash (the architecture worktree).
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
ROOT=$(pwd)
PORT="${SPA_PORT:-8914}"
PW_DIR="${PW_DIR:-/root/rose-ash}" # worktree that has node_modules + chromium
USER="admin"
PASS="spa-check-pw"
SECRET="spa-check-secret"
PDIR=$(mktemp -d)
JAR=$(mktemp)
SPEC_SRC="lib/host/playwright/spa-check.spec.js"
SPEC_DST="$PW_DIR/tests/playwright/_spa-check.spec.js"
SERVE_LOG=$(mktemp)
cleanup() {
[ -n "${SVPID:-}" ] && kill "$SVPID" 2>/dev/null
local pid
pid=$(ss -lptn "sport = :$PORT" 2>/dev/null | grep -oE 'pid=[0-9]+' | head -1 | cut -d= -f2)
[ -n "$pid" ] && kill "$pid" 2>/dev/null
rm -f "$SPEC_DST" "$JAR" "$SERVE_LOG"
rm -rf "$PDIR"
}
trap cleanup EXIT
echo "== starting ephemeral host server on :$PORT (persist=$PDIR) =="
HOST_PORT="$PORT" SX_PERSIST_DIR="$PDIR" \
SX_ADMIN_USER="$USER" SX_ADMIN_PASSWORD="$PASS" SX_SESSION_SECRET="$SECRET" \
bash lib/host/serve.sh >"$SERVE_LOG" 2>&1 &
SVPID=$!
for i in $(seq 1 60); do
curl -sf -o /dev/null "http://127.0.0.1:$PORT/health" 2>/dev/null && break
sleep 1
[ "$i" = "60" ] && { echo "server never came up:"; cat "$SERVE_LOG"; exit 1; }
done
echo "== server up =="
echo "== seeding posts =="
curl -s -c "$JAR" -o /dev/null -X POST "http://127.0.0.1:$PORT/login" \
--data "username=$USER&password=$PASS"
for t in "Alpha Post" "Beta Post"; do
curl -s -b "$JAR" -o /dev/null -X POST "http://127.0.0.1:$PORT/new" \
--data "title=$t&sx_content=(article (h1 \"$t\") (p \"body\"))&status=published"
done
echo "== seeded ($(curl -s "http://127.0.0.1:$PORT/posts" | grep -o '"slug"' | wc -l) posts) =="
echo "== running Playwright =="
cp "$ROOT/$SPEC_SRC" "$SPEC_DST"
cd "$PW_DIR"
SX_TEST_URL="http://127.0.0.1:$PORT" \
node_modules/.bin/playwright test _spa-check.spec.js --workers=1 \
--config tests/playwright/playwright.config.js
RC=$?
echo "== done (exit $RC) =="
exit $RC

84
lib/host/playwright/spa-check.spec.js Normal file
View File

@@ -0,0 +1,84 @@
// Browser check for the blog SPA (lib/host/blog.sx + lib/host/static.sx). Runs
// against an ephemeral host server seeded with a couple of posts by
// run-spa-check.sh, which copies this spec into the Playwright env and sets
// SX_TEST_URL. Verifies the WASM OCaml kernel boots in the browser, the SX-htmx
// engine activates sx-boost on #content's links, and clicking a link does a
// fragment swap (no full page reload) with history — i.e. it's a real SPA.
const { test, expect } = require('playwright/test');
// boot-init sets data-sx-ready="true" on <html> once the WASM kernel + web stack
// have loaded and the page has been processed. WASM compile + ~25 asset fetches,
// so allow generous time.
async function waitReady(page) {
await expect(page.locator('html[data-sx-ready="true"]')).toHaveCount(1, { timeout: 45000 });
}
// a post link in the listing (trailing slash); skip /new, /login, /tags.
const POSTLINK = '#content a[href$="/"]';
test.describe('blog SPA', () => {
test('WASM kernel boots, loads modules content-addressed, marks ready', async ({ page }) => {
const errors = [];
// Track web-stack module fetches: content-addressed (/sx/h/{hash}) vs the
// path-based .sxbc fallback. A correctly-booting client takes ONLY the
// content-addressed branch (immutable, localStorage-cached).
const caFetches = []; // /sx/h/{hash}
const pathSxbc = []; // *.sxbc by path (the fallback — should not happen)
page.on('request', (r) => {
const u = r.url();
if (u.includes('/sx/h/')) caFetches.push(u);
else if (/\.sxbc(\?|$)/.test(u)) pathSxbc.push(u);
});
page.on('console', (m) => { if (m.type() === 'error') errors.push(m.text()); });
page.on('pageerror', (e) => errors.push(String(e)));
await page.goto('/');
await waitReady(page);
// the shell shipped the WASM loaders
expect(await page.locator('script[src*="sx_browser.bc.wasm.js"]').count()).toBe(1);
expect(await page.locator('script[src*="sx-platform.js"]').count()).toBe(1);
// modules loaded by content hash, with no path-.sxbc fallback fetches
expect(caFetches.length, 'expected content-addressed /sx/h/ module fetches').toBeGreaterThan(0);
expect(pathSxbc, `path-based .sxbc fallback fetched:\n${pathSxbc.join('\n')}`).toEqual([]);
// no boot-time JS errors
expect(errors, errors.join('\n')).toEqual([]);
});
test('clicking a link does a fragment swap — no full reload, URL updates', async ({ page }) => {
await page.goto('/');
await waitReady(page);
// sentinel survives ONLY if there is no full-page reload
await page.evaluate(() => { window.__noReload = true; });
const link = page.locator(POSTLINK).first();
const href = await link.getAttribute('href');
await link.click();
await page.waitForURL((u) => u.pathname === href, { timeout: 15000 });
expect(await page.evaluate(() => window.__noReload)).toBe(true); // no reload
// content was swapped into #content (a post page carries the post footer)
await expect(page.locator('#content')).toContainText(/all posts/i, { timeout: 15000 });
// the post BODY itself rendered — the <article> comes from raw! HTML, which
// exercises the client SX raw-HTML path (dom-parse-html). If that drops the
// content (NodeList-vs-Node bug), the footer still shows but this fails.
await expect(page.locator('#content article').first()).toBeVisible({ timeout: 15000 });
});
test('back button restores the listing', async ({ page }) => {
await page.goto('/');
await waitReady(page);
const link = page.locator(POSTLINK).first();
const href = await link.getAttribute('href');
await link.click();
await page.waitForURL((u) => u.pathname === href, { timeout: 15000 });
await page.goBack();
await page.waitForURL((u) => u.pathname === '/', { timeout: 15000 });
await expect(page.locator('#content h1')).toContainText('Posts');
// and a click AFTER back must still be a SPA nav, not a full reload — the
// restored content has to be re-boosted (its [sx-boost] marker is an
// ancestor of the swap target, so the re-boost must scan upward).
await page.evaluate(() => { window.__noReload2 = true; });
const link2 = page.locator(POSTLINK).first();
const href2 = await link2.getAttribute('href');
await link2.click();
await page.waitForURL((u) => u.pathname === href2, { timeout: 15000 });
expect(await page.evaluate(() => window.__noReload2)).toBe(true);
});
});

134
lib/host/relations.sx Normal file
View File

@@ -0,0 +1,134 @@
;; 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.
;; Body is text/sx (host/sx-body); non-dict -> 400.
(define host/relations-attach
(fn (req)
(let ((p (host/sx-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.
;; Body is text/sx (host/sx-body); non-dict -> 400.
(define host/relations-detach
(fn (req)
(let ((p (host/sx-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)))))

25
lib/host/router.sx Normal file
View File

@@ -0,0 +1,25 @@
;; 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 + the host
;; session middleware (lib/host/session.sx) and login routes (lib/host/auth.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 + login routes are always mounted; Dream's router returns a
;; JSON 404 for unmatched paths, which host endpoints override per-domain as
;; needed. The WHOLE app is wrapped in the signed-session middleware so every
;; request carries a session and any handler can log a principal in/out — this is
;; the front door, so sessions are not optional.
(define host/make-app
(fn (groups)
(let ((router (dream-router
(cons host/health-route
(cons host/auth-routes groups)))))
((host/sessions) router))))

198
lib/host/serve.sh Executable file
View File

@@ -0,0 +1,198 @@
#!/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/session.sx"
"lib/dream/router.sx"
"lib/host/handler.sx"
"lib/host/middleware.sx"
"lib/host/session.sx"
"lib/host/auth.sx"
"lib/host/sxtp.sx"
"lib/host/router.sx"
"lib/host/static.sx"
"lib/host/sx/relate-picker.sx"
"lib/host/sx/kg-cards.sx"
"lib/host/feed.sx"
"lib/host/relations.sx"
"lib/host/compose.sx"
"lib/host/execute.sx"
"lib/host/htmlsx.sx"
"lib/host/blog.sx"
"lib/host/server.sx"
)
# Admin login credentials + session signing secret. Override via the container
# env; the in-source defaults are dev-only. The blog write routes are now GUARDED
# (session login or Bearer), so these gate publishing on blog.rose-ash.com.
ADMIN_USER="${SX_ADMIN_USER:-admin}"
ADMIN_PASS="${SX_ADMIN_PASSWORD:-letmein}"
SESSION_SECRET="${SX_SESSION_SECRET:-rose-ash-host-dev-secret-change-me}"
EPOCH=1
{
for M in "${MODULES[@]}"; do
echo "(epoch $EPOCH)"; echo "(load \"$M\")"; EPOCH=$((EPOCH+1))
done
# 100% serving JIT — NO host exclude. The serving-JIT perform-in-HO-callback
# miscompile (map/rest/drop wrong args → blank pages, empty picker) is fixed by
# two composing pieces: sx-vm-extensions 81177d0e resolves a callback's IO
# inline (instead of unwinding the native HO loop) WHEN a synchronous resolver
# is installed, and sx_server.ml's http-listen now installs that resolver (it
# mirrors cek_run_with_io exactly). So the whole request path — host app +
# Dream + Datalog — runs under JIT with no exclude. Verified: ephemeral durable
# server, 100% JIT, zero fallbacks, real content, picker lists candidates.
# 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))
# Rebuild the relations graph from the durable edge store. lib/relations holds
# the graph in memory only, so without this, related/tags/types vanish on every
# restart even though the posts persist.
echo "(epoch $EPOCH)"
echo "(eval \"(host/blog-load-edges!)\")"
EPOCH=$((EPOCH+1))
# Sessions on the DURABLE store, LAZILY: only a logged-in session (one that
# writes a field) persists, so a login survives a restart while anonymous /
# crawler traffic leaves no rows. host/session-init! bumps the per-boot epoch
# that keeps sids unique across restarts. Then the signing secret + admin
# credentials, and grant admin "edit" on "blog" so a logged-in session passes
# the ACL gate on the write routes.
echo "(epoch $EPOCH)"
echo "(eval \"(host/session-use-store! (persist/durable-backend))\")"
EPOCH=$((EPOCH+1))
echo "(epoch $EPOCH)"
echo "(eval \"(host/session-init!)\")"
EPOCH=$((EPOCH+1))
echo "(epoch $EPOCH)"
echo "(eval \"(host/session-set-secret! \\\"$SESSION_SECRET\\\")\")"
EPOCH=$((EPOCH+1))
echo "(epoch $EPOCH)"
echo "(eval \"(host/auth-set-admin! \\\"$ADMIN_USER\\\" \\\"$ADMIN_PASS\\\")\")"
EPOCH=$((EPOCH+1))
echo "(epoch $EPOCH)"
echo "(eval \"(acl/load! (list (acl-grant \\\"$ADMIN_USER\\\" \\\"edit\\\" \\\"blog\\\")))\")"
EPOCH=$((EPOCH+1))
# 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-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))
# Seed the root type-posts (type, tag) — types ARE posts. Idempotent.
echo "(epoch $EPOCH)"
echo "(eval \"(host/blog-seed-types!)\")"
EPOCH=$((EPOCH+1))
# Seed a live demo of the composition fold (plans/composition-objects.md): /compose-demo
# is one composition object rendered by host/comp-render — renders differently by context.
echo "(epoch $EPOCH)"
echo "(eval \"(host/blog-seed-compose-demo!)\")"
EPOCH=$((EPOCH+1))
# Seed the EXECUTE-fold demo (composition step 7): /workflow-demo runs ONE composition
# object through host/exec-run — the same algebra as render, folded to an effect log.
echo "(epoch $EPOCH)"
echo "(eval \"(host/blog-seed-workflow-demo!)\")"
EPOCH=$((EPOCH+1))
# Seed a REAL imported blog post (rose-ash.com/nt-live-encore) decomposed into the :body
# composition — so the import survives store wipes, reseeded on boot like the demos.
echo "(epoch $EPOCH)"
echo "(eval \"(host/blog-seed-nt-live-encore!)\")"
EPOCH=$((EPOCH+1))
# Seed the layer-2 demo: a Landing type with TWO composition fields (:body + :aside) + a
# populated instance — so the two-field composition editor + render show side by side.
echo "(epoch $EPOCH)"
echo "(eval \"(host/blog-seed-landing-demo!)\")"
EPOCH=$((EPOCH+1))
# Load relation metadata (symmetry/labels) from the relation-posts into the
# in-memory cache, so render paths read it without a (VmSuspending) durable read.
echo "(epoch $EPOCH)"
echo "(eval \"(host/blog-load-rel-kinds!)\")"
EPOCH=$((EPOCH+1))
# Index the web-stack .sxbc by content hash so /sx/h/{hash} can serve them
# immutably and the shell can emit the data-sx-manifest (content-addressed
# client module cache). Done once at boot.
echo "(epoch $EPOCH)"
echo "(eval \"(host/static-build-sxh-index!)\")"
EPOCH=$((EPOCH+1))
echo "(epoch $EPOCH)"
# Anonymous reads (feed timeline + relations container reads + blog post detail)
# plus the GUARDED blog write routes: POST /new (editor form ingest), POST/PUT/
# DELETE /posts behind host/require-user (session login OR Bearer) + ACL. make-app
# auto-mounts /login + /logout and wraps everything in the signed-session
# middleware, so a browser logs in then publishes. The bearer resolver is a stub
# (no API tokens configured) — browser session is the live auth path for now.
# blog-routes LAST — its GET /:slug catch-all must not shadow the rest.
echo "(eval \"(host/serve $PORT (list host/static-routes host/feed-routes host/relations-routes (host/blog-write-routes (fn (tok) nil)) host/blog-routes))\")"
} | exec "$SX_SERVER"

48
lib/host/server.sx Normal file
View File

@@ -0,0 +1,48 @@
;; 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). :set-cookies is a LIST of
;; pre-formatted cookie strings (Dream's dream-set-cookie); the kernel http-listen
;; emit serialises one Set-Cookie header per item (a headers dict can't hold more
;; than one). Carry it through so sessions/login can set the cookie.
(define host/-dream->native
(fn (resp)
{:status (dream-status resp)
:headers (or (dream-headers resp) {})
:set-cookies (dream-resp-cookies 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)))))

81
lib/host/session.sx Normal file
View File

@@ -0,0 +1,81 @@
;; lib/host/session.sx — durable, signed sessions for the host.
;; Backs Dream's session middleware ops (session/create|exists|get|set|clear)
;; with the SAME durable persist KV the blog uses, so a login survives restarts.
;; The session cookie carries only a signed sid (dream-sessions-signed): the sid
;; itself is a persisted monotonic counter ("s1", "s2", …) — cheap and ordered —
;; and the HMAC signature (dr/sess-hash, keyed by host/session-secret) makes a
;; guessed or forged cookie unusable. http-listen serialises handler calls under a
;; mutex, so the counter increment is race-free.
;;
;; Depends on lib/dream/session.sx (dream-sessions-signed + cookie helpers) and
;; lib/persist/* (the KV backend). Wired into host/make-app via host/sessions.
;; ── store (durable persist KV, injectable; mirrors host/blog-store) ──
(define host/session-store (persist/open))
(define host/session-use-store! (fn (b) (set! host/session-store b)))
;; ── signing secret (override from $SX_SESSION_SECRET in serve.sh) ────
(define host/session-secret "rose-ash-host-dev-secret-change-me")
(define host/session-set-secret! (fn (s) (set! host/session-secret s)))
;; ── keys ────────────────────────────────────────────────────────────
(define host/-sess-key (fn (sid) (str "session:" sid)))
(define host/-sess-epoch-key "session:-epoch")
;; sid generation: a per-BOOT epoch (one durable write at startup) + an in-memory
;; counter. The epoch keeps sids unique across restarts WITHOUT a write per
;; request, so anonymous traffic costs no disk. host/session-init! bumps the epoch
;; on boot (serve.sh); without it (e.g. tests) epoch 0 is fine within one process.
(define host/session-epoch 0)
(define host/session-ctr 0)
(define host/session-init!
(fn ()
(let ((e (+ 1 (or (persist/backend-kv-get host/session-store host/-sess-epoch-key) 0))))
(begin
(persist/backend-kv-put host/session-store host/-sess-epoch-key e)
(set! host/session-epoch e)
(set! host/session-ctr 0)))))
(define host/-sess-next-sid
(fn ()
(begin
(set! host/session-ctr (+ host/session-ctr 1))
(str "s" host/session-epoch "-" host/session-ctr))))
;; ── backend io fn: dispatch session/* ops onto the persist KV ───────
;; LAZY: session/create mints a sid but writes NO row, so an anonymous request
;; (which never sets a field) leaves no durable trace — the store isn't spammed by
;; crawlers. The row appears on the first session/set (i.e. login), so a logged-in
;; session persists and survives a restart; session/exists is "has a written row".
(define host/session-backend
(fn (op)
(let ((kind (get op :op)))
(cond
((= kind "session/create") (host/-sess-next-sid))
((= kind "session/exists")
(persist/backend-kv-has? host/session-store (host/-sess-key (get op :sid))))
((= kind "session/get")
(get
(or (persist/backend-kv-get host/session-store (host/-sess-key (get op :sid))) {})
(get op :key)))
((= kind "session/set")
(let ((sid (get op :sid)))
(persist/backend-kv-put host/session-store (host/-sess-key sid)
(assoc
(or (persist/backend-kv-get host/session-store (host/-sess-key sid)) {})
(get op :key)
(get op :val)))))
((= kind "session/load")
(or (persist/backend-kv-get host/session-store (host/-sess-key (get op :sid))) {}))
((= kind "session/clear")
(persist/backend-kv-delete host/session-store (host/-sess-key (get op :sid))))
(else nil)))))
;; ── middleware for the host pipeline: signed cookie + durable backend ─
(define host/sessions
(fn () (dream-sessions-signed host/session-backend host/session-secret)))
;; ── handler-facing helpers ──────────────────────────────────────────
;; The logged-in principal (or nil), and login/logout writing the session field.
(define host/current-principal (fn (req) (dream-session-field req :principal)))
(define host/login! (fn (req principal) (dream-set-session-field req :principal principal)))
(define host/logout! (fn (req) (dream-invalidate-session req)))

118
lib/host/static.sx Normal file
View File

@@ -0,0 +1,118 @@
;; lib/host/static.sx — serve the client kernel + assets so the blog can boot the
;; SX-htmx hypermedia engine (web/engine.sx) and run as a SPA. The native
;; http-listen host reads files with the `file-read` primitive (no perform), so
;; GET /static/** maps to a file under the static root (default "shared/static",
;; resolved against the server cwd — mount ./shared/static there in the container).
;;
;; Also wires the CONTENT-ADDRESSED module cache the SX client expects: GET
;; /sx/h/{hash} serves a web-stack .sxbc by its content hash (immutable, never
;; stale — a deploy changes the content → changes the hash → a fresh URL), and a
;; <script data-sx-manifest> mapping {file -> hash} makes the client's
;; loadBytecodeFile take the content-addressed branch (localStorage + immutable)
;; instead of the path + max-age=3600 branch.
;; Depends on lib/dream/types.sx (dream-response/-html-status/-param) + router.
(define host/static-root "shared/static")
(define host/static-use-root! (fn (r) (set! host/static-root r)))
;; content-type by file extension; default to octet-stream.
(define host/static--ctype
(fn (path)
(cond
((ends-with? path ".js") "application/javascript; charset=utf-8")
((ends-with? path ".mjs") "application/javascript; charset=utf-8")
((ends-with? path ".css") "text/css; charset=utf-8")
((ends-with? path ".json") "application/json; charset=utf-8")
((ends-with? path ".map") "application/json; charset=utf-8")
((ends-with? path ".svg") "image/svg+xml")
((ends-with? path ".png") "image/png")
((ends-with? path ".woff2") "font/woff2")
((ends-with? path ".wasm") "application/wasm")
(true "application/octet-stream"))))
;; A content-hashed filename (e.g. js_of_ocaml-651f6707.wasm, or anything under
;; /sx/h/) is immutable; everything else gets a modest max-age (mutable bundle).
(define host/static--cache-control
(fn (rel)
(if (ends-with? rel ".wasm")
"public, max-age=31536000, immutable"
"public, max-age=3600")))
;; reject empty, absolute, or traversal paths.
(define host/static--safe?
(fn (rel)
(and (> (len rel) 0)
(not (starts-with? rel "/"))
(not (string-contains? rel "..")))))
;; Serve one asset by its path relative to the static root. file-read THROWS on a
;; missing file, so gate on file-exists? first and return a 404 instead.
(define host/static-serve
(fn (rel)
(if (not (host/static--safe? rel))
(dream-html-status 403 "Forbidden")
(let ((path (str host/static-root "/" rel)))
(if (not (file-exists? path))
(dream-html-status 404 "Not Found")
(dream-response 200
{:content-type (host/static--ctype rel)
:cache-control (host/static--cache-control rel)}
(file-read path)))))))
;; ── content-addressed module cache (/sx/h/{hash}) ───────────────────
;; Each web-stack .sxbc carries its content hash in its head: (sxbc 1 "HASH" ...).
;; Index every .sxbc by that hash at startup so the client can fetch each module
;; immutably + localStorage-cached, and never stale.
(define host/static--sxh->path (dict)) ;; hash -> filepath
(define host/static--file->hash (dict)) ;; "dom.sxbc" -> hash
;; the embedded hash from a .sxbc head: (sxbc 1 "HASH" ... -> "HASH"
(define host/static--sxbc-hash
(fn (head) (nth (split head "\"") 1)))
(define host/static-build-sxh-index!
(fn ()
(for-each
(fn (path)
(let ((h (host/static--sxbc-hash (substr (file-read path) 0 60)))
(base (last (split path "/"))))
(dict-set! host/static--sxh->path h path)
(dict-set! host/static--file->hash base h)))
(file-glob (str host/static-root "/wasm/sx/*.sxbc")))))
;; GET /sx/h/{hash} -> the .sxbc content, immutable (content-addressed).
(define host/static-sxh-serve
(fn (hash)
(let ((path (get host/static--sxh->path hash)))
(if (nil? path)
(dream-html-status 404 "Not Found")
(dream-response 200
{:content-type "text/sx; charset=utf-8"
:cache-control "public, max-age=31536000, immutable"}
(file-read path))))))
;; the data-sx-manifest JSON for the shell: {"modules": {"dom.sxbc": "hash", ...}}.
;; The client's loadBytecodeFile reads manifest.modules[file] -> hash -> /sx/h/.
;; App components the client must eager-load (after the web stack) so their
;; defcomps are registered before a boosted fragment references them. Loaded
;; content-addressed via the modules map below, the same as any web-stack module.
(define host/static--boot-modules (list "relate-picker.sxbc"))
(define host/static-manifest-json
(fn ()
(str "{\"v\":1,\"boot\":["
(join "," (map (fn (m) (str "\"" m "\"")) host/static--boot-modules))
"],\"defs\":{},\"modules\":{"
(join ","
(map (fn (k) (str "\"" k "\":\"" (get host/static--file->hash k) "\""))
(keys host/static--file->hash)))
"}}")))
;; Route group: GET /static/** (path) + GET /sx/h/** (content-addressed). A plain
;; route LIST (like host/feed-routes); host/serve combines + flattens the groups.
(define host/static-routes
(list
(dream-get "/static/**"
(fn (req) (host/static-serve (dream-param req "**"))))
(dream-get "/sx/h/**"
(fn (req) (host/static-sxh-serve (dream-param req "**"))))))

157
lib/host/sx/kg-cards.sx Normal file
View File

@@ -0,0 +1,157 @@
;; KG card components — Ghost/Koenig-compatible card rendering, copied into the host
;; so it can render imported Ghost posts (sx_content holds (~kg_cards/kg-*) from the
;; lexical_to_sx converter). Produces the same HTML structure as lexical_renderer.py.
;;
;; ~rich-text: the host-local dep these cards need (raw HTML injection). Defined here
;; (it was only a test fixture before) so kg-html/kg-bookmark/etc. resolve in the host.
(defcomp ~rich-text (&key (html :as string)) (raw! html))
;; @css kg-card kg-image-card kg-width-wide kg-width-full kg-gallery-card kg-gallery-container kg-gallery-row kg-gallery-image kg-embed-card kg-bookmark-card kg-bookmark-container kg-bookmark-content kg-bookmark-title kg-bookmark-description kg-bookmark-metadata kg-bookmark-icon kg-bookmark-author kg-bookmark-publisher kg-bookmark-thumbnail kg-callout-card kg-callout-emoji kg-callout-text kg-button-card kg-btn kg-btn-accent kg-toggle-card kg-toggle-heading kg-toggle-heading-text kg-toggle-card-icon kg-toggle-content kg-audio-card kg-audio-thumbnail kg-audio-player-container kg-audio-title kg-audio-player kg-audio-play-icon kg-audio-current-time kg-audio-time kg-audio-seek-slider kg-audio-playback-rate kg-audio-unmute-icon kg-audio-volume-slider kg-video-card kg-video-container kg-file-card kg-file-card-container kg-file-card-contents kg-file-card-title kg-file-card-filesize kg-file-card-icon kg-file-card-caption kg-align-center kg-align-left kg-callout-card-grey kg-callout-card-white kg-callout-card-blue kg-callout-card-green kg-callout-card-yellow kg-callout-card-red kg-callout-card-pink kg-callout-card-purple kg-callout-card-accent kg-html-card kg-md-card placeholder
;; ---------------------------------------------------------------------------
;; Image card
;; ---------------------------------------------------------------------------
(defcomp ~kg_cards/kg-image (&key (src :as string) (alt :as string?) (caption :as string?) (width :as string?) (href :as string?))
(figure :class (str "kg-card kg-image-card"
(if (= width "wide") " kg-width-wide"
(if (= width "full") " kg-width-full" "")))
(if href
(a :href href (img :src src :alt (or alt "") :loading "lazy"))
(img :src src :alt (or alt "") :loading "lazy"))
(when caption (figcaption caption))))
;; ---------------------------------------------------------------------------
;; Gallery card
;; ---------------------------------------------------------------------------
(defcomp ~kg_cards/kg-gallery (&key (images :as list) (caption :as string?))
(figure :class "kg-card kg-gallery-card kg-width-wide"
(div :class "kg-gallery-container"
(map (lambda (row)
(div :class "kg-gallery-row"
(map (lambda (img-data)
(figure :class "kg-gallery-image"
(img :src (get img-data "src") :alt (or (get img-data "alt") "") :loading "lazy")
(when (get img-data "caption") (figcaption (get img-data "caption")))))
row)))
images))
(when caption (figcaption caption))))
;; ---------------------------------------------------------------------------
;; HTML card — wraps user-pasted HTML so the editor can identify the block.
;; Content is native sx children (no longer an opaque HTML string).
;; ---------------------------------------------------------------------------
(defcomp ~kg_cards/kg-html (&rest children)
(div :class "kg-card kg-html-card" children))
;; ---------------------------------------------------------------------------
;; Markdown card — rendered markdown content, editor can identify the block.
;; ---------------------------------------------------------------------------
(defcomp ~kg_cards/kg-md (&rest children)
(div :class "kg-card kg-md-card" children))
;; ---------------------------------------------------------------------------
;; Embed card
;; ---------------------------------------------------------------------------
(defcomp ~kg_cards/kg-embed (&key (html :as string) (caption :as string?))
(figure :class "kg-card kg-embed-card"
(~rich-text :html html)
(when caption (figcaption caption))))
;; ---------------------------------------------------------------------------
;; Bookmark card
;; ---------------------------------------------------------------------------
(defcomp ~kg_cards/kg-bookmark (&key (url :as string) (title :as string?) (description :as string?) (icon :as string?) (author :as string?) (publisher :as string?) (thumbnail :as string?) (caption :as string?))
(figure :class "kg-card kg-bookmark-card"
(a :class "kg-bookmark-container" :href url
(div :class "kg-bookmark-content"
(div :class "kg-bookmark-title" (or title ""))
(div :class "kg-bookmark-description" (or description ""))
(when (or icon author publisher)
(span :class "kg-bookmark-metadata"
(when icon (img :class "kg-bookmark-icon" :src icon :alt ""))
(when author (span :class "kg-bookmark-author" author))
(when publisher (span :class "kg-bookmark-publisher" publisher)))))
(when thumbnail
(div :class "kg-bookmark-thumbnail"
(img :src thumbnail :alt ""))))
(when caption (figcaption caption))))
;; ---------------------------------------------------------------------------
;; Callout card
;; ---------------------------------------------------------------------------
(defcomp ~kg_cards/kg-callout (&key (color :as string?) (emoji :as string?) (content :as string?))
(div :class (str "kg-card kg-callout-card kg-callout-card-" (or color "grey"))
(when emoji (div :class "kg-callout-emoji" emoji))
(div :class "kg-callout-text" (or content ""))))
;; ---------------------------------------------------------------------------
;; Button card
;; ---------------------------------------------------------------------------
(defcomp ~kg_cards/kg-button (&key (url :as string) (text :as string?) (alignment :as string?))
(div :class (str "kg-card kg-button-card kg-align-" (or alignment "center"))
(a :href url :class "kg-btn kg-btn-accent" (or text ""))))
;; ---------------------------------------------------------------------------
;; Toggle card (accordion)
;; ---------------------------------------------------------------------------
(defcomp ~kg_cards/kg-toggle (&key (heading :as string?) (content :as string?))
(div :class "kg-card kg-toggle-card" :data-kg-toggle-state "close"
(div :class "kg-toggle-heading"
(h4 :class "kg-toggle-heading-text" (or heading ""))
(button :class "kg-toggle-card-icon"
(~rich-text :html "<svg viewBox=\"0 0 14 14\"><path d=\"M7 0a.5.5 0 0 1 .5.5v6h6a.5.5 0 1 1 0 1h-6v6a.5.5 0 1 1-1 0v-6h-6a.5.5 0 0 1 0-1h6v-6A.5.5 0 0 1 7 0Z\" fill=\"currentColor\"/></svg>")))
(div :class "kg-toggle-content" (or content ""))))
;; ---------------------------------------------------------------------------
;; Audio card
;; ---------------------------------------------------------------------------
(defcomp ~kg_cards/kg-audio (&key (src :as string) (title :as string?) (duration :as string?) (thumbnail :as string?))
(div :class "kg-card kg-audio-card"
(if thumbnail
(img :src thumbnail :alt "audio-thumbnail" :class "kg-audio-thumbnail")
(div :class "kg-audio-thumbnail placeholder"
(~rich-text :html "<svg viewBox=\"0 0 24 24\"><path d=\"M2 12C2 6.48 6.48 2 12 2s10 4.48 10 10-4.48 10-10 10S2 17.52 2 12zm7.5 5.25L16 12 9.5 6.75v10.5z\" fill=\"currentColor\"/></svg>")))
(div :class "kg-audio-player-container"
(div :class "kg-audio-title" (or title ""))
(div :class "kg-audio-player"
(button :class "kg-audio-play-icon"
(~rich-text :html "<svg viewBox=\"0 0 24 24\"><path d=\"M8 5v14l11-7z\" fill=\"currentColor\"/></svg>"))
(div :class "kg-audio-current-time" "0:00")
(div :class "kg-audio-time" (str "/ " (or duration "0:00")))
(input :type "range" :class "kg-audio-seek-slider" :max "100" :value "0")
(button :class "kg-audio-playback-rate" "1×")
(button :class "kg-audio-unmute-icon"
(~rich-text :html "<svg viewBox=\"0 0 24 24\"><path d=\"M3 9v6h4l5 5V4L7 9H3zm13.5 3c0-1.77-1.02-3.29-2.5-4.03v8.05c1.48-.73 2.5-2.25 2.5-4.02zM14 3.23v2.06c2.89.86 5 3.54 5 6.71s-2.11 5.85-5 6.71v2.06c4.01-.91 7-4.49 7-8.77s-2.99-7.86-7-8.77z\" fill=\"currentColor\"/></svg>"))
(input :type "range" :class "kg-audio-volume-slider" :max "100" :value "100")))
(audio :src src :preload "metadata")))
;; ---------------------------------------------------------------------------
;; Video card
;; ---------------------------------------------------------------------------
(defcomp ~kg_cards/kg-video (&key (src :as string) (caption :as string?) (width :as string?) (thumbnail :as string?) (loop :as boolean?))
(figure :class (str "kg-card kg-video-card"
(if (= width "wide") " kg-width-wide"
(if (= width "full") " kg-width-full" "")))
(div :class "kg-video-container"
(video :src src :controls true :preload "metadata"
:poster (or thumbnail nil) :loop (or loop nil)))
(when caption (figcaption caption))))
;; ---------------------------------------------------------------------------
;; File card
;; ---------------------------------------------------------------------------
(defcomp ~kg_cards/kg-file (&key (src :as string) (filename :as string?) (title :as string?) (filesize :as string?) (caption :as string?))
(div :class "kg-card kg-file-card"
(a :class "kg-file-card-container" :href src :download (or filename "")
(div :class "kg-file-card-contents"
(div :class "kg-file-card-title" (or title filename ""))
(when filesize (div :class "kg-file-card-filesize" filesize)))
(div :class "kg-file-card-icon"
(~rich-text :html "<svg viewBox=\"0 0 24 24\"><path d=\"M19 9h-4V3H9v6H5l7 7 7-7zM5 18v2h14v-2H5z\" fill=\"currentColor\"/></svg>")))
(when caption (div :class "kg-file-card-caption" caption))))
;; ---------------------------------------------------------------------------
;; Paywall marker
;; ---------------------------------------------------------------------------
(defcomp ~kg_cards/kg-paywall ()
(~rich-text :html "<!--members-only-->"))

39
lib/host/sx/relate-picker.sx Normal file
View File

@@ -0,0 +1,39 @@
;; lib/host/sx/relate-picker.sx — the relate picker as a reusable, content-addressed
;; SX component. On a FULL load render-page expands it server-side (SEO / no-JS); on a
;; boosted SPA nav the edit body is serialized as `(~relate-picker :slug … :kind …)`
;; and the CLIENT expands it — the component module is loaded content-addressed via
;; the data-sx-manifest at boot, so its defcomp is registered before any fragment
;; referencing it arrives.
;;
;; Pure markup, no client JS: the form GETs /<slug>/relate-options serialising kind +
;; the filter q (a FORM is serialised on GET, a bare input is not), innerHTML-swapping
;; the results <ul> on "load" and on a debounced "input". Paging is server-driven —
;; each full page carries a "load more" sentinel (sx-trigger revealed) the endpoint
;; emits. sx-retry makes a dropped/offline fetch self-heal; the engine's .sx-error
;; class (styled by the host shell) surfaces a stuck retry. The engine re-binds these
;; triggers on swapped-in content, so it works on full load AND boosted nav.
(defcomp
~relate-picker
(&key slug kind)
(form
:class "relate-picker"
:data-slug slug
:data-kind kind
:sx-get (str "/" slug "/relate-options")
:sx-trigger "input delay:200ms, load"
:sx-target (str "#rp-" kind "-results")
:sx-swap "innerHTML"
:sx-retry "exponential:1000:30000"
:style "margin:0"
(input :type "hidden" :name "kind" :value kind)
(input
:type "text"
:name "q"
:class "rp-filter"
:placeholder "filter…"
:autocomplete "off"
:style "width:100%;padding:0.4em;box-sizing:border-box")
(ul
:id (str "rp-" kind "-results")
:class "rp-results"
:style "list-style:none;padding:0;margin:0.5em 0;border:1px solid #ddd")))

224
lib/host/sxtp.sx Normal file
View File

@@ -0,0 +1,224 @@
;; 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"/"patch"/"signals"), with string keys so the
;; keyword==string rule makes construction and access trivial. verb/status/type/
;; mode 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)))
;; Patch (Datastar-borrowed) — DOM fragment morph.
;; target: CSS selector (required). mode in opts defaults to outer; accepts
;; string OR symbol and is normalised. mode values: outer | inner | replace |
;; prepend | append | before | after | remove. body: SX subtree (omit for remove).
(define sxtp/patch
(fn (target opts)
(let ((mode (or (get opts :mode) "outer")))
(merge opts {:msg "patch" :target target :mode (sxtp/-sym mode)}))))
;; Signals (Datastar-borrowed) — reactive state patch.
;; values: dict of signal-name -> new-value (nil removes). only-if-missing: bool.
(define sxtp/signals
(fn (values opts)
(merge {:msg "signals" :values values} 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")))
(define sxtp/patch? (fn (m) (sxtp/-is? m "patch")))
(define sxtp/signals? (fn (m) (sxtp/-is? m "signals")))
;; ── 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)))
(define sxtp/target (fn (m) (get m :target)))
(define sxtp/mode (fn (m) (get m :mode)))
(define sxtp/values (fn (m) (get m :values)))
(define sxtp/only-if-missing? (fn (m) (= (get m :only-if-missing) true)))
(define sxtp/transition? (fn (m) (= (get m :transition) true)))
;; ── 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)
:patch (list :target :mode :body :transition)
:signals (list :values :only-if-missing)})
;; 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))}))))
;; ── host write-body: a request's text/sx body -> string-keyed dict ──
;; The write-side counterpart to host/sx-status: the SX engine posts text/sx for
;; writes (boosted forms serialise their fields), so write handlers read the body
;; through this instead of dream-json-body. parse-safe yields keyword-token keys;
;; sxtp/-normalize deep-converts them to strings so (get p :field) works — the same
;; shape dream-json-body produced from JSON. Empty / blank / non-dict / unparseable
;; body -> nil (handlers then return 400).
(define host/sx-body
(fn (req)
(let ((raw (dream-body req)))
(if (or (nil? raw) (= raw ""))
nil
(let ((v (parse-safe raw)))
(if (= (type-of v) "dict") (sxtp/-normalize v) nil))))))
;; ── unified write-field reader: text/sx body OR urlencoded form ─────
;; A boosted form posts text/sx (the SX engine serialises its fields); a no-engine
;; / pre-hydration submit (and the login bootstrap) posts urlencoded. Content-type
;; decides. host/fields returns ALL fields as one string-keyed dict; host/field
;; reads one by name. Form handlers read through these so both encodings work.
(define host/fields
(fn (req)
(if (contains? (or (dream-content-type-of req) "") "text/sx")
(or (host/sx-body req) {})
(or (dream-form-fields req) {}))))
(define host/field (fn (req name) (get (host/fields req) name)))

1167
lib/host/tests/blog.sx Normal file
View File

File diff suppressed because it is too large Load Diff

93
lib/host/tests/compose.sx Normal file
View File

@@ -0,0 +1,93 @@
;; lib/host/tests/compose.sx — the composition CORE + render-fold (lib/host/compose.sx).
;; Tests host/comp-fold's shared dispatch (seq/alt/each + when + each-source + recursion +
;; depth guard) through the RENDER domain (render → HTML). The execute domain is tested in
;; tests/execute.sx; together they show one core, two folds (plans/composition-objects.md).
(define host-cp-pass 0)
(define host-cp-fail 0)
(define host-cp-fails (list))
(define host-cp-test
(fn (name actual expected)
(if (= actual expected)
(set! host-cp-pass (+ host-cp-pass 1))
(begin
(set! host-cp-fail (+ host-cp-fail 1))
(append! host-cp-fails {:name name :actual actual :expected expected})))))
;; -- leaves --
(host-cp-test "text leaf passes markup through"
(host/comp-render (quote (text "<p>hi</p>")) {}) "<p>hi</p>")
(host-cp-test "field wraps the value in a span; reads the context"
(host/comp-render (quote (field :title)) {"title" "Hello"}) "<span>Hello</span>")
(host-cp-test "val is the raw value (no markup) — for attributes"
(host/comp-render (quote (val :slug)) {"slug" "p1"}) "p1")
(host-cp-test "a missing field renders empty, not an error"
(host/comp-render (quote (field :nope)) {}) "<span></span>")
;; -- seq: render all in order --
(host-cp-test "seq renders children in order"
(host/comp-render (quote (seq (text "a") (text "b") (text "c"))) {}) "abc")
;; -- row/grid: layout combinators wrap + recurse via the core --
(host-cp-test "row wraps its children in a flex div"
(host/comp-render (quote (row (text "A") (text "B"))) {})
"<div class=\"row\" style=\"display:flex;gap:1em\">AB</div>")
;; -- alt + when: render the first branch whose predicate holds --
(host-cp-test "alt renders the when-branch when the predicate holds"
(host/comp-render (quote (alt (when (has "auth") (text "in")) (else (text "out")))) {"auth" "y"}) "in")
(host-cp-test "alt falls through to else"
(host/comp-render (quote (alt (when (has "auth") (text "in")) (else (text "out")))) {}) "out")
(host-cp-test "alt eq predicate matches a context value"
(host/comp-render (quote (alt (when (eq "t" "dark") (text "D")) (else (text "L")))) {"t" "dark"}) "D")
(host-cp-test "alt not predicate negates"
(host/comp-render (quote (alt (when (not (has "auth")) (text "anon")) (else (text "user")))) {}) "anon")
;; -- each: iterate a source, binding :item, with field resolution --
(host-cp-test "each renders the template per item (items source)"
(host/comp-render (quote (each (items {:n "x"} {:n "y"}) (seq (text "<li>") (field :n) (text "</li>")))) {})
"<li><span>x</span></li><li><span>y</span></li>")
(host-cp-test "each over an empty source renders empty"
(host/comp-render (quote (each (items) (field :n))) {}) "")
(host-cp-test "each query source delegates to the context resolver"
(host/comp-render (quote (each (query is-a t) (field :title)))
{"query" (fn (qargs ctx) (list {:title "One"} {:title "Two"}))})
"<span>One</span><span>Two</span>")
;; -- recursion via named templates + a depth guard --
(host/comp--def-tmpl! "node"
(quote (seq (field :name) (each (children) (tmpl "node")))))
(host-cp-test "tmpl recurses over a (children) tree until the source runs dry"
(host/comp-render (quote (tmpl "node"))
{"item" {:name "root" :children (list {:name "a" :children (list)} {:name "b" :children (list)})}})
"<span>root</span><span>a</span><span>b</span>")
;; -- ref: transclude via the context resolver --
(host-cp-test "ref transcludes via the context resolver"
(host/comp-render (quote (ref "c1")) {"ref" (fn (id ctx) (str "<card:" id ">"))}) "<card:c1>")
(host-cp-test "ref with no resolver renders empty"
(host/comp-render (quote (ref "c1")) {}) "")
;; -- the unifying property: ONE object renders differently per context --
(host-cp-test "the SAME object renders two ways by context (anon vs authed)"
(let ((obj (quote (alt (when (has "auth") (text "member")) (else (text "guest"))))))
(list (host/comp-render obj {}) (host/comp-render obj {"auth" "y"})))
(list "guest" "member"))
;; -- a THIRD domain over the SAME core: deps (collect transcluded refs). Proves step 8 —
;; a new domain is just a dict + leaf, reusing seq/alt/each with no new control flow. --
(host-cp-test "deps collects the refs a seq body transcludes (the contains DAG)"
(host/comp-deps (quote (seq (ref "c0") (text "x") (ref "c1"))) {})
(list "c0" "c1"))
(host-cp-test "deps walks each — refs inside an iterated template are collected per item"
(host/comp-deps (quote (each (items {} {}) (ref "card"))) {})
(list "card" "card"))
(host-cp-test "deps follows alt's taken branch (context-specific transclusions)"
(list (host/comp-deps (quote (alt (when (has "auth") (ref "member")) (else (ref "guest")))) {"auth" "y"})
(host/comp-deps (quote (alt (when (has "auth") (ref "member")) (else (ref "guest")))) {}))
(list (list "member") (list "guest")))
(define host-cp-tests-run!
(fn ()
{:total (+ host-cp-pass host-cp-fail)
:passed host-cp-pass :failed host-cp-fail :fails host-cp-fails}))

87
lib/host/tests/execute.sx Normal file
View File

@@ -0,0 +1,87 @@
;; lib/host/tests/execute.sx — the EXECUTE-fold (lib/host/execute.sx): a second interpreter
;; over the SAME seq/alt/each composition algebra as the render-fold, proving the algebra is
;; domain-agnostic (plans/composition-objects.md step 7). Leaves are effects; the fold
;; returns an effect log. Reuses compose.sx's when-predicates / field resolver / each source.
(define host-ex-pass 0)
(define host-ex-fail 0)
(define host-ex-fails (list))
(define host-ex-test
(fn (name actual expected)
(if (= actual expected)
(set! host-ex-pass (+ host-ex-pass 1))
(begin
(set! host-ex-fail (+ host-ex-fail 1))
(append! host-ex-fails {:name name :actual actual :expected expected})))))
;; the verbs of an effect log, in order (effect records are {:verb :args}).
(define ex-verbs (fn (effects) (map (fn (e) (get e :verb)) effects)))
(define ex-args (fn (effects) (map (fn (e) (get e :args)) effects)))
;; -- seq: steps in order --
(host-ex-test "seq runs effects in order"
(ex-verbs (host/exec-run (quote (seq (effect a) (effect b) (effect c))) {}))
(list "a" "b" "c"))
(host-ex-test "nested seq flattens in order"
(ex-verbs (host/exec-run (quote (seq (effect a) (seq (effect b) (effect c)) (effect d))) {}))
(list "a" "b" "c" "d"))
;; -- alt + when: branch (reusing the render-fold's predicate set) --
(host-ex-test "alt runs the first branch whose when holds"
(ex-verbs (host/exec-run (quote (alt (when (has "auth") (effect publish)) (else (effect hold)))) {"auth" "y"}))
(list "publish"))
(host-ex-test "alt falls through to else when no when holds"
(ex-verbs (host/exec-run (quote (alt (when (has "auth") (effect publish)) (else (effect hold)))) {}))
(list "hold"))
(host-ex-test "alt eq predicate branches on a context value"
(ex-verbs (host/exec-run (quote (alt (when (eq "role" "admin") (effect grant)) (else (effect deny)))) {"role" "admin"}))
(list "grant"))
;; -- each: for-each over the (reused) source, with field resolution from the item --
(host-ex-test "each runs the body per item (for-each)"
(ex-verbs (host/exec-run (quote (each (items {:email "a"} {:email "b"}) (effect notify))) {}))
(list "notify" "notify"))
(host-ex-test "effect args resolve (field K) from the current item"
(ex-args (host/exec-run (quote (each (items {:email "a@x"} {:email "b@x"}) (effect notify (field :email)))) {}))
(list (list "a@x") (list "b@x")))
(host-ex-test "effect args resolve (field K) from the context, and literals pass through"
(ex-args (host/exec-run (quote (seq (effect log (field :who) "done"))) {"who" "alice"}))
(list (list "alice" "done")))
;; -- robustness: non-effect leaves / unknown heads produce no effects --
(host-ex-test "a non-list node yields no effects"
(host/exec-run "bare" {}) (list))
(host-ex-test "an unknown combinator head yields no effects"
(host/exec-run (quote (frobnicate 1 2)) {}) (list))
;; -- the KEYSTONE: ONE control skeleton, folded TWO ways. Same alt+when, same context, the
;; SAME branch is chosen (both use host/comp--pred?); render emits HTML, execute emits an
;; effect. The composition algebra is domain-agnostic — render and behaviour are two folds. --
(host-ex-test "same skeleton folds two ways — render picks the branch, execute picks the SAME branch (authed)"
(let ((ctx {"auth" "y"}))
(list (host/comp-render (quote (alt (when (has "auth") (text "<b>in</b>")) (else (text "out")))) ctx)
(ex-verbs (host/exec-run (quote (alt (when (has "auth") (effect enter)) (else (effect leave)))) ctx))))
(list "<b>in</b>" (list "enter")))
(host-ex-test "same skeleton folds two ways — the else branch agrees across folds (anon)"
(let ((ctx {}))
(list (host/comp-render (quote (alt (when (has "auth") (text "<b>in</b>")) (else (text "out")))) ctx)
(ex-verbs (host/exec-run (quote (alt (when (has "auth") (effect enter)) (else (effect leave)))) ctx))))
(list "out" (list "leave")))
;; -- a small workflow: validate -> (branch on status) -> notify each recipient. Proves the
;; behaviour model is just an execute-fold over a composition object. --
(host-ex-test "a publish workflow runs as one execute-fold over the composition"
(ex-verbs
(host/exec-run
(quote (seq
(effect validate (field :slug))
(alt (when (eq "status" "ready") (effect publish (field :slug)))
(else (effect hold (field :slug))))
(each (items {:to "a"} {:to "b"}) (effect notify (field :to)))))
{"slug" "post-1" "status" "ready"}))
(list "validate" "publish" "notify" "notify"))
(define host-ex-tests-run!
(fn ()
{:total (+ host-ex-pass host-ex-fail)
:passed host-ex-pass :failed host-ex-fail :fails host-ex-fails}))

132
lib/host/tests/feed.sx Normal file
View File

@@ -0,0 +1,132 @@
;; 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")))
(serialize {:ok true :data (feed/items (feed/recent (feed/all)))}))
(host-fd-test
"golden actor-filtered"
(dream-resp-body (host-fd-app (host-fd-req "/feed?actor=alice")))
(serialize {:ok true :data (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
View 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 sx"
(dream-resp-header (host/ok "x") "content-type")
"text/sx; charset=utf-8")
(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 sx"
(dream-resp-header (host/error 500 "boom") "content-type")
"text/sx; charset=utf-8")
;; ── host/sx-status ─────────────────────────────────────────────────
(host-hd-test
"sx-status arbitrary status"
(dream-status (host/sx-status 418 {:a 1}))
418)
(host-hd-test
"sx-status serializes body"
(contains? (dream-resp-body (host/sx-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}))

63
lib/host/tests/htmlsx.sx Normal file
View File

@@ -0,0 +1,63 @@
;; lib/host/tests/htmlsx.sx — the pure-SX HTML → SX converter (host/html->sx). Covers text,
;; entities, void/nested tags, attributes, figure/iframe, and an end-to-end import round-trip.
(define host-ht-pass 0)
(define host-ht-fail 0)
(define host-ht-fails (list))
(define host-ht-test
(fn (name actual expected)
(if (= actual expected)
(set! host-ht-pass (+ host-ht-pass 1))
(begin
(set! host-ht-fail (+ host-ht-fail 1))
(append! host-ht-fails {:name name :actual actual :expected expected})))))
;; a paragraph with inline formatting — kept nested (decompose flattens to text later).
(host-ht-test "a <p> with inline <strong> parses to (p \"…\" (strong \"…\") \"…\")"
(str (host/html->sx "<p>Hello <strong>world</strong> now</p>"))
"(article (p \"Hello \" (strong \"world\") \" now\"))")
;; HTML entities decode to UTF-8 (not \\uXXXX).
(host-ht-test "entities decode (&amp; &pound; &#x2019;)"
(str (host/html->sx "<p>Tom &amp; Jerry cost &pound;5 &#x2019;n up</p>"))
"(article (p \"Tom & Jerry cost £5 ’n up\"))")
;; a void <img> keeps its attributes as keyword attrs.
(host-ht-test "a void <img> keeps :src/:alt attrs"
(str (host/html->sx "<img src=\"a.jpg\" alt=\"a photo\">"))
"(article (img :alt \"a photo\" :src \"a.jpg\"))")
;; a <figure> with an <img> + <figcaption> nests correctly.
(host-ht-test "a <figure> nests an <img> and a <figcaption>"
(str (host/html->sx "<figure><img src=\"y.jpg\" alt=\"y\"><figcaption>a caption</figcaption></figure>"))
"(article (figure (img :alt \"y\" :src \"y.jpg\") (figcaption \"a caption\")))")
;; an <iframe> is a void-ish embed (self-contained token).
(host-ht-test "an <iframe> becomes a leaf with its :src"
(str (host/html->sx "<iframe src=\"https://youtube.com/embed/x\"></iframe>"))
"(article (iframe :src \"https://youtube.com/embed/x\"))")
;; comments + doctype are skipped; whitespace-only text is dropped.
(host-ht-test "comments/doctype are skipped, blank text dropped"
(str (host/html->sx "<!-- hi --> <p>x</p>\n <p>y</p>"))
"(article (p \"x\") (p \"y\"))")
;; headings map through (decompose then turns h2 into card-heading).
(host-ht-test "headings + paragraphs come through in order"
(str (host/html->sx "<h2>Title</h2><p>body</p>"))
"(article (h2 \"Title\") (p \"body\"))")
;; ── END TO END: HTML → SX → decompose → typed card objects ──────────
(host/blog-use-store! (persist/open))
(host/blog-seed-types!)
(host-ht-test "html->sx feeds decompose: a real snippet becomes typed cards"
(begin
(host/blog-put! "htdoc" "HT" "(p)" "published")
(host/blog--decompose! "htdoc"
(host/html->sx "<h2>Heading</h2><p>Some <strong>bold</strong> text.</p><figure><img src=\"p.jpg\" alt=\"a\"><figcaption>cap</figcaption></figure><iframe src=\"https://youtube.com/embed/z\"></iframe>"))
(list (host/blog-is-a? "htdoc__body__b0" "card-heading")
(host/blog-is-a? "htdoc__body__b1" "card-text")
(get (host/blog-field-values-of "htdoc__body__b1") "text") ;; strong flattened to text
(host/blog-is-a? "htdoc__body__b2" "card-image")
(get (host/blog-field-values-of "htdoc__body__b2") "caption")
(host/blog-is-a? "htdoc__body__b3" "card-embed")))
(list true true "Some bold text." true "cap" true))
(define host-ht-tests-run!
(fn ()
{:total (+ host-ht-pass host-ht-fail)
:passed host-ht-pass :failed host-ht-fail :fails host-ht-fails}))

106
lib/host/tests/ledger.sx Normal file
View 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
View 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
View 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}))

172
lib/host/tests/relations.sx Normal file
View File

@@ -0,0 +1,172 @@
;; 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)))
(serialize {:ok true :data (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)))
(serialize {:ok true :data (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
View 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
View 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}))

146
lib/host/tests/session.sx Normal file
View File

@@ -0,0 +1,146 @@
;; lib/host/tests/session.sx — the live-write story end-to-end: a browser logs in
;; (POST /login) → signed session cookie → guarded write succeeds; no cookie → 401;
;; the Bearer path still works for API clients; logout drops the principal.
;; make-app auto-mounts /login + /logout and wraps everything in host/sessions, so
;; these tests drive the WHOLE app handler (session middleware + router) the way
;; the native server does.
(define host-se-pass 0)
(define host-se-fail 0)
(define host-se-fails (list))
(define host-se-test
(fn (name actual expected)
(if (= actual expected)
(set! host-se-pass (+ host-se-pass 1))
(begin
(set! host-se-fail (+ host-se-fail 1))
(append! host-se-fails {:name name :actual actual :expected expected})))))
;; ── fixtures ────────────────────────────────────────────────────────
(acl/load! (list (acl-grant "admin" "edit" "blog")))
(host/auth-set-admin! "admin" "secret")
(host/session-set-secret! "test-session-secret")
;; bearer fallback for API clients (session is the browser path)
(define host-se-resolve (fn (tok) (if (= tok "apitoken") "admin" nil)))
;; a guarded write route isolating the session mechanism from blog specifics:
;; same pipeline shape as host/blog--protect (wrap-errors + require-user + ACL).
(define host-se-secure-h
(host/pipeline
(list
host/wrap-errors
(host/require-user host-se-resolve)
(host/require-permission "edit" (fn (req) "blog")))
(fn (req) (host/ok-status 201 (host/principal req)))))
(define host-se-app
(host/make-app (list (list (dream-post "/secure" host-se-secure-h)))))
;; ── helpers ─────────────────────────────────────────────────────────
(define host-se-login
(fn (user pass)
(host-se-app
(dream-request "POST" "/login" {}
(str "username=" user "&password=" pass)))))
;; the name=value pair from the Set-Cookie (drop the "; Path=…" attributes)
(define host-se-cookie-of
(fn (resp)
(let ((c (first (dream-resp-cookies resp))))
(if (nil? c) nil (substr c 0 (index-of c ";"))))))
(define host-se-secure
(fn (cookie)
(host-se-app
(dream-request "POST" "/secure" (if cookie {:cookie cookie} {}) ""))))
(define host-se-secure-bearer
(fn (tok)
(host-se-app
(dream-request "POST" "/secure" {:authorization (str "Bearer " tok)} ""))))
;; ── login ───────────────────────────────────────────────────────────
(host-se-test "login good creds -> 303 redirect"
(dream-status (host-se-login "admin" "secret")) 303)
(host-se-test "login good creds sets a session cookie"
(not (nil? (host-se-cookie-of (host-se-login "admin" "secret")))) true)
(host-se-test "login bad creds -> 401"
(dream-status (host-se-login "admin" "wrong")) 401)
;; ── return-to (?next=) after login ──────────────────────────────────
(host-se-test "login page carries ?next in a hidden field"
(contains?
(dream-resp-body (host-se-app (dream-request "GET" "/login?next=/secure" {} "")))
"value=\"/secure\"")
true)
(host-se-test "login redirects to next on success"
(dream-resp-header
(host-se-app (dream-request "POST" "/login" {} "username=admin&password=secret&next=/secure"))
"location")
"/secure")
(host-se-test "login rejects open-redirect next (//evil) -> /"
(dream-resp-header
(host-se-app (dream-request "POST" "/login" {} "username=admin&password=secret&next=//evil.com"))
"location")
"/")
;; ── session-authed write ────────────────────────────────────────────
(host-se-test "logged-in session passes the guarded write -> 201"
(dream-status (host-se-secure (host-se-cookie-of (host-se-login "admin" "secret"))))
201)
(host-se-test "principal threaded from the session to the handler"
(contains?
(dream-resp-body (host-se-secure (host-se-cookie-of (host-se-login "admin" "secret"))))
":data \"admin\"")
true)
;; ── unauthenticated / forged ────────────────────────────────────────
(host-se-test "no cookie -> 401"
(dream-status (host-se-secure nil)) 401)
(host-se-test "bad-cred login leaves an anonymous session (no principal) -> 401"
(dream-status (host-se-secure (host-se-cookie-of (host-se-login "admin" "wrong"))))
401)
(host-se-test "forged cookie -> 401"
(dream-status (host-se-secure "dream.session=s1|forged")) 401)
;; ── bearer fallback (API path still works) ──────────────────────────
(host-se-test "valid bearer token -> 201"
(dream-status (host-se-secure-bearer "apitoken")) 201)
(host-se-test "invalid bearer token -> 401"
(dream-status (host-se-secure-bearer "nope")) 401)
;; ── logout ──────────────────────────────────────────────────────────
;; log in, get the cookie, log out with it, then the same cookie no longer authes.
(define host-se-logout
(fn (cookie)
(host-se-app
(dream-request "POST" "/logout" (if cookie {:cookie cookie} {}) ""))))
(define host-se-live-cookie (host-se-cookie-of (host-se-login "admin" "secret")))
(host-se-test "logout returns 303"
(dream-status (host-se-logout host-se-live-cookie)) 303)
(host-se-test "after logout the cookie no longer authes -> 401"
(begin
(host-se-logout host-se-live-cookie)
(dream-status (host-se-secure host-se-live-cookie)))
401)
;; ── lazy persistence: only a written (logged-in) session leaves a durable row ──
(host-se-test "session/create writes no row (anonymous leaves no durable trace)"
(host/session-backend {:op "session/exists" :sid (host/session-backend {:op "session/create"})})
false)
(host-se-test "session/set creates the row (a login persists)"
(let ((sid (host/session-backend {:op "session/create"})))
(begin
(host/session-backend {:op "session/set" :sid sid :key :principal :val "bob"})
(list (host/session-backend {:op "session/exists" :sid sid})
(host/session-backend {:op "session/get" :sid sid :key :principal}))))
(list true "bob"))
(define host-se-tests-run!
(fn ()
{:total (+ host-se-pass host-se-fail)
:passed host-se-pass
:failed host-se-fail
:fails host-se-fails}))

218
lib/host/tests/sxtp.sx Normal file
View File

@@ -0,0 +1,218 @@
;; 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)
(host-sx-test "patch?" (sxtp/patch? (sxtp/patch "#x" {})) true)
(host-sx-test "patch not event" (sxtp/event? (sxtp/patch "#x" {})) false)
(host-sx-test "signals?" (sxtp/signals? (sxtp/signals {:n 3} {})) true)
(host-sx-test "signals not patch" (sxtp/patch? (sxtp/signals {:n 3} {})) false)
;; ── 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)
;; ── patch + signals (Datastar-borrowed) ───────────────────────────
;; Mode defaults to outer; accepts string OR symbol input.
(host-sx-test
"patch default mode is outer symbol"
(symbol->string (sxtp/mode (sxtp/patch "#x" {})))
"outer")
(host-sx-test
"patch accepts symbol mode"
(symbol->string (sxtp/mode (sxtp/patch "#x" {:mode (string->symbol "inner")})))
"inner")
(host-sx-test
"patch accepts string mode and normalises"
(symbol->string (sxtp/mode (sxtp/patch "#x" {:mode "append"})))
"append")
(host-sx-test
"patch target accessor"
(sxtp/target (sxtp/patch "#cart" {}))
"#cart")
(host-sx-test
"patch serialises with target/mode/body in fixed order"
(sxtp/serialize (sxtp/patch "#x" {:body "hi"}))
"(patch :target \"#x\" :mode outer :body \"hi\")")
(host-sx-test
"patch remove mode serialises without :body"
(sxtp/serialize (sxtp/patch "#x" {:mode "remove"}))
"(patch :target \"#x\" :mode remove)")
(host-sx-test
"patch transition? predicate"
(sxtp/transition? (sxtp/patch "#x" {:transition true}))
true)
(host-sx-test
"signals accessor"
(get (sxtp/values (sxtp/signals {:cart/count 3} {})) :cart/count)
3)
(host-sx-test
"signals only-if-missing default false"
(sxtp/only-if-missing? (sxtp/signals {:n 1} {}))
false)
(host-sx-test
"signals only-if-missing true round-trips"
(sxtp/only-if-missing? (sxtp/signals {:n 1} {:only-if-missing true}))
true)
(host-sx-test
"signals serialise"
(sxtp/serialize (sxtp/signals {:cart/count 3} {}))
"(signals :values {:cart/count 3})")
;; ── round-trip ────────────────────────────────────────────────────
(define host-sx-patch-rt
(sxtp/parse (sxtp/serialize (sxtp/patch "#mini" {:mode "inner" :body "n=3"}))))
(host-sx-test "patch rt msg" (sxtp/patch? host-sx-patch-rt) true)
(host-sx-test "patch rt target" (sxtp/target host-sx-patch-rt) "#mini")
(host-sx-test "patch rt mode" (symbol->string (sxtp/mode host-sx-patch-rt)) "inner")
(define host-sx-signals-rt
(sxtp/parse (sxtp/serialize (sxtp/signals {:a 1 :b "x"} {:only-if-missing true}))))
(host-sx-test "signals rt msg" (sxtp/signals? host-sx-signals-rt) true)
(host-sx-test "signals rt values"
(get (sxtp/values host-sx-signals-rt) :a) 1)
(host-sx-test "signals rt only-if-missing"
(sxtp/only-if-missing? host-sx-signals-rt) true)
;; ── 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)
;; ── engine<->server write wire: serialize (engine) <-> host/sx-body (server) ──
;; A boosted form posts (serialize {field->value}) as text/sx; the server reads it
;; back with host/sx-body. This is the SX write wire, verified with NO DOM (client-
;; agnostic): what the engine's serialize emits, host/sx-body must parse back
;; losslessly — including sx_content full of the quotes/parens that would break a
;; naive encoder. (The server side is what conformance can prove; the DOM field-read
;; is the one irreducibly-browser bit, left to a Playwright smoke.)
(define host-sx-wire-content "(article (h1 \"Title\") (p \"He said \\\"hi\\\" (x)\"))")
(define host-sx-wire-req
(dream-request "POST" "/x" {:content-type "text/sx"}
(serialize {:title "Hi there" :sx_content host-sx-wire-content :status "published"})))
(host-sx-test "sx-body round-trips a serialized field dict"
(get (host/sx-body host-sx-wire-req) "title") "Hi there")
(host-sx-test "sx-body preserves quoted/parenthesised sx_content losslessly"
(get (host/sx-body host-sx-wire-req) "sx_content") host-sx-wire-content)
(host-sx-test "field reads a text/sx body by content-type"
(host/field host-sx-wire-req "status") "published")
(host-sx-test "field falls back to urlencoded form (the no-engine path)"
(host/field (dream-request "POST" "/x"
{:content-type "application/x-www-form-urlencoded"}
"title=From+Form&status=draft") "title")
"From Form")
(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}))

149
lib/host/warm-conf.sh Executable file
View File

@@ -0,0 +1,149 @@
#!/usr/bin/env bash
# warm-conf.sh — a WARM, persistent conformance server for fast iteration.
#
# conformance.sh cold-loads all ~57 modules (datalog/acl/relations/persist/dream + host)
# on EVERY run — a fixed multi-minute tax, worst under box contention. This keeps a
# long-lived sx_server with the heavy dependency modules loaded ONCE, and per run reloads
# only the lib/host/* modules + the suite's test file (the things you actually edit),
# then evals the runner. Cross-run state is safe: each test file re-opens a fresh persist
# store at its top, and (since host/blog typing now reads direct KV edges, not lib/relations)
# the warm Datalog DB no longer feeds blog results, so stale facts can't pollute a re-run.
#
# Usage:
# lib/host/warm-conf.sh start # boot server, load the heavy dep modules once
# lib/host/warm-conf.sh run blog # reload host modules + tests/blog.sx, run the suite
# lib/host/warm-conf.sh run # run every suite
# lib/host/warm-conf.sh stop # kill the warm server
# lib/host/warm-conf.sh restart # stop + start
#
# It reads the MODULES + SUITES arrays straight from conformance.sh (no duplication, no
# drift). Heavy deps are everything NOT under lib/host/; those host modules + the test
# files are what `run` reloads.
set -u
HERE="$(cd "$(dirname "${BASH_SOURCE[0]}")/../.." && pwd)"
cd "$HERE" || exit 1
CONF="lib/host/conformance.sh"
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
[ -x "$SX_SERVER" ] || SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
if [ ! -x "$SX_SERVER" ]; then echo "ERROR: sx_server.exe not found" >&2; exit 1; fi
D="${WARM_CONF_DIR:-/tmp/warm-conf-host}"
FIFO="$D/in"; LOG="$D/out"; SPID="$D/server.pid"; HPID="$D/holder.pid"; EPF="$D/epoch"
# All module load paths from conformance.sh's MODULES=( ... ) array (in order).
mapfile -t ALL_MODULES < <(awk '/^MODULES=\(/{f=1;next} f&&/^\)/{f=0} f' "$CONF" | grep -oE '"[^"]+\.sx"' | tr -d '"')
# Heavy deps = everything that is NOT a lib/host module (loaded once, kept warm).
DEPS=(); HOSTMODS=()
for m in "${ALL_MODULES[@]}"; do
case "$m" in lib/host/*) HOSTMODS+=("$m") ;; *) DEPS+=("$m") ;; esac
done
# Suites: "NAME RUNNER FILE" lines from conformance.sh's SUITES=( ... ) array.
mapfile -t SUITES < <(awk '/^SUITES=\(/{f=1;next} f&&/^\)/{f=0} f' "$CONF" | grep -oE '"[^"]+"' | tr -d '"')
_running() { [ -f "$SPID" ] && kill -0 "$(cat "$SPID")" 2>/dev/null; }
_send() { printf '%s\n' "$1" > "$FIFO"; }
# wait until a line matching $1 appears in the log AFTER byte-offset $2, or $3 seconds pass.
_wait_for() {
local pat="$1" from="$2" timeout="${3:-1200}" waited=0
while true; do
if tail -c +"$((from+1))" "$LOG" | grep -qE "$pat"; then return 0; fi
if tail -c +"$((from+1))" "$LOG" | grep -qE 'Undefined symbol|Unhandled exception|: error |expected list, got'; then
echo " ! error in server output:" >&2
tail -c +"$((from+1))" "$LOG" | grep -nE 'Undefined symbol|Unhandled exception|: error |expected list, got' | head -5 >&2
return 2
fi
sleep 1; waited=$((waited+1))
[ "$waited" -ge "$timeout" ] && { echo " ! timeout after ${timeout}s waiting for /$pat/" >&2; return 1; }
done
}
_emit_loads() { # $@ = module paths; uses + bumps the epoch counter in $EPF
local e; e="$(cat "$EPF")"
{ for m in "$@"; do e=$((e+1)); printf '(epoch %d)\n(load "%s")\n' "$e" "$m"; done; } > "$FIFO"
echo "$e" > "$EPF"; echo "$e" # echo the last epoch used
}
cmd_start() {
cmd_stop >/dev/null 2>&1
mkdir -p "$D"; : > "$LOG"; echo 0 > "$EPF"
rm -f "$FIFO"; mkfifo "$FIFO"
"$SX_SERVER" < "$FIFO" > "$LOG" 2>&1 &
echo $! > "$SPID"
sleep infinity > "$FIFO" & # holder: keeps the write end open so the server never EOFs
echo $! > "$HPID"
echo "warm: loading ${#DEPS[@]} dependency modules (once)..."
local last; last="$(_emit_loads "${DEPS[@]}")"
if _wait_for "^\(ok $last " 0 900; then
echo "warm: ready — ${#DEPS[@]} deps loaded, server pid $(cat "$SPID")"
else
echo "warm: FAILED to load deps" >&2; return 1
fi
}
cmd_stop() {
[ -f "$HPID" ] && kill "$(cat "$HPID")" 2>/dev/null
[ -f "$SPID" ] && kill "$(cat "$SPID")" 2>/dev/null
rm -f "$FIFO" "$SPID" "$HPID" "$EPF"
echo "warm: stopped"
}
cmd_run() {
if ! _running; then echo "warm: server not running — starting it first"; cmd_start || return 1; fi
local filter="${1:-}" any=0 totp=0 totf=0
for s in "${SUITES[@]}"; do
read -r name runner file <<< "$s"
[ -n "$filter" ] && [ "$name" != "$filter" ] && continue
any=1
# reload the host modules (what changes) + this suite's test file, then eval the runner.
local off; off="$(wc -c < "$LOG")"
_emit_loads "${HOSTMODS[@]}" "$file" >/dev/null
local e; e="$(cat "$EPF")"; e=$((e+1))
_send "(epoch $e)"; _send "(eval \"($runner)\")"
echo "$e" > "$EPF"
if ! _wait_for '^\{:' "$off" 1800; then echo "X $name — no result"; continue; fi
local dict; dict="$(tail -c +"$((off+1))" "$LOG" | grep -E '^\{:' | tail -1)"
local p f; p="$(echo "$dict" | grep -oE ':passed [0-9]+' | awk '{print $2}')"; f="$(echo "$dict" | grep -oE ':failed [0-9]+' | awk '{print $2}')"
p="${p:-0}"; f="${f:-0}"; totp=$((totp+p)); totf=$((totf+f))
if [ "$f" -gt 0 ]; then
printf 'X %-12s %d/%d\n' "$name" "$p" "$((p+f))"
echo "$dict" | grep -oE ':name "[^"]*"' | sed 's/:name / fail: /'
else
printf 'ok %-12s %d passed\n' "$name" "$p"
fi
done
[ "$any" = 0 ] && { echo "no suite matched '$filter'"; return 1; }
if [ "$totf" -eq 0 ]; then echo "ok $totp passed (warm)"; else echo "FAIL $totp passed, $totf failed (warm)"; return 1; fi
}
# profiling: eval an SX expression against the warm image, report round-trip time. The
# epoch protocol only accepts COMMANDS, so the expr is wrapped in (eval "<source>") with
# quotes/backslashes escaped; errors come back as (error N …), success as (ok N …).
cmd_eval() {
if ! _running; then echo "warm: not running"; return 1; fi
local expr="$1" esc off e t0 t1
esc="${expr//\\/\\\\}"; esc="${esc//\"/\\\"}"
off="$(wc -c < "$LOG")"; e="$(cat "$EPF")"; e=$((e+1)); echo "$e" > "$EPF"
t0=$(date +%s.%N)
{ printf '(epoch %d)\n(eval "%s")\n' "$e" "$esc"; } > "$FIFO"
# an (eval …) acks as (ok-len N C) with the result printed on its own line(s); an error
# acks as (error N …). Wait for either, then show the result line (the non-ack output).
_wait_for "^\((ok-len|error) $e " "$off" 600 || { echo " (eval timeout)"; return 1; }
t1=$(date +%s.%N)
printf ' [%6.2fs] %s\n' "$(echo "$t1 - $t0" | bc -l)" "$(tail -c +"$((off+1))" "$LOG" | grep -vE '^\((ok|ok-len) ' | tail -1)"
}
# reload one or more module files into the warm image (e.g. after editing blog.sx).
cmd_reload() { if ! _running; then echo "warm: not running"; return 1; fi; shift; local last; last="$(_emit_loads "$@")"; _wait_for "^\(ok $last " 0 300 && echo "warm: reloaded $* (epoch $last)"; }
case "${1:-}" in
start) cmd_start ;;
stop) cmd_stop ;;
restart) cmd_stop; cmd_start ;;
run) shift; cmd_run "${1:-}" ;;
eval) cmd_eval "${2:-}" ;;
reload) cmd_reload "$@" ;;
*) echo "usage: $0 {start|run [suite]|stop|restart|eval <expr>|reload <files...>}" >&2; exit 1 ;;
esac