Compare commits
63 Commits
loops/conf
...
loops/fed-
| Author | SHA1 | Date | |
|---|---|---|---|
| 78eae9ef12 | |||
| 7267b83b08 | |||
| 31ff1e6a3f | |||
| 0f85bd963a | |||
| e1336986cd | |||
| ed9f180d12 | |||
| 897449cb35 | |||
| 595c15a3fb | |||
| 6d7f0a3f15 | |||
| 076b8ae7f7 | |||
| 4852cca9eb | |||
| 3d80bd8ce6 | |||
| 24e3bf53b0 | |||
| 24763c5199 | |||
| 004a88c03c | |||
| e8ca0590a3 | |||
| 559ed68907 | |||
| 1496136d12 | |||
| 5940b98878 | |||
| 6137904368 | |||
| 2a14b37c6c | |||
| dd7b7d7a2d | |||
| 1aaede4272 | |||
| 3c945b9104 | |||
| fa064093f5 | |||
| cd7693d443 | |||
| 285dd64dc2 | |||
| 05100ef050 | |||
| ccceb4a0b3 | |||
| e9a905eb5f | |||
| f2aa294f00 | |||
| 212bf53a03 | |||
| 2aeab806fb | |||
| a4905a3e71 | |||
| d15f4d229e | |||
| b45ea2aa16 | |||
| 81efa1d8f0 | |||
| 1ea47681b2 | |||
| c91683b885 | |||
| 4956a6d8ae | |||
| c5481d06aa | |||
| 6e12f539fd | |||
| 8c592c41b8 | |||
| b7f7915c2a | |||
| 460257f2bb | |||
| 9cb002c856 | |||
| aa6b01f430 | |||
| 1aab9eff7d | |||
| d1a2ebd709 | |||
| 203a3a3c67 | |||
| 73a1a55572 | |||
| ae5df5cfa1 | |||
| 5d7b167a93 | |||
| cfdb9cd875 | |||
| 4c0295cdff | |||
| b308ddb9b0 | |||
| 28168b16aa | |||
| ab159dface | |||
| 53b4a4c1fd | |||
| 65dfdd0ba4 | |||
| e11e8b941f | |||
| 9cbf14fe8c | |||
| 11ed4ddf27 |
@@ -1 +1 @@
|
||||
{"sessionId":"bf20a443-9df8-4cb9-932e-8c6f4c4625c2","pid":1303602,"procStart":"253831081","acquiredAt":1779865895644}
|
||||
{"sessionId":"31c80255-eb92-43e4-8997-84ad84e27326","pid":90960,"procStart":"564684","acquiredAt":1777049890282}
|
||||
@@ -2,7 +2,7 @@
|
||||
"mcpServers": {
|
||||
"sx-tree": {
|
||||
"type": "stdio",
|
||||
"command": "/root/rose-ash/hosts/ocaml/_build/default/bin/mcp_tree.exe"
|
||||
"command": "./hosts/ocaml/_build/default/bin/mcp_tree.exe"
|
||||
},
|
||||
"rose-ash-services": {
|
||||
"type": "stdio",
|
||||
|
||||
@@ -855,164 +855,6 @@ let setup_evaluator_bridge env =
|
||||
done;
|
||||
Nil
|
||||
| _ -> raise (Eval_error "http-listen: (port handler)"));
|
||||
|
||||
(* fed-sx Milestone 1 client direction (Phase J). NATIVE ONLY —
|
||||
Unix sockets + DNS; absent from the WASM kernel. HTTP/1.1
|
||||
request: TCP connect, write request line + headers + body,
|
||||
read status + headers + body, return {:status :headers :body}.
|
||||
URL must be http://...; HTTPS is a later phase (needs TLS).
|
||||
Body read: Content-Length first, else read to EOF (we send
|
||||
Connection: close). Transfer-Encoding: chunked is rejected —
|
||||
fed-sx Phase 8 wires this for inter-server POSTs which will
|
||||
all carry Content-Length. *)
|
||||
Sx_primitives.register "http-request" (fun args ->
|
||||
let strip_cr s =
|
||||
let n = String.length s in
|
||||
if n > 0 && s.[n - 1] = '\r' then String.sub s 0 (n - 1) else s
|
||||
in
|
||||
match args with
|
||||
| [String meth; String url; headers_v; body_v] ->
|
||||
let body = match body_v with
|
||||
| String s -> s
|
||||
| Nil -> ""
|
||||
| v -> Sx_types.value_to_string v in
|
||||
let prefix = "http://" in
|
||||
let plen = String.length prefix in
|
||||
let ulen = String.length url in
|
||||
if ulen < plen || String.sub url 0 plen <> prefix
|
||||
then raise (Eval_error "http-request: URL must start with http://");
|
||||
let rest = String.sub url plen (ulen - plen) in
|
||||
let host_port, path =
|
||||
match String.index_opt rest '/' with
|
||||
| Some i ->
|
||||
String.sub rest 0 i,
|
||||
String.sub rest i (String.length rest - i)
|
||||
| None -> rest, "/" in
|
||||
if host_port = "" then
|
||||
raise (Eval_error "http-request: missing host");
|
||||
let host, port =
|
||||
match String.index_opt host_port ':' with
|
||||
| Some i ->
|
||||
let h = String.sub host_port 0 i in
|
||||
let ps = String.sub host_port (i + 1)
|
||||
(String.length host_port - i - 1) in
|
||||
(h,
|
||||
(try int_of_string ps with _ ->
|
||||
raise (Eval_error "http-request: bad port")))
|
||||
| None -> host_port, 80 in
|
||||
let addr =
|
||||
(try (Unix.gethostbyname host).h_addr_list.(0)
|
||||
with Not_found ->
|
||||
raise (Eval_error ("http-request: dns: " ^ host))) in
|
||||
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
||||
let cleanup () = try Unix.close sock with _ -> () in
|
||||
let result =
|
||||
(try
|
||||
(try Unix.connect sock (Unix.ADDR_INET (addr, port))
|
||||
with Unix.Unix_error (e, _, _) ->
|
||||
raise (Eval_error
|
||||
("http-request: connect: " ^ Unix.error_message e)));
|
||||
let oc = Unix.out_channel_of_descr sock in
|
||||
let ic = Unix.in_channel_of_descr sock in
|
||||
let buf = Buffer.create 256 in
|
||||
Buffer.add_string buf
|
||||
(Printf.sprintf "%s %s HTTP/1.1\r\n" meth path);
|
||||
let host_hdr_sent = ref false in
|
||||
let clen_sent = ref false in
|
||||
let conn_sent = ref false in
|
||||
(match headers_v with
|
||||
| Dict h ->
|
||||
Hashtbl.iter (fun k v ->
|
||||
let kl = String.lowercase_ascii k in
|
||||
if kl = "host" then host_hdr_sent := true;
|
||||
if kl = "content-length" then clen_sent := true;
|
||||
if kl = "connection" then conn_sent := true;
|
||||
let vs = match v with
|
||||
| String s -> s
|
||||
| x -> Sx_types.value_to_string x in
|
||||
Buffer.add_string buf
|
||||
(Printf.sprintf "%s: %s\r\n" k vs)) h
|
||||
| Nil -> ()
|
||||
| _ -> raise (Eval_error "http-request: headers must be dict"));
|
||||
if not !host_hdr_sent then
|
||||
Buffer.add_string buf
|
||||
(Printf.sprintf "Host: %s\r\n" host_port);
|
||||
if not !clen_sent then
|
||||
Buffer.add_string buf
|
||||
(Printf.sprintf "Content-Length: %d\r\n"
|
||||
(String.length body));
|
||||
if not !conn_sent then
|
||||
Buffer.add_string buf "Connection: close\r\n";
|
||||
Buffer.add_string buf "\r\n";
|
||||
Buffer.add_string buf body;
|
||||
output_string oc (Buffer.contents buf);
|
||||
flush oc;
|
||||
let sl =
|
||||
(try strip_cr (input_line ic)
|
||||
with End_of_file ->
|
||||
raise (Eval_error
|
||||
"http-request: connection closed before status")) in
|
||||
let status =
|
||||
match String.split_on_char ' ' sl with
|
||||
| _ver :: code :: _ ->
|
||||
(try int_of_string code with _ ->
|
||||
raise (Eval_error "http-request: bad status code"))
|
||||
| _ -> raise (Eval_error "http-request: bad status line") in
|
||||
let rhdrs = Sx_types.make_dict () in
|
||||
let clen = ref (-1) in
|
||||
let chunked = ref false in
|
||||
let rec rdh () =
|
||||
let h =
|
||||
(try strip_cr (input_line ic)
|
||||
with End_of_file -> "") in
|
||||
if h = "" then ()
|
||||
else begin
|
||||
(match String.index_opt h ':' with
|
||||
| Some i ->
|
||||
let name =
|
||||
String.lowercase_ascii
|
||||
(String.trim (String.sub h 0 i)) in
|
||||
let value =
|
||||
String.trim
|
||||
(String.sub h (i + 1)
|
||||
(String.length h - i - 1)) in
|
||||
Hashtbl.replace rhdrs name (String value);
|
||||
if name = "content-length" then
|
||||
(try clen := int_of_string value with _ -> ())
|
||||
else if name = "transfer-encoding" &&
|
||||
String.lowercase_ascii value = "chunked"
|
||||
then chunked := true
|
||||
| None -> ());
|
||||
rdh ()
|
||||
end in
|
||||
rdh ();
|
||||
if !chunked then
|
||||
raise (Eval_error
|
||||
"http-request: chunked transfer-encoding not supported");
|
||||
let rbody =
|
||||
if !clen >= 0 then begin
|
||||
let b = Bytes.create !clen in
|
||||
really_input ic b 0 !clen;
|
||||
Bytes.unsafe_to_string b
|
||||
end else begin
|
||||
let b = Buffer.create 256 in
|
||||
(try
|
||||
while true do
|
||||
Buffer.add_channel b ic 4096
|
||||
done; assert false
|
||||
with End_of_file -> ());
|
||||
Buffer.contents b
|
||||
end in
|
||||
let resp = Sx_types.make_dict () in
|
||||
Hashtbl.replace resp "status" (Integer status);
|
||||
Hashtbl.replace resp "headers" (Dict rhdrs);
|
||||
Hashtbl.replace resp "body" (String rbody);
|
||||
Dict resp
|
||||
with e -> cleanup (); raise e) in
|
||||
cleanup ();
|
||||
result
|
||||
| _ -> raise (Eval_error "http-request: (method url headers body)"));
|
||||
|
||||
bind "trampoline" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
|
||||
@@ -1,80 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
# Phase J test — native-only http-request client primitive.
|
||||
# Reuses Phase H's http-listen to spin up an echo server, then drives
|
||||
# a separate sx_server via the epoch protocol to issue http-request
|
||||
# calls and assert response shape + headers + body.
|
||||
set -u
|
||||
cd "$(dirname "$0")/.."
|
||||
|
||||
SRV=_build/default/bin/sx_server.exe
|
||||
PORT=${HTTP_CLIENT_TEST_PORT:-8921}
|
||||
PASS=0
|
||||
FAIL=0
|
||||
ok() { echo " PASS: $1"; PASS=$((PASS+1)); }
|
||||
bad() { echo " FAIL: $1 — $2"; FAIL=$((FAIL+1)); }
|
||||
|
||||
if [ ! -x "$SRV" ]; then
|
||||
echo "build sx_server.exe first (dune build bin/sx_server.exe)"; exit 1
|
||||
fi
|
||||
|
||||
# /echo echoes method/path/query/body and reflects request X-Custom
|
||||
# back as response X-Got; /missing-test → 404.
|
||||
H='(begin (define (h req) (if (= (get req "path") "/echo") {:status 200 :headers {"X-Echo" (get req "method") "X-Got" (get (get req "headers") "x-custom")} :body (str "M=" (get req "method") " P=" (get req "path") " Q=" (get req "query") " B=" (get req "body"))} (if (= (get req "path") "/missing-test") {:status 404 :body "nope"} {:status 500 :body "err"}))) (http-listen '"$PORT"' h))'
|
||||
ESC=${H//\"/\\\"}
|
||||
|
||||
{ printf '(epoch 1)\n(eval "%s")\n' "$ESC"; sleep 60; } | "$SRV" >/tmp/test_http_client_srv.out 2>&1 &
|
||||
SVPID=$!
|
||||
trap 'kill $SVPID 2>/dev/null; wait 2>/dev/null' EXIT
|
||||
|
||||
up=0
|
||||
for _ in $(seq 1 50); do
|
||||
curl -s -o /dev/null "http://127.0.0.1:$PORT/echo" 2>/dev/null && { up=1; break; }
|
||||
sleep 0.2
|
||||
done
|
||||
[ "$up" = 1 ] || { echo " FAIL: server did not start"; cat /tmp/test_http_client_srv.out; exit 1; }
|
||||
|
||||
emit() {
|
||||
# $1 = epoch num, $2 = raw SX form. Wraps in (eval "...") with quotes escaped.
|
||||
local esc=${2//\"/\\\"}
|
||||
printf '(epoch %s)\n(eval "%s")\n' "$1" "$esc"
|
||||
}
|
||||
|
||||
DRV_OUT=/tmp/test_http_client_drv.out
|
||||
{
|
||||
emit 1 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo?x=1" {} ""))) (str "S=" (get r "status") " E=" (get (get r "headers") "x-echo") " B=" (get r "body")))'
|
||||
emit 2 '(let ((r (http-request "POST" "http://127.0.0.1:'"$PORT"'/echo" {} "hello"))) (str "S=" (get r "status") " B=" (get r "body")))'
|
||||
emit 3 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/missing-test" {} ""))) (str "S=" (get r "status") " B=" (get r "body")))'
|
||||
emit 4 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo" {"X-Custom" "myval"} ""))) (get (get r "headers") "x-got"))'
|
||||
emit 5 '(http-request "GET" "ftp://nope" {} "")'
|
||||
emit 6 '(let ((r (http-request "GET" "http://127.0.0.1:'"$PORT"'/echo" {} ""))) (get r "status"))'
|
||||
} | "$SRV" >"$DRV_OUT" 2>&1
|
||||
|
||||
# eval results come back as (ok-len N L)\n<body>\n — grep the body content.
|
||||
grep -q '^"S=200 E=GET B=M=GET P=/echo Q=x=1 B="$' "$DRV_OUT" \
|
||||
&& ok "GET status + echo header + body" \
|
||||
|| bad "GET" "$(grep -A1 '^(ok-len 1 ' "$DRV_OUT" | tail -1)"
|
||||
|
||||
grep -q '^"S=200 B=M=POST P=/echo Q= B=hello"$' "$DRV_OUT" \
|
||||
&& ok "POST body roundtrip" \
|
||||
|| bad "POST" "$(grep -A1 '^(ok-len 2 ' "$DRV_OUT" | tail -1)"
|
||||
|
||||
grep -q '^"S=404 B=nope"$' "$DRV_OUT" \
|
||||
&& ok "404 status + body" \
|
||||
|| bad "404" "$(grep -A1 '^(ok-len 3 ' "$DRV_OUT" | tail -1)"
|
||||
|
||||
grep -q '^"myval"$' "$DRV_OUT" \
|
||||
&& ok "custom request header reaches server" \
|
||||
|| bad "custom-header" "$(grep -A1 '^(ok-len 4 ' "$DRV_OUT" | tail -1)"
|
||||
|
||||
R5=$(grep '^(error 5 ' "$DRV_OUT" | head -1)
|
||||
echo "$R5" | grep -q 'URL must start with http' \
|
||||
&& ok "non-http scheme rejected" \
|
||||
|| bad "bad-url" "$R5"
|
||||
|
||||
# Status is an Integer (200), serialized bare without quotes.
|
||||
grep -q '^200$' "$DRV_OUT" \
|
||||
&& ok "response status is integer 200" \
|
||||
|| bad "status-integer" "$(grep -A1 '^(ok-len 6 ' "$DRV_OUT" | tail -1)"
|
||||
|
||||
echo "Results: $PASS passed, $FAIL failed"
|
||||
[ "$FAIL" = 0 ]
|
||||
@@ -1,45 +0,0 @@
|
||||
;; lib/acl/api.sx — public ACL surface over an implicit current db.
|
||||
;;
|
||||
;; Callers load a fact set once, then issue decisions without threading the db
|
||||
;; through every call. The current db is module state; (acl/load! facts) rebuilds
|
||||
;; it. This is the boundary the rest of rose-ash imports.
|
||||
|
||||
(define acl-current-db nil)
|
||||
|
||||
;; Replace the current fact base. Rebuilds the Datalog db under the active
|
||||
;; ruleset (see lib/acl/engine.sx).
|
||||
(define
|
||||
acl/load!
|
||||
(fn
|
||||
(facts)
|
||||
(do (set! acl-current-db (acl-build-db facts)) acl-current-db)))
|
||||
|
||||
;; Ensure a db exists, building an empty one on first use.
|
||||
(define
|
||||
acl-ensure-db!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(when
|
||||
(= acl-current-db nil)
|
||||
(set! acl-current-db (acl-build-db (list))))
|
||||
acl-current-db)))
|
||||
|
||||
;; Public decision against the current db (pure, no logging).
|
||||
(define
|
||||
acl/permit?
|
||||
(fn (subj act res) (acl-permit? (acl-ensure-db!) subj act res)))
|
||||
|
||||
;; Decision-with-proof against the current db. See lib/acl/explain.sx.
|
||||
(define
|
||||
acl/explain
|
||||
(fn (subj act res) (acl-explain (acl-ensure-db!) subj act res)))
|
||||
|
||||
;; Audited decision: logs the outcome to the append-only audit log and returns
|
||||
;; the boolean. See lib/acl/audit.sx.
|
||||
(define
|
||||
acl/audit
|
||||
(fn (subj act res) (acl-audit-decide! (acl-ensure-db!) subj act res)))
|
||||
|
||||
;; Recent audited decisions (chronological).
|
||||
(define acl/audit-tail (fn (n) (acl-audit-tail n)))
|
||||
110
lib/acl/audit.sx
110
lib/acl/audit.sx
@@ -1,110 +0,0 @@
|
||||
;; lib/acl/audit.sx — append-only decision log.
|
||||
;;
|
||||
;; Every decision routed through acl-audit-decide! is appended to an in-memory
|
||||
;; log with a monotonic sequence number (no wall-clock — deterministic and
|
||||
;; testable; a host can stamp time at the serializer boundary). The log is
|
||||
;; append-only: there is no mutate or delete, only append, tail, clear,
|
||||
;; snapshot/restore, and serialize-for-disk.
|
||||
|
||||
(define acl-audit-log (list))
|
||||
(define acl-audit-seq 0)
|
||||
|
||||
;; Copy a list into a fresh, append!-able list. `map`/`rest`-derived lists are
|
||||
;; NOT extensible by append! in this runtime (it silently no-ops), so the live
|
||||
;; log must always be a list built with `list` + `append!`.
|
||||
(define
|
||||
acl-audit-copy
|
||||
(fn
|
||||
(xs)
|
||||
(let
|
||||
((fresh (list)))
|
||||
(do (for-each (fn (e) (append! fresh e)) xs) fresh))))
|
||||
|
||||
(define
|
||||
acl-audit-clear!
|
||||
(fn
|
||||
()
|
||||
(do (set! acl-audit-log (list)) (set! acl-audit-seq 0) nil)))
|
||||
|
||||
;; Append a decision record. Returns the record.
|
||||
(define
|
||||
acl-audit-record!
|
||||
(fn
|
||||
(subj act res allowed?)
|
||||
(let
|
||||
((entry {:allowed? allowed? :act act :subj subj :res res :seq acl-audit-seq}))
|
||||
(do
|
||||
(set! acl-audit-seq (+ acl-audit-seq 1))
|
||||
(append! acl-audit-log entry)
|
||||
entry))))
|
||||
|
||||
;; Decide against db, log the outcome, and return the boolean. This is the
|
||||
;; audited path; acl-permit? remains the pure, side-effect-free decision.
|
||||
(define
|
||||
acl-audit-decide!
|
||||
(fn
|
||||
(db subj act res)
|
||||
(let
|
||||
((allowed? (acl-permit? db subj act res)))
|
||||
(do (acl-audit-record! subj act res allowed?) allowed?))))
|
||||
|
||||
(define acl-audit-count (fn () (len acl-audit-log)))
|
||||
|
||||
;; Most recent n entries (in chronological order). n >= log size returns all.
|
||||
(define
|
||||
acl-audit-tail
|
||||
(fn
|
||||
(n)
|
||||
(let
|
||||
((total (len acl-audit-log)))
|
||||
(if
|
||||
(<= total n)
|
||||
acl-audit-log
|
||||
(acl-audit-drop acl-audit-log (- total n))))))
|
||||
|
||||
(define
|
||||
acl-audit-drop
|
||||
(fn
|
||||
(xs k)
|
||||
(if (<= k 0) xs (acl-audit-drop (rest xs) (- k 1)))))
|
||||
|
||||
;; Structured snapshot for save/restore — a {:seq :entries} value carrying a
|
||||
;; copy of the log (so later appends don't mutate a held snapshot).
|
||||
(define acl-audit-snapshot (fn () {:seq acl-audit-seq :entries (acl-audit-copy acl-audit-log)}))
|
||||
|
||||
;; Replace the live log from a snapshot. Restores both entries and the seq
|
||||
;; counter so subsequent records continue numbering correctly. The log is
|
||||
;; rebuilt as a fresh append!-able list (see acl-audit-copy).
|
||||
(define
|
||||
acl-audit-restore!
|
||||
(fn
|
||||
(snap)
|
||||
(do
|
||||
(set! acl-audit-log (acl-audit-copy (get snap :entries)))
|
||||
(set! acl-audit-seq (get snap :seq))
|
||||
nil)))
|
||||
|
||||
;; Serialize the whole log to a disk-ready string: one record per line,
|
||||
;; "seq\tsubj\tact\tres\tallowed?". A host writes this; structured reload is via
|
||||
;; snapshot/restore.
|
||||
(define
|
||||
acl-audit-serialize
|
||||
(fn
|
||||
()
|
||||
(reduce
|
||||
(fn
|
||||
(acc e)
|
||||
(str
|
||||
acc
|
||||
(get e :seq)
|
||||
"\t"
|
||||
(get e :subj)
|
||||
"\t"
|
||||
(get e :act)
|
||||
"\t"
|
||||
(get e :res)
|
||||
"\t"
|
||||
(get e :allowed?)
|
||||
"\n"))
|
||||
""
|
||||
acl-audit-log)))
|
||||
@@ -1,32 +0,0 @@
|
||||
# ACL conformance config — sourced by lib/guest/conformance.sh.
|
||||
|
||||
LANG_NAME=acl
|
||||
MODE=dict
|
||||
|
||||
PRELOADS=(
|
||||
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
|
||||
)
|
||||
|
||||
SUITES=(
|
||||
"direct:lib/acl/tests/direct.sx:(acl-direct-tests-run!)"
|
||||
"inherit:lib/acl/tests/inherit.sx:(acl-inherit-tests-run!)"
|
||||
"explain:lib/acl/tests/explain.sx:(acl-explain-tests-run!)"
|
||||
"fed:lib/acl/tests/fed.sx:(acl-fed-tests-run!)"
|
||||
"harden:lib/acl/tests/harden.sx:(acl-harden-tests-run!)"
|
||||
)
|
||||
@@ -1,3 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
# Thin wrapper — see lib/guest/conformance.sh and lib/acl/conformance.conf.
|
||||
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"
|
||||
@@ -1,72 +0,0 @@
|
||||
;; lib/acl/engine.sx — ACL ruleset + decision reducer over lib/datalog/.
|
||||
;;
|
||||
;; The engine is a thin layer: it owns the permit ruleset (SX data rules) and
|
||||
;; reduces a (subject, action, resource) decision to a Datalog query against a
|
||||
;; db built from EDB facts. The rule engine itself is Datalog's.
|
||||
;;
|
||||
;; Policy — inheritance + federation with deny-overrides:
|
||||
;;
|
||||
;; eff_grant(S,A,R) :- grant(S,A,R). ; direct
|
||||
;; eff_grant(S,A,R) :- member_of(S,G), eff_grant(G,A,R). ; group/role chain
|
||||
;; eff_grant(S,A,R) :- child_of(R,P), eff_grant(S,A,P). ; resource tree
|
||||
;; eff_grant(S,A,R) :- member_of(S,Role), role_grant(Role,A,R). ; role expansion
|
||||
;; eff_grant(S,A,R) :- delegate(Peer,S,A,R), ; federated grant
|
||||
;; trust(Peer,L), level_covers(L,A).
|
||||
;;
|
||||
;; eff_deny(S,A,R) :- deny(S,A,R). ; direct
|
||||
;; eff_deny(S,A,R) :- member_of(S,G), eff_deny(G,A,R). ; group chain
|
||||
;; eff_deny(S,A,R) :- child_of(R,P), eff_deny(S,A,P). ; resource tree
|
||||
;;
|
||||
;; permit(S,A,R) :- eff_grant(S,A,R), not eff_deny(S,A,R).
|
||||
;;
|
||||
;; DENY-OVERRIDES: an effective deny anywhere in the inheritance closure of
|
||||
;; (S,A,R) defeats any effective grant — including federated grants. Deny
|
||||
;; inherits through the *same* group and resource chains as grant, so a
|
||||
;; group-level or ancestor-resource deny is authoritative for members/
|
||||
;; descendants. This is the principled, fail-safe reading of "deny wins".
|
||||
;;
|
||||
;; FEDERATION — non-transitive trust: a peer's `delegate` fact only grants if a
|
||||
;; *local* `trust(Peer, L)` exists AND that level `level_covers` the action.
|
||||
;; Trust is re-checked on every query (it is a body literal), never baked in at
|
||||
;; fact-ingestion time, so revoking trust or narrowing a level takes effect
|
||||
;; immediately on the next decision.
|
||||
;;
|
||||
;; Termination & stratification:
|
||||
;; - eff_grant/eff_deny recurse only over member_of and child_of, which are
|
||||
;; EDB relations with no function symbols, so the closure is finite (cyclic
|
||||
;; membership/containment just reaches a fixpoint, never loops). The
|
||||
;; federation rule is non-recursive.
|
||||
;; - permit negates eff_deny; neither eff_grant nor eff_deny depends on
|
||||
;; permit, so the program is stratifiable (permit sits in a higher stratum).
|
||||
|
||||
(define
|
||||
acl-rules
|
||||
(quote
|
||||
((eff_grant S A R <- (grant S A R))
|
||||
(eff_grant S A R <- (member_of S G) (eff_grant G A R))
|
||||
(eff_grant S A R <- (child_of R P) (eff_grant S A P))
|
||||
(eff_grant S A R <- (member_of S Role) (role_grant Role A R))
|
||||
(eff_grant
|
||||
S
|
||||
A
|
||||
R
|
||||
<-
|
||||
(delegate Peer S A R)
|
||||
(trust Peer L)
|
||||
(level_covers L A))
|
||||
(eff_deny S A R <- (deny S A R))
|
||||
(eff_deny S A R <- (member_of S G) (eff_deny G A R))
|
||||
(eff_deny S A R <- (child_of R P) (eff_deny S A P))
|
||||
(permit S A R <- (eff_grant S A R) {:neg (eff_deny S A R)}))))
|
||||
|
||||
;; Build a Datalog db from a list of EDB facts under the ACL ruleset.
|
||||
(define acl-build-db (fn (facts) (dl-program-data facts acl-rules)))
|
||||
|
||||
;; Core decision: does the db permit subject S to perform action A on
|
||||
;; resource R? Reduces to a ground Datalog query on the derived `permit`
|
||||
;; relation — non-empty result means permitted.
|
||||
(define
|
||||
acl-permit?
|
||||
(fn
|
||||
(db subj act res)
|
||||
(> (len (dl-query db (list (quote permit) subj act res))) 0)))
|
||||
@@ -1,125 +0,0 @@
|
||||
;; lib/acl/explain.sx — proof-tree reconstruction over the saturated db.
|
||||
;;
|
||||
;; lib/datalog/ records derived facts but not their provenance, so the proof is
|
||||
;; reconstructed here by goal-directed search over the *saturated* db: for a
|
||||
;; ground goal we find the first ACL rule (in rule order) whose body holds, take
|
||||
;; the first solution binding its remaining variables, and recurse on each body
|
||||
;; literal. Negated literals are recorded as verified `:neg-ok` leaves.
|
||||
;;
|
||||
;; CANONICAL DERIVATION: the Datalog derivation graph is a DAG (a fact may hold
|
||||
;; many ways). We pick ONE canonical proof — first matching rule, first solution
|
||||
;; — matching the rule order in lib/acl/engine.sx (direct/EDB rules first). A
|
||||
;; depth cap guards against pathological cyclic data producing unbounded search.
|
||||
;;
|
||||
;; A proof node is one of:
|
||||
;; {:fact <lit> :via "edb"} — base EDB fact
|
||||
;; {:fact <lit> :rule <head> :body (<node|negleaf> ...)} — derived
|
||||
;; {:neg-ok <lit>} — negation verified to fail
|
||||
;; {:fact <lit> :truncated true} — depth cap hit
|
||||
|
||||
(define acl-proof-max-depth 64)
|
||||
|
||||
;; Substitute a body literal, descending into {:neg ...} dicts (dl-apply-subst
|
||||
;; does not recurse into dicts, which would leak the neg's free vars).
|
||||
(define
|
||||
acl-subst-lit
|
||||
(fn
|
||||
(lit s)
|
||||
(if
|
||||
(and (dict? lit) (has-key? lit :neg))
|
||||
{:neg (dl-apply-subst (get lit :neg) s)}
|
||||
(dl-apply-subst lit s))))
|
||||
|
||||
(define
|
||||
acl-lit-edb?
|
||||
(fn
|
||||
(lit)
|
||||
(and
|
||||
(list? lit)
|
||||
(> (len lit) 0)
|
||||
(symbol? (first lit))
|
||||
(has-key? acl-edb-arity (symbol->string (first lit))))))
|
||||
|
||||
(define
|
||||
acl-subst-zip!
|
||||
(fn
|
||||
(d ks vs)
|
||||
(when
|
||||
(> (len ks) 0)
|
||||
(do
|
||||
(dict-set! d (symbol->string (first ks)) (first vs))
|
||||
(acl-subst-zip! d (rest ks) (rest vs))))))
|
||||
|
||||
;; Bind a rule head's variables to a ground goal's arguments (positional).
|
||||
(define
|
||||
acl-bind-head
|
||||
(fn
|
||||
(head goal)
|
||||
(let
|
||||
((d {}))
|
||||
(do (acl-subst-zip! d (rest head) (rest goal)) d))))
|
||||
|
||||
(define
|
||||
acl-subst-union
|
||||
(fn
|
||||
(a b)
|
||||
(let
|
||||
((d {}))
|
||||
(do
|
||||
(for-each (fn (k) (dict-set! d k (get a k))) (keys a))
|
||||
(for-each (fn (k) (dict-set! d k (get b k))) (keys b))
|
||||
d))))
|
||||
|
||||
(define acl-prove (fn (db goal) (acl-prove-d db goal 0)))
|
||||
|
||||
(define
|
||||
acl-prove-d
|
||||
(fn
|
||||
(db goal depth)
|
||||
(cond
|
||||
((> depth acl-proof-max-depth) {:truncated true :fact goal})
|
||||
((acl-lit-edb? goal)
|
||||
(if (> (len (dl-query db goal)) 0) {:via "edb" :fact goal} nil))
|
||||
(else (acl-prove-rules db goal acl-rules depth)))))
|
||||
|
||||
(define
|
||||
acl-prove-rules
|
||||
(fn
|
||||
(db goal rules depth)
|
||||
(if
|
||||
(= (len rules) 0)
|
||||
nil
|
||||
(let
|
||||
((p (dl-rule-from-list (first rules))))
|
||||
(if
|
||||
(= (first (get p :head)) (first goal))
|
||||
(let
|
||||
((hs (acl-bind-head (get p :head) goal)))
|
||||
(let
|
||||
((qbody (map (fn (l) (acl-subst-lit l hs)) (get p :body))))
|
||||
(let
|
||||
((sols (dl-query db qbody)))
|
||||
(if
|
||||
(> (len sols) 0)
|
||||
(acl-prove-build db goal p hs (first sols) depth)
|
||||
(acl-prove-rules db goal (rest rules) depth)))))
|
||||
(acl-prove-rules db goal (rest rules) depth))))))
|
||||
|
||||
(define
|
||||
acl-prove-build
|
||||
(fn
|
||||
(db goal p hs sol depth)
|
||||
(let ((full (acl-subst-union hs sol))) {:body (map (fn (l) (let ((g (acl-subst-lit l full))) (if (and (dict? g) (has-key? g :neg)) {:neg-ok (get g :neg)} (acl-prove-d db g (+ depth 1))))) (get p :body)) :rule (get p :head) :fact goal})))
|
||||
|
||||
;; Public decision-with-proof. Returns:
|
||||
;; {:allowed? <bool> :proof <node|nil> :reason <eff_deny proof|nil>}
|
||||
;; When permitted, :proof is the permit derivation. When denied, :proof is nil
|
||||
;; and :reason carries the blocking eff_deny proof if one exists (an explicit or
|
||||
;; inherited deny), else nil (simply no grant).
|
||||
(define
|
||||
acl-explain
|
||||
(fn
|
||||
(db subj act res)
|
||||
(let
|
||||
((proof (acl-prove db (list (quote permit) subj act res))))
|
||||
(if (= proof nil) {:allowed? false :proof nil :reason (acl-prove db (list (quote eff_deny) subj act res))} {:allowed? true :proof proof :reason nil}))))
|
||||
@@ -1,47 +0,0 @@
|
||||
;; lib/acl/facts.sx — EDB fact constructors.
|
||||
;;
|
||||
;; Each constructor returns a Datalog fact tuple (a list whose head is the
|
||||
;; predicate symbol). These are the only shapes lib/acl/engine.sx feeds to
|
||||
;; lib/datalog/.
|
||||
;; Phase 1: actor/resource/grant/deny.
|
||||
;; Phase 2: member_of (subject -> group/role), child_of (resource -> parent),
|
||||
;; role_grant (role -> action,resource capability).
|
||||
;; Phase 4: peer/trust/delegate/level_covers (federation).
|
||||
|
||||
(define acl-actor (fn (id kind) (list (quote actor) id kind)))
|
||||
|
||||
(define acl-resource-fact (fn (id kind) (list (quote resource) id kind)))
|
||||
|
||||
(define acl-grant (fn (subj act res) (list (quote grant) subj act res)))
|
||||
|
||||
(define acl-deny (fn (subj act res) (list (quote deny) subj act res)))
|
||||
|
||||
;; subject S is a member of group/role G (one hop; transitivity is derived).
|
||||
(define acl-member-of (fn (subj grp) (list (quote member_of) subj grp)))
|
||||
|
||||
;; resource R is a child of parent P (one hop; transitivity is derived).
|
||||
(define acl-child-of (fn (res parent) (list (quote child_of) res parent)))
|
||||
|
||||
;; role confers capability (act on res) to every member of the role.
|
||||
(define
|
||||
acl-role-grant
|
||||
(fn (role act res) (list (quote role_grant) role act res)))
|
||||
|
||||
;; --- federation ---
|
||||
|
||||
;; a known peer instance at addr, of some kind (e.g. peer).
|
||||
(define acl-peer (fn (addr kind) (list (quote peer) addr kind)))
|
||||
|
||||
;; local trust in a peer at a named level. Gates delegated grants at query time.
|
||||
(define acl-trust (fn (peer level) (list (quote trust) peer level)))
|
||||
|
||||
;; a peer asserts that subject S may A on R. Only takes effect if local trust in
|
||||
;; that peer covers action A (see level_covers).
|
||||
(define
|
||||
acl-delegate
|
||||
(fn (peer subj act res) (list (quote delegate) peer subj act res)))
|
||||
|
||||
;; local policy: trust `level` authorises delegated grants for action `act`.
|
||||
(define
|
||||
acl-level-covers
|
||||
(fn (level act) (list (quote level_covers) level act)))
|
||||
@@ -1,61 +0,0 @@
|
||||
;; lib/acl/federation.sx — cross-instance ACL facts + revocation.
|
||||
;;
|
||||
;; fed-sx replicates ACL facts between instances; this module models the local
|
||||
;; side. A peer's authority arrives as `delegate(Peer, S, A, R)` facts, which
|
||||
;; only take effect when a local `trust(Peer, L)` and `level_covers(L, A)`
|
||||
;; authorise them (enforced by the engine rule, re-checked every query). The
|
||||
;; actual network transport is fed-sx's job and is mocked in tests as a dict.
|
||||
;;
|
||||
;; Trust is NOT transitive: trusting peer α does not extend to peers α trusts.
|
||||
;; Only delegate facts that α itself asserts, and that local trust covers, flow.
|
||||
|
||||
;; Mock fed-sx pull: `transport` is a dict mapping a peer address (its string
|
||||
;; name) to the list of delegate facts that peer asserts. Returns the facts for
|
||||
;; `addr`, or an empty list if the peer is unknown / unreachable.
|
||||
(define
|
||||
acl-fed-fetch
|
||||
(fn
|
||||
(transport addr)
|
||||
(let
|
||||
((k (if (symbol? addr) (symbol->string addr) addr)))
|
||||
(if (has-key? transport k) (get transport k) (list)))))
|
||||
|
||||
;; Gather delegate facts from every peer in `addrs` via the transport.
|
||||
(define
|
||||
acl-fed-collect
|
||||
(fn
|
||||
(transport addrs)
|
||||
(let
|
||||
((acc (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(addr)
|
||||
(for-each
|
||||
(fn (f) (append! acc f))
|
||||
(acl-fed-fetch transport addr)))
|
||||
addrs)
|
||||
acc))))
|
||||
|
||||
;; Build a db from local facts plus delegate facts pulled from `peers`. Local
|
||||
;; facts must include the `trust`/`level_covers` policy; replicated delegate
|
||||
;; facts are gated against it by the engine rule at query time.
|
||||
(define
|
||||
acl-fed-build-db
|
||||
(fn
|
||||
(local-facts transport peers)
|
||||
(let
|
||||
((all (list)))
|
||||
(do
|
||||
(for-each (fn (f) (append! all f)) local-facts)
|
||||
(for-each
|
||||
(fn (f) (append! all f))
|
||||
(acl-fed-collect transport peers))
|
||||
(acl-build-db all)))))
|
||||
|
||||
;; Propagated revocation: retract a replicated fact (e.g. a peer's delegate, or
|
||||
;; local trust) from a live db. The next decision re-saturates and reflects it.
|
||||
(define acl-revoke! (fn (db fact) (do (dl-retract! db fact) db)))
|
||||
|
||||
;; Propagated assertion: ingest a newly replicated fact into a live db.
|
||||
(define acl-fed-assert! (fn (db fact) (do (dl-assert! db fact) db)))
|
||||
@@ -1,71 +0,0 @@
|
||||
;; lib/acl/schema.sx — ACL sorts and EDB predicate vocabulary.
|
||||
;;
|
||||
;; Datalog is untyped; this module is the schema-as-data layer. It declares
|
||||
;; the subject/resource/action sorts and the arity of every EDB predicate the
|
||||
;; ACL engine recognises, plus light validators. Facts that pass these checks
|
||||
;; are well-formed inputs to lib/acl/engine.sx.
|
||||
|
||||
(define acl-subject-kinds (quote (user group role service)))
|
||||
(define acl-resource-kinds (quote (page post thread peer)))
|
||||
|
||||
;; Actions are open-ended (a grant may name any action symbol), but these are
|
||||
;; the platform's well-known verbs.
|
||||
(define acl-actions (quote (read edit comment moderate federate)))
|
||||
|
||||
;; EDB predicate name -> arity.
|
||||
;; Phase 1: actor/resource/grant/deny.
|
||||
;; Phase 2: member_of (subject->group/role), child_of (resource->parent),
|
||||
;; role_grant (role->action,resource).
|
||||
;; Phase 4: peer (addr->kind), trust (peer->level),
|
||||
;; delegate (peer->subj,action,resource), level_covers (level->action).
|
||||
(define acl-edb-arity {:role_grant 3 :child_of 2 :trust 2 :peer 2 :actor 2 :level_covers 2 :delegate 4 :member_of 2 :deny 3 :grant 3 :resource 2})
|
||||
|
||||
(define
|
||||
acl-member?
|
||||
(fn
|
||||
(x xs)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((= (first xs) x) true)
|
||||
(else (acl-member? x (rest xs))))))
|
||||
|
||||
(define acl-subject-kind? (fn (k) (acl-member? k acl-subject-kinds)))
|
||||
|
||||
(define acl-resource-kind? (fn (k) (acl-member? k acl-resource-kinds)))
|
||||
|
||||
(define acl-known-action? (fn (a) (acl-member? a acl-actions)))
|
||||
|
||||
;; A fact is a list whose head is a predicate symbol. Valid when the predicate
|
||||
;; is known and the argument count matches the declared arity.
|
||||
(define
|
||||
acl-fact-valid?
|
||||
(fn
|
||||
(f)
|
||||
(and
|
||||
(list? f)
|
||||
(> (len f) 0)
|
||||
(symbol? (first f))
|
||||
(let
|
||||
((pred (symbol->string (first f))))
|
||||
(and
|
||||
(has-key? acl-edb-arity pred)
|
||||
(= (- (len f) 1) (get acl-edb-arity pred)))))))
|
||||
|
||||
;; Return the sublist of facts that fail acl-fact-valid?. Empty list means the
|
||||
;; whole set is well-formed. acl-build-db stays lenient (Datalog accepts any
|
||||
;; tuple, and custom action symbols are allowed); callers opt in to checking.
|
||||
(define
|
||||
acl-validate-facts
|
||||
(fn
|
||||
(facts)
|
||||
(let
|
||||
((bad (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn (f) (when (not (acl-fact-valid? f)) (append! bad f)))
|
||||
facts)
|
||||
bad))))
|
||||
|
||||
(define
|
||||
acl-facts-valid?
|
||||
(fn (facts) (= (len (acl-validate-facts facts)) 0)))
|
||||
@@ -1,14 +0,0 @@
|
||||
{
|
||||
"lang": "acl",
|
||||
"total_passed": 145,
|
||||
"total_failed": 0,
|
||||
"total": 145,
|
||||
"suites": [
|
||||
{"name":"direct","passed":24,"failed":0,"total":24},
|
||||
{"name":"inherit","passed":30,"failed":0,"total":30},
|
||||
{"name":"explain","passed":35,"failed":0,"total":35},
|
||||
{"name":"fed","passed":31,"failed":0,"total":31},
|
||||
{"name":"harden","passed":25,"failed":0,"total":25}
|
||||
],
|
||||
"generated": "2026-06-06T22:43:27+00:00"
|
||||
}
|
||||
@@ -1,11 +0,0 @@
|
||||
# acl scoreboard
|
||||
|
||||
**145 / 145 passing** (0 failure(s)).
|
||||
|
||||
| Suite | Passed | Total | Status |
|
||||
|-------|--------|-------|--------|
|
||||
| direct | 24 | 24 | ok |
|
||||
| inherit | 30 | 30 | ok |
|
||||
| explain | 35 | 35 | ok |
|
||||
| fed | 31 | 31 | ok |
|
||||
| harden | 25 | 25 | ok |
|
||||
@@ -1,170 +0,0 @@
|
||||
;; lib/acl/tests/direct.sx — Phase 1: direct grants + deny-overrides.
|
||||
|
||||
(define acl-dt-pass 0)
|
||||
(define acl-dt-fail 0)
|
||||
(define acl-dt-failures (list))
|
||||
|
||||
(define
|
||||
acl-dt-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! acl-dt-pass (+ acl-dt-pass 1))
|
||||
(do
|
||||
(set! acl-dt-fail (+ acl-dt-fail 1))
|
||||
(append!
|
||||
acl-dt-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
;; A small fixture used by most cases: alice can read page1, is denied edit on
|
||||
;; page1, and a service may federate peer1.
|
||||
(define
|
||||
acl-dt-fixture
|
||||
(fn
|
||||
()
|
||||
(acl-build-db
|
||||
(list
|
||||
(acl-actor (quote alice) (quote user))
|
||||
(acl-actor (quote svc1) (quote service))
|
||||
(acl-resource-fact (quote page1) (quote page))
|
||||
(acl-resource-fact (quote peer1) (quote peer))
|
||||
(acl-grant (quote alice) (quote read) (quote page1))
|
||||
(acl-grant (quote alice) (quote edit) (quote page1))
|
||||
(acl-deny (quote alice) (quote edit) (quote page1))
|
||||
(acl-grant (quote svc1) (quote federate) (quote peer1))))))
|
||||
|
||||
(define
|
||||
acl-dt-run-all!
|
||||
(fn
|
||||
()
|
||||
(let
|
||||
((db (acl-dt-fixture)))
|
||||
(do
|
||||
(acl-dt-check!
|
||||
"direct grant permits"
|
||||
(acl-permit? db (quote alice) (quote read) (quote page1))
|
||||
true)
|
||||
(acl-dt-check!
|
||||
"service grant permits federate"
|
||||
(acl-permit? db (quote svc1) (quote federate) (quote peer1))
|
||||
true)
|
||||
(acl-dt-check!
|
||||
"missing action denied"
|
||||
(acl-permit? db (quote alice) (quote comment) (quote page1))
|
||||
false)
|
||||
(acl-dt-check!
|
||||
"missing resource denied"
|
||||
(acl-permit? db (quote alice) (quote read) (quote page2))
|
||||
false)
|
||||
(acl-dt-check!
|
||||
"missing subject denied"
|
||||
(acl-permit? db (quote bob) (quote read) (quote page1))
|
||||
false)
|
||||
(acl-dt-check!
|
||||
"wrong subject for service grant denied"
|
||||
(acl-permit? db (quote alice) (quote federate) (quote peer1))
|
||||
false)
|
||||
(acl-dt-check!
|
||||
"grant plus deny -> deny wins"
|
||||
(acl-permit? db (quote alice) (quote edit) (quote page1))
|
||||
false)
|
||||
(acl-dt-check!
|
||||
"deny alone still denies"
|
||||
(acl-permit?
|
||||
(acl-build-db
|
||||
(list (acl-deny (quote alice) (quote read) (quote page1))))
|
||||
(quote alice)
|
||||
(quote read)
|
||||
(quote page1))
|
||||
false)
|
||||
(acl-dt-check!
|
||||
"deny on edit does not block read"
|
||||
(acl-permit? db (quote alice) (quote read) (quote page1))
|
||||
true)
|
||||
(acl-dt-check!
|
||||
"empty db denies"
|
||||
(acl-permit?
|
||||
(acl-build-db (list))
|
||||
(quote alice)
|
||||
(quote read)
|
||||
(quote page1))
|
||||
false)
|
||||
(let
|
||||
((db2 (acl-build-db (list (acl-grant (quote a) (quote read) (quote r)) (acl-grant (quote b) (quote read) (quote r)) (acl-deny (quote b) (quote read) (quote r))))))
|
||||
(do
|
||||
(acl-dt-check!
|
||||
"subject a allowed"
|
||||
(acl-permit? db2 (quote a) (quote read) (quote r))
|
||||
true)
|
||||
(acl-dt-check!
|
||||
"subject b denied by override"
|
||||
(acl-permit? db2 (quote b) (quote read) (quote r))
|
||||
false)))
|
||||
(let
|
||||
((db3 (acl-build-db (list (acl-actor (quote editors) (quote role)) (acl-grant (quote editors) (quote edit) (quote post1))))))
|
||||
(acl-dt-check!
|
||||
"role subject direct grant"
|
||||
(acl-permit? db3 (quote editors) (quote edit) (quote post1))
|
||||
true))
|
||||
(do
|
||||
(acl/load!
|
||||
(list
|
||||
(acl-grant (quote carol) (quote moderate) (quote thread1))))
|
||||
(acl-dt-check!
|
||||
"api permit via current db"
|
||||
(acl/permit? (quote carol) (quote moderate) (quote thread1))
|
||||
true)
|
||||
(acl-dt-check!
|
||||
"api deny via current db"
|
||||
(acl/permit? (quote carol) (quote read) (quote thread1))
|
||||
false))
|
||||
(do
|
||||
(acl/load! (list))
|
||||
(acl-dt-check!
|
||||
"api reload clears prior grants"
|
||||
(acl/permit? (quote carol) (quote moderate) (quote thread1))
|
||||
false))
|
||||
(acl-dt-check!
|
||||
"schema grant arity valid"
|
||||
(acl-fact-valid? (acl-grant (quote x) (quote read) (quote y)))
|
||||
true)
|
||||
(acl-dt-check!
|
||||
"schema bad arity invalid"
|
||||
(acl-fact-valid? (list (quote grant) (quote x)))
|
||||
false)
|
||||
(acl-dt-check!
|
||||
"schema unknown predicate invalid"
|
||||
(acl-fact-valid? (list (quote frobnicate) (quote x)))
|
||||
false)
|
||||
(acl-dt-check!
|
||||
"schema subject kind known"
|
||||
(acl-subject-kind? (quote service))
|
||||
true)
|
||||
(acl-dt-check!
|
||||
"schema resource kind unknown"
|
||||
(acl-resource-kind? (quote galaxy))
|
||||
false)
|
||||
(acl-dt-check!
|
||||
"schema known action"
|
||||
(acl-known-action? (quote moderate))
|
||||
true)
|
||||
(acl-dt-check!
|
||||
"grant constructor shape"
|
||||
(acl-grant (quote u) (quote read) (quote p))
|
||||
(list (quote grant) (quote u) (quote read) (quote p)))
|
||||
(acl-dt-check!
|
||||
"actor constructor shape"
|
||||
(acl-actor (quote u) (quote user))
|
||||
(list (quote actor) (quote u) (quote user)))))))
|
||||
|
||||
(define
|
||||
acl-direct-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! acl-dt-pass 0)
|
||||
(set! acl-dt-fail 0)
|
||||
(set! acl-dt-failures (list))
|
||||
(acl-dt-run-all!)
|
||||
{:failures acl-dt-failures :total (+ acl-dt-pass acl-dt-fail) :passed acl-dt-pass :failed acl-dt-fail})))
|
||||
@@ -1,316 +0,0 @@
|
||||
;; lib/acl/tests/explain.sx — Phase 3: proof correctness + audit completeness.
|
||||
|
||||
(define acl-et-pass 0)
|
||||
(define acl-et-fail 0)
|
||||
(define acl-et-failures (list))
|
||||
|
||||
;; Name-based deep equality. The host `=` compares symbols by interned
|
||||
;; identity, which is unstable across substitution/saturation; comparing by
|
||||
;; name (as the datalog suite does) makes structural assertions deterministic.
|
||||
(define
|
||||
acl-et-eq?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (acl-et-eq-l? a b 0)))
|
||||
((and (dict? a) (dict? b))
|
||||
(let
|
||||
((ka (keys a)) (kb (keys b)))
|
||||
(and (= (len ka) (len kb)) (acl-et-eq-d? a b ka 0))))
|
||||
((and (symbol? a) (symbol? b))
|
||||
(= (symbol->string a) (symbol->string b)))
|
||||
(else (= a b)))))
|
||||
|
||||
(define
|
||||
acl-et-eq-l?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (acl-et-eq? (nth a i) (nth b i))) false)
|
||||
(else (acl-et-eq-l? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
acl-et-eq-d?
|
||||
(fn
|
||||
(a b ka i)
|
||||
(cond
|
||||
((>= i (len ka)) true)
|
||||
((let ((k (nth ka i))) (not (acl-et-eq? (get a k) (get b k))))
|
||||
false)
|
||||
(else (acl-et-eq-d? a b ka (+ i 1))))))
|
||||
|
||||
(define
|
||||
acl-et-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(acl-et-eq? got expected)
|
||||
(set! acl-et-pass (+ acl-et-pass 1))
|
||||
(do
|
||||
(set! acl-et-fail (+ acl-et-fail 1))
|
||||
(append!
|
||||
acl-et-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
;; --- proof-tree walkers ---
|
||||
|
||||
;; True if EDB fact `target` appears as a base leaf anywhere in the proof.
|
||||
(define
|
||||
acl-et-has-leaf?
|
||||
(fn
|
||||
(node target)
|
||||
(cond
|
||||
((= node nil) false)
|
||||
((and (dict? node) (has-key? node :via))
|
||||
(acl-et-eq? (get node :fact) target))
|
||||
((and (dict? node) (has-key? node :body))
|
||||
(acl-et-any-leaf? (get node :body) target))
|
||||
(else false))))
|
||||
|
||||
(define
|
||||
acl-et-any-leaf?
|
||||
(fn
|
||||
(nodes target)
|
||||
(cond
|
||||
((= (len nodes) 0) false)
|
||||
((acl-et-has-leaf? (first nodes) target) true)
|
||||
(else (acl-et-any-leaf? (rest nodes) target)))))
|
||||
|
||||
;; True if the proof records a verified negation (deny did not fire).
|
||||
(define
|
||||
acl-et-has-negok?
|
||||
(fn
|
||||
(node)
|
||||
(cond
|
||||
((= node nil) false)
|
||||
((and (dict? node) (has-key? node :neg-ok)) true)
|
||||
((and (dict? node) (has-key? node :body))
|
||||
(acl-et-any-negok? (get node :body)))
|
||||
(else false))))
|
||||
|
||||
(define
|
||||
acl-et-any-negok?
|
||||
(fn
|
||||
(nodes)
|
||||
(cond
|
||||
((= (len nodes) 0) false)
|
||||
((acl-et-has-negok? (first nodes)) true)
|
||||
(else (acl-et-any-negok? (rest nodes))))))
|
||||
|
||||
(define
|
||||
acl-et-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(let
|
||||
((db (acl-build-db (list (acl-grant (quote u) (quote read) (quote p))))))
|
||||
(let
|
||||
((e (acl-explain db (quote u) (quote read) (quote p))))
|
||||
(do
|
||||
(acl-et-check! "direct: allowed?" (get e :allowed?) true)
|
||||
(acl-et-check!
|
||||
"direct: proof root fact"
|
||||
(get (get e :proof) :fact)
|
||||
(list (quote permit) (quote u) (quote read) (quote p)))
|
||||
(acl-et-check!
|
||||
"direct: grant leaf present"
|
||||
(acl-et-has-leaf?
|
||||
(get e :proof)
|
||||
(list (quote grant) (quote u) (quote read) (quote p)))
|
||||
true)
|
||||
(acl-et-check!
|
||||
"direct: negation verified"
|
||||
(acl-et-has-negok? (get e :proof))
|
||||
true)
|
||||
(acl-et-check!
|
||||
"direct: reason nil when allowed"
|
||||
(get e :reason)
|
||||
nil))))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-member-of (quote team) (quote org)) (acl-grant (quote org) (quote read) (quote doc))))))
|
||||
(let
|
||||
((e (acl-explain db (quote alice) (quote read) (quote doc))))
|
||||
(do
|
||||
(acl-et-check! "group: allowed?" (get e :allowed?) true)
|
||||
(acl-et-check!
|
||||
"group: member_of alice leaf"
|
||||
(acl-et-has-leaf?
|
||||
(get e :proof)
|
||||
(list (quote member_of) (quote alice) (quote team)))
|
||||
true)
|
||||
(acl-et-check!
|
||||
"group: member_of team leaf"
|
||||
(acl-et-has-leaf?
|
||||
(get e :proof)
|
||||
(list (quote member_of) (quote team) (quote org)))
|
||||
true)
|
||||
(acl-et-check!
|
||||
"group: grant org leaf at base"
|
||||
(acl-et-has-leaf?
|
||||
(get e :proof)
|
||||
(list (quote grant) (quote org) (quote read) (quote doc)))
|
||||
true))))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-child-of (quote sec) (quote book)) (acl-grant (quote u) (quote read) (quote book))))))
|
||||
(let
|
||||
((e (acl-explain db (quote u) (quote read) (quote sec))))
|
||||
(do
|
||||
(acl-et-check! "resource: allowed?" (get e :allowed?) true)
|
||||
(acl-et-check!
|
||||
"resource: child_of leaf"
|
||||
(acl-et-has-leaf?
|
||||
(get e :proof)
|
||||
(list (quote child_of) (quote sec) (quote book)))
|
||||
true)
|
||||
(acl-et-check!
|
||||
"resource: grant on parent leaf"
|
||||
(acl-et-has-leaf?
|
||||
(get e :proof)
|
||||
(list (quote grant) (quote u) (quote read) (quote book)))
|
||||
true))))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-role-grant (quote editor) (quote edit) (quote page1))))))
|
||||
(let
|
||||
((e (acl-explain db (quote bob) (quote edit) (quote page1))))
|
||||
(do
|
||||
(acl-et-check! "role: allowed?" (get e :allowed?) true)
|
||||
(acl-et-check!
|
||||
"role: member_of leaf"
|
||||
(acl-et-has-leaf?
|
||||
(get e :proof)
|
||||
(list (quote member_of) (quote bob) (quote editor)))
|
||||
true)
|
||||
(acl-et-check!
|
||||
"role: role_grant leaf"
|
||||
(acl-et-has-leaf?
|
||||
(get e :proof)
|
||||
(list
|
||||
(quote role_grant)
|
||||
(quote editor)
|
||||
(quote edit)
|
||||
(quote page1)))
|
||||
true))))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-grant (quote u) (quote edit) (quote p)) (acl-deny (quote u) (quote edit) (quote p))))))
|
||||
(let
|
||||
((e (acl-explain db (quote u) (quote edit) (quote p))))
|
||||
(do
|
||||
(acl-et-check! "deny: not allowed" (get e :allowed?) false)
|
||||
(acl-et-check! "deny: no proof" (get e :proof) nil)
|
||||
(acl-et-check!
|
||||
"deny: reason root is eff_deny"
|
||||
(get (get e :reason) :fact)
|
||||
(list (quote eff_deny) (quote u) (quote edit) (quote p)))
|
||||
(acl-et-check!
|
||||
"deny: reason has deny leaf"
|
||||
(acl-et-has-leaf?
|
||||
(get e :reason)
|
||||
(list (quote deny) (quote u) (quote edit) (quote p)))
|
||||
true))))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote alice) (quote read) (quote doc)) (acl-deny (quote team) (quote read) (quote doc))))))
|
||||
(let
|
||||
((e (acl-explain db (quote alice) (quote read) (quote doc))))
|
||||
(do
|
||||
(acl-et-check!
|
||||
"inherited deny: not allowed"
|
||||
(get e :allowed?)
|
||||
false)
|
||||
(acl-et-check!
|
||||
"inherited deny: reason has member_of leaf"
|
||||
(acl-et-has-leaf?
|
||||
(get e :reason)
|
||||
(list (quote member_of) (quote alice) (quote team)))
|
||||
true)
|
||||
(acl-et-check!
|
||||
"inherited deny: reason has group deny leaf"
|
||||
(acl-et-has-leaf?
|
||||
(get e :reason)
|
||||
(list (quote deny) (quote team) (quote read) (quote doc)))
|
||||
true))))
|
||||
(let
|
||||
((db (acl-build-db (list))))
|
||||
(let
|
||||
((e (acl-explain db (quote u) (quote read) (quote p))))
|
||||
(do
|
||||
(acl-et-check! "no grant: not allowed" (get e :allowed?) false)
|
||||
(acl-et-check! "no grant: proof nil" (get e :proof) nil)
|
||||
(acl-et-check! "no grant: reason nil" (get e :reason) nil))))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-grant (quote u) (quote read) (quote p)) (acl-deny (quote u) (quote edit) (quote p))))))
|
||||
(do
|
||||
(acl-audit-clear!)
|
||||
(acl-et-check! "audit: starts empty" (acl-audit-count) 0)
|
||||
(acl-et-check!
|
||||
"audit decide allowed returns true"
|
||||
(acl-audit-decide! db (quote u) (quote read) (quote p))
|
||||
true)
|
||||
(acl-et-check!
|
||||
"audit decide denied returns false"
|
||||
(acl-audit-decide! db (quote u) (quote edit) (quote p))
|
||||
false)
|
||||
(acl-audit-decide! db (quote u) (quote comment) (quote p))
|
||||
(acl-et-check!
|
||||
"audit: count after three decisions"
|
||||
(acl-audit-count)
|
||||
3)
|
||||
(acl-et-check!
|
||||
"audit: tail size respects n"
|
||||
(len (acl-audit-tail 2))
|
||||
2)
|
||||
(acl-et-check!
|
||||
"audit: tail returns most recent"
|
||||
(get (first (acl-audit-tail 1)) :act)
|
||||
(quote comment))
|
||||
(acl-et-check!
|
||||
"audit: first record seq is 0"
|
||||
(get (first (acl-audit-tail 3)) :seq)
|
||||
0)
|
||||
(acl-et-check!
|
||||
"audit: allowed flag recorded"
|
||||
(get (first (acl-audit-tail 3)) :allowed?)
|
||||
true)
|
||||
(acl-et-check!
|
||||
"audit: serialize line count"
|
||||
(len (acl-et-lines (acl-audit-serialize)))
|
||||
3)
|
||||
(acl-audit-clear!)
|
||||
(acl-et-check!
|
||||
"audit: clear resets count"
|
||||
(acl-audit-count)
|
||||
0))))))
|
||||
|
||||
;; count newline-terminated lines in a serialized log
|
||||
(define acl-et-lines (fn (s) (acl-et-count-nl s 0 0)))
|
||||
(define
|
||||
acl-et-count-nl
|
||||
(fn
|
||||
(s i n)
|
||||
(if
|
||||
(>= i (len s))
|
||||
(if (= n 0) (list) (acl-et-rangelist n))
|
||||
(acl-et-count-nl
|
||||
s
|
||||
(+ i 1)
|
||||
(if (= (slice s i (+ i 1)) "\n") (+ n 1) n)))))
|
||||
(define
|
||||
acl-et-rangelist
|
||||
(fn
|
||||
(n)
|
||||
(if
|
||||
(<= n 0)
|
||||
(list)
|
||||
(cons n (acl-et-rangelist (- n 1))))))
|
||||
|
||||
(define
|
||||
acl-explain-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! acl-et-pass 0)
|
||||
(set! acl-et-fail 0)
|
||||
(set! acl-et-failures (list))
|
||||
(acl-et-run-all!)
|
||||
{:failures acl-et-failures :total (+ acl-et-pass acl-et-fail) :passed acl-et-pass :failed acl-et-fail})))
|
||||
@@ -1,273 +0,0 @@
|
||||
;; lib/acl/tests/fed.sx — Phase 4: federation (peer trust, delegation,
|
||||
;; cross-instance chains, revocation). fed-sx transport is mocked as a dict.
|
||||
|
||||
(define acl-ft-pass 0)
|
||||
(define acl-ft-fail 0)
|
||||
(define acl-ft-failures (list))
|
||||
|
||||
;; Name-based deep equality (host `=` compares symbols by unstable interned
|
||||
;; identity; see lib/acl/tests/explain.sx).
|
||||
(define
|
||||
acl-ft-eq?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (acl-ft-eq-l? a b 0)))
|
||||
((and (symbol? a) (symbol? b))
|
||||
(= (symbol->string a) (symbol->string b)))
|
||||
(else (= a b)))))
|
||||
(define
|
||||
acl-ft-eq-l?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (acl-ft-eq? (nth a i) (nth b i))) false)
|
||||
(else (acl-ft-eq-l? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
acl-ft-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(acl-ft-eq? got expected)
|
||||
(set! acl-ft-pass (+ acl-ft-pass 1))
|
||||
(do
|
||||
(set! acl-ft-fail (+ acl-ft-fail 1))
|
||||
(append!
|
||||
acl-ft-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
;; proof leaf walker (federated proofs reconstruct through the engine rule).
|
||||
(define
|
||||
acl-ft-has-leaf?
|
||||
(fn
|
||||
(node target)
|
||||
(cond
|
||||
((= node nil) false)
|
||||
((and (dict? node) (has-key? node :via))
|
||||
(acl-ft-eq? (get node :fact) target))
|
||||
((and (dict? node) (has-key? node :body))
|
||||
(acl-ft-any-leaf? (get node :body) target))
|
||||
(else false))))
|
||||
(define
|
||||
acl-ft-any-leaf?
|
||||
(fn
|
||||
(nodes target)
|
||||
(cond
|
||||
((= (len nodes) 0) false)
|
||||
((acl-ft-has-leaf? (first nodes) target) true)
|
||||
(else (acl-ft-any-leaf? (rest nodes) target)))))
|
||||
|
||||
(define acl-ft-p? (fn (db s a r) (acl-permit? db s a r)))
|
||||
|
||||
;; A standard federation fixture: local trusts peer alpha at "readonly", which
|
||||
;; covers read+comment. alpha delegates several capabilities to alice.
|
||||
(define
|
||||
acl-ft-fixture
|
||||
(fn
|
||||
()
|
||||
(acl-build-db
|
||||
(list
|
||||
(acl-trust (quote alpha) (quote readonly))
|
||||
(acl-level-covers (quote readonly) (quote read))
|
||||
(acl-level-covers (quote readonly) (quote comment))
|
||||
(acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))
|
||||
(acl-delegate (quote alpha) (quote alice) (quote edit) (quote doc))))))
|
||||
|
||||
(define
|
||||
acl-ft-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(let
|
||||
((db (acl-ft-fixture)))
|
||||
(do
|
||||
(acl-ft-check!
|
||||
"trusted delegate, level covers action -> permit"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"trusted delegate, level does NOT cover action -> deny"
|
||||
(acl-ft-p? db (quote alice) (quote edit) (quote doc))
|
||||
false)
|
||||
(acl-ft-check!
|
||||
"delegated but action class uncovered (comment has no delegate)"
|
||||
(acl-ft-p? db (quote alice) (quote comment) (quote doc))
|
||||
false)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-level-covers (quote readonly) (quote read)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
|
||||
(acl-ft-check!
|
||||
"untrusted peer delegate -> deny"
|
||||
(acl-ft-p? db (quote bob) (quote read) (quote doc))
|
||||
false))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote readonly)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
|
||||
(acl-ft-check!
|
||||
"trust but no level_covers -> deny"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
false))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
|
||||
(do
|
||||
(acl-ft-check!
|
||||
"trust is per-peer: alpha's delegate applies"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"trust not transitive: beta's delegate does not apply"
|
||||
(acl-ft-p? db (quote bob) (quote read) (quote doc))
|
||||
false)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc))))))
|
||||
(acl-ft-check!
|
||||
"local deny overrides federated grant"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
false))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-member-of (quote alice) (quote team)) (acl-delegate (quote alpha) (quote team) (quote read) (quote doc))))))
|
||||
(acl-ft-check!
|
||||
"federated grant to group reaches member"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
true))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-child-of (quote sec) (quote book)) (acl-delegate (quote alpha) (quote u) (quote read) (quote book))))))
|
||||
(acl-ft-check!
|
||||
"federated grant on parent resource reaches child"
|
||||
(acl-ft-p? db (quote u) (quote read) (quote sec))
|
||||
true))
|
||||
(let
|
||||
((transport {:gamma (list (acl-delegate (quote gamma) (quote carol) (quote read) (quote post))) :alpha (list (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)))}))
|
||||
(do
|
||||
(acl-ft-check!
|
||||
"fetch known peer returns its delegates"
|
||||
(len (acl-fed-fetch transport (quote alpha)))
|
||||
1)
|
||||
(acl-ft-check!
|
||||
"fetch unknown peer returns empty"
|
||||
(len (acl-fed-fetch transport (quote delta)))
|
||||
0)
|
||||
(acl-ft-check!
|
||||
"collect across peers"
|
||||
(len
|
||||
(acl-fed-collect transport (list (quote alpha) (quote gamma))))
|
||||
2)
|
||||
(let
|
||||
((db (acl-fed-build-db (list (acl-trust (quote alpha) (quote readonly)) (acl-trust (quote gamma) (quote readonly)) (acl-level-covers (quote readonly) (quote read))) transport (list (quote alpha) (quote gamma)))))
|
||||
(do
|
||||
(acl-ft-check!
|
||||
"fed-build-db: alpha delegate permits"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"fed-build-db: gamma delegate permits"
|
||||
(acl-ft-p? db (quote carol) (quote read) (quote post))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"fed-build-db: untrusted action still denied"
|
||||
(acl-ft-p? db (quote alice) (quote edit) (quote doc))
|
||||
false)))))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
|
||||
(do
|
||||
(acl-ft-check!
|
||||
"before revoke: permitted"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
true)
|
||||
(acl-revoke!
|
||||
db
|
||||
(acl-delegate
|
||||
(quote alpha)
|
||||
(quote alice)
|
||||
(quote read)
|
||||
(quote doc)))
|
||||
(acl-ft-check!
|
||||
"after delegate revoked: denied"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
false)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
|
||||
(do
|
||||
(acl-ft-check!
|
||||
"before trust revoke: permitted"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
true)
|
||||
(acl-revoke! db (acl-trust (quote alpha) (quote full)))
|
||||
(acl-ft-check!
|
||||
"after trust revoked: denied"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
false)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
|
||||
(do
|
||||
(acl-ft-check!
|
||||
"delegate without trust: denied"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
false)
|
||||
(acl-fed-assert! db (acl-trust (quote alpha) (quote full)))
|
||||
(acl-ft-check!
|
||||
"trust ingested then re-checked: permitted"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
true)))
|
||||
(let
|
||||
((db (acl-ft-fixture)))
|
||||
(let
|
||||
((e (acl-explain db (quote alice) (quote read) (quote doc))))
|
||||
(do
|
||||
(acl-ft-check! "federated proof allowed?" (get e :allowed?) true)
|
||||
(acl-ft-check!
|
||||
"federated proof has delegate leaf"
|
||||
(acl-ft-has-leaf?
|
||||
(get e :proof)
|
||||
(list
|
||||
(quote delegate)
|
||||
(quote alpha)
|
||||
(quote alice)
|
||||
(quote read)
|
||||
(quote doc)))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"federated proof has trust leaf"
|
||||
(acl-ft-has-leaf?
|
||||
(get e :proof)
|
||||
(list (quote trust) (quote alpha) (quote readonly)))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"federated proof has level_covers leaf"
|
||||
(acl-ft-has-leaf?
|
||||
(get e :proof)
|
||||
(list (quote level_covers) (quote readonly) (quote read)))
|
||||
true))))
|
||||
(acl-ft-check!
|
||||
"schema delegate arity valid"
|
||||
(acl-fact-valid?
|
||||
(acl-delegate (quote p) (quote s) (quote a) (quote r)))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"schema trust arity valid"
|
||||
(acl-fact-valid? (acl-trust (quote p) (quote l)))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"schema peer arity valid"
|
||||
(acl-fact-valid? (acl-peer (quote p) (quote peer)))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"schema level_covers arity valid"
|
||||
(acl-fact-valid? (acl-level-covers (quote l) (quote read)))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"schema delegate bad arity invalid"
|
||||
(acl-fact-valid? (list (quote delegate) (quote p) (quote s)))
|
||||
false))))
|
||||
|
||||
(define
|
||||
acl-fed-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! acl-ft-pass 0)
|
||||
(set! acl-ft-fail 0)
|
||||
(set! acl-ft-failures (list))
|
||||
(acl-ft-run-all!)
|
||||
{:failures acl-ft-failures :total (+ acl-ft-pass acl-ft-fail) :passed acl-ft-pass :failed acl-ft-fail})))
|
||||
@@ -1,228 +0,0 @@
|
||||
;; lib/acl/tests/harden.sx — adversarial / cross-phase hardening.
|
||||
;;
|
||||
;; Diamond hierarchies, conflict resolution where deny must win through every
|
||||
;; path, chain inheritance, cycle termination, multi-peer delegation, fact
|
||||
;; validation, and audit save/restore.
|
||||
;;
|
||||
;; PROVER-FREE BY DESIGN: this suite calls only acl-permit? (which runs in
|
||||
;; compiled Datalog, safe at any depth) plus pure data ops — never acl-explain /
|
||||
;; acl-prove-d. The SX-side proof reconstructor recurses, and once the kernel
|
||||
;; JIT-compiles it (after the explain/fed suites warm the process) it loops on
|
||||
;; chains deeper than ~3 (substrate JIT bug — see plan Blockers). Proof
|
||||
;; reconstruction is covered by tests/explain.sx (and federated proofs by
|
||||
;; tests/fed.sx), both of which stay under the warm-process depth threshold.
|
||||
|
||||
(define acl-hd-pass 0)
|
||||
(define acl-hd-fail 0)
|
||||
(define acl-hd-failures (list))
|
||||
|
||||
(define
|
||||
acl-hd-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! acl-hd-pass (+ acl-hd-pass 1))
|
||||
(do
|
||||
(set! acl-hd-fail (+ acl-hd-fail 1))
|
||||
(append!
|
||||
acl-hd-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define acl-hd-p? (fn (db s a r) (acl-permit? db s a r)))
|
||||
|
||||
(define
|
||||
acl-hd-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(let
|
||||
((grant-deny (acl-build-db (list (acl-child-of (quote r) (quote p1)) (acl-child-of (quote r) (quote p2)) (acl-grant (quote u) (quote read) (quote p1)) (acl-deny (quote u) (quote read) (quote p2)))))
|
||||
(both-grant
|
||||
(acl-build-db
|
||||
(list
|
||||
(acl-child-of (quote r) (quote p1))
|
||||
(acl-child-of (quote r) (quote p2))
|
||||
(acl-grant (quote u) (quote read) (quote p1))
|
||||
(acl-grant (quote u) (quote read) (quote p2))))))
|
||||
(do
|
||||
(acl-hd-check!
|
||||
"diamond resource: grant+deny parents -> deny wins"
|
||||
(acl-hd-p? grant-deny (quote u) (quote read) (quote r))
|
||||
false)
|
||||
(acl-hd-check!
|
||||
"diamond resource: both grant -> permit"
|
||||
(acl-hd-p? both-grant (quote u) (quote read) (quote r))
|
||||
true)
|
||||
(acl-hd-check!
|
||||
"diamond resource: deny does not leak to other parent"
|
||||
(acl-hd-p? grant-deny (quote u) (quote read) (quote p1))
|
||||
true)))
|
||||
(let
|
||||
((grant-deny (acl-build-db (list (acl-member-of (quote alice) (quote g1)) (acl-member-of (quote alice) (quote g2)) (acl-grant (quote g1) (quote read) (quote doc)) (acl-deny (quote g2) (quote read) (quote doc)))))
|
||||
(both-grant
|
||||
(acl-build-db
|
||||
(list
|
||||
(acl-member-of (quote alice) (quote g1))
|
||||
(acl-member-of (quote alice) (quote g2))
|
||||
(acl-grant (quote g1) (quote read) (quote doc))
|
||||
(acl-grant (quote g2) (quote read) (quote doc))))))
|
||||
(do
|
||||
(acl-hd-check!
|
||||
"diamond group: grant+deny groups -> deny wins"
|
||||
(acl-hd-p? grant-deny (quote alice) (quote read) (quote doc))
|
||||
false)
|
||||
(acl-hd-check!
|
||||
"diamond group: both grant -> permit"
|
||||
(acl-hd-p? both-grant (quote alice) (quote read) (quote doc))
|
||||
true)))
|
||||
(let
|
||||
((chain (acl-build-db (list (acl-member-of (quote a0) (quote a1)) (acl-member-of (quote a1) (quote a2)) (acl-member-of (quote a2) (quote a3)) (acl-member-of (quote a3) (quote a4)) (acl-grant (quote a4) (quote read) (quote res)))))
|
||||
(chain-deny
|
||||
(acl-build-db
|
||||
(list
|
||||
(acl-member-of (quote a0) (quote a1))
|
||||
(acl-member-of (quote a1) (quote a2))
|
||||
(acl-member-of (quote a2) (quote a3))
|
||||
(acl-member-of (quote a3) (quote a4))
|
||||
(acl-grant (quote a4) (quote read) (quote res))
|
||||
(acl-deny (quote a0) (quote read) (quote res))))))
|
||||
(do
|
||||
(acl-hd-check!
|
||||
"chain: top-group grant reaches leaf member"
|
||||
(acl-hd-p? chain (quote a0) (quote read) (quote res))
|
||||
true)
|
||||
(acl-hd-check!
|
||||
"chain: intermediate also covered"
|
||||
(acl-hd-p? chain (quote a2) (quote read) (quote res))
|
||||
true)
|
||||
(acl-hd-check!
|
||||
"chain: leaf-member deny overrides top grant"
|
||||
(acl-hd-p? chain-deny (quote a0) (quote read) (quote res))
|
||||
false)
|
||||
(acl-hd-check!
|
||||
"chain: deny on leaf does not block sibling level"
|
||||
(acl-hd-p? chain-deny (quote a1) (quote read) (quote res))
|
||||
true)))
|
||||
(let
|
||||
((self-member (acl-build-db (list (acl-member-of (quote a) (quote a)) (acl-grant (quote a) (quote read) (quote r)))))
|
||||
(self-child
|
||||
(acl-build-db
|
||||
(list
|
||||
(acl-child-of (quote r) (quote r))
|
||||
(acl-grant (quote u) (quote read) (quote r)))))
|
||||
(two-cycle
|
||||
(acl-build-db
|
||||
(list
|
||||
(acl-member-of (quote x) (quote y))
|
||||
(acl-member-of (quote y) (quote x))
|
||||
(acl-grant (quote y) (quote read) (quote r))))))
|
||||
(do
|
||||
(acl-hd-check!
|
||||
"self-membership cycle terminates and grants"
|
||||
(acl-hd-p? self-member (quote a) (quote read) (quote r))
|
||||
true)
|
||||
(acl-hd-check!
|
||||
"self-child cycle terminates and grants"
|
||||
(acl-hd-p? self-child (quote u) (quote read) (quote r))
|
||||
true)
|
||||
(acl-hd-check!
|
||||
"two-node membership cycle terminates"
|
||||
(acl-hd-p? two-cycle (quote x) (quote read) (quote r))
|
||||
true)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-member-of (quote alice) (quote team)) (acl-delegate (quote alpha) (quote team) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc))))))
|
||||
(acl-hd-check!
|
||||
"federated group grant, local member deny -> deny wins"
|
||||
(acl-hd-p? db (quote alice) (quote read) (quote doc))
|
||||
false))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote bob) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
|
||||
(acl-hd-check!
|
||||
"two peers delegate, one trusted -> permit"
|
||||
(acl-hd-p? db (quote bob) (quote read) (quote doc))
|
||||
true))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-trust (quote beta) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote bob) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
|
||||
(acl-hd-check!
|
||||
"two peers both trusted -> permit"
|
||||
(acl-hd-p? db (quote bob) (quote read) (quote doc))
|
||||
true))
|
||||
(let
|
||||
((empty (acl-build-db (list))))
|
||||
(acl-hd-check!
|
||||
"empty db: nothing permitted"
|
||||
(acl-hd-p? empty (quote u) (quote read) (quote r))
|
||||
false))
|
||||
(do
|
||||
(acl-hd-check!
|
||||
"validate: clean set has no bad facts"
|
||||
(len
|
||||
(acl-validate-facts
|
||||
(list
|
||||
(acl-grant (quote u) (quote read) (quote p))
|
||||
(acl-member-of (quote u) (quote g))
|
||||
(acl-delegate (quote pe) (quote u) (quote read) (quote p)))))
|
||||
0)
|
||||
(acl-hd-check!
|
||||
"validate: facts-valid? true on clean set"
|
||||
(acl-facts-valid?
|
||||
(list (acl-grant (quote u) (quote read) (quote p))))
|
||||
true)
|
||||
(acl-hd-check!
|
||||
"validate: surfaces wrong-arity and unknown predicate"
|
||||
(len
|
||||
(acl-validate-facts
|
||||
(list
|
||||
(acl-grant (quote u) (quote read) (quote p))
|
||||
(list (quote grant) (quote u))
|
||||
(list (quote bogus) (quote x) (quote y)))))
|
||||
2)
|
||||
(acl-hd-check!
|
||||
"validate: empty set is valid"
|
||||
(acl-facts-valid? (list))
|
||||
true))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-grant (quote u) (quote read) (quote p)) (acl-deny (quote u) (quote edit) (quote p))))))
|
||||
(do
|
||||
(acl-audit-clear!)
|
||||
(acl-audit-decide! db (quote u) (quote read) (quote p))
|
||||
(acl-audit-decide! db (quote u) (quote edit) (quote p))
|
||||
(let
|
||||
((snap (acl-audit-snapshot)))
|
||||
(do
|
||||
(acl-audit-clear!)
|
||||
(acl-hd-check!
|
||||
"audit: cleared count is 0"
|
||||
(acl-audit-count)
|
||||
0)
|
||||
(acl-audit-restore! snap)
|
||||
(acl-hd-check!
|
||||
"audit: restored count"
|
||||
(acl-audit-count)
|
||||
2)
|
||||
(acl-hd-check!
|
||||
"audit: restored last act"
|
||||
(get (first (acl-audit-tail 1)) :act)
|
||||
(quote edit))
|
||||
(acl-audit-decide! db (quote u) (quote comment) (quote p))
|
||||
(acl-hd-check!
|
||||
"audit: seq continues after restore"
|
||||
(get (first (acl-audit-tail 1)) :seq)
|
||||
2)
|
||||
(acl-hd-check!
|
||||
"audit: snapshot is an immutable copy"
|
||||
(len (get snap :entries))
|
||||
2)
|
||||
(acl-audit-clear!))))))))
|
||||
|
||||
(define
|
||||
acl-harden-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! acl-hd-pass 0)
|
||||
(set! acl-hd-fail 0)
|
||||
(set! acl-hd-failures (list))
|
||||
(acl-hd-run-all!)
|
||||
{:failures acl-hd-failures :total (+ acl-hd-pass acl-hd-fail) :passed acl-hd-pass :failed acl-hd-fail})))
|
||||
@@ -1,202 +0,0 @@
|
||||
;; lib/acl/tests/inherit.sx — Phase 2: inheritance (groups, resource trees,
|
||||
;; role expansion) with deny-overrides.
|
||||
|
||||
(define acl-it-pass 0)
|
||||
(define acl-it-fail 0)
|
||||
(define acl-it-failures (list))
|
||||
|
||||
(define
|
||||
acl-it-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! acl-it-pass (+ acl-it-pass 1))
|
||||
(do
|
||||
(set! acl-it-fail (+ acl-it-fail 1))
|
||||
(append!
|
||||
acl-it-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define acl-it-p? (fn (db s a r) (acl-permit? db s a r)))
|
||||
|
||||
(define
|
||||
acl-it-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(let
|
||||
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc))))))
|
||||
(do
|
||||
(acl-it-check!
|
||||
"group grant reaches member"
|
||||
(acl-it-p? db (quote alice) (quote read) (quote doc))
|
||||
true)
|
||||
(acl-it-check!
|
||||
"group grant: non-member excluded"
|
||||
(acl-it-p? db (quote bob) (quote read) (quote doc))
|
||||
false)
|
||||
(acl-it-check!
|
||||
"group grant: wrong action"
|
||||
(acl-it-p? db (quote alice) (quote edit) (quote doc))
|
||||
false)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-member-of (quote team) (quote org)) (acl-member-of (quote org) (quote company)) (acl-grant (quote company) (quote read) (quote doc))))))
|
||||
(do
|
||||
(acl-it-check!
|
||||
"deep nested group grant reaches leaf member"
|
||||
(acl-it-p? db (quote alice) (quote read) (quote doc))
|
||||
true)
|
||||
(acl-it-check!
|
||||
"intermediate group also covered"
|
||||
(acl-it-p? db (quote team) (quote read) (quote doc))
|
||||
true)
|
||||
(acl-it-check!
|
||||
"mid group org covered"
|
||||
(acl-it-p? db (quote org) (quote read) (quote doc))
|
||||
true)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-member-of (quote a) (quote b)) (acl-member-of (quote b) (quote a)) (acl-grant (quote b) (quote read) (quote r))))))
|
||||
(do
|
||||
(acl-it-check!
|
||||
"cyclic membership terminates and grants"
|
||||
(acl-it-p? db (quote a) (quote read) (quote r))
|
||||
true)
|
||||
(acl-it-check!
|
||||
"cyclic membership covers both"
|
||||
(acl-it-p? db (quote b) (quote read) (quote r))
|
||||
true)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-child-of (quote sec) (quote chap)) (acl-child-of (quote chap) (quote book)) (acl-grant (quote u) (quote read) (quote book))))))
|
||||
(do
|
||||
(acl-it-check!
|
||||
"parent grant reaches direct child"
|
||||
(acl-it-p? db (quote u) (quote read) (quote chap))
|
||||
true)
|
||||
(acl-it-check!
|
||||
"parent grant reaches deep descendant"
|
||||
(acl-it-p? db (quote u) (quote read) (quote sec))
|
||||
true)
|
||||
(acl-it-check!
|
||||
"parent grant covers parent itself"
|
||||
(acl-it-p? db (quote u) (quote read) (quote book))
|
||||
true)
|
||||
(acl-it-check!
|
||||
"child grant does not climb to parent"
|
||||
(acl-it-p?
|
||||
(acl-build-db
|
||||
(list
|
||||
(acl-child-of (quote sec) (quote book))
|
||||
(acl-grant (quote u) (quote read) (quote sec))))
|
||||
(quote u)
|
||||
(quote read)
|
||||
(quote book))
|
||||
false)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-child-of (quote post1) (quote board)) (acl-grant (quote team) (quote comment) (quote board))))))
|
||||
(do
|
||||
(acl-it-check!
|
||||
"group + resource: member on child resource"
|
||||
(acl-it-p? db (quote alice) (quote comment) (quote post1))
|
||||
true)
|
||||
(acl-it-check!
|
||||
"group + resource: member on parent resource"
|
||||
(acl-it-p? db (quote alice) (quote comment) (quote board))
|
||||
true)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-role-grant (quote editor) (quote edit) (quote page1)) (acl-role-grant (quote editor) (quote read) (quote page1))))))
|
||||
(do
|
||||
(acl-it-check!
|
||||
"role confers edit to member"
|
||||
(acl-it-p? db (quote bob) (quote edit) (quote page1))
|
||||
true)
|
||||
(acl-it-check!
|
||||
"role confers read to member"
|
||||
(acl-it-p? db (quote bob) (quote read) (quote page1))
|
||||
true)
|
||||
(acl-it-check!
|
||||
"role: capability not in tuple denied"
|
||||
(acl-it-p? db (quote bob) (quote moderate) (quote page1))
|
||||
false)
|
||||
(acl-it-check!
|
||||
"role: non-member excluded"
|
||||
(acl-it-p? db (quote eve) (quote edit) (quote page1))
|
||||
false)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-child-of (quote draft) (quote page1)) (acl-role-grant (quote editor) (quote edit) (quote page1))))))
|
||||
(acl-it-check!
|
||||
"role grant flows to child resource"
|
||||
(acl-it-p? db (quote bob) (quote edit) (quote draft))
|
||||
true))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc))))))
|
||||
(acl-it-check!
|
||||
"explicit deny beats inherited group allow"
|
||||
(acl-it-p? db (quote alice) (quote read) (quote doc))
|
||||
false))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote alice) (quote read) (quote doc)) (acl-deny (quote team) (quote read) (quote doc))))))
|
||||
(do
|
||||
(acl-it-check!
|
||||
"group deny inherits and overrides direct grant"
|
||||
(acl-it-p? db (quote alice) (quote read) (quote doc))
|
||||
false)
|
||||
(acl-it-check!
|
||||
"group deny: another member also blocked"
|
||||
(acl-it-p? db (quote team) (quote read) (quote doc))
|
||||
false)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-child-of (quote sec) (quote book)) (acl-grant (quote u) (quote read) (quote sec)) (acl-deny (quote u) (quote read) (quote book))))))
|
||||
(acl-it-check!
|
||||
"ancestor deny overrides descendant grant"
|
||||
(acl-it-p? db (quote u) (quote read) (quote sec))
|
||||
false))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc)) (acl-grant (quote team) (quote edit) (quote doc)) (acl-deny (quote alice) (quote edit) (quote doc))))))
|
||||
(do
|
||||
(acl-it-check!
|
||||
"deny on edit leaves inherited read intact"
|
||||
(acl-it-p? db (quote alice) (quote read) (quote doc))
|
||||
true)
|
||||
(acl-it-check!
|
||||
"deny on edit blocks edit"
|
||||
(acl-it-p? db (quote alice) (quote edit) (quote doc))
|
||||
false)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-deny (quote team) (quote read) (quote doc))))))
|
||||
(acl-it-check!
|
||||
"inherited deny, no grant: denied"
|
||||
(acl-it-p? db (quote alice) (quote read) (quote doc))
|
||||
false))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-child-of (quote a) (quote root)) (acl-child-of (quote b) (quote root)) (acl-grant (quote u) (quote read) (quote root)) (acl-deny (quote u) (quote read) (quote a))))))
|
||||
(do
|
||||
(acl-it-check!
|
||||
"deny on sibling a blocks a"
|
||||
(acl-it-p? db (quote u) (quote read) (quote a))
|
||||
false)
|
||||
(acl-it-check!
|
||||
"deny on sibling a leaves b permitted"
|
||||
(acl-it-p? db (quote u) (quote read) (quote b))
|
||||
true)
|
||||
(acl-it-check!
|
||||
"root itself still permitted"
|
||||
(acl-it-p? db (quote u) (quote read) (quote root))
|
||||
true)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-grant (quote x) (quote read) (quote y))))))
|
||||
(acl-it-check!
|
||||
"direct grant under inheritance ruleset"
|
||||
(acl-it-p? db (quote x) (quote read) (quote y))
|
||||
true)))))
|
||||
|
||||
(define
|
||||
acl-inherit-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! acl-it-pass 0)
|
||||
(set! acl-it-fail 0)
|
||||
(set! acl-it-failures (list))
|
||||
(acl-it-run-all!)
|
||||
{:failures acl-it-failures :total (+ acl-it-pass acl-it-fail) :passed acl-it-pass :failed acl-it-fail})))
|
||||
@@ -1,63 +0,0 @@
|
||||
# APL conformance config — sourced by lib/guest/conformance.sh.
|
||||
|
||||
LANG_NAME=apl
|
||||
MODE=counters
|
||||
COUNTERS_PASS=apl-test-pass
|
||||
COUNTERS_FAIL=apl-test-fail
|
||||
TIMEOUT_PER_SUITE=300
|
||||
|
||||
PRELOADS=(
|
||||
spec/stdlib.sx
|
||||
lib/r7rs.sx
|
||||
lib/apl/runtime.sx
|
||||
lib/apl/tokenizer.sx
|
||||
lib/apl/parser.sx
|
||||
lib/apl/transpile.sx
|
||||
lib/apl/test-harness.sx
|
||||
)
|
||||
|
||||
SUITES=(
|
||||
"structural:lib/apl/tests/structural.sx"
|
||||
"operators:lib/apl/tests/operators.sx"
|
||||
"dfn:lib/apl/tests/dfn.sx"
|
||||
"tradfn:lib/apl/tests/tradfn.sx"
|
||||
"valence:lib/apl/tests/valence.sx"
|
||||
"programs:lib/apl/tests/programs.sx"
|
||||
"system:lib/apl/tests/system.sx"
|
||||
"idioms:lib/apl/tests/idioms.sx"
|
||||
"eval-ops:lib/apl/tests/eval-ops.sx"
|
||||
"pipeline:lib/apl/tests/pipeline.sx"
|
||||
)
|
||||
|
||||
emit_scoreboard_json() {
|
||||
local n=${#GC_NAMES[@]} i sep
|
||||
printf '{\n'
|
||||
printf ' "suites": {\n'
|
||||
for ((i=0; i<n; i++)); do
|
||||
sep=","; [ $i -eq $((n-1)) ] && sep=""
|
||||
printf ' "%s": {"pass": %d, "fail": %d}%s\n' \
|
||||
"${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_FAIL[$i]}" "$sep"
|
||||
done
|
||||
printf ' },\n'
|
||||
printf ' "total_pass": %d,\n' "$GC_TOTAL_PASS"
|
||||
printf ' "total_fail": %d,\n' "$GC_TOTAL_FAIL"
|
||||
printf ' "total": %d\n' "$GC_TOTAL"
|
||||
printf '}\n'
|
||||
}
|
||||
|
||||
emit_scoreboard_md() {
|
||||
local n=${#GC_NAMES[@]} i
|
||||
printf '# APL Conformance Scoreboard\n\n'
|
||||
printf '_Generated by `lib/apl/conformance.sh`_\n\n'
|
||||
printf '| Suite | Pass | Fail | Total |\n'
|
||||
printf '|-------|-----:|-----:|------:|\n'
|
||||
for ((i=0; i<n; i++)); do
|
||||
printf '| %s | %d | %d | %d |\n' \
|
||||
"${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_FAIL[$i]}" "${GC_TOTAL_S[$i]}"
|
||||
done
|
||||
printf '| **Total** | **%d** | **%d** | **%d** |\n' "$GC_TOTAL_PASS" "$GC_TOTAL_FAIL" "$GC_TOTAL"
|
||||
printf '\n'
|
||||
printf '## Notes\n\n'
|
||||
printf '%s\n' '- Suites use the standard `apl-test name got expected` framework loaded against `lib/apl/runtime.sx` + `lib/apl/transpile.sx`.'
|
||||
printf '%s\n' '- `lib/apl/tests/parse.sx` and `lib/apl/tests/scalar.sx` use their own self-contained frameworks and are excluded from this scoreboard.'
|
||||
}
|
||||
@@ -1,5 +1,116 @@
|
||||
#!/usr/bin/env bash
|
||||
# lib/apl/conformance.sh — APL conformance via the shared guest driver.
|
||||
# Config lives in lib/apl/conformance.conf (MODE=counters). Override the binary
|
||||
# with SX_SERVER=path/to/sx_server.exe bash lib/apl/conformance.sh
|
||||
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"
|
||||
# lib/apl/conformance.sh — run APL test suites, emit scoreboard.json + scoreboard.md.
|
||||
|
||||
set -uo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
SX_SERVER="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
|
||||
|
||||
SUITES=(structural operators dfn tradfn valence programs system idioms eval-ops pipeline)
|
||||
|
||||
OUT_JSON="lib/apl/scoreboard.json"
|
||||
OUT_MD="lib/apl/scoreboard.md"
|
||||
|
||||
run_suite() {
|
||||
local suite=$1
|
||||
local file="lib/apl/tests/${suite}.sx"
|
||||
local TMP
|
||||
TMP=$(mktemp)
|
||||
cat > "$TMP" << EPOCHS
|
||||
(epoch 1)
|
||||
(load "spec/stdlib.sx")
|
||||
(load "lib/r7rs.sx")
|
||||
(load "lib/apl/runtime.sx")
|
||||
(load "lib/apl/tokenizer.sx")
|
||||
(load "lib/apl/parser.sx")
|
||||
(load "lib/apl/transpile.sx")
|
||||
(epoch 2)
|
||||
(eval "(define apl-test-pass 0)")
|
||||
(eval "(define apl-test-fail 0)")
|
||||
(eval "(define apl-test (fn (name got expected) (if (= got expected) (set! apl-test-pass (+ apl-test-pass 1)) (set! apl-test-fail (+ apl-test-fail 1)))))")
|
||||
(epoch 3)
|
||||
(load "${file}")
|
||||
(epoch 4)
|
||||
(eval "(list apl-test-pass apl-test-fail)")
|
||||
EPOCHS
|
||||
|
||||
local OUTPUT
|
||||
OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMP" 2>/dev/null)
|
||||
rm -f "$TMP"
|
||||
|
||||
local LINE
|
||||
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}')
|
||||
if [ -z "$LINE" ]; then
|
||||
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \
|
||||
| sed -E 's/^\(ok 4 //; s/\)$//')
|
||||
fi
|
||||
|
||||
local P F
|
||||
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
|
||||
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
|
||||
P=${P:-0}
|
||||
F=${F:-0}
|
||||
echo "${P} ${F}"
|
||||
}
|
||||
|
||||
declare -A SUITE_PASS
|
||||
declare -A SUITE_FAIL
|
||||
TOTAL_PASS=0
|
||||
TOTAL_FAIL=0
|
||||
|
||||
echo "Running APL conformance suite..." >&2
|
||||
for s in "${SUITES[@]}"; do
|
||||
read -r p f < <(run_suite "$s")
|
||||
SUITE_PASS[$s]=$p
|
||||
SUITE_FAIL[$s]=$f
|
||||
TOTAL_PASS=$((TOTAL_PASS + p))
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + f))
|
||||
printf " %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2
|
||||
done
|
||||
|
||||
# scoreboard.json
|
||||
{
|
||||
printf '{\n'
|
||||
printf ' "suites": {\n'
|
||||
first=1
|
||||
for s in "${SUITES[@]}"; do
|
||||
if [ $first -eq 0 ]; then printf ',\n'; fi
|
||||
printf ' "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}"
|
||||
first=0
|
||||
done
|
||||
printf '\n },\n'
|
||||
printf ' "total_pass": %d,\n' "$TOTAL_PASS"
|
||||
printf ' "total_fail": %d,\n' "$TOTAL_FAIL"
|
||||
printf ' "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))"
|
||||
printf '}\n'
|
||||
} > "$OUT_JSON"
|
||||
|
||||
# scoreboard.md
|
||||
{
|
||||
printf '# APL Conformance Scoreboard\n\n'
|
||||
printf '_Generated by `lib/apl/conformance.sh`_\n\n'
|
||||
printf '| Suite | Pass | Fail | Total |\n'
|
||||
printf '|-------|-----:|-----:|------:|\n'
|
||||
for s in "${SUITES[@]}"; do
|
||||
p=${SUITE_PASS[$s]}
|
||||
f=${SUITE_FAIL[$s]}
|
||||
printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))"
|
||||
done
|
||||
printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
|
||||
printf '\n'
|
||||
printf '## Notes\n\n'
|
||||
printf '%s\n' '- Suites use the standard `apl-test name got expected` framework loaded against `lib/apl/runtime.sx` + `lib/apl/transpile.sx`.'
|
||||
printf '%s\n' '- `lib/apl/tests/parse.sx` and `lib/apl/tests/scalar.sx` use their own self-contained frameworks and are excluded from this scoreboard.'
|
||||
} > "$OUT_MD"
|
||||
|
||||
echo "Wrote $OUT_JSON and $OUT_MD" >&2
|
||||
echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
|
||||
|
||||
[ "$TOTAL_FAIL" -eq 0 ]
|
||||
|
||||
@@ -9,9 +9,9 @@
|
||||
"system": {"pass": 13, "fail": 0},
|
||||
"idioms": {"pass": 64, "fail": 0},
|
||||
"eval-ops": {"pass": 14, "fail": 0},
|
||||
"pipeline": {"pass": 152, "fail": 0}
|
||||
"pipeline": {"pass": 40, "fail": 0}
|
||||
},
|
||||
"total_pass": 562,
|
||||
"total_pass": 450,
|
||||
"total_fail": 0,
|
||||
"total": 562
|
||||
"total": 450
|
||||
}
|
||||
|
||||
@@ -13,8 +13,8 @@ _Generated by `lib/apl/conformance.sh`_
|
||||
| system | 13 | 0 | 13 |
|
||||
| idioms | 64 | 0 | 64 |
|
||||
| eval-ops | 14 | 0 | 14 |
|
||||
| pipeline | 152 | 0 | 152 |
|
||||
| **Total** | **562** | **0** | **562** |
|
||||
| pipeline | 40 | 0 | 40 |
|
||||
| **Total** | **450** | **0** | **450** |
|
||||
|
||||
## Notes
|
||||
|
||||
|
||||
@@ -1,15 +0,0 @@
|
||||
; lib/apl/test-harness.sx — counters + assertion fn for the shared conformance
|
||||
; driver (lib/guest/conformance.sh, MODE=counters). Loaded as a PRELOAD so each
|
||||
; suite starts from a fresh 0/0; suites call (apl-test name got expected).
|
||||
|
||||
(define apl-test-pass 0)
|
||||
(define apl-test-fail 0)
|
||||
|
||||
(define
|
||||
apl-test
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! apl-test-pass (+ apl-test-pass 1))
|
||||
(set! apl-test-fail (+ apl-test-fail 1)))))
|
||||
@@ -1,67 +0,0 @@
|
||||
# Common-Lisp-on-SX conformance config — sourced by lib/guest/conformance.sh.
|
||||
#
|
||||
# CL suites run their tests at *load* time, mutating per-suite global counters
|
||||
# (different variable names per suite), and each suite needs a different
|
||||
# preload chain. Both are expressed via the extended MODE=counters SUITES
|
||||
# format: "name:file:pass-var:fail-var:extra-preload ...".
|
||||
|
||||
LANG_NAME=common-lisp
|
||||
MODE=counters
|
||||
# No global counter defaults — every suite names its own pair below.
|
||||
COUNTERS_PASS=
|
||||
COUNTERS_FAIL=
|
||||
TIMEOUT_PER_SUITE=180
|
||||
|
||||
# Base preloads common to every suite (loaded before each suite's own chain).
|
||||
PRELOADS=(
|
||||
spec/stdlib.sx
|
||||
lib/guest/prefix.sx
|
||||
)
|
||||
|
||||
# name:file:pass-var:fail-var:extra-preloads(space-separated)
|
||||
SUITES=(
|
||||
"read:lib/common-lisp/tests/read.sx:cl-test-pass:cl-test-fail:lib/common-lisp/reader.sx"
|
||||
"lambda:lib/common-lisp/tests/lambda.sx:cl-test-pass:cl-test-fail:lib/common-lisp/reader.sx lib/common-lisp/parser.sx"
|
||||
"eval:lib/common-lisp/tests/eval.sx:cl-test-pass:cl-test-fail:lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx"
|
||||
"conditions:lib/common-lisp/tests/conditions.sx:passed:failed:lib/common-lisp/runtime.sx"
|
||||
"restart-demo:lib/common-lisp/tests/programs/restart-demo.sx:demo-passed:demo-failed:lib/common-lisp/runtime.sx"
|
||||
"parse-recover:lib/common-lisp/tests/programs/parse-recover.sx:parse-passed:parse-failed:lib/common-lisp/runtime.sx"
|
||||
"interactive-debugger:lib/common-lisp/tests/programs/interactive-debugger.sx:debugger-passed:debugger-failed:lib/common-lisp/runtime.sx"
|
||||
"clos:lib/common-lisp/tests/clos.sx:passed:failed:lib/common-lisp/runtime.sx lib/common-lisp/clos.sx"
|
||||
"geometry:lib/common-lisp/tests/programs/geometry.sx:geo-passed:geo-failed:lib/common-lisp/runtime.sx lib/common-lisp/clos.sx"
|
||||
"mop-trace:lib/common-lisp/tests/programs/mop-trace.sx:mop-passed:mop-failed:lib/common-lisp/runtime.sx lib/common-lisp/clos.sx"
|
||||
"macros:lib/common-lisp/tests/macros.sx:macro-passed:macro-failed:lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/loop.sx"
|
||||
"stdlib:lib/common-lisp/tests/stdlib.sx:stdlib-passed:stdlib-failed:lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx"
|
||||
)
|
||||
|
||||
# Preserve the historical scoreboard schema (total_pass/total_fail, suites with
|
||||
# name/pass/fail) so any consumer of lib/common-lisp/scoreboard.json keeps working.
|
||||
emit_scoreboard_json() {
|
||||
local n=${#GC_NAMES[@]} i
|
||||
printf '{\n'
|
||||
printf ' "generated": "%s",\n' "$(date -u +%Y-%m-%dT%H:%M:%SZ)"
|
||||
printf ' "total_pass": %d,\n' "$GC_TOTAL_PASS"
|
||||
printf ' "total_fail": %d,\n' "$GC_TOTAL_FAIL"
|
||||
printf ' "suites": [\n'
|
||||
for ((i=0; i<n; i++)); do
|
||||
[ "$i" -gt 0 ] && printf ',\n'
|
||||
printf ' {"name": "%s", "pass": %d, "fail": %d}' \
|
||||
"${GC_NAMES[$i]}" "${GC_PASS[$i]}" "${GC_FAIL[$i]}"
|
||||
done
|
||||
printf '\n ]\n'
|
||||
printf '}\n'
|
||||
}
|
||||
|
||||
emit_scoreboard_md() {
|
||||
local n=${#GC_NAMES[@]} i p f status
|
||||
printf '# Common Lisp on SX — Scoreboard\n\n'
|
||||
printf '_Generated: %s_\n\n' "$(date -u '+%Y-%m-%d %H:%M UTC')"
|
||||
printf '| Suite | Pass | Fail | Status |\n'
|
||||
printf '|-------|------|------|--------|\n'
|
||||
for ((i=0; i<n; i++)); do
|
||||
p="${GC_PASS[$i]}"; f="${GC_FAIL[$i]}"
|
||||
if [ "$f" = "0" ] && [ "${p:-0}" -gt 0 ] 2>/dev/null; then status="pass"; else status="FAIL"; fi
|
||||
printf '| %s | %s | %s | %s |\n' "${GC_NAMES[$i]}" "$p" "$f" "$status"
|
||||
done
|
||||
printf '\n**Total: %d passed, %d failed**\n' "$GC_TOTAL_PASS" "$GC_TOTAL_FAIL"
|
||||
}
|
||||
@@ -1,3 +1,161 @@
|
||||
#!/usr/bin/env bash
|
||||
# Thin wrapper — see lib/guest/conformance.sh and lib/common-lisp/conformance.conf.
|
||||
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"
|
||||
# lib/common-lisp/conformance.sh — CL-on-SX conformance test runner
|
||||
#
|
||||
# Runs all Common Lisp test suites and writes scoreboard.json + scoreboard.md.
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/common-lisp/conformance.sh
|
||||
# bash lib/common-lisp/conformance.sh -v
|
||||
|
||||
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."
|
||||
exit 1
|
||||
fi
|
||||
|
||||
VERBOSE="${1:-}"
|
||||
TOTAL_PASS=0; TOTAL_FAIL=0
|
||||
SUITE_NAMES=()
|
||||
SUITE_PASS=()
|
||||
SUITE_FAIL=()
|
||||
|
||||
# run_suite NAME "file1 file2 ..." PASS_VAR FAIL_VAR FAILURES_VAR
|
||||
run_suite() {
|
||||
local name="$1" load_files="$2" pass_var="$3" fail_var="$4" failures_var="$5"
|
||||
local TMP; TMP=$(mktemp)
|
||||
{
|
||||
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(load "lib/guest/prefix.sx")\n'
|
||||
local i=2
|
||||
for f in $load_files; do
|
||||
printf '(epoch %d)\n(load "%s")\n' "$i" "$f"
|
||||
i=$((i+1))
|
||||
done
|
||||
printf '(epoch 100)\n(eval "%s")\n' "$pass_var"
|
||||
printf '(epoch 101)\n(eval "%s")\n' "$fail_var"
|
||||
} > "$TMP"
|
||||
local OUT; OUT=$(timeout 30 "$SX_SERVER" < "$TMP" 2>/dev/null)
|
||||
rm -f "$TMP"
|
||||
local P F
|
||||
P=$(echo "$OUT" | grep -A1 "^(ok-len 100 " | tail -1 | tr -d ' ()' || true)
|
||||
F=$(echo "$OUT" | grep -A1 "^(ok-len 101 " | tail -1 | tr -d ' ()' || true)
|
||||
# Also try plain (ok 100 N) format
|
||||
[ -z "$P" ] && P=$(echo "$OUT" | grep "^(ok 100 " | awk '{print $3}' | tr -d ')' || true)
|
||||
[ -z "$F" ] && F=$(echo "$OUT" | grep "^(ok 101 " | awk '{print $3}' | tr -d ')' || true)
|
||||
[ -z "$P" ] && P=0; [ -z "$F" ] && F=0
|
||||
SUITE_NAMES+=("$name")
|
||||
SUITE_PASS+=("$P")
|
||||
SUITE_FAIL+=("$F")
|
||||
TOTAL_PASS=$((TOTAL_PASS + P))
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + F))
|
||||
if [ "$F" = "0" ] && [ "${P:-0}" -gt 0 ] 2>/dev/null; then
|
||||
echo " PASS $name ($P tests)"
|
||||
else
|
||||
echo " FAIL $name ($P passed, $F failed)"
|
||||
fi
|
||||
}
|
||||
|
||||
echo "=== Common Lisp on SX — Conformance Run ==="
|
||||
echo ""
|
||||
|
||||
run_suite "Phase 1: tokenizer/reader" \
|
||||
"lib/common-lisp/reader.sx lib/common-lisp/tests/read.sx" \
|
||||
"cl-test-pass" "cl-test-fail" "cl-test-fails"
|
||||
|
||||
run_suite "Phase 1: parser/lambda-lists" \
|
||||
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/tests/lambda.sx" \
|
||||
"cl-test-pass" "cl-test-fail" "cl-test-fails"
|
||||
|
||||
run_suite "Phase 2: evaluator" \
|
||||
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/tests/eval.sx" \
|
||||
"cl-test-pass" "cl-test-fail" "cl-test-fails"
|
||||
|
||||
run_suite "Phase 3: condition system" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/tests/conditions.sx" \
|
||||
"passed" "failed" "failures"
|
||||
|
||||
run_suite "Phase 3: restart-demo" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/restart-demo.sx" \
|
||||
"demo-passed" "demo-failed" "demo-failures"
|
||||
|
||||
run_suite "Phase 3: parse-recover" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/parse-recover.sx" \
|
||||
"parse-passed" "parse-failed" "parse-failures"
|
||||
|
||||
run_suite "Phase 3: interactive-debugger" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/interactive-debugger.sx" \
|
||||
"debugger-passed" "debugger-failed" "debugger-failures"
|
||||
|
||||
run_suite "Phase 4: CLOS" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/clos.sx" \
|
||||
"passed" "failed" "failures"
|
||||
|
||||
run_suite "Phase 4: geometry" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/geometry.sx" \
|
||||
"geo-passed" "geo-failed" "geo-failures"
|
||||
|
||||
run_suite "Phase 4: mop-trace" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/mop-trace.sx" \
|
||||
"mop-passed" "mop-failed" "mop-failures"
|
||||
|
||||
run_suite "Phase 5: macros+LOOP" \
|
||||
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/loop.sx lib/common-lisp/tests/macros.sx" \
|
||||
"macro-passed" "macro-failed" "macro-failures"
|
||||
|
||||
run_suite "Phase 6: stdlib" \
|
||||
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/tests/stdlib.sx" \
|
||||
"stdlib-passed" "stdlib-failed" "stdlib-failures"
|
||||
|
||||
echo ""
|
||||
echo "=== Total: $TOTAL_PASS passed, $TOTAL_FAIL failed ==="
|
||||
|
||||
# ── write scoreboard.json ─────────────────────────────────────────────────
|
||||
|
||||
SCORE_DIR="lib/common-lisp"
|
||||
JSON="$SCORE_DIR/scoreboard.json"
|
||||
{
|
||||
printf '{\n'
|
||||
printf ' "generated": "%s",\n' "$(date -u +%Y-%m-%dT%H:%M:%SZ)"
|
||||
printf ' "total_pass": %d,\n' "$TOTAL_PASS"
|
||||
printf ' "total_fail": %d,\n' "$TOTAL_FAIL"
|
||||
printf ' "suites": [\n'
|
||||
first=true
|
||||
for i in "${!SUITE_NAMES[@]}"; do
|
||||
if [ "$first" = "true" ]; then first=false; else printf ',\n'; fi
|
||||
printf ' {"name": "%s", "pass": %d, "fail": %d}' \
|
||||
"${SUITE_NAMES[$i]}" "${SUITE_PASS[$i]}" "${SUITE_FAIL[$i]}"
|
||||
done
|
||||
printf '\n ]\n'
|
||||
printf '}\n'
|
||||
} > "$JSON"
|
||||
|
||||
# ── write scoreboard.md ───────────────────────────────────────────────────
|
||||
|
||||
MD="$SCORE_DIR/scoreboard.md"
|
||||
{
|
||||
printf '# Common Lisp on SX — Scoreboard\n\n'
|
||||
printf '_Generated: %s_\n\n' "$(date -u '+%Y-%m-%d %H:%M UTC')"
|
||||
printf '| Suite | Pass | Fail | Status |\n'
|
||||
printf '|-------|------|------|--------|\n'
|
||||
for i in "${!SUITE_NAMES[@]}"; do
|
||||
p="${SUITE_PASS[$i]}" f="${SUITE_FAIL[$i]}"
|
||||
status=""
|
||||
if [ "$f" = "0" ] && [ "${p:-0}" -gt 0 ] 2>/dev/null; then
|
||||
status="pass"
|
||||
else
|
||||
status="FAIL"
|
||||
fi
|
||||
printf '| %s | %s | %s | %s |\n' "${SUITE_NAMES[$i]}" "$p" "$f" "$status"
|
||||
done
|
||||
printf '\n**Total: %d passed, %d failed**\n' "$TOTAL_PASS" "$TOTAL_FAIL"
|
||||
} > "$MD"
|
||||
|
||||
echo ""
|
||||
echo "Scoreboard written to $JSON and $MD"
|
||||
|
||||
[ "$TOTAL_FAIL" -eq 0 ]
|
||||
|
||||
@@ -1,19 +1,19 @@
|
||||
{
|
||||
"generated": "2026-06-07T09:35:38Z",
|
||||
"total_pass": 487,
|
||||
"generated": "2026-05-06T22:55:42Z",
|
||||
"total_pass": 518,
|
||||
"total_fail": 0,
|
||||
"suites": [
|
||||
{"name": "read", "pass": 79, "fail": 0},
|
||||
{"name": "lambda", "pass": 31, "fail": 0},
|
||||
{"name": "eval", "pass": 182, "fail": 0},
|
||||
{"name": "conditions", "pass": 59, "fail": 0},
|
||||
{"name": "restart-demo", "pass": 7, "fail": 0},
|
||||
{"name": "parse-recover", "pass": 6, "fail": 0},
|
||||
{"name": "interactive-debugger", "pass": 7, "fail": 0},
|
||||
{"name": "clos", "pass": 35, "fail": 0},
|
||||
{"name": "geometry", "pass": 0, "fail": 0},
|
||||
{"name": "mop-trace", "pass": 0, "fail": 0},
|
||||
{"name": "macros", "pass": 27, "fail": 0},
|
||||
{"name": "stdlib", "pass": 54, "fail": 0}
|
||||
{"name": "Phase 1: tokenizer/reader", "pass": 79, "fail": 0},
|
||||
{"name": "Phase 1: parser/lambda-lists", "pass": 31, "fail": 0},
|
||||
{"name": "Phase 2: evaluator", "pass": 182, "fail": 0},
|
||||
{"name": "Phase 3: condition system", "pass": 59, "fail": 0},
|
||||
{"name": "Phase 3: restart-demo", "pass": 7, "fail": 0},
|
||||
{"name": "Phase 3: parse-recover", "pass": 6, "fail": 0},
|
||||
{"name": "Phase 3: interactive-debugger", "pass": 7, "fail": 0},
|
||||
{"name": "Phase 4: CLOS", "pass": 41, "fail": 0},
|
||||
{"name": "Phase 4: geometry", "pass": 12, "fail": 0},
|
||||
{"name": "Phase 4: mop-trace", "pass": 13, "fail": 0},
|
||||
{"name": "Phase 5: macros+LOOP", "pass": 27, "fail": 0},
|
||||
{"name": "Phase 6: stdlib", "pass": 54, "fail": 0}
|
||||
]
|
||||
}
|
||||
|
||||
@@ -1,20 +1,20 @@
|
||||
# Common Lisp on SX — Scoreboard
|
||||
|
||||
_Generated: 2026-06-07 09:35 UTC_
|
||||
_Generated: 2026-05-06 22:55 UTC_
|
||||
|
||||
| Suite | Pass | Fail | Status |
|
||||
|-------|------|------|--------|
|
||||
| read | 79 | 0 | pass |
|
||||
| lambda | 31 | 0 | pass |
|
||||
| eval | 182 | 0 | pass |
|
||||
| conditions | 59 | 0 | pass |
|
||||
| restart-demo | 7 | 0 | pass |
|
||||
| parse-recover | 6 | 0 | pass |
|
||||
| interactive-debugger | 7 | 0 | pass |
|
||||
| clos | 35 | 0 | pass |
|
||||
| geometry | 0 | 0 | FAIL |
|
||||
| mop-trace | 0 | 0 | FAIL |
|
||||
| macros | 27 | 0 | pass |
|
||||
| stdlib | 54 | 0 | pass |
|
||||
| Phase 1: tokenizer/reader | 79 | 0 | pass |
|
||||
| Phase 1: parser/lambda-lists | 31 | 0 | pass |
|
||||
| Phase 2: evaluator | 182 | 0 | pass |
|
||||
| Phase 3: condition system | 59 | 0 | pass |
|
||||
| Phase 3: restart-demo | 7 | 0 | pass |
|
||||
| Phase 3: parse-recover | 6 | 0 | pass |
|
||||
| Phase 3: interactive-debugger | 7 | 0 | pass |
|
||||
| Phase 4: CLOS | 41 | 0 | pass |
|
||||
| Phase 4: geometry | 12 | 0 | pass |
|
||||
| Phase 4: mop-trace | 13 | 0 | pass |
|
||||
| Phase 5: macros+LOOP | 27 | 0 | pass |
|
||||
| Phase 6: stdlib | 54 | 0 | pass |
|
||||
|
||||
**Total: 487 passed, 0 failed**
|
||||
**Total: 518 passed, 0 failed**
|
||||
|
||||
@@ -1,51 +0,0 @@
|
||||
;; content-on-sx — anchored-heading HTML render.
|
||||
;;
|
||||
;; Like asHTML, but headings carry an id attribute (the block id), so the TOC's
|
||||
;; #id links resolve. A separate render so the plain asHTML stays unchanged.
|
||||
;; Tree-aware (sections recurse); other blocks use their normal asHTML.
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx, render.sx (asHTML +
|
||||
;; htmlEscaped).
|
||||
|
||||
(define
|
||||
anch-section?
|
||||
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
|
||||
(define anch-esc (fn (s) (str (st-send s "htmlEscaped" (list)))))
|
||||
|
||||
(define
|
||||
anchor-block
|
||||
(fn
|
||||
(b)
|
||||
(cond
|
||||
((= (blk-type b) "heading")
|
||||
(let
|
||||
((l (str (blk-get b "level"))) (id (blk-id b)))
|
||||
(str
|
||||
"<h"
|
||||
l
|
||||
" id=\""
|
||||
id
|
||||
"\">"
|
||||
(anch-esc (str (blk-get b "text")))
|
||||
"</h"
|
||||
l
|
||||
">")))
|
||||
((anch-section? b)
|
||||
(let
|
||||
((ch (st-iv-get b "children")))
|
||||
(str
|
||||
"<section>"
|
||||
(anchor-blocks (if (list? ch) ch (list)))
|
||||
"</section>")))
|
||||
(else (str (st-send b "asHTML" (list)))))))
|
||||
|
||||
(define
|
||||
anchor-blocks
|
||||
(fn
|
||||
(blocks)
|
||||
(if
|
||||
(= (len blocks) 0)
|
||||
""
|
||||
(str (anchor-block (first blocks)) (anchor-blocks (rest blocks))))))
|
||||
|
||||
(define content/html-anchored (fn (doc) (anchor-blocks (doc-blocks doc))))
|
||||
@@ -1,67 +0,0 @@
|
||||
;; content-on-sx — public API facade.
|
||||
;;
|
||||
;; The stable surface other code calls. Composes block + doc + render. Document
|
||||
;; values are immutable; every edit returns a new document, so callers hold
|
||||
;; explicit versions (the persist op log in Phase 2 becomes the source of truth).
|
||||
;;
|
||||
;; Requires (loaded by the harness): block.sx, doc.sx, render.sx and a base
|
||||
;; Smalltalk class table (st-bootstrap-classes!).
|
||||
|
||||
;; Register the content class hierarchy + render methods. Caller bootstraps the
|
||||
;; base Smalltalk classes first; this only adds content classes (idempotent).
|
||||
(define
|
||||
content/bootstrap!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(content-bootstrap-blocks!)
|
||||
(content-bootstrap-doc!)
|
||||
(content-bootstrap-render!)
|
||||
true)))
|
||||
|
||||
;; ── documents ──
|
||||
(define content/new doc-new)
|
||||
(define content/empty doc-empty)
|
||||
(define content/append doc-append)
|
||||
(define content/blocks doc-blocks)
|
||||
(define content/count doc-count)
|
||||
(define content/find doc-find)
|
||||
(define content/has? doc-has?)
|
||||
(define content/ids doc-ids)
|
||||
(define content/types doc-types)
|
||||
|
||||
;; ── blocks ──
|
||||
(define content/block mk-block)
|
||||
|
||||
;; ── edit ops (data payload) ──
|
||||
(define content/insert op-insert)
|
||||
(define content/update op-update)
|
||||
(define content/move op-move)
|
||||
(define content/delete op-delete)
|
||||
|
||||
(define content/op? (fn (x) (and (dict? x) (has-key? x :op))))
|
||||
|
||||
;; edit — apply one op or a stream of ops; returns a new document.
|
||||
(define
|
||||
content/edit
|
||||
(fn
|
||||
(doc ops)
|
||||
(if (content/op? ops) (doc-apply doc ops) (doc-apply-all doc ops))))
|
||||
|
||||
;; ── render boundary ──
|
||||
;; fmt is "html"/"sx"/"md"/"text" (or the matching keyword). "md" needs
|
||||
;; markdown.sx loaded; "text" needs text.sx loaded.
|
||||
(define
|
||||
content/render
|
||||
(fn
|
||||
(doc fmt)
|
||||
(cond
|
||||
((= fmt "html") (asHTML doc))
|
||||
((= fmt "sx") (asSx doc))
|
||||
((= fmt "md") (asMarkdown doc))
|
||||
((= fmt "markdown") (asMarkdown doc))
|
||||
((= fmt "text") (asText doc))
|
||||
(else (error (str "unknown render format: " fmt))))))
|
||||
|
||||
(define content/html asHTML)
|
||||
(define content/sx asSx)
|
||||
@@ -1,171 +0,0 @@
|
||||
;; content-on-sx — typed block objects on Smalltalk-on-SX.
|
||||
;;
|
||||
;; A block is a Smalltalk instance. Behaviour (type tag, later render) is a
|
||||
;; message, not a property switch. Fields are immutable: blk-set / mk-* build a
|
||||
;; fresh instance via the functional st-iv-set!, so old versions are never
|
||||
;; clobbered (history-safe for the persist op log and CRDT merge).
|
||||
;;
|
||||
;; Hierarchy:
|
||||
;; CtBlock (id)
|
||||
;; CtText (text)
|
||||
;; CtHeading (level)
|
||||
;; CtCode (language)
|
||||
;; CtQuote (cite)
|
||||
;; CtImage (src alt)
|
||||
;; CtEmbed (url provider)
|
||||
;; CtDivider
|
||||
;; CtList (ordered items)
|
||||
;; Plus self-contained blocks registered by their own files: CtSection,
|
||||
;; CtTable, CtCallout, CtMedia. ct-class-for-type maps every tag (so mk-block,
|
||||
;; content/from-data and CRDT materialise build them uniformly); the classes
|
||||
;; themselves are registered by content-bootstrap-section!/table!/callout!/media!.
|
||||
|
||||
(define
|
||||
ct-def-method!
|
||||
(fn (cls sel src) (st-class-add-method! cls sel (st-parse-method src))))
|
||||
|
||||
;; Register the block hierarchy in the Smalltalk class table. Call AFTER
|
||||
;; st-bootstrap-classes! (which resets the table). Idempotent.
|
||||
(define
|
||||
content-bootstrap-blocks!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(st-class-define! "CtBlock" "Object" (list "id"))
|
||||
(ct-def-method! "CtBlock" "id" "id ^ id")
|
||||
(ct-def-method! "CtBlock" "type" "type ^ #block")
|
||||
(ct-def-method! "CtBlock" "isBlock" "isBlock ^ true")
|
||||
(st-class-define! "CtText" "CtBlock" (list "text"))
|
||||
(ct-def-method! "CtText" "text" "text ^ text")
|
||||
(ct-def-method! "CtText" "type" "type ^ #text")
|
||||
(st-class-define! "CtHeading" "CtText" (list "level"))
|
||||
(ct-def-method! "CtHeading" "level" "level ^ level")
|
||||
(ct-def-method! "CtHeading" "type" "type ^ #heading")
|
||||
(st-class-define! "CtCode" "CtText" (list "language"))
|
||||
(ct-def-method! "CtCode" "language" "language ^ language")
|
||||
(ct-def-method! "CtCode" "type" "type ^ #code")
|
||||
(st-class-define! "CtQuote" "CtText" (list "cite"))
|
||||
(ct-def-method! "CtQuote" "cite" "cite ^ cite")
|
||||
(ct-def-method! "CtQuote" "type" "type ^ #quote")
|
||||
(st-class-define! "CtImage" "CtBlock" (list "src" "alt"))
|
||||
(ct-def-method! "CtImage" "src" "src ^ src")
|
||||
(ct-def-method! "CtImage" "alt" "alt ^ alt")
|
||||
(ct-def-method! "CtImage" "type" "type ^ #image")
|
||||
(st-class-define! "CtEmbed" "CtBlock" (list "url" "provider"))
|
||||
(ct-def-method! "CtEmbed" "url" "url ^ url")
|
||||
(ct-def-method! "CtEmbed" "provider" "provider ^ provider")
|
||||
(ct-def-method! "CtEmbed" "type" "type ^ #embed")
|
||||
(st-class-define! "CtDivider" "CtBlock" (list))
|
||||
(ct-def-method! "CtDivider" "type" "type ^ #divider")
|
||||
(st-class-define! "CtList" "CtBlock" (list "ordered" "items"))
|
||||
(ct-def-method! "CtList" "ordered" "ordered ^ ordered")
|
||||
(ct-def-method! "CtList" "items" "items ^ items")
|
||||
(ct-def-method! "CtList" "type" "type ^ #list")
|
||||
true)))
|
||||
|
||||
;; Apply (name value) pairs functionally onto a fresh instance.
|
||||
(define
|
||||
ct-apply-fields
|
||||
(fn
|
||||
(inst pairs)
|
||||
(if
|
||||
(= (len pairs) 0)
|
||||
inst
|
||||
(ct-apply-fields
|
||||
(st-iv-set!
|
||||
inst
|
||||
(first (first pairs))
|
||||
(first (rest (first pairs))))
|
||||
(rest pairs)))))
|
||||
|
||||
(define
|
||||
ct-class-for-type
|
||||
(fn
|
||||
(tag)
|
||||
(cond
|
||||
((= tag "text") "CtText")
|
||||
((= tag "heading") "CtHeading")
|
||||
((= tag "code") "CtCode")
|
||||
((= tag "quote") "CtQuote")
|
||||
((= tag "image") "CtImage")
|
||||
((= tag "embed") "CtEmbed")
|
||||
((= tag "divider") "CtDivider")
|
||||
((= tag "list") "CtList")
|
||||
((= tag "section") "CtSection")
|
||||
((= tag "table") "CtTable")
|
||||
((= tag "callout") "CtCallout")
|
||||
((= tag "media") "CtMedia")
|
||||
(else (error (str "unknown block type: " tag))))))
|
||||
|
||||
;; Generic constructor — wire tag + id + (name value) field pairs.
|
||||
(define
|
||||
mk-block
|
||||
(fn
|
||||
(type-tag id fields)
|
||||
(ct-apply-fields
|
||||
(st-iv-set! (st-make-instance (ct-class-for-type type-tag)) "id" id)
|
||||
fields)))
|
||||
|
||||
(define
|
||||
mk-text
|
||||
(fn (id text) (mk-block "text" id (list (list "text" text)))))
|
||||
|
||||
(define
|
||||
mk-heading
|
||||
(fn
|
||||
(id level text)
|
||||
(mk-block "heading" id (list (list "level" level) (list "text" text)))))
|
||||
|
||||
(define
|
||||
mk-code
|
||||
(fn
|
||||
(id language text)
|
||||
(mk-block
|
||||
"code"
|
||||
id
|
||||
(list (list "language" language) (list "text" text)))))
|
||||
|
||||
(define
|
||||
mk-quote
|
||||
(fn
|
||||
(id cite text)
|
||||
(mk-block "quote" id (list (list "cite" cite) (list "text" text)))))
|
||||
|
||||
(define
|
||||
mk-image
|
||||
(fn
|
||||
(id src alt)
|
||||
(mk-block "image" id (list (list "src" src) (list "alt" alt)))))
|
||||
|
||||
(define
|
||||
mk-embed
|
||||
(fn
|
||||
(id url provider)
|
||||
(mk-block "embed" id (list (list "url" url) (list "provider" provider)))))
|
||||
|
||||
(define mk-divider (fn (id) (mk-block "divider" id (list))))
|
||||
|
||||
(define
|
||||
mk-list
|
||||
(fn
|
||||
(id ordered items)
|
||||
(mk-block
|
||||
"list"
|
||||
id
|
||||
(list (list "ordered" ordered) (list "items" items)))))
|
||||
|
||||
;; Accessors. blk-type / blk-id go through message dispatch (polymorphic);
|
||||
;; blk-get reads any ivar directly; blk-set is copy-on-write.
|
||||
(define blk-id (fn (b) (st-send b "id" (list))))
|
||||
(define blk-type (fn (b) (str (st-send b "type" (list)))))
|
||||
(define blk-send (fn (b sel) (st-send b sel (list))))
|
||||
(define blk-get (fn (b field) (st-iv-get b field)))
|
||||
(define blk-set (fn (b field val) (st-iv-set! b field val)))
|
||||
|
||||
(define
|
||||
block?
|
||||
(fn
|
||||
(v)
|
||||
(and
|
||||
(st-instance? v)
|
||||
(st-class-inherits-from? (get v :class) "CtBlock"))))
|
||||
@@ -1,49 +0,0 @@
|
||||
;; content-on-sx — callout / admonition block.
|
||||
;;
|
||||
;; CtCallout holds a `kind` (note/warning/tip/…) and `text`. Self-contained: it
|
||||
;; answers asHTML/asSx/asText/asMarkdown: so it composes with the render boundary
|
||||
;; with no changes elsewhere. HTML text is htmlEscaped, SX text sxEscaped.
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx, render.sx (escapers);
|
||||
;; markdown.sx / text.sx for those formats.
|
||||
|
||||
(define
|
||||
content-bootstrap-callout!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(st-class-define! "CtCallout" "CtBlock" (list "kind" "text"))
|
||||
(ct-def-method! "CtCallout" "kind" "kind ^ kind")
|
||||
(ct-def-method! "CtCallout" "text" "text ^ text")
|
||||
(ct-def-method! "CtCallout" "type" "type ^ #callout")
|
||||
(ct-def-method!
|
||||
"CtCallout"
|
||||
"asHTML"
|
||||
"asHTML ^ '<aside class=\"callout callout-' , kind htmlEscaped , '\">' , text htmlEscaped , '</aside>'")
|
||||
(ct-def-method!
|
||||
"CtCallout"
|
||||
"asSx"
|
||||
"asSx ^ '(aside :class \"callout callout-' , kind sxEscaped , '\" \"' , text sxEscaped , '\")'")
|
||||
(ct-def-method! "CtCallout" "asText" "asText ^ text")
|
||||
(ct-def-method!
|
||||
"CtCallout"
|
||||
"asMarkdown:"
|
||||
"asMarkdown: nl ^ '> **' , kind , ':** ' , text")
|
||||
true)))
|
||||
|
||||
(define
|
||||
mk-callout
|
||||
(fn
|
||||
(id kind text)
|
||||
(st-iv-set!
|
||||
(st-iv-set!
|
||||
(st-iv-set! (st-make-instance "CtCallout") "id" id)
|
||||
"kind"
|
||||
kind)
|
||||
"text"
|
||||
text)))
|
||||
|
||||
(define
|
||||
callout?
|
||||
(fn (b) (and (st-instance? b) (= (get b :class) "CtCallout"))))
|
||||
(define callout-kind (fn (b) (st-send b "kind" (list))))
|
||||
@@ -1,34 +0,0 @@
|
||||
;; content-on-sx — block id remapping / clone.
|
||||
;;
|
||||
;; Deep-rewrite every block id in the tree (descending into sections) by applying
|
||||
;; a function. Enables collision-free composition: prefix one document's ids
|
||||
;; before concatenating it with another. Immutable; content is unchanged, only
|
||||
;; ids.
|
||||
;;
|
||||
;; Requires (loaded by harness): doc.sx, section.sx (section? /
|
||||
;; section-children / section-with-children).
|
||||
|
||||
(define
|
||||
block-remap-id
|
||||
(fn
|
||||
(b f)
|
||||
(let
|
||||
((nb (blk-set b "id" (f (blk-id b)))))
|
||||
(if
|
||||
(section? nb)
|
||||
(section-with-children
|
||||
nb
|
||||
(map (fn (c) (block-remap-id c f)) (section-children nb)))
|
||||
nb))))
|
||||
|
||||
(define
|
||||
content/remap-ids
|
||||
(fn
|
||||
(doc f)
|
||||
(doc-with-blocks
|
||||
doc
|
||||
(map (fn (b) (block-remap-id b f)) (doc-blocks doc)))))
|
||||
|
||||
(define
|
||||
content/prefix-ids
|
||||
(fn (doc prefix) (content/remap-ids doc (fn (id) (str prefix id)))))
|
||||
@@ -1,42 +0,0 @@
|
||||
;; content-on-sx — document composition.
|
||||
;;
|
||||
;; Combine documents (header + body + footer, templates, partials) into a new
|
||||
;; document. The result keeps the FIRST document's id and metadata; blocks are
|
||||
;; concatenated. Immutable — inputs are untouched. Block-id collisions across
|
||||
;; combined docs are the caller's concern (content/validate flags duplicates).
|
||||
;;
|
||||
;; Requires (loaded by harness): doc.sx.
|
||||
|
||||
(define
|
||||
content/concat
|
||||
(fn (a b) (doc-with-blocks a (append (doc-blocks a) (doc-blocks b)))))
|
||||
|
||||
(define
|
||||
content/prepend
|
||||
(fn (a b) (doc-with-blocks a (append (doc-blocks b) (doc-blocks a)))))
|
||||
|
||||
(define
|
||||
content/-concat-fold
|
||||
(fn
|
||||
(acc more)
|
||||
(if
|
||||
(= (len more) 0)
|
||||
acc
|
||||
(content/-concat-fold (content/concat acc (first more)) (rest more)))))
|
||||
|
||||
(define
|
||||
content/concat-all
|
||||
(fn
|
||||
(docs)
|
||||
(if
|
||||
(= (len docs) 0)
|
||||
(doc-empty "merged")
|
||||
(content/-concat-fold (first docs) (rest docs)))))
|
||||
|
||||
;; wrap a document's blocks inside a single section (collapse to a subtree).
|
||||
;; Requires section.sx (mk-section) when used.
|
||||
(define
|
||||
content/wrap-section
|
||||
(fn
|
||||
(doc section-id)
|
||||
(doc-with-blocks doc (list (mk-section section-id (doc-blocks doc))))))
|
||||
@@ -1,158 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
# lib/content/conformance.sh — run content-on-sx suites, emit scoreboard.
|
||||
|
||||
set -uo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
SX_SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}')
|
||||
if [ -x "$MAIN_ROOT/$SX_SERVER" ]; then
|
||||
SX_SERVER="$MAIN_ROOT/$SX_SERVER"
|
||||
else
|
||||
echo "ERROR: sx_server.exe not found." >&2
|
||||
exit 1
|
||||
fi
|
||||
fi
|
||||
|
||||
SUITES=(block doc render api meta page page-full markdown text section compose tree-edit move clone query toc anchor outline flatten transform normalize find-replace stats summary index table callout media data wire validate store snapshot crdt crdt-tree crdt-blocks crdt-store sync md-import md-doc fed)
|
||||
|
||||
OUT_JSON="lib/content/scoreboard.json"
|
||||
OUT_MD="lib/content/scoreboard.md"
|
||||
|
||||
run_suite() {
|
||||
local suite=$1
|
||||
local file="lib/content/tests/${suite}.sx"
|
||||
local TMP
|
||||
TMP=$(mktemp)
|
||||
cat > "$TMP" << EPOCHS
|
||||
(epoch 1)
|
||||
(load "lib/smalltalk/tokenizer.sx")
|
||||
(load "lib/smalltalk/parser.sx")
|
||||
(load "lib/guest/reflective/class-chain.sx")
|
||||
(load "lib/smalltalk/runtime.sx")
|
||||
(load "lib/guest/reflective/env.sx")
|
||||
(load "lib/smalltalk/eval.sx")
|
||||
(load "lib/persist/event.sx")
|
||||
(load "lib/persist/backend.sx")
|
||||
(load "lib/persist/log.sx")
|
||||
(load "lib/persist/kv.sx")
|
||||
(load "lib/persist/api.sx")
|
||||
(load "lib/content/block.sx")
|
||||
(load "lib/content/doc.sx")
|
||||
(load "lib/content/render.sx")
|
||||
(load "lib/content/api.sx")
|
||||
(load "lib/content/meta.sx")
|
||||
(load "lib/content/text.sx")
|
||||
(load "lib/content/section.sx")
|
||||
(load "lib/content/compose.sx")
|
||||
(load "lib/content/tree-edit.sx")
|
||||
(load "lib/content/move.sx")
|
||||
(load "lib/content/clone.sx")
|
||||
(load "lib/content/query.sx")
|
||||
(load "lib/content/toc.sx")
|
||||
(load "lib/content/anchor.sx")
|
||||
(load "lib/content/outline.sx")
|
||||
(load "lib/content/flatten.sx")
|
||||
(load "lib/content/transform.sx")
|
||||
(load "lib/content/normalize.sx")
|
||||
(load "lib/content/find-replace.sx")
|
||||
(load "lib/content/stats.sx")
|
||||
(load "lib/content/summary.sx")
|
||||
(load "lib/content/index.sx")
|
||||
(load "lib/content/table.sx")
|
||||
(load "lib/content/callout.sx")
|
||||
(load "lib/content/media.sx")
|
||||
(load "lib/content/data.sx")
|
||||
(load "lib/content/wire.sx")
|
||||
(load "lib/content/page.sx")
|
||||
(load "lib/content/page-full.sx")
|
||||
(load "lib/content/markdown.sx")
|
||||
(load "lib/content/validate.sx")
|
||||
(load "lib/content/store.sx")
|
||||
(load "lib/content/snapshot.sx")
|
||||
(load "lib/content/crdt.sx")
|
||||
(load "lib/content/crdt-tree.sx")
|
||||
(load "lib/content/crdt-store.sx")
|
||||
(load "lib/content/sync.sx")
|
||||
(load "lib/content/md-import.sx")
|
||||
(load "lib/content/md-doc.sx")
|
||||
(load "lib/content/fed.sx")
|
||||
(epoch 2)
|
||||
(eval "(define content-test-pass 0)")
|
||||
(eval "(define content-test-fail 0)")
|
||||
(eval "(define content-test-fails (list))")
|
||||
(eval "(define content-test (fn (name got expected) (if (= got expected) (set! content-test-pass (+ content-test-pass 1)) (begin (set! content-test-fail (+ content-test-fail 1)) (set! content-test-fails (cons name content-test-fails))))))")
|
||||
(epoch 3)
|
||||
(load "${file}")
|
||||
(epoch 4)
|
||||
(eval "(list content-test-pass content-test-fail)")
|
||||
EPOCHS
|
||||
|
||||
local OUTPUT
|
||||
OUTPUT=$(timeout 240 "$SX_SERVER" < "$TMP" 2>/dev/null)
|
||||
rm -f "$TMP"
|
||||
|
||||
local LINE
|
||||
LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}')
|
||||
if [ -z "$LINE" ]; then
|
||||
LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \
|
||||
| sed -E 's/^\(ok 4 //; s/\)$//')
|
||||
fi
|
||||
|
||||
local P F
|
||||
P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/')
|
||||
F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/')
|
||||
P=${P:-0}
|
||||
F=${F:-0}
|
||||
echo "${P} ${F}"
|
||||
}
|
||||
|
||||
declare -A SUITE_PASS
|
||||
declare -A SUITE_FAIL
|
||||
TOTAL_PASS=0
|
||||
TOTAL_FAIL=0
|
||||
|
||||
echo "Running content conformance suite..." >&2
|
||||
for s in "${SUITES[@]}"; do
|
||||
read -r p f < <(run_suite "$s")
|
||||
SUITE_PASS[$s]=$p
|
||||
SUITE_FAIL[$s]=$f
|
||||
TOTAL_PASS=$((TOTAL_PASS + p))
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + f))
|
||||
printf " %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2
|
||||
done
|
||||
|
||||
{
|
||||
printf '{\n'
|
||||
printf ' "suites": {\n'
|
||||
first=1
|
||||
for s in "${SUITES[@]}"; do
|
||||
if [ $first -eq 0 ]; then printf ',\n'; fi
|
||||
printf ' "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}"
|
||||
first=0
|
||||
done
|
||||
printf '\n },\n'
|
||||
printf ' "total_pass": %d,\n' "$TOTAL_PASS"
|
||||
printf ' "total_fail": %d,\n' "$TOTAL_FAIL"
|
||||
printf ' "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))"
|
||||
printf '}\n'
|
||||
} > "$OUT_JSON"
|
||||
|
||||
{
|
||||
printf '# content-on-sx Conformance Scoreboard\n\n'
|
||||
printf '_Generated by `lib/content/conformance.sh`_\n\n'
|
||||
printf '| Suite | Pass | Fail | Total |\n'
|
||||
printf '|-------|-----:|-----:|------:|\n'
|
||||
for s in "${SUITES[@]}"; do
|
||||
p=${SUITE_PASS[$s]}
|
||||
f=${SUITE_FAIL[$s]}
|
||||
printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))"
|
||||
done
|
||||
printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))"
|
||||
} > "$OUT_MD"
|
||||
|
||||
echo "Wrote $OUT_JSON and $OUT_MD" >&2
|
||||
echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2
|
||||
|
||||
[ "$TOTAL_FAIL" -eq 0 ]
|
||||
@@ -1,71 +0,0 @@
|
||||
;; content-on-sx — durable collaborative replication: CRDT ops on persist.
|
||||
;;
|
||||
;; Each replica appends its CRDT ops to its own persist stream
|
||||
;; (crdt:<doc>:<replica>). Any node reconstructs the converged document by
|
||||
;; replaying every replica's log into a CvRDT state and merging them. Because
|
||||
;; the merge is a join and crdt-apply is order/duplicate-insensitive, the
|
||||
;; converged result is identical regardless of replica order or re-delivery —
|
||||
;; the durable log + CRDT give offline-capable, eventually-consistent editing.
|
||||
;;
|
||||
;; Requires (loaded by harness): crdt.sx (+ deps) and persist
|
||||
;; (event/backend/log/kv/api). Backend `b` injected via (persist/open).
|
||||
|
||||
(define crdt/-stream (fn (doc-id replica) (str "crdt:" doc-id ":" replica)))
|
||||
|
||||
;; ── commit ops to a replica's durable log ──
|
||||
(define
|
||||
crdt/commit!
|
||||
(fn
|
||||
(b doc-id replica op at)
|
||||
(persist/append b (crdt/-stream doc-id replica) (get op :op) at op)))
|
||||
|
||||
(define
|
||||
crdt/commit-all!
|
||||
(fn
|
||||
(b doc-id replica ops at)
|
||||
(if
|
||||
(= (len ops) 0)
|
||||
nil
|
||||
(begin
|
||||
(crdt/commit! b doc-id replica (first ops) at)
|
||||
(crdt/commit-all! b doc-id replica (rest ops) at)))))
|
||||
|
||||
;; ── read a replica's log ──
|
||||
(define
|
||||
crdt/log
|
||||
(fn (b doc-id replica) (persist/read b (crdt/-stream doc-id replica))))
|
||||
|
||||
(define
|
||||
crdt/replica-ops
|
||||
(fn
|
||||
(b doc-id replica)
|
||||
(map (fn (ev) (persist/event-data ev)) (crdt/log b doc-id replica))))
|
||||
|
||||
(define
|
||||
crdt/replica-version
|
||||
(fn (b doc-id replica) (persist/last-seq b (crdt/-stream doc-id replica))))
|
||||
|
||||
;; ── replay one replica's log into a CvRDT state ──
|
||||
(define
|
||||
crdt/replay
|
||||
(fn
|
||||
(b doc-id replica)
|
||||
(crdt-apply-all (crdt-empty) (crdt/replica-ops b doc-id replica))))
|
||||
|
||||
;; ── converge: merge every replica's replayed state ──
|
||||
(define
|
||||
crdt/converge
|
||||
(fn
|
||||
(b doc-id replicas)
|
||||
(crdt-merge-all (map (fn (r) (crdt/replay b doc-id r)) replicas))))
|
||||
|
||||
;; ── converged, materialised document ──
|
||||
(define
|
||||
crdt/document
|
||||
(fn
|
||||
(b doc-id replicas)
|
||||
(crdt-materialize doc-id (crdt/converge b doc-id replicas))))
|
||||
|
||||
(define
|
||||
crdt/order
|
||||
(fn (b doc-id replicas) (crdt-order (crdt/converge b doc-id replicas))))
|
||||
@@ -1,193 +0,0 @@
|
||||
;; content-on-sx — nested-tree CvRDT.
|
||||
;;
|
||||
;; Extends the flat CvRDT (crdt.sx) to a TREE: each element carries a `parent`
|
||||
;; (the id of its containing section, "" = root) alongside its Logoot position.
|
||||
;; Merge is still a join — it reuses crdt.sx's position/register/field merges and
|
||||
;; adds parent (immutable, set once at insert). Materialisation rebuilds the
|
||||
;; ordered tree: root = elements with parent "" (plus ORPHANS — elements whose
|
||||
;; parent is not a live section, e.g. after a concurrent delete-section +
|
||||
;; insert-child, so content is never silently lost); a section's children =
|
||||
;; elements whose parent is that section's id. Commutative/associative/idempotent
|
||||
;; like the flat layer.
|
||||
;;
|
||||
;; Requires (loaded by harness): crdt.sx (merge helpers + live/sort/materialise
|
||||
;; bits + crdt-member?), block.sx, doc.sx, section.sx (mk-section).
|
||||
|
||||
(define ctt-merge-parent (fn (p1 p2) (if (= p1 nil) p2 p1)))
|
||||
|
||||
(define ctt-merge-element (fn (e1 e2) {:fields (crdt-merge-fields (get e1 :fields) (get e2 :fields)) :parent (ctt-merge-parent (get e1 :parent) (get e2 :parent)) :id (get e1 :id) :type (crdt-merge-type (get e1 :type) (get e2 :type)) :deleted (or (= (get e1 :deleted) true) (= (get e2 :deleted) true)) :pos (crdt-merge-pos (get e1 :pos) (get e2 :pos))}))
|
||||
|
||||
(define
|
||||
ctt-add-element
|
||||
(fn
|
||||
(state elem)
|
||||
(let
|
||||
((elems (get state :elements)) (id (get elem :id)))
|
||||
(let
|
||||
((existing (get elems id)))
|
||||
(assoc
|
||||
state
|
||||
:elements (assoc
|
||||
elems
|
||||
id
|
||||
(if (= existing nil) elem (ctt-merge-element existing elem))))))))
|
||||
|
||||
;; ── ops as partial-element contributions ──
|
||||
(define
|
||||
crdt-tree-insert
|
||||
(fn
|
||||
(state id type pos parent fields ts actor)
|
||||
(ctt-add-element state {:fields (crdt-build-fields fields ts actor) :parent parent :id id :type type :deleted false :pos pos})))
|
||||
|
||||
(define
|
||||
crdt-tree-update
|
||||
(fn (state id fname value ts actor) (ctt-add-element state {:fields (assoc {} fname {:ts ts :actor actor :value value}) :parent nil :id id :type nil :deleted false :pos nil})))
|
||||
|
||||
(define crdt-tree-delete (fn (state id) (ctt-add-element state {:fields {} :parent nil :id id :type nil :deleted true :pos nil})))
|
||||
|
||||
;; ── state merge (join) ──
|
||||
(define
|
||||
ctt-merge-loop
|
||||
(fn
|
||||
(ids ea eb acc)
|
||||
(if
|
||||
(= (len ids) 0)
|
||||
acc
|
||||
(let
|
||||
((id (first ids)))
|
||||
(let
|
||||
((x (get ea id)) (y (get eb id)))
|
||||
(ctt-merge-loop
|
||||
(rest ids)
|
||||
ea
|
||||
eb
|
||||
(assoc
|
||||
acc
|
||||
id
|
||||
(cond
|
||||
((= x nil) y)
|
||||
((= y nil) x)
|
||||
(else (ctt-merge-element x y))))))))))
|
||||
|
||||
(define crdt-tree-merge (fn (a b) {:elements (ctt-merge-loop (crdt-union-keys (get a :elements) (get b :elements)) (get a :elements) (get b :elements) {})}))
|
||||
|
||||
(define
|
||||
crdt-tree-merge-all
|
||||
(fn
|
||||
(states)
|
||||
(if
|
||||
(= (len states) 0)
|
||||
(crdt-empty)
|
||||
(if
|
||||
(= (len states) 1)
|
||||
(first states)
|
||||
(crdt-tree-merge (first states) (crdt-tree-merge-all (rest states)))))))
|
||||
|
||||
;; ── op interpreter ──
|
||||
(define
|
||||
crdt-tree-op-insert
|
||||
(fn (id type pos parent fields ts actor) {:ts ts :fields fields :parent parent :id id :type type :op "insert" :actor actor :pos pos}))
|
||||
|
||||
(define crdt-tree-op-update (fn (id field value ts actor) {:ts ts :field field :id id :op "update" :actor actor :value value}))
|
||||
|
||||
(define crdt-tree-op-delete (fn (id) {:id id :op "delete"}))
|
||||
|
||||
(define
|
||||
crdt-tree-apply
|
||||
(fn
|
||||
(state op)
|
||||
(let
|
||||
((k (get op :op)))
|
||||
(cond
|
||||
((= k "insert")
|
||||
(crdt-tree-insert
|
||||
state
|
||||
(get op :id)
|
||||
(get op :type)
|
||||
(get op :pos)
|
||||
(get op :parent)
|
||||
(get op :fields)
|
||||
(get op :ts)
|
||||
(get op :actor)))
|
||||
((= k "update")
|
||||
(crdt-tree-update
|
||||
state
|
||||
(get op :id)
|
||||
(get op :field)
|
||||
(get op :value)
|
||||
(get op :ts)
|
||||
(get op :actor)))
|
||||
((= k "delete") (crdt-tree-delete state (get op :id)))
|
||||
(else (error (str "unknown crdt-tree op: " k)))))))
|
||||
|
||||
(define
|
||||
crdt-tree-apply-all
|
||||
(fn
|
||||
(state ops)
|
||||
(if
|
||||
(= (len ops) 0)
|
||||
state
|
||||
(crdt-tree-apply-all (crdt-tree-apply state (first ops)) (rest ops)))))
|
||||
|
||||
;; ── materialise to a Phase-1 document (rebuild the ordered tree) ──
|
||||
(define
|
||||
ctt-live-section-ids
|
||||
(fn
|
||||
(state)
|
||||
(map
|
||||
(fn (e) (get e :id))
|
||||
(filter
|
||||
(fn (e) (= (get e :type) "section"))
|
||||
(crdt-live-elements state)))))
|
||||
|
||||
;; an element belongs at root if its parent is "" or its parent is not a live
|
||||
;; section (orphan-reparenting: don't lose content when its section is deleted).
|
||||
(define
|
||||
ctt-roots
|
||||
(fn
|
||||
(state)
|
||||
(let
|
||||
((secids (ctt-live-section-ids state)))
|
||||
(crdt-sort-by-pos
|
||||
(filter
|
||||
(fn
|
||||
(e)
|
||||
(if
|
||||
(= (get e :parent) "")
|
||||
true
|
||||
(if (crdt-member? (get e :parent) secids) false true)))
|
||||
(crdt-live-elements state))))))
|
||||
|
||||
(define
|
||||
ctt-children
|
||||
(fn
|
||||
(state parent-id)
|
||||
(crdt-sort-by-pos
|
||||
(filter
|
||||
(fn (e) (= (get e :parent) parent-id))
|
||||
(crdt-live-elements state)))))
|
||||
|
||||
(define
|
||||
ctt-element->block
|
||||
(fn
|
||||
(state e)
|
||||
(if
|
||||
(= (get e :type) "section")
|
||||
(mk-section
|
||||
(get e :id)
|
||||
(map
|
||||
(fn (c) (ctt-element->block state c))
|
||||
(ctt-children state (get e :id))))
|
||||
(crdt-element->block e))))
|
||||
|
||||
(define
|
||||
crdt-tree-materialize
|
||||
(fn
|
||||
(doc-id state)
|
||||
(doc-new
|
||||
doc-id
|
||||
(map (fn (e) (ctt-element->block state e)) (ctt-roots state)))))
|
||||
|
||||
(define
|
||||
crdt-tree-order
|
||||
(fn (state) (map (fn (e) (get e :id)) (ctt-roots state))))
|
||||
@@ -1,378 +0,0 @@
|
||||
;; content-on-sx — collaborative merge (state-based CvRDT).
|
||||
;;
|
||||
;; The merge is a join (least upper bound) on a semilattice, so it is
|
||||
;; commutative, associative and idempotent BY CONSTRUCTION — applying ops in any
|
||||
;; order, or merging replicas in any order / twice, converges to the same
|
||||
;; document. This is NOT last-write-wins-as-cop-out: ordering uses unique dense
|
||||
;; position keys (Logoot), presence uses OR-tombstones (remove-wins), and each
|
||||
;; field is an LWW-Register keyed by a logical (ts, actor) clock — an explicit,
|
||||
;; deterministic per-field conflict policy.
|
||||
;;
|
||||
;; Every op (insert/update/delete) contributes a PARTIAL element; the per-id
|
||||
;; state is the join of all contributions. So update-before-insert and
|
||||
;; delete-before-insert are not lost — they merge when the rest arrives.
|
||||
;;
|
||||
;; Shapes:
|
||||
;; state = {:elements <dict id -> element>}
|
||||
;; element = {:id :pos :type :deleted :fields <dict fname -> register>}
|
||||
;; register = {:value v :ts <int> :actor <int>}
|
||||
;; position = list of cells; cell = (list digit actor); lexicographic order
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx.
|
||||
|
||||
(define CRDT-BASE 65536)
|
||||
|
||||
;; ── position order (Logoot) ──
|
||||
(define
|
||||
crdt-cell-cmp
|
||||
(fn
|
||||
(c1 c2)
|
||||
(let
|
||||
((d1 (first c1)) (d2 (first c2)))
|
||||
(cond
|
||||
((< d1 d2) -1)
|
||||
((> d1 d2) 1)
|
||||
(else
|
||||
(let
|
||||
((a1 (first (rest c1))) (a2 (first (rest c2))))
|
||||
(cond
|
||||
((< a1 a2) -1)
|
||||
((> a1 a2) 1)
|
||||
(else 0))))))))
|
||||
|
||||
(define
|
||||
crdt-pos-compare
|
||||
(fn
|
||||
(p1 p2)
|
||||
(cond
|
||||
((and (= (len p1) 0) (= (len p2) 0)) 0)
|
||||
((= (len p1) 0) -1)
|
||||
((= (len p2) 0) 1)
|
||||
(else
|
||||
(let
|
||||
((c (crdt-cell-cmp (first p1) (first p2))))
|
||||
(if (= c 0) (crdt-pos-compare (rest p1) (rest p2)) c))))))
|
||||
|
||||
;; single-cell position constructor (handy for explicit tests)
|
||||
(define crdt-pos (fn (digit actor) (list (list digit actor))))
|
||||
|
||||
;; allocate a position strictly between left and right (nil = unbounded)
|
||||
(define
|
||||
cr-alloc
|
||||
(fn
|
||||
(left right actor i acc)
|
||||
(let
|
||||
((ld (if (< i (len left)) (first (nth left i)) 0))
|
||||
(rd (if (< i (len right)) (first (nth right i)) CRDT-BASE)))
|
||||
(if
|
||||
(> (- rd ld) 1)
|
||||
(append
|
||||
acc
|
||||
(list
|
||||
(list
|
||||
(+
|
||||
ld
|
||||
(+
|
||||
1
|
||||
(floor (/ (- (- rd ld) 1) 2))))
|
||||
actor)))
|
||||
(cr-alloc
|
||||
left
|
||||
right
|
||||
actor
|
||||
(+ i 1)
|
||||
(append
|
||||
acc
|
||||
(list
|
||||
(list
|
||||
ld
|
||||
(if (< i (len left)) (first (rest (nth left i))) actor)))))))))
|
||||
|
||||
(define
|
||||
crdt-pos-between
|
||||
(fn
|
||||
(left right actor)
|
||||
(cr-alloc
|
||||
(if (= left nil) (list) left)
|
||||
(if (= right nil) (list) right)
|
||||
actor
|
||||
0
|
||||
(list))))
|
||||
|
||||
;; ── register (LWW by logical (ts, actor)) ──
|
||||
(define
|
||||
crdt-reg-max
|
||||
(fn
|
||||
(r1 r2)
|
||||
(cond
|
||||
((= r1 nil) r2)
|
||||
((= r2 nil) r1)
|
||||
(else
|
||||
(let
|
||||
((t1 (get r1 :ts)) (t2 (get r2 :ts)))
|
||||
(cond
|
||||
((> t1 t2) r1)
|
||||
((< t1 t2) r2)
|
||||
(else (if (>= (get r1 :actor) (get r2 :actor)) r1 r2))))))))
|
||||
|
||||
;; ── small set/dict helpers ──
|
||||
(define
|
||||
crdt-member?
|
||||
(fn
|
||||
(x xs)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((= (first xs) x) true)
|
||||
(else (crdt-member? x (rest xs))))))
|
||||
|
||||
(define
|
||||
crdt-dedup-loop
|
||||
(fn
|
||||
(xs seen)
|
||||
(if
|
||||
(= (len xs) 0)
|
||||
(reverse seen)
|
||||
(if
|
||||
(crdt-member? (first xs) seen)
|
||||
(crdt-dedup-loop (rest xs) seen)
|
||||
(crdt-dedup-loop (rest xs) (cons (first xs) seen))))))
|
||||
|
||||
(define crdt-dedup (fn (xs) (crdt-dedup-loop xs (list))))
|
||||
|
||||
(define
|
||||
crdt-union-keys
|
||||
(fn (d1 d2) (crdt-dedup (append (keys d1) (keys d2)))))
|
||||
|
||||
;; ── element join ──
|
||||
(define
|
||||
crdt-merge-pos
|
||||
(fn
|
||||
(p1 p2)
|
||||
(cond
|
||||
((= p1 nil) p2)
|
||||
((= p2 nil) p1)
|
||||
((<= (crdt-pos-compare p1 p2) 0) p1)
|
||||
(else p2))))
|
||||
|
||||
(define crdt-merge-type (fn (t1 t2) (if (= t1 nil) t2 t1)))
|
||||
|
||||
(define
|
||||
crdt-merge-fields-loop
|
||||
(fn
|
||||
(names f1 f2 acc)
|
||||
(if
|
||||
(= (len names) 0)
|
||||
acc
|
||||
(let
|
||||
((nm (first names)))
|
||||
(crdt-merge-fields-loop
|
||||
(rest names)
|
||||
f1
|
||||
f2
|
||||
(assoc acc nm (crdt-reg-max (get f1 nm) (get f2 nm))))))))
|
||||
|
||||
(define
|
||||
crdt-merge-fields
|
||||
(fn
|
||||
(f1 f2)
|
||||
(crdt-merge-fields-loop (crdt-union-keys f1 f2) f1 f2 {})))
|
||||
|
||||
(define crdt-merge-element (fn (e1 e2) {:fields (crdt-merge-fields (get e1 :fields) (get e2 :fields)) :id (get e1 :id) :type (crdt-merge-type (get e1 :type) (get e2 :type)) :deleted (or (= (get e1 :deleted) true) (= (get e2 :deleted) true)) :pos (crdt-merge-pos (get e1 :pos) (get e2 :pos))}))
|
||||
|
||||
;; ── state ──
|
||||
(define crdt-empty (fn () {:elements {}}))
|
||||
|
||||
(define
|
||||
crdt-add-element
|
||||
(fn
|
||||
(state elem)
|
||||
(let
|
||||
((elems (get state :elements)) (id (get elem :id)))
|
||||
(let
|
||||
((existing (get elems id)))
|
||||
(assoc
|
||||
state
|
||||
:elements (assoc
|
||||
elems
|
||||
id
|
||||
(if (= existing nil) elem (crdt-merge-element existing elem))))))))
|
||||
|
||||
(define
|
||||
crdt-build-fields-loop
|
||||
(fn
|
||||
(pairs ts actor acc)
|
||||
(if
|
||||
(= (len pairs) 0)
|
||||
acc
|
||||
(crdt-build-fields-loop
|
||||
(rest pairs)
|
||||
ts
|
||||
actor
|
||||
(assoc acc (first (first pairs)) {:ts ts :actor actor :value (first (rest (first pairs)))})))))
|
||||
|
||||
(define
|
||||
crdt-build-fields
|
||||
(fn (pairs ts actor) (crdt-build-fields-loop pairs ts actor {})))
|
||||
|
||||
;; ── ops as partial-element contributions ──
|
||||
(define
|
||||
crdt-insert
|
||||
(fn
|
||||
(state id type pos fields ts actor)
|
||||
(crdt-add-element state {:fields (crdt-build-fields fields ts actor) :id id :type type :deleted false :pos pos})))
|
||||
|
||||
(define
|
||||
crdt-update
|
||||
(fn (state id fname value ts actor) (crdt-add-element state {:fields (assoc {} fname {:ts ts :actor actor :value value}) :id id :type nil :deleted false :pos nil})))
|
||||
|
||||
(define crdt-delete (fn (state id) (crdt-add-element state {:fields {} :id id :type nil :deleted true :pos nil})))
|
||||
|
||||
;; ── state merge (join) ──
|
||||
(define
|
||||
crdt-merge-loop
|
||||
(fn
|
||||
(ids ea eb acc)
|
||||
(if
|
||||
(= (len ids) 0)
|
||||
acc
|
||||
(let
|
||||
((id (first ids)))
|
||||
(let
|
||||
((x (get ea id)) (y (get eb id)))
|
||||
(crdt-merge-loop
|
||||
(rest ids)
|
||||
ea
|
||||
eb
|
||||
(assoc
|
||||
acc
|
||||
id
|
||||
(cond
|
||||
((= x nil) y)
|
||||
((= y nil) x)
|
||||
(else (crdt-merge-element x y))))))))))
|
||||
|
||||
(define crdt-merge (fn (a b) {:elements (crdt-merge-loop (crdt-union-keys (get a :elements) (get b :elements)) (get a :elements) (get b :elements) {})}))
|
||||
|
||||
(define
|
||||
crdt-merge-all
|
||||
(fn
|
||||
(states)
|
||||
(if
|
||||
(= (len states) 0)
|
||||
(crdt-empty)
|
||||
(if
|
||||
(= (len states) 1)
|
||||
(first states)
|
||||
(crdt-merge (first states) (crdt-merge-all (rest states)))))))
|
||||
|
||||
;; ── op interpreter ──
|
||||
(define crdt-op-insert (fn (id type pos fields ts actor) {:ts ts :fields fields :id id :type type :op "insert" :actor actor :pos pos}))
|
||||
|
||||
(define crdt-op-update (fn (id field value ts actor) {:ts ts :field field :id id :op "update" :actor actor :value value}))
|
||||
|
||||
(define crdt-op-delete (fn (id) {:id id :op "delete"}))
|
||||
|
||||
(define
|
||||
crdt-apply
|
||||
(fn
|
||||
(state op)
|
||||
(let
|
||||
((k (get op :op)))
|
||||
(cond
|
||||
((= k "insert")
|
||||
(crdt-insert
|
||||
state
|
||||
(get op :id)
|
||||
(get op :type)
|
||||
(get op :pos)
|
||||
(get op :fields)
|
||||
(get op :ts)
|
||||
(get op :actor)))
|
||||
((= k "update")
|
||||
(crdt-update
|
||||
state
|
||||
(get op :id)
|
||||
(get op :field)
|
||||
(get op :value)
|
||||
(get op :ts)
|
||||
(get op :actor)))
|
||||
((= k "delete") (crdt-delete state (get op :id)))
|
||||
(else (error (str "unknown crdt op: " k)))))))
|
||||
|
||||
(define
|
||||
crdt-apply-all
|
||||
(fn
|
||||
(state ops)
|
||||
(if
|
||||
(= (len ops) 0)
|
||||
state
|
||||
(crdt-apply-all (crdt-apply state (first ops)) (rest ops)))))
|
||||
|
||||
;; ── materialise to a Phase-1 document ──
|
||||
(define
|
||||
crdt-elements-list
|
||||
(fn
|
||||
(state)
|
||||
(map
|
||||
(fn (id) (get (get state :elements) id))
|
||||
(keys (get state :elements)))))
|
||||
|
||||
(define
|
||||
crdt-live?
|
||||
(fn
|
||||
(e)
|
||||
(and
|
||||
(= (get e :deleted) false)
|
||||
(if (= (get e :pos) nil) false true)
|
||||
(if (= (get e :type) nil) false true))))
|
||||
|
||||
(define
|
||||
crdt-live-elements
|
||||
(fn (state) (filter crdt-live? (crdt-elements-list state))))
|
||||
|
||||
(define
|
||||
crdt-insert-sorted
|
||||
(fn
|
||||
(e sorted)
|
||||
(cond
|
||||
((= (len sorted) 0) (list e))
|
||||
((< (crdt-pos-compare (get e :pos) (get (first sorted) :pos)) 0)
|
||||
(cons e sorted))
|
||||
(else (cons (first sorted) (crdt-insert-sorted e (rest sorted)))))))
|
||||
|
||||
(define
|
||||
crdt-sort-by-pos
|
||||
(fn
|
||||
(elems)
|
||||
(if
|
||||
(= (len elems) 0)
|
||||
(list)
|
||||
(crdt-insert-sorted (first elems) (crdt-sort-by-pos (rest elems))))))
|
||||
|
||||
(define
|
||||
crdt-field-pairs
|
||||
(fn
|
||||
(fields)
|
||||
(map (fn (nm) (list nm (get (get fields nm) :value))) (keys fields))))
|
||||
|
||||
(define
|
||||
crdt-element->block
|
||||
(fn
|
||||
(e)
|
||||
(mk-block (get e :type) (get e :id) (crdt-field-pairs (get e :fields)))))
|
||||
|
||||
(define
|
||||
crdt-order
|
||||
(fn
|
||||
(state)
|
||||
(map
|
||||
(fn (e) (get e :id))
|
||||
(crdt-sort-by-pos (crdt-live-elements state)))))
|
||||
|
||||
(define
|
||||
crdt-materialize
|
||||
(fn
|
||||
(doc-id state)
|
||||
(doc-new
|
||||
doc-id
|
||||
(map crdt-element->block (crdt-sort-by-pos (crdt-live-elements state))))))
|
||||
@@ -1,79 +0,0 @@
|
||||
;; content-on-sx — portable data serialization.
|
||||
;;
|
||||
;; Converts documents to/from a plain SX data form, decoupling storage and
|
||||
;; transport from the Smalltalk instance shape. A document becomes
|
||||
;; {:id :title :slug :tags :blocks (list block-data)}
|
||||
;; and a block becomes {:id :type :fields {...}} (section children recurse).
|
||||
;; content/from-data reconstructs real block objects.
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx, meta.sx, section.sx
|
||||
;; (mk-section), table.sx (mk-table).
|
||||
|
||||
;; ── to-data ──
|
||||
(define
|
||||
content/-fd-loop
|
||||
(fn
|
||||
(ks ivs acc)
|
||||
(if
|
||||
(= (len ks) 0)
|
||||
acc
|
||||
(let
|
||||
((k (first ks)))
|
||||
(if
|
||||
(= k "id")
|
||||
(content/-fd-loop (rest ks) ivs acc)
|
||||
(content/-fd-loop
|
||||
(rest ks)
|
||||
ivs
|
||||
(assoc
|
||||
acc
|
||||
k
|
||||
(if
|
||||
(= k "children")
|
||||
(map block->data (get ivs k))
|
||||
(get ivs k)))))))))
|
||||
|
||||
(define block->data (fn (b) {:fields (content/-fd-loop (keys (get b :ivars)) (get b :ivars) {}) :id (blk-id b) :type (blk-type b)}))
|
||||
|
||||
(define content/to-data (fn (doc) {:blocks (map block->data (doc-blocks doc)) :slug (doc-slug doc) :id (doc-id doc) :title (doc-title doc) :tags (doc-tags doc)}))
|
||||
|
||||
;; ── from-data ──
|
||||
(define
|
||||
content/-field-pairs
|
||||
(fn (fields) (map (fn (k) (list k (get fields k))) (keys fields))))
|
||||
|
||||
(define
|
||||
data->block
|
||||
(fn
|
||||
(d)
|
||||
(let
|
||||
((type (get d :type)) (id (get d :id)) (fields (get d :fields)))
|
||||
(cond
|
||||
((= type "section")
|
||||
(mk-section id (map data->block (get fields "children"))))
|
||||
((= type "table")
|
||||
(mk-table id (get fields "headers") (get fields "rows")))
|
||||
(else (mk-block type id (content/-field-pairs fields)))))))
|
||||
|
||||
(define
|
||||
content/-meta-of
|
||||
(fn
|
||||
(data)
|
||||
(let
|
||||
((m1 (if (= (get data :title) nil) {} (assoc {} :title (get data :title)))))
|
||||
(let
|
||||
((m2 (if (= (get data :slug) nil) m1 (assoc m1 :slug (get data :slug)))))
|
||||
(let
|
||||
((tags (get data :tags)))
|
||||
(if
|
||||
(or (= tags nil) (= (len tags) 0))
|
||||
m2
|
||||
(assoc m2 :tags tags)))))))
|
||||
|
||||
(define
|
||||
content/from-data
|
||||
(fn
|
||||
(data)
|
||||
(doc-with-meta
|
||||
(doc-new (get data :id) (map data->block (get data :blocks)))
|
||||
(content/-meta-of data))))
|
||||
@@ -1,203 +0,0 @@
|
||||
;; content-on-sx — ordered block document on Smalltalk-on-SX.
|
||||
;;
|
||||
;; A document (CtDoc) is a Smalltalk object holding an ordered sequence of block
|
||||
;; objects. Editing is a stream of ops (data dicts); doc-apply interprets one op
|
||||
;; and returns a NEW document — the input is never mutated, so any version is the
|
||||
;; head of an op stream (replay-friendly for persist + CRDT merge).
|
||||
;;
|
||||
;; CtDoc also carries optional metadata (title/slug/tags) — see meta.sx for the
|
||||
;; ergonomic API; they default nil and do not affect block operations.
|
||||
;;
|
||||
;; Op shapes (data, not objects — they are the persist event payload):
|
||||
;; {:op "insert" :block <blk> :after <id|nil>} ; after nil = prepend
|
||||
;; {:op "update" :id <id> :field <name> :value <v>}
|
||||
;; {:op "move" :id <id> :index <n>}
|
||||
;; {:op "delete" :id <id>}
|
||||
|
||||
(define
|
||||
content-bootstrap-doc!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(st-class-define!
|
||||
"CtDoc"
|
||||
"Object"
|
||||
(list "id" "blocks" "title" "slug" "tags"))
|
||||
(ct-def-method! "CtDoc" "id" "id ^ id")
|
||||
(ct-def-method! "CtDoc" "blocks" "blocks ^ blocks")
|
||||
(ct-def-method! "CtDoc" "type" "type ^ #document")
|
||||
(ct-def-method! "CtDoc" "title" "title ^ title")
|
||||
(ct-def-method! "CtDoc" "slug" "slug ^ slug")
|
||||
(ct-def-method! "CtDoc" "tags" "tags ^ tags")
|
||||
true)))
|
||||
|
||||
;; ── construction ──
|
||||
(define
|
||||
doc-new
|
||||
(fn
|
||||
(id blocks)
|
||||
(st-iv-set!
|
||||
(st-iv-set! (st-make-instance "CtDoc") "id" id)
|
||||
"blocks"
|
||||
blocks)))
|
||||
|
||||
(define doc-empty (fn (id) (doc-new id (list))))
|
||||
|
||||
;; ── accessors (message dispatch) ──
|
||||
(define doc-id (fn (doc) (st-send doc "id" (list))))
|
||||
(define doc-type (fn (doc) (str (st-send doc "type" (list)))))
|
||||
(define doc-blocks (fn (doc) (st-send doc "blocks" (list))))
|
||||
(define doc-count (fn (doc) (len (doc-blocks doc))))
|
||||
(define doc-block-at (fn (doc i) (nth (doc-blocks doc) i)))
|
||||
|
||||
(define doc? (fn (v) (and (st-instance? v) (= (get v :class) "CtDoc"))))
|
||||
|
||||
;; ── list helpers over block sequences ──
|
||||
(define
|
||||
ct-index-loop
|
||||
(fn
|
||||
(blocks id i)
|
||||
(cond
|
||||
((= (len blocks) 0) -1)
|
||||
((= (blk-id (first blocks)) id) i)
|
||||
(else (ct-index-loop (rest blocks) id (+ i 1))))))
|
||||
|
||||
(define ct-index-of (fn (blocks id) (ct-index-loop blocks id 0)))
|
||||
|
||||
(define
|
||||
ct-insert-at
|
||||
(fn
|
||||
(blocks i x)
|
||||
(cond
|
||||
((= i 0) (cons x blocks))
|
||||
((= (len blocks) 0) (list x))
|
||||
(else
|
||||
(cons
|
||||
(first blocks)
|
||||
(ct-insert-at (rest blocks) (- i 1) x))))))
|
||||
|
||||
(define
|
||||
ct-remove-id
|
||||
(fn
|
||||
(blocks id)
|
||||
(filter (fn (b) (if (= (blk-id b) id) false true)) blocks)))
|
||||
|
||||
(define
|
||||
ct-replace-id
|
||||
(fn
|
||||
(blocks id f)
|
||||
(map (fn (b) (if (= (blk-id b) id) (f b) b)) blocks)))
|
||||
|
||||
;; ── query ──
|
||||
(define doc-index-of (fn (doc id) (ct-index-of (doc-blocks doc) id)))
|
||||
|
||||
(define
|
||||
doc-find
|
||||
(fn
|
||||
(doc id)
|
||||
(let
|
||||
((hits (filter (fn (b) (= (blk-id b) id)) (doc-blocks doc))))
|
||||
(if (= (len hits) 0) nil (first hits)))))
|
||||
|
||||
(define
|
||||
doc-has?
|
||||
(fn (doc id) (if (= (doc-index-of doc id) -1) false true)))
|
||||
|
||||
;; ── structural edits (each returns a new document) ──
|
||||
(define doc-with-blocks (fn (doc blocks) (st-iv-set! doc "blocks" blocks)))
|
||||
|
||||
(define
|
||||
doc-append
|
||||
(fn
|
||||
(doc block)
|
||||
(doc-with-blocks doc (append (doc-blocks doc) (list block)))))
|
||||
|
||||
(define
|
||||
doc-insert-at
|
||||
(fn
|
||||
(doc block i)
|
||||
(doc-with-blocks doc (ct-insert-at (doc-blocks doc) i block))))
|
||||
|
||||
(define
|
||||
doc-insert-after
|
||||
(fn
|
||||
(doc block after-id)
|
||||
(let
|
||||
((blocks (doc-blocks doc)))
|
||||
(if
|
||||
(= after-id nil)
|
||||
(doc-with-blocks doc (cons block blocks))
|
||||
(let
|
||||
((idx (ct-index-of blocks after-id)))
|
||||
(if
|
||||
(= idx -1)
|
||||
(doc-with-blocks doc (append blocks (list block)))
|
||||
(doc-with-blocks
|
||||
doc
|
||||
(ct-insert-at blocks (+ idx 1) block))))))))
|
||||
|
||||
(define
|
||||
doc-update
|
||||
(fn
|
||||
(doc id field value)
|
||||
(doc-with-blocks
|
||||
doc
|
||||
(ct-replace-id (doc-blocks doc) id (fn (b) (blk-set b field value))))))
|
||||
|
||||
(define
|
||||
doc-delete
|
||||
(fn (doc id) (doc-with-blocks doc (ct-remove-id (doc-blocks doc) id))))
|
||||
|
||||
(define
|
||||
doc-move
|
||||
(fn
|
||||
(doc id i)
|
||||
(let
|
||||
((blk (doc-find doc id)))
|
||||
(if
|
||||
(= blk nil)
|
||||
doc
|
||||
(doc-with-blocks
|
||||
doc
|
||||
(ct-insert-at (ct-remove-id (doc-blocks doc) id) i blk))))))
|
||||
|
||||
;; ── op constructors (data payload, reused by persist op log) ──
|
||||
(define op-insert (fn (block after) {:after after :op "insert" :block block}))
|
||||
|
||||
(define op-update (fn (id field value) {:field field :id id :op "update" :value value}))
|
||||
|
||||
(define op-move (fn (id index) {:id id :op "move" :index index}))
|
||||
|
||||
(define op-delete (fn (id) {:id id :op "delete"}))
|
||||
|
||||
;; ── op interpreter ──
|
||||
(define
|
||||
doc-apply
|
||||
(fn
|
||||
(doc op)
|
||||
(let
|
||||
((kind (get op :op)))
|
||||
(cond
|
||||
((= kind "insert")
|
||||
(doc-insert-after doc (get op :block) (get op :after)))
|
||||
((= kind "update")
|
||||
(doc-update doc (get op :id) (get op :field) (get op :value)))
|
||||
((= kind "move") (doc-move doc (get op :id) (get op :index)))
|
||||
((= kind "delete") (doc-delete doc (get op :id)))
|
||||
(else (error (str "unknown op: " kind)))))))
|
||||
|
||||
(define
|
||||
doc-apply-all
|
||||
(fn
|
||||
(doc ops)
|
||||
(if
|
||||
(= (len ops) 0)
|
||||
doc
|
||||
(doc-apply-all (doc-apply doc (first ops)) (rest ops)))))
|
||||
|
||||
;; ── render-agnostic snapshot: list of (id . type) for assertions/debug ──
|
||||
(define doc-ids (fn (doc) (map (fn (b) (blk-id b)) (doc-blocks doc))))
|
||||
|
||||
(define
|
||||
doc-types
|
||||
(fn (doc) (map (fn (b) (blk-type b)) (doc-blocks doc))))
|
||||
@@ -1,68 +0,0 @@
|
||||
;; content-on-sx — federated documents: trust-gated peer-authored ops.
|
||||
;;
|
||||
;; A peer-authored op carries provenance (:author, and a :sig stub). We never
|
||||
;; auto-accept: a peer op is applied only if it passes a trust gate. The gate is
|
||||
;; a predicate (fn op -> bool) so acl-on-sx can inject real trust facts later;
|
||||
;; the convenience form takes an explicit trusted-actor list (the stub).
|
||||
;;
|
||||
;; Accepted ops flow through the CvRDT merge (Phase 3), so concurrent local and
|
||||
;; external edits reconcile deterministically (same-field LWW, order-independent).
|
||||
;;
|
||||
;; Requires (loaded by harness): crdt.sx (and its deps).
|
||||
|
||||
;; tag an op with provenance
|
||||
(define content/authored (fn (op author) (assoc op :author author)))
|
||||
|
||||
(define
|
||||
content/signed
|
||||
(fn (op author sig) (assoc (assoc op :author author) :sig sig)))
|
||||
|
||||
;; explicit trust stub: membership in a trusted-actor list
|
||||
(define content/trusted? (fn (trust author) (crdt-member? author trust)))
|
||||
|
||||
;; general form: accept? is a predicate (fn op -> bool). Applies accepted ops
|
||||
;; through the CRDT; quarantines the rest. Returns
|
||||
;; {:state :accepted (ops) :rejected (ops)}.
|
||||
(define
|
||||
content/-merge-peer-loop
|
||||
(fn
|
||||
(state accept? ops accepted rejected)
|
||||
(if
|
||||
(= (len ops) 0)
|
||||
{:state state :accepted (reverse accepted) :rejected (reverse rejected)}
|
||||
(let
|
||||
((op (first ops)))
|
||||
(if
|
||||
(accept? op)
|
||||
(content/-merge-peer-loop
|
||||
(crdt-apply state op)
|
||||
accept?
|
||||
(rest ops)
|
||||
(cons op accepted)
|
||||
rejected)
|
||||
(content/-merge-peer-loop
|
||||
state
|
||||
accept?
|
||||
(rest ops)
|
||||
accepted
|
||||
(cons op rejected)))))))
|
||||
|
||||
(define
|
||||
content/merge-peer-with
|
||||
(fn
|
||||
(state accept? ops)
|
||||
(content/-merge-peer-loop state accept? ops (list) (list))))
|
||||
|
||||
;; convenience: trust = list of trusted actor ids
|
||||
(define
|
||||
content/merge-peer
|
||||
(fn
|
||||
(state trust ops)
|
||||
(content/merge-peer-with
|
||||
state
|
||||
(fn (op) (content/trusted? trust (get op :author)))
|
||||
ops)))
|
||||
|
||||
(define content/accepted (fn (res) (get res :accepted)))
|
||||
(define content/rejected (fn (res) (get res :rejected)))
|
||||
(define content/peer-state (fn (res) (get res :state)))
|
||||
@@ -1,31 +0,0 @@
|
||||
;; content-on-sx — global find/replace across text-bearing blocks.
|
||||
;;
|
||||
;; Replaces every occurrence of `from` with `to` in the text field of text /
|
||||
;; heading / code / quote blocks, tree-wide (via the transform layer). For
|
||||
;; renaming a term throughout a document. Immutable; case-sensitive.
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, transform.sx (content/map-blocks).
|
||||
|
||||
(define
|
||||
fr-in?
|
||||
(fn
|
||||
(x xs)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((= (first xs) x) true)
|
||||
(else (fr-in? x (rest xs))))))
|
||||
|
||||
(define
|
||||
fr-has-text?
|
||||
(fn (b) (fr-in? (blk-type b) (list "text" "heading" "code" "quote"))))
|
||||
|
||||
(define
|
||||
content/find-replace
|
||||
(fn
|
||||
(doc from to)
|
||||
(content/map-blocks
|
||||
doc
|
||||
fr-has-text?
|
||||
(fn
|
||||
(b)
|
||||
(blk-set b "text" (replace (str (blk-get b "text")) from to))))))
|
||||
@@ -1,34 +0,0 @@
|
||||
;; content-on-sx — document flatten.
|
||||
;;
|
||||
;; Un-nests a sectioned document into a flat block sequence: each section is
|
||||
;; replaced inline by its (recursively flattened) children, dropping the section
|
||||
;; wrapper. The inverse of content/wrap-section, for flat export targets.
|
||||
;; Immutable; inline tree handling (no section.sx dep).
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx.
|
||||
|
||||
(define
|
||||
flat-section?
|
||||
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
|
||||
|
||||
(define
|
||||
flat-blocks
|
||||
(fn
|
||||
(blocks)
|
||||
(if
|
||||
(= (len blocks) 0)
|
||||
(list)
|
||||
(let
|
||||
((b (first blocks)))
|
||||
(append
|
||||
(if
|
||||
(flat-section? b)
|
||||
(let
|
||||
((ch (st-iv-get b "children")))
|
||||
(if (list? ch) (flat-blocks ch) (list)))
|
||||
(list b))
|
||||
(flat-blocks (rest blocks)))))))
|
||||
|
||||
(define
|
||||
content/flatten
|
||||
(fn (doc) (doc-with-blocks doc (flat-blocks (doc-blocks doc)))))
|
||||
@@ -1,51 +0,0 @@
|
||||
;; content-on-sx — multi-document index.
|
||||
;;
|
||||
;; Projects a list of documents into summary cards (the blog index page), with
|
||||
;; tag filtering (category pages) and a tag cloud. Composes content/summary +
|
||||
;; doc metadata.
|
||||
;;
|
||||
;; Requires (loaded by harness): summary.sx (content/summary), meta.sx (doc-tags).
|
||||
|
||||
(define
|
||||
idx-in?
|
||||
(fn
|
||||
(x xs)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((= (first xs) x) true)
|
||||
(else (idx-in? x (rest xs))))))
|
||||
|
||||
(define
|
||||
idx-dedup
|
||||
(fn
|
||||
(xs seen)
|
||||
(if
|
||||
(= (len xs) 0)
|
||||
(reverse seen)
|
||||
(if
|
||||
(idx-in? (first xs) seen)
|
||||
(idx-dedup (rest xs) seen)
|
||||
(idx-dedup (rest xs) (cons (first xs) seen))))))
|
||||
|
||||
(define content/index (fn (docs) (map content/summary docs)))
|
||||
|
||||
(define content/has-tag? (fn (doc tag) (idx-in? tag (doc-tags doc))))
|
||||
|
||||
(define
|
||||
content/index-by-tag
|
||||
(fn
|
||||
(docs tag)
|
||||
(map content/summary (filter (fn (d) (content/has-tag? d tag)) docs))))
|
||||
|
||||
(define
|
||||
content/all-tags
|
||||
(fn (docs) (idx-dedup (ct-flatmap-tags docs) (list))))
|
||||
|
||||
(define
|
||||
ct-flatmap-tags
|
||||
(fn
|
||||
(docs)
|
||||
(if
|
||||
(= (len docs) 0)
|
||||
(list)
|
||||
(append (doc-tags (first docs)) (ct-flatmap-tags (rest docs))))))
|
||||
@@ -1,55 +0,0 @@
|
||||
;; content-on-sx — Markdown render mode.
|
||||
;;
|
||||
;; A third boundary format alongside asHTML / asSx, via the same polymorphic
|
||||
;; dispatch. The newline is supplied by the boundary as a keyword arg
|
||||
;; (asMarkdown: nl) because this Smalltalk dialect has no Character newline
|
||||
;; constructor — blocks that need internal newlines (code, lists, doc) use it.
|
||||
;;
|
||||
;; No Markdown escaping yet (Markdown's escaping rules differ from HTML); raw
|
||||
;; text is emitted. Ordered lists emit "1." for every item (Markdown renumbers).
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx.
|
||||
|
||||
(define
|
||||
content-bootstrap-markdown!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(ct-def-method!
|
||||
"CtHeading"
|
||||
"asMarkdown:"
|
||||
"asMarkdown: nl | h i | h := ''. i := 0. [i < level] whileTrue: [h := h , '#'. i := i + 1]. ^ h , ' ' , text")
|
||||
(ct-def-method! "CtText" "asMarkdown:" "asMarkdown: nl ^ text")
|
||||
(ct-def-method!
|
||||
"CtCode"
|
||||
"asMarkdown:"
|
||||
"asMarkdown: nl ^ '```' , language , nl , text , nl , '```'")
|
||||
(ct-def-method! "CtQuote" "asMarkdown:" "asMarkdown: nl ^ '> ' , text")
|
||||
(ct-def-method!
|
||||
"CtImage"
|
||||
"asMarkdown:"
|
||||
"asMarkdown: nl ^ ''")
|
||||
(ct-def-method!
|
||||
"CtEmbed"
|
||||
"asMarkdown:"
|
||||
"asMarkdown: nl ^ '[embed](' , url , ')'")
|
||||
(ct-def-method! "CtDivider" "asMarkdown:" "asMarkdown: nl ^ '---'")
|
||||
(ct-def-method!
|
||||
"CtList"
|
||||
"asMarkdown:"
|
||||
"asMarkdown: nl | mark | mark := ordered ifTrue: ['1. '] ifFalse: ['- ']. ^ (items inject: '' into: [:a :x | a , (a = '' ifTrue: [''] ifFalse: [nl]) , mark , x])")
|
||||
(ct-def-method!
|
||||
"CtDoc"
|
||||
"asMarkdown:"
|
||||
"asMarkdown: nl ^ (blocks inject: '' into: [:a :b | a , (a = '' ifTrue: [''] ifFalse: [nl , nl]) , (b asMarkdown: nl)])")
|
||||
true)))
|
||||
|
||||
(define ct-nl (str "\n"))
|
||||
|
||||
;; ── SX boundary ──
|
||||
(define
|
||||
asMarkdown
|
||||
(fn (node) (str (st-send node "asMarkdown:" (list ct-nl)))))
|
||||
(define content/markdown asMarkdown)
|
||||
(define render-markdown asMarkdown)
|
||||
(define block-markdown asMarkdown)
|
||||
@@ -1,63 +0,0 @@
|
||||
;; content-on-sx — Markdown document export (frontmatter + body).
|
||||
;;
|
||||
;; content/markdown-doc emits a YAML-ish --- frontmatter block from the document
|
||||
;; metadata (title/slug/tags) followed by the Markdown body, completing the
|
||||
;; metadata round-trip with md/import (md/import ∘ content/markdown-doc keeps
|
||||
;; title/slug/tags). With no metadata it is just asMarkdown.
|
||||
;;
|
||||
;; Requires (loaded by harness): doc.sx, meta.sx (doc-title/slug/tags),
|
||||
;; markdown.sx (asMarkdown).
|
||||
|
||||
(define mdd-nl (str "\n"))
|
||||
|
||||
(define
|
||||
mdd-join
|
||||
(fn
|
||||
(sep parts)
|
||||
(cond
|
||||
((= (len parts) 0) "")
|
||||
((= (len parts) 1) (first parts))
|
||||
(else (str (first parts) sep (mdd-join sep (rest parts)))))))
|
||||
|
||||
(define
|
||||
content/-fm-parts
|
||||
(fn
|
||||
(doc)
|
||||
(append
|
||||
(append
|
||||
(if
|
||||
(= (doc-title doc) nil)
|
||||
(list)
|
||||
(list (str "title: " (doc-title doc))))
|
||||
(if
|
||||
(= (doc-slug doc) nil)
|
||||
(list)
|
||||
(list (str "slug: " (doc-slug doc)))))
|
||||
(let
|
||||
((tags (doc-tags doc)))
|
||||
(if
|
||||
(= (len tags) 0)
|
||||
(list)
|
||||
(list (str "tags: " (mdd-join ", " tags))))))))
|
||||
|
||||
(define
|
||||
content/-frontmatter
|
||||
(fn
|
||||
(doc)
|
||||
(let
|
||||
((parts (content/-fm-parts doc)))
|
||||
(if
|
||||
(= (len parts) 0)
|
||||
""
|
||||
(str "---" mdd-nl (mdd-join mdd-nl parts) mdd-nl "---")))))
|
||||
|
||||
(define
|
||||
content/markdown-doc
|
||||
(fn
|
||||
(doc)
|
||||
(let
|
||||
((fm (content/-frontmatter doc)))
|
||||
(if
|
||||
(= fm "")
|
||||
(asMarkdown doc)
|
||||
(str fm mdd-nl mdd-nl (asMarkdown doc))))))
|
||||
@@ -1,449 +0,0 @@
|
||||
;; content-on-sx — Markdown import adapter (markdown text -> block document).
|
||||
;;
|
||||
;; A line-based parser, the inverse of markdown.sx's asMarkdown. Confined to the
|
||||
;; adapter boundary: the core knows nothing about Markdown. Handles a leading
|
||||
;; --- frontmatter block (key: value -> doc metadata), ATX headings (#..######),
|
||||
;; fenced code (```lang), blockquotes (> ), unordered (- / * ) and ordered (1. )
|
||||
;; lists, thematic breaks (--- / ***), pipe tables (header + --- separator +
|
||||
;; body), and paragraphs (consecutive plain lines joined with a space). Block ids
|
||||
;; are assigned sequentially b0,b1…
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx, table.sx (mk-table),
|
||||
;; meta.sx (doc-with-meta); markdown.sx for the adapter's export side.
|
||||
|
||||
(define md/-id (fn (i) (str "b" i)))
|
||||
(define md/-blank? (fn (s) (= s "")))
|
||||
(define md/-hr? (fn (s) (if (= s "---") true (= s "***"))))
|
||||
|
||||
(define
|
||||
ct-in?
|
||||
(fn
|
||||
(x xs)
|
||||
(cond
|
||||
((= (len xs) 0) false)
|
||||
((= (first xs) x) true)
|
||||
(else (ct-in? x (rest xs))))))
|
||||
|
||||
(define
|
||||
ct-starts-with?
|
||||
(fn
|
||||
(s prefix)
|
||||
(and
|
||||
(>= (string-length s) (string-length prefix))
|
||||
(= (substring s 0 (string-length prefix)) prefix))))
|
||||
|
||||
(define
|
||||
md/-drop
|
||||
(fn (s prefix) (substring s (string-length prefix) (string-length s))))
|
||||
|
||||
(define
|
||||
md/-drop-n
|
||||
(fn
|
||||
(xs n)
|
||||
(if
|
||||
(= n 0)
|
||||
xs
|
||||
(if
|
||||
(= (len xs) 0)
|
||||
xs
|
||||
(md/-drop-n (rest xs) (- n 1))))))
|
||||
|
||||
(define
|
||||
md/-join-with
|
||||
(fn
|
||||
(sep parts)
|
||||
(cond
|
||||
((= (len parts) 0) "")
|
||||
((= (len parts) 1) (first parts))
|
||||
(else (str (first parts) sep (md/-join-with sep (rest parts)))))))
|
||||
(define md/-join-sp (fn (parts) (md/-join-with " " parts)))
|
||||
(define md/-join-nl (fn (parts) (md/-join-with (str "\n") parts)))
|
||||
|
||||
;; ── heading detection (leading #s then a space) ──
|
||||
(define
|
||||
md/-hashes
|
||||
(fn
|
||||
(s n)
|
||||
(if
|
||||
(and
|
||||
(< n (string-length s))
|
||||
(= (substring s n (+ n 1)) "#"))
|
||||
(md/-hashes s (+ n 1))
|
||||
n)))
|
||||
(define
|
||||
md/-heading?
|
||||
(fn
|
||||
(line)
|
||||
(let
|
||||
((n (md/-hashes line 0)))
|
||||
(and
|
||||
(> n 0)
|
||||
(<= n 6)
|
||||
(> (string-length line) n)
|
||||
(= (substring line n (+ n 1)) " ")))))
|
||||
(define
|
||||
md/-heading-block
|
||||
(fn
|
||||
(line i)
|
||||
(let
|
||||
((n (md/-hashes line 0)))
|
||||
(mk-heading
|
||||
(md/-id i)
|
||||
n
|
||||
(substring line (+ n 1) (string-length line))))))
|
||||
|
||||
;; ── list detection ──
|
||||
(define
|
||||
ct-digit?
|
||||
(fn (ch) (ct-in? ch (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))))
|
||||
(define
|
||||
md/-digits
|
||||
(fn
|
||||
(s n)
|
||||
(if
|
||||
(and
|
||||
(< n (string-length s))
|
||||
(ct-digit? (substring s n (+ n 1))))
|
||||
(md/-digits s (+ n 1))
|
||||
n)))
|
||||
(define
|
||||
md/-ol?
|
||||
(fn
|
||||
(line)
|
||||
(let
|
||||
((n (md/-digits line 0)))
|
||||
(and
|
||||
(> n 0)
|
||||
(>= (string-length line) (+ n 2))
|
||||
(= (substring line n (+ n 2)) ". ")))))
|
||||
(define
|
||||
md/-drop-ol
|
||||
(fn
|
||||
(line)
|
||||
(let
|
||||
((n (md/-digits line 0)))
|
||||
(substring line (+ n 2) (string-length line)))))
|
||||
(define
|
||||
md/-ul?
|
||||
(fn
|
||||
(line)
|
||||
(if (ct-starts-with? line "- ") true (ct-starts-with? line "* "))))
|
||||
(define
|
||||
md/-drop-ul
|
||||
(fn (line) (substring line 2 (string-length line))))
|
||||
|
||||
;; ── table detection ──
|
||||
(define md/-pipe-row? (fn (line) (ct-starts-with? (trim line) "|")))
|
||||
(define md/-sep-char? (fn (ch) (ct-in? ch (list "-" ":" "|" " "))))
|
||||
(define
|
||||
md/-all-sep?
|
||||
(fn
|
||||
(s i)
|
||||
(if
|
||||
(>= i (string-length s))
|
||||
true
|
||||
(if
|
||||
(md/-sep-char? (substring s i (+ i 1)))
|
||||
(md/-all-sep? s (+ i 1))
|
||||
false))))
|
||||
(define
|
||||
md/-has-dash?
|
||||
(fn
|
||||
(s i)
|
||||
(if
|
||||
(>= i (string-length s))
|
||||
false
|
||||
(if
|
||||
(= (substring s i (+ i 1)) "-")
|
||||
true
|
||||
(md/-has-dash? s (+ i 1))))))
|
||||
(define
|
||||
md/-sep-row?
|
||||
(fn
|
||||
(line)
|
||||
(and
|
||||
(md/-pipe-row? line)
|
||||
(md/-all-sep? (trim line) 0)
|
||||
(md/-has-dash? line 0))))
|
||||
(define
|
||||
md/-table-start?
|
||||
(fn
|
||||
(lines)
|
||||
(and
|
||||
(md/-pipe-row? (first lines))
|
||||
(> (len lines) 1)
|
||||
(md/-sep-row? (nth lines 1)))))
|
||||
(define
|
||||
md/-strip-pipes
|
||||
(fn
|
||||
(s0)
|
||||
(let
|
||||
((s (trim s0)))
|
||||
(let
|
||||
((a (if (ct-starts-with? s "|") (substring s 1 (string-length s)) s)))
|
||||
(if
|
||||
(and
|
||||
(> (string-length a) 0)
|
||||
(=
|
||||
(substring
|
||||
a
|
||||
(- (string-length a) 1)
|
||||
(string-length a))
|
||||
"|"))
|
||||
(substring a 0 (- (string-length a) 1))
|
||||
a)))))
|
||||
(define
|
||||
md/-cells
|
||||
(fn (line) (map (fn (c) (trim c)) (split (md/-strip-pipes line) "|"))))
|
||||
|
||||
(define
|
||||
md/-plain?
|
||||
(fn
|
||||
(line)
|
||||
(if
|
||||
(md/-blank? line)
|
||||
false
|
||||
(if
|
||||
(ct-starts-with? line "```")
|
||||
false
|
||||
(if
|
||||
(md/-heading? line)
|
||||
false
|
||||
(if
|
||||
(ct-starts-with? line "> ")
|
||||
false
|
||||
(if
|
||||
(md/-hr? line)
|
||||
false
|
||||
(if (md/-ul? line) false (if (md/-ol? line) false true)))))))))
|
||||
|
||||
;; ── multi-line collectors ──
|
||||
(define
|
||||
md/-code
|
||||
(fn
|
||||
(lines i acc)
|
||||
(md/-code-collect
|
||||
(rest lines)
|
||||
(md/-drop (first lines) "```")
|
||||
(list)
|
||||
i
|
||||
acc)))
|
||||
(define
|
||||
md/-code-collect
|
||||
(fn
|
||||
(lines lang body i acc)
|
||||
(cond
|
||||
((= (len lines) 0)
|
||||
(md/-walk
|
||||
lines
|
||||
(+ i 1)
|
||||
(cons (mk-code (md/-id i) lang (md/-join-nl (reverse body))) acc)))
|
||||
((= (first lines) "```")
|
||||
(md/-walk
|
||||
(rest lines)
|
||||
(+ i 1)
|
||||
(cons (mk-code (md/-id i) lang (md/-join-nl (reverse body))) acc)))
|
||||
(else
|
||||
(md/-code-collect (rest lines) lang (cons (first lines) body) i acc)))))
|
||||
|
||||
(define
|
||||
md/-table-body
|
||||
(fn
|
||||
(lines headers rows i acc)
|
||||
(if
|
||||
(= (len lines) 0)
|
||||
(md/-walk
|
||||
lines
|
||||
(+ i 1)
|
||||
(cons (mk-table (md/-id i) headers (reverse rows)) acc))
|
||||
(let
|
||||
((line (first lines)))
|
||||
(if
|
||||
(md/-pipe-row? line)
|
||||
(md/-table-body
|
||||
(rest lines)
|
||||
headers
|
||||
(cons (md/-cells line) rows)
|
||||
i
|
||||
acc)
|
||||
(md/-walk
|
||||
lines
|
||||
(+ i 1)
|
||||
(cons (mk-table (md/-id i) headers (reverse rows)) acc)))))))
|
||||
(define
|
||||
md/-table
|
||||
(fn
|
||||
(lines i acc)
|
||||
(md/-table-body
|
||||
(rest (rest lines))
|
||||
(md/-cells (first lines))
|
||||
(list)
|
||||
i
|
||||
acc)))
|
||||
|
||||
(define
|
||||
md/-list-collect
|
||||
(fn
|
||||
(lines items i acc ordered)
|
||||
(if
|
||||
(= (len lines) 0)
|
||||
(md/-walk
|
||||
lines
|
||||
(+ i 1)
|
||||
(cons (mk-list (md/-id i) ordered (reverse items)) acc))
|
||||
(let
|
||||
((line (first lines)))
|
||||
(cond
|
||||
(ordered
|
||||
(if
|
||||
(md/-ol? line)
|
||||
(md/-list-collect
|
||||
(rest lines)
|
||||
(cons (md/-drop-ol line) items)
|
||||
i
|
||||
acc
|
||||
ordered)
|
||||
(md/-walk
|
||||
lines
|
||||
(+ i 1)
|
||||
(cons (mk-list (md/-id i) ordered (reverse items)) acc))))
|
||||
(else
|
||||
(if
|
||||
(md/-ul? line)
|
||||
(md/-list-collect
|
||||
(rest lines)
|
||||
(cons (md/-drop-ul line) items)
|
||||
i
|
||||
acc
|
||||
ordered)
|
||||
(md/-walk
|
||||
lines
|
||||
(+ i 1)
|
||||
(cons (mk-list (md/-id i) ordered (reverse items)) acc)))))))))
|
||||
|
||||
(define
|
||||
md/-para-collect
|
||||
(fn
|
||||
(lines parts i acc)
|
||||
(if
|
||||
(= (len lines) 0)
|
||||
(md/-walk
|
||||
lines
|
||||
(+ i 1)
|
||||
(cons (mk-text (md/-id i) (md/-join-sp (reverse parts))) acc))
|
||||
(let
|
||||
((line (first lines)))
|
||||
(if
|
||||
(md/-plain? line)
|
||||
(md/-para-collect (rest lines) (cons line parts) i acc)
|
||||
(md/-walk
|
||||
lines
|
||||
(+ i 1)
|
||||
(cons (mk-text (md/-id i) (md/-join-sp (reverse parts))) acc)))))))
|
||||
|
||||
;; ── main walk ──
|
||||
(define
|
||||
md/-walk
|
||||
(fn
|
||||
(lines i acc)
|
||||
(if
|
||||
(= (len lines) 0)
|
||||
(reverse acc)
|
||||
(let
|
||||
((line (first lines)))
|
||||
(cond
|
||||
((md/-blank? line) (md/-walk (rest lines) i acc))
|
||||
((ct-starts-with? line "```") (md/-code lines i acc))
|
||||
((md/-heading? line)
|
||||
(md/-walk
|
||||
(rest lines)
|
||||
(+ i 1)
|
||||
(cons (md/-heading-block line i) acc)))
|
||||
((ct-starts-with? line "> ")
|
||||
(md/-walk
|
||||
(rest lines)
|
||||
(+ i 1)
|
||||
(cons (mk-quote (md/-id i) "" (md/-drop line "> ")) acc)))
|
||||
((md/-hr? line)
|
||||
(md/-walk
|
||||
(rest lines)
|
||||
(+ i 1)
|
||||
(cons (mk-divider (md/-id i)) acc)))
|
||||
((md/-table-start? lines) (md/-table lines i acc))
|
||||
((md/-ul? line) (md/-list-collect lines (list) i acc false))
|
||||
((md/-ol? line) (md/-list-collect lines (list) i acc true))
|
||||
(else (md/-para-collect lines (list) i acc)))))))
|
||||
|
||||
(define
|
||||
md/parse
|
||||
(fn (text) (md/-walk (split text (str "\n")) 0 (list))))
|
||||
|
||||
;; ── frontmatter (leading --- key: value --- block) ──
|
||||
(define
|
||||
md/-frontmatter?
|
||||
(fn (lines) (and (> (len lines) 0) (= (first lines) "---"))))
|
||||
(define
|
||||
md/-fm-end
|
||||
(fn
|
||||
(lines i)
|
||||
(cond
|
||||
((>= i (len lines)) -1)
|
||||
((= (nth lines i) "---") i)
|
||||
(else (md/-fm-end lines (+ i 1))))))
|
||||
(define
|
||||
md/-fm-add
|
||||
(fn
|
||||
(acc line)
|
||||
(let
|
||||
((parts (split line ":")))
|
||||
(if
|
||||
(< (len parts) 2)
|
||||
acc
|
||||
(let
|
||||
((key (trim (first parts)))
|
||||
(val (trim (md/-join-with ":" (rest parts)))))
|
||||
(cond
|
||||
((= key "title") (assoc acc :title val))
|
||||
((= key "slug") (assoc acc :slug val))
|
||||
((= key "tags")
|
||||
(assoc acc :tags (map (fn (t) (trim t)) (split val ","))))
|
||||
(else acc)))))))
|
||||
(define
|
||||
md/-fm-pairs
|
||||
(fn
|
||||
(lines start end acc)
|
||||
(if
|
||||
(>= start end)
|
||||
acc
|
||||
(md/-fm-pairs
|
||||
lines
|
||||
(+ start 1)
|
||||
end
|
||||
(md/-fm-add acc (nth lines start))))))
|
||||
|
||||
;; ── adapter ──
|
||||
(define
|
||||
md/import
|
||||
(fn
|
||||
(text doc-id)
|
||||
(let
|
||||
((lines (split text (str "\n"))))
|
||||
(if
|
||||
(md/-frontmatter? lines)
|
||||
(let
|
||||
((end (md/-fm-end lines 1)))
|
||||
(if
|
||||
(= end -1)
|
||||
(doc-new doc-id (md/-walk lines 0 (list)))
|
||||
(doc-with-meta
|
||||
(doc-new
|
||||
doc-id
|
||||
(md/-walk
|
||||
(md/-drop-n lines (+ end 1))
|
||||
0
|
||||
(list)))
|
||||
(md/-fm-pairs lines 1 end {}))))
|
||||
(doc-new doc-id (md/-walk lines 0 (list)))))))
|
||||
|
||||
(define content/from-markdown md/import)
|
||||
(define markdown-adapter {:export (fn (doc) (asMarkdown doc)) :import md/import})
|
||||
@@ -1,52 +0,0 @@
|
||||
;; content-on-sx — video/audio media block.
|
||||
;;
|
||||
;; CtMedia holds a `kind` (video/audio) and `src`. Self-contained: answers
|
||||
;; asHTML/asSx/asText/asMarkdown: so it composes with the render boundary with no
|
||||
;; changes elsewhere. HTML src is htmlEscaped, SX src sxEscaped.
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx, render.sx (escapers);
|
||||
;; markdown.sx / text.sx for those formats.
|
||||
|
||||
(define
|
||||
content-bootstrap-media!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(st-class-define! "CtMedia" "CtBlock" (list "kind" "src"))
|
||||
(ct-def-method! "CtMedia" "kind" "kind ^ kind")
|
||||
(ct-def-method! "CtMedia" "src" "src ^ src")
|
||||
(ct-def-method! "CtMedia" "type" "type ^ #media")
|
||||
(ct-def-method!
|
||||
"CtMedia"
|
||||
"asHTML"
|
||||
"asHTML ^ '<' , kind , ' src=\"' , src htmlEscaped , '\" controls></' , kind , '>'")
|
||||
(ct-def-method!
|
||||
"CtMedia"
|
||||
"asSx"
|
||||
"asSx ^ '(' , kind , ' :src \"' , src sxEscaped , '\")'")
|
||||
(ct-def-method! "CtMedia" "asText" "asText ^ ''")
|
||||
(ct-def-method!
|
||||
"CtMedia"
|
||||
"asMarkdown:"
|
||||
"asMarkdown: nl ^ '[' , kind , '](' , src , ')'")
|
||||
true)))
|
||||
|
||||
(define
|
||||
mk-media
|
||||
(fn
|
||||
(id kind src)
|
||||
(st-iv-set!
|
||||
(st-iv-set!
|
||||
(st-iv-set! (st-make-instance "CtMedia") "id" id)
|
||||
"kind"
|
||||
kind)
|
||||
"src"
|
||||
src)))
|
||||
|
||||
(define
|
||||
media?
|
||||
(fn (b) (and (st-instance? b) (= (get b :class) "CtMedia"))))
|
||||
(define media-kind (fn (b) (st-send b "kind" (list))))
|
||||
|
||||
(define mk-video (fn (id src) (mk-media id "video" src)))
|
||||
(define mk-audio (fn (id src) (mk-media id "audio" src)))
|
||||
@@ -1,53 +0,0 @@
|
||||
;; content-on-sx — document metadata (title / slug / tags).
|
||||
;;
|
||||
;; CtDoc carries optional metadata alongside its blocks (ivars declared in
|
||||
;; doc.sx). Reads go through message dispatch; setters are copy-on-write
|
||||
;; (functional st-iv-set!), consistent with the immutable document model.
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx.
|
||||
|
||||
;; ── reads ──
|
||||
(define doc-title (fn (doc) (st-send doc "title" (list))))
|
||||
(define doc-slug (fn (doc) (st-send doc "slug" (list))))
|
||||
(define
|
||||
doc-tags
|
||||
(fn
|
||||
(doc)
|
||||
(let ((t (st-send doc "tags" (list)))) (if (= t nil) (list) t))))
|
||||
|
||||
(define doc-meta (fn (doc) {:slug (doc-slug doc) :id (doc-id doc) :title (doc-title doc) :tags (doc-tags doc)}))
|
||||
|
||||
;; ── copy-on-write setters ──
|
||||
(define doc-with-title (fn (doc title) (st-iv-set! doc "title" title)))
|
||||
(define doc-with-slug (fn (doc slug) (st-iv-set! doc "slug" slug)))
|
||||
(define doc-with-tags (fn (doc tags) (st-iv-set! doc "tags" tags)))
|
||||
|
||||
(define
|
||||
doc-add-tag
|
||||
(fn (doc tag) (doc-with-tags doc (append (doc-tags doc) (list tag)))))
|
||||
|
||||
;; set several at once: meta is a dict with optional :title :slug :tags
|
||||
(define
|
||||
doc-with-meta
|
||||
(fn
|
||||
(doc meta)
|
||||
(let
|
||||
((d1 (if (has-key? meta :title) (doc-with-title doc (get meta :title)) doc)))
|
||||
(let
|
||||
((d2 (if (has-key? meta :slug) (doc-with-slug d1 (get meta :slug)) d1)))
|
||||
(if (has-key? meta :tags) (doc-with-tags d2 (get meta :tags)) d2)))))
|
||||
|
||||
;; constructor with metadata
|
||||
(define
|
||||
doc-new-meta
|
||||
(fn (id blocks meta) (doc-with-meta (doc-new id blocks) meta)))
|
||||
|
||||
;; ── content/* facade aliases ──
|
||||
(define content/title doc-title)
|
||||
(define content/slug doc-slug)
|
||||
(define content/tags doc-tags)
|
||||
(define content/meta doc-meta)
|
||||
(define content/with-title doc-with-title)
|
||||
(define content/with-slug doc-with-slug)
|
||||
(define content/with-tags doc-with-tags)
|
||||
(define content/with-meta doc-with-meta)
|
||||
@@ -1,69 +0,0 @@
|
||||
;; content-on-sx — relative block reorder.
|
||||
;;
|
||||
;; Move a top-level block to just before / after another block by id — more
|
||||
;; ergonomic than the index-based doc-move. No-op if either id is missing.
|
||||
;; Immutable; composes the doc.sx list helpers.
|
||||
;;
|
||||
;; Requires (loaded by harness): doc.sx.
|
||||
|
||||
(define
|
||||
content/move-before
|
||||
(fn
|
||||
(doc id target)
|
||||
(let
|
||||
((blk (doc-find doc id)))
|
||||
(if
|
||||
(= blk nil)
|
||||
doc
|
||||
(let
|
||||
((without (ct-remove-id (doc-blocks doc) id)))
|
||||
(let
|
||||
((idx (ct-index-of without target)))
|
||||
(if
|
||||
(= idx -1)
|
||||
doc
|
||||
(doc-with-blocks doc (ct-insert-at without idx blk)))))))))
|
||||
|
||||
(define
|
||||
content/move-after
|
||||
(fn
|
||||
(doc id target)
|
||||
(let
|
||||
((blk (doc-find doc id)))
|
||||
(if
|
||||
(= blk nil)
|
||||
doc
|
||||
(let
|
||||
((without (ct-remove-id (doc-blocks doc) id)))
|
||||
(let
|
||||
((idx (ct-index-of without target)))
|
||||
(if
|
||||
(= idx -1)
|
||||
doc
|
||||
(doc-with-blocks
|
||||
doc
|
||||
(ct-insert-at without (+ idx 1) blk)))))))))
|
||||
|
||||
(define
|
||||
content/move-to-front
|
||||
(fn
|
||||
(doc id)
|
||||
(let
|
||||
((blk (doc-find doc id)))
|
||||
(if
|
||||
(= blk nil)
|
||||
doc
|
||||
(doc-with-blocks doc (cons blk (ct-remove-id (doc-blocks doc) id)))))))
|
||||
|
||||
(define
|
||||
content/move-to-back
|
||||
(fn
|
||||
(doc id)
|
||||
(let
|
||||
((blk (doc-find doc id)))
|
||||
(if
|
||||
(= blk nil)
|
||||
doc
|
||||
(doc-with-blocks
|
||||
doc
|
||||
(append (ct-remove-id (doc-blocks doc) id) (list blk)))))))
|
||||
@@ -1,49 +0,0 @@
|
||||
;; content-on-sx — document normalization.
|
||||
;;
|
||||
;; A cleanup pass: drop empty text blocks and empty sections across the tree.
|
||||
;; Sections are normalised first, so a section that becomes empty (all children
|
||||
;; dropped) is itself dropped. For tidying imported/edited documents. Immutable.
|
||||
;; Inline tree handling (no section.sx dep).
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx.
|
||||
|
||||
(define
|
||||
norm-section?
|
||||
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
|
||||
(define
|
||||
norm-empty-text?
|
||||
(fn (b) (and (= (blk-type b) "text") (= (str (blk-get b "text")) ""))))
|
||||
(define
|
||||
norm-empty-section?
|
||||
(fn
|
||||
(b)
|
||||
(and
|
||||
(norm-section? b)
|
||||
(let
|
||||
((ch (st-iv-get b "children")))
|
||||
(or (= ch nil) (= (len ch) 0))))))
|
||||
|
||||
(define
|
||||
norm-recurse
|
||||
(fn
|
||||
(b)
|
||||
(if
|
||||
(norm-section? b)
|
||||
(let
|
||||
((ch (st-iv-get b "children")))
|
||||
(if (list? ch) (st-iv-set! b "children" (norm-blocks ch)) b))
|
||||
b)))
|
||||
|
||||
(define
|
||||
norm-keep?
|
||||
(fn
|
||||
(b)
|
||||
(if (norm-empty-text? b) false (if (norm-empty-section? b) false true))))
|
||||
|
||||
(define
|
||||
norm-blocks
|
||||
(fn (blocks) (filter norm-keep? (map norm-recurse blocks))))
|
||||
|
||||
(define
|
||||
content/normalize
|
||||
(fn (doc) (doc-with-blocks doc (norm-blocks (doc-blocks doc)))))
|
||||
@@ -1,34 +0,0 @@
|
||||
;; content-on-sx — nested document outline.
|
||||
;;
|
||||
;; Builds a hierarchical heading tree from content/headings: each node is
|
||||
;; {:id :text :level :children}, where a heading nests under the nearest
|
||||
;; preceding heading of a lower level. The structured companion to the flat TOC,
|
||||
;; for rendering nested navigation.
|
||||
;;
|
||||
;; Requires (loaded by harness): query.sx (content/headings).
|
||||
|
||||
;; consume a prefix of `hs` forming nodes whose level > minlevel; return
|
||||
;; {:nodes ... :rest ...}.
|
||||
(define
|
||||
ol-forest
|
||||
(fn
|
||||
(hs minlevel)
|
||||
(if
|
||||
(= (len hs) 0)
|
||||
{:rest (list) :nodes (list)}
|
||||
(let
|
||||
((h (first hs)))
|
||||
(if
|
||||
(<= (get h :level) minlevel)
|
||||
{:rest hs :nodes (list)}
|
||||
(let
|
||||
((sub (ol-forest (rest hs) (get h :level))))
|
||||
(let
|
||||
((node {:id (get h :id) :text (get h :text) :children (get sub :nodes) :level (get h :level)}))
|
||||
(let
|
||||
((more (ol-forest (get sub :rest) minlevel)))
|
||||
{:rest (get more :rest) :nodes (cons node (get more :nodes))}))))))))
|
||||
|
||||
(define
|
||||
content/outline
|
||||
(fn (doc) (get (ol-forest (content/headings doc) 0) :nodes)))
|
||||
@@ -1,23 +0,0 @@
|
||||
;; content-on-sx — SEO-complete HTML page.
|
||||
;;
|
||||
;; content/page-full extends content/page with a lang attribute and a
|
||||
;; <meta name="description"> drawn from the document excerpt (plain text,
|
||||
;; truncated). Composes the page, metadata and text layers.
|
||||
;;
|
||||
;; Requires (loaded by harness): page.sx (ct-html-escape, content/page-title),
|
||||
;; text.sx (content/excerpt), render.sx (asHTML).
|
||||
|
||||
(define CONTENT-EXCERPT-LEN 160)
|
||||
|
||||
(define
|
||||
content/page-full
|
||||
(fn
|
||||
(doc)
|
||||
(str
|
||||
"<!doctype html><html lang=\"en\"><head><meta charset=\"utf-8\"><title>"
|
||||
(ct-html-escape (content/page-title doc))
|
||||
"</title><meta name=\"description\" content=\""
|
||||
(ct-html-escape (content/excerpt doc CONTENT-EXCERPT-LEN))
|
||||
"\"></head><body>"
|
||||
(asHTML doc)
|
||||
"</body></html>")))
|
||||
@@ -1,26 +0,0 @@
|
||||
;; content-on-sx — full HTML page wrapper.
|
||||
;;
|
||||
;; content/page composes the metadata + render layers into the shippable
|
||||
;; artifact the blog serves: a minimal valid HTML5 document with an escaped
|
||||
;; <title> (from doc metadata, falling back to the id) and the rendered blocks
|
||||
;; as the body.
|
||||
;;
|
||||
;; Requires (loaded by harness): doc.sx, render.sx (asHTML + htmlEscaped),
|
||||
;; meta.sx (doc-title).
|
||||
|
||||
(define ct-html-escape (fn (s) (str (st-send s "htmlEscaped" (list)))))
|
||||
|
||||
(define
|
||||
content/page-title
|
||||
(fn (doc) (let ((t (doc-title doc))) (if (= t nil) (doc-id doc) t))))
|
||||
|
||||
(define
|
||||
content/page
|
||||
(fn
|
||||
(doc)
|
||||
(str
|
||||
"<!doctype html><html><head><meta charset=\"utf-8\"><title>"
|
||||
(ct-html-escape (content/page-title doc))
|
||||
"</title></head><body>"
|
||||
(asHTML doc)
|
||||
"</body></html>")))
|
||||
@@ -1,51 +0,0 @@
|
||||
;; content-on-sx — block query + table of contents.
|
||||
;;
|
||||
;; Collect blocks across the whole tree (descending into sections) by predicate
|
||||
;; or type, and derive a table of contents from headings. Tree detection is
|
||||
;; inline (class + st-iv-get) so this needs no section.sx.
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx.
|
||||
|
||||
(define
|
||||
qry-section?
|
||||
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
|
||||
(define
|
||||
qry-tree
|
||||
(fn
|
||||
(blocks)
|
||||
(if
|
||||
(= (len blocks) 0)
|
||||
(list)
|
||||
(let
|
||||
((b (first blocks)))
|
||||
(append
|
||||
(cons
|
||||
b
|
||||
(if
|
||||
(qry-section? b)
|
||||
(let
|
||||
((ch (st-iv-get b "children")))
|
||||
(if (list? ch) (qry-tree ch) (list)))
|
||||
(list)))
|
||||
(qry-tree (rest blocks)))))))
|
||||
|
||||
(define
|
||||
content/select
|
||||
(fn (doc pred) (filter pred (qry-tree (doc-blocks doc)))))
|
||||
|
||||
(define
|
||||
content/select-type
|
||||
(fn (doc type) (content/select doc (fn (b) (= (blk-type b) type)))))
|
||||
|
||||
(define
|
||||
content/count-type
|
||||
(fn (doc type) (len (content/select-type doc type))))
|
||||
|
||||
(define
|
||||
content/select-ids
|
||||
(fn (doc pred) (map (fn (b) (blk-id b)) (content/select doc pred))))
|
||||
|
||||
;; table of contents: {:id :level :text} for every heading, in document order.
|
||||
(define
|
||||
content/headings
|
||||
(fn (doc) (map (fn (b) {:id (blk-id b) :text (blk-get b "text") :level (blk-get b "level")}) (content/select-type doc "heading"))))
|
||||
@@ -1,99 +0,0 @@
|
||||
;; content-on-sx — render boundary.
|
||||
;;
|
||||
;; Rendering is a message, not a property switch: every block (and the document)
|
||||
;; answers asHTML and asSx. The internal model carries no presentation — the
|
||||
;; boundary format is chosen by which message you send. The document folds its
|
||||
;; children's renderings, so (asHTML doc) / (asSx doc) are pure polymorphic
|
||||
;; sends with no type dispatch in the SX layer.
|
||||
;;
|
||||
;; Escaping happens HERE, at the boundary. asHTML routes text/attrs through
|
||||
;; String>>htmlEscaped (& < > "); asSx routes them through String>>sxEscaped
|
||||
;; (\ and ") so values cannot break out of an element or an SX string literal.
|
||||
|
||||
(define
|
||||
content-bootstrap-render!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(ct-def-method!
|
||||
"String"
|
||||
"htmlEscaped"
|
||||
"htmlEscaped | out i n c | out := ''. n := self size. i := 1. [i <= n] whileTrue: [c := self at: i. (c = $&) ifTrue: [out := out , '&'] ifFalse: [(c = $<) ifTrue: [out := out , '<'] ifFalse: [(c = $>) ifTrue: [out := out , '>'] ifFalse: [(c = $\") ifTrue: [out := out , '"'] ifFalse: [out := out , c asString]]]]. i := i + 1]. ^ out")
|
||||
(ct-def-method!
|
||||
"String"
|
||||
"sxEscaped"
|
||||
"sxEscaped | out i n c | out := ''. n := self size. i := 1. [i <= n] whileTrue: [c := self at: i. (c = $\\) ifTrue: [out := out , '\\\\'] ifFalse: [(c = $\") ifTrue: [out := out , '\\\"'] ifFalse: [out := out , c asString]]. i := i + 1]. ^ out")
|
||||
(ct-def-method!
|
||||
"CtHeading"
|
||||
"asHTML"
|
||||
"asHTML | t | t := level printString. ^ '<h' , t , '>' , text htmlEscaped , '</h' , t , '>'")
|
||||
(ct-def-method!
|
||||
"CtText"
|
||||
"asHTML"
|
||||
"asHTML ^ '<p>' , text htmlEscaped , '</p>'")
|
||||
(ct-def-method!
|
||||
"CtCode"
|
||||
"asHTML"
|
||||
"asHTML ^ '<pre><code class=\"language-' , language htmlEscaped , '\">' , text htmlEscaped , '</code></pre>'")
|
||||
(ct-def-method!
|
||||
"CtQuote"
|
||||
"asHTML"
|
||||
"asHTML ^ '<blockquote>' , text htmlEscaped , '</blockquote>'")
|
||||
(ct-def-method!
|
||||
"CtImage"
|
||||
"asHTML"
|
||||
"asHTML ^ '<img src=\"' , src htmlEscaped , '\" alt=\"' , alt htmlEscaped , '\">'")
|
||||
(ct-def-method!
|
||||
"CtEmbed"
|
||||
"asHTML"
|
||||
"asHTML ^ '<iframe src=\"' , url htmlEscaped , '\"></iframe>'")
|
||||
(ct-def-method! "CtDivider" "asHTML" "asHTML ^ '<hr>'")
|
||||
(ct-def-method!
|
||||
"CtList"
|
||||
"asHTML"
|
||||
"asHTML | tag | tag := ordered ifTrue: ['ol'] ifFalse: ['ul']. ^ '<' , tag , '>' , (items inject: '' into: [:a :x | a , '<li>' , x htmlEscaped , '</li>']) , '</' , tag , '>'")
|
||||
(ct-def-method!
|
||||
"CtDoc"
|
||||
"asHTML"
|
||||
"asHTML ^ blocks inject: '' into: [:a :b | a , (b asHTML)]")
|
||||
(ct-def-method!
|
||||
"CtHeading"
|
||||
"asSx"
|
||||
"asSx | t | t := level printString. ^ '(h' , t , ' \"' , text sxEscaped , '\")'")
|
||||
(ct-def-method! "CtText" "asSx" "asSx ^ '(p \"' , text sxEscaped , '\")'")
|
||||
(ct-def-method!
|
||||
"CtCode"
|
||||
"asSx"
|
||||
"asSx ^ '(pre (code \"' , text sxEscaped , '\"))'")
|
||||
(ct-def-method!
|
||||
"CtQuote"
|
||||
"asSx"
|
||||
"asSx ^ '(blockquote \"' , text sxEscaped , '\")'")
|
||||
(ct-def-method!
|
||||
"CtImage"
|
||||
"asSx"
|
||||
"asSx ^ '(img :src \"' , src sxEscaped , '\" :alt \"' , alt sxEscaped , '\")'")
|
||||
(ct-def-method!
|
||||
"CtEmbed"
|
||||
"asSx"
|
||||
"asSx ^ '(iframe :src \"' , url sxEscaped , '\")'")
|
||||
(ct-def-method! "CtDivider" "asSx" "asSx ^ '(hr)'")
|
||||
(ct-def-method!
|
||||
"CtList"
|
||||
"asSx"
|
||||
"asSx | tag | tag := ordered ifTrue: ['ol'] ifFalse: ['ul']. ^ '(' , tag , ' ' , (items inject: '' into: [:a :x | a , '(li \"' , x sxEscaped , '\")']) , ')'")
|
||||
(ct-def-method!
|
||||
"CtDoc"
|
||||
"asSx"
|
||||
"asSx ^ '(article ' , (blocks inject: '' into: [:a :b | a , (b asSx)]) , ')'")
|
||||
true)))
|
||||
|
||||
;; ── SX boundary API — pure message sends ──
|
||||
(define asHTML (fn (node) (str (st-send node "asHTML" (list)))))
|
||||
(define asSx (fn (node) (str (st-send node "asSx" (list)))))
|
||||
|
||||
;; readable aliases
|
||||
(define render-html asHTML)
|
||||
(define render-sx asSx)
|
||||
(define block-html asHTML)
|
||||
(define block-sx asSx)
|
||||
@@ -1,48 +0,0 @@
|
||||
{
|
||||
"suites": {
|
||||
"block": {"pass": 38, "fail": 0},
|
||||
"doc": {"pass": 40, "fail": 0},
|
||||
"render": {"pass": 42, "fail": 0},
|
||||
"api": {"pass": 26, "fail": 0},
|
||||
"meta": {"pass": 27, "fail": 0},
|
||||
"page": {"pass": 7, "fail": 0},
|
||||
"page-full": {"pass": 4, "fail": 0},
|
||||
"markdown": {"pass": 20, "fail": 0},
|
||||
"text": {"pass": 20, "fail": 0},
|
||||
"section": {"pass": 25, "fail": 0},
|
||||
"compose": {"pass": 17, "fail": 0},
|
||||
"tree-edit": {"pass": 17, "fail": 0},
|
||||
"move": {"pass": 11, "fail": 0},
|
||||
"clone": {"pass": 10, "fail": 0},
|
||||
"query": {"pass": 13, "fail": 0},
|
||||
"toc": {"pass": 8, "fail": 0},
|
||||
"anchor": {"pass": 6, "fail": 0},
|
||||
"outline": {"pass": 14, "fail": 0},
|
||||
"flatten": {"pass": 10, "fail": 0},
|
||||
"transform": {"pass": 12, "fail": 0},
|
||||
"normalize": {"pass": 11, "fail": 0},
|
||||
"find-replace": {"pass": 10, "fail": 0},
|
||||
"stats": {"pass": 17, "fail": 0},
|
||||
"summary": {"pass": 14, "fail": 0},
|
||||
"index": {"pass": 13, "fail": 0},
|
||||
"table": {"pass": 15, "fail": 0},
|
||||
"callout": {"pass": 12, "fail": 0},
|
||||
"media": {"pass": 15, "fail": 0},
|
||||
"data": {"pass": 25, "fail": 0},
|
||||
"wire": {"pass": 11, "fail": 0},
|
||||
"validate": {"pass": 23, "fail": 0},
|
||||
"store": {"pass": 33, "fail": 0},
|
||||
"snapshot": {"pass": 20, "fail": 0},
|
||||
"crdt": {"pass": 34, "fail": 0},
|
||||
"crdt-tree": {"pass": 21, "fail": 0},
|
||||
"crdt-blocks": {"pass": 7, "fail": 0},
|
||||
"crdt-store": {"pass": 14, "fail": 0},
|
||||
"sync": {"pass": 14, "fail": 0},
|
||||
"md-import": {"pass": 38, "fail": 0},
|
||||
"md-doc": {"pass": 12, "fail": 0},
|
||||
"fed": {"pass": 20, "fail": 0}
|
||||
},
|
||||
"total_pass": 746,
|
||||
"total_fail": 0,
|
||||
"total": 746
|
||||
}
|
||||
@@ -1,48 +0,0 @@
|
||||
# content-on-sx Conformance Scoreboard
|
||||
|
||||
_Generated by `lib/content/conformance.sh`_
|
||||
|
||||
| Suite | Pass | Fail | Total |
|
||||
|-------|-----:|-----:|------:|
|
||||
| block | 38 | 0 | 38 |
|
||||
| doc | 40 | 0 | 40 |
|
||||
| render | 42 | 0 | 42 |
|
||||
| api | 26 | 0 | 26 |
|
||||
| meta | 27 | 0 | 27 |
|
||||
| page | 7 | 0 | 7 |
|
||||
| page-full | 4 | 0 | 4 |
|
||||
| markdown | 20 | 0 | 20 |
|
||||
| text | 20 | 0 | 20 |
|
||||
| section | 25 | 0 | 25 |
|
||||
| compose | 17 | 0 | 17 |
|
||||
| tree-edit | 17 | 0 | 17 |
|
||||
| move | 11 | 0 | 11 |
|
||||
| clone | 10 | 0 | 10 |
|
||||
| query | 13 | 0 | 13 |
|
||||
| toc | 8 | 0 | 8 |
|
||||
| anchor | 6 | 0 | 6 |
|
||||
| outline | 14 | 0 | 14 |
|
||||
| flatten | 10 | 0 | 10 |
|
||||
| transform | 12 | 0 | 12 |
|
||||
| normalize | 11 | 0 | 11 |
|
||||
| find-replace | 10 | 0 | 10 |
|
||||
| stats | 17 | 0 | 17 |
|
||||
| summary | 14 | 0 | 14 |
|
||||
| index | 13 | 0 | 13 |
|
||||
| table | 15 | 0 | 15 |
|
||||
| callout | 12 | 0 | 12 |
|
||||
| media | 15 | 0 | 15 |
|
||||
| data | 25 | 0 | 25 |
|
||||
| wire | 11 | 0 | 11 |
|
||||
| validate | 23 | 0 | 23 |
|
||||
| store | 33 | 0 | 33 |
|
||||
| snapshot | 20 | 0 | 20 |
|
||||
| crdt | 34 | 0 | 34 |
|
||||
| crdt-tree | 21 | 0 | 21 |
|
||||
| crdt-blocks | 7 | 0 | 7 |
|
||||
| crdt-store | 14 | 0 | 14 |
|
||||
| sync | 14 | 0 | 14 |
|
||||
| md-import | 38 | 0 | 38 |
|
||||
| md-doc | 12 | 0 | 12 |
|
||||
| fed | 20 | 0 | 20 |
|
||||
| **Total** | **746** | **0** | **746** |
|
||||
@@ -1,103 +0,0 @@
|
||||
;; content-on-sx — nested block trees (section container).
|
||||
;;
|
||||
;; CtSection is a block whose ivar `children` is an ordered list of blocks (any
|
||||
;; type, including nested sections → arbitrary depth). This turns the document
|
||||
;; from a flat sequence into the ordered TREE of the architecture sketch.
|
||||
;;
|
||||
;; Self-contained: CtSection answers asHTML/asSx/asText/asMarkdown: by folding
|
||||
;; its children's renderings — pure polymorphic recursion, so it composes with
|
||||
;; the existing render boundary with no changes to block.sx or render.sx. (The
|
||||
;; relevant per-block render bootstrap must be loaded for the children.)
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx, render.sx (asHTML/asSx);
|
||||
;; markdown.sx / text.sx for those formats on children.
|
||||
|
||||
(define
|
||||
content-bootstrap-section!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(st-class-define! "CtSection" "CtBlock" (list "children"))
|
||||
(ct-def-method! "CtSection" "children" "children ^ children")
|
||||
(ct-def-method! "CtSection" "type" "type ^ #section")
|
||||
(ct-def-method!
|
||||
"CtSection"
|
||||
"asHTML"
|
||||
"asHTML ^ '<section>' , (children inject: '' into: [:a :b | a , (b asHTML)]) , '</section>'")
|
||||
(ct-def-method!
|
||||
"CtSection"
|
||||
"asSx"
|
||||
"asSx ^ '(section ' , (children inject: '' into: [:a :b | a , (b asSx)]) , ')'")
|
||||
(ct-def-method!
|
||||
"CtSection"
|
||||
"asText"
|
||||
"asText ^ (children inject: '' into: [:a :b | (b asText = '') ifTrue: [a] ifFalse: [(a = '' ifTrue: [b asText] ifFalse: [a , ' ' , b asText])]])")
|
||||
(ct-def-method!
|
||||
"CtSection"
|
||||
"asMarkdown:"
|
||||
"asMarkdown: nl ^ (children inject: '' into: [:a :b | a , (a = '' ifTrue: [''] ifFalse: [nl , nl]) , (b asMarkdown: nl)])")
|
||||
true)))
|
||||
|
||||
(define
|
||||
mk-section
|
||||
(fn
|
||||
(id children)
|
||||
(st-iv-set!
|
||||
(st-iv-set! (st-make-instance "CtSection") "id" id)
|
||||
"children"
|
||||
children)))
|
||||
|
||||
(define
|
||||
section?
|
||||
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
|
||||
|
||||
(define section-children (fn (sec) (st-send sec "children" (list))))
|
||||
|
||||
;; copy-on-write child edits (return a new section)
|
||||
(define
|
||||
section-with-children
|
||||
(fn (sec children) (st-iv-set! sec "children" children)))
|
||||
(define
|
||||
section-append
|
||||
(fn
|
||||
(sec block)
|
||||
(section-with-children sec (append (section-children sec) (list block)))))
|
||||
|
||||
;; ── tree traversal (descends into nested sections) ──
|
||||
(define
|
||||
block-deep-find
|
||||
(fn
|
||||
(blocks id)
|
||||
(if
|
||||
(= (len blocks) 0)
|
||||
nil
|
||||
(let
|
||||
((b (first blocks)))
|
||||
(if
|
||||
(= (blk-id b) id)
|
||||
b
|
||||
(let
|
||||
((nested (if (section? b) (block-deep-find (section-children b) id) nil)))
|
||||
(if (= nested nil) (block-deep-find (rest blocks) id) nested)))))))
|
||||
|
||||
(define doc-deep-find (fn (doc id) (block-deep-find (doc-blocks doc) id)))
|
||||
|
||||
(define
|
||||
block-tree-ids
|
||||
(fn
|
||||
(blocks)
|
||||
(if
|
||||
(= (len blocks) 0)
|
||||
(list)
|
||||
(let
|
||||
((b (first blocks)))
|
||||
(append
|
||||
(cons
|
||||
(blk-id b)
|
||||
(if (section? b) (block-tree-ids (section-children b)) (list)))
|
||||
(block-tree-ids (rest blocks)))))))
|
||||
|
||||
(define doc-tree-ids (fn (doc) (block-tree-ids (doc-blocks doc))))
|
||||
|
||||
(define block-tree-count (fn (blocks) (len (block-tree-ids blocks))))
|
||||
(define doc-tree-count (fn (doc) (len (doc-tree-ids doc))))
|
||||
@@ -1,90 +0,0 @@
|
||||
;; content-on-sx — snapshot cache over the op-log replay.
|
||||
;;
|
||||
;; Snapshots are a CACHE, never primary state: the op log stays the source of
|
||||
;; truth. A snapshot stores a materialised document at a sequence in the persist
|
||||
;; KV; cached reads start from it and replay only the tail of ops, so they return
|
||||
;; a document IDENTICAL to a full replay — just faster. Drop the snapshot and
|
||||
;; nothing is lost.
|
||||
;;
|
||||
;; Requires (loaded by harness): store.sx (+ doc.sx, persist event/log/kv/api).
|
||||
|
||||
(define content/-snap-key (fn (doc-id) (str "content-snap:" doc-id)))
|
||||
|
||||
;; take a snapshot of the current head at the current version. Returns the seq.
|
||||
(define
|
||||
content/snapshot!
|
||||
(fn
|
||||
(b doc-id)
|
||||
(let
|
||||
((seq (content/version-count b doc-id)))
|
||||
(begin (persist/kv-put b (content/-snap-key doc-id) {:doc (content/head b doc-id) :seq seq}) seq))))
|
||||
|
||||
(define
|
||||
content/-snapshot
|
||||
(fn
|
||||
(b doc-id)
|
||||
(if
|
||||
(persist/kv-has? b (content/-snap-key doc-id))
|
||||
(persist/kv-get b (content/-snap-key doc-id))
|
||||
nil)))
|
||||
|
||||
(define
|
||||
content/snapshot-seq
|
||||
(fn
|
||||
(b doc-id)
|
||||
(let
|
||||
((s (content/-snapshot b doc-id)))
|
||||
(if (= s nil) 0 (get s :seq)))))
|
||||
|
||||
(define
|
||||
content/has-snapshot?
|
||||
(fn (b doc-id) (persist/kv-has? b (content/-snap-key doc-id))))
|
||||
|
||||
(define
|
||||
content/drop-snapshot!
|
||||
(fn (b doc-id) (persist/kv-delete b (content/-snap-key doc-id))))
|
||||
|
||||
;; ── cached reads (transparent: identical result to store.sx replay) ──
|
||||
(define
|
||||
content/-tail-ops
|
||||
(fn
|
||||
(b doc-id from to)
|
||||
(map
|
||||
(fn (ev) (persist/event-data ev))
|
||||
(filter
|
||||
(fn
|
||||
(ev)
|
||||
(and
|
||||
(> (persist/event-seq ev) from)
|
||||
(<= (persist/event-seq ev) to)))
|
||||
(content/log b doc-id)))))
|
||||
|
||||
(define
|
||||
content/head-cached
|
||||
(fn
|
||||
(b doc-id)
|
||||
(let
|
||||
((snap (content/-snapshot b doc-id)))
|
||||
(if
|
||||
(= snap nil)
|
||||
(content/head b doc-id)
|
||||
(doc-apply-all
|
||||
(get snap :doc)
|
||||
(content/-tail-ops
|
||||
b
|
||||
doc-id
|
||||
(get snap :seq)
|
||||
(content/version-count b doc-id)))))))
|
||||
|
||||
(define
|
||||
content/at-cached
|
||||
(fn
|
||||
(b doc-id seq)
|
||||
(let
|
||||
((snap (content/-snapshot b doc-id)))
|
||||
(if
|
||||
(or (= snap nil) (< seq (get snap :seq)))
|
||||
(content/at b doc-id seq)
|
||||
(doc-apply-all
|
||||
(get snap :doc)
|
||||
(content/-tail-ops b doc-id (get snap :seq) seq))))))
|
||||
@@ -1,49 +0,0 @@
|
||||
;; content-on-sx — document statistics (word/char/block counts, reading time).
|
||||
;;
|
||||
;; Counts derive from the plain-text projection (asText, tree-accurate via
|
||||
;; section recursion) and a tree block count (inline class check, so this needs
|
||||
;; no section.sx). Reading time uses 200 wpm, rounded up.
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx, text.sx (asText).
|
||||
|
||||
(define
|
||||
ct-words
|
||||
(fn (s) (filter (fn (w) (if (= w "") false true)) (split s " "))))
|
||||
|
||||
(define ct-ceil-div (fn (a b) (quotient (+ a (- b 1)) b)))
|
||||
|
||||
(define
|
||||
ct-stat-section?
|
||||
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
|
||||
(define
|
||||
ct-stat-count
|
||||
(fn
|
||||
(blocks)
|
||||
(if
|
||||
(= (len blocks) 0)
|
||||
0
|
||||
(let
|
||||
((b (first blocks)))
|
||||
(+
|
||||
(+
|
||||
1
|
||||
(if
|
||||
(ct-stat-section? b)
|
||||
(let
|
||||
((ch (st-iv-get b "children")))
|
||||
(if (list? ch) (ct-stat-count ch) 0))
|
||||
0))
|
||||
(ct-stat-count (rest blocks)))))))
|
||||
|
||||
(define content/word-count (fn (doc) (len (ct-words (asText doc)))))
|
||||
(define content/char-count (fn (doc) (string-length (asText doc))))
|
||||
(define content/block-count (fn (doc) (ct-stat-count (doc-blocks doc))))
|
||||
(define
|
||||
content/reading-minutes
|
||||
(fn
|
||||
(doc)
|
||||
(let
|
||||
((w (content/word-count doc)))
|
||||
(if (= w 0) 0 (ct-ceil-div w 200)))))
|
||||
|
||||
(define content/stats (fn (doc) {:blocks (content/block-count doc) :reading-minutes (content/reading-minutes doc) :words (content/word-count doc) :chars (content/char-count doc)}))
|
||||
@@ -1,101 +0,0 @@
|
||||
;; content-on-sx — op log + versioning over the persist event stream.
|
||||
;;
|
||||
;; The op log is the source of truth. Editing a document = appending the edit op
|
||||
;; as a persist event to the document's stream. Any version of the document is a
|
||||
;; replay of its op stream up to a sequence number; the materialised doc is a
|
||||
;; cache, never primary state.
|
||||
;;
|
||||
;; Requires (loaded by the harness): block.sx, doc.sx, and persist
|
||||
;; (event/backend/log/kv/api). The persist backend `b` is opened by the caller
|
||||
;; via (persist/open) and injected — content knows nothing about which backend.
|
||||
|
||||
(define content/-stream (fn (doc-id) (str "content:" doc-id)))
|
||||
|
||||
;; ── commit: append an edit op as an event. `at` is a caller-supplied logical
|
||||
;; timestamp (Date.now is unavailable in-kernel). Returns the stored event. ──
|
||||
(define
|
||||
content/commit!
|
||||
(fn
|
||||
(b doc-id op at)
|
||||
(persist/append b (content/-stream doc-id) (get op :op) at op)))
|
||||
|
||||
(define
|
||||
content/commit-all!
|
||||
(fn
|
||||
(b doc-id ops at)
|
||||
(if
|
||||
(= (len ops) 0)
|
||||
nil
|
||||
(begin
|
||||
(content/commit! b doc-id (first ops) at)
|
||||
(content/commit-all! b doc-id (rest ops) at)))))
|
||||
|
||||
;; ── read the raw log / op stream ──
|
||||
(define
|
||||
content/log
|
||||
(fn (b doc-id) (persist/read b (content/-stream doc-id))))
|
||||
|
||||
(define
|
||||
content/ops
|
||||
(fn
|
||||
(b doc-id)
|
||||
(map (fn (ev) (persist/event-data ev)) (content/log b doc-id))))
|
||||
|
||||
;; logical version count (highest seq assigned, survives compaction)
|
||||
(define
|
||||
content/version-count
|
||||
(fn (b doc-id) (persist/last-seq b (content/-stream doc-id))))
|
||||
|
||||
;; ── replay ──
|
||||
;; head — materialise the latest document by folding all ops.
|
||||
(define
|
||||
content/head
|
||||
(fn (b doc-id) (doc-apply-all (doc-empty doc-id) (content/ops b doc-id))))
|
||||
|
||||
;; at — materialise the document as of sequence `seq` (a version).
|
||||
(define
|
||||
content/at
|
||||
(fn
|
||||
(b doc-id seq)
|
||||
(let
|
||||
((evs (filter (fn (ev) (<= (persist/event-seq ev) seq)) (content/log b doc-id))))
|
||||
(doc-apply-all
|
||||
(doc-empty doc-id)
|
||||
(map (fn (ev) (persist/event-data ev)) evs)))))
|
||||
|
||||
;; ── history: per-version metadata, oldest-first ──
|
||||
(define
|
||||
content/history
|
||||
(fn (b doc-id) (map (fn (ev) {:type (persist/event-type ev) :at (persist/event-at ev) :seq (persist/event-seq ev)}) (content/log b doc-id))))
|
||||
|
||||
;; ── diff between two materialised document versions ──
|
||||
;; Returns {:added (ids) :removed (ids) :changed (ids)} where changed = ids
|
||||
;; present in both whose block content differs.
|
||||
(define
|
||||
content/-missing?
|
||||
(fn (doc id) (= (ct-index-of (doc-blocks doc) id) -1)))
|
||||
|
||||
(define
|
||||
content/-changed
|
||||
(fn
|
||||
(old new)
|
||||
(filter
|
||||
(fn
|
||||
(id)
|
||||
(let
|
||||
((bo (doc-find old id)) (bn (doc-find new id)))
|
||||
(cond
|
||||
((= bo nil) false)
|
||||
((= bn nil) false)
|
||||
((= bo bn) false)
|
||||
(else true))))
|
||||
(doc-ids old))))
|
||||
|
||||
(define content/diff (fn (old new) {:changed (content/-changed old new) :removed (filter (fn (id) (content/-missing? new id)) (doc-ids old)) :added (filter (fn (id) (content/-missing? old id)) (doc-ids new))}))
|
||||
|
||||
;; convenience: diff two persisted versions by seq.
|
||||
(define
|
||||
content/diff-versions
|
||||
(fn
|
||||
(b doc-id seq-a seq-b)
|
||||
(content/diff (content/at b doc-id seq-a) (content/at b doc-id seq-b))))
|
||||
@@ -1,26 +0,0 @@
|
||||
;; content-on-sx — list-card summary projection.
|
||||
;;
|
||||
;; content/summary returns a one-call projection for index/listing cards:
|
||||
;; {:id :title :excerpt :words :reading-minutes :cover}
|
||||
;; composing the metadata, text, stats and query layers. `cover` is the first
|
||||
;; image's src (or nil).
|
||||
;;
|
||||
;; Requires (loaded by harness): doc.sx, meta.sx (doc-title), text.sx
|
||||
;; (content/excerpt), stats.sx (word-count/reading), query.sx (select-type).
|
||||
|
||||
(define
|
||||
content/summary-title
|
||||
(fn (doc) (let ((t (doc-title doc))) (if (= t nil) (doc-id doc) t))))
|
||||
|
||||
(define
|
||||
content/cover
|
||||
(fn
|
||||
(doc)
|
||||
(let
|
||||
((imgs (content/select-type doc "image")))
|
||||
(if
|
||||
(= (len imgs) 0)
|
||||
nil
|
||||
(str (blk-get (first imgs) "src"))))))
|
||||
|
||||
(define content/summary (fn (doc) {:id (doc-id doc) :reading-minutes (content/reading-minutes doc) :words (content/word-count doc) :title (content/summary-title doc) :excerpt (content/excerpt doc 160) :cover (content/cover doc)}))
|
||||
@@ -1,74 +0,0 @@
|
||||
;; content-on-sx — external CMS sync via an injected adapter.
|
||||
;;
|
||||
;; Sync is a peripheral, not a feature. The core defines a SHAPE — an adapter is
|
||||
;; a dict {:import (fn external doc-id -> doc) :export (fn doc -> external)} — and
|
||||
;; delegates to it. The core knows nothing about Ghost's data model; all
|
||||
;; translation lives in the adapter. Swap the adapter and the core is unchanged;
|
||||
;; if Ghost goes away, nothing here does.
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx.
|
||||
|
||||
;; ── generic boundary: pure delegation ──
|
||||
(define
|
||||
content/import
|
||||
(fn (adapter external doc-id) ((get adapter :import) external doc-id)))
|
||||
|
||||
(define content/export (fn (adapter doc) ((get adapter :export) doc)))
|
||||
|
||||
;; round-trip a document through an adapter (export then import).
|
||||
(define
|
||||
content/round-trip
|
||||
(fn
|
||||
(adapter doc)
|
||||
(content/import adapter (content/export adapter doc) (doc-id doc))))
|
||||
|
||||
;; ── a Ghost-flavoured adapter (the peripheral). Ghost knowledge is confined
|
||||
;; here: a post is {:title :sections (list section)}; a section is a tagged dict
|
||||
;; {:kind ...} that this adapter maps to/from content blocks. ──
|
||||
(define
|
||||
ghost-section->block
|
||||
(fn
|
||||
(sec)
|
||||
(let
|
||||
((kind (get sec :kind)) (id (get sec :id)))
|
||||
(cond
|
||||
((= kind "heading")
|
||||
(mk-heading id (get sec :level) (get sec :text)))
|
||||
((= kind "paragraph") (mk-text id (get sec :text)))
|
||||
((= kind "image") (mk-image id (get sec :src) (get sec :alt)))
|
||||
((= kind "code") (mk-code id (get sec :language) (get sec :text)))
|
||||
((= kind "quote") (mk-quote id (get sec :cite) (get sec :text)))
|
||||
((= kind "hr") (mk-divider id))
|
||||
((= kind "list") (mk-list id (get sec :ordered) (get sec :items)))
|
||||
((= kind "embed") (mk-embed id (get sec :url) (get sec :provider)))
|
||||
(else (mk-text id (get sec :text)))))))
|
||||
|
||||
(define
|
||||
block->ghost-section
|
||||
(fn
|
||||
(b)
|
||||
(let
|
||||
((t (blk-type b)) (id (blk-id b)))
|
||||
(cond
|
||||
((= t "heading") {:id id :text (str (blk-send b "text")) :kind "heading" :level (blk-send b "level")})
|
||||
((= t "text") {:id id :text (str (blk-send b "text")) :kind "paragraph"})
|
||||
((= t "image") {:id id :src (str (blk-send b "src")) :alt (str (blk-send b "alt")) :kind "image"})
|
||||
((= t "code") {:id id :text (str (blk-send b "text")) :kind "code" :language (str (blk-send b "language"))})
|
||||
((= t "quote") {:cite (str (blk-send b "cite")) :id id :text (str (blk-send b "text")) :kind "quote"})
|
||||
((= t "divider") {:id id :kind "hr"})
|
||||
((= t "list") {:items (blk-send b "items") :id id :kind "list" :ordered (blk-send b "ordered")})
|
||||
((= t "embed") {:id id :provider (str (blk-send b "provider")) :kind "embed" :url (str (blk-send b "url"))})
|
||||
(else {:id id :text "" :kind "paragraph"})))))
|
||||
|
||||
(define
|
||||
ghost-import
|
||||
(fn
|
||||
(post doc-id)
|
||||
(st-iv-set!
|
||||
(doc-new doc-id (map ghost-section->block (get post :sections)))
|
||||
"title"
|
||||
(get post :title))))
|
||||
|
||||
(define ghost-export (fn (doc) {:sections (map block->ghost-section (doc-blocks doc)) :title (st-send doc "title" (list))}))
|
||||
|
||||
(define ghost-adapter {:export ghost-export :import ghost-import})
|
||||
@@ -1,54 +0,0 @@
|
||||
;; content-on-sx — table block.
|
||||
;;
|
||||
;; CtTable holds `headers` (list of strings) and `rows` (list of string lists).
|
||||
;; Self-contained: it answers asHTML/asSx/asText/asMarkdown: by folding rows and
|
||||
;; cells, so it composes with the render boundary with no changes elsewhere. HTML
|
||||
;; cells are htmlEscaped, SX cells sxEscaped (render.sx must be loaded).
|
||||
;;
|
||||
;; Requires (loaded by harness): block.sx, doc.sx, render.sx (escapers);
|
||||
;; markdown.sx / text.sx for those formats.
|
||||
|
||||
(define
|
||||
content-bootstrap-table!
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(st-class-define! "CtTable" "CtBlock" (list "headers" "rows"))
|
||||
(ct-def-method! "CtTable" "headers" "headers ^ headers")
|
||||
(ct-def-method! "CtTable" "rows" "rows ^ rows")
|
||||
(ct-def-method! "CtTable" "type" "type ^ #table")
|
||||
(ct-def-method!
|
||||
"CtTable"
|
||||
"asHTML"
|
||||
"asHTML | thead tbody | thead := '<thead><tr>' , (headers inject: '' into: [:a :h | a , '<th>' , h htmlEscaped , '</th>']) , '</tr></thead>'. tbody := '<tbody>' , (rows inject: '' into: [:a :r | a , '<tr>' , (r inject: '' into: [:b :c | b , '<td>' , c htmlEscaped , '</td>']) , '</tr>']) , '</tbody>'. ^ '<table>' , thead , tbody , '</table>'")
|
||||
(ct-def-method!
|
||||
"CtTable"
|
||||
"asSx"
|
||||
"asSx ^ '(table (thead (tr ' , (headers inject: '' into: [:a :h | a , '(th \"' , h sxEscaped , '\")']) , ')) (tbody ' , (rows inject: '' into: [:a :r | a , '(tr ' , (r inject: '' into: [:b :c | b , '(td \"' , c sxEscaped , '\")']) , ')']) , '))'")
|
||||
(ct-def-method!
|
||||
"CtTable"
|
||||
"asText"
|
||||
"asText ^ (rows inject: (headers inject: '' into: [:a :h | (a = '' ifTrue: [h] ifFalse: [a , ' ' , h])]) into: [:acc :r | acc , ' ' , (r inject: '' into: [:b :c | (b = '' ifTrue: [c] ifFalse: [b , ' ' , c])])])")
|
||||
(ct-def-method!
|
||||
"CtTable"
|
||||
"asMarkdown:"
|
||||
"asMarkdown: nl | head sep body | head := '|' , (headers inject: '' into: [:a :h | a , ' ' , h , ' |']). sep := '|' , (headers inject: '' into: [:a :h | a , ' --- |']). body := (rows inject: '' into: [:acc :r | acc , nl , '|' , (r inject: '' into: [:a :c | a , ' ' , c , ' |'])]). ^ head , nl , sep , body")
|
||||
true)))
|
||||
|
||||
(define
|
||||
mk-table
|
||||
(fn
|
||||
(id headers rows)
|
||||
(st-iv-set!
|
||||
(st-iv-set!
|
||||
(st-iv-set! (st-make-instance "CtTable") "id" id)
|
||||
"headers"
|
||||
headers)
|
||||
"rows"
|
||||
rows)))
|
||||
|
||||
(define
|
||||
table?
|
||||
(fn (b) (and (st-instance? b) (= (get b :class) "CtTable"))))
|
||||
(define table-headers (fn (tb) (st-send tb "headers" (list))))
|
||||
(define table-rows (fn (tb) (st-send tb "rows" (list))))
|
||||
@@ -1,58 +0,0 @@
|
||||
;; Extension — anchored-heading HTML render (functional TOC links).
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-section!)
|
||||
|
||||
(define
|
||||
d
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-heading "intro" 1 "Intro"))
|
||||
(mk-text "p" "Body"))
|
||||
(mk-section
|
||||
"s"
|
||||
(list (mk-heading "sub" 2 "Sub") (mk-text "n" "nested")))))
|
||||
|
||||
;; ── headings get id anchors; other blocks unchanged ──
|
||||
(content-test
|
||||
"anchored html"
|
||||
(content/html-anchored d)
|
||||
"<h1 id=\"intro\">Intro</h1><p>Body</p><section><h2 id=\"sub\">Sub</h2><p>nested</p></section>")
|
||||
|
||||
;; ── heading text escaped ──
|
||||
(content-test
|
||||
"anchored escapes text"
|
||||
(content/html-anchored
|
||||
(doc-append (doc-empty "d") (mk-heading "h" 2 "A < B")))
|
||||
"<h2 id=\"h\">A < B</h2>")
|
||||
|
||||
;; ── non-heading-only doc identical to asHTML ──
|
||||
(define
|
||||
np
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-text "p" "x"))
|
||||
(mk-image "i" "/a.png" "alt")))
|
||||
(content-test "no headings == asHTML" (content/html-anchored np) (asHTML np))
|
||||
|
||||
;; ── empty doc ──
|
||||
(content-test "anchored empty" (content/html-anchored (doc-empty "e")) "")
|
||||
|
||||
;; ── anchors match TOC ids (end-to-end) ──
|
||||
(content-test
|
||||
"anchor ids match toc"
|
||||
(map (fn (h) (get h :id)) (content/headings d))
|
||||
(list "intro" "sub"))
|
||||
|
||||
;; ── deep nesting ──
|
||||
(define
|
||||
deep
|
||||
(doc-append
|
||||
(doc-empty "d")
|
||||
(mk-section
|
||||
"o"
|
||||
(list (mk-section "i" (list (mk-heading "deep" 3 "Deep")))))))
|
||||
(content-test
|
||||
"deep anchored"
|
||||
(content/html-anchored deep)
|
||||
"<section><section><h3 id=\"deep\">Deep</h3></section></section>")
|
||||
@@ -1,99 +0,0 @@
|
||||
;; Phase 1 — public API facade. End-to-end through content/*.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
|
||||
;; ── build a document via the facade ──
|
||||
(define d0 (content/empty "post"))
|
||||
(define
|
||||
h
|
||||
(content/block
|
||||
"heading"
|
||||
"h"
|
||||
(list (list "level" 1) (list "text" "Hi"))))
|
||||
(define p (content/block "text" "p" (list (list "text" "World"))))
|
||||
(define d1 (content/append (content/append d0 h) p))
|
||||
|
||||
(content/op? (content/insert h nil))
|
||||
(content-test "count" (content/count d1) 2)
|
||||
(content-test "ids" (content/ids d1) (list "h" "p"))
|
||||
(content-test "types" (content/types d1) (list "heading" "text"))
|
||||
(content-test "find" (blk-id (content/find d1 "p")) "p")
|
||||
(content-test "has? yes" (content/has? d1 "h") true)
|
||||
(content-test "has? no" (content/has? d1 "x") false)
|
||||
|
||||
;; ── content/op? distinguishes a single op from a list / a block ──
|
||||
(content-test "op? on insert" (content/op? (content/insert h nil)) true)
|
||||
(content-test
|
||||
"op? on update"
|
||||
(content/op? (content/update "p" "text" "z"))
|
||||
true)
|
||||
(content-test "op? on list" (content/op? (list (content/delete "h"))) false)
|
||||
(content-test "op? on block" (content/op? h) false)
|
||||
(content-test "op? on doc" (content/op? d1) false)
|
||||
|
||||
;; ── edit with a single op ──
|
||||
(define
|
||||
img
|
||||
(content/block
|
||||
"image"
|
||||
"img"
|
||||
(list (list "src" "/c.png") (list "alt" "cat"))))
|
||||
(define d2 (content/edit d1 (content/insert img "h")))
|
||||
(content-test "edit single op order" (content/ids d2) (list "h" "img" "p"))
|
||||
(content-test "edit single immutable" (content/ids d1) (list "h" "p"))
|
||||
(content-test
|
||||
"edit update"
|
||||
(str
|
||||
(blk-send
|
||||
(content/find
|
||||
(content/edit d1 (content/update "p" "text" "Edited"))
|
||||
"p")
|
||||
"text"))
|
||||
"Edited")
|
||||
(content-test
|
||||
"edit delete"
|
||||
(content/ids (content/edit d1 (content/delete "h")))
|
||||
(list "p"))
|
||||
(content-test
|
||||
"edit move"
|
||||
(content/ids (content/edit d1 (content/move "p" 0)))
|
||||
(list "p" "h"))
|
||||
|
||||
;; ── edit with a stream of ops ──
|
||||
(define ops (list (content/insert img "h") (content/delete "p")))
|
||||
(content-test
|
||||
"edit op stream"
|
||||
(content/ids (content/edit d1 ops))
|
||||
(list "h" "img"))
|
||||
(content-test "edit op stream immutable" (content/ids d1) (list "h" "p"))
|
||||
|
||||
;; ── render via facade ──
|
||||
(content-test
|
||||
"render html"
|
||||
(content/render d1 "html")
|
||||
"<h1>Hi</h1><p>World</p>")
|
||||
(content-test
|
||||
"render sx"
|
||||
(content/render d1 "sx")
|
||||
"(article (h1 \"Hi\")(p \"World\"))")
|
||||
(content-test
|
||||
"render html keyword"
|
||||
(content/render d1 :html)
|
||||
"<h1>Hi</h1><p>World</p>")
|
||||
(content-test
|
||||
"render sx keyword"
|
||||
(content/render d1 :sx)
|
||||
"(article (h1 \"Hi\")(p \"World\"))")
|
||||
(content-test "content/html" (content/html d1) "<h1>Hi</h1><p>World</p>")
|
||||
(content-test "content/sx" (content/sx d1) "(article (h1 \"Hi\")(p \"World\"))")
|
||||
|
||||
;; ── render reflects each version ──
|
||||
(content-test
|
||||
"render edited version"
|
||||
(content/render (content/edit d1 (content/update "h" "text" "Hey")) "html")
|
||||
"<h1>Hey</h1><p>World</p>")
|
||||
(content-test
|
||||
"render original unchanged"
|
||||
(content/render d1 "html")
|
||||
"<h1>Hi</h1><p>World</p>")
|
||||
@@ -1,75 +0,0 @@
|
||||
;; Phase 1 — typed block objects. Behaviour via message dispatch; fields
|
||||
;; immutable (copy-on-write).
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content-bootstrap-blocks!)
|
||||
|
||||
;; ── construction + polymorphic type dispatch ──
|
||||
(define h (mk-heading "b1" 2 "Title"))
|
||||
(define t (mk-text "b2" "Body text"))
|
||||
(define img (mk-image "b3" "/cat.png" "a cat"))
|
||||
(define code (mk-code "b4" "sx" "(+ 1 2)"))
|
||||
(define q (mk-quote "b5" "Ada" "to err"))
|
||||
(define em (mk-embed "b6" "https://v/1" "vimeo"))
|
||||
(define dv (mk-divider "b7"))
|
||||
(define ls (mk-list "b8" true (list "one" "two")))
|
||||
|
||||
(content-test "heading type" (blk-type h) "heading")
|
||||
(content-test "text type" (blk-type t) "text")
|
||||
(content-test "image type" (blk-type img) "image")
|
||||
(content-test "code type" (blk-type code) "code")
|
||||
(content-test "quote type" (blk-type q) "quote")
|
||||
(content-test "embed type" (blk-type em) "embed")
|
||||
(content-test "divider type" (blk-type dv) "divider")
|
||||
(content-test "list type" (blk-type ls) "list")
|
||||
|
||||
;; ── id via message dispatch ──
|
||||
(content-test "heading id" (blk-id h) "b1")
|
||||
(content-test "image id" (blk-id img) "b3")
|
||||
(content-test "divider id" (blk-id dv) "b7")
|
||||
|
||||
;; ── field reads via messages (incl. inherited text) ──
|
||||
(content-test "heading text inherited" (str (blk-send h "text")) "Title")
|
||||
(content-test "heading level" (blk-send h "level") 2)
|
||||
(content-test "text body" (str (blk-send t "text")) "Body text")
|
||||
(content-test "image src" (str (blk-send img "src")) "/cat.png")
|
||||
(content-test "image alt" (str (blk-send img "alt")) "a cat")
|
||||
(content-test "code language" (str (blk-send code "language")) "sx")
|
||||
(content-test "code text inherited" (str (blk-send code "text")) "(+ 1 2)")
|
||||
(content-test "quote cite" (str (blk-send q "cite")) "Ada")
|
||||
(content-test "embed url" (str (blk-send em "url")) "https://v/1")
|
||||
(content-test "embed provider" (str (blk-send em "provider")) "vimeo")
|
||||
(content-test "list ordered" (blk-send ls "ordered") true)
|
||||
(content-test "list items" (blk-send ls "items") (list "one" "two"))
|
||||
|
||||
;; ── blk-get reads ivars directly ──
|
||||
(content-test "blk-get level" (blk-get h "level") 2)
|
||||
(content-test "blk-get missing nil" (blk-get h "nope") nil)
|
||||
|
||||
;; ── copy-on-write: blk-set returns a new block, original untouched ──
|
||||
(define h2 (blk-set h "level" 1))
|
||||
(content-test "blk-set new value" (blk-send h2 "level") 1)
|
||||
(content-test "blk-set original unchanged" (blk-send h "level") 2)
|
||||
(content-test "blk-set keeps id" (blk-id h2) "b1")
|
||||
(content-test "blk-set keeps text" (str (blk-send h2 "text")) "Title")
|
||||
|
||||
;; ── predicate ──
|
||||
(content-test "block? on heading" (block? h) true)
|
||||
(content-test "block? on divider" (block? dv) true)
|
||||
(content-test "block? on number" (block? 5) false)
|
||||
(content-test "block? on string" (block? "x") false)
|
||||
|
||||
;; ── isBlock message inherited by all ──
|
||||
(content-test "isBlock heading" (blk-send h "isBlock") true)
|
||||
(content-test "isBlock list" (blk-send ls "isBlock") true)
|
||||
|
||||
;; ── generic mk-block via wire tag ──
|
||||
(define
|
||||
g
|
||||
(mk-block
|
||||
"heading"
|
||||
"g1"
|
||||
(list (list "level" 3) (list "text" "Gen"))))
|
||||
(content-test "mk-block type" (blk-type g) "heading")
|
||||
(content-test "mk-block level" (blk-send g "level") 3)
|
||||
(content-test "mk-block text" (str (blk-send g "text")) "Gen")
|
||||
@@ -1,55 +0,0 @@
|
||||
;; Extension — callout / admonition block.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-markdown!)
|
||||
(content-bootstrap-text!)
|
||||
(content-bootstrap-callout!)
|
||||
|
||||
(define c (mk-callout "c" "warning" "Be careful"))
|
||||
|
||||
;; ── identity ──
|
||||
(content-test "callout is block" (block? c) true)
|
||||
(content-test "callout? yes" (callout? c) true)
|
||||
(content-test "callout type" (blk-type c) "callout")
|
||||
(content-test "callout kind" (callout-kind c) "warning")
|
||||
|
||||
;; ── render ──
|
||||
(content-test
|
||||
"callout html"
|
||||
(asHTML c)
|
||||
"<aside class=\"callout callout-warning\">Be careful</aside>")
|
||||
(content-test
|
||||
"callout sx"
|
||||
(asSx c)
|
||||
"(aside :class \"callout callout-warning\" \"Be careful\")")
|
||||
(content-test "callout text" (asText c) "Be careful")
|
||||
(content-test "callout markdown" (asMarkdown c) "> **warning:** Be careful")
|
||||
|
||||
;; ── html escapes text ──
|
||||
(content-test
|
||||
"callout html escapes"
|
||||
(asHTML (mk-callout "c" "note" "a < b"))
|
||||
"<aside class=\"callout callout-note\">a < b</aside>")
|
||||
|
||||
;; ── in a document ──
|
||||
(define
|
||||
d
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-heading "h" 1 "T"))
|
||||
c))
|
||||
(content-test
|
||||
"doc with callout html"
|
||||
(asHTML d)
|
||||
"<h1>T</h1><aside class=\"callout callout-warning\">Be careful</aside>")
|
||||
|
||||
;; ── validation ──
|
||||
(content-test
|
||||
"valid callout"
|
||||
(content/valid? (doc-append (doc-empty "d") c))
|
||||
true)
|
||||
(content-test
|
||||
"bad callout kind flagged"
|
||||
(content/issue-kinds
|
||||
(doc-append (doc-empty "d") (mk-callout "c" 5 "x")))
|
||||
(list "field"))
|
||||
@@ -1,55 +0,0 @@
|
||||
;; Extension — block id remapping / clone.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-section!)
|
||||
|
||||
(define
|
||||
d
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-heading "h" 1 "Title"))
|
||||
(mk-section "s" (list (mk-text "a" "A") (mk-text "b" "B")))))
|
||||
|
||||
;; ── prefix-ids rewrites every id in the tree ──
|
||||
(define p (content/prefix-ids d "x-"))
|
||||
(content-test "prefix top-level ids" (doc-ids p) (list "x-h" "x-s"))
|
||||
(content-test
|
||||
"prefix tree-ids"
|
||||
(doc-tree-ids p)
|
||||
(list "x-h" "x-s" "x-a" "x-b"))
|
||||
(content-test "prefix immutable" (doc-tree-ids d) (list "h" "s" "a" "b"))
|
||||
(content-test "prefix preserves content" (asHTML p) (asHTML d))
|
||||
(content-test
|
||||
"prefix preserves nested content"
|
||||
(str (blk-send (doc-deep-find p "x-a") "text"))
|
||||
"A")
|
||||
|
||||
;; ── custom remap fn ──
|
||||
(define u (content/remap-ids d (fn (id) (str id "!"))))
|
||||
(content-test "remap suffix" (doc-tree-ids u) (list "h!" "s!" "a!" "b!"))
|
||||
|
||||
;; ── collision-free composition ──
|
||||
(define
|
||||
d2
|
||||
(doc-append (doc-empty "d2") (mk-heading "h" 2 "Other")))
|
||||
(define
|
||||
combined
|
||||
(content/concat
|
||||
(content/prefix-ids d "left-")
|
||||
(content/prefix-ids d2 "right-")))
|
||||
(content-test
|
||||
"combined ids unique"
|
||||
(doc-tree-ids combined)
|
||||
(list "left-h" "left-s" "left-a" "left-b" "right-h"))
|
||||
(content-test "combined validates" (content/valid? combined) true)
|
||||
;; without prefixing, the shared id "h" collides
|
||||
(content-test
|
||||
"unprefixed collides"
|
||||
(content/valid? (content/concat d d2))
|
||||
false)
|
||||
|
||||
;; ── render of combined ──
|
||||
(content-test
|
||||
"combined render"
|
||||
(asHTML combined)
|
||||
"<h1>Title</h1><section><p>A</p><p>B</p></section><h2>Other</h2>")
|
||||
@@ -1,76 +0,0 @@
|
||||
;; Extension — document composition.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-section!)
|
||||
|
||||
(define
|
||||
a
|
||||
(doc-with-title
|
||||
(doc-append (doc-empty "a") (mk-heading "h" 1 "A"))
|
||||
"Doc A"))
|
||||
(define
|
||||
b
|
||||
(doc-append
|
||||
(doc-append (doc-empty "b") (mk-text "p" "B1"))
|
||||
(mk-text "q" "B2")))
|
||||
|
||||
;; ── concat ──
|
||||
(define ab (content/concat a b))
|
||||
(content-test "concat ids" (doc-ids ab) (list "h" "p" "q"))
|
||||
(content-test "concat keeps first id" (doc-id ab) "a")
|
||||
(content-test "concat keeps first title" (doc-title ab) "Doc A")
|
||||
(content-test "concat immutable a" (doc-ids a) (list "h"))
|
||||
(content-test "concat immutable b" (doc-ids b) (list "p" "q"))
|
||||
|
||||
;; ── prepend ──
|
||||
(define ba (content/prepend a b))
|
||||
(content-test "prepend ids" (doc-ids ba) (list "p" "q" "h"))
|
||||
(content-test "prepend keeps a id" (doc-id ba) "a")
|
||||
|
||||
;; ── concat with empty ──
|
||||
(content-test
|
||||
"concat empty right"
|
||||
(doc-ids (content/concat a (doc-empty "e")))
|
||||
(list "h"))
|
||||
(content-test
|
||||
"concat empty left"
|
||||
(doc-ids (content/concat (doc-empty "e") b))
|
||||
(list "p" "q"))
|
||||
|
||||
;; ── concat-all ──
|
||||
(define c (doc-append (doc-empty "c") (mk-divider "d")))
|
||||
(content-test
|
||||
"concat-all order"
|
||||
(doc-ids (content/concat-all (list a b c)))
|
||||
(list "h" "p" "q" "d"))
|
||||
(content-test
|
||||
"concat-all keeps first id"
|
||||
(doc-id (content/concat-all (list a b c)))
|
||||
"a")
|
||||
(content-test
|
||||
"concat-all single"
|
||||
(doc-ids (content/concat-all (list a)))
|
||||
(list "h"))
|
||||
(content-test
|
||||
"concat-all empty"
|
||||
(doc-ids (content/concat-all (list)))
|
||||
(list))
|
||||
|
||||
;; ── render of composed doc ──
|
||||
(content-test
|
||||
"composed renders"
|
||||
(asHTML (content/concat a b))
|
||||
"<h1>A</h1><p>B1</p><p>B2</p>")
|
||||
|
||||
;; ── wrap-section collapses blocks into a subtree ──
|
||||
(define w (content/wrap-section ab "sec"))
|
||||
(content-test "wrap top-level is one section" (doc-ids w) (list "sec"))
|
||||
(content-test
|
||||
"wrap children preserved"
|
||||
(doc-tree-ids w)
|
||||
(list "sec" "h" "p" "q"))
|
||||
(content-test
|
||||
"wrap renders nested"
|
||||
(asHTML w)
|
||||
"<section><h1>A</h1><p>B1</p><p>B2</p></section>")
|
||||
@@ -1,136 +0,0 @@
|
||||
;; Hardening — non-core block types (callout/table/media/section) survive the
|
||||
;; flat and tree CvRDT materialise paths (regression for the ct-class-for-type
|
||||
;; fix: these route through crdt-element->block -> mk-block).
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content-bootstrap-blocks!)
|
||||
(content-bootstrap-doc!)
|
||||
(content-bootstrap-render!)
|
||||
(content-bootstrap-section!)
|
||||
(content-bootstrap-callout!)
|
||||
(content-bootstrap-table!)
|
||||
(content-bootstrap-media!)
|
||||
|
||||
;; ── flat CRDT: callout / table / media leaves ──
|
||||
(define
|
||||
s
|
||||
(crdt-apply-all
|
||||
(crdt-empty)
|
||||
(list
|
||||
(crdt-op-insert
|
||||
"co"
|
||||
"callout"
|
||||
(crdt-pos 1 0)
|
||||
(list (list "kind" "note") (list "text" "hi"))
|
||||
1
|
||||
0)
|
||||
(crdt-op-insert
|
||||
"tb"
|
||||
"table"
|
||||
(crdt-pos 2 0)
|
||||
(list (list "headers" (list "A")) (list "rows" (list (list "1"))))
|
||||
1
|
||||
0)
|
||||
(crdt-op-insert
|
||||
"vid"
|
||||
"media"
|
||||
(crdt-pos 3 0)
|
||||
(list (list "kind" "video") (list "src" "/v.mp4"))
|
||||
1
|
||||
0))))
|
||||
(content-test
|
||||
"flat crdt callout render"
|
||||
(asHTML (crdt-materialize "d" s))
|
||||
"<aside class=\"callout callout-note\">hi</aside><table><thead><tr><th>A</th></tr></thead><tbody><tr><td>1</td></tr></tbody></table><video src=\"/v.mp4\" controls></video>")
|
||||
(content-test "flat crdt order" (crdt-order s) (list "co" "tb" "vid"))
|
||||
|
||||
;; ── flat CRDT: callout field via LWW update ──
|
||||
(define s2 (crdt-update s "co" "text" "edited" 5 1))
|
||||
(content-test
|
||||
"flat crdt callout update"
|
||||
(str (blk-send (doc-find (crdt-materialize "d" s2) "co") "text"))
|
||||
"edited")
|
||||
|
||||
;; ── tree CRDT: callout/table inside a section ──
|
||||
(define
|
||||
t
|
||||
(crdt-tree-apply-all
|
||||
(crdt-empty)
|
||||
(list
|
||||
(crdt-tree-op-insert
|
||||
"sec"
|
||||
"section"
|
||||
(crdt-pos 1 0)
|
||||
""
|
||||
(list)
|
||||
1
|
||||
0)
|
||||
(crdt-tree-op-insert
|
||||
"co"
|
||||
"callout"
|
||||
(crdt-pos 1 0)
|
||||
"sec"
|
||||
(list (list "kind" "tip") (list "text" "T"))
|
||||
1
|
||||
0)
|
||||
(crdt-tree-op-insert
|
||||
"tb"
|
||||
"table"
|
||||
(crdt-pos 2 0)
|
||||
"sec"
|
||||
(list (list "headers" (list "H")) (list "rows" (list)))
|
||||
1
|
||||
0))))
|
||||
(content-test
|
||||
"tree crdt nested blocks"
|
||||
(doc-tree-ids (crdt-tree-materialize "d" t))
|
||||
(list "sec" "co" "tb"))
|
||||
(content-test
|
||||
"tree crdt nested render"
|
||||
(asHTML (crdt-tree-materialize "d" t))
|
||||
"<section><aside class=\"callout callout-tip\">T</aside><table><thead><tr><th>H</th></tr></thead><tbody></tbody></table></section>")
|
||||
|
||||
;; ── tree CRDT: concurrent callout inserts into a section converge ──
|
||||
(define
|
||||
base
|
||||
(crdt-tree-insert
|
||||
(crdt-empty)
|
||||
"sec"
|
||||
"section"
|
||||
(crdt-pos 1 0)
|
||||
""
|
||||
(list)
|
||||
1
|
||||
0))
|
||||
(define
|
||||
rA
|
||||
(crdt-tree-insert
|
||||
base
|
||||
"x"
|
||||
"callout"
|
||||
(crdt-pos 5 1)
|
||||
"sec"
|
||||
(list (list "kind" "note") (list "text" "A"))
|
||||
2
|
||||
1))
|
||||
(define
|
||||
rB
|
||||
(crdt-tree-insert
|
||||
base
|
||||
"y"
|
||||
"media"
|
||||
(crdt-pos 5 2)
|
||||
"sec"
|
||||
(list (list "kind" "audio") (list "src" "/a.mp3"))
|
||||
2
|
||||
2))
|
||||
(content-test
|
||||
"tree crdt mixed converge"
|
||||
(=
|
||||
(get (crdt-tree-merge rA rB) :elements)
|
||||
(get (crdt-tree-merge rB rA) :elements))
|
||||
true)
|
||||
(content-test
|
||||
"tree crdt mixed ids"
|
||||
(doc-tree-ids (crdt-tree-materialize "d" (crdt-tree-merge rA rB)))
|
||||
(list "sec" "x" "y"))
|
||||
@@ -1,139 +0,0 @@
|
||||
;; Extension — durable collaborative replication (CRDT ops on persist).
|
||||
;; Replicas log independently; converge merges the logs deterministically.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content-bootstrap-blocks!)
|
||||
(content-bootstrap-doc!)
|
||||
(content-bootstrap-render!)
|
||||
|
||||
(define same? (fn (a b) (= (get a :elements) (get b :elements))))
|
||||
(define B (persist/open))
|
||||
|
||||
;; replica "a" (origin): inserts h, p
|
||||
(crdt/commit!
|
||||
B
|
||||
"doc"
|
||||
"a"
|
||||
(crdt-op-insert
|
||||
"h"
|
||||
"heading"
|
||||
(crdt-pos 1 0)
|
||||
(list (list "level" 1) (list "text" "T"))
|
||||
1
|
||||
1)
|
||||
1)
|
||||
(crdt/commit!
|
||||
B
|
||||
"doc"
|
||||
"a"
|
||||
(crdt-op-insert
|
||||
"p"
|
||||
"text"
|
||||
(crdt-pos 2 0)
|
||||
(list (list "text" "Body"))
|
||||
1
|
||||
1)
|
||||
1)
|
||||
|
||||
;; replica "b" (concurrent): edits p, inserts x
|
||||
(crdt/commit-all!
|
||||
B
|
||||
"doc"
|
||||
"b"
|
||||
(list
|
||||
(crdt-op-update "p" "text" "Edited" 5 2)
|
||||
(crdt-op-insert
|
||||
"x"
|
||||
"text"
|
||||
(crdt-pos 3 0)
|
||||
(list (list "text" "X"))
|
||||
6
|
||||
2))
|
||||
5)
|
||||
|
||||
;; ── durability ──
|
||||
(content-test
|
||||
"replica a version"
|
||||
(crdt/replica-version B "doc" "a")
|
||||
2)
|
||||
(content-test
|
||||
"replica b version"
|
||||
(crdt/replica-version B "doc" "b")
|
||||
2)
|
||||
(content-test
|
||||
"replica a ops len"
|
||||
(len (crdt/replica-ops B "doc" "a"))
|
||||
2)
|
||||
|
||||
;; ── single-replica replay ──
|
||||
(content-test
|
||||
"replay a order"
|
||||
(crdt-order (crdt/replay B "doc" "a"))
|
||||
(list "h" "p"))
|
||||
(content-test
|
||||
"replay a == apply-all"
|
||||
(same?
|
||||
(crdt/replay B "doc" "a")
|
||||
(crdt-apply-all (crdt-empty) (crdt/replica-ops B "doc" "a")))
|
||||
true)
|
||||
|
||||
;; ── converge ──
|
||||
(content-test
|
||||
"converge order"
|
||||
(crdt/order B "doc" (list "a" "b"))
|
||||
(list "h" "p" "x"))
|
||||
(content-test
|
||||
"converge replica-order-independent"
|
||||
(same?
|
||||
(crdt/converge B "doc" (list "a" "b"))
|
||||
(crdt/converge B "doc" (list "b" "a")))
|
||||
true)
|
||||
(content-test
|
||||
"converge LWW p edited"
|
||||
(str
|
||||
(blk-send (doc-find (crdt/document B "doc" (list "a" "b")) "p") "text"))
|
||||
"Edited")
|
||||
(content-test
|
||||
"converged document render"
|
||||
(asHTML (crdt/document B "doc" (list "a" "b")))
|
||||
"<h1>T</h1><p>Edited</p><p>X</p>")
|
||||
|
||||
;; ── duplicate delivery is idempotent ──
|
||||
(crdt/commit!
|
||||
B
|
||||
"doc"
|
||||
"a"
|
||||
(crdt-op-insert
|
||||
"p"
|
||||
"text"
|
||||
(crdt-pos 2 0)
|
||||
(list (list "text" "Body"))
|
||||
1
|
||||
1)
|
||||
1)
|
||||
(content-test
|
||||
"duplicate op no effect on converge"
|
||||
(crdt/order B "doc" (list "a" "b"))
|
||||
(list "h" "p" "x"))
|
||||
(content-test
|
||||
"duplicate keeps LWW value"
|
||||
(str
|
||||
(blk-send (doc-find (crdt/document B "doc" (list "a" "b")) "p") "text"))
|
||||
"Edited")
|
||||
|
||||
;; ── new op on a replica is reflected after re-converge ──
|
||||
(crdt/commit! B "doc" "b" (crdt-op-delete "h") 9)
|
||||
(content-test
|
||||
"delete reflected after reconverge"
|
||||
(crdt/order B "doc" (list "a" "b"))
|
||||
(list "p" "x"))
|
||||
|
||||
;; ── isolation: unknown doc converges to empty ──
|
||||
(content-test
|
||||
"unknown doc empty"
|
||||
(crdt/order B "other" (list "a" "b"))
|
||||
(list))
|
||||
(content-test
|
||||
"unknown replica empty ops"
|
||||
(len (crdt/replica-ops B "doc" "zzz"))
|
||||
0)
|
||||
@@ -1,289 +0,0 @@
|
||||
;; Extension — nested-tree CvRDT. Sections nest and merge collaboratively;
|
||||
;; convergence is order/replica/duplicate-insensitive like the flat layer.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content-bootstrap-blocks!)
|
||||
(content-bootstrap-doc!)
|
||||
(content-bootstrap-render!)
|
||||
(content-bootstrap-section!)
|
||||
|
||||
(define same? (fn (a b) (= (get a :elements) (get b :elements))))
|
||||
|
||||
;; base: a section "s" at root, with one child heading.
|
||||
(define
|
||||
base
|
||||
(crdt-tree-insert
|
||||
(crdt-tree-insert
|
||||
(crdt-empty)
|
||||
"s"
|
||||
"section"
|
||||
(crdt-pos 1 0)
|
||||
""
|
||||
(list)
|
||||
1
|
||||
0)
|
||||
"h"
|
||||
"heading"
|
||||
(crdt-pos 1 0)
|
||||
"s"
|
||||
(list (list "level" 2) (list "text" "Sub"))
|
||||
1
|
||||
0))
|
||||
|
||||
;; ── materialise rebuilds the tree ──
|
||||
(content-test "tree order root" (crdt-tree-order base) (list "s"))
|
||||
(content-test
|
||||
"tree materialize ids"
|
||||
(doc-tree-ids (crdt-tree-materialize "d" base))
|
||||
(list "s" "h"))
|
||||
(content-test
|
||||
"tree render"
|
||||
(asHTML (crdt-tree-materialize "d" base))
|
||||
"<section><h2>Sub</h2></section>")
|
||||
|
||||
;; ── concurrent inserts into the SAME section converge + order by pos ──
|
||||
(define
|
||||
rA
|
||||
(crdt-tree-insert
|
||||
base
|
||||
"a"
|
||||
"text"
|
||||
(crdt-pos 5 1)
|
||||
"s"
|
||||
(list (list "text" "A"))
|
||||
2
|
||||
1))
|
||||
(define
|
||||
rB
|
||||
(crdt-tree-insert
|
||||
base
|
||||
"b"
|
||||
"text"
|
||||
(crdt-pos 5 2)
|
||||
"s"
|
||||
(list (list "text" "B"))
|
||||
2
|
||||
2))
|
||||
(content-test
|
||||
"same-parent merge commutes"
|
||||
(same? (crdt-tree-merge rA rB) (crdt-tree-merge rB rA))
|
||||
true)
|
||||
(content-test
|
||||
"same-parent order deterministic"
|
||||
(doc-tree-ids (crdt-tree-materialize "d" (crdt-tree-merge rA rB)))
|
||||
(list "s" "h" "a" "b"))
|
||||
|
||||
;; ── concurrent inserts into DIFFERENT parents converge ──
|
||||
(define
|
||||
base2
|
||||
(crdt-tree-insert
|
||||
(crdt-tree-insert
|
||||
(crdt-empty)
|
||||
"s1"
|
||||
"section"
|
||||
(crdt-pos 1 0)
|
||||
""
|
||||
(list)
|
||||
1
|
||||
0)
|
||||
"s2"
|
||||
"section"
|
||||
(crdt-pos 2 0)
|
||||
""
|
||||
(list)
|
||||
1
|
||||
0))
|
||||
(define
|
||||
x
|
||||
(crdt-tree-insert
|
||||
base2
|
||||
"x"
|
||||
"text"
|
||||
(crdt-pos 1 0)
|
||||
"s1"
|
||||
(list (list "text" "X"))
|
||||
2
|
||||
1))
|
||||
(define
|
||||
y
|
||||
(crdt-tree-insert
|
||||
base2
|
||||
"y"
|
||||
"text"
|
||||
(crdt-pos 1 0)
|
||||
"s2"
|
||||
(list (list "text" "Y"))
|
||||
2
|
||||
2))
|
||||
(define m (crdt-tree-merge x y))
|
||||
(content-test
|
||||
"different-parent commutes"
|
||||
(same? m (crdt-tree-merge y x))
|
||||
true)
|
||||
(content-test
|
||||
"different-parent tree"
|
||||
(doc-tree-ids (crdt-tree-materialize "d" m))
|
||||
(list "s1" "x" "s2" "y"))
|
||||
(content-test
|
||||
"different-parent render"
|
||||
(asHTML (crdt-tree-materialize "d" m))
|
||||
"<section><p>X</p></section><section><p>Y</p></section>")
|
||||
|
||||
;; ── nested sections (section inside section) ──
|
||||
(define
|
||||
nested
|
||||
(crdt-tree-apply-all
|
||||
(crdt-empty)
|
||||
(list
|
||||
(crdt-tree-op-insert
|
||||
"outer"
|
||||
"section"
|
||||
(crdt-pos 1 0)
|
||||
""
|
||||
(list)
|
||||
1
|
||||
0)
|
||||
(crdt-tree-op-insert
|
||||
"inner"
|
||||
"section"
|
||||
(crdt-pos 1 0)
|
||||
"outer"
|
||||
(list)
|
||||
1
|
||||
0)
|
||||
(crdt-tree-op-insert
|
||||
"leaf"
|
||||
"text"
|
||||
(crdt-pos 1 0)
|
||||
"inner"
|
||||
(list (list "text" "deep"))
|
||||
1
|
||||
0))))
|
||||
(content-test
|
||||
"nested tree ids"
|
||||
(doc-tree-ids (crdt-tree-materialize "d" nested))
|
||||
(list "outer" "inner" "leaf"))
|
||||
(content-test
|
||||
"nested render"
|
||||
(asHTML (crdt-tree-materialize "d" nested))
|
||||
"<section><section><p>deep</p></section></section>")
|
||||
|
||||
;; ── ops in any order converge (commutative) ──
|
||||
(define
|
||||
opA
|
||||
(crdt-tree-op-insert
|
||||
"p"
|
||||
"text"
|
||||
(crdt-pos 6 0)
|
||||
"s"
|
||||
(list (list "text" "P"))
|
||||
3
|
||||
1))
|
||||
(define opB (crdt-tree-op-update "h" "text" "Edited" 5 1))
|
||||
(define opC (crdt-tree-op-delete "h"))
|
||||
(content-test
|
||||
"ops commute"
|
||||
(same?
|
||||
(crdt-tree-apply-all base (list opA opB opC))
|
||||
(crdt-tree-apply-all base (list opC opB opA)))
|
||||
true)
|
||||
(content-test
|
||||
"ops idempotent"
|
||||
(same?
|
||||
(crdt-tree-apply-all base (list opA opB))
|
||||
(crdt-tree-apply-all
|
||||
(crdt-tree-apply-all base (list opA opB))
|
||||
(list opA opB)))
|
||||
true)
|
||||
|
||||
;; ── update into a section + LWW ──
|
||||
(define u1 (crdt-tree-update base "h" "text" "v5" 5 1))
|
||||
(define u2 (crdt-tree-update base "h" "text" "v7" 7 2))
|
||||
(content-test
|
||||
"tree LWW higher ts"
|
||||
(str
|
||||
(blk-send
|
||||
(doc-deep-find (crdt-tree-materialize "d" (crdt-tree-merge u1 u2)) "h")
|
||||
"text"))
|
||||
"v7")
|
||||
|
||||
;; ── delete inside a section ──
|
||||
(content-test
|
||||
"delete in section"
|
||||
(doc-tree-ids (crdt-tree-materialize "d" (crdt-tree-delete base "h")))
|
||||
(list "s"))
|
||||
|
||||
;; ── merge idempotence ──
|
||||
(content-test "merge idempotent self" (same? (crdt-tree-merge m m) m) true)
|
||||
|
||||
;; ── full convergence: two replicas, divergent edits in different sections ──
|
||||
(define
|
||||
repl1
|
||||
(crdt-tree-apply-all
|
||||
base2
|
||||
(list
|
||||
(crdt-tree-op-insert
|
||||
"p1"
|
||||
"text"
|
||||
(crdt-pos 1 0)
|
||||
"s1"
|
||||
(list (list "text" "from1"))
|
||||
5
|
||||
1))))
|
||||
(define
|
||||
repl2
|
||||
(crdt-tree-apply-all
|
||||
base2
|
||||
(list
|
||||
(crdt-tree-op-insert
|
||||
"p2"
|
||||
"text"
|
||||
(crdt-pos 1 0)
|
||||
"s2"
|
||||
(list (list "text" "from2"))
|
||||
6
|
||||
2))))
|
||||
(content-test
|
||||
"two-replica tree converges"
|
||||
(same? (crdt-tree-merge repl1 repl2) (crdt-tree-merge repl2 repl1))
|
||||
true)
|
||||
(content-test
|
||||
"two-replica tree ids"
|
||||
(doc-tree-ids (crdt-tree-materialize "d" (crdt-tree-merge repl1 repl2)))
|
||||
(list "s1" "p1" "s2" "p2"))
|
||||
|
||||
;; ── orphan reparenting: concurrent delete-section + insert-child ──
|
||||
;; A deletes section s; B inserts a child into s. After merge, s is gone but the
|
||||
;; child must survive (reparented to root), not silently vanish.
|
||||
(define delA (crdt-tree-delete base "s"))
|
||||
(define
|
||||
insB
|
||||
(crdt-tree-insert
|
||||
base
|
||||
"c"
|
||||
"text"
|
||||
(crdt-pos 9 0)
|
||||
"s"
|
||||
(list (list "text" "kept"))
|
||||
5
|
||||
2))
|
||||
(define orphan-merge (crdt-tree-merge delA insB))
|
||||
(content-test
|
||||
"orphan survives delete-section"
|
||||
(doc-tree-ids (crdt-tree-materialize "d" orphan-merge))
|
||||
(list "h" "c"))
|
||||
(content-test
|
||||
"orphan reparent commutes"
|
||||
(same? orphan-merge (crdt-tree-merge insB delA))
|
||||
true)
|
||||
(content-test
|
||||
"orphan content preserved"
|
||||
(str
|
||||
(blk-send
|
||||
(doc-deep-find (crdt-tree-materialize "d" orphan-merge) "c")
|
||||
"text"))
|
||||
"kept")
|
||||
(content-test
|
||||
"orphan render at root"
|
||||
(asHTML (crdt-tree-materialize "d" orphan-merge))
|
||||
"<h2>Sub</h2><p>kept</p>")
|
||||
@@ -1,315 +0,0 @@
|
||||
;; Phase 3 — collaborative merge (CvRDT). The merge is a join: commutative,
|
||||
;; associative, idempotent. Tests apply ops in any order, twice, and merge
|
||||
;; replicas both ways — all must converge to identical state.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content-bootstrap-blocks!)
|
||||
(content-bootstrap-doc!)
|
||||
(content-bootstrap-render!)
|
||||
|
||||
(define same? (fn (a b) (= (get a :elements) (get b :elements))))
|
||||
|
||||
;; ── position order (Logoot) ──
|
||||
(content-test
|
||||
"pos lt"
|
||||
(crdt-pos-compare
|
||||
(crdt-pos 1 0)
|
||||
(crdt-pos 2 0))
|
||||
-1)
|
||||
(content-test
|
||||
"pos gt"
|
||||
(crdt-pos-compare
|
||||
(crdt-pos 2 0)
|
||||
(crdt-pos 1 0))
|
||||
1)
|
||||
(content-test
|
||||
"pos eq"
|
||||
(crdt-pos-compare
|
||||
(crdt-pos 1 0)
|
||||
(crdt-pos 1 0))
|
||||
0)
|
||||
(content-test
|
||||
"pos actor tiebreak"
|
||||
(crdt-pos-compare
|
||||
(crdt-pos 1 1)
|
||||
(crdt-pos 1 2))
|
||||
-1)
|
||||
(content-test
|
||||
"between > left"
|
||||
(<
|
||||
(crdt-pos-compare
|
||||
(crdt-pos 1 0)
|
||||
(crdt-pos-between
|
||||
(crdt-pos 1 0)
|
||||
(crdt-pos 2 0)
|
||||
9))
|
||||
0)
|
||||
true)
|
||||
(content-test
|
||||
"between < right"
|
||||
(<
|
||||
(crdt-pos-compare
|
||||
(crdt-pos-between
|
||||
(crdt-pos 1 0)
|
||||
(crdt-pos 2 0)
|
||||
9)
|
||||
(crdt-pos 2 0))
|
||||
0)
|
||||
true)
|
||||
(content-test
|
||||
"between start < right"
|
||||
(<
|
||||
(crdt-pos-compare
|
||||
(crdt-pos-between nil (crdt-pos 5 0) 9)
|
||||
(crdt-pos 5 0))
|
||||
0)
|
||||
true)
|
||||
(content-test
|
||||
"between end > left"
|
||||
(<
|
||||
(crdt-pos-compare
|
||||
(crdt-pos 5 0)
|
||||
(crdt-pos-between (crdt-pos 5 0) nil 9))
|
||||
0)
|
||||
true)
|
||||
|
||||
;; ── build + materialise ──
|
||||
(define
|
||||
base
|
||||
(crdt-insert
|
||||
(crdt-insert
|
||||
(crdt-empty)
|
||||
"h"
|
||||
"heading"
|
||||
(crdt-pos 1 0)
|
||||
(list (list "level" 1) (list "text" "Title"))
|
||||
1
|
||||
0)
|
||||
"p"
|
||||
"text"
|
||||
(crdt-pos 2 0)
|
||||
(list (list "text" "Body"))
|
||||
1
|
||||
0))
|
||||
|
||||
(content-test "order" (crdt-order base) (list "h" "p"))
|
||||
(content-test
|
||||
"materialize ids"
|
||||
(doc-ids (crdt-materialize "d" base))
|
||||
(list "h" "p"))
|
||||
(content-test
|
||||
"materialize render"
|
||||
(asHTML (crdt-materialize "d" base))
|
||||
"<h1>Title</h1><p>Body</p>")
|
||||
|
||||
;; ── commutativity: ops in any order converge ──
|
||||
(define
|
||||
opA
|
||||
(crdt-op-insert
|
||||
"x"
|
||||
"text"
|
||||
(crdt-pos 3 0)
|
||||
(list (list "text" "X"))
|
||||
2
|
||||
1))
|
||||
(define opB (crdt-op-update "p" "text" "Edited" 5 1))
|
||||
(define opC (crdt-op-delete "h"))
|
||||
(define s-abc (crdt-apply-all base (list opA opB opC)))
|
||||
(define s-cba (crdt-apply-all base (list opC opB opA)))
|
||||
(define s-bca (crdt-apply-all base (list opB opC opA)))
|
||||
(content-test "commutative abc=cba" (same? s-abc s-cba) true)
|
||||
(content-test "commutative abc=bca" (same? s-abc s-bca) true)
|
||||
(content-test "commutative result order" (crdt-order s-abc) (list "p" "x"))
|
||||
|
||||
;; ── idempotence: applying ops twice changes nothing ──
|
||||
(content-test
|
||||
"idempotent ops"
|
||||
(same? s-abc (crdt-apply-all s-abc (list opA opB opC)))
|
||||
true)
|
||||
|
||||
;; ── update-before-insert is not lost ──
|
||||
(define
|
||||
ub
|
||||
(crdt-apply-all
|
||||
(crdt-empty)
|
||||
(list
|
||||
(crdt-op-update "z" "text" "late" 3 1)
|
||||
(crdt-op-insert
|
||||
"z"
|
||||
"text"
|
||||
(crdt-pos 1 0)
|
||||
(list (list "text" "orig"))
|
||||
1
|
||||
1))))
|
||||
(content-test
|
||||
"update before insert kept"
|
||||
(str (blk-send (doc-find (crdt-materialize "d" ub) "z") "text"))
|
||||
"late")
|
||||
|
||||
;; ── delete-before-insert: remove-wins ──
|
||||
(define
|
||||
db
|
||||
(crdt-apply-all
|
||||
(crdt-empty)
|
||||
(list
|
||||
(crdt-op-delete "k")
|
||||
(crdt-op-insert
|
||||
"k"
|
||||
"text"
|
||||
(crdt-pos 1 0)
|
||||
(list (list "text" "x"))
|
||||
1
|
||||
1))))
|
||||
(content-test "delete before insert removes" (crdt-order db) (list))
|
||||
|
||||
;; ── concurrent inserts converge + deterministic order ──
|
||||
(define
|
||||
rA
|
||||
(crdt-insert
|
||||
base
|
||||
"a1"
|
||||
"text"
|
||||
(crdt-pos 5 1)
|
||||
(list (list "text" "A"))
|
||||
2
|
||||
1))
|
||||
(define
|
||||
rB
|
||||
(crdt-insert
|
||||
base
|
||||
"b1"
|
||||
"text"
|
||||
(crdt-pos 5 2)
|
||||
(list (list "text" "B"))
|
||||
2
|
||||
2))
|
||||
(content-test
|
||||
"merge commutes"
|
||||
(same? (crdt-merge rA rB) (crdt-merge rB rA))
|
||||
true)
|
||||
(content-test
|
||||
"merge order deterministic AB"
|
||||
(crdt-order (crdt-merge rA rB))
|
||||
(list "h" "p" "a1" "b1"))
|
||||
(content-test
|
||||
"merge order deterministic BA"
|
||||
(crdt-order (crdt-merge rB rA))
|
||||
(list "h" "p" "a1" "b1"))
|
||||
|
||||
;; ── merge idempotence ──
|
||||
(define mAB (crdt-merge rA rB))
|
||||
(content-test "merge idempotent self" (same? (crdt-merge mAB mAB) mAB) true)
|
||||
(content-test
|
||||
"merge idempotent remerge"
|
||||
(same? (crdt-merge mAB rA) mAB)
|
||||
true)
|
||||
|
||||
;; ── concurrent same-field update: LWW by (ts, actor) ──
|
||||
(define u1 (crdt-update base "p" "text" "v-ts5" 5 1))
|
||||
(define u2 (crdt-update base "p" "text" "v-ts7" 7 2))
|
||||
(content-test
|
||||
"LWW higher ts wins"
|
||||
(str
|
||||
(blk-send
|
||||
(doc-find (crdt-materialize "d" (crdt-merge u1 u2)) "p")
|
||||
"text"))
|
||||
"v-ts7")
|
||||
(content-test
|
||||
"LWW commutes"
|
||||
(same? (crdt-merge u1 u2) (crdt-merge u2 u1))
|
||||
true)
|
||||
(define t1 (crdt-update base "p" "text" "actor1" 9 1))
|
||||
(define t2 (crdt-update base "p" "text" "actor2" 9 2))
|
||||
(content-test
|
||||
"LWW tie -> actor wins"
|
||||
(str
|
||||
(blk-send
|
||||
(doc-find (crdt-materialize "d" (crdt-merge t1 t2)) "p")
|
||||
"text"))
|
||||
"actor2")
|
||||
|
||||
;; ── concurrent disjoint-field updates both survive ──
|
||||
(define f1 (crdt-update base "h" "text" "NewTitle" 5 1))
|
||||
(define f2 (crdt-update base "h" "level" 3 5 2))
|
||||
(define fm (crdt-merge f1 f2))
|
||||
(content-test
|
||||
"disjoint field text"
|
||||
(str (blk-send (doc-find (crdt-materialize "d" fm) "h") "text"))
|
||||
"NewTitle")
|
||||
(content-test
|
||||
"disjoint field level"
|
||||
(blk-send (doc-find (crdt-materialize "d" fm) "h") "level")
|
||||
3)
|
||||
(content-test "disjoint commutes" (same? fm (crdt-merge f2 f1)) true)
|
||||
|
||||
;; ── associativity ──
|
||||
(define c1 (crdt-update base "p" "text" "c1" 4 1))
|
||||
(define
|
||||
c2
|
||||
(crdt-insert
|
||||
base
|
||||
"n2"
|
||||
"text"
|
||||
(crdt-pos 6 0)
|
||||
(list (list "text" "N"))
|
||||
2
|
||||
2))
|
||||
(define c3 (crdt-delete base "h"))
|
||||
(content-test
|
||||
"associative"
|
||||
(same?
|
||||
(crdt-merge (crdt-merge c1 c2) c3)
|
||||
(crdt-merge c1 (crdt-merge c2 c3)))
|
||||
true)
|
||||
(content-test
|
||||
"merge-all = fold"
|
||||
(same?
|
||||
(crdt-merge-all (list c1 c2 c3))
|
||||
(crdt-merge c1 (crdt-merge c2 c3)))
|
||||
true)
|
||||
|
||||
;; ── full convergence: two replicas, divergent edits, merge both ways ──
|
||||
(define
|
||||
repl-1
|
||||
(crdt-apply-all
|
||||
base
|
||||
(list
|
||||
(crdt-op-update "p" "text" "from-1" 5 1)
|
||||
(crdt-op-insert
|
||||
"img"
|
||||
"image"
|
||||
(crdt-pos-between
|
||||
(crdt-pos 1 0)
|
||||
(crdt-pos 2 0)
|
||||
1)
|
||||
(list (list "src" "/a.png") (list "alt" "a"))
|
||||
6
|
||||
1))))
|
||||
(define
|
||||
repl-2
|
||||
(crdt-apply-all
|
||||
base
|
||||
(list
|
||||
(crdt-op-delete "h")
|
||||
(crdt-op-update "p" "text" "from-2" 7 2))))
|
||||
(content-test
|
||||
"two-replica converges"
|
||||
(same? (crdt-merge repl-1 repl-2) (crdt-merge repl-2 repl-1))
|
||||
true)
|
||||
(content-test
|
||||
"two-replica result order"
|
||||
(crdt-order (crdt-merge repl-1 repl-2))
|
||||
(list "img" "p"))
|
||||
(content-test
|
||||
"two-replica LWW field"
|
||||
(str
|
||||
(blk-send
|
||||
(doc-find (crdt-materialize "d" (crdt-merge repl-1 repl-2)) "p")
|
||||
"text"))
|
||||
"from-2")
|
||||
(content-test
|
||||
"two-replica idempotent"
|
||||
(same?
|
||||
(crdt-merge (crdt-merge repl-1 repl-2) repl-1)
|
||||
(crdt-merge repl-1 repl-2))
|
||||
true)
|
||||
@@ -1,116 +0,0 @@
|
||||
;; Extension — portable data serialization (to-data / from-data round-trip).
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-text!)
|
||||
(content-bootstrap-markdown!)
|
||||
(content-bootstrap-section!)
|
||||
(content-bootstrap-table!)
|
||||
(content-bootstrap-callout!)
|
||||
(content-bootstrap-media!)
|
||||
|
||||
;; ── block->data shape ──
|
||||
(define h (mk-heading "h" 2 "Hi"))
|
||||
(content-test "block->data id" (get (block->data h) :id) "h")
|
||||
(content-test "block->data type" (get (block->data h) :type) "heading")
|
||||
(content-test "block->data fields" (get (block->data h) :fields) {:text "Hi" :level 2})
|
||||
|
||||
;; ── round-trip a mixed document with metadata ──
|
||||
(define
|
||||
d
|
||||
(doc-with-meta
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append (doc-empty "post") (mk-heading "h" 1 "Title"))
|
||||
(mk-text "p" "Body"))
|
||||
(mk-image "img" "/c.png" "cat"))
|
||||
(mk-list "l" true (list "a" "b")))
|
||||
{:slug "s" :title "T" :tags (list "x" "y")}))
|
||||
|
||||
(define rt (content/from-data (content/to-data d)))
|
||||
(content-test "rt id" (doc-id rt) "post")
|
||||
(content-test "rt title" (doc-title rt) "T")
|
||||
(content-test "rt slug" (doc-slug rt) "s")
|
||||
(content-test "rt tags" (doc-tags rt) (list "x" "y"))
|
||||
(content-test "rt ids" (doc-ids rt) (list "h" "p" "img" "l"))
|
||||
(content-test "rt render" (asHTML rt) (asHTML d))
|
||||
(content-test
|
||||
"rt heading level"
|
||||
(blk-send (doc-find rt "h") "level")
|
||||
1)
|
||||
(content-test
|
||||
"rt list items"
|
||||
(blk-send (doc-find rt "l") "items")
|
||||
(list "a" "b"))
|
||||
|
||||
;; ── nested sections round-trip ──
|
||||
(define
|
||||
ds
|
||||
(doc-append
|
||||
(doc-empty "d")
|
||||
(mk-section
|
||||
"s"
|
||||
(list
|
||||
(mk-heading "nh" 2 "N")
|
||||
(mk-section "i" (list (mk-text "x" "deep")))))))
|
||||
(define rts (content/from-data (content/to-data ds)))
|
||||
(content-test "rt nested render" (asHTML rts) (asHTML ds))
|
||||
(content-test "rt nested tree-ids" (doc-tree-ids rts) (doc-tree-ids ds))
|
||||
(content-test
|
||||
"rt nested deep-find"
|
||||
(str (blk-send (doc-deep-find rts "x") "text"))
|
||||
"deep")
|
||||
|
||||
;; ── table round-trip ──
|
||||
(define
|
||||
dtb
|
||||
(doc-append
|
||||
(doc-empty "d")
|
||||
(mk-table "t" (list "A" "B") (list (list "1" "2")))))
|
||||
(define rtt (content/from-data (content/to-data dtb)))
|
||||
(content-test "rt table render" (asHTML rtt) (asHTML dtb))
|
||||
(content-test
|
||||
"rt table headers"
|
||||
(table-headers (doc-find rtt "t"))
|
||||
(list "A" "B"))
|
||||
|
||||
;; ── callout + media round-trip (regression: ct-class-for-type must know them) ──
|
||||
(define
|
||||
dcm
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-callout "co" "warning" "careful"))
|
||||
(mk-video "vid" "/clip.mp4")))
|
||||
(define rtcm (content/from-data (content/to-data dcm)))
|
||||
(content-test "rt callout+media render" (asHTML rtcm) (asHTML dcm))
|
||||
(content-test
|
||||
"rt callout kind"
|
||||
(str (blk-send (doc-find rtcm "co") "kind"))
|
||||
"warning")
|
||||
(content-test
|
||||
"rt media kind"
|
||||
(str (blk-send (doc-find rtcm "vid") "kind"))
|
||||
"video")
|
||||
(content-test
|
||||
"rt callout+media types"
|
||||
(doc-types rtcm)
|
||||
(list "callout" "media"))
|
||||
|
||||
;; ── data is plain (no st-instance markers at top level) ──
|
||||
(define dat (content/to-data d))
|
||||
(content-test "data id field" (get dat :id) "post")
|
||||
(content-test "data block count" (len (get dat :blocks)) 4)
|
||||
(content-test
|
||||
"data first block type"
|
||||
(get (first (get dat :blocks)) :type)
|
||||
"heading")
|
||||
|
||||
;; ── empty doc round-trip ──
|
||||
(content-test
|
||||
"rt empty ids"
|
||||
(doc-ids (content/from-data (content/to-data (doc-empty "e"))))
|
||||
(list))
|
||||
(content-test
|
||||
"rt no-meta title nil"
|
||||
(doc-title (content/from-data (content/to-data (doc-empty "e"))))
|
||||
nil)
|
||||
@@ -1,132 +0,0 @@
|
||||
;; Phase 1 — ordered block document: apply edit ops, structural moves.
|
||||
;; Every op returns a NEW document; the input is never mutated.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content-bootstrap-blocks!)
|
||||
(content-bootstrap-doc!)
|
||||
|
||||
(define h (mk-heading "h" 1 "Title"))
|
||||
(define p1 (mk-text "p1" "First"))
|
||||
(define p2 (mk-text "p2" "Second"))
|
||||
(define img (mk-image "img" "/c.png" "cat"))
|
||||
|
||||
;; ── empty + construction ──
|
||||
(define d0 (doc-empty "doc1"))
|
||||
(content-test "empty id" (doc-id d0) "doc1")
|
||||
(content-test "empty type" (doc-type d0) "document")
|
||||
(content-test "empty count" (doc-count d0) 0)
|
||||
(content-test "doc? on doc" (doc? d0) true)
|
||||
(content-test "doc? on block" (doc? h) false)
|
||||
|
||||
;; ── append + order ──
|
||||
(define d1 (doc-append (doc-append (doc-append d0 h) p1) p2))
|
||||
(content-test "append count" (doc-count d1) 3)
|
||||
(content-test "append order" (doc-ids d1) (list "h" "p1" "p2"))
|
||||
(content-test "append types" (doc-types d1) (list "heading" "text" "text"))
|
||||
(content-test "block-at 0" (blk-id (doc-block-at d1 0)) "h")
|
||||
|
||||
;; ── append is immutable ──
|
||||
(content-test "append leaves original" (doc-count d0) 0)
|
||||
|
||||
;; ── find / index / has ──
|
||||
(content-test "find p1" (blk-id (doc-find d1 "p1")) "p1")
|
||||
(content-test "find missing" (doc-find d1 "nope") nil)
|
||||
(content-test "index-of p2" (doc-index-of d1 "p2") 2)
|
||||
(content-test "index-of missing" (doc-index-of d1 "nope") -1)
|
||||
(content-test "has? yes" (doc-has? d1 "h") true)
|
||||
(content-test "has? no" (doc-has? d1 "x") false)
|
||||
|
||||
;; ── insert-after ──
|
||||
(define d2 (doc-insert-after d1 img "h"))
|
||||
(content-test "insert-after order" (doc-ids d2) (list "h" "img" "p1" "p2"))
|
||||
(content-test
|
||||
"insert-after prepend"
|
||||
(doc-ids (doc-insert-after d1 img nil))
|
||||
(list "img" "h" "p1" "p2"))
|
||||
(content-test
|
||||
"insert-after missing appends"
|
||||
(doc-ids (doc-insert-after d1 img "zzz"))
|
||||
(list "h" "p1" "p2" "img"))
|
||||
(content-test "insert-after immutable" (doc-ids d1) (list "h" "p1" "p2"))
|
||||
|
||||
;; ── insert-at ──
|
||||
(content-test
|
||||
"insert-at 0"
|
||||
(doc-ids (doc-insert-at d1 img 0))
|
||||
(list "img" "h" "p1" "p2"))
|
||||
(content-test
|
||||
"insert-at 1"
|
||||
(doc-ids (doc-insert-at d1 img 1))
|
||||
(list "h" "img" "p1" "p2"))
|
||||
|
||||
;; ── update (copy-on-write block) ──
|
||||
(define d3 (doc-update d1 "p1" "text" "Edited"))
|
||||
(content-test
|
||||
"update value"
|
||||
(str (blk-send (doc-find d3 "p1") "text"))
|
||||
"Edited")
|
||||
(content-test "update keeps order" (doc-ids d3) (list "h" "p1" "p2"))
|
||||
(content-test
|
||||
"update immutable"
|
||||
(str (blk-send (doc-find d1 "p1") "text"))
|
||||
"First")
|
||||
|
||||
;; ── delete ──
|
||||
(define d4 (doc-delete d1 "p1"))
|
||||
(content-test "delete order" (doc-ids d4) (list "h" "p2"))
|
||||
(content-test "delete count" (doc-count d4) 2)
|
||||
(content-test "delete immutable" (doc-count d1) 3)
|
||||
(content-test
|
||||
"delete missing no-op"
|
||||
(doc-ids (doc-delete d1 "x"))
|
||||
(list "h" "p1" "p2"))
|
||||
|
||||
;; ── move ──
|
||||
(content-test
|
||||
"move p2 to front"
|
||||
(doc-ids (doc-move d1 "p2" 0))
|
||||
(list "p2" "h" "p1"))
|
||||
(content-test
|
||||
"move h to end"
|
||||
(doc-ids (doc-move d1 "h" 2))
|
||||
(list "p1" "p2" "h"))
|
||||
(content-test
|
||||
"move missing no-op"
|
||||
(doc-ids (doc-move d1 "x" 0))
|
||||
(list "h" "p1" "p2"))
|
||||
(content-test "move immutable" (doc-ids d1) (list "h" "p1" "p2"))
|
||||
|
||||
;; ── op constructors + interpreter ──
|
||||
(content-test
|
||||
"op-insert apply"
|
||||
(doc-ids (doc-apply d1 (op-insert img "h")))
|
||||
(list "h" "img" "p1" "p2"))
|
||||
(content-test
|
||||
"op-delete apply"
|
||||
(doc-ids (doc-apply d1 (op-delete "h")))
|
||||
(list "p1" "p2"))
|
||||
(content-test
|
||||
"op-move apply"
|
||||
(doc-ids (doc-apply d1 (op-move "p2" 0)))
|
||||
(list "p2" "h" "p1"))
|
||||
(content-test
|
||||
"op-update apply"
|
||||
(str
|
||||
(blk-send
|
||||
(doc-find (doc-apply d1 (op-update "p1" "text" "X")) "p1")
|
||||
"text"))
|
||||
"X")
|
||||
|
||||
;; ── apply-all: a stream of ops ──
|
||||
(define
|
||||
ops
|
||||
(list (op-insert img "h") (op-delete "p1") (op-move "p2" 0)))
|
||||
(content-test
|
||||
"apply-all"
|
||||
(doc-ids (doc-apply-all d1 ops))
|
||||
(list "p2" "h" "img"))
|
||||
(content-test "apply-all immutable" (doc-ids d1) (list "h" "p1" "p2"))
|
||||
(content-test
|
||||
"apply-all empty"
|
||||
(doc-ids (doc-apply-all d1 (list)))
|
||||
(list "h" "p1" "p2"))
|
||||
@@ -1,148 +0,0 @@
|
||||
;; Phase 4 — federated documents: trust-gated peer ops + concurrent-external-
|
||||
;; edit conflict resolution via the CRDT.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content-bootstrap-blocks!)
|
||||
(content-bootstrap-doc!)
|
||||
(content-bootstrap-render!)
|
||||
|
||||
(define same? (fn (a b) (= (get a :elements) (get b :elements))))
|
||||
|
||||
;; base shared document, then a local edit
|
||||
(define
|
||||
base
|
||||
(crdt-insert
|
||||
(crdt-insert
|
||||
(crdt-empty)
|
||||
"h"
|
||||
"heading"
|
||||
(crdt-pos 1 0)
|
||||
(list (list "level" 1) (list "text" "T"))
|
||||
1
|
||||
0)
|
||||
"p"
|
||||
"text"
|
||||
(crdt-pos 2 0)
|
||||
(list (list "text" "Body"))
|
||||
1
|
||||
0))
|
||||
(define local (crdt-update base "p" "text" "local" 5 1))
|
||||
|
||||
;; ── provenance ──
|
||||
(content-test
|
||||
"authored tags author"
|
||||
(get (content/authored (crdt-op-delete "h") "ed") :author)
|
||||
"ed")
|
||||
(content-test
|
||||
"signed tags sig"
|
||||
(get (content/signed (crdt-op-delete "h") "ed" "sig1") :sig)
|
||||
"sig1")
|
||||
(content-test "trusted? yes" (content/trusted? (list "ed" "al") "ed") true)
|
||||
(content-test "trusted? no" (content/trusted? (list "ed") "mal") false)
|
||||
|
||||
;; peer ops: ed is trusted, mal is not
|
||||
(define
|
||||
peer-ops
|
||||
(list
|
||||
(content/authored
|
||||
(crdt-op-update "p" "text" "peer-ed" 7 2)
|
||||
"ed")
|
||||
(content/authored
|
||||
(crdt-op-insert
|
||||
"x"
|
||||
"text"
|
||||
(crdt-pos 3 0)
|
||||
(list (list "text" "X"))
|
||||
8
|
||||
2)
|
||||
"ed")
|
||||
(content/authored (crdt-op-delete "h") "mal")))
|
||||
|
||||
(define res (content/merge-peer local (list "ed") peer-ops))
|
||||
|
||||
;; ── trust gate: only ed's ops applied ──
|
||||
(content-test "accepted count" (len (content/accepted res)) 2)
|
||||
(content-test "rejected count" (len (content/rejected res)) 1)
|
||||
(content-test
|
||||
"rejected is mal's"
|
||||
(get (first (content/rejected res)) :author)
|
||||
"mal")
|
||||
|
||||
;; ── resulting document ──
|
||||
(define rdoc (crdt-materialize "d" (content/peer-state res)))
|
||||
(content-test "untrusted delete blocked: h survives" (doc-has? rdoc "h") true)
|
||||
(content-test "trusted insert applied: x present" (doc-has? rdoc "x") true)
|
||||
(content-test "result order" (doc-ids rdoc) (list "h" "p" "x"))
|
||||
(content-test
|
||||
"trusted edit wins (ts7 > ts5)"
|
||||
(str (blk-send (doc-find rdoc "p") "text"))
|
||||
"peer-ed")
|
||||
|
||||
;; ── order-independence of accepted peer ops ──
|
||||
(define res-rev (content/merge-peer local (list "ed") (reverse peer-ops)))
|
||||
(content-test
|
||||
"peer merge order-independent"
|
||||
(same? (content/peer-state res) (content/peer-state res-rev))
|
||||
true)
|
||||
|
||||
;; ── trust = nobody → nothing applied, state unchanged ──
|
||||
(define res0 (content/merge-peer local (list) peer-ops))
|
||||
(content-test
|
||||
"no trust accepts none"
|
||||
(len (content/accepted res0))
|
||||
0)
|
||||
(content-test
|
||||
"no trust rejects all"
|
||||
(len (content/rejected res0))
|
||||
3)
|
||||
(content-test
|
||||
"no trust state unchanged"
|
||||
(same? (content/peer-state res0) local)
|
||||
true)
|
||||
|
||||
;; ── pluggable predicate gate (acl-on-sx hook) ──
|
||||
(define
|
||||
res-pred
|
||||
(content/merge-peer-with
|
||||
local
|
||||
(fn (op) (= (get op :author) "ed"))
|
||||
peer-ops))
|
||||
(content-test
|
||||
"predicate gate == list gate"
|
||||
(same? (content/peer-state res-pred) (content/peer-state res))
|
||||
true)
|
||||
|
||||
;; ── conflict on concurrent external edit: local vs external, same field ──
|
||||
;; external (peer) state edits p concurrently with a later ts; CRDT reconciles.
|
||||
(define
|
||||
external
|
||||
(crdt-update base "p" "text" "external" 9 2))
|
||||
(content-test
|
||||
"conflict LWW deterministic"
|
||||
(str
|
||||
(blk-send
|
||||
(doc-find (crdt-materialize "d" (crdt-merge local external)) "p")
|
||||
"text"))
|
||||
"external")
|
||||
(content-test
|
||||
"conflict merge commutes"
|
||||
(same? (crdt-merge local external) (crdt-merge external local))
|
||||
true)
|
||||
(content-test
|
||||
"conflict merge idempotent"
|
||||
(same?
|
||||
(crdt-merge (crdt-merge local external) external)
|
||||
(crdt-merge local external))
|
||||
true)
|
||||
|
||||
;; concurrent external edit with LOWER ts loses to local
|
||||
(define
|
||||
external-old
|
||||
(crdt-update base "p" "text" "stale" 3 2))
|
||||
(content-test
|
||||
"older external loses to local"
|
||||
(str
|
||||
(blk-send
|
||||
(doc-find (crdt-materialize "d" (crdt-merge local external-old)) "p")
|
||||
"text"))
|
||||
"local")
|
||||
@@ -1,83 +0,0 @@
|
||||
;; Extension — global find/replace across text-bearing blocks.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-section!)
|
||||
|
||||
(define
|
||||
d
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-heading "h" 1 "Foo title"))
|
||||
(mk-text "p" "the Foo is here"))
|
||||
(mk-section
|
||||
"s"
|
||||
(list (mk-text "n" "nested Foo") (mk-image "img" "/foo.png" "Foo alt")))))
|
||||
|
||||
(define r (content/find-replace d "Foo" "Bar"))
|
||||
|
||||
;; ── replaces in heading + text ──
|
||||
(content-test
|
||||
"replace heading"
|
||||
(str (blk-send (doc-deep-find r "h") "text"))
|
||||
"Bar title")
|
||||
(content-test
|
||||
"replace text"
|
||||
(str (blk-send (doc-deep-find r "p") "text"))
|
||||
"the Bar is here")
|
||||
(content-test
|
||||
"replace nested text"
|
||||
(str (blk-send (doc-deep-find r "n") "text"))
|
||||
"nested Bar")
|
||||
|
||||
;; ── does NOT touch image alt/src (not a text field) ──
|
||||
(content-test
|
||||
"image alt untouched"
|
||||
(str (blk-send (doc-deep-find r "img") "alt"))
|
||||
"Foo alt")
|
||||
(content-test
|
||||
"image src untouched"
|
||||
(str (blk-send (doc-deep-find r "img") "src"))
|
||||
"/foo.png")
|
||||
|
||||
;; ── immutable ──
|
||||
(content-test
|
||||
"original unchanged"
|
||||
(str (blk-send (doc-deep-find d "p") "text"))
|
||||
"the Foo is here")
|
||||
|
||||
;; ── multiple occurrences in one block ──
|
||||
(content-test
|
||||
"all occurrences"
|
||||
(str
|
||||
(blk-send
|
||||
(doc-find
|
||||
(content/find-replace
|
||||
(doc-append (doc-empty "d") (mk-text "p" "a a a"))
|
||||
"a"
|
||||
"b")
|
||||
"p")
|
||||
"text"))
|
||||
"b b b")
|
||||
|
||||
;; ── code + quote text replaced ──
|
||||
(define
|
||||
d2
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-code "c" "sx" "(old)"))
|
||||
(mk-quote "q" "src" "old saying")))
|
||||
(define r2 (content/find-replace d2 "old" "new"))
|
||||
(content-test
|
||||
"replace code"
|
||||
(str (blk-send (doc-find r2 "c") "text"))
|
||||
"(new)")
|
||||
(content-test
|
||||
"replace quote"
|
||||
(str (blk-send (doc-find r2 "q") "text"))
|
||||
"new saying")
|
||||
|
||||
;; ── no match → unchanged render ──
|
||||
(content-test
|
||||
"no match"
|
||||
(asHTML (content/find-replace d "zzz" "qqq"))
|
||||
(asHTML d))
|
||||
@@ -1,72 +0,0 @@
|
||||
;; Extension — document flatten (un-nest sections).
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-section!)
|
||||
|
||||
(define
|
||||
d
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-heading "h" 1 "Top"))
|
||||
(mk-section "s" (list (mk-text "a" "A") (mk-text "b" "B")))))
|
||||
|
||||
;; ── one level un-nested ──
|
||||
(define f (content/flatten d))
|
||||
(content-test "flatten ids" (doc-ids f) (list "h" "a" "b"))
|
||||
(content-test
|
||||
"flatten no sections"
|
||||
(content/types f)
|
||||
(list "heading" "text" "text"))
|
||||
(content-test "flatten immutable" (doc-ids d) (list "h" "s"))
|
||||
(content-test "flatten render" (asHTML f) "<h1>Top</h1><p>A</p><p>B</p>")
|
||||
|
||||
;; ── deep nesting fully flattened ──
|
||||
(define
|
||||
deep
|
||||
(doc-append
|
||||
(doc-empty "d")
|
||||
(mk-section
|
||||
"o"
|
||||
(list
|
||||
(mk-text "x" "X")
|
||||
(mk-section
|
||||
"i"
|
||||
(list (mk-text "y" "Y") (mk-heading "z" 2 "Z")))))))
|
||||
(content-test
|
||||
"deep flatten ids"
|
||||
(doc-ids (content/flatten deep))
|
||||
(list "x" "y" "z"))
|
||||
|
||||
;; ── inverse of wrap-section ──
|
||||
(define
|
||||
plain
|
||||
(doc-append
|
||||
(doc-append (doc-empty "p") (mk-text "a" "A"))
|
||||
(mk-text "b" "B")))
|
||||
(content-test
|
||||
"flatten . wrap == identity ids"
|
||||
(doc-ids (content/flatten (content/wrap-section plain "sec")))
|
||||
(doc-ids plain))
|
||||
(content-test
|
||||
"flatten . wrap == identity render"
|
||||
(asHTML (content/flatten (content/wrap-section plain "sec")))
|
||||
(asHTML plain))
|
||||
|
||||
;; ── already-flat doc unchanged ──
|
||||
(content-test
|
||||
"flat unchanged"
|
||||
(asHTML (content/flatten plain))
|
||||
(asHTML plain))
|
||||
|
||||
;; ── empty section disappears ──
|
||||
(content-test
|
||||
"empty section flattens away"
|
||||
(doc-ids
|
||||
(content/flatten (doc-append (doc-empty "d") (mk-section "s" (list)))))
|
||||
(list))
|
||||
|
||||
;; ── empty doc ──
|
||||
(content-test
|
||||
"flatten empty"
|
||||
(doc-ids (content/flatten (doc-empty "e")))
|
||||
(list))
|
||||
@@ -1,61 +0,0 @@
|
||||
;; Extension — multi-document index + tag filtering.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-text!)
|
||||
|
||||
(define
|
||||
a
|
||||
(doc-with-meta
|
||||
(doc-append (doc-empty "a") (mk-text "p" "first post"))
|
||||
{:title "A" :tags (list "sx" "news")}))
|
||||
(define
|
||||
b
|
||||
(doc-with-meta
|
||||
(doc-append (doc-empty "b") (mk-text "p" "second post"))
|
||||
{:title "B" :tags (list "news")}))
|
||||
(define
|
||||
c
|
||||
(doc-with-meta
|
||||
(doc-append (doc-empty "c") (mk-text "p" "third"))
|
||||
{:title "C" :tags (list "sx")}))
|
||||
(define docs (list a b c))
|
||||
|
||||
;; ── index = list of summaries ──
|
||||
(define idx (content/index docs))
|
||||
(content-test "index count" (len idx) 3)
|
||||
(content-test
|
||||
"index titles"
|
||||
(map (fn (s) (get s :title)) idx)
|
||||
(list "A" "B" "C"))
|
||||
(content-test
|
||||
"index ids"
|
||||
(map (fn (s) (get s :id)) idx)
|
||||
(list "a" "b" "c"))
|
||||
(content-test "index excerpt" (get (first idx) :excerpt) "first post")
|
||||
|
||||
;; ── has-tag? ──
|
||||
(content-test "has-tag yes" (content/has-tag? a "news") true)
|
||||
(content-test "has-tag no" (content/has-tag? c "news") false)
|
||||
|
||||
;; ── index-by-tag (category page) ──
|
||||
(content-test
|
||||
"by-tag news"
|
||||
(map (fn (s) (get s :id)) (content/index-by-tag docs "news"))
|
||||
(list "a" "b"))
|
||||
(content-test
|
||||
"by-tag sx"
|
||||
(map (fn (s) (get s :id)) (content/index-by-tag docs "sx"))
|
||||
(list "a" "c"))
|
||||
(content-test "by-tag none" (content/index-by-tag docs "missing") (list))
|
||||
|
||||
;; ── all-tags (tag cloud, deduped, document order) ──
|
||||
(content-test "all-tags" (content/all-tags docs) (list "sx" "news"))
|
||||
(content-test "all-tags empty" (content/all-tags (list)) (list))
|
||||
(content-test
|
||||
"all-tags untagged"
|
||||
(content/all-tags (list (doc-empty "x")))
|
||||
(list))
|
||||
|
||||
;; ── empty index ──
|
||||
(content-test "empty index" (content/index (list)) (list))
|
||||
@@ -1,79 +0,0 @@
|
||||
;; Extension — Markdown render mode. asMarkdown is a polymorphic message send;
|
||||
;; the boundary supplies the newline.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-markdown!)
|
||||
|
||||
(define nl (str "\n"))
|
||||
|
||||
;; ── per-block ──
|
||||
(content-test
|
||||
"heading h3"
|
||||
(asMarkdown (mk-heading "h" 3 "Title"))
|
||||
"### Title")
|
||||
(content-test
|
||||
"heading h1"
|
||||
(asMarkdown (mk-heading "h" 1 "T"))
|
||||
"# T")
|
||||
(content-test "text md" (asMarkdown (mk-text "p" "body")) "body")
|
||||
(content-test
|
||||
"quote md"
|
||||
(asMarkdown (mk-quote "q" "Ada" "to err"))
|
||||
"> to err")
|
||||
(content-test
|
||||
"image md"
|
||||
(asMarkdown (mk-image "i" "/c.png" "cat"))
|
||||
"")
|
||||
(content-test
|
||||
"embed md"
|
||||
(asMarkdown (mk-embed "e" "https://v/1" "vimeo"))
|
||||
"[embed](https://v/1)")
|
||||
(content-test "divider md" (asMarkdown (mk-divider "d")) "---")
|
||||
(content-test
|
||||
"code md"
|
||||
(asMarkdown (mk-code "c" "sx" "(+ 1 2)"))
|
||||
(str "```sx" nl "(+ 1 2)" nl "```"))
|
||||
(content-test
|
||||
"ul md"
|
||||
(asMarkdown (mk-list "u" false (list "a" "b" "c")))
|
||||
(str "- a" nl "- b" nl "- c"))
|
||||
(content-test
|
||||
"ol md"
|
||||
(asMarkdown (mk-list "o" true (list "x" "y")))
|
||||
(str "1. x" nl "1. y"))
|
||||
(content-test "empty list md" (asMarkdown (mk-list "e" false (list))) "")
|
||||
|
||||
;; ── document joins blocks with a blank line ──
|
||||
(define
|
||||
d
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append (doc-empty "doc") (mk-heading "h" 2 "Title"))
|
||||
(mk-text "p" "Hello"))
|
||||
(mk-divider "d")))
|
||||
(content-test
|
||||
"doc md"
|
||||
(asMarkdown d)
|
||||
(str "## Title" nl nl "Hello" nl nl "---"))
|
||||
(content-test "empty doc md" (asMarkdown (doc-empty "e")) "")
|
||||
|
||||
;; ── via facade ──
|
||||
(content-test "render md" (content/render d "md") (asMarkdown d))
|
||||
(content-test "render markdown" (content/render d "markdown") (asMarkdown d))
|
||||
(content-test "render md keyword" (content/render d :md) (asMarkdown d))
|
||||
(content-test "content/markdown alias" (content/markdown d) (asMarkdown d))
|
||||
(content-test
|
||||
"block-markdown alias"
|
||||
(block-markdown (mk-heading "h" 2 "X"))
|
||||
"## X")
|
||||
|
||||
;; ── reflects edits / immutability ──
|
||||
(content-test
|
||||
"md after update"
|
||||
(asMarkdown (doc-update d "p" "text" "Edited"))
|
||||
(str "## Title" nl nl "Edited" nl nl "---"))
|
||||
(content-test
|
||||
"md original unchanged"
|
||||
(asMarkdown d)
|
||||
(str "## Title" nl nl "Hello" nl nl "---"))
|
||||
@@ -1,71 +0,0 @@
|
||||
;; Extension — Markdown document export (frontmatter + body), round-trips with
|
||||
;; md/import including metadata.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-markdown!)
|
||||
(content-bootstrap-table!)
|
||||
|
||||
(define nl (str "\n"))
|
||||
|
||||
;; ── no metadata → plain markdown (no frontmatter) ──
|
||||
(define plain (doc-append (doc-empty "d") (mk-heading "h" 1 "Hi")))
|
||||
(content-test
|
||||
"no-meta == asMarkdown"
|
||||
(content/markdown-doc plain)
|
||||
(asMarkdown plain))
|
||||
(content-test "no-meta no frontmatter" (content/markdown-doc plain) "# Hi")
|
||||
|
||||
;; ── full metadata frontmatter ──
|
||||
(define
|
||||
d
|
||||
(doc-with-meta
|
||||
(doc-append (doc-empty "post") (mk-heading "h" 1 "Hi"))
|
||||
{:slug "my-post" :title "My Post" :tags (list "a" "b")}))
|
||||
(content-test
|
||||
"frontmatter export"
|
||||
(content/markdown-doc d)
|
||||
(str
|
||||
"---"
|
||||
nl
|
||||
"title: My Post"
|
||||
nl
|
||||
"slug: my-post"
|
||||
nl
|
||||
"tags: a, b"
|
||||
nl
|
||||
"---"
|
||||
nl
|
||||
nl
|
||||
"# Hi"))
|
||||
|
||||
;; ── title only ──
|
||||
(content-test
|
||||
"title-only frontmatter"
|
||||
(content/markdown-doc
|
||||
(doc-with-title (doc-append (doc-empty "p") (mk-text "x" "body")) "T"))
|
||||
(str "---" nl "title: T" nl "---" nl nl "body"))
|
||||
|
||||
;; ── round-trip: import . export keeps metadata + blocks ──
|
||||
(define rt (md/import (content/markdown-doc d) "post"))
|
||||
(content-test "round-trip title" (doc-title rt) "My Post")
|
||||
(content-test "round-trip slug" (doc-slug rt) "my-post")
|
||||
(content-test "round-trip tags" (doc-tags rt) (list "a" "b"))
|
||||
(content-test "round-trip body" (doc-types rt) (list "heading"))
|
||||
(content-test
|
||||
"round-trip body text"
|
||||
(str (blk-send (doc-find rt "b0") "text"))
|
||||
"Hi")
|
||||
|
||||
;; ── round-trip a richer doc ──
|
||||
(define
|
||||
d2
|
||||
(doc-with-meta
|
||||
(doc-append
|
||||
(doc-append (doc-empty "p") (mk-heading "h" 2 "Title"))
|
||||
(mk-text "p" "para text"))
|
||||
{:title "Big" :tags (list "x")}))
|
||||
(define rt2 (md/import (content/markdown-doc d2) "p"))
|
||||
(content-test "rt2 title" (doc-title rt2) "Big")
|
||||
(content-test "rt2 tags" (doc-tags rt2) (list "x"))
|
||||
(content-test "rt2 types" (doc-types rt2) (list "heading" "text"))
|
||||
@@ -1,206 +0,0 @@
|
||||
;; Extension — Markdown import adapter (markdown text -> blocks), inverse of
|
||||
;; asMarkdown. Round-trips canonical Markdown; parses frontmatter + tables.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-markdown!)
|
||||
(content-bootstrap-table!)
|
||||
|
||||
(define nl (str "\n"))
|
||||
|
||||
;; ── headings ──
|
||||
(define dh (md/import "# Title" "d"))
|
||||
(content-test "heading import type" (doc-types dh) (list "heading"))
|
||||
(content-test
|
||||
"heading level"
|
||||
(blk-send (doc-find dh "b0") "level")
|
||||
1)
|
||||
(content-test
|
||||
"heading text"
|
||||
(str (blk-send (doc-find dh "b0") "text"))
|
||||
"Title")
|
||||
(content-test
|
||||
"h3 import"
|
||||
(blk-send (doc-find (md/import "### Deep" "d") "b0") "level")
|
||||
3)
|
||||
|
||||
;; ── paragraph (consecutive lines join with space) ──
|
||||
(content-test
|
||||
"paragraph join"
|
||||
(str
|
||||
(blk-send
|
||||
(doc-find (md/import (str "hello" nl "world") "d") "b0")
|
||||
"text"))
|
||||
"hello world")
|
||||
|
||||
;; ── blockquote, divider ──
|
||||
(content-test
|
||||
"blockquote"
|
||||
(str (blk-send (doc-find (md/import "> quoted" "d") "b0") "text"))
|
||||
"quoted")
|
||||
(content-test "divider" (doc-types (md/import "---" "d")) (list "divider"))
|
||||
|
||||
;; ── unordered + ordered lists ──
|
||||
(define dul (md/import (str "- a" nl "- b" nl "- c") "d"))
|
||||
(content-test "ul type" (doc-types dul) (list "list"))
|
||||
(content-test
|
||||
"ul not ordered"
|
||||
(blk-send (doc-find dul "b0") "ordered")
|
||||
false)
|
||||
(content-test
|
||||
"ul items"
|
||||
(blk-send (doc-find dul "b0") "items")
|
||||
(list "a" "b" "c"))
|
||||
(define dol (md/import (str "1. x" nl "2. y") "d"))
|
||||
(content-test "ol ordered" (blk-send (doc-find dol "b0") "ordered") true)
|
||||
(content-test
|
||||
"ol items"
|
||||
(blk-send (doc-find dol "b0") "items")
|
||||
(list "x" "y"))
|
||||
|
||||
;; ── fenced code ──
|
||||
(define dc (md/import (str "```sx" nl "(+ 1 2)" nl "(* 3 4)" nl "```") "d"))
|
||||
(content-test "code type" (doc-types dc) (list "code"))
|
||||
(content-test
|
||||
"code language"
|
||||
(str (blk-send (doc-find dc "b0") "language"))
|
||||
"sx")
|
||||
(content-test
|
||||
"code body"
|
||||
(str (blk-send (doc-find dc "b0") "text"))
|
||||
(str "(+ 1 2)" nl "(* 3 4)"))
|
||||
|
||||
;; ── multiple blocks separated by blank lines ──
|
||||
(define dm (md/import (str "# H" nl nl "para" nl nl "- a" nl "- b") "d"))
|
||||
(content-test "multi types" (doc-types dm) (list "heading" "text" "list"))
|
||||
(content-test "multi ids" (doc-ids dm) (list "b0" "b1" "b2"))
|
||||
|
||||
;; ── empty / blank input ──
|
||||
(content-test "empty input" (doc-ids (md/import "" "d")) (list))
|
||||
(content-test
|
||||
"blank lines only"
|
||||
(doc-ids (md/import (str nl nl) "d"))
|
||||
(list))
|
||||
|
||||
;; ── pipe tables ──
|
||||
(define
|
||||
dt
|
||||
(md/import
|
||||
(str
|
||||
"| Name | Age |"
|
||||
nl
|
||||
"| --- | --- |"
|
||||
nl
|
||||
"| Ada | 36 |"
|
||||
nl
|
||||
"| Al | 40 |")
|
||||
"d"))
|
||||
(content-test "table import type" (doc-types dt) (list "table"))
|
||||
(content-test
|
||||
"table headers"
|
||||
(table-headers (doc-find dt "b0"))
|
||||
(list "Name" "Age"))
|
||||
(content-test
|
||||
"table rows"
|
||||
(table-rows (doc-find dt "b0"))
|
||||
(list (list "Ada" "36") (list "Al" "40")))
|
||||
(content-test
|
||||
"table round-trip"
|
||||
(asMarkdown
|
||||
(md/import (str "| A | B |" nl "| --- | --- |" nl "| 1 | 2 |") "d"))
|
||||
(str "| A | B |" nl "| --- | --- |" nl "| 1 | 2 |"))
|
||||
(define
|
||||
dmix
|
||||
(md/import
|
||||
(str
|
||||
"# Title"
|
||||
nl
|
||||
nl
|
||||
"| H1 | H2 |"
|
||||
nl
|
||||
"| --- | --- |"
|
||||
nl
|
||||
"| a | b |"
|
||||
nl
|
||||
nl
|
||||
"para")
|
||||
"d"))
|
||||
(content-test
|
||||
"table mixed types"
|
||||
(doc-types dmix)
|
||||
(list "heading" "table" "text"))
|
||||
|
||||
;; ── frontmatter ──
|
||||
(define
|
||||
dfm
|
||||
(md/import
|
||||
(str
|
||||
"---"
|
||||
nl
|
||||
"title: My Post"
|
||||
nl
|
||||
"slug: my-post"
|
||||
nl
|
||||
"tags: a, b, c"
|
||||
nl
|
||||
"---"
|
||||
nl
|
||||
"# Hi"
|
||||
nl
|
||||
nl
|
||||
"body")
|
||||
"d"))
|
||||
(content-test "fm title" (doc-title dfm) "My Post")
|
||||
(content-test "fm slug" (doc-slug dfm) "my-post")
|
||||
(content-test "fm tags" (doc-tags dfm) (list "a" "b" "c"))
|
||||
(content-test "fm body types" (doc-types dfm) (list "heading" "text"))
|
||||
(content-test
|
||||
"fm body content"
|
||||
(str (blk-send (doc-find dfm "b0") "text"))
|
||||
"Hi")
|
||||
(content-test "no fm title nil" (doc-title (md/import "# Hi" "d")) nil)
|
||||
(content-test
|
||||
"hr not frontmatter"
|
||||
(doc-types (md/import (str "text" nl nl "---") "d"))
|
||||
(list "text" "divider"))
|
||||
(define dfmo (md/import (str "---" nl "title: T" nl "---") "d"))
|
||||
(content-test "fm only title" (doc-title dfmo) "T")
|
||||
(content-test "fm only empty body" (doc-ids dfmo) (list))
|
||||
|
||||
;; ── round-trip: import . export == identity (canonical markdown) ──
|
||||
(define
|
||||
src
|
||||
(str
|
||||
"# Title"
|
||||
nl
|
||||
nl
|
||||
"hello world"
|
||||
nl
|
||||
nl
|
||||
"> quoted"
|
||||
nl
|
||||
nl
|
||||
"- a"
|
||||
nl
|
||||
"- b"
|
||||
nl
|
||||
nl
|
||||
"---"))
|
||||
(content-test "round-trip markdown" (asMarkdown (md/import src "d")) src)
|
||||
(content-test
|
||||
"round-trip code"
|
||||
(asMarkdown (md/import (str "```js" nl "x = 1" nl "```") "d"))
|
||||
(str "```js" nl "x = 1" nl "```"))
|
||||
|
||||
;; ── adapter form ──
|
||||
(content-test
|
||||
"adapter import"
|
||||
(doc-types (content/import markdown-adapter "# Hi" "d"))
|
||||
(list "heading"))
|
||||
(content-test
|
||||
"adapter export round-trip"
|
||||
(content/export markdown-adapter (content/import markdown-adapter src "d"))
|
||||
src)
|
||||
|
||||
;; ── imported doc validates ──
|
||||
(content-test "imported doc valid" (content/valid? (md/import src "d")) true)
|
||||
@@ -1,59 +0,0 @@
|
||||
;; Extension — video/audio media block.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-markdown!)
|
||||
(content-bootstrap-text!)
|
||||
(content-bootstrap-media!)
|
||||
|
||||
(define v (mk-video "v" "/clip.mp4"))
|
||||
(define a (mk-audio "a" "/song.mp3"))
|
||||
|
||||
;; ── identity ──
|
||||
(content-test "media is block" (block? v) true)
|
||||
(content-test "media? yes" (media? v) true)
|
||||
(content-test "video type" (blk-type v) "media")
|
||||
(content-test "video kind" (media-kind v) "video")
|
||||
(content-test "audio kind" (media-kind a) "audio")
|
||||
|
||||
;; ── render ──
|
||||
(content-test
|
||||
"video html"
|
||||
(asHTML v)
|
||||
"<video src=\"/clip.mp4\" controls></video>")
|
||||
(content-test
|
||||
"audio html"
|
||||
(asHTML a)
|
||||
"<audio src=\"/song.mp3\" controls></audio>")
|
||||
(content-test "video sx" (asSx v) "(video :src \"/clip.mp4\")")
|
||||
(content-test "video text" (asText v) "")
|
||||
(content-test "video markdown" (asMarkdown v) "[video](/clip.mp4)")
|
||||
(content-test "audio markdown" (asMarkdown a) "[audio](/song.mp3)")
|
||||
|
||||
;; ── html escapes src ──
|
||||
(content-test
|
||||
"media html escapes"
|
||||
(asHTML (mk-video "v" "/a.mp4?x=1&y=2"))
|
||||
"<video src=\"/a.mp4?x=1&y=2\" controls></video>")
|
||||
|
||||
;; ── in a document ──
|
||||
(define
|
||||
d
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-heading "h" 1 "Watch"))
|
||||
v))
|
||||
(content-test
|
||||
"doc with media html"
|
||||
(asHTML d)
|
||||
"<h1>Watch</h1><video src=\"/clip.mp4\" controls></video>")
|
||||
|
||||
;; ── validation ──
|
||||
(content-test
|
||||
"valid media"
|
||||
(content/valid? (doc-append (doc-empty "d") v))
|
||||
true)
|
||||
(content-test
|
||||
"bad media kind flagged"
|
||||
(content/issue-kinds
|
||||
(doc-append (doc-empty "d") (mk-media "m" "movie" "/x")))
|
||||
(list "field"))
|
||||
@@ -1,79 +0,0 @@
|
||||
;; Extension — document metadata (title/slug/tags) + Ghost title plumbing.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
|
||||
(define d (doc-empty "post"))
|
||||
|
||||
;; ── defaults ──
|
||||
(content-test "default title nil" (doc-title d) nil)
|
||||
(content-test "default slug nil" (doc-slug d) nil)
|
||||
(content-test "default tags empty" (doc-tags d) (list))
|
||||
|
||||
;; ── copy-on-write setters ──
|
||||
(define d2 (doc-with-title d "Hello World"))
|
||||
(content-test "with-title" (doc-title d2) "Hello World")
|
||||
(content-test "with-title immutable" (doc-title d) nil)
|
||||
(content-test "with-title keeps id" (doc-id d2) "post")
|
||||
|
||||
(define d3 (doc-with-slug (doc-with-title d "T") "my-slug"))
|
||||
(content-test "with-slug" (doc-slug d3) "my-slug")
|
||||
(content-test "title preserved with slug" (doc-title d3) "T")
|
||||
|
||||
(define d4 (doc-with-tags d (list "a" "b")))
|
||||
(content-test "with-tags" (doc-tags d4) (list "a" "b"))
|
||||
(content-test "add-tag" (doc-tags (doc-add-tag d4 "c")) (list "a" "b" "c"))
|
||||
(content-test
|
||||
"add-tag from empty"
|
||||
(doc-tags (doc-add-tag d "x"))
|
||||
(list "x"))
|
||||
|
||||
;; ── batch + dict ──
|
||||
(define d5 (doc-with-meta d {:slug "s" :title "T" :tags (list "t1")}))
|
||||
(content-test "with-meta title" (doc-title d5) "T")
|
||||
(content-test "with-meta slug" (doc-slug d5) "s")
|
||||
(content-test "with-meta tags" (doc-tags d5) (list "t1"))
|
||||
(content-test
|
||||
"with-meta partial leaves title"
|
||||
(doc-title (doc-with-meta d {:slug "only"}))
|
||||
nil)
|
||||
(content-test "doc-meta dict" (doc-meta d5) {:slug "s" :id "post" :title "T" :tags (list "t1")})
|
||||
|
||||
;; ── constructor with metadata ──
|
||||
(define d6 (doc-new-meta "p2" (list (mk-text "x" "hi")) {:title "Post 2"}))
|
||||
(content-test "new-meta title" (doc-title d6) "Post 2")
|
||||
(content-test "new-meta blocks" (doc-ids d6) (list "x"))
|
||||
|
||||
;; ── facade aliases ──
|
||||
(content-test "content/title" (content/title d5) "T")
|
||||
(content-test
|
||||
"content/with-title"
|
||||
(content/title (content/with-title d "Z"))
|
||||
"Z")
|
||||
(content-test "content/meta" (content/meta d5) (doc-meta d5))
|
||||
|
||||
;; ── metadata coexists with block ops ──
|
||||
(define
|
||||
d7
|
||||
(doc-append
|
||||
(doc-with-title (doc-empty "x") "Titled")
|
||||
(mk-text "p" "body")))
|
||||
(content-test "meta + blocks coexist" (doc-ids d7) (list "p"))
|
||||
(content-test "meta survives append" (doc-title d7) "Titled")
|
||||
(content-test
|
||||
"meta survives edit"
|
||||
(doc-title (doc-update d7 "p" "text" "changed"))
|
||||
"Titled")
|
||||
|
||||
;; ── Ghost adapter now carries title ──
|
||||
(define post {:sections (list {:id "h" :text "Hi" :kind "heading" :level 1}) :title "My Post"})
|
||||
(define gd (content/import ghost-adapter post "post"))
|
||||
(content-test "ghost import title" (doc-title gd) "My Post")
|
||||
(content-test
|
||||
"ghost export title"
|
||||
(get (content/export ghost-adapter gd) :title)
|
||||
"My Post")
|
||||
(content-test
|
||||
"ghost title round-trip"
|
||||
(doc-title (content/round-trip ghost-adapter gd))
|
||||
"My Post")
|
||||
@@ -1,63 +0,0 @@
|
||||
;; Extension — relative block reorder.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
|
||||
(define
|
||||
d
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-text "a" "A"))
|
||||
(mk-text "b" "B"))
|
||||
(mk-text "c" "C")))
|
||||
|
||||
;; ── move-before ──
|
||||
(content-test
|
||||
"move-before"
|
||||
(doc-ids (content/move-before d "c" "a"))
|
||||
(list "c" "a" "b"))
|
||||
(content-test
|
||||
"move-before mid"
|
||||
(doc-ids (content/move-before d "c" "b"))
|
||||
(list "a" "c" "b"))
|
||||
(content-test "move-before immutable" (doc-ids d) (list "a" "b" "c"))
|
||||
|
||||
;; ── move-after ──
|
||||
(content-test
|
||||
"move-after"
|
||||
(doc-ids (content/move-after d "a" "b"))
|
||||
(list "b" "a" "c"))
|
||||
(content-test
|
||||
"move-after last"
|
||||
(doc-ids (content/move-after d "a" "c"))
|
||||
(list "b" "c" "a"))
|
||||
|
||||
;; ── move-to-front / back ──
|
||||
(content-test
|
||||
"move-to-front"
|
||||
(doc-ids (content/move-to-front d "c"))
|
||||
(list "c" "a" "b"))
|
||||
(content-test
|
||||
"move-to-back"
|
||||
(doc-ids (content/move-to-back d "a"))
|
||||
(list "b" "c" "a"))
|
||||
(content-test
|
||||
"front already first"
|
||||
(doc-ids (content/move-to-front d "a"))
|
||||
(list "a" "b" "c"))
|
||||
|
||||
;; ── no-ops ──
|
||||
(content-test
|
||||
"missing id no-op"
|
||||
(doc-ids (content/move-before d "zzz" "a"))
|
||||
(list "a" "b" "c"))
|
||||
(content-test
|
||||
"missing target no-op"
|
||||
(doc-ids (content/move-before d "a" "zzz"))
|
||||
(list "a" "b" "c"))
|
||||
|
||||
;; ── render after move ──
|
||||
(content-test
|
||||
"render after move"
|
||||
(asHTML (content/move-after d "a" "c"))
|
||||
"<p>B</p><p>C</p><p>A</p>")
|
||||
@@ -1,99 +0,0 @@
|
||||
;; Extension — document normalization (drop empty text blocks + empty sections).
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-section!)
|
||||
|
||||
;; ── drop empty text blocks ──
|
||||
(define
|
||||
d
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-heading "h" 1 "Hi"))
|
||||
(mk-text "empty" ""))
|
||||
(mk-text "p" "Body")))
|
||||
(content-test
|
||||
"drops empty text"
|
||||
(doc-ids (content/normalize d))
|
||||
(list "h" "p"))
|
||||
(content-test "normalize immutable" (doc-ids d) (list "h" "empty" "p"))
|
||||
(content-test
|
||||
"keeps non-empty text"
|
||||
(str (blk-send (doc-find (content/normalize d) "p") "text"))
|
||||
"Body")
|
||||
|
||||
;; ── drop empty sections ──
|
||||
(define
|
||||
d2
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-text "p" "x"))
|
||||
(mk-section "empty-sec" (list))))
|
||||
(content-test
|
||||
"drops empty section"
|
||||
(doc-ids (content/normalize d2))
|
||||
(list "p"))
|
||||
|
||||
;; ── section that becomes empty (all children dropped) is itself dropped ──
|
||||
(define
|
||||
d3
|
||||
(doc-append
|
||||
(doc-empty "d")
|
||||
(mk-section "s" (list (mk-text "e1" "") (mk-text "e2" "")))))
|
||||
(content-test
|
||||
"section emptied then dropped"
|
||||
(doc-ids (content/normalize d3))
|
||||
(list))
|
||||
|
||||
;; ── section with some content keeps surviving children ──
|
||||
(define
|
||||
d4
|
||||
(doc-append
|
||||
(doc-empty "d")
|
||||
(mk-section
|
||||
"s"
|
||||
(list (mk-text "e" "") (mk-heading "k" 2 "Keep")))))
|
||||
(define n4 (content/normalize d4))
|
||||
(content-test "section kept" (doc-ids n4) (list "s"))
|
||||
(content-test
|
||||
"empty child dropped, real kept"
|
||||
(doc-tree-ids n4)
|
||||
(list "s" "k"))
|
||||
|
||||
;; ── nested: empty deep section removed, content bubbles correctly ──
|
||||
(define
|
||||
d5
|
||||
(doc-append
|
||||
(doc-empty "d")
|
||||
(mk-section
|
||||
"outer"
|
||||
(list (mk-text "a" "A") (mk-section "inner" (list (mk-text "x" "")))))))
|
||||
(content-test
|
||||
"nested empty inner dropped"
|
||||
(doc-tree-ids (content/normalize d5))
|
||||
(list "outer" "a"))
|
||||
|
||||
;; ── already-clean doc unchanged ──
|
||||
(define
|
||||
clean
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-heading "h" 1 "T"))
|
||||
(mk-text "p" "B")))
|
||||
(content-test
|
||||
"clean doc unchanged ids"
|
||||
(doc-ids (content/normalize clean))
|
||||
(list "h" "p"))
|
||||
(content-test
|
||||
"clean doc render"
|
||||
(asHTML (content/normalize clean))
|
||||
(asHTML clean))
|
||||
|
||||
;; ── non-text empties preserved (divider, image with empty alt) ──
|
||||
(define
|
||||
d6
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-divider "dv"))
|
||||
(mk-image "i" "/a.png" "")))
|
||||
(content-test
|
||||
"divider + image kept"
|
||||
(doc-ids (content/normalize d6))
|
||||
(list "dv" "i"))
|
||||
@@ -1,78 +0,0 @@
|
||||
;; Extension — nested document outline.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-section!)
|
||||
|
||||
;; H1 / H2 H2 / H1 -> [h1{children: h2,h3}, h4]
|
||||
(define
|
||||
d
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-heading "a" 1 "A"))
|
||||
(mk-heading "b" 2 "B"))
|
||||
(mk-heading "c" 2 "C"))
|
||||
(mk-heading "e" 1 "E")))
|
||||
|
||||
(define o (content/outline d))
|
||||
(content-test "outline top count" (len o) 2)
|
||||
(content-test "outline first id" (get (first o) :id) "a")
|
||||
(content-test
|
||||
"outline first children ids"
|
||||
(map (fn (n) (get n :id)) (get (first o) :children))
|
||||
(list "b" "c"))
|
||||
(content-test "outline second top" (get (nth o 1) :id) "e")
|
||||
(content-test
|
||||
"outline second no children"
|
||||
(get (nth o 1) :children)
|
||||
(list))
|
||||
|
||||
;; ── deeper nesting: H1 / H2 / H3 ──
|
||||
(define
|
||||
d2
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-heading "x" 1 "X"))
|
||||
(mk-heading "y" 2 "Y"))
|
||||
(mk-heading "z" 3 "Z")))
|
||||
(define o2 (content/outline d2))
|
||||
(content-test "deep top" (get (first o2) :id) "x")
|
||||
(content-test
|
||||
"deep child"
|
||||
(get (first (get (first o2) :children)) :id)
|
||||
"y")
|
||||
(content-test
|
||||
"deep grandchild"
|
||||
(get (first (get (first (get (first o2) :children)) :children)) :id)
|
||||
"z")
|
||||
|
||||
;; ── node carries text + level ──
|
||||
(content-test "node text" (get (first o) :text) "A")
|
||||
(content-test "node level" (get (first o) :level) 1)
|
||||
|
||||
;; ── empty / no headings ──
|
||||
(content-test "outline empty" (content/outline (doc-empty "e")) (list))
|
||||
(content-test
|
||||
"outline no headings"
|
||||
(content/outline (doc-append (doc-empty "d") (mk-text "p" "x")))
|
||||
(list))
|
||||
|
||||
;; ── starting at H2 (no H1) still forms a forest ──
|
||||
(define
|
||||
d3
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-heading "p" 2 "P"))
|
||||
(mk-heading "q" 2 "Q")))
|
||||
(content-test "no-h1 forest count" (len (content/outline d3)) 2)
|
||||
|
||||
;; ── headings nested inside sections are found (tree-wide via query) ──
|
||||
(define
|
||||
d4
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-heading "top" 1 "Top"))
|
||||
(mk-section "s" (list (mk-heading "in" 2 "In")))))
|
||||
(content-test
|
||||
"section heading nested in outline"
|
||||
(map (fn (n) (get n :id)) (get (first (content/outline d4)) :children))
|
||||
(list "in"))
|
||||
@@ -1,39 +0,0 @@
|
||||
;; Extension — SEO-complete HTML page (lang + meta description).
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-text!)
|
||||
|
||||
(define
|
||||
d
|
||||
(doc-with-title
|
||||
(doc-append
|
||||
(doc-append (doc-empty "post") (mk-heading "h" 1 "Hi"))
|
||||
(mk-text "p" "Hello world"))
|
||||
"My Title"))
|
||||
|
||||
(content-test
|
||||
"page-full"
|
||||
(content/page-full d)
|
||||
"<!doctype html><html lang=\"en\"><head><meta charset=\"utf-8\"><title>My Title</title><meta name=\"description\" content=\"Hi Hello world\"></head><body><h1>Hi</h1><p>Hello world</p></body></html>")
|
||||
|
||||
;; description escaped
|
||||
(content-test
|
||||
"page-full escapes description"
|
||||
(content/page-full
|
||||
(doc-with-title
|
||||
(doc-append (doc-empty "x") (mk-text "p" "a < b & c"))
|
||||
"T"))
|
||||
"<!doctype html><html lang=\"en\"><head><meta charset=\"utf-8\"><title>T</title><meta name=\"description\" content=\"a < b & c\"></head><body><p>a < b & c</p></body></html>")
|
||||
|
||||
;; title falls back to id, empty description for empty doc
|
||||
(content-test
|
||||
"page-full empty"
|
||||
(content/page-full (doc-empty "fallback"))
|
||||
"<!doctype html><html lang=\"en\"><head><meta charset=\"utf-8\"><title>fallback</title><meta name=\"description\" content=\"\"></head><body></body></html>")
|
||||
|
||||
;; body reflects edits
|
||||
(content-test
|
||||
"page-full reflects edits"
|
||||
(content/page-full (doc-update d "p" "text" "Bye now"))
|
||||
"<!doctype html><html lang=\"en\"><head><meta charset=\"utf-8\"><title>My Title</title><meta name=\"description\" content=\"Hi Bye now\"></head><body><h1>Hi</h1><p>Bye now</p></body></html>")
|
||||
@@ -1,42 +0,0 @@
|
||||
;; Extension — full HTML page wrapper.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
|
||||
(define
|
||||
d
|
||||
(doc-with-title
|
||||
(doc-append (doc-empty "post") (mk-heading "h" 1 "Hi"))
|
||||
"My Title"))
|
||||
|
||||
(content-test
|
||||
"page"
|
||||
(content/page d)
|
||||
"<!doctype html><html><head><meta charset=\"utf-8\"><title>My Title</title></head><body><h1>Hi</h1></body></html>")
|
||||
|
||||
(content-test
|
||||
"page title escaped"
|
||||
(content/page (doc-with-title (doc-empty "x") "A < B"))
|
||||
"<!doctype html><html><head><meta charset=\"utf-8\"><title>A < B</title></head><body></body></html>")
|
||||
|
||||
(content-test
|
||||
"page falls back to id"
|
||||
(content/page (doc-empty "fallback"))
|
||||
"<!doctype html><html><head><meta charset=\"utf-8\"><title>fallback</title></head><body></body></html>")
|
||||
|
||||
(content-test "page-title from meta" (content/page-title d) "My Title")
|
||||
(content-test
|
||||
"page-title fallback id"
|
||||
(content/page-title (doc-empty "z"))
|
||||
"z")
|
||||
|
||||
(content-test
|
||||
"page body reflects edits"
|
||||
(content/page (doc-update d "h" "text" "Bye"))
|
||||
"<!doctype html><html><head><meta charset=\"utf-8\"><title>My Title</title></head><body><h1>Bye</h1></body></html>")
|
||||
|
||||
(content-test
|
||||
"page multi-block body"
|
||||
(content/page
|
||||
(doc-append (doc-with-title (doc-empty "p") "T") (mk-text "x" "para")))
|
||||
"<!doctype html><html><head><meta charset=\"utf-8\"><title>T</title></head><body><p>para</p></body></html>")
|
||||
@@ -1,89 +0,0 @@
|
||||
;; Extension — block query + table of contents.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-section!)
|
||||
|
||||
(define
|
||||
d
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-heading "h1" 1 "Intro"))
|
||||
(mk-text "p1" "para"))
|
||||
(mk-image "img" "/a.png" "alt"))
|
||||
(mk-section
|
||||
"s"
|
||||
(list
|
||||
(mk-heading "h2" 2 "Sub")
|
||||
(mk-text "p2" "more")
|
||||
(mk-image "img2" "/b.png" "b")))))
|
||||
|
||||
;; ── select-type (tree-wide) ──
|
||||
(content-test
|
||||
"select headings ids"
|
||||
(map (fn (b) (blk-id b)) (content/select-type d "heading"))
|
||||
(list "h1" "h2"))
|
||||
(content-test
|
||||
"select images ids"
|
||||
(map (fn (b) (blk-id b)) (content/select-type d "image"))
|
||||
(list "img" "img2"))
|
||||
(content-test
|
||||
"select text ids"
|
||||
(map (fn (b) (blk-id b)) (content/select-type d "text"))
|
||||
(list "p1" "p2"))
|
||||
(content-test
|
||||
"select section ids"
|
||||
(map (fn (b) (blk-id b)) (content/select-type d "section"))
|
||||
(list "s"))
|
||||
|
||||
;; ── count-type ──
|
||||
(content-test "count headings" (content/count-type d "heading") 2)
|
||||
(content-test "count images" (content/count-type d "image") 2)
|
||||
(content-test "count dividers" (content/count-type d "divider") 0)
|
||||
|
||||
;; ── select with custom predicate ──
|
||||
(content-test
|
||||
"select-ids custom"
|
||||
(content/select-ids d (fn (b) (= (blk-type b) "image")))
|
||||
(list "img" "img2"))
|
||||
(content-test
|
||||
"select custom field"
|
||||
(map
|
||||
(fn (b) (blk-id b))
|
||||
(content/select
|
||||
d
|
||||
(fn
|
||||
(b)
|
||||
(if
|
||||
(= (blk-type b) "heading")
|
||||
(= (blk-get b "level") 2)
|
||||
false))))
|
||||
(list "h2"))
|
||||
|
||||
;; ── headings / TOC ──
|
||||
(content-test
|
||||
"headings TOC"
|
||||
(content/headings d)
|
||||
(list {:id "h1" :text "Intro" :level 1} {:id "h2" :text "Sub" :level 2}))
|
||||
(content-test
|
||||
"empty doc no headings"
|
||||
(content/headings (doc-empty "e"))
|
||||
(list))
|
||||
|
||||
;; ── deeply nested ──
|
||||
(define
|
||||
deep
|
||||
(doc-append
|
||||
(doc-empty "d")
|
||||
(mk-section
|
||||
"o"
|
||||
(list (mk-section "i" (list (mk-heading "deep" 3 "Deep")))))))
|
||||
(content-test
|
||||
"deep heading found"
|
||||
(map (fn (b) (blk-id b)) (content/select-type deep "heading"))
|
||||
(list "deep"))
|
||||
(content-test
|
||||
"deep toc level"
|
||||
(get (first (content/headings deep)) :level)
|
||||
3)
|
||||
@@ -1,135 +0,0 @@
|
||||
;; Phase 1 — render boundary. asHTML / asSx are polymorphic message sends on
|
||||
;; blocks and the document. Escaping happens at the boundary.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content-bootstrap-blocks!)
|
||||
(content-bootstrap-doc!)
|
||||
(content-bootstrap-render!)
|
||||
|
||||
(define h (mk-heading "h" 2 "Title"))
|
||||
(define p (mk-text "p" "Hello"))
|
||||
(define code (mk-code "c" "sx" "(+ 1 2)"))
|
||||
(define q (mk-quote "q" "Ada" "to err"))
|
||||
(define img (mk-image "i" "/c.png" "cat"))
|
||||
(define em (mk-embed "e" "https://v/1" "vimeo"))
|
||||
(define dv (mk-divider "d"))
|
||||
(define ul (mk-list "u" false (list "a" "b")))
|
||||
(define ol (mk-list "o" true (list "x" "y")))
|
||||
|
||||
;; ── per-block asHTML ──
|
||||
(content-test "heading html" (asHTML h) "<h2>Title</h2>")
|
||||
(content-test "text html" (asHTML p) "<p>Hello</p>")
|
||||
(content-test
|
||||
"code html"
|
||||
(asHTML code)
|
||||
"<pre><code class=\"language-sx\">(+ 1 2)</code></pre>")
|
||||
(content-test "quote html" (asHTML q) "<blockquote>to err</blockquote>")
|
||||
(content-test "image html" (asHTML img) "<img src=\"/c.png\" alt=\"cat\">")
|
||||
(content-test "embed html" (asHTML em) "<iframe src=\"https://v/1\"></iframe>")
|
||||
(content-test "divider html" (asHTML dv) "<hr>")
|
||||
(content-test "ul html" (asHTML ul) "<ul><li>a</li><li>b</li></ul>")
|
||||
(content-test "ol html" (asHTML ol) "<ol><li>x</li><li>y</li></ol>")
|
||||
|
||||
;; ── per-block asSx ──
|
||||
(content-test "heading sx" (asSx h) "(h2 \"Title\")")
|
||||
(content-test "text sx" (asSx p) "(p \"Hello\")")
|
||||
(content-test "code sx" (asSx code) "(pre (code \"(+ 1 2)\"))")
|
||||
(content-test "quote sx" (asSx q) "(blockquote \"to err\")")
|
||||
(content-test "image sx" (asSx img) "(img :src \"/c.png\" :alt \"cat\")")
|
||||
(content-test "embed sx" (asSx em) "(iframe :src \"https://v/1\")")
|
||||
(content-test "divider sx" (asSx dv) "(hr)")
|
||||
(content-test "ul sx" (asSx ul) "(ul (li \"a\")(li \"b\"))")
|
||||
(content-test "ol sx" (asSx ol) "(ol (li \"x\")(li \"y\"))")
|
||||
|
||||
;; ── document folds children (pure message dispatch) ──
|
||||
(define d (doc-append (doc-append (doc-append (doc-empty "doc") h) p) dv))
|
||||
(content-test "doc html" (asHTML d) "<h2>Title</h2><p>Hello</p><hr>")
|
||||
(content-test "doc sx" (asSx d) "(article (h2 \"Title\")(p \"Hello\")(hr))")
|
||||
(content-test "empty doc html" (asHTML (doc-empty "e")) "")
|
||||
(content-test "empty doc sx" (asSx (doc-empty "e")) "(article )")
|
||||
|
||||
;; ── render-* / block-* aliases ──
|
||||
(content-test "render-html alias" (render-html d) (asHTML d))
|
||||
(content-test "render-sx alias" (render-sx d) (asSx d))
|
||||
(content-test "block-html alias" (block-html h) "<h2>Title</h2>")
|
||||
|
||||
;; ── render reflects edits (immutability: each render is of a version) ──
|
||||
(define d2 (doc-update d "p" "text" "Edited"))
|
||||
(content-test
|
||||
"render after update"
|
||||
(asHTML d2)
|
||||
"<h2>Title</h2><p>Edited</p><hr>")
|
||||
(content-test
|
||||
"original render unchanged"
|
||||
(asHTML d)
|
||||
"<h2>Title</h2><p>Hello</p><hr>")
|
||||
(content-test
|
||||
"render after move"
|
||||
(asHTML (doc-move d "h" 2))
|
||||
"<p>Hello</p><hr><h2>Title</h2>")
|
||||
(content-test
|
||||
"render after delete"
|
||||
(asHTML (doc-delete d "p"))
|
||||
"<h2>Title</h2><hr>")
|
||||
|
||||
;; ── HTML escaping at the boundary ──
|
||||
(define xh (mk-heading "xh" 2 "A < B & \"C\""))
|
||||
(define xp (mk-text "xp" "<script>alert(1)</script>"))
|
||||
(define xi (mk-image "xi" "/a.png?x=1&y=2" "tag <b>"))
|
||||
(define xl (mk-list "xl" false (list "a<1" "b&2")))
|
||||
(content-test
|
||||
"escape heading text"
|
||||
(asHTML xh)
|
||||
"<h2>A < B & "C"</h2>")
|
||||
(content-test
|
||||
"escape paragraph"
|
||||
(asHTML xp)
|
||||
"<p><script>alert(1)</script></p>")
|
||||
(content-test
|
||||
"escape image attrs"
|
||||
(asHTML xi)
|
||||
"<img src=\"/a.png?x=1&y=2\" alt=\"tag <b>\">")
|
||||
(content-test
|
||||
"escape list items"
|
||||
(asHTML xl)
|
||||
"<ul><li>a<1</li><li>b&2</li></ul>")
|
||||
(content-test
|
||||
"escape ampersand once"
|
||||
(asHTML (mk-text "amp" "a & b"))
|
||||
"<p>a & b</p>")
|
||||
(content-test
|
||||
"escape in document"
|
||||
(asHTML (doc-append (doc-empty "e") xp))
|
||||
"<p><script>alert(1)</script></p>")
|
||||
(content-test
|
||||
"no over-escape plain"
|
||||
(asHTML (mk-text "plain" "hello world"))
|
||||
"<p>hello world</p>")
|
||||
(content-test
|
||||
"escape code body"
|
||||
(asHTML (mk-code "xc" "html" "<div> & </div>"))
|
||||
"<pre><code class=\"language-html\"><div> & </div></code></pre>")
|
||||
|
||||
;; ── asSx string-escaping (build expected via q/bs to avoid miscounts) ──
|
||||
(define q1 (str "\""))
|
||||
(define bs (str "\\"))
|
||||
(content-test
|
||||
"asSx escapes quote"
|
||||
(asSx (mk-text "qt" (str "say " q1 "hi" q1)))
|
||||
(str "(p " q1 "say " bs q1 "hi" bs q1 q1 ")"))
|
||||
(content-test
|
||||
"asSx escapes backslash"
|
||||
(asSx (mk-text "qb" (str "a" bs "b")))
|
||||
(str "(p " q1 "a" bs bs "b" q1 ")"))
|
||||
(content-test
|
||||
"asSx plain unchanged"
|
||||
(asSx (mk-text "pp" "plain"))
|
||||
"(p \"plain\")")
|
||||
(content-test
|
||||
"asSx escapes image attr"
|
||||
(asSx (mk-image "im" (str "/a" q1) "x"))
|
||||
(str "(img :src " q1 "/a" bs q1 q1 " :alt " q1 "x" q1 ")"))
|
||||
(content-test
|
||||
"asSx escapes list item"
|
||||
(asSx (mk-list "lq" false (list (str "i" q1) "j")))
|
||||
(str "(ul (li " q1 "i" bs q1 q1 ")(li " q1 "j" q1 "))"))
|
||||
@@ -1,99 +0,0 @@
|
||||
;; Extension — nested block trees (CtSection container).
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-markdown!)
|
||||
(content-bootstrap-text!)
|
||||
(content-bootstrap-section!)
|
||||
|
||||
(define nl (str "\n"))
|
||||
|
||||
;; ── a section is a block ──
|
||||
(define
|
||||
sec
|
||||
(mk-section
|
||||
"s"
|
||||
(list (mk-heading "h" 2 "Hi") (mk-text "p" "Body"))))
|
||||
(content-test "section is block" (block? sec) true)
|
||||
(content-test "section? yes" (section? sec) true)
|
||||
(content-test "section? no on text" (section? (mk-text "x" "y")) false)
|
||||
(content-test "section type" (blk-type sec) "section")
|
||||
(content-test "section id" (blk-id sec) "s")
|
||||
(content-test
|
||||
"section children count"
|
||||
(len (section-children sec))
|
||||
2)
|
||||
|
||||
;; ── recursive render ──
|
||||
(content-test
|
||||
"section html"
|
||||
(asHTML sec)
|
||||
"<section><h2>Hi</h2><p>Body</p></section>")
|
||||
(content-test "section sx" (asSx sec) "(section (h2 \"Hi\")(p \"Body\"))")
|
||||
(content-test "section text" (asText sec) "Hi Body")
|
||||
(content-test
|
||||
"empty section html"
|
||||
(asHTML (mk-section "e" (list)))
|
||||
"<section></section>")
|
||||
|
||||
;; ── nested in a document ──
|
||||
(define
|
||||
d
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-heading "top" 1 "Top"))
|
||||
sec))
|
||||
(content-test
|
||||
"doc with section html"
|
||||
(asHTML d)
|
||||
"<h1>Top</h1><section><h2>Hi</h2><p>Body</p></section>")
|
||||
(content-test "doc top-level ids" (doc-ids d) (list "top" "s"))
|
||||
|
||||
;; ── arbitrary depth ──
|
||||
(define
|
||||
deep
|
||||
(mk-section
|
||||
"outer"
|
||||
(list
|
||||
(mk-text "a" "A")
|
||||
(mk-section
|
||||
"inner"
|
||||
(list (mk-text "b" "B") (mk-heading "c" 3 "C"))))))
|
||||
(content-test
|
||||
"deep html"
|
||||
(asHTML deep)
|
||||
"<section><p>A</p><section><p>B</p><h3>C</h3></section></section>")
|
||||
(content-test "deep text" (asText deep) "A B C")
|
||||
|
||||
;; ── tree traversal descends into sections ──
|
||||
(define dd (doc-append (doc-empty "d") deep))
|
||||
(content-test "deep-find nested" (blk-id (doc-deep-find dd "b")) "b")
|
||||
(content-test
|
||||
"deep-find deeper"
|
||||
(str (blk-send (doc-deep-find dd "c") "text"))
|
||||
"C")
|
||||
(content-test "deep-find missing" (doc-deep-find dd "zzz") nil)
|
||||
(content-test
|
||||
"deep-find top-level"
|
||||
(blk-id (doc-deep-find dd "outer"))
|
||||
"outer")
|
||||
(content-test
|
||||
"tree-ids flattened"
|
||||
(doc-tree-ids dd)
|
||||
(list "outer" "a" "inner" "b" "c"))
|
||||
(content-test "tree-count" (doc-tree-count dd) 5)
|
||||
(content-test "top-level ids still flat" (doc-ids dd) (list "outer"))
|
||||
|
||||
;; ── copy-on-write child edits ──
|
||||
(define sec2 (section-append sec (mk-divider "dv")))
|
||||
(content-test "section-append" (len (section-children sec2)) 3)
|
||||
(content-test
|
||||
"section-append immutable"
|
||||
(len (section-children sec))
|
||||
2)
|
||||
(content-test
|
||||
"section-append renders"
|
||||
(asHTML sec2)
|
||||
"<section><h2>Hi</h2><p>Body</p><hr></section>")
|
||||
|
||||
;; ── markdown of a section (children joined by blank line) ──
|
||||
(content-test "section markdown" (asMarkdown sec) (str "## Hi" nl nl "Body"))
|
||||
@@ -1,100 +0,0 @@
|
||||
;; Extension — snapshot cache over op-log replay. The cache is transparent:
|
||||
;; cached reads equal full replays.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content-bootstrap-blocks!)
|
||||
(content-bootstrap-doc!)
|
||||
|
||||
(define B (persist/open))
|
||||
(define h (mk-heading "h" 1 "T"))
|
||||
(define p (mk-text "p" "Body"))
|
||||
(define img (mk-image "img" "/c.png" "cat"))
|
||||
|
||||
(content/commit! B "post" (op-insert h nil) 1)
|
||||
(content/commit! B "post" (op-insert p "h") 2)
|
||||
(content/commit! B "post" (op-insert img "h") 3)
|
||||
(content/commit! B "post" (op-update "p" "text" "Edited") 4)
|
||||
|
||||
;; ── no snapshot yet: cached == full replay ──
|
||||
(content-test
|
||||
"no snapshot head-cached == head"
|
||||
(doc-ids (content/head-cached B "post"))
|
||||
(doc-ids (content/head B "post")))
|
||||
(content-test
|
||||
"has-snapshot? false initially"
|
||||
(content/has-snapshot? B "post")
|
||||
false)
|
||||
(content-test
|
||||
"snapshot-seq 0 initially"
|
||||
(content/snapshot-seq B "post")
|
||||
0)
|
||||
|
||||
;; ── take a snapshot at seq 4 ──
|
||||
(content-test "snapshot returns seq" (content/snapshot! B "post") 4)
|
||||
(content-test "has-snapshot? true" (content/has-snapshot? B "post") true)
|
||||
(content-test "snapshot-seq is 4" (content/snapshot-seq B "post") 4)
|
||||
|
||||
;; cached head equals full head right after snapshot
|
||||
(content-test
|
||||
"head-cached == head after snap"
|
||||
(doc-ids (content/head-cached B "post"))
|
||||
(list "h" "img" "p"))
|
||||
(content-test
|
||||
"head-cached p value"
|
||||
(str (blk-send (doc-find (content/head-cached B "post") "p") "text"))
|
||||
"Edited")
|
||||
|
||||
;; ── commit more after the snapshot; cached head replays only the tail ──
|
||||
(content/commit! B "post" (op-delete "img") 5)
|
||||
(content/commit! B "post" (op-insert (mk-text "q" "New") "p") 6)
|
||||
(content-test
|
||||
"head-cached reflects post-snapshot ops"
|
||||
(doc-ids (content/head-cached B "post"))
|
||||
(doc-ids (content/head B "post")))
|
||||
(content-test
|
||||
"head-cached order"
|
||||
(doc-ids (content/head-cached B "post"))
|
||||
(list "h" "p" "q"))
|
||||
|
||||
;; ── at-cached transparency across versions ──
|
||||
(content-test
|
||||
"at-cached seq2 (before snap) == at"
|
||||
(doc-ids (content/at-cached B "post" 2))
|
||||
(doc-ids (content/at B "post" 2)))
|
||||
(content-test
|
||||
"at-cached seq5 (after snap) == at"
|
||||
(doc-ids (content/at-cached B "post" 5))
|
||||
(doc-ids (content/at B "post" 5)))
|
||||
(content-test
|
||||
"at-cached seq6 == at"
|
||||
(doc-ids (content/at-cached B "post" 6))
|
||||
(doc-ids (content/at B "post" 6)))
|
||||
(content-test
|
||||
"at-cached seq4 == snapshot version"
|
||||
(doc-ids (content/at-cached B "post" 4))
|
||||
(list "h" "img" "p"))
|
||||
|
||||
;; ── re-snapshot moves the cache forward ──
|
||||
(content-test "re-snapshot seq" (content/snapshot! B "post") 6)
|
||||
(content-test
|
||||
"head-cached still correct after resnap"
|
||||
(doc-ids (content/head-cached B "post"))
|
||||
(list "h" "p" "q"))
|
||||
|
||||
;; ── drop snapshot falls back to full replay, same result ──
|
||||
(content/drop-snapshot! B "post")
|
||||
(content-test "snapshot dropped" (content/has-snapshot? B "post") false)
|
||||
(content-test
|
||||
"head-cached == head after drop"
|
||||
(doc-ids (content/head-cached B "post"))
|
||||
(doc-ids (content/head B "post")))
|
||||
|
||||
;; ── snapshot of empty / fresh doc ──
|
||||
(content-test
|
||||
"snapshot empty doc seq 0"
|
||||
(content/snapshot! B "empty")
|
||||
0)
|
||||
(content-test
|
||||
"head-cached empty"
|
||||
(doc-ids (content/head-cached B "empty"))
|
||||
(list))
|
||||
@@ -1,68 +0,0 @@
|
||||
;; Extension — document statistics.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-text!)
|
||||
(content-bootstrap-section!)
|
||||
|
||||
;; ── empty doc ──
|
||||
(define e (doc-empty "e"))
|
||||
(content-test "empty words" (content/word-count e) 0)
|
||||
(content-test "empty chars" (content/char-count e) 0)
|
||||
(content-test "empty blocks" (content/block-count e) 0)
|
||||
(content-test "empty reading" (content/reading-minutes e) 0)
|
||||
(content-test "empty stats" (content/stats e) {:blocks 0 :reading-minutes 0 :words 0 :chars 0})
|
||||
|
||||
;; ── simple doc ──
|
||||
(define
|
||||
d
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-heading "h" 1 "Hello World"))
|
||||
(mk-text "p" "one two three")))
|
||||
(content-test "word count" (content/word-count d) 5)
|
||||
(content-test
|
||||
"char count"
|
||||
(content/char-count d)
|
||||
(string-length "Hello World one two three"))
|
||||
(content-test "block count" (content/block-count d) 2)
|
||||
(content-test "reading rounds up" (content/reading-minutes d) 1)
|
||||
|
||||
;; ── reading time at 0 vs 1 word ──
|
||||
(content-test
|
||||
"one word one minute"
|
||||
(content/reading-minutes (doc-append (doc-empty "d") (mk-text "p" "hi")))
|
||||
1)
|
||||
|
||||
;; ── block count includes nested section children ──
|
||||
(define
|
||||
nested
|
||||
(doc-append
|
||||
(doc-empty "d")
|
||||
(mk-section
|
||||
"s"
|
||||
(list (mk-heading "nh" 1 "A") (mk-text "np" "b c")))))
|
||||
(content-test
|
||||
"block count counts section + children"
|
||||
(content/block-count nested)
|
||||
3)
|
||||
(content-test
|
||||
"word count descends into section"
|
||||
(content/word-count nested)
|
||||
3)
|
||||
|
||||
;; ── deep nesting ──
|
||||
(define
|
||||
deep
|
||||
(doc-append
|
||||
(doc-empty "d")
|
||||
(mk-section
|
||||
"o"
|
||||
(list (mk-text "a" "x") (mk-section "i" (list (mk-text "b" "y z")))))))
|
||||
(content-test "deep block count" (content/block-count deep) 4)
|
||||
(content-test "deep word count" (content/word-count deep) 3)
|
||||
|
||||
;; ── stats dict shape ──
|
||||
(define s (content/stats d))
|
||||
(content-test "stats words" (get s :words) 5)
|
||||
(content-test "stats blocks" (get s :blocks) 2)
|
||||
(content-test "stats has reading" (get s :reading-minutes) 1)
|
||||
@@ -1,153 +0,0 @@
|
||||
;; Phase 2 — op log + versioning over persist. The log is the source of truth;
|
||||
;; any version is a replay of the op stream up to a seq.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content-bootstrap-blocks!)
|
||||
(content-bootstrap-doc!)
|
||||
|
||||
(define B (persist/open))
|
||||
(define h (mk-heading "h" 1 "Title"))
|
||||
(define p (mk-text "p" "Body"))
|
||||
(define img (mk-image "img" "/c.png" "cat"))
|
||||
|
||||
;; ── commit an op stream ──
|
||||
(content/commit! B "post" (op-insert h nil) 10)
|
||||
(content/commit! B "post" (op-insert p "h") 11)
|
||||
(content/commit! B "post" (op-insert img "h") 12)
|
||||
(content/commit! B "post" (op-update "p" "text" "Edited") 13)
|
||||
(content/commit! B "post" (op-delete "img") 14)
|
||||
|
||||
(content-test "version-count" (content/version-count B "post") 5)
|
||||
(content-test "log length" (len (content/log B "post")) 5)
|
||||
|
||||
;; ── head: latest materialised document ──
|
||||
(content-test "head ids" (doc-ids (content/head B "post")) (list "h" "p"))
|
||||
(content-test
|
||||
"head p edited"
|
||||
(str (blk-send (doc-find (content/head B "post") "p") "text"))
|
||||
"Edited")
|
||||
|
||||
;; ── replay to any version ──
|
||||
(content-test
|
||||
"at seq1"
|
||||
(doc-ids (content/at B "post" 1))
|
||||
(list "h"))
|
||||
(content-test
|
||||
"at seq2"
|
||||
(doc-ids (content/at B "post" 2))
|
||||
(list "h" "p"))
|
||||
(content-test
|
||||
"at seq3"
|
||||
(doc-ids (content/at B "post" 3))
|
||||
(list "h" "img" "p"))
|
||||
(content-test
|
||||
"at seq3 p original"
|
||||
(str (blk-send (doc-find (content/at B "post" 3) "p") "text"))
|
||||
"Body")
|
||||
(content-test
|
||||
"at seq4 p edited"
|
||||
(str (blk-send (doc-find (content/at B "post" 4) "p") "text"))
|
||||
"Edited")
|
||||
(content-test
|
||||
"at seq5 img gone"
|
||||
(doc-ids (content/at B "post" 5))
|
||||
(list "h" "p"))
|
||||
(content-test
|
||||
"at seq0 empty"
|
||||
(doc-ids (content/at B "post" 0))
|
||||
(list))
|
||||
|
||||
;; ── ops accessor ──
|
||||
(content-test
|
||||
"ops kinds"
|
||||
(map (fn (o) (get o :op)) (content/ops B "post"))
|
||||
(list "insert" "insert" "insert" "update" "delete"))
|
||||
|
||||
;; ── history metadata ──
|
||||
(define hist (content/history B "post"))
|
||||
(content-test "history length" (len hist) 5)
|
||||
(content-test "history first seq" (get (first hist) :seq) 1)
|
||||
(content-test "history first type" (get (first hist) :type) "insert")
|
||||
(content-test "history first at" (get (first hist) :at) 10)
|
||||
(content-test
|
||||
"history fourth type"
|
||||
(get (nth hist 3) :type)
|
||||
"update")
|
||||
|
||||
;; ── diff between versions ──
|
||||
(define dvf (content/diff-versions B "post" 1 3))
|
||||
(content-test "diff added" (get dvf :added) (list "img" "p"))
|
||||
(content-test "diff removed empty" (get dvf :removed) (list))
|
||||
(content-test "diff changed empty" (get dvf :changed) (list))
|
||||
|
||||
(define dvf2 (content/diff-versions B "post" 3 5))
|
||||
(content-test "diff2 removed" (get dvf2 :removed) (list "img"))
|
||||
(content-test "diff2 changed" (get dvf2 :changed) (list "p"))
|
||||
(content-test "diff2 added empty" (get dvf2 :added) (list))
|
||||
|
||||
;; ── direct diff of two materialised docs ──
|
||||
(define da (content/at B "post" 2))
|
||||
(define db (content/at B "post" 5))
|
||||
(content-test
|
||||
"direct diff changed"
|
||||
(get (content/diff da db) :changed)
|
||||
(list "p"))
|
||||
(content-test
|
||||
"direct diff no-op"
|
||||
(get (content/diff da da) :changed)
|
||||
(list))
|
||||
|
||||
;; ── commit-all batch ──
|
||||
(define B2 (persist/open))
|
||||
(content/commit-all!
|
||||
B2
|
||||
"doc2"
|
||||
(list (op-insert h nil) (op-insert p "h"))
|
||||
1)
|
||||
(content-test "commit-all count" (content/version-count B2 "doc2") 2)
|
||||
(content-test
|
||||
"commit-all head"
|
||||
(doc-ids (content/head B2 "doc2"))
|
||||
(list "h" "p"))
|
||||
|
||||
;; ── stream isolation ──
|
||||
(content-test
|
||||
"separate stream empty"
|
||||
(content/version-count B "doc2")
|
||||
0)
|
||||
(content-test
|
||||
"head of empty stream"
|
||||
(doc-ids (content/head B "never"))
|
||||
(list))
|
||||
|
||||
;; ── op-log carries non-core block types (callout/media) through replay ──
|
||||
(content-bootstrap-callout!)
|
||||
(content-bootstrap-media!)
|
||||
(define B3 (persist/open))
|
||||
(content/commit!
|
||||
B3
|
||||
"rich"
|
||||
(op-insert (mk-callout "co" "note" "hi") nil)
|
||||
1)
|
||||
(content/commit!
|
||||
B3
|
||||
"rich"
|
||||
(op-insert (mk-media "v" "video" "/c.mp4") "co")
|
||||
2)
|
||||
(content/commit! B3 "rich" (op-update "co" "text" "edited") 3)
|
||||
(content-test
|
||||
"op-log rich ids"
|
||||
(doc-ids (content/head B3 "rich"))
|
||||
(list "co" "v"))
|
||||
(content-test
|
||||
"op-log callout type"
|
||||
(blk-type (doc-find (content/head B3 "rich") "co"))
|
||||
"callout")
|
||||
(content-test
|
||||
"op-log callout update"
|
||||
(str (blk-send (doc-find (content/head B3 "rich") "co") "text"))
|
||||
"edited")
|
||||
(content-test
|
||||
"op-log media type"
|
||||
(blk-type (doc-find (content/head B3 "rich") "v"))
|
||||
"media")
|
||||
@@ -1,74 +0,0 @@
|
||||
;; Extension — list-card summary projection.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content/bootstrap!)
|
||||
(content-bootstrap-text!)
|
||||
|
||||
(define
|
||||
d
|
||||
(doc-with-title
|
||||
(doc-append
|
||||
(doc-append
|
||||
(doc-append (doc-empty "post") (mk-heading "h" 1 "Hello"))
|
||||
(mk-text "p" "one two three four"))
|
||||
(mk-image "img" "/cover.png" "cover"))
|
||||
"My Post"))
|
||||
|
||||
;; image alt ("cover") is part of the plain-text projection, so it counts.
|
||||
(define s (content/summary d))
|
||||
(content-test "summary id" (get s :id) "post")
|
||||
(content-test "summary title" (get s :title) "My Post")
|
||||
(content-test
|
||||
"summary excerpt"
|
||||
(get s :excerpt)
|
||||
"Hello one two three four cover")
|
||||
(content-test "summary words" (get s :words) 6)
|
||||
(content-test "summary reading" (get s :reading-minutes) 1)
|
||||
(content-test "summary cover" (get s :cover) "/cover.png")
|
||||
|
||||
;; ── title falls back to id ──
|
||||
(content-test
|
||||
"summary title fallback"
|
||||
(get
|
||||
(content/summary (doc-append (doc-empty "x") (mk-text "p" "y")))
|
||||
:title)
|
||||
"x")
|
||||
|
||||
;; ── no image → cover nil ──
|
||||
(content-test
|
||||
"no cover"
|
||||
(get
|
||||
(content/summary (doc-append (doc-empty "x") (mk-text "p" "y")))
|
||||
:cover)
|
||||
nil)
|
||||
(content-test "cover helper nil" (content/cover (doc-empty "e")) nil)
|
||||
|
||||
;; ── first image wins as cover ──
|
||||
(define
|
||||
d2
|
||||
(doc-append
|
||||
(doc-append (doc-empty "d") (mk-image "i1" "/a.png" "a"))
|
||||
(mk-image "i2" "/b.png" "b")))
|
||||
(content-test "first image cover" (content/cover d2) "/a.png")
|
||||
|
||||
;; ── empty doc ──
|
||||
(define se (content/summary (doc-empty "e")))
|
||||
(content-test "empty summary words" (get se :words) 0)
|
||||
(content-test "empty summary excerpt" (get se :excerpt) "")
|
||||
(content-test "empty summary cover" (get se :cover) nil)
|
||||
|
||||
;; ── excerpt truncates long content ──
|
||||
(content-test
|
||||
"excerpt truncated"
|
||||
(>
|
||||
(string-length
|
||||
(get
|
||||
(content/summary
|
||||
(doc-append
|
||||
(doc-empty "d")
|
||||
(mk-text
|
||||
"p"
|
||||
"word word word word word word word word word word word word word word word word word word word word word word word word word word word word word word word word word")))
|
||||
:excerpt))
|
||||
100)
|
||||
true)
|
||||
@@ -1,74 +0,0 @@
|
||||
;; Phase 4 — external CMS sync via injected adapter. Import/export round-trip.
|
||||
|
||||
(st-bootstrap-classes!)
|
||||
(content-bootstrap-blocks!)
|
||||
(content-bootstrap-doc!)
|
||||
(content-bootstrap-render!)
|
||||
|
||||
;; ── a Ghost post (external shape) ──
|
||||
(define post {:sections (list {:id "h" :text "Hello" :kind "heading" :level 1} {:id "p" :text "World" :kind "paragraph"} {:id "i" :src "/c.png" :alt "cat" :kind "image"} {:id "d" :kind "hr"} {:items (list "a" "b") :id "l" :kind "list" :ordered true}) :title "Hello"})
|
||||
|
||||
;; ── import (delegates to adapter) ──
|
||||
(define doc (content/import ghost-adapter post "post"))
|
||||
(content-test "import doc-id" (doc-id doc) "post")
|
||||
(content-test "import ids" (doc-ids doc) (list "h" "p" "i" "d" "l"))
|
||||
(content-test
|
||||
"import types"
|
||||
(doc-types doc)
|
||||
(list "heading" "text" "image" "divider" "list"))
|
||||
(content-test
|
||||
"import renders"
|
||||
(content/render doc "html")
|
||||
"<h1>Hello</h1><p>World</p><img src=\"/c.png\" alt=\"cat\"><hr><ol><li>a</li><li>b</li></ol>")
|
||||
(content-test
|
||||
"import preserves heading level"
|
||||
(blk-send (doc-find doc "h") "level")
|
||||
1)
|
||||
(content-test
|
||||
"import preserves list items"
|
||||
(blk-send (doc-find doc "l") "items")
|
||||
(list "a" "b"))
|
||||
|
||||
;; ── export (delegates to adapter) ──
|
||||
(define out (content/export ghost-adapter doc))
|
||||
(content-test
|
||||
"export sections round-trip"
|
||||
(get out :sections)
|
||||
(get post :sections))
|
||||
|
||||
;; ── round-trip: export then import yields the same document ──
|
||||
(define doc2 (content/round-trip ghost-adapter doc))
|
||||
(content-test "round-trip ids" (doc-ids doc2) (doc-ids doc))
|
||||
(content-test
|
||||
"round-trip render"
|
||||
(content/render doc2 "html")
|
||||
(content/render doc "html"))
|
||||
|
||||
;; ── round-trip the external form: import . export . import == import ──
|
||||
(content-test
|
||||
"external round-trip sections"
|
||||
(get
|
||||
(content/export ghost-adapter (content/import ghost-adapter post "post"))
|
||||
:sections)
|
||||
(get post :sections))
|
||||
|
||||
;; ── core knows nothing about Ghost: a different (stub) adapter works the same ──
|
||||
(define raw-adapter {:export (fn (d) (str (blk-send (doc-find d "only") "text"))) :import (fn (ext doc-id) (doc-new doc-id (list (mk-text "only" ext))))})
|
||||
(define rdoc (content/import raw-adapter "just text" "r"))
|
||||
(content-test "alt adapter import" (doc-ids rdoc) (list "only"))
|
||||
(content-test
|
||||
"alt adapter export"
|
||||
(content/export raw-adapter rdoc)
|
||||
"just text")
|
||||
|
||||
;; ── code / quote / embed kinds round-trip ──
|
||||
(define post2 {:sections (list {:id "c" :text "(+ 1 2)" :kind "code" :language "sx"} {:cite "Ada" :id "q" :text "to err" :kind "quote"} {:id "e" :provider "vimeo" :kind "embed" :url "https://v/1"})})
|
||||
(define d3 (content/import ghost-adapter post2 "p2"))
|
||||
(content-test
|
||||
"code/quote/embed types"
|
||||
(doc-types d3)
|
||||
(list "code" "quote" "embed"))
|
||||
(content-test
|
||||
"code/quote/embed round-trip"
|
||||
(get (content/export ghost-adapter d3) :sections)
|
||||
(get post2 :sections))
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user