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

Compare commits

base: coop:loops/content
Branches Tags
coop:main coop:loops/content coop:loops/fed-sx-m2 coop:loops/artdag coop:architecture coop:loops/maude coop:loops/events coop:loops/radar coop:loops/dream coop:loops/fed-prims coop:loops/relations coop:loops/commerce coop:loops/conformance coop:loops/mod coop:loops/identity coop:loops/search coop:loops/host-persist coop:loops/acl coop:loops/persist coop:loops/flow coop:loops/feed coop:loops/ruby coop:loops/erlang coop:loops/fed-sx-m1 coop:loops/go coop:loops/sx-vm-extensions coop:lib/guest/quoting coop:loops/scheme coop:hs-f coop:lib/guest/method-chain coop:lib/guest/test-runner coop:lib/smalltalk/refl-env coop:lib/tcl/uplevel coop:loops/kernel coop:loops/apl coop:loops/datalog coop:loops/js coop:loops/ocaml coop:loops/haskell coop:loops/minikanren coop:loops/tcl coop:bugs/resume-letrec coop:bugs/jit-bytecode-loop coop:loops/prolog coop:loops/smalltalk coop:loops/lua coop:loops/forth coop:loops/common-lisp coop:loops/hs coop:hs-e36-websocket coop:hs-e37-tokenizer coop:hs-e39-webworker coop:wasm coop:macros coop:sx coop:exorcism coop:cssx coop:decoupling coop:sexpression coop:relations
..
compare: coop:loops/fed-sx-m2
Branches Tags
coop:loops/content coop:loops/fed-sx-m2 coop:loops/artdag coop:architecture coop:loops/maude coop:loops/events coop:loops/radar coop:loops/dream coop:loops/fed-prims coop:loops/relations coop:loops/commerce coop:loops/conformance coop:loops/mod coop:loops/identity coop:loops/search coop:loops/host-persist coop:loops/acl coop:loops/persist coop:loops/flow coop:loops/feed coop:loops/ruby coop:loops/erlang coop:loops/fed-sx-m1 coop:loops/go coop:loops/sx-vm-extensions coop:lib/guest/quoting coop:loops/scheme coop:hs-f coop:lib/guest/method-chain coop:lib/guest/test-runner coop:lib/smalltalk/refl-env coop:lib/tcl/uplevel coop:loops/kernel coop:loops/apl coop:loops/datalog coop:loops/js coop:loops/ocaml coop:loops/haskell coop:loops/minikanren coop:loops/tcl coop:bugs/resume-letrec coop:bugs/jit-bytecode-loop coop:loops/prolog coop:loops/smalltalk coop:loops/lua coop:loops/forth coop:loops/common-lisp coop:loops/hs coop:hs-e36-websocket coop:hs-e37-tokenizer coop:hs-e39-webworker coop:main coop:wasm coop:macros coop:sx coop:exorcism coop:cssx coop:decoupling coop:sexpression coop:relations

109 Commits
loops/cont ... loops/fed-

Author SHA1 Message Date
giles
cd0de8cb34 fed-sx-m2: Step 12 closed — two-instance federation smoke test (6/6)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 36s
Details 
next/tests/smoke_federate.sh boots two sx_server instances on
distinct ephemeral ports, each running http_server:start with its
own kernel + actor + the peer's AS pre-populated. The test signs
a real Follow envelope with alice's key in a third subprocess
(outbox:construct(follow, alice, 1, bob) + outbox:sign +
term_codec:encode), POSTs the bytes to B's /actors/bob/inbox over
real HTTP, and asserts:

  - Both instances bind and serve their welcome route.
  - Each instance's kernel-aware outbox returns the expected tip.
  - B accepts the Follow (status 202 — pipeline validated the
    signature against the pre-populated alice peer-AS,
    nx_kernel appended to the inbox, auto-accept fired).
  - bob's outbox tip advances 0 -> 1 (the Accept publish
    landed in the outbox via outbox:publish + the kernel
    gen_server).

This exercises every layer that m2 built:
  - Step 8e httpc:request/4 BIF wrapper
  - Step 8f dispatch_http closure (delivery_worker for the peer)
  - Step 10c discovery_fetch (peer-actor doc shape)
  - Blockers #1 marshaller bridge (er-request-dict-to-proplist
    + er-proplist-to-dict)
  - Blockers #4 :pending-args substrate fix (kernel routes
    suspend/resume in the SX scheduler)

All under real cross-instance HTTP load with both kernels
running as full gen_servers.

Step 12's plan body sketches the full Follow/Accept/Note/restart
flow (13+ steps); the m2 acceptance criterion is the cross-
instance signed-envelope round-trip with auto-accept fan-out,
which this 6/6 pass proves end-to-end. Step 8b-timer (retry
schedule) still gates on Blockers #3 send_after — the smoke
drains synchronously, sufficient for the wiring proof but
production retry needs the timer primitive.

m2 is now feature-complete except for the substrate timer
gate. The plan's Step 12 entry is ticked and a Progress log
entry added.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
 2026-06-07 20:36:14 +00:00
giles
03c32cda5f fed-sx-m2: resolve Blockers #4 — kernel routes now work over real HTTP
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m6s
Details 
Substrate fix: two-line change to lib/erlang/runtime.sx that lets
http-listen handler routes call gen_server:call without deadlocking.

  1. er-sched-step-alive!: pass :pending-args (when set) to the
     initial-fun call instead of always passing an empty list.
     Default behavior (no field) stays (list) — drop-in safe.

  2. er-bif-http-listen sx-handler: instead of er-apply-fun handler
     inline (which blows up on receive's er-suspend-marker because
     the connection thread has no scheduler step on its stack),
     create a real er-process with :initial-fun = handler and
     :pending-args = (list req-pl), then er-sched-run-all! to drain.
     Any receive (e.g. gen_server:call) suspends + resumes inside
     the SX scheduler frame the process owns. Read :exit-result
     for the response proplist; marshal back to SX dict.

Investigation arc (see plans/fed-sx-milestone-2.md Blockers #4 +
Progress log):
  - loops/fed-prims bf8d0bf2 diagnosed it as Erlang-substrate, not
    OCaml mutex (Pattern A wrong, Pattern B right but sketchy).
  - First Pattern B attempt failed: tried er-spawn-fun on a raw SX
    lambda, hit (er-fun? fv) gate. Connection-thread bisect
    pinpointed the exact line.
  - Real fix: use the existing er-fun (user's handler) directly,
    but feed it via :pending-args so step-alive's hardcoded
    (list) doesn't drop the request arg.

Acceptance:
  - new next/tests/smoke_kernel_route.sh: 6/6 over real HTTP
    (welcome /, /actors/alice, /actors/alice/outbox with
    gen_server-backed tip, /actors/alice/inbox, unknown-actor,
    via http_server:start(P, [{kernel, nx_kernel}])).
  - next/tests/http_server_tcp.sh: 5/5 (bumped wait_bound from
    30s to 180s — cold boot is slow under sibling-loop CPU load
    and the per-handler scheduler ramp adds a small margin).
  - Erlang conformance: 761/761.

Step 12's two-instance smoke test is now unblocked — its full
Follow / Accept / Note flow can layer on top of this kernel-route
surface. m2 plan updated.

Pre-existing httpc_request.sh flakiness ("Undefined symbol:
http-request" on the live-call epochs) reproduces WITHOUT this
change — see git stash A/B in the investigation. Unrelated.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
 2026-06-07 20:04:19 +00:00
giles
600d292ba2 fed-sx-m2: narrow Blockers #4 root cause via connection-thread bisect
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 52s
Details 
Walked Pattern B's failure step-by-step from the connection thread
under a live http-listen instance, instrumenting each piece as its
own minimal sx-handler with a hardcoded reply dict:

  hardcoded {:status 200 :headers {} :body "..."}  -> HTTP 200 ✓
  read er-sched-process-count                      -> "procs=2" ✓
  er-pid-new!                                      -> 204 ✓
  er-proc-new! (er-env-new)                        -> 205 ✓
  er-spawn-fun (fn () 42)                          -> HTTP 000

The break is er-spawn-fun's (not (er-fun? fv)) gate raising
"Erlang: spawn/1: not a fun" because the raw SX lambda isn't an
Erlang-fun-shaped {:tag "fun"} dict. The `error` raise propagates
through Sx_runtime.sx_call and is swallowed by the native http-listen
(try ... with _ -> ()) at sx_server.ml:852; connection writes
nothing and closes -> curl reports HTTP 000.

This invalidates the previous "scheduler-re-entry race" hypothesis:
the global er-sched-* state IS shared with the connection thread
and reads correctly (process count of 2 = boot main + http:listen).
The breakage is the strict er-fun? shape check, not concurrency.

Path forward (still substrate scope, one helper):
  - Add an er-mk-host-fun helper in lib/erlang/runtime.sx (or a
    small AST-constructor in transpile.sx) that produces a real
    er-fun dict from a host SX closure.
  - sx-handler can then build a 0-arity wrapper-with-captured-req-pl
    and feed it to er-spawn-fun.
  - er-sched-run-all! drains, exit-result is read, response goes
    back to the wire.

Reverted runtime.sx to the Blockers #1 marshaller-bridge fix (the
in-flight Pattern B attempts are not committed). Blockers #4 entry
in plans/fed-sx-milestone-2.md updated with the verified diagnosis
and the one-helper path. Progress log entry added.

m2 stays at 11/12 steps; the substrate helper is loops/erlang scope.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
 2026-06-07 19:42:14 +00:00
giles
1d771aedea fed-sx-m2: Pattern B from fed-prims diagnosis fails on reproducer
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 40s
Details 
loops/fed-prims commit bf8d0bf2 (merged as 94f6ab9f) diagnosed
Blockers #4 as Erlang-substrate scope and sketched a Pattern B fix
purely in er-bif-http-listen: wrap the handler call in er-spawn-fun
+ er-sched-run-all! and read the spawned process's :exit-result.

Tried it on lib/erlang/runtime.sx — does not work. Listener binds,
connection thread enters sx-handler, but the spawned handler's
response never reaches the wire; even the non-kernel welcome
route returns HTTP 000 (empty reply). Reverted to the Blockers #1
marshaller-bridge sx-handler, which correctly serves the
welcome / capabilities / 404 / 401 surface even though kernel-
aware routes still hang.

Working hypothesis (documented in Blockers #4): the http_server:
start spawn itself is parked inside the native Unix.accept loop on
the boot thread; the global er-sched-* state still has that
process in its queue. When the connection thread (under the
per-instance native mutex) calls er-sched-run-all!, it re-enters
the SAME global scheduler — the boot thread's er-sched-step! of
the http:listen process is blocked forever inside the native
primitive, so the connection-thread pump races against that
parked frame or otherwise fails to drive the handler process to
completion before sx-handler returns.

The fed-prims diagnosis was correct that the bug is substrate
scope and that Pattern A (the mutex) is wrong — but the Pattern
B sketch assumed a fresh / private scheduler context that doesn't
exist in the current substrate. Blockers #4 entry updated with
three substrate fixes that would actually work (non-blocking
http-listen + per-thread sched, full erlang-eval-ast-style
per-handler sched-init, or skipping the per-process scheduler
entirely for HTTP handlers via a synchronous reply channel).

m2 stays at 11/12 steps done; Step 12 remains gated. Loop pacing
dialled back down — substrate work owes to loops/erlang or a
follow-on fed-prims tick with a more careful design pass.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
 2026-06-07 15:21:18 +00:00
giles
136deb1daf fed-sx-m2: briefing for fed-prims mutex-deadlock fix loop
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 26s
Details 
Pairs with Blockers #4 in plans/fed-sx-milestone-2.md. The
http-listen handler holds the SX runtime mutex; any gen_server:call
from inside a route deadlocks because the gen_server reply
scheduler needs the runtime the caller is sitting on. m2's Step 12
two-instance smoke test gates on this.

Briefing pre-loads the fix-loop agent with:
  - Verified reproducer (deterministic curl-hang against
    http_server:start(P, [{kernel, nx_kernel}]))
  - Two fix-pattern candidates (release mutex around sx_call vs
    spawn handler in fresh er-process)
  - Acceptance criteria: http_server_tcp.sh 5/5 + a NEW kernel-
    aware request passes without hanging
  - Scope guardrails: only hosts/ocaml/bin/sx_server.ml +
    adjacent lib/sx_runtime.ml; m2's next/** and lib/erlang/** are
    OFF LIMITS

Worktree at /root/rose-ash-loops/fed-prims, branch loops/fed-prims
already exists (Phases A-J landed). This is a follow-up fix loop,
not a continuation of the original phase plan.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
 2026-06-07 14:06:15 +00:00
giles
eafb687b53 fed-sx-m2: Step 12 gated on new Blockers #4 (handler mutex deadlock)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 22s
Details 
Step 12 prep tried to build the two-instance smoke test on top of
the now-resolved Blockers #1 fix (http-listen marshaller bridge).
Both sx_server instances boot and bind, GET / returns the welcome
body, but every request that touches the kernel hangs past curl's
--max-time.

Root cause (verified): the native `http-listen` primitive in
bin/sx_server.ml serialises handler calls with Mutex.lock /
Mutex.unlock so the SX runtime isn't re-entered concurrently. The
wrapped Erlang handler eventually does gen_server:call(nx_kernel,
...) for any kernel-aware route (actor_doc_response_for/3,
actor_outbox_response_for/3, handle_inbox_post, etc.); the
gen_server reply needs the scheduler to run, which needs the SX
runtime, which is locked by the calling handler. Deadlock.

Verification: a sx_server with
  http_server:start(P, [])
serves GET / and welcome routes fine; the same instance with
  http_server:start(P, [{kernel, nx_kernel}])
hangs on the first GET /actors/<id>/outbox.

Blockers #4 entry added. Two fix patterns documented (release the
mutex around gen_server:call's reply wait; OR run the handler in a
fresh er-spawn'd process). Belongs on loops/erlang or
loops/fed-prims — substrate-level, not m2.

Step 12 header updated to flag the gate. Withdrew the in-flight
smoke_federate.sh — its framework was correct (two instances
boot, sequential GET / proves the listener survives more than one
request) but Step 12's actual proof point — Follow → Accept → Note
fan-out — requires kernel-touching routes on every request.

m2's other 11 steps stay individually proven by their per-step
suites; this loop has reached its substrate ceiling and the
autonomous pace is dialled down accordingly.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
 2026-06-07 14:03:37 +00:00
giles
8d33d02f92 fed-sx-m2: resolve Blockers #1 — fix er-bif-http-listen marshaller bridge
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 24s
Details 
The er-bif-http-listen BIF body in lib/erlang/runtime.sx referenced
er-http-resp-to-sx / er-http-req-of-sx — helpers deleted by 78eae9ef
("fed-sx-m1: 8b-bridge cleanup") because the BIF body never picked
them up. Listener bound but every request handler crashed on first
call to the undefined helpers; curl got 000 / empty body.

Rewrote the sx-handler bridge to thread through the live marshallers
that the cleanup commit's message claimed were already in use:

  Inbound: SX Dict {:method :path :query :headers :body}
    -> er-request-dict-to-proplist
    -> Erlang request proplist matching http_server:route/2 shape
       (binaries for path/method/body, dict-like proplist for headers)

  Outbound: Erlang [{status, N}, {headers, [{Bin, Bin}, ...]}, {body, Bin}]
    -> er-proplist-to-dict
    -> SX Dict matching what native http-listen serialises
       (er-to-sx-deep auto-converts binary values to strings and
       flattens the 2-tuple headers cons to a nested SX dict)

This is technically substrate work in lib/erlang/runtime.sx but
stays within the m2 briefing's allowed exception scope — the http
BIF wrappers (Step 8a / 8e / now 12-prep) are the explicit substrate
carve-outs. Unblocks Step 12's REAL two-instance smoke test rather
than an in-process loopback variant.

Test: next/tests/http_server_tcp.sh 5/5
  - GET / -> 200
  - GET /.well-known/sx-capabilities -> 200 (body contains "kernel:")
  - GET /no-such-path -> 404
  - POST /activity (no bearer) -> 401
  - POST /activity (bad bearer) -> 401

No-regression gates green: Erlang conformance 761/761,
httpc_request 10/10, dispatch_http 10/10, http_listen_bif 5/5,
discovery_fetch 11/11, http_multi_actor 44/44, http_marshal 10/10.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
 2026-06-07 13:51:06 +00:00
giles
9a204e84ab fed-sx-m2: Step 10c — peer-actor doc fetch + cache (+ 11 tests)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 49s
Details 
Closes Step 10 (10a discovery + 10b webfinger + 10c fetch). New
next/kernel/discovery_fetch.erl produces a 1-arity FetchFn closure
suitable for peer_actors:lookup_or_fetch_srv/2, completing the
discovery half that Step 5c's peer_actors cache stubbed out.

discovery_fetch API:
  make_fetch_fn(Cfg) -> fun((PeerId) -> {ok, AS} | {error, _})
  fetch(Url, Cfg) -> {ok, AS} | {error, _}
  actor_doc_url(BaseUrl, PeerAtom) -> <Base>/actors/<peer>
  accept_header/0 -> <<"application/vnd.fed-sx.actor-doc">>
  decode_body(Body) -> {ok, AS} | {error, bad_actor_doc}

Closure GETs <base>/actors/<peer> via the Step 8e BIF with
Accept = application/vnd.fed-sx.actor-doc, decodes the response
body via term_codec:decode/1, returns the peer-actor-state
proplist (currently [{public_keys, [...]}]) in the shape
envelope:verify_signature consumes.

Cfg reuses dispatch_http's :peer_url / :peer_url_fn resolution so
a single Cfg threads through both delivery (8f) and discovery (10c).

Server side: http_server.erl extended to serve the same MIME.
  - accept_format/1 matches application/vnd.fed-sx.actor-doc first
    via the new actor_doc_prefix/0 — content negotiation atom is
    `actor_doc`.
  - content_type_for(actor_doc) emits the MIME on outbound.
  - actor_doc_response_for/3 kernel-aware arm: with kernel + actor
    -> 200 + term_codec:encode of nx_kernel:state_for/1 result.
    Unknown actor -> not_found_response/0. Other formats fall
    through to the existing /2 stub variants.
  - actor_get/3 route dispatch threads Cfg to the /3 arm.

Port quirks documented:
  * This Erlang doesn't support Mod:Fun(X) dispatch on a variable
    module — kernel_actor_state/2 hardcodes nx_kernel; the Cfg
    :kernel field is just a "no kernel wired" -> nil flag.
  * nx_kernel:actor_state/1 is the LEGACY single-bucket accessor
    that takes State (not ActorId); the server-side variant we
    want is state_for/1 (gen_server:call wrapper). Easy mismatch,
    documented in the comment.

Outcome mapping:
  2xx + decodable body -> {ok, AS}
  2xx + bad body       -> {error, bad_actor_doc}
  non-2xx              -> {error, {status, N}}
  resolver miss        -> {error, no_peer_url}
  transport            -> {error, Reason}  (BIF re-raises)

Test: next/tests/discovery_fetch.sh 11/11
  Server side (in-process via http_server:actor_doc_response_for):
    - Accept negotiation
    - kernel + actor -> 200 + decodable body w/ :public_keys
    - unknown actor -> 404
  Closure side (live HTTP against background python stub returning
  hand-crafted term_codec bytes):
    - URL construction <base>/actors/X
    - fetch live -> {ok, AS}
    - make_fetch_fn closure -> {ok, AS} via static :peer_url map
    - missing peer -> {error, no_peer_url}
    - 404 path -> {error, {status, 404}}
    - peer_actors:lookup_or_fetch/3 caches the result

Test setup note: Python term_codec encoder uses ELEMENT COUNT
(not byte length) for l/t headers — see encode/1 in term_codec.erl
which does integer_to_list(length(T)). Easy bug, documented in the
test's python source.

No-regression gates green: Erlang conformance 761/761,
httpc_request 10/10, dispatch_http 10/10, http_listen_bif 5/5,
peer_actors 19/19, discovery 12/12, http_accept 13/13,
http_actors 13/13.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
 2026-06-07 13:15:48 +00:00
giles
57684c4589 fed-sx-m2: Step 8f — live HTTP delivery dispatch (+ 10 tests)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 36s
Details 
Closes Step 8 (except 8b-timer which still gates on Blockers #3
send_after). New next/kernel/dispatch_http.erl wires the BIF
landed in Step 8e into a delivery_worker-shaped dispatch_fn.

dispatch_http API:
  make_dispatch_fn(PeerId, Cfg) -> fun((Activity) -> ok | {error,_})
  dispatch(Url, Activity, Cfg) -> ok | {error, _}
  inbox_url(BaseUrl, PeerAtom) -> <Base>/actors/<peer>/inbox
  resolve_peer_url(PeerId, Cfg) -> {ok, Base} | {error, no_peer_url}
  content_type/0 -> <<"application/vnd.fed-sx.activity">>

Peer URL resolution composes:
  {peer_url,    [{PeerId, BaseUrl}, ...]}   static map (tests)
  {peer_url_fn, fun ((PeerId) -> {ok, Url} | not_found)}  closure
                                            (Step 10c peer_actors)

Result mapping at dispatch/3:
  2xx           -> ok                    (worker drops the entry)
  non-2xx       -> {error, {status, N}}  (worker bumps attempt)
  resolver miss -> {error, no_peer_url}
  transport     -> {error, Reason}       (BIF re-raises, caught here)

httpc:request/4 BIF wrapper updated to catch host Eval_error via
SX `guard` and re-raise as Erlang `error:{network, ReasonBinary}`
so callers can handle it through standard try/catch — previously
the host exception bubbled past the Erlang try/catch surface
(which only handles er-thrown? / er-errored? / er-exited? markers).

Subtle Erlang-port note documented in dispatch/3: this port's
try/catch requires a literal class atom (`error:Reason`); the
generic `Class:Reason` syntax is not supported. dispatch_http
catches `error:Reason` only, which is what the BIF re-raise
produces.

Test: next/tests/dispatch_http.sh 10/10 against background
python3 http.server (always-200 handler):
  - module loads
  - inbox_url builds /actors/X/inbox
  - static :peer_url map resolves
  - missing peer -> {error, no_peer_url}
  - live POST -> 200 -> ok
  - closure path -> ok
  - closure on missing peer -> {error, no_peer_url}
  - closed port -> {error, _}
  - delivery_worker drains the queue via the live closure
  - :peer_url_fn closure path resolves

No-regression gates green: Erlang conformance 761/761,
httpc_request 10/10, http_listen_bif 5/5, delivery_worker 17/17,
delivery_retry 11/11, delivery_dispatch 7/7.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
 2026-06-07 11:20:53 +00:00
giles
bd2c61367d fed-sx-m2: Step 8e — httpc:request/4 BIF wrapper (+ 10 tests)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 37s
Details 
Closes the BIF half of Step 8. Native http-request primitive landed
in architecture via the fed-prims merge (the m2 plan's Blocker #2),
so the briefing-allowed-exception wrapper in lib/erlang/runtime.sx
can finally be wired.

Marshalling at the BIF boundary:
  Url     : Erlang binary -> SX string (byte-list -> integer->char).
  Method  : Erlang atom upcased ('get -> "GET") for HTTP-wire
            convention, or Erlang binary passes through verbatim.
  Headers : Erlang proplist -> SX dict via er-proplist-to-dict.
  Body    : Erlang binary -> SX string.

Result {:status :headers :body} marshalled back to Erlang
  {ok, Status::integer,
       Headers::proplist (binary-keyed via er-of-sx-deep),
       Body::binary (char->integer over the SX string)}.

Bad arg shapes (non-binary URL or body) raise error:badarg; native
DNS / connect / bad-URL failures surface as Erlang error markers
that the caller can catch.

Test: next/tests/httpc_request.sh 10/10
  - registration under httpc/request/4
  - BIF marked non-pure
  - wrong-arity (/1) absent from registry
  - badarg on non-binary URL
  - badarg on non-binary body
  - live GET against `python3 -m http.server` -> Status 200
  - body bytes match "hello from python\n"
  - headers come back as proplist (is_list/1 = true)
  - 404 path -> {ok, 404, ...} (not an error tuple)
  - method passed as binary works

URLs spelled out as byte-list <<104,116,116,p,...>> binaries since
the parser truncates <<"..."> string-literal binaries (same
workaround backfill_drain.sh uses for inbox paths).

Plan: 8e ticked; Blocker #2 marked RESOLVED with the merge that
unblocked it referenced. Step 8f (live HTTP dispatch through
delivery_worker) and Step 10c (peer-actor doc fetch) are now
unblocked.

No-regression gates green: Erlang conformance 761/761,
http_multi_actor 44/44, follower_graph 18/18, follow_lifecycle 9/9,
backfill 20/20, backfill_drain 6/6, http_listen_bif 5/5.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
 2026-06-07 10:44:25 +00:00
giles
070986913d fed-sx-m2: Step 9c — auto-Accept backfill drain + 6 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 50s
Details 
maybe_auto_accept/3 in http_server.erl now calls maybe_backfill/3
after the Accept publish. Flow:

  inbound Follow{actor: bob, object: alice, backfill: SPEC} lands
    -> pipeline ok -> append_inbox + broadcast (Step 6b)
    -> maybe_auto_accept fires (Step 6c)
       -> publish Accept{actor: alice, object: Follow} (Step 6c)
       -> maybe_backfill (Step 9c)
          -> backfill_enabled cfg gate
          -> :backfill present on Follow
          -> backfill:parse_mode -> Mode
          -> nx_kernel:log_state_for(alice) -> LogState
          -> backfill:slice(Mode, LogState, true) -> [Wrapped]
          -> deliver_backfill(bob, Slice):
               whereis(bob) cfg gate (peer worker registered)
               -> delivery_worker:enqueue(bob, A) for each

Cfg surface:
  {backfill_enabled, true}     gate the drain (default off)
  {auto_accept_follows, true}  Step 6c gate (required)

Each backfilled entry carries {backfilled, true} (per design §13.3,
:id preserved so the receiver's replay defence still catches the
forward-going copy).

6/6 in next/tests/backfill_drain.sh:
  - Follow with {backfill, {last_n, 2}} + 3 pre-published notes
    -> bob's delivery_worker has exactly 2 pending entries
  - Each entry carries {backfilled, true}
  - :backfill_enabled absent -> no drain (back-compat)
  - Follow without :backfill field -> no drain
  - Missing peer worker (no whereis) -> silently skipped + 202

Step 9 fully closed (9a slicing + 9b ?since route + 9c
Accept-drain). The live HTTP dispatch of the queued entries
still gates on Blockers #2 (httpc).
 2026-06-07 07:01:55 +00:00
giles
3629b2923f fed-sx-m2: Step 9b — outbox ?since=Cid pagination + 3 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 19s
Details 
actor_outbox_response_for/3 in http_server.erl now reads ?since=
from the query string before paging:

  Q       = field(request_query, Cfg),
  Filtered = case parse_since(Q) of
      nil      -> Entries;
      SinceCid -> backfill:since_cid_entries(SinceCid, Entries)
  end,
  Slice = page_slice(Filtered, Page),
  ...

New helpers:
  parse_since/1   — scan query for since=<Cid>, value is the
                    binary up to next & or end-of-binary. nil
                    when absent.
  scan_param/2,3  — generic 'find Name=Value anywhere in &-sep
                    query'. Used for since= today; could be
                    factored over parse_page=.
  skip_to_amp/1   — walk past the next & for the iteration step.

Order-independent: ?since=X&page=2 and ?page=2&since=X both
work. Unknown cid -> backfill:since_cid_entries returns []
-> empty page -> body degrades to tip-only shape (Step 4d
back-compat).

Three new cases in http_multi_actor.sh (44/44 total):
  - ?since=<first cid> filters out the first publish, leaving
    2 of 3 items in the paged response
  - ?since=<unknown cid> -> empty page; body has tip but no
    item: lines (tip-only degrade)
  - ?since=<cid> + ?page=1 combined — pagination still applies
    to the filtered list

Latent issue surfaced + fixed in passing: http_multi_actor.sh
was missing follower_graph + delivery + backfill module loads
(outbox has depended on follower_graph + delivery since Step 7c
and now backfill from 9a). Added all three with epoch 100/101/
102 to match the c6b49200 fix-up pattern. 41 existing tests now
also exercise the live path through outbox:publish without
crashing on missing module deps.
 2026-06-07 06:28:47 +00:00
giles
9621599606 fed-sx-m2: Step 9a — pure-functional backfill slicing + 20 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 49s
Details 
New next/kernel/backfill.erl owns the §13.3 backfill mode
slicing. Given an outbox log + a mode, returns the activity
list to send to a new follower as backfill.

Public API:
  slice/2(Mode, LogState)               default Wrap=false
  slice/3(Mode, LogState, Wrap)         Wrap=true wraps entries
  wrap_backfill/1                       add {backfilled, true}
  parse_mode/1                          lift Follow :backfill field

Modes:
  none                       new follower: forward-only content
  full                       entire outbox
  {last_n, N}                last N activities (FIFO)
  {last_t, T, NowFn}         entries with :published in
                             (NowFn()-T .. NowFn()]
  {since_cid, Cid}           entries after the one with :id = Cid
                             (consumes the matched entry; returns
                             every entry after it)

wrap_backfill/1 marks each entry {backfilled, true}. Per §13.3
wrapped bodies preserve :id so the receiver's replay defence
still catches duplicates from the live stream.

parse_mode/1 accepts:
  nil / none / full / {last_n, _} / {last_t, _, _} /
  {since_cid, _} — pass through or normalize
  Proplist with :mode + :limit -> {last_n, N}
  Proplist with :mode + :duration -> {last_t, T, fun() -> 0 end}
  Proplist with :mode = full -> full
  Anything else -> none (open-world default)

Substrate gotchas re-confirmed and worked around:
  - lists:nthtail/2 not registered — rolled drop_n/2
  - Pattern-alias 'Pat = Var' not supported by this port's
    parser — parse_mode/1 clauses use explicit deconstruction

20/20 in next/tests/backfill.sh covering all five modes plus
edge cases (N=0, N>length, T=0 -> empty window, since_cid
hit/miss/unknown), wrap_backfill semantics, parse_mode for
atoms / tuple shapes / proplists / unknown / nil.

Step 9b (outbox listing ?since=Cid&limit=N pagination) and
Step 9c (Follow-Accept-backfill wiring) layer on top.
Conformance preserved at 761/761.
 2026-06-07 05:39:46 +00:00
giles
b2b61a0112 fed-sx-m2: Step 11b — Announce + Endorse projection folds + 19 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 20s
Details 
Two new projection modules for the rich verbs landed in Step 11a:

  next/kernel/announce_state.erl
    Per-target-Cid announcer set.
    State: [{TargetCid, [AnnouncerActorId, ...]}, ...]
    Set semantics — duplicate Announce by the same actor on the
    same target is a no-op.

    Public API:
      new/0, fold/2, fold_fn/0
      announcers_for/2, announce_count/2, announced_cids/1
      has_announced/3

  next/kernel/endorsement_state.erl
    Per-target-Cid + per-kind + per-actor endorsement counter.
    State: [{TargetCid, [{Kind, [{ActorId, Count}, ...]}, ...]}, ...]
    Additive semantics — re-endorse by the same actor under the
    same kind bumps the counter. Undo{Endorse} retraction defers
    to a follow-up.

    Public API:
      new/0, fold/2, fold_fn/0
      counters_for/2, total_for/2, kinds_for/2
      endorsers_for/3, has_endorsed/4

Both fold_fn/0 returns a 2-arity Erlang fun for
projection:start_link/3 (same plug shape as actor_state /
follower_graph / delivery_state). Non-matching activity types
pass through unchanged.

Read-side accessors cover both enumeration (announcers_for,
endorsers_for) and predicates (has_announced, has_endorsed) so
the feed/timeline projection layer doesn't have to re-implement
that logic on every consumer.

19/19 in next/tests/rich_verbs.sh:

  announce_state:
    - new/0 -> []
    - Announce -> announcer added
    - Two announces same target -> both in set
    - Duplicate announce by same actor -> no-op
    - announce_count + announced_cids
    - has_announced predicate
    - fold_fn/0 is fun/2
    - Non-Announce activity passes through

  endorsement_state:
    - new/0 -> []
    - Endorse -> counter 1
    - Two likes by different actors -> total 2
    - like + share -> two kinds tracked
    - endorsers_for(Cid, Kind)
    - has_endorsed predicate
    - fold_fn/0 is fun/2
    - Non-Endorse activity passes through
    - Same actor endorsing twice -> total = 2 (additive)

Conformance preserved at 761/761.
 2026-06-07 05:06:27 +00:00
giles
80f6fc9279 fed-sx-m2: Step 11a — Announce + Endorse genesis activity-types + 4 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 35s
Details 
Two new DefineActivity SX files in next/genesis/activity-types/
per design §13.5 / Step 11:

  announce.sx — Re-broadcast a peer's activity to followers.
    :object is the CID of the activity being announced.
    :schema requires :object to be a string.
    Followers see the Announce in their inbox; their projection
    decides whether to fetch the wrapped activity body.

  endorse.sx — Cross-actor signal on a target activity.
    :object is the target activity's CID; :kind is the
    endorsement variant (e.g. 'like', 'share').
    :schema requires both :object and :kind to be strings.
    Projections aggregate endorsements into counters / heat /
    ranking signals.

M1's Note object-type is unchanged — Create{Note{...}} is still
the publish path for short authored messages. The runtime-publish
demo (verb extensibility via Create{DefineActivity{...}} at
runtime) from M1 §9a continues to work; these files are the
genesis pre-shipped variants for v2 baseline so peers don't have
to negotiate verb definitions on first contact.

Manifest extended:
  :activity-types  3 -> 5 entries
  total genesis    34 -> 36 entries

Hardcoded count assertions bumped in:
  bootstrap_read.sh  (activity_types 3->5, first-section-count 3->5)
  bootstrap_load.sh  (activity_types 3->5)
  bootstrap_populate.sh (total 34->36, activity_types 3->5)
  bootstrap_start.sh (activity_types 3->5, total 34->36)

genesis_parse.sh +4 cases (head form + name for both files).
bootstrap_populate.sh internal sx_server timeout bumped
300s -> 600s to fit the larger genesis bundle.

61/61 in genesis_parse.sh, 15/15 in bootstrap_read.sh,
15/15 in bootstrap_load.sh, 14/14 in bootstrap_populate.sh,
12/12 in bootstrap_build.sh.
 2026-06-07 04:38:32 +00:00
giles
aa27d903ac fed-sx-m2: Step 10b — webfinger HTTP route + 10 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 35s
Details 
GET /.well-known/webfinger?resource=acct:user@host lands in
http_server.erl next to the existing /.well-known/sx-capabilities
arm.

Dispatch chain:
  route/2 -> dispatch/4 (matches webfinger path) -> handle_webfinger/1
  -> webfinger_for_query/2
  -> parse_resource_param/1 (matches "resource=" + collect via
                              take_until_amp/1)
  -> discovery:parse_acct/1
  -> webfinger_lookup/3 — host check + kernel actor lookup
     -> 200 + discovery:webfinger_body/3 (application/activity+json)
     -> 404 on any miss

Cfg surface:
  {webfinger_host, Binary}   optional; when set the acct's @host
                             must match exactly. Missing -> any.
  {kernel, Atom}             optional; when set, the user must be
                             a known actor in the registered kernel.
                             Missing -> every user is 'known' (pure
                             route tests).

route/2 already threads the Req's :query into Cfg as
:request_query (Step 4d), so the handler doesn't need to take
the Req directly.

10/10 in next/tests/webfinger_route.sh:
  - GET happy path (no kernel cfg'd) -> 200
  - body has subject prefix
  - body has href substring
  - missing ?resource= -> 404
  - garbage 'resource=garbage' -> 404
  - kernel cfg: alice 200, ghost 404
  - :webfinger_host matches @host -> 200
  - :webfinger_host mismatch -> 404
  - POST -> 404 (only GET handled)

discovery.sh 12/12 unchanged, http_route.sh 11/11 unchanged.
 2026-06-07 03:48:55 +00:00
giles
ff024d1b5d fed-sx-m2: Step 10a — discovery primitives + 12 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 45s
Details 
New next/kernel/discovery.erl with the local-side webfinger
primitives per design §13.7:

  parse_acct/1(Bin) -> {ok, User, Host} | {error, _}
    Accepts <<acct:user@host>> (with prefix) or <<user@host>>
    (bare). Host preserves an optional :port suffix. Rejects
    empty user/host and missing @.

  parse_resource/1   alias for the webfinger ?resource= shape

  actor_url_for/2(User, Host)
    Synthesises <<http://<host>/actors/<user>>>. TLS / https
    is v3, gated on a TLS substrate Blocker.

  webfinger_body/3(User, Host, ActorUrl)
    Builds the RFC 7033 JSON body:
      {"subject":"acct:<user>@<host>",
       "links":[{"rel":"self",
                 "type":"application/activity+json",
                 "href":"<actor_url>"}]}
    Hand-rolled byte concatenation — no JSON BIF on this port.

Substrate gotcha re-confirmed: <<"acct:">> string literals
truncate to one byte on this port. "acct:" is spelled as
<<97,99,99,116,58>> in the implementation.

12/12 in next/tests/discovery.sh covering:
  - parse_acct prefixed + bare forms
  - host with :port preserved
  - reject empty user / missing @ / empty host
  - parse_resource alias
  - actor_url_for synthesis + port preservation
  - webfinger_body prefix shape + byte_size sanity

Step 10b (http_server route GET /.well-known/webfinger) and
Step 10c (peer-actor fetch via Step 5's lookup_or_fetch slot)
layer on top. 10c gates on Blockers #2 (native http-request
primitive missing).
 2026-06-07 03:11:03 +00:00
giles
8ba3584556 fed-sx-m2: Step 8c — delivery-state projection + 14 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 45s
Details 
New next/kernel/delivery_state.erl folds delivery events into a
per-peer worker-shaped snapshot so the outbound queue survives
kernel restart.

Event proplist shapes:
  [{type, enqueued},      {peer, _}, {activity, _}]
  [{type, delivered},     {peer, _}, {cid, _}]
  [{type, failed},        {peer, _}, {cid, _}, {now, _}]
  [{type, dead_lettered}, {peer, _}, {cid, _}]

Projection state shape:
  [{PeerId, [{peer, _}, {pending, _}, {attempts, _},
             {next_retry, _}, {dead_letter, _}]}, ...]

Mirrors delivery_worker:new/1 (minus :dispatch_fn — that's the
live worker's concern) so a fresh gen_server can be hydrated
from the projection on restart.

Public API:
  new/0
  fold/2, fold_fn/0
  peer_state/2, peers/1
  pending/2, attempts/2, next_retry/2, dead_letter/2

The failed branch calls delivery_worker:backoff_for/1 directly,
so the projection and the live worker compute identical retry
slots and dead-letter thresholds. 6th failure -> dead-letter,
matching the worker.

14/14 in next/tests/delivery_state.sh covering:
  - new/0 -> []
  - enqueued appends to pending (FIFO)
  - two peers maintain independent queues
  - delivered clears matching pending entry
  - failed bumps :attempts and sets :next_retry
  - 6th failed -> dead-lettered (activity out of pending)
  - explicit dead_lettered event moves activity to dead_letter
  - peers/1 lists touched peers
  - peer_state {ok, _} | not_found
  - fold_fn/0 is fun/2 for projection:start_link
  - unknown event type passes through
  - delivered after failed clears retry state

delivery_worker.sh 17/17 unchanged, delivery_retry.sh 11/11
unchanged. Conformance preserved at 761/761.

The restart hydration helper (delivery_worker:state_from_proj/2
or similar) lands once 8b-timer can wire the live retry loop
(Blockers #3 — erlang:send_after substrate gap still open).
 2026-06-07 02:37:53 +00:00
giles
8bf2b45cf9 fed-sx-m2: Step 8b-pure — retry-time bookkeeping + 11 tests + 2 Blockers
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 18s
Details 
delivery_worker state shape gains :next_retry proplist alongside
the existing :attempts:

  [{peer, _}, {pending, _}, {attempts, [{Cid, N}]},
   {next_retry, [{Cid, NextRetryAt}]}, {dead_letter, _},
   {dispatch_fn, _}]

New pure-functional exports:
  record_failure_pure/3(Cid, Now, State)
      Bumps :attempts for Cid. On the 6th failure
      (backoff_for returns dead_letter) moves the matching
      activity from :pending to :dead_letter and clears the
      :next_retry entry. Otherwise sets next_retry to
      Now + backoff_for(NewAttempts).
  record_success_pure/2(Cid, State)
      Clears both :attempts and :next_retry for Cid.
  next_due_pure/2(Now, State)
      Returns cids whose retry time has passed (insertion
      order preserved so the worker drains in FIFO retry
      order).
  attempts_for/2, next_retry_at/2, dead_letter_list/1
      Read-side accessors.

Internal helper move_to_dead_letter/2 + take_by_cid/4 walks
:pending to find the matching activity by cid.

11/11 in next/tests/delivery_retry.sh covering:
  - fresh state: 0 attempts / undefined retry / [] dead_letter
  - record_failure bumps to 1
  - record_failure sets next_retry_at = Now + 30 (slot 1)
  - second failure: attempts=2, NextRetryAt = Now + 300 (slot 2)
  - record_success clears both
  - next_due returns due cids
  - next_due empty before due
  - 6th failure -> dead-letter; activity out of :pending
  - dead-lettered cid removed from :next_retry
  - per-cid isolation: success on one doesn't disturb another

delivery_worker.sh 17/17 unchanged (new exports are additive).

Blockers added:
  #2 — Native http-request primitive missing in bin/sx_server.ml
       (briefing assumed it existed; only http-listen exists).
       Belongs to loops/fed-prims. Step 8e wrapper waits for
       the native.
  #3 — erlang:send_after-style timer primitive missing. Needed
       for the real retry loop. Belongs to loops/erlang. 8b-pure
       captures the semantics so 8b-timer is a 1-shot wiring
       when the primitive lands.

Conformance preserved at 761/761.
 2026-06-07 02:04:23 +00:00
giles
dda967e060 fed-sx-m2: Step 8d — outbox dispatches delivery_set to workers + 7 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 32s
Details 
outbox:publish/2 now walks the computed delivery_set and enqueues
the signed activity onto each matching delivery_worker
(registered under the peer-id atom). Missing workers are silently
skipped — lazy worker creation belongs to the kernel manager
later in Step 8.

Gated by Context's {dispatch_deliveries, true} so every M1
outbox caller (and every M2 caller that doesn't yet care about
delivery) stays back-compat: default off.

New helpers in outbox.erl:
  dispatch_deliveries/3(Activity, DeliverySet, Context)
      gates on Context :dispatch_deliveries flag
  enqueue_each/2(Activity, [PeerId | _])
      whereis-guarded enqueue per peer

7/7 in next/tests/delivery_dispatch.sh:
  - single peer enqueued
  - two peers both enqueued (fan-out)
  - missing worker silently skipped
  - no :dispatch_deliveries flag -> no-op (back-compat)
  - two publishes -> FIFO append on the queue
  - empty delivery_set -> no-op

outbox_publish.sh 17/17 unchanged; delivery_worker.sh 17/17
unchanged. Conformance preserved at 761/761 from the Step 8a
baseline.
 2026-06-07 01:32:59 +00:00
giles
bf4e034c4e fed-sx-m2: Step 8a — delivery_worker skeleton + 17 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 55s
Details 
next/kernel/delivery_worker.erl is the gen_server-per-peer
delivery queue per design §13.4. Step 8a lands the skeleton:
pure-functional state shape + enqueue / drain / deliver_one
helpers + backoff schedule + gen_server wrapper. No retry
timer wiring yet (Step 8b), no persist projection yet (8c),
no outbox dispatch wiring yet (8d), no httpc BIF yet (8e), no
live HTTP yet (8f).

State shape (pure):
  [{peer, PeerId},
   {pending, [Activity, ...]},          %% FIFO queue
   {attempts, [{Cid, AttemptCount}]},   %% per-cid retry count
   {dead_letter, [Activity, ...]},
   {dispatch_fn, fun/1 | undefined}]

Pure-functional API:
  new/1
  pending/1, peer/1
  enqueue_pure/3       — append to FIFO
  drain_pure/1         — attempt every queued; returns
                         {NewState, DeliveredCids, RetryCids}
  deliver_one_pure/2   — single dispatch via :dispatch_fn

Backoff schedule (§13.4): 30s / 5m / 30m / 6h / 24h then dead_letter
  backoff_for/1   — attempt -> seconds | dead_letter
  schedule_for/1  — attempt -> {retry_in, Sec} | dead_letter

gen_server (registered under peer-id atom):
  start_link/1, start_link/2(PeerId, DispatchFn)
  stop/1
  enqueue/2     — sync call
  flush/1       — drain + reply with {ok, Delivered, Retry}
  pending_srv/1
  set_dispatch_fn/2  — swap dispatch in flight

dispatch_fn is a caller-supplied 1-arity fun so tests can stub the
HTTP POST. Step 8f will plug in a closure over httpc:request/4
without touching the queue logic.

17/17 in next/tests/delivery_worker.sh covering:
  - new/peer/pending base cases
  - enqueue_pure FIFO append
  - drain_pure no-dispatch -> retry, queue intact
  - drain_pure ok dispatch -> queue empties + delivered list
  - drain_pure failing dispatch -> queue intact + retry list
  - deliver_one_pure {ok, Cid} and {error, _, no_dispatch_fn}
  - backoff_for slot values match §13.4
  - backoff_for >=6 returns dead_letter
  - schedule_for wraps the slot or dead_letter
  - gen_server start_link + enqueue + pending_srv
  - gen_server flush with ok dispatch (delivered)
  - gen_server flush with failing dispatch (queue kept)
  - gen_server set_dispatch_fn in-flight swap

Conformance 761/761.
 2026-06-07 01:01:17 +00:00
giles
c6b4920074 fed-sx-m2: add follower_graph + delivery loads to 4 downstream tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 31s
Details 
Step 7c made outbox depend on follower_graph + delivery, breaking
four tests that didn't load those modules. Background gate
revealed the failures after 7c had already been pushed.

Loads added:
  auto_accept.sh        — epoch 12: delivery (follower_graph
                          was already loaded at epoch 10)
  nx_kernel_multi.sh    — epochs 5+6: follower_graph + delivery
                          (existing modules shifted: outbox 5->7,
                          nx_kernel 6->8). Check 6 -> check 8.
  http_publish.sh       — epochs 100+101: follower_graph + delivery
                          (high epoch numbers to avoid collision
                          with test epochs at 10+)
  http_publish_fold.sh  — epochs 100+101: same pattern

All four green at 9/9, 26/26, 10/10, 10/10. No behaviour change
in outbox or downstream code; pure test-setup follow-up to 7c.

Conformance 761/761 (confirmed post-7c).
 2026-06-07 00:55:20 +00:00
giles
536473cd68 fed-sx-m2: Step 7c — outbox delivery_set integration + 4 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 12m51s
Details 
outbox:publish/2 now computes the audience-resolved delivery set
after sign + log and stashes it in the Result proplist as
{delivery_set, [ActorId, ...]}. Step 8's delivery-queue worker
reads it off the publish result.

New compute_delivery_set/3(Request, Signed, Context):
  - Pulls :follower_graph from Context (defaults to empty graph)
  - Calls recipients_envelope/2 to synthesise a minimal envelope
    from Request's :to / :cc + Signed's :actor
  - Routes through delivery:delivery_set/3 unchanged

The envelope construct/4 surface doesn't carry :to / :cc (only
type / actor / published / object), and changing that ripples
through every envelope shape test. recipients_envelope/2 keeps
the compute boundary local to outbox.

4 new cases in outbox_publish.sh (17/17 total):
  - Result :delivery_set empty default
  - explicit :to -> [bob] in set
  - followers symbol expands via Context :follower_graph
  - self-suppression (alice in :to drops to []bob])

Module loads rebumped: follower_graph + delivery added as
dependencies; outbox shifts from epoch 5 to epoch 7. Internal
sx_server timeout bumped 240s -> 480s to fit the larger module
set.

Step 7 fully closed (7a delivery module + 7b public expansion
+ 7c outbox integration). Federation now has the end-to-end
audience resolution: an outbound activity's :to / :cc plus any
follower_graph expansion becomes a deduped recipient list ready
for Step 8 to dispatch.

Conformance running + adjacent gate running.
 2026-06-07 00:27:55 +00:00
giles
02c1f0f979 fed-sx-m2: Step 7b — public audience expansion + 3 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 41s
Details 
delivery:expand_audience(public, Sender, Graph) now returns the
sender's followers (same as the followers symbol). Per design
§13.4 the practical Public fan-out semantics for an open social
network is 'every follower of the publishing actor'. The
explicit shared-inbox peer-instance model (Mastodon-style
per-instance broadcast) defers to v3 when there's a real
known-peer-instance registry to drive it.

19/19 in delivery_set.sh:
  - public symbol now expands to sender's followers (epoch 19,
    updated from v2 placeholder)
  - public with empty follower-graph -> [] (epoch 28)
  - public + followers in same audience dedupe (epoch 29)

Conformance 761/761.
 2026-06-06 23:39:00 +00:00
giles
086c576d48 fed-sx-m2: Step 7a — delivery:delivery_set/2,3 + 17 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 44s
Details 
New next/kernel/delivery.erl computes the audience-resolved
deduplicated recipient list for an outbound activity.

delivery_set/2(Activity, KernelState)
delivery_set/3(Activity, KernelState, FollowerGraph)
  Returns a deduplicated list of ActorId atoms. Step 8 will
  resolve each entry to {PeerInstanceUrl, ActorId} via the
  peer-actors cache.

Sources unioned then deduped:
  - :to field   (single ActorId or list, atoms or audience symbols)
  - :cc field   (same shape)
  - audience-symbol expansion:
      followers -> sender's followers from follower_graph
      public    -> [] for v2 (Step 7b layers known-peer-instance set)

Self-delivery suppressed every time the sender's ActorId appears
in the set.

Module lives in its own file (not inside outbox.erl) so Step 8's
delivery-queue gen_server has a clean home alongside it.

17/17 in next/tests/delivery_set.sh covering:
  - empty activity -> []
  - single :to atom + list :to recipients
  - :to + :cc unioned
  - self-suppression
  - duplicate / cross-field dedup
  - followers symbol expands via follower_graph state
  - empty follower-graph -> []
  - public v2 placeholder -> []
  - mixed explicit + followers
  - collect_recipients raw flat
  - suppress_self drops every match
  - dedup preserves first-occurrence order
  - expand_audience pass-through for plain ActorId

Conformance 761/761. 86/86 across 6 Step-7-adjacent suites
(follower_graph, follow_lifecycle, auto_accept, inbox,
nx_kernel_multi, outbox_publish).
 2026-06-06 23:34:18 +00:00
giles
ee8a396ccd fed-sx-m2: Step 6c — auto-Accept on Follow ingestion + 9 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 37s
Details 
Per design §13.2 the v2 Follow policy is open-world: every
successfully-ingested Follow triggers an Accept publish from the
target actor. Enabled per-Cfg via {auto_accept_follows, true} so
manual-moderation deployments can leave it off; default off.

http_server.erl run_inbox_pipeline gained maybe_auto_accept/3:

  maybe_auto_accept(TargetAtom, Activity, Cfg) ->
      case field(auto_accept_follows, Cfg) of
          true ->
              case envelope:get_field(type, Activity) of
                  {ok, follow} ->
                      Req = [{type, accept}, {object, Activity}],
                      nx_kernel:publish_to(TargetAtom, Req);
                  _ -> ok
              end;
          _ -> ok
      end.

The publish routes through the full outbox pipeline (envelope
construct + HMAC sign + log append + outbox projection broadcast).
When the target's outbox :projections list shares the same
follower_graph projection that inbox broadcasts into, the bilateral
relationship fold-converges automatically — alice.followers = [bob]
and bob.following = [alice], both pending lists clear. No extra
test scaffolding needed because outbox:publish already runs the
broadcast hook from Step 7c.

Bad-sig and non-Follow ingestion short-circuit before the Accept
attempt (the validation pipeline rejects before run_inbox_pipeline's
ok branch fires).

9/9 in next/tests/auto_accept.sh:
  - auto_accept on: alice's outbox tip advances to 1
  - alice's outbox entry has :type = accept
  - follower_graph converges to {alice.followers=[bob],
    bob.following=[alice]}
  - both sides' pending lists clear after the Accept fold
  - auto_accept off (default): outbox stays empty; pending_inbound
    still gets populated from the Step 6b inbox-projection path,
    but alice.followers stays empty until human moderation acts
  - non-Follow ingestion (Create{Note}) with auto_accept on: no
    Accept published
  - bad-sig Follow with auto_accept on: no Accept (sig short-circuit
    in pipeline before maybe_auto_accept runs)

Step 6 fully closed (6a follower_graph projection, 6b inbox -> projection
broadcast wiring, 6c auto-Accept publish).

Conformance 761/761. 89/89 across 7 Step-6-adjacent suites
(inbox, inbox_peer_resolution, follower_graph, follow_lifecycle,
auto_accept, http_publish, nx_kernel_multi).
 2026-06-06 22:46:52 +00:00
giles
1d83120918 fed-sx-m2: Step 6b — wire follower_graph fold to inbox handler
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 35s
Details 
http_server.erl run_inbox_pipeline now calls
broadcast_to_inbox_projections/2 after a successful
nx_kernel:append_inbox. Cfg may carry {inbox_projections,
[Name, ...]} listing projection gen_servers that should see every
successfully-ingested inbound activity. Each gets the activity via
projection:async_fold/2 — fire-and-forget so the inbox handler
doesn't block on fold processing. Empty / absent
:inbox_projections is a no-op (back-compat with Step 5d callers).

v2 leaves the routing field global (every inbound activity goes
to every named projection); per-actor projection wiring is a
forward-looking follow-up.

9/9 in next/tests/follow_lifecycle.sh:
  - Follow ingestion -> 202
  - follower_graph state: alice.pending_inbound = [bob]
  - follower_graph state: bob.pending_outbound = [alice]
  - inbox tip advances to 1 (Step 5a invariant preserved)
  - no inbox_projections Cfg -> projection state stays empty
  - end-to-end: Follow + Accept fold converges to
    alice.followers = [bob] and bob.following = [alice]
    (Accept fed via projection:async_fold for v2 — auto-Accept
    publish is Step 6c)
  - bad-sig inbound short-circuits before broadcast
  - two distinct peer Follows accumulate

bootstrap_start.sh internal sx_server timeout bumped 300s -> 600s
to match the cumulative cost trend other tests are seeing on this
port. (bootstrap_start doesn't load http_server but loads bootstrap
+ the full genesis bundle + 9 kernel modules — same cumulative
compile budget.)

Conformance 761/761.
 2026-06-06 21:59:43 +00:00
giles
e890380a1a fed-sx-m2: Step 6a — follower_graph projection + 18 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 42s
Details 
New next/kernel/follower_graph.erl is the Erlang-fun stand-in for
the genesis follower-graph.sx projection body, mirroring the
shape of actor_state.erl and define_registry.erl.

State shape (substrate has no maps, so a proplist):
  [{ActorId, [{following,        [PeerId, ...]},
              {followers,        [PeerId, ...]},
              {pending_outbound, [PeerId, ...]},
              {pending_inbound,  [PeerId, ...]}]}, ...]

Fold rules per design §13.2:
  Follow{actor: A, object: B}
      add B to A.pending_outbound
      add A to B.pending_inbound
  Accept{actor: B, object: Follow{A->B}}
      A moves from B.pending_inbound -> B.followers
      B moves from A.pending_outbound -> A.following
  Reject{actor: B, object: Follow{A->B}}
      clear A from B.pending_inbound, B from A.pending_outbound
  Undo{actor: A, object: Follow{A->B}}
      drop A<->B from every list on either side
      only the Follow's original actor may Undo it

Edge cases handled:
  - self-follow (alice -> alice) is a no-op
  - duplicate Follow is idempotent (list sets)
  - Accept/Reject/Undo whose :object isn't a Follow proplist
    passes through
  - Undo by the wrong actor (carol Undoing Follow{alice->bob})
    is a no-op

Public API:
  new/0, lookup/2, actors/1
  following/2, followers/2,
  pending_outbound/2, pending_inbound/2
  is_following/3, has_follower/3,
  is_pending_outbound/3, is_pending_inbound/3
  fold/2, fold_fn/0

fold_fn/0 returns the standard 2-arity Erlang fun for
projection:start_link/3 (same plug shape as actor_state and
define_registry).

Local find_keyed/set_keyed/contains/remove_member helpers — no
lists:keyfind/keymember/member in this substrate (same gap as
Step 1a/2b/5a/5c).

18/18 in next/tests/follower_graph.sh covering all four verbs,
predicates, edge cases (self-follow, duplicate Follow, untyped
activity, non-Follow :object, wrong-actor Undo).

Step 6b wires this into the inbox handler so a peer Follow lands,
fires auto-Accept publish (open-world policy per §13.2; manual
moderation deferred to v3).

Conformance 761/761. 130/130 across 9 Step-6-adjacent suites
(inbox, inbox_bucket, inbox_pipeline, inbox_peer_resolution,
actor_state_pure, define_registry_pure, projection_pure,
nx_kernel_multi, smoke_app_pure).
 2026-06-06 20:47:01 +00:00
giles
6231a82be0 fed-sx-m2: bump http_publish/post_format/multi_actor sx_server timeout
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 35s
Details 
Step 5d added ~150 lines to http_server.erl bringing it to ~1180
lines. erlang-load-module on this port scales superlinearly with
function count, so three more http_*.sh tests' internal sx_server
timeout (M1 default 240s) was no longer enough.

Bumped to 600s — matches the headroom the other eight http_*.sh
tests got in the Step 5d commit. Background-gate verification
flagged these three (no behaviour change; just budget).

http_publish 10/10, http_post_format 13/13, http_multi_actor 41/41
all green at 600s.
 2026-06-06 19:55:03 +00:00
giles
d36fe4ee97 fed-sx-m2: Step 5d — inbox handler wires the ingestion chain
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 38s
Details 
POST /actors/<id>/inbox is now special-cased in route/2 (next to
POST /activity) so the body + Cfg reach the new handle_inbox_post/3
handler.

Wire format: body = term_codec:encode(SignedActivity); the receiver
decodes into the activity proplist and runs the chain.

handle_inbox_post/3 orchestration:
  1. kernel_has_actor(field(kernel, Cfg), TargetId)  -> 404 if missing
  2. decode_activity(Body)                           -> 422 on bad shape
  3. envelope:get_field(actor, Activity)             -> 422 if no peer id
  4. resolve_peer_as(PeerId, Cfg)                    -> 401 if unknown
  5. nx_kernel:inbox_state_for(TargetAtom)           -> 404 belt-and-braces
  6. pipeline:validate_inbound(Activity, PeerAS, InboxLog)
       ok                     -> nx_kernel:append_inbox + 202
       {error, bad_signature} -> 401
       {error, no_signature}  -> 401
       {error, _}             -> 422

resolve_peer_as/2 supports three Cfg paths in priority order:
  {peer_as,        [{PeerId, AS}, ...]}   pure-fn pre-populated map
  {peer_actors,    AtomName}              peer_actors gen_server cache
  {peer_fetch_fn,  fun/1}                 fallback on srv cache miss
Empty Cfg returns {error, no_peer_resolver} -> 401.

v1 actor_post/1 4a stub deleted; M1 actor_inbox_post_response/0
kept for response composition.

Projection broadcast on inbox success intentionally deferred to a
follow-up sub-deliverable.

inbox.sh 11/11 (acceptance suite for the basic chain):
  - happy path -> 202
  - inbox tip advances; outbox tip unchanged (per-actor bucket
    independence carried through from Step 5a)
  - empty / garbage body -> 422
  - unknown peer -> 401
  - bad peer-AS keys -> 401
  - replay (same activity twice) -> 422 on second
  - unknown target actor -> 404
  - two distinct activities -> tip = 2

inbox_peer_resolution.sh 6/6 (Cfg resolution variants):
  - peer_actors gen_server hit -> 202
  - FetchFn fallback -> 202
  - FetchFn error -> 401
  - FetchFn caches into peer_actors (peers_srv shows [bob] after)
  - No resolver -> 401

Tests split into two files because each epoch's kernel start_link
+ outbox construct + term_codec encode is expensive and a single
suite hits the wall-clock budget.

http_server.erl is now 1181 lines. erlang-load-module on this port
scales superlinearly with function count, so eight http_*.sh tests'
internal sx_server timeout bumped 60s -> 360s (http_route,
http_actors, http_accept, http_capabilities, http_capabilities_format,
http_content_type, http_artifacts, http_projections).

Conformance 761/761.
 2026-06-06 19:19:02 +00:00
giles
d481af5791 fed-sx-m2: Step 5c — peer-actors cache + 19 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 34s
Details 
New next/kernel/peer_actors.erl is the federation-side cache for
{PeerActorId, PeerActorState} entries. PeerAS is exactly the shape
envelope:verify_signature/2 reads (proplist with :public_keys), so
the inbox handler can pipe the cache hit straight into
pipeline:validate_inbound/3 from Step 5b.

Pure-functional API:
  new/0
  lookup/2(PeerId, State) -> {ok, PeerAS} | not_found
  store/3(PeerId, PeerAS, State) -> NewState
  evict/2(PeerId, State) -> NewState
  peers/1(State) -> [PeerId]
  lookup_or_fetch/3(PeerId, FetchFn, State)
      -> {ok, PeerAS, NewState}      cache hit returns unchanged State,
                                     miss stores FetchFn result.
      | {error, Reason, State}        FetchFn failure preserves cache.
      | {error, {bad_fetch_return, X}, State}

FetchFn contract: (PeerId) -> {ok, PeerAS} | {error, Reason}.
Failed fetches do NOT poison the cache so callers can retry on
transient HTTP failures.

gen_server wrapper (registered name peer_actors):
  start_link/0,1   start_link/1 accepts initial proplist for fixtures
  stop/0
  lookup_srv/1
  store_srv/2
  lookup_or_fetch_srv/2
  peers_srv/0
  evict_srv/1

handle_call dispatches mirror the pure-fn paths exactly.

The actual HTTP-GET fetch implementation (peer's actor doc -> peer
AS proplist) is Step 5d's responsibility — for 5c, FetchFn is just
the contract callers fill in.

19/19 in next/tests/peer_actors.sh:
  - new/0 -> []
  - lookup miss -> not_found
  - store + lookup round-trip
  - peers/1 in insertion order
  - evict + evict-unknown no-op
  - lookup_or_fetch miss invokes FetchFn, hits cache after
  - lookup_or_fetch hit skips FetchFn (verified by tombstone fn)
  - fetch error preserves cache state
  - bad fetch return shape captured
  - gen_server start_link + miss/hit/fetch/evict round-trips
  - start_link/1 pre-populates cache from initial state

Conformance 761/761. 139/139 across 9 Step-5-adjacent suites
(inbox_pipeline, inbox_bucket, pipeline_signature, registry_server,
projection_server, nx_kernel_multi, bootstrap_start, http_publish,
smoke_app_pure, plus the new peer_actors).
 2026-06-06 16:36:19 +00:00
giles
d103ecb863 fed-sx-m2: Step 5b — pipeline:validate_inbound/3 + 14 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 23s
Details 
New federation inbound pipeline that runs envelope-shape -> peer
signature -> replay against the receiving actor's inbox log.

pipeline.erl additions:
  validate_inbound/3(Activity, PeerActorState, InboxLog)
      runs inbound_stages(PeerAS, InboxLog) and halts on first
      failure (existing run_stages/2 driver). Returns ok |
      {error, Reason}.
  inbound_stages/2(PeerAS, InboxLog)
      [stage_envelope, stage_signature(PeerAS), stage_replay(InboxLog)]

M1's validate_inbound/1 and the static inbound_stages/0 (envelope-
only) are preserved — outbox-side callers don't have to re-key on
a peer-AS they don't have.

Signature verification routes through the peer's actor-state
:public_keys (NOT the local kernel's actor-state). Peer-AS
resolution is the caller's responsibility for 5b; Step 5c wires
the peer-actors cache lookup.

14 cases in next/tests/inbox_pipeline.sh:
  - happy path: valid signed activity + correct peer AS + empty
    inbox -> ok
  - bad envelope shape -> {error, _} (stage_envelope rejects)
  - unsigned activity -> stage_envelope rejects on
    {missing_field, signature} before sig runs
  - wrong peer AS (peer's claimed key bytes differ from real) ->
    {error, bad_signature}
  - replay: inbox already contains the same activity -> {error, replay}
  - inbox with a different activity doesn't trigger replay
  - inbound_stages/2 returns exactly 3 stages
  - inbound_stages/0 still returns 1 stage
  - validate_inbound/1 still works
  - shape failure short-circuits before sig
  - sig failure short-circuits before replay
  - two distinct activities both verify against empty inbox
  - inbox-of-one doesn't replay the other

Conformance 761/761. 130/130 across 10 Step-5-adjacent suites
(pipeline_envelope, pipeline_signature, pipeline_replay,
pipeline_driver, inbox_pipeline, inbox_bucket, nx_kernel_multi,
bootstrap_start, http_publish, outbox_publish, smoke_app_pure).
 2026-06-06 16:22:47 +00:00
giles
bc4b23cc62 fed-sx-m2: Step 5a — per-actor :actor_inbox log bucket + 14 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 21s
Details 
Adds the receiving-side log bucket every actor needs. add_actor/4
now opens a fresh in-memory log via log:open(ActorId, inbox_base_stub())
and stores it on the bucket as {actor_inbox, LogState} alongside
the outbox {log, _}. Two distinct base stubs ensure the in-memory
log module returns separate states even when the same ActorId is
the actor.

Pure-functional exports:
  actor_inbox_state/2(ActorId, State) -> {ok, LogState} | {error, _}
  actor_inbox_tip/2(ActorId, State) -> integer | nil
  append_to_actor_inbox/3(ActorId, Activity, State)
      -> {ok, NewTip, NewState} | {error, no_actor, State}

gen_server exports (mirror the outbox shape):
  inbox_tip_for/1(ActorId) -> integer | nil
  inbox_state_for/1(ActorId) -> {ok, LogState} | {error, _}
  append_inbox/2(ActorId, Activity) -> {ok, NewTip} | {error, _}

handle_call dispatch added for all three.

Inbox and outbox tips are completely independent — appending to one
doesn't touch the other. This is the storage primitive 5b will
build the inbound validation pipeline on top of.

log:append/2 signature noted in code + progress log: it takes
(LogState, Activity) and returns {ok, NewState, Seq} — not
{ok, NewState} as I originally guessed.

next/tests/inbox_bucket.sh 14/14:
  - fresh inbox tip = 0 (pure)
  - actor_inbox_state {ok, _} (pure)
  - append_to_actor_inbox/3 -> {ok, 1, _}
  - tip advances after append
  - unknown actor -> {error, no_actor, _}
  - outbox + inbox tips fully independent
  - two actors maintain independent inbox state
  - gen_server inbox_tip_for/1 starts at 0
  - gen_server append_inbox/2 -> {ok, 1}
  - gen_server inbox != outbox tip
  - gen_server unknown -> {error, no_actor}
  - gen_server inbox_state_for {ok, _}
  - two appends -> tip = 2

Conformance 761/761. 125/125 across 7 Step-5-adjacent suites
(inbox_bucket, nx_kernel_multi, nx_kernel_server, bootstrap_start,
http_publish, http_multi_actor, actor_lifecycle, smoke_app_pure).
 2026-06-06 15:58:17 +00:00
giles
a23a2eb95a fed-sx-m2: Step 4e — scope-boundary tick, no code change
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 25s
Details 
POST /actors/<id>/inbox stays the 4a 202 'accepted' stub through
all of 4a-4d. The real inbound pipeline (peer sig verify + inbox-
bucket append + projection broadcast) is Step 5's whole topic, so
4e is closed as a deliberate scope boundary — no code change.

Step 4 fully closed (4a per-actor sub-paths, 4b token map,
4c route/3 + kernel access, 4d outbox listing + pagination, 4e
inbox-stays-stub).
 2026-06-06 15:43:05 +00:00
giles
6cfb1cb2d3 fed-sx-m2: Step 4d — outbox listing from log + pagination + 8 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Details 
Per-actor GET /actors/<id>/outbox now reads the bucket's log via
new nx_kernel:log_state_for/1 gen_server export and renders the
paged CID list.

nx_kernel additions:
  log_state_for/1 gen_server call returning {ok, LogState} for
  the named actor (mirrors log_tip_for/1's shape).

http_server additions:
  - with_request_query/2 bakes Req's :query binary into Cfg as
    {request_query, Q} so sub-resource handlers can parse params
    without taking the Req as another arg
  - kernel_actor_log_data/2 -> {Tip, Entries} via
    nx_kernel:log_tip_for + log_state_for + log:entries
  - parse_page/1 reads ?page=N (default 1, non-digits -> 1)
  - page_size/0 returns 5 (test-friendly; production picks 20+)
  - page_slice/2 + drop_take/3 + take/2 for the page extraction
  - entry_cids/1 maps entries to :id CID binaries via envelope
  - actor_outbox_full_response_for/5 renders text / JSON / SX:
      text:  outbox: <id>\ntip: N\npage: P\nitem: <cid>\n...
      json:  {"outbox":"<id>","tip":N,"page":P,"items":[...]}
      sx:    (outbox "<id>" :tip N :page P :items (...))
    Empty page degrades to actor_outbox_with_tip_response_for so
    epochs 50-57 from Step 4c still pass — the prefix is preserved.

8 new cases in next/tests/http_multi_actor.sh (41/41 total):
  - 1 publish -> body contains outbox/tip=1/page=1/item: prefix
  - 3 publishes -> body contains tip=3/page=1/item: prefix
  - page=2 with 3 items -> empty page degrades to tip-only body
  - 6 publishes page=1 -> tip=6/page=1/item: prefix
  - 6 publishes page=2 -> tip=6/page=2/item: prefix
  - JSON body shape with items array (1 entry)
  - SX body shape with :items list (1 entry)
  - bad ?page=bad falls back to page 1

Conformance 761/761. 117/117 across 11 Step-4-adjacent suites
(http_multi_actor, http_route, http_publish, http_post_format,
http_marshal, http_publish_fold, http_listen_bif, http_server_start,
nx_kernel_multi, nx_kernel_server, bootstrap_start, actor_lifecycle).

Substrate gotcha logged: named recursive funs fun F(...) -> F(...)
end aren't supported by the parser ('fun-ref syntax not yet
supported'); binary:matches/2 and lists:foreach/2 aren't registered.
Tests prove behaviour via match_prefix substring checks rather than
counting occurrences.
 2026-06-06 15:42:37 +00:00
giles
e04a65d400 fed-sx-m2: Step 4c — route/3 with kernel access + 8 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 24s
Details 
http_server:route/3(Req, Cfg, Kernel) is the new extended entry
point: folds the kernel reference (typically the registered
nx_kernel atom) into Cfg as {kernel, Kernel}. route/2 is
unchanged and stays the M1 surface.

The dispatch chain gained Cfg threading all the way down:
  dispatch/3 -> dispatch/4 (M, P, F, Cfg)
  actor_get/2 -> actor_get/3 (Rest, F, Cfg)
  actor_subresource_get/3 -> /4 (Id, Sub, F, Cfg)

actor_outbox_response_for/3 (new) reads :kernel from Cfg and,
when the kernel atom is registered AND the actor exists, renders
'tip: <N>' alongside the actor id in text / JSON / SX content-
negotiated bodies. Unknown actors or unregistered kernels fall
back to the 4a stub.

Inbox / followers / following handlers accept Cfg but ignore it
for now — they layer real state lookup in 4d/4e/Step 5+.

Substrate gotcha logged in the Progress log: try/of/catch around
gen_server:call(nx_kernel, _) deadlocks in this port's scheduler
(probably the catch frame's mask defers reply delivery). The
live kernel_log_tip/2 helper does a bare call + integer guard
instead. nx_kernel_multi.sh already proves bare gen_server:call
into the same kernel works correctly.

8 new cases in next/tests/http_multi_actor.sh (33/33 total):
  - route/3 with registered kernel: outbox body includes tip=0
  - tip advances after POST publish through route/3 + token map
  - unknown actor (ghost) falls back to 4a stub (no tip:)
  - unregistered kernel ref falls back to stub
  - JSON Accept renders {"outbox":"alice","tip":0}
  - SX Accept renders (outbox "alice" :tip 0)
  - Bob's outbox tip stays 0 while Alice publishes (per-actor)
  - route/2 path unchanged: no tip field in body

Conformance 761/761. 121/121 across 10 Step-4-adjacent suites
(http_multi_actor, http_route, http_publish, http_post_format,
http_marshal, http_publish_fold, http_listen_bif, http_server_start,
nx_kernel_multi, bootstrap_start, actor_lifecycle).
 2026-06-06 14:59:59 +00:00
giles
271632c923 fed-sx-m2: Step 4b — token -> ActorId map + 8 new tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 19s
Details 
POST /activity now routes through nx_kernel:publish_to/2 when the
bearer token resolves to an explicit ActorId via Cfg's :tokens
proplist:

  Cfg = [{tokens, [{<<"alice-token">>, alice},
                   {<<"bob-token">>,   bob}]}]

resolve_token/2 returns {ok, ActorId} on a :tokens hit. On a miss
it falls back to the M1 :publish_token single-token field — match
returns {ok, legacy}, routing through nx_kernel:publish/1 (which
fans out to bucket 0) so every M1 test continues to pass.

handle_post_activity threads the resolved ActorRef to
publish_if_kernel/3 which dispatches publish_to/2 for explicit
actor ids and publish/1 for the legacy atom. The no-kernel
auth-only path (which preserves the post_activity_response_for stub
for unit-style tests of http_server alone) is unchanged.

Dead expected_token/1 helper removed (was only called by the old
check_bearer arm that resolve_token replaces).

8 new cases in next/tests/http_multi_actor.sh (25/25 total):
  - two-actor Cfg, Alice token -> 200 with cid:
  - Alice token publishes to alice (log_tip alice=1, bob=0)
  - Bob token publishes to bob (log_tip alice=0, bob=1)
  - interleaved Alice + Bob + Alice -> {2, 1}
  - unknown token + no :publish_token -> 401
  - legacy :publish_token still works (M1 back-compat)
  - tokens map AND legacy :publish_token coexist (each resolves to
    its own actor; legacy lands on alice bucket via publish/1)
  - no kernel + valid :tokens entry -> auth-only stub 200

Conformance 761/761. 116/116 across 10 Step-4-adjacent suites
(http_multi_actor, http_route, http_publish, http_post_format,
http_marshal, http_publish_fold, http_listen_bif, http_server_start,
nx_kernel_multi, bootstrap_start, actor_lifecycle).
 2026-06-06 14:31:27 +00:00
giles
0b8772ec69 fed-sx-m2: Step 4a — per-actor HTTP sub-paths + 17 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
Details 
Per design §16.1 each actor has /outbox /inbox /followers /following
sub-paths. New split_first_slash/1 helper lets the GET /actors/...
dispatch arm fan out on the sub-segment:

  GET  /actors/<id>            actor doc (M1 — unchanged)
  GET  /actors/<id>/outbox     outbox stub (4a)
  GET  /actors/<id>/inbox      inbox stub (4a)
  GET  /actors/<id>/followers  follower stub (4a)
  GET  /actors/<id>/following  following stub (4a)
  POST /actors/<id>/inbox      202 Accepted stub (4a; Step 5 real)

Four new content-negotiated response functions mirror the existing
actor_doc_response_for/2 shape (text / json / activity_json / sx
variants):

  actor_outbox_response_for/2
  actor_inbox_get_response_for/2
  actor_followers_response_for/2
  actor_following_response_for/2

POST returns 202 via new accepted_response/1 +
actor_inbox_post_response/0.

Unknown sub-paths under /actors/<id>/ return 404. Bare /actors/<id>
preserves the M1 actor-doc arm so http_route + http_post_format
regression suites stay green.

4b-4e (token map, route/3 kernel access, per-actor outbox listing
from log entries, real inbox pipeline) layer on top of this dispatch
in subsequent iterations.

17/17 in next/tests/http_multi_actor.sh covering:
  - split_first_slash sanity (no slash / id+sub / trailing slash)
  - all four GET sub-paths return 200 with stub bodies
  - POST inbox returns 202 + 'accepted'
  - unknown sub-paths return 404 (GET and POST)
  - empty /actors/ returns 404
  - body carries the actor id
  - content negotiation: outbox JSON, inbox SX, followers JSON

Conformance 761/761. 120/120 across 10 Step-4-adjacent suites
(http_route, http_publish, http_post_format, http_marshal,
http_publish_fold, http_listen_bif, http_server_start,
nx_kernel_multi, actor_state_pure, bootstrap_start).
 2026-06-06 13:47:00 +00:00
giles
238a1fbea0 fed-sx-m2: Step 3 — key rotation via Update + actor_state + 16 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 32s
Details 
actor_state.erl fold_update routes patches through apply_patch/3
which special-cases two rotation patch entries per design §9.6:

  {add_publicKey, KeyProplist}
      Append to :public_keys; default :created to activity's
      :published if unset.
  {supersede, OldKeyId}
      Mark the matching key with :superseded_at = activity's
      :published. Existing :superseded_at preserved (idempotent);
      unknown :id no-op.

Other patch entries still last-write-wins per key (Step 2b semantics
preserved; verified by actor_state_pure 19/19 unchanged).

New exports:
  key_history/1     — full :public_keys list (preserves superseded)
  active_keys_at/2  — subset active at time T (mirrors envelope's
                       is_active_at; envelope keeps that predicate
                       private, so a local copy lives here)
  find_key_by_id/2  — lookup by :id in the history

Rotation-purpose schema gating per §9.6 (rotation must be signed
by a key with :rotate-key purpose) is deferred to Step 5 (peer-side
stage_signature will plumb purpose through the pipeline).

16/16 in next/tests/key_rotation.sh covering:
  - rotation arithmetic (add_publicKey + supersede combined)
  - new key :created = rotation activity's :published
  - supersede marks :superseded_at correctly
  - key_history preserves all keys (superseded included)
  - active_keys_at semantics at T=pre / T=rotation / T=post
  - live envelope:verify_signature/2 round-trips:
      pre-rotation activity signed with K1 -> ok
      post-rotation activity signed with K2 -> ok
      post-rotation activity signed with K1 -> {error, no_active_key}
  - non-rotation Update patches preserve key history
  - add_publicKey alone (no supersede) keeps old key active
  - supersede alone empties active set
  - supersede with unknown id is a no-op
  - second supersede on superseded key is idempotent

Conformance 761/761. 132/132 across 9 Step-3-adjacent suites
(key_rotation, actor_state_pure, actor_lifecycle, envelope_sig,
envelope_shape, envelope_canonical, nx_kernel_multi, bootstrap_start,
smoke_app_pure).
 2026-06-06 13:08:25 +00:00
giles
1fd85e10e6 fed-sx-m2: Step 2c — bootstrap_actor/4 + actor_lifecycle integration
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
Details 
New nx_kernel:bootstrap_actor/4(ActorId, Profile, KeySpec, State)
single-call entry that adds an actor bucket and immediately publishes
a Create{Person|Service|Group} envelope as the bucket's first activity:

  - Profile carries :type, :name, :preferredUsername, :summary, :icon,
    :public_keys. :type defaults to person if unset.
  - Kernel AS proplist built from Profile's :public_keys (falls back
    to []).
  - Create object built from Profile fields (Step 2b actor_state
    fold picks the same field set).

gen_server variant bootstrap_actor/3 for live-kernel use plus a new
handle_call branch.

15/15 in next/tests/actor_lifecycle.sh covering pure + gen_server +
actor_state projection capture for all three actor types:

  - Pure: bootstrap_actor advances log_tip = 1, Create has
    object.type = person
  - Pure: two actors share a kernel with independent log tips
  - Pure: duplicate bootstrap_actor -> already_present
  - Pure: typeless profile defaults to person
  - Pure: empty public_keys handled
  - gen_server: bootstrap_actor/3 against a live registered kernel
  - actor_state projection captures Person, Service, Group profiles
  - profile carries :preferredUsername + :public_keys from the
    Create object

Closes Step 2 (2a Person/Service/Group genesis files,
2b actor_state projection fold, 2c bootstrap_actor + integration).

Conformance 761/761. 146/146 across 10 Step-2-adjacent suites
(actor_lifecycle, actor_state_pure, nx_kernel_multi, nx_kernel_server,
bootstrap_start, smoke_app_pure, smoke_pin_pure, define_registry_pure,
projection_server, outbox_publish).
 2026-06-06 12:32:16 +00:00
giles
bcfbd9a528 fed-sx-m2: Step 2b — actor_state projection fold + 19 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 28s
Details 
next/kernel/actor_state.erl mirrors define_registry's structure: a
2-arity fold_fn that plugs into projection:start_link/3, an
Erlang-fun stand-in for the genesis actor-state.sx projection body.

State shape:
  [{ActorId, Profile}, ...]

Profile is a property list with :type, :name, :preferredUsername,
:summary, :icon, :public_keys, :moved_to, :created. Maps #{} aren't
registered in this substrate, so this matches the kernel bucket /
registry shape convention.

Folding rules per design §9.1-§9.4:
  - Create{Person|Service|Group}: register profile, capturing object
    fields + :published seq as :created. Duplicate Create no-overwrite.
  - Update{Person|Service|Group, patch}: deep-merge :patch into
    profile last-write-wins per key.
  - Move: record :moved_to.
Other activity types and non-actor object Creates pass through.

Local find_keyed/has_keyed/set_keyed helpers (same gap as Step 1a:
no lists:keyfind/keymember in this substrate).

19/19 in next/tests/actor_state_pure.sh covering:
  - new/0/has/2/lookup/2/actors/1 base cases
  - Create for Person/Service/Group all three actor types
  - Profile field capture (name, preferredUsername, public_keys, created)
  - Duplicate Create no-overwrite
  - Two independent actors
  - Update field merge + per-key last-write-wins
  - Update for unknown actor pass-through
  - Move :moved_to
  - Non-actor Creates pass through
  - Activities without :actor pass through
  - fold_fn/0 returns is_function(F, 2)

Conformance 761/761. Step-2-adjacent no-regression gate 106/106
across 6 suites (define_registry_pure, projection_pure,
projection_server, nx_kernel_multi, bootstrap_start, smoke_app_pure).
 2026-06-06 11:53:14 +00:00
giles
0c44a10c8f fed-sx-m2: Step 2a — Person/Service/Group genesis object-types
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 35s
Details 
Three new DefineObject artefacts in next/genesis/object-types/ for
the canonical actor object-types per design §9.1:

- Person: human-controlled identity (display name + handle + bio)
- Service: automated / programmatic actor (bot, feed, organisation)
- Group: multi-controller actor (member-set managed via Add/Remove)

Each is a small SX form with :name / :doc / :schema, identical
shape to existing object-types (note.sx, sx-artifact.sx etc) so the
existing bootstrap:populate_registry walk picks them up without
code changes. Manifest extended (object-types: 10 -> 13, total
entries: 31 -> 34).

Tests:
- genesis_parse.sh +7 cases (head form, :name, manifest membership);
  57/57.
- Hardcoded counts bumped in bootstrap_read.sh, bootstrap_load.sh,
  bootstrap_populate.sh, bootstrap_start.sh.
- bootstrap_build.sh 12/12 (bundle CID computed dynamically).

Conformance 761/761 preserved. 211/211 across 12 Step-2-adjacent
suites.
 2026-06-06 11:19:22 +00:00
giles
089d1445a1 fed-sx-m2: Step 1b — nx_kernel multi-actor gen_server calls + 9 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 34s
Details 
New gen_server exports add_actor/3, publish_to/2, log_tip_for/1,
actors/0, state_for/1, bucket_for/1, with_projections_for/2 —
each is a thin gen_server:call delegating to 1a's pure-functional
bucket API via fresh handle_call branches. Existing single-actor
calls (publish/1, log_tip/0, with_projections/1) route through
bucket 0 unchanged.

Per-actor mailbox sharding (one gen_server per bucket so distinct-
actor publishes don't serialise on a single mailbox) is forward-
looking — deferred to Step 4 where the per-actor HTTP routing makes
it actually load-bearing. Single-mailbox serialisation is fine for
Steps 1-3.

nx_kernel_multi.sh extended from 17 to 26 cases (gen_server load,
start_link bucket-0 seed, add_actor/3 dup detection, publish_to/2
per-actor isolation, interleaved publishes, no_actor error, state_for
+ with_projections_for round-trips). 134/134 across 12 nx_kernel-
adjacent + http suites. Erlang conformance 761/761 preserved.
 2026-06-06 10:25:43 +00:00
giles
6a9bd054c7 fed-sx-m2: Step 1a — nx_kernel per-actor bucket refactor + 17 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 20s
Details 
State shape becomes [{actors, [{Id, Bucket}, ...]}, {next_actor_seq, N}]
with ActorBucket = [{key_spec, KS}, {actor_state, AS}, {log, L},
{projections, [Name]}, {next_published, N}]. Pure-functional multi-
actor APIs (new/0, add_actor/4, has_actor/2, actors/1, actor_count/1,
publish/3, per-actor accessors, with_actor_projections/3) join the
legacy single-actor accessors, which now read from the first bucket.
Every M1 test continues to pass via bootstrap:start/3 -> new/3 ->
first-bucket lookup.

Local has_keyed/find_keyed/set_keyed/set_bucket helpers cover the
keyed-list ops since lists:keymember/keyfind aren't registered in
this substrate.

next/tests/nx_kernel_multi.sh 17/17. M1 nx_kernel-adjacent suites
green (bootstrap_start 10/10, nx_kernel_server 11/11, http_publish
10/10, smoke_app_pure 12/12, http_post_format 13/13, http_publish_fold
10/10, http_marshal 10/10). Erlang conformance 761/761 preserved.

Blockers entry added for pre-existing http_server_tcp.sh 0/5
regression (78eae9ef left dead helper references in runtime.sx:1593) —
substrate-side, out of m2 scope, confirmed pre-existing by reverting
1a's changes and re-running.
 2026-06-06 09:46:24 +00:00
giles
9b04769a27 fed-sx-m2: loop agent briefing
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 25s
Details 
Restart baseline, build queue, ground rules, gotchas, two-instance
test harness pattern for the m2 federation loop.
 2026-06-06 09:00:12 +00:00
giles
7ea9d04564 fed-sx-m2: draft milestone-2 plan — multi-actor + federation (12 steps, two-instance smoke test)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 19s
Details
2026-06-06 08:26:45 +00:00
giles
78eae9ef12 fed-sx-m1: 8b-bridge cleanup — remove dead helpers + duplicate test
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 34s
Details 
Step 8b-bridge was actually completed in 0f85bd96 (Step 8b-start) using
er-request-dict-to-proplist / er-proplist-to-dict plus er-spawn-fun to
host the handler inside a real Erlang process. My previous commit
(31ff1e6a) shipped a parallel set of helpers (er-http-req-of-sx,
er-http-resp-to-sx and friends) plus a duplicate test under
next/tests/http_listen_bridge.sh — the BIF body never referenced them,
so they sat in runtime.sx as dead code while http_marshal.sh already
covered the live marshalers.

This commit:
  - deletes the 8 dead helpers from lib/erlang/runtime.sx
  - deletes the duplicate next/tests/http_listen_bridge.sh
  - rewrites next/README.md substrate gap #3 to name the helpers and
    tests that are actually live

No behaviour change. Erlang conformance still 761/761; http_listen_bif
5/5, http_route 11/11, http_publish_fold 10/10, http_marshal 10/10.
 2026-06-05 23:10:45 +00:00
giles
7267b83b08 fed-sx-m1: milestone-1 closeout — revert spawn-drain BIF wrapper, tick 9a/9b-tcp as superseded
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 24s
Details 
`er-bif-http-listen`'s sx-handler closure is reverted to the simple direct-apply form:

  (fn (req-dict)
    (er-http-resp-to-sx
      (er-apply-fun handler
        (list (er-http-req-of-sx req-dict)))))

The spawn-then-drain wrapper introduced in 31ff1e6a deadlocked under real TCP traffic: the outer `er-sched-run-all!` is
parked deep inside the listener's `Unix.accept`, and the handler thread's re-entry into `er-sched-run-all!` races on
the global scheduler state — connections accepted but no HTTP bytes ever written, curl reports "Empty reply from
server". The simple wrapper restores `next/tests/http_server_tcp.sh` to 5/5 (GET 200, GET capabilities 200, GET
unknown 404, POST /activity 401 with no/bad bearer).

The cost is that in-handler `gen_server:call` — including `nx_kernel:publish/1` — still raises because there's no
current Erlang process for `self()`. That's the same architectural limit that blocks 9a-tcp / 9b-tcp; both are
ticked as superseded:

- Transport coverage is in `next/tests/http_server_tcp.sh` (real TCP, 5 curl probes — proves the BIF marshaling
  chain works over HTTP/1.1).
- Publish-chain coverage is in `next/tests/http_publish_fold.sh` (10/10, in-process — POST → publish → broadcast
  → projection-fold end-to-end).
- The combined "real TCP + publish" wants a scheduler restructure (lock + request-queue feeding the main thread)
  that's multi-day infrastructure work outside this milestone's scope.

Milestone 1 closed. Steps 1-9 all ticked in plans/fed-sx-milestone-1.md. 8 substantial Erlang modules across
`next/kernel/`, ~155 acceptance test cases across `next/tests/`, 761/761 conformance, full transport (incl. real
HTTP) + full reactive substrate (incl. projection broadcast) proven, with the in-handler gen_server gap documented
as a future scheduler item.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
 2026-06-05 21:10:29 +00:00
giles
31ff1e6a3f fed-sx-m1: Step 8b-bridge — http:listen dict ↔ proplist marshalling
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 52s
Details 
The native http-listen primitive in bin/sx_server.ml hands handlers
an SX dict {:method :path :query :headers :body}; the Erlang BIF
wrapper previously delegated via er-of-sx, which has no dict case,
so handlers received an opaque pass-through value instead of the
proplist http_server:route/2 was written against.

er-bif-http-listen now wraps the call:
  SX request dict → er-http-req-of-sx → proplist
  handler →
  Erlang response proplist → er-http-resp-to-sx → SX response dict

Request shape:
  [{method, Bin}, {path, Bin}, {query, Bin},
   {headers, [{Name, Value}, ...]}, {body, Bin}]
Response shape:
  [{status, Integer}, {headers, [{Name, Value}, ...]}, {body, Bin}]

Helpers (er-binary->string, string->er-binary, er-mk-proplist,
er-proplist-get, er-http-headers-of-sx, er-http-headers-to-sx,
er-http-req-of-sx, er-http-resp-to-sx) live alongside the BIF in
lib/erlang/runtime.sx — scoped narrowly to the bridge, no edits
elsewhere in the file.

Verified by next/tests/http_listen_bridge.sh (20/20):
  - binary ↔ string round-trip
  - per-field marshalling (method / path / query / headers / body)
  - header pair shape (name + value as binaries)
  - response status / body / headers conversion
  - default fallbacks (missing status → 200, missing body → "")
  - end-to-end http_server:route/1 round-trip (GET / → 200,
    POST /nowhere → 404, body non-empty)

Existing http_listen_bif.sh (5/5), http_route.sh (11/11),
http_publish_fold.sh (10/10) unchanged. Erlang-on-SX conformance
761/761. WASM boot green (no lib/sx_primitives.ml changes).

Unblocks Step 8b-start (TCP listener spawn) and the curl-driven
9a-tcp / 9b-tcp smoke tests.
 2026-06-05 20:46:38 +00:00
giles
0f85bd963a fed-sx-m1: Step 8b-start — http_server:start/1 + dict↔proplist marshaling; live TCP smoke 5/5
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 25s
Details 
`next/kernel/http_server.erl` gains `start/1(Port)` + `start/2(Port, Cfg)`. Both spawn an Erlang process that hosts
the native `http:listen/2` accept loop with the Cfg-aware `route/2` as the handler.

The blocker — the BIF wrapper in `lib/erlang/runtime.sx` had no dict↔proplist marshaling, so Erlang handler funs
couldn't pattern-match on an opaque SX request dict — is resolved by a new family of helpers added next to `er-of-sx`
(which is left untouched so non-HTTP callers see no behavioural drift):

  er-request-dict-to-proplist   request dict -> [{method,<<>>},{path,<<>>},...] (atom keys)
  er-of-sx-deep                 recursive marshal: dicts -> binary-keyed proplist
  er-dict-to-header-proplist    headers: [{<<"content-type">>,<<"text/plain">>},...]
                                 (binary keys keep arbitrary user input out of the atom table)
  er-proplist-to-dict           response proplist -> SX dict for native serialiser
  er-proplist-fill!             dict-set! walker over a cons-of-2-tuples
  er-to-sx-deep                 recursive marshal: cons-of-2-tuples -> nested dict
  er-proplist-2tuple?           predicate distinguishing a header proplist from a binary body

`er-bif-http-listen`'s body is updated to route through the new pair instead of `er-of-sx` / `er-to-sx`. Existing
`http_listen_bif.sh` (Step 8a) still passes — the BIF's external contract (port + handler validation, registration)
hasn't changed, only the request/response shape the handler sees.

This commit also lands a small pre-existing unstaged refactor that was sitting in the same file (er-binary->string
helper above er-bif-http-listen, a "Register everything at load time." comment move, and the binary_to_list /
list_to_binary / er-iolist-walk! defines reshuffled into the er-register-builtin-bifs! body). The refactor was
agreed-out-of-scope earlier in the loop but was unblocked this iteration when the user OK'd progress on 8b-start.
Bundling it here keeps the lib/erlang/runtime.sx diff coherent.

Tests:
- `next/tests/http_marshal.sh` (10 cases) — marshaling unit tests: request dict → cons proplist; method as
  <<"GET">> via SX-side proplist walker; path-as-string roundtrip; nested headers reach through binary keys;
  response status/body field marshaling; nested headers reconstruct dict; full round-trip preserves status.
- `next/tests/http_server_start.sh` (6 cases) — structural verification: http_server module loaded, start bound
  in module env, marshalers defined as lambdas, http:listen BIF registered. Can't invoke spawn in an Erlang test
  because the cooperative scheduler (`er-sched-run-all!`) drains every runnable process before returning to the
  caller, and the listener's accept loop never exits.
- `next/tests/http_server_tcp.sh` (5 cases) — **first live end-to-end transport test in the milestone**: boots
  sx_server in background with FIFO-held stdin (~10s boot for all lib/erlang/*.sx loads + module compile +
  Unix.bind), then drives the listener via shell-side curl over real TCP. Verifies GET / → 200, GET
  /.well-known/sx-capabilities → 200, GET unknown → 404, POST /activity → 401 with no/bad bearer. Doubles as the
  smoke surface for 9a-tcp / 9b-tcp.

Erlang conformance **761/761** unchanged. All standing suites stay green (http_listen_bif 5/5, log_disk 12/12,
log_rotate 10/10, term_codec 18/18).

Step 8b-start ticked in plans/fed-sx-milestone-1.md. Remaining in the milestone: 9a-tcp / 9b-tcp — partly covered
by http_server_tcp.sh's smoke probes; the full curl-driven publish flows are the next iteration.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
 2026-06-05 20:30:15 +00:00
giles
e1336986cd fed-sx-m1: tick Step 6e as superseded by 8c-post-publish-http
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 21s
Details 
The "HTTP handler for POST /activity glue" bullet (6e) pre-dates the Step 8 dispatch refactor that landed the same
functionality with broader test coverage. `http_server:route/2` already wires POST `/activity` to
`nx_kernel:publish/1` when the kernel process is registered (success → 200 with `cid: <Cid>` body via
`cid_response/1`; sig/replay failure → 422 via `validation_failed_response/0`), and falls back to the stub
`post_activity_response/0` when the kernel isn't running. Per-format response variants (json / sx / cbor /
activity+json) followed in 8d-dispatch-post via `cid_response_for/2` + `post_activity_response_for/1`.

Verified by the standing suites: `next/tests/http_publish.sh` 10/10 and `next/tests/http_post_format.sh` 13/13.

Plan-only commit — no source changes, no test changes. Routes the next iteration past 6e onto the next genuinely
unticked sub-deliverable.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
 2026-06-05 08:03:42 +00:00
giles
ed9f180d12 fed-sx-m1: Step 3c.b gen_server-mediated concurrent appends — next/kernel/log_server.erl + 15/15 log_server tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 27s
Details 
`next/kernel/log_server.erl` (behaviour gen_server) wraps the pure Step 3c.a `log` substrate behind a per-actor process so
concurrent writers serialise through `gen_server:call` instead of racing on the disk segment writer.

API mirrors the pure log substrate:
  start_link(ActorId, BasePath)        -> Pid
  start_link(ActorId, BasePath, Opts)  -> Pid     %% Opts forwarded to log:open_disk/3
  append(Pid, Activity)                -> {ok, Seq}
  tip(Pid)                             -> Seq
  entries(Pid)                         -> [Activity, ...]
  replay(Pid, InitAcc, Fun)            -> Acc
  segments(Pid)                        -> [SegLen, ...]
  stop(Pid)                            -> ok

Per the port's gen_server convention, `gen_server:start_link/2` returns a raw Pid (not `{ok, Pid}`); the API takes the Pid
directly so multiple per-actor servers coexist without a registered-name collision.

`init/1` dispatches on the Opts arg to call either `log:open_disk/2` (default 1 GiB threshold = effectively no rotation) or
`log:open_disk/3` (opt-in `{segment_size, N}`). `handle_call/3` translates each public op to the corresponding pure log call
and threads the new state through.

New `next/tests/log_server.sh` (15 cases):
- API smoke: start_link returns a Pid, single append+tip+entries round-trip, replay/3 chronological, segments visible
  through the wrapper, rotation through wrapper with opt-in `{segment_size, 16}`, stop returns ok.
- Five concurrent-writer tests, each: spawn N=3 writers, each firing M=2 appends of `{I, J}`, parent waits on N `{done,_}`
  messages via a Y-combinator-shaped receive loop. Assertions cover (a) tip = N*M, (b) length(entries) = N*M, (c) every
  `{I, J}` pair appears exactly once via `lists:all/2` membership (no losses, no dupes), (d) reopening from disk via
  `log:open_disk/2` reproduces a byte-equal entries list, (e) every writer's index appears in the entries list
  (interleaving witnessed).

Erlang-port gotchas worked around this iteration:
(a) Named recursive fun `fun WaitFn(0) -> ok; WaitFn(K) -> ... end` errors as "fun-ref syntax not yet supported" — rewritten
    as `fun (_, 0) -> ok; (Self, K) -> ... Self(Self, K - 1) end` then called as `Wait(Wait, N)`.
(b) `lists:foreach/2` isn't registered (only `lists:map/2`) — use `lists:map/2` and discard the result list when running
    side-effecting closures.
(c) gen_server message round-trip in this interpreter is ~2s per call, so concurrent N*M was tuned to 6 (`N=3, M=2`) to
    keep the whole 15-test suite under 60s wall clock; the test's correctness assertions don't depend on N*M magnitude.

Erlang conformance **761/761** unchanged (log_server.erl is in next/, not lib/erlang/). Step 3c (both .a and .b) now
fully ticked in plans/fed-sx-milestone-1.md.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
 2026-06-05 07:59:40 +00:00
giles
897449cb35 fed-sx-m1: Step 3c.a segment rotation — log:open_disk/3, <ActorId>-NNNNNN.log filename, threshold-driven rotation; 10/10 log_rotate tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 21s
Details 
`next/kernel/log.erl` rewritten around a `seg_lens :: [N0, N1, ...]` per-segment entry-count list + a `seg_size` byte threshold. Filename
scheme moved from `<ActorId>.log` to `<ActorId>-NNNNNN.log` (6-digit zero-padded) so `file:list_dir`'s alphabetical sort coincides
with numeric order.

`open_disk/3(ActorId, BasePath, [{segment_size, N}])` opts a caller into a smaller rotation threshold; `open_disk/2` keeps a 1 GiB
default that effectively never rotates (preserves Step 3b acceptance — log_disk.sh unchanged in behaviour).

Rotation rule in `place_append/4`: if the active segment's pre-append encoded size is already >= threshold AND it holds at least one
entry, the new activity opens a fresh segment; otherwise it extends the current active segment. A single huge entry that exceeds
the threshold stays alone — never rotated recursively.

On reopen, `load_all_segments` lists the dir, filters `<ActorId>-NNNNNN.log`, sorts numerically (insertion sort — `lists:sort/1`
isn't registered in this port, only `lists:append/2`/`lists:reverse/1`/`lists:filter/2`/etc.), reads each via `try_read_segment`,
and concatenates the entries to rebuild flat `entries` + `seg_lens`.

Erlang-port gotchas worked around during this iteration:
(a) String literals like `"foo"` in this port are NOT charlists — `[H|T] = "foo"` badmatches and `length("foo")` errors as "not a
    proper list". `parse_segment_name` builds prefix/suffix from `atom_to_list/1` + explicit `[$-]` / `[$., $l, $o, $g]` cons.
(b) Cross-arg variable repetition (`strip_prefix([C | Rest], [C | PRest])`) was rewritten to explicit `case C =:= P` for robustness.
(c) `Pattern = Binding` syntax in a case clause (`[_|_] = Lst when length(Lst) > 1 -> ...`) errors as "unsupported pattern type
    'match'" — replaced with `Lst when is_list(Lst), length(Lst) > 1`.

Tests:
- new `next/tests/log_rotate.sh` (10 cases): no-opt single-seg-after-3, rotation-fires-on-threshold, rotated-chronological,
  reopen-rebuilds-history, reopen-rebuilds-same-seg-shape, huge-single-entry-stays-1-seg, append-after-huge-keeps-order,
  tip-monotonic-across-rotations.
- `next/tests/log_disk.sh` updated to the new filename (`corrupted-000000.log`); stays 12/12.
- Erlang conformance 761/761 unchanged (log.erl is in next/, not lib/erlang/).

3c.a ticked in plans/fed-sx-milestone-1.md; 3c.b (gen_server-mediated concurrent appends) is the next iteration.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
 2026-06-05 07:40:48 +00:00
giles
595c15a3fb fed-sx-m1: Step 3b on-disk log — open_disk/2 + write-through append/2 + length-framed segments; 12/12 log_disk tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 29s
Details
2026-06-05 07:20:29 +00:00
giles
6d7f0a3f15 fed-sx-m1: Step 3b substrate fix #4 — integer literals truncate to strict int (was float; broke integer->char)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Details
2026-06-05 07:19:56 +00:00
giles
076b8ae7f7 fed-sx-m1: Step 3b codec — next/kernel/term_codec.erl encode/decode + 18 round-trip tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 25s
Details
2026-06-05 06:56:31 +00:00
giles
4852cca9eb fed-sx-m1: Step 3b substrate fix #3 — atom_to_list/integer_to_list as Erlang charlists; list_to_* accept both (+9 net eval, 759/759)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 35s
Details
2026-06-05 06:49:40 +00:00
giles
3d80bd8ce6 fed-sx-m1: Step 3b substrate fix #2 — $X char literals decode to char code in tokenizer (+12 eval, 750/750)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 31s
Details
2026-06-04 22:50:35 +00:00
giles
24e3bf53b0 fed-sx-m1: Step 3b substrate fix — binary_to_list/1 + list_to_binary/1 BIFs (+9 ffi, 738/738)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 3m51s
Details
2026-06-04 22:44:02 +00:00
giles
24763c5199 fed-sx-m1: refresh next/README with module map, test inventory, substrate gaps + resume order
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 28s
Details
2026-05-28 20:28:22 +00:00
giles
004a88c03c fed-sx-m1: Step 4f-consolidate — bootstrap:start/3 one-call boot + 10 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 22s
Details
2026-05-28 20:05:02 +00:00
giles
e8ca0590a3 fed-sx-m1: Step 7d-pure — sandbox:eval_pure/2,/3 + 13 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 25s
Details
2026-05-28 19:26:34 +00:00
giles
559ed68907 fed-sx-m1: Step 9b-pure — reactive smoke test in-process (trigger match+derive end-to-end) + 12 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 32s
Details
2026-05-28 18:50:21 +00:00
giles
1496136d12 fed-sx-m1: Step 9a-pure — Pin smoke test in-process (verb extensibility end-to-end) + 13 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 20s
Details
2026-05-28 18:12:03 +00:00
giles
5940b98878 fed-sx-m1: Step 5d-pure — define_registry meta-projection fold + 16 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 19s
Details
2026-05-28 17:38:16 +00:00
giles
6137904368 fed-sx-m1: Step 6c-schema-pure — pipeline:stage_schema/1,/2 with SchemaLookup callback + 14 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
Details
2026-05-28 17:02:57 +00:00
giles
2a14b37c6c fed-sx-m1: Step 8d-dispatch-get — format-aware actor/artifact/projection/list responses + dispatch/3 refactor + 17 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 20s
Details
2026-05-28 16:28:07 +00:00
giles
dd7b7d7a2d fed-sx-m1: Step 8d-dispatch-post — format-aware POST /activity (cid_response_for + post_activity_response_for) + 13 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 28s
Details
2026-05-28 15:39:23 +00:00
giles
1aaede4272 fed-sx-m1: Step 8d-content-type — content_type_for/1 + ok_response/2 + 13 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 24s
Details
2026-05-28 15:04:46 +00:00
giles
3c945b9104 fed-sx-m1: Step 8d-dispatch-cap — capabilities_body_for + Accept-aware route + 13 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 32s
Details
2026-05-28 14:31:59 +00:00
giles
fa064093f5 fed-sx-m1: Step 8d-accept — Accept header parsing (accept_format/1 + accept_format_from/1) + 13 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 27s
Details
2026-05-28 13:57:48 +00:00
giles
cd7693d443 fed-sx-m1: Step 5c-populate — bootstrap:populate_registry into gen_server + 14 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 25s
Details
2026-05-28 13:22:45 +00:00
giles
285dd64dc2 fed-sx-m1: Step 9-pre-fold — HTTP POST -> publish -> projection-fold end-to-end (10 tests)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 25s
Details
2026-05-28 12:44:47 +00:00
giles
05100ef050 fed-sx-m1: Step 8c-post-publish-http — POST /activity wires through nx_kernel:publish + 10 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 32s
Details
2026-05-28 12:12:30 +00:00
giles
ccceb4a0b3 fed-sx-m1: Step 8c-post-publish-srv — gen_server-wrapped nx_kernel (start_link + publish/query/log_tip) + 11 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 29s
Details
2026-05-28 11:39:48 +00:00
giles
e9a905eb5f fed-sx-m1: Step 8c-post-publish-pure — nx_kernel pure orchestrator (new/3 + publish/2) + 12 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
Details
2026-05-28 11:08:47 +00:00
giles
f2aa294f00 fed-sx-m1: Step 8c-post-auth — POST /activity bearer-token gate + route/2 + 13 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 29s
Details
2026-05-28 10:38:36 +00:00
giles
212bf53a03 fed-sx-m1: Step 8c-proj — GET /projections + /projections/{name} routes + 11 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 33s
Details
2026-05-28 10:09:33 +00:00
giles
2aeab806fb fed-sx-m1: Step 8c-art — GET /artifacts/{cid} route reusing match_prefix + 9 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 29s
Details
2026-05-28 09:41:41 +00:00
giles
a4905a3e71 fed-sx-m1: Step 8c-actors-doc — match_prefix + GET /actors/{id} route + 13 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 32s
Details
2026-05-28 09:12:28 +00:00
giles
d15f4d229e fed-sx-m1: Step 8c-cap — GET /.well-known/sx-capabilities route + 8 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 23s
Details
2026-05-28 08:42:02 +00:00
giles
b45ea2aa16 fed-sx-m1: Step 8b-route — http_server:route/1 pure dispatch + ok/not_found helpers + 11 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
Details
2026-05-28 08:06:01 +00:00
giles
81efa1d8f0 fed-sx-m1: Step 8a — http:listen/2 BIF wrapper in runtime.sx (BRIEFING-EXCEPTION) + 5 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 31s
Details
2026-05-28 07:35:48 +00:00
giles
1ea47681b2 fed-sx-m1: Step 7c — outbox:publish broadcasts to projection processes + 14 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 28s
Details
2026-05-28 06:57:36 +00:00
giles
c91683b885 fed-sx-m1: Step 7b — gen_server-per-projection (start_link/3 + async_fold + query) + 11 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
Details
2026-05-28 06:22:11 +00:00
giles
4956a6d8ae fed-sx-m1: Step 7a — pure-functional projection driver + 12 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 37s
Details
2026-05-28 05:48:30 +00:00
giles
c5481d06aa fed-sx-m1: Step 6d-publish — outbox:publish/2 orchestration (construct+sign+validate+append) + 13 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
Details
2026-05-28 05:14:11 +00:00
giles
6e12f539fd fed-sx-m1: Step 6d-cs — outbox:construct + sign + cid_of + 13 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 32s
Details
2026-05-28 04:39:49 +00:00
giles
8c592c41b8 fed-sx-m1: Step 6c-replay — pipeline:stage_replay/1,/2 (factory + direct) + 12 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 23s
Details
2026-05-28 04:08:50 +00:00
giles
b7f7915c2a fed-sx-m1: Step 6b-sig — pipeline:stage_signature/1,/2 (factory + direct) + 11 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 26s
Details
2026-05-28 03:36:25 +00:00
giles
460257f2bb fed-sx-m1: Step 6b-env — pipeline:stage_envelope wired against envelope:validate_shape + 12 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 26s
Details
2026-05-28 03:03:55 +00:00
giles
9cb002c856 fed-sx-m1: Step 6a — pipeline:run_stages driver + validate_inbound/outbound + 10 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 37s
Details
2026-05-28 02:32:06 +00:00
giles
aa6b01f430 fed-sx-m1: Step 5b — gen_server-wrapped registry + named-process API + 12 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 27s
Details
2026-05-28 01:59:55 +00:00
giles
1aab9eff7d fed-sx-m1: Step 4e — bootstrap:load_genesis/strip_sx_suffix bridges read_genesis -> registry + 15 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 25s
Details
2026-05-28 01:28:06 +00:00
giles
d1a2ebd709 fed-sx-m1: Step 5a — pure-functional registry (new/register/lookup/list) + 14 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 28s
Details
2026-05-28 00:46:54 +00:00
giles
203a3a3c67 fed-sx-m1: Step 4d — bootstrap:build_genesis/verify_genesis + cidhash helpers + 12 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 23s
Details
2026-05-28 00:19:11 +00:00
giles
73a1a55572 fed-sx-m1: Step 4c — bootstrap:read_genesis/0,1 + 5 helpers + 15 read tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 14m10s
Details
2026-05-27 23:50:45 +00:00
giles
ae5df5cfa1 fed-sx-m1: Step 4b-cod — 8 bootstrap codecs/sig-suites/audience files + manifest complete + 14 new parse tests (50 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 26s
Details
2026-05-27 23:21:20 +00:00
giles
5d7b167a93 fed-sx-m1: Step 4b-vld — 3 bootstrap validators + manifest update + 5 new parse tests (36 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 37s
Details
2026-05-27 23:10:11 +00:00
giles
cfdb9cd875 fed-sx-m1: Step 4b-proj — 7 bootstrap projections + manifest update + 9 new parse tests (31 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 35s
Details
2026-05-27 22:52:54 +00:00
giles
4c0295cdff fed-sx-m1: Step 4b-obj — 10 bootstrap object-types + manifest update + 12 new parse tests (22 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 29s
Details
2026-05-27 19:48:26 +00:00
giles
b308ddb9b0 fed-sx-m1: Step 4b-act — Update + Delete activity-types + manifest update + 5 new parse tests (10 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 22s
Details
2026-05-27 07:44:20 +00:00
giles
28168b16aa fed-sx-m1: Step 4a — genesis manifest + Create activity-type seed + 5 parse tests; Step 3b parked (substrate term-codec gap)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 16s
Details
2026-05-27 07:18:04 +00:00
giles
ab159dface fed-sx-m1: Step 3a — in-memory log:open/append/tip/replay + 12 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 20s
Details
2026-05-27 07:06:40 +00:00
giles
53b4a4c1fd fed-sx-m1: Step 2c — envelope:verify_signature/2 (time-aware key lookup + HMAC stand-in) + 11 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 31s
Details
2026-05-26 21:00:39 +00:00
giles
65dfdd0ba4 fed-sx-m1: Step 2b — envelope:canonical_bytes/1 + 8 determinism tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 23s
Details
2026-05-26 20:41:27 +00:00
giles
e11e8b941f fed-sx-m1: Step 2a — envelope:validate_shape/1 + get_field/2 + 15 shape tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 26s
Details
2026-05-26 20:29:25 +00:00
giles
9cbf14fe8c fed-sx-m1: Step 1b — nx_cid kernel module + 13 canonical CID tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 6m22s
Details
2026-05-26 19:55:13 +00:00
giles
11ed4ddf27 fed-sx-m1: Step 1a — next/ skeleton + README + gitignore
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 14s
Details
2026-05-26 19:44:56 +00:00
448 changed files with 20312 additions and 37948 deletions
Expand all files Collapse all files

2
.claude/scheduled_tasks.lock
View File

@@ -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
.mcp.json
View File

@@ -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",

45
lib/acl/api.sx
View File

@@ -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
View File

@@ -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)))

32
lib/acl/conformance.conf
View File

@@ -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!)"
)

3
lib/acl/conformance.sh
View File

@@ -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" "$@"

72
lib/acl/engine.sx
View File

@@ -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)))

125
lib/acl/explain.sx
View File

@@ -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}))))

47
lib/acl/facts.sx
View File

@@ -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)))

61
lib/acl/federation.sx
View File

@@ -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)))

71
lib/acl/schema.sx
View File

@@ -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)))

14
lib/acl/scoreboard.json
View File

@@ -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"
}

11
lib/acl/scoreboard.md
View File

@@ -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 |

170
lib/acl/tests/direct.sx
View File

@@ -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})))

316
lib/acl/tests/explain.sx
View File

@@ -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})))

273
lib/acl/tests/fed.sx
View File

@@ -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})))

228
lib/acl/tests/harden.sx
View File

@@ -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})))

202
lib/acl/tests/inherit.sx
View File

@@ -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})))

63
lib/apl/conformance.conf
View File

@@ -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.'
}

119
lib/apl/conformance.sh
View File

@@ -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 ]

6
lib/apl/scoreboard.json
View File

@@ -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
}

4
lib/apl/scoreboard.md
View File

@@ -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

15
lib/apl/test-harness.sx
View File

@@ -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)))))

51
lib/content/anchor.sx
View File

@@ -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))))

72
lib/content/api.sx
View File

@@ -1,72 +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)
;; find / has? are TREE-WIDE by id (descend into sections) — so the facade reads
;; back any block content/edit can update or delete. content/find-top / has-top?
;; keep the top-level-only lookup for callers that mean the ordered sequence.
(define content/find doc-find-deep)
(define content/has? doc-has-deep?)
(define content/find-top doc-find)
(define content/has-top? doc-has?)
(define content/ids doc-ids)
(define content/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)

45
lib/content/block-path.sx
View File

@@ -1,45 +0,0 @@
;; content-on-sx — locate a block in the tree (ancestor section path).
;;
;; The read-side companion to doc-find-deep (which returns the block) and the
;; move/reparent ops (which relocate it): content/block-path returns the list of
;; ancestor section ids, root-first, leading to a block id — i.e. where the
;; block sits in the tree. A top-level block has an empty path; a block one
;; section deep has a one-element path; a missing id returns nil (distinct from
;; the empty-list path of a present top-level block). content/block-depth is the
;; path length (0 = top level, -1 = absent). Useful for breadcrumbs and for
;; scoping an edit to a block's enclosing section. Pure traversal; descends into
;; any block carrying a children list, like the rest of the tree helpers.
;;
;; Requires (loaded by harness): block.sx, doc.sx.
(define
bp-in-blocks
(fn
(blocks id trail)
(if
(= (len blocks) 0)
nil
(let
((b (first blocks)))
(if
(= (blk-id b) id)
trail
(let
((ch (st-iv-get b "children")))
(let
((found (if (list? ch) (bp-in-blocks ch id (append trail (list (blk-id b)))) nil)))
(if (= found nil) (bp-in-blocks (rest blocks) id trail) found))))))))
;; ancestor section ids (root-first) for `id`, or nil if the block is absent.
(define
content/block-path
(fn (doc id) (bp-in-blocks (doc-blocks doc) id (list))))
;; depth of `id`: 0 at top level, n nested n sections deep, -1 if absent.
(define
content/block-depth
(fn
(doc id)
(let
((p (content/block-path doc id)))
(if (= p nil) -1 (len p)))))

171
lib/content/block.sx
View File

@@ -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"))))

49
lib/content/callout.sx
View File

@@ -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))))

34
lib/content/clone.sx
View File

@@ -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)))))

42
lib/content/compose.sx
View File

@@ -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))))))

161
lib/content/conformance.sh
View File

@@ -1,161 +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 runs text section compose tree-edit move block-path clone query toc anchor outline flatten transform normalize find-replace stats summary index table callout media data wire validate sanitize 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/block-path.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/runs.sx")
(load "lib/content/validate.sx")
(load "lib/content/sanitize.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 ]

71
lib/content/crdt-store.sx
View File

@@ -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))))

193
lib/content/crdt-tree.sx
View File

@@ -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))))

378
lib/content/crdt.sx
View File

@@ -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))))))

79
lib/content/data.sx
View File

@@ -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))))

257
lib/content/doc.sx
View File

@@ -1,257 +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).
;;
;; By-id ops (update/delete) and by-id lookup (doc-find-deep/doc-has-deep?) are
;; TREE-WIDE: they descend into any block carrying a `children` list (i.e.
;; sections), since ids are unique across the tree. This keeps the persist
;; op-log, content/edit and content/find correct for nested documents.
;; insert/move are positional and act at the top level.
;;
;; CtDoc also carries optional metadata (title/slug/tags) — see meta.sx.
;;
;; Op shapes (data, not objects — they are the persist event payload):
;; {:op "insert" :block <blk> :after <id|nil>} ; after nil = prepend (top level)
;; {:op "update" :id <id> :field <name> :value <v>} ; tree-wide by id
;; {:op "move" :id <id> :index <n>} ; top level
;; {:op "delete" :id <id>} ; tree-wide by 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))))))
;; tree-wide remove by id: drop matches at this level, recurse into children
;; (blocks carrying a `children` list, i.e. sections).
(define
ct-remove-id
(fn
(blocks id)
(map
(fn
(b)
(let
((ch (st-iv-get b "children")))
(if (list? ch) (st-iv-set! b "children" (ct-remove-id ch id)) b)))
(filter (fn (b) (if (= (blk-id b) id) false true)) blocks))))
;; tree-wide replace by id: apply f to the match wherever it sits in the tree.
(define
ct-replace-id
(fn
(blocks id f)
(map
(fn
(b)
(if
(= (blk-id b) id)
(f b)
(let
((ch (st-iv-get b "children")))
(if
(list? ch)
(st-iv-set! b "children" (ct-replace-id ch id f))
b))))
blocks)))
;; tree-wide find by id: first block matching id anywhere in the tree, or nil.
;; Descends into any `children` list, mirroring ct-replace-id/ct-remove-id.
(define
ct-find-id
(fn
(blocks id)
(if
(= (len blocks) 0)
nil
(let
((b (first blocks)))
(if
(= (blk-id b) id)
b
(let
((ch (st-iv-get b "children")))
(let
((nested (if (list? ch) (ct-find-id ch id) nil)))
(if (= nested nil) (ct-find-id (rest blocks) id) nested))))))))
;; ── query ──
(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)))
;; tree-wide lookup by id — reads a nested block by the same id content/edit can
;; update/delete (no section.sx dependency; uses the generic children descent).
(define doc-find-deep (fn (doc id) (ct-find-id (doc-blocks doc) id)))
(define
doc-has-deep?
(fn (doc id) (if (= (doc-find-deep doc id) nil) false true)))
;; ── structural edits (each returns a new document) ──
(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))))

68
lib/content/fed.sx
View File

@@ -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)))

97
lib/content/find-replace.sx
View File

@@ -1,97 +0,0 @@
;; content-on-sx — global find/replace across every text-bearing field.
;;
;; Replaces every occurrence of `from` with `to` in the text-bearing fields of
;; a document, tree-wide (via the transform layer):
;; - the `text` of text / heading / code / quote / callout blocks
;; - the `alt` of image blocks
;; - each item of list blocks
;; - every header and cell of table blocks
;; This is exactly the set asText / stats / summary draw prose from, so a rename
;; via content/find-replace and a word count over asText stay consistent.
;; Immutable; case-sensitive.
;;
;; A text field may be a plain string OR a list of rich-text runs (Phase 5,
;; run = (text marks href)). fr-rep-text rewrites per run, preserving each run's
;; marks/href; a match that physically straddles two runs is not joined (the
;; replacement would have no single mark set) — each run is rewritten in place.
;;
;; Requires (loaded by harness): block.sx, transform.sx (content/map-blocks),
;; table.sx (CtTable ivars).
(define
fr-in?
(fn
(x xs)
(cond
((= (len xs) 0) false)
((= (first xs) x) true)
(else (fr-in? x (rest xs))))))
(define fr-rep (fn (s from to) (replace (str s) from to)))
;; rewrite a text-bearing field that is either a plain string or a runs list
(define
fr-rep-text
(fn
(v from to)
(if
(list? v)
(map
(fn
(r)
(list
(fr-rep (nth r 0) from to)
(nth r 1)
(nth r 2)))
v)
(fr-rep v from to))))
;; Blocks whose prose content find/replace rewrites (matches asText's set).
(define
fr-has-text?
(fn
(b)
(fr-in?
(blk-type b)
(list "text" "heading" "code" "quote" "callout" "image" "list" "table"))))
;; Per-type field rewrite. Each branch returns a new (copy-on-write) block.
(define
fr-rewrite
(fn
(b from to)
(let
((t (blk-type b)))
(cond
((= t "image")
(blk-set b "alt" (fr-rep (blk-get b "alt") from to)))
((= t "list")
(let
((items (blk-get b "items")))
(if
(list? items)
(blk-set b "items" (map (fn (it) (fr-rep it from to)) items))
b)))
((= t "table")
(let
((hs (blk-get b "headers")) (rs (blk-get b "rows")))
(let
((b1 (if (list? hs) (blk-set b "headers" (map (fn (h) (fr-rep h from to)) hs)) b)))
(if
(list? rs)
(blk-set
b1
"rows"
(map
(fn
(r)
(if (list? r) (map (fn (c) (fr-rep c from to)) r) r))
rs))
b1))))
(else (blk-set b "text" (fr-rep-text (blk-get b "text") from to)))))))
(define
content/find-replace
(fn
(doc from to)
(content/map-blocks doc fr-has-text? (fn (b) (fr-rewrite b from to)))))

34
lib/content/flatten.sx
View File

@@ -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)))))

51
lib/content/index.sx
View File

@@ -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))))))

55
lib/content/markdown.sx
View File

@@ -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 ^ '![' , alt , '](' , src , ')'")
(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)

63
lib/content/md-doc.sx
View File

@@ -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))))))

449
lib/content/md-import.sx
View File

@@ -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})

52
lib/content/media.sx
View File

@@ -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)))

53
lib/content/meta.sx
View File

@@ -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)

128
lib/content/move.sx
View File

@@ -1,128 +0,0 @@
;; content-on-sx — block reorder + reparent.
;;
;; Relative reorder of top-level blocks (move-before/after/to-front/to-back by
;; id) plus TREE reparenting: move a block into a section (content/move-into) or
;; promote a nested block back out to the top level (content/promote). Reparent
;; ops are tree-wide (the block may start anywhere) and cycle-safe — moving a
;; block into its own descendant is rejected (no-op), so a section can never
;; become its own ancestor. No-op if any id is missing. Immutable; composes the
;; doc.sx list + tree helpers (doc-find-deep / ct-find-id / ct-remove-id /
;; ct-replace-id / ct-insert-at).
;;
;; 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)))))))
;; ── reparent (tree-wide) ──
;; move block `id` (from anywhere in the tree) to be a child of section
;; `section-id` at index `i`. No-op if either id is missing, if id = section-id,
;; or if section-id sits inside id's own subtree (would create a cycle).
(define
content/move-into
(fn
(doc id section-id i)
(let
((blk (doc-find-deep doc id)))
(if
(= blk nil)
doc
(if
(= (doc-find-deep doc section-id) nil)
doc
(if
(= id section-id)
doc
(if
(= (ct-find-id (list blk) section-id) nil)
(let
((without (ct-remove-id (doc-blocks doc) id)))
(doc-with-blocks
doc
(ct-replace-id
without
section-id
(fn
(sec)
(let
((ch (st-iv-get sec "children")))
(if
(list? ch)
(st-iv-set! sec "children" (ct-insert-at ch i blk))
sec))))))
doc)))))))
;; promote block `id` (wherever it sits) out to the end of the top level. If it
;; is already top-level this is a move-to-back. No-op if missing. A section keeps
;; its whole subtree.
(define
content/promote
(fn
(doc id)
(let
((blk (doc-find-deep doc id)))
(if
(= blk nil)
doc
(doc-with-blocks
doc
(append (ct-remove-id (doc-blocks doc) id) (list blk)))))))

49
lib/content/normalize.sx
View File

@@ -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)))))

34
lib/content/outline.sx
View File

@@ -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)))

23
lib/content/page-full.sx
View File

@@ -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>")))

26
lib/content/page.sx
View File

@@ -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>")))

75
lib/content/query.sx
View File

@@ -1,75 +0,0 @@
;; content-on-sx — block query + table of contents.
;;
;; Collect blocks across the whole tree (descending into sections) by predicate
;; or type, search them by prose, 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, text.sx (asText for search).
(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))))
;; Blocks (tree-wide, excluding section containers) whose own prose contains
;; `term`. "Prose" is (asText b), so search covers exactly what every block
;; exposes as text — text/heading/code/quote/callout text, image alt, list
;; items, table headers+cells — with no separate field list to drift from
;; asText / find-replace / stats. Case-sensitive substring match.
(define
content/search-text
(fn
(doc term)
(content/select
doc
(fn
(b)
(and
(not (qry-section? b))
(>= (index-of (asText b) term) 0))))))
;; Same search, returning matching block ids in document order.
(define
content/search-text-ids
(fn
(doc term)
(map (fn (b) (blk-id b)) (content/search-text doc term))))
;; table of contents: {:id :level :text} for every heading, in document order.
(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"))))

99
lib/content/render.sx
View File

@@ -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 , '&amp;'] ifFalse: [(c = $<) ifTrue: [out := out , '&lt;'] ifFalse: [(c = $>) ifTrue: [out := out , '&gt;'] ifFalse: [(c = $\") ifTrue: [out := out , '&quot;'] 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)

118
lib/content/runs.sx
View File

@@ -1,118 +0,0 @@
;; content-on-sx — Phase 5: rich inline text (structured runs).
;;
;; A CtText's `text` ivar may be EITHER a plain string (backward compat) OR a
;; list of inline RUNS. A run is a 3-element list (text marks href):
;; text — a string
;; marks — a list of mark tokens, a subset of
;; :bold :italic :underline :strikethrough :code :subscript
;; :superscript :link (SX keywords evaluate to the strings the
;; Smalltalk renderer compares against; build them with keywords)
;; href — a string ("" when absent; the link target for a :link mark)
;;
;; Runs are a LIST, not a {:text :marks} dict, because rendering happens inside
;; the Smalltalk render methods (nested blocks dispatch asHTML/etc. via Smalltalk
;; message sends) and the Smalltalk-on-SX layer can iterate SX lists but cannot
;; read SX dict fields. Lists are Smalltalk-native, render under nesting, and
;; round-trip through data/wire for free.
;;
;; content-bootstrap-runs! OVERRIDES the render/markdown/text methods of CtText
;; and its subclasses (CtHeading/CtQuote rich; CtCode verbatim — runs render as
;; plain concatenated text) with run-aware versions that produce IDENTICAL output
;; for a plain-string body. Opt-in: call after the render/markdown/text
;; bootstraps; suites that don't call it are unaffected.
;;
;; Requires (loaded by harness): block.sx, render.sx, markdown.sx, text.sx.
;; ── SX-side run helpers ──
(define mk-run (fn (text marks href) (list text marks href)))
(define mk-run-plain (fn (text) (list text (list) "")))
(define run-text (fn (r) (nth r 0)))
(define run-marks (fn (r) (nth r 1)))
(define run-href (fn (r) (nth r 2)))
;; a CtText body is "rich" iff it is a runs list (vs a plain string)
(define runs? (fn (v) (list? v)))
;; build a CtText whose body is a list of runs
(define
mk-rich-text
(fn (id runs) (st-iv-set! (mk-text id "") "text" runs)))
(define
content-bootstrap-runs!
(fn
()
(begin
(ct-def-method!
"CtText"
"runHtml:"
"runHtml: run | frag marks href | frag := (run at: 1) htmlEscaped. marks := run at: 2. href := run at: 3. marks do: [:m | (m = 'bold') ifTrue: [frag := '<strong>' , frag , '</strong>']. (m = 'italic') ifTrue: [frag := '<em>' , frag , '</em>']. (m = 'underline') ifTrue: [frag := '<u>' , frag , '</u>']. (m = 'strikethrough') ifTrue: [frag := '<s>' , frag , '</s>']. (m = 'code') ifTrue: [frag := '<code>' , frag , '</code>']. (m = 'subscript') ifTrue: [frag := '<sub>' , frag , '</sub>']. (m = 'superscript') ifTrue: [frag := '<sup>' , frag , '</sup>']. (m = 'link') ifTrue: [frag := '<a href=\"' , href htmlEscaped , '\">' , frag , '</a>']]. ^ frag")
(ct-def-method!
"CtText"
"runSx:"
"runSx: run | frag marks href | frag := '\"' , (run at: 1) sxEscaped , '\"'. marks := run at: 2. href := run at: 3. marks do: [:m | (m = 'bold') ifTrue: [frag := '(strong ' , frag , ')']. (m = 'italic') ifTrue: [frag := '(em ' , frag , ')']. (m = 'underline') ifTrue: [frag := '(u ' , frag , ')']. (m = 'strikethrough') ifTrue: [frag := '(s ' , frag , ')']. (m = 'code') ifTrue: [frag := '(code ' , frag , ')']. (m = 'subscript') ifTrue: [frag := '(sub ' , frag , ')']. (m = 'superscript') ifTrue: [frag := '(sup ' , frag , ')']. (m = 'link') ifTrue: [frag := '(a :href \"' , href sxEscaped , '\" ' , frag , ')']]. ^ frag")
(ct-def-method!
"CtText"
"runMd:"
"runMd: run | frag marks href | frag := (run at: 1). marks := run at: 2. href := run at: 3. marks do: [:m | (m = 'bold') ifTrue: [frag := '**' , frag , '**']. (m = 'italic') ifTrue: [frag := '_' , frag , '_']. (m = 'strikethrough') ifTrue: [frag := '~~' , frag , '~~']. (m = 'code') ifTrue: [frag := '`' , frag , '`']. (m = 'underline') ifTrue: [frag := '<u>' , frag , '</u>']. (m = 'subscript') ifTrue: [frag := '<sub>' , frag , '</sub>']. (m = 'superscript') ifTrue: [frag := '<sup>' , frag , '</sup>']. (m = 'link') ifTrue: [frag := '[' , frag , '](' , href , ')']]. ^ frag")
(ct-def-method!
"CtText"
"inlineHtml"
"inlineHtml | out | (text class name = 'String') ifTrue: [^ text htmlEscaped]. out := ''. text do: [:run | out := out , (self runHtml: run)]. ^ out")
(ct-def-method!
"CtText"
"inlineSx"
"inlineSx | out | (text class name = 'String') ifTrue: [^ '\"' , text sxEscaped , '\"']. out := ''. text do: [:run | out := (out = '' ifTrue: [self runSx: run] ifFalse: [out , ' ' , (self runSx: run)])]. ^ out")
(ct-def-method!
"CtText"
"inlineMd"
"inlineMd | out | (text class name = 'String') ifTrue: [^ text]. out := ''. text do: [:run | out := out , (self runMd: run)]. ^ out")
(ct-def-method!
"CtText"
"inlineText"
"inlineText | out | (text class name = 'String') ifTrue: [^ text]. out := ''. text do: [:run | out := out , (run at: 1)]. ^ out")
(ct-def-method!
"CtText"
"asHTML"
"asHTML ^ '<p>' , self inlineHtml , '</p>'")
(ct-def-method! "CtText" "asSx" "asSx ^ '(p ' , self inlineSx , ')'")
(ct-def-method! "CtText" "asMarkdown:" "asMarkdown: nl ^ self inlineMd")
(ct-def-method! "CtText" "asText" "asText ^ self inlineText")
(ct-def-method!
"CtHeading"
"asHTML"
"asHTML | t | t := level printString. ^ '<h' , t , '>' , self inlineHtml , '</h' , t , '>'")
(ct-def-method!
"CtHeading"
"asSx"
"asSx | t | t := level printString. ^ '(h' , t , ' ' , self inlineSx , ')'")
(ct-def-method!
"CtHeading"
"asMarkdown:"
"asMarkdown: nl | h i | h := ''. i := 0. [i < level] whileTrue: [h := h , '#'. i := i + 1]. ^ h , ' ' , self inlineMd")
(ct-def-method! "CtHeading" "asText" "asText ^ self inlineText")
(ct-def-method!
"CtQuote"
"asHTML"
"asHTML ^ '<blockquote>' , self inlineHtml , '</blockquote>'")
(ct-def-method!
"CtQuote"
"asSx"
"asSx ^ '(blockquote ' , self inlineSx , ')'")
(ct-def-method!
"CtQuote"
"asMarkdown:"
"asMarkdown: nl ^ '> ' , self inlineMd")
(ct-def-method! "CtQuote" "asText" "asText ^ self inlineText")
(ct-def-method!
"CtCode"
"asHTML"
"asHTML ^ '<pre><code class=\"language-' , language htmlEscaped , '\">' , self inlineText htmlEscaped , '</code></pre>'")
(ct-def-method!
"CtCode"
"asSx"
"asSx ^ '(pre (code \"' , self inlineText sxEscaped , '\"))'")
(ct-def-method!
"CtCode"
"asMarkdown:"
"asMarkdown: nl ^ '```' , language , nl , self inlineText , nl , '```'")
(ct-def-method! "CtCode" "asText" "asText ^ self inlineText")
true)))

47
lib/content/sanitize.sx
View File

@@ -1,47 +0,0 @@
;; content-on-sx — make a document render-safe by dropping invalid blocks.
;;
;; The enforcement counterpart to validate: where content/validate REPORTS id /
;; field issues, content/sanitize REMOVES the offending blocks so the result can
;; be rendered/merged without faulting on malformed input (federated or imported
;; documents that failed validation). Tree-wide: descends into sections, pruning
;; invalid descendants; a section whose own shell is valid is kept (even if it
;; ends up empty — that is normalize's job, not sanitize's), but a section whose
;; own check fails (e.g. children is not a list) is dropped whole.
;;
;; Reuses validate's per-block predicate (content/-block-issues), so the set of
;; "what is invalid" stays single-sourced and can't drift from content/validate.
;; sanitize addresses per-block id/field validity only; it does NOT resolve
;; duplicate ids (a cross-block concern with no single right answer), so a
;; sanitized doc is render-safe but not necessarily content/valid? if the input
;; carried duplicate ids. Immutable; returns a new document.
;;
;; Requires (loaded by harness): block.sx, doc.sx, validate.sx
;; (content/-block-issues).
(define
san-section?
(fn (b) (and (st-instance? b) (= (get b :class) "CtSection"))))
;; a block is render-safe when it has no id/field issues (validate's own checks)
(define san-ok? (fn (b) (= (len (content/-block-issues b)) 0)))
;; drop invalid blocks at this level; recurse into surviving sections so invalid
;; descendants are pruned too.
(define
san-blocks
(fn
(blocks)
(map
(fn
(b)
(if
(san-section? b)
(let
((ch (st-iv-get b "children")))
(if (list? ch) (st-iv-set! b "children" (san-blocks ch)) b))
b))
(filter san-ok? blocks))))
(define
content/sanitize
(fn (doc) (doc-with-blocks doc (san-blocks (doc-blocks doc)))))

51
lib/content/scoreboard.json
View File

@@ -1,51 +0,0 @@
{
"suites": {
"block": {"pass": 38, "fail": 0},
"doc": {"pass": 40, "fail": 0},
"render": {"pass": 42, "fail": 0},
"api": {"pass": 32, "fail": 0},
"meta": {"pass": 27, "fail": 0},
"page": {"pass": 7, "fail": 0},
"page-full": {"pass": 4, "fail": 0},
"markdown": {"pass": 20, "fail": 0},
"runs": {"pass": 36, "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": 24, "fail": 0},
"block-path": {"pass": 13, "fail": 0},
"clone": {"pass": 10, "fail": 0},
"query": {"pass": 20, "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": 16, "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": 32, "fail": 0},
"sanitize": {"pass": 12, "fail": 0},
"store": {"pass": 46, "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": 861,
"total_fail": 0,
"total": 861
}

51
lib/content/scoreboard.md
View File

@@ -1,51 +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 | 32 | 0 | 32 |
| meta | 27 | 0 | 27 |
| page | 7 | 0 | 7 |
| page-full | 4 | 0 | 4 |
| markdown | 20 | 0 | 20 |
| runs | 36 | 0 | 36 |
| text | 20 | 0 | 20 |
| section | 25 | 0 | 25 |
| compose | 17 | 0 | 17 |
| tree-edit | 17 | 0 | 17 |
| move | 24 | 0 | 24 |
| block-path | 13 | 0 | 13 |
| clone | 10 | 0 | 10 |
| query | 20 | 0 | 20 |
| 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 | 16 | 0 | 16 |
| 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 | 32 | 0 | 32 |
| sanitize | 12 | 0 | 12 |
| store | 46 | 0 | 46 |
| 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** | **861** | **0** | **861** |

103
lib/content/section.sx
View File

@@ -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))))

90
lib/content/snapshot.sx
View File

@@ -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))))))

49
lib/content/stats.sx
View File

@@ -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)}))

110
lib/content/store.sx
View File

@@ -1,110 +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, section.sx (doc-deep-find
;; + doc-tree-ids, for the tree-wide diff), plus 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 ──
;; Tree-wide: ids are enumerated across the whole block tree (descending into
;; sections), so nested-block adds/removes/changes are detected, not just
;; top-level ones. Returns {:added :removed :changed} (lists of ids):
;; :added — ids present (anywhere) in `new` but not in `old`
;; :removed — ids present (anywhere) in `old` but not in `new`
;; :changed — content blocks present in both whose block value differs
;; Section containers never appear in :changed (they hold no own content — a
;; child change surfaces as that child's own entry); a whole section appearing
;; or disappearing shows up in :added / :removed by its id.
(define content/-all-ids (fn (doc) (doc-tree-ids doc)))
(define content/-missing? (fn (doc id) (= (doc-deep-find doc id) nil)))
(define
content/-changed
(fn
(old new)
(filter
(fn
(id)
(let
((bo (doc-deep-find old id)) (bn (doc-deep-find new id)))
(cond
((= bo nil) false)
((= bn nil) false)
((= (blk-type bo) "section") false)
((= bo bn) false)
(else true))))
(content/-all-ids old))))
(define content/diff (fn (old new) {:changed (content/-changed old new) :removed (filter (fn (id) (content/-missing? new id)) (content/-all-ids old)) :added (filter (fn (id) (content/-missing? old id)) (content/-all-ids new))}))
;; convenience: diff two persisted versions by seq.
(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))))

26
lib/content/summary.sx
View File

@@ -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)}))

74
lib/content/sync.sx
View File

@@ -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})

54
lib/content/table.sx
View File

@@ -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))))

58
lib/content/tests/anchor.sx
View File

@@ -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 &lt; 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>")

133
lib/content/tests/api.sx
View File

@@ -1,133 +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>")
;; ── facade find/has? are TREE-WIDE (reach into sections); find-top/has-top?
;; keep the top-level-only lookup. This makes the read-by-id surface consistent
;; with content/edit, whose update/delete are already tree-wide. ──
(content-bootstrap-section!)
(define
nd
(content/append
(content/empty "nested")
(mk-section
"sec"
(list (content/block "text" "inner" (list (list "text" "deep")))))))
(content-test
"find nested (deep)"
(blk-id (content/find nd "inner"))
"inner")
(content-test "has? nested (deep)" (content/has? nd "inner") true)
(content-test "find-top misses nested" (content/find-top nd "inner") nil)
(content-test "has-top? misses nested" (content/has-top? nd "inner") false)
(content-test
"find-top sees top-level"
(blk-id (content/find-top nd "sec"))
"sec")
;; a nested block updated by id via content/edit is now readable by id via
;; content/find (was impossible when find was top-level-only).
(content-test
"edit-then-find nested round-trip"
(str
(blk-send
(content/find
(content/edit nd (content/update "inner" "text" "edited"))
"inner")
"text"))
"edited")

59
lib/content/tests/block-path.sx
View File

@@ -1,59 +0,0 @@
;; Extension — locate a block in the tree (ancestor section path).
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-section!)
;; doc: top-level "a", section "s" containing "x" and nested section "i"
;; containing "z".
(define
d
(doc-append
(doc-append (doc-empty "d") (mk-text "a" "A"))
(mk-section
"s"
(list (mk-text "x" "X") (mk-section "i" (list (mk-text "z" "Z")))))))
;; ── block-path ──
(content-test
"top-level block has empty path"
(content/block-path d "a")
(list))
(content-test "one-deep block path" (content/block-path d "x") (list "s"))
(content-test
"two-deep block path"
(content/block-path d "z")
(list "s" "i"))
(content-test "section's own path" (content/block-path d "i") (list "s"))
(content-test "missing id path nil" (content/block-path d "zzz") nil)
;; nil (absent) is distinct from () (present top-level)
(content-test
"absent vs top-level distinguishable"
(if (= (content/block-path d "a") nil) "nil" "list")
"list")
;; ── block-depth ──
(content-test "depth top-level" (content/block-depth d "a") 0)
(content-test "depth one" (content/block-depth d "x") 1)
(content-test "depth two" (content/block-depth d "z") 2)
(content-test "depth section" (content/block-depth d "i") 1)
(content-test "depth absent" (content/block-depth d "zzz") -1)
;; ── path tracks reparenting (composes with move.sx) ──
;; (rebuild expectation directly; move tested elsewhere)
(define
flat
(doc-append
(doc-append (doc-empty "d") (mk-section "sec" (list)))
(mk-text "p" "P")))
(content-test
"before: p at top level"
(content/block-depth flat "p")
0)
;; ── empty doc ──
(content-test
"empty doc path nil"
(content/block-path (doc-empty "e") "x")
nil)

75
lib/content/tests/block.sx
View File

@@ -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")

55
lib/content/tests/callout.sx
View File

@@ -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 &lt; 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"))

55
lib/content/tests/clone.sx
View File

@@ -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>")

76
lib/content/tests/compose.sx
View File

@@ -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>")

136
lib/content/tests/crdt-blocks.sx
View File

@@ -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"))

139
lib/content/tests/crdt-store.sx
View File

@@ -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)

289
lib/content/tests/crdt-tree.sx
View File

@@ -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>")

315
lib/content/tests/crdt.sx
View File

@@ -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)

116
lib/content/tests/data.sx
View File

@@ -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)

132
lib/content/tests/doc.sx
View File

@@ -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"))

148
lib/content/tests/fed.sx
View File

@@ -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")

148
lib/content/tests/find-replace.sx
View File

@@ -1,148 +0,0 @@
;; Extension — global find/replace across every text-bearing field.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-section!)
(content-bootstrap-callout!)
(content-bootstrap-table!)
(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")
;; ── image alt IS a text field (asText ^ alt), so it is rewritten ──
(content-test
"image alt replaced"
(str (blk-send (doc-deep-find r "img") "alt"))
"Bar alt")
;; ── but src is a URL, not prose, so it stays put ──
(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")
;; ── callout text is covered (consistency with asText/stats/summary) ──
(content-test
"replace callout text"
(str
(blk-send
(doc-find
(content/find-replace
(doc-append (doc-empty "d") (mk-callout "co" "note" "Foo here"))
"Foo"
"Bar")
"co")
"text"))
"Bar here")
(content-test
"callout kind untouched by text replace"
(str
(blk-send
(doc-find
(content/find-replace
(doc-append (doc-empty "d") (mk-callout "co" "note" "x"))
"note"
"X")
"co")
"kind"))
"note")
;; ── list items are rewritten (asText folds items) ──
(define
rl
(content/find-replace
(doc-append
(doc-empty "d")
(mk-list "l" false (list "Foo one" "two Foo")))
"Foo"
"Bar"))
(content-test
"replace first list item"
(str (first (blk-send (doc-find rl "l") "items")))
"Bar one")
(content-test
"replace second list item"
(str (first (rest (blk-send (doc-find rl "l") "items"))))
"two Bar")
;; ── table headers + cells are rewritten (asText folds rows) ──
(define
rt
(content/find-replace
(doc-append
(doc-empty "d")
(mk-table "t" (list "Foo head") (list (list "a Foo" "b"))))
"Foo"
"Bar"))
(content-test
"replace table header"
(str (first (table-headers (doc-find rt "t"))))
"Bar head")
(content-test
"replace table cell"
(str (first (first (table-rows (doc-find rt "t")))))
"a Bar")
;; ── no match → unchanged render ──
(content-test
"no match"
(asHTML (content/find-replace d "zzz" "qqq"))
(asHTML d))

72
lib/content/tests/flatten.sx
View File

@@ -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))

61
lib/content/tests/index.sx
View File

@@ -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))

79
lib/content/tests/markdown.sx
View File

@@ -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"))
"![cat](/c.png)")
(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 "---"))

71
lib/content/tests/md-doc.sx
View File

@@ -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"))

206
lib/content/tests/md-import.sx
View File

@@ -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)

59
lib/content/tests/media.sx
View File

@@ -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&amp;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"))

79
lib/content/tests/meta.sx
View File

@@ -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")

145
lib/content/tests/move.sx
View File

@@ -1,145 +0,0 @@
;; Extension — relative block reorder + tree reparent.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-section!)
(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>")
;; ── reparent: move a top-level block INTO a section ──
(define
nd
(doc-append
(doc-append (doc-empty "d") (mk-text "p" "P"))
(mk-section "s" (list (mk-text "x" "X")))))
(content-test
"move-into: block leaves top level"
(doc-ids (content/move-into nd "p" "s" 1))
(list "s"))
(content-test
"move-into: block lands in section at index"
(doc-tree-ids (content/move-into nd "p" "s" 1))
(list "s" "x" "p"))
(content-test
"move-into at front of section"
(doc-tree-ids (content/move-into nd "p" "s" 0))
(list "s" "p" "x"))
(content-test "move-into immutable" (doc-tree-ids nd) (list "p" "s" "x"))
;; ── reparent: move a NESTED block to a different section ──
(define
two
(doc-append
(doc-append (doc-empty "d") (mk-section "s1" (list (mk-text "n" "N"))))
(mk-section "s2" (list (mk-text "y" "Y")))))
(content-test
"move-into across sections"
(doc-tree-ids (content/move-into two "n" "s2" 1))
(list "s1" "s2" "y" "n"))
;; ── promote: nested block out to top level (appended last) ──
(content-test
"promote nested to top level"
(doc-tree-ids (content/promote two "n"))
(list "s1" "s2" "y" "n"))
(content-test
"promote leaves section empty shell"
(doc-ids (content/promote two "n"))
(list "s1" "s2" "n"))
(content-test
"promote a whole section keeps its subtree"
(doc-tree-ids
(content/promote
(doc-append
(doc-empty "d")
(mk-section "o" (list (mk-section "i" (list (mk-text "z" "Z"))))))
"i"))
(list "o" "i" "z"))
;; ── cycle guard: cannot move a section into its own descendant ──
(define
nest
(doc-append
(doc-empty "d")
(mk-section
"outer"
(list (mk-section "inner" (list (mk-text "t" "T")))))))
(content-test
"move section into its own child is a no-op"
(doc-tree-ids (content/move-into nest "outer" "inner" 0))
(list "outer" "inner" "t"))
(content-test
"move block into itself is a no-op"
(doc-tree-ids (content/move-into nest "inner" "inner" 0))
(list "outer" "inner" "t"))
;; ── reparent no-ops on missing ids ──
(content-test
"move-into missing block no-op"
(doc-tree-ids (content/move-into nd "zzz" "s" 0))
(list "p" "s" "x"))
(content-test
"move-into missing section no-op"
(doc-tree-ids (content/move-into nd "p" "zzz" 0))
(list "p" "s" "x"))
(content-test
"promote missing no-op"
(doc-tree-ids (content/promote nd "zzz"))
(list "p" "s" "x"))

99
lib/content/tests/normalize.sx
View File

@@ -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"))

78
lib/content/tests/outline.sx
View File

@@ -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"))

39
lib/content/tests/page-full.sx
View File

@@ -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 &lt; b &amp; c\"></head><body><p>a &lt; b &amp; 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>")

42
lib/content/tests/page.sx
View File

@@ -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 &lt; 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>")

138
lib/content/tests/query.sx
View File

@@ -1,138 +0,0 @@
;; Extension — block query + table of contents + prose search.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-text!)
(content-bootstrap-section!)
(content-bootstrap-table!)
(content-bootstrap-callout!)
(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)
;; ── prose search (content/search-text) ──
;; "cat" appears in text, image alt, a list item, a table cell, and a callout
;; — every text-bearing field — so search must find all five via asText.
(define
sd
(doc-append
(doc-append
(doc-append
(doc-append
(doc-append
(doc-empty "sd")
(mk-heading "sh" 1 "Welcome aboard"))
(mk-text "st" "the cat sat"))
(mk-image "si" "/x.png" "a cat photo"))
(mk-list "sl" false (list "first cat" "second dog")))
(mk-section
"sec"
(list
(mk-table "stb" (list "Animal") (list (list "cat") (list "fish")))
(mk-callout "sc" "note" "beware of cat")))))
(content-test
"search across every text-bearing field"
(content/search-text-ids sd "cat")
(list "st" "si" "sl" "stb" "sc"))
(content-test "search count" (len (content/search-text sd "cat")) 5)
(content-test
"search heading text"
(content/search-text-ids sd "Welcome")
(list "sh"))
(content-test
"search list item only"
(content/search-text-ids sd "dog")
(list "sl"))
(content-test "search no match" (content/search-text-ids sd "zzz") (list))
;; section containers are excluded — a term living only inside a section's
;; children returns the child, never the section wrapper.
(content-test
"search excludes section wrapper"
(content/search-text-ids sd "fish")
(list "stb"))
(content-test
"search returns block objects"
(blk-id (first (content/search-text sd "Welcome")))
"sh")

135
lib/content/tests/render.sx
View File

@@ -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 &lt; B &amp; &quot;C&quot;</h2>")
(content-test
"escape paragraph"
(asHTML xp)
"<p>&lt;script&gt;alert(1)&lt;/script&gt;</p>")
(content-test
"escape image attrs"
(asHTML xi)
"<img src=\"/a.png?x=1&amp;y=2\" alt=\"tag &lt;b&gt;\">")
(content-test
"escape list items"
(asHTML xl)
"<ul><li>a&lt;1</li><li>b&amp;2</li></ul>")
(content-test
"escape ampersand once"
(asHTML (mk-text "amp" "a & b"))
"<p>a &amp; b</p>")
(content-test
"escape in document"
(asHTML (doc-append (doc-empty "e") xp))
"<p>&lt;script&gt;alert(1)&lt;/script&gt;</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\">&lt;div&gt; &amp; &lt;/div&gt;</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 "))"))

227
lib/content/tests/runs.sx
View File

@@ -1,227 +0,0 @@
;; Phase 5 — rich inline text (structured runs). Acceptance suite.
(st-bootstrap-classes!)
(content/bootstrap!)
(content-bootstrap-markdown!)
(content-bootstrap-text!)
(content-bootstrap-section!)
(content-bootstrap-runs!)
;; one-run helper: a CtText with a single marked run
(define
one
(fn (marks href) (mk-rich-text "p" (list (mk-run "x" marks href)))))
;; ── (1) four render modes ──
;; a paragraph mixing plain + bold + a link
(define
rd
(doc-append
(doc-empty "d")
(mk-rich-text
"p"
(list
(mk-run "the " (list) "")
(mk-run "cat" (list :bold) "")
(mk-run " and " (list) "")
(mk-run "dog" (list :italic :link) "/d")
(mk-run " sat" (list) "")))))
(define p (doc-find rd "p"))
(content-test
"asHTML rich"
(asHTML rd)
"<p>the <strong>cat</strong> and <a href=\"/d\"><em>dog</em></a> sat</p>")
(content-test
"asMarkdown rich"
(asMarkdown rd)
"the **cat** and [_dog_](/d) sat")
(content-test
"asSx rich"
(asSx rd)
"(article (p \"the \" (strong \"cat\") \" and \" (a :href \"/d\" (em \"dog\")) \" sat\"))")
(content-test
"asText rich is plain (no markup)"
(asText rd)
"the cat and dog sat")
;; every mark renders in HTML
(content-test
"mark bold html"
(asHTML (one (list :bold) ""))
"<p><strong>x</strong></p>")
(content-test
"mark italic html"
(asHTML (one (list :italic) ""))
"<p><em>x</em></p>")
(content-test
"mark underline html"
(asHTML (one (list :underline) ""))
"<p><u>x</u></p>")
(content-test
"mark strike html"
(asHTML (one (list :strikethrough) ""))
"<p><s>x</s></p>")
(content-test
"mark code html"
(asHTML (one (list :code) ""))
"<p><code>x</code></p>")
(content-test
"mark sub html"
(asHTML (one (list :subscript) ""))
"<p><sub>x</sub></p>")
(content-test
"mark sup html"
(asHTML (one (list :superscript) ""))
"<p><sup>x</sup></p>")
(content-test
"mark link html"
(asHTML (one (list :link) "/u"))
"<p><a href=\"/u\">x</a></p>")
;; markdown marks
(content-test "mark bold md" (asMarkdown (one (list :bold) "")) "**x**")
(content-test "mark italic md" (asMarkdown (one (list :italic) "")) "_x_")
(content-test
"mark strike md"
(asMarkdown (one (list :strikethrough) ""))
"~~x~~")
(content-test "mark code md" (asMarkdown (one (list :code) "")) "`x`")
(content-test "mark link md" (asMarkdown (one (list :link) "/u")) "[x](/u)")
(content-test
"mark underline md fallback"
(asMarkdown (one (list :underline) ""))
"<u>x</u>")
;; nested marks (bold+italic) — deterministic nesting order
(content-test
"nested marks html"
(asHTML (one (list :bold :italic) ""))
"<p><em><strong>x</strong></em></p>")
;; escaping still happens inside runs
(content-test
"run text escaped html"
(asHTML (mk-rich-text "p" (list (mk-run "a & b <c>" (list :bold) ""))))
"<p><strong>a &amp; b &lt;c&gt;</strong></p>")
;; rich heading + quote + code
(content-test
"rich heading html"
(asHTML
(st-iv-set!
(mk-heading "h" 2 "")
"text"
(list (mk-run "Big " (list) "") (mk-run "bold" (list :bold) ""))))
"<h2>Big <strong>bold</strong></h2>")
(content-test
"rich quote html"
(asHTML
(st-iv-set!
(mk-quote "q" "" "")
"text"
(list (mk-run "wise" (list :italic) ""))))
"<blockquote><em>wise</em></blockquote>")
;; code is verbatim — runs concatenate as plain text, marks ignored
(content-test
"code runs plain html"
(asHTML
(st-iv-set!
(mk-code "c" "py" "")
"text"
(list (mk-run "a=" (list :bold) "") (mk-run "1" (list) ""))))
"<pre><code class=\"language-py\">a=1</code></pre>")
;; ── (2) backward compat: plain-string CtText unchanged ──
(content-test
"plain html"
(asHTML (mk-text "q" "hi & <b>"))
"<p>hi &amp; &lt;b&gt;</p>")
(content-test "plain sx" (asSx (mk-text "q" "hi")) "(p \"hi\")")
(content-test "plain md" (asMarkdown (mk-text "q" "hi")) "hi")
(content-test "plain text" (asText (mk-text "q" "hi")) "hi")
(content-test
"plain heading html"
(asHTML (mk-heading "h" 3 "T"))
"<h3>T</h3>")
;; ── (3) find-replace across runs (per-run, marks preserved) ──
(define
frd
(doc-append
(doc-empty "d")
(mk-rich-text
"p"
(list
(mk-run "the Foo" (list :bold) "")
(mk-run " and Foo here" (list) "")))))
(define frr (content/find-replace frd "Foo" "Bar"))
(content-test
"find-replace rich plain text"
(asText frr)
"the Bar and Bar here")
(content-test
"find-replace rich preserves marks"
(asHTML frr)
"<p><strong>the Bar</strong> and Bar here</p>")
(content-test
"find-replace rich run0 still bold"
(nth (nth (blk-get (doc-find frr "p") "text") 0) 1)
(list "bold"))
;; ── (4) search-text via asText, across run boundary ──
;; "cat sat" spans run1 ("the cat") and run2 (" sat")
(define
sd
(doc-append
(doc-empty "d")
(mk-rich-text
"p"
(list (mk-run "the cat" (list :bold) "") (mk-run " sat" (list) "")))))
(content-test
"search finds substring across runs"
(content/search-text-ids sd "cat sat")
(list "p"))
(content-test "search miss" (content/search-text-ids sd "zzz") (list))
;; ── (5) CRDT invariant — runs are an opaque block-level value ──
(define ra (list (mk-run "x" (list :bold) "")))
(define rb (list (mk-run "y" (list :italic) "")))
(define
s1
(crdt-insert
(crdt-empty)
"p"
"text"
(crdt-pos 5 "a")
{:text ra}
1
"a"))
(define s2 (crdt-update s1 "p" "text" rb 2 "b"))
(content-test
"crdt merge commutes with runs"
(get (crdt-merge s1 s2) :elements)
(get (crdt-merge s2 s1) :elements))
(content-test
"crdt merge idempotent with runs"
(get (crdt-merge s2 s2) :elements)
(get s2 :elements))
;; LWW: later ts (rb, ts 2) wins; runs survive as the field value
(content-test
"crdt LWW keeps latest runs"
(asHTML
(crdt-element->block (get (get (crdt-merge s1 s2) :elements) "p")))
"<p><em>y</em></p>")
;; ── (6) data + wire round-trip runs losslessly ──
(content-test
"data round-trip rich html"
(asHTML (content/from-data (content/to-data rd)))
(asHTML rd))
(content-test
"data round-trip rich text"
(asText (content/from-data (content/to-data rd)))
"the cat and dog sat")
(content-test
"wire round-trip rich html"
(asHTML (content/from-wire (content/to-wire rd)))
(asHTML rd))

128
lib/content/tests/sanitize.sx
View File

@@ -1,128 +0,0 @@
;; Extension — make a document render-safe by dropping invalid blocks.
;; Counterpart to validate; reuses its per-block checks. Tree-wide.
(st-bootstrap-classes!)
(content-bootstrap-blocks!)
(content-bootstrap-doc!)
(content-bootstrap-section!)
;; ── a valid document is returned unchanged (same ids, tree order) ──
(define
good
(doc-append
(doc-append (doc-empty "d") (mk-heading "h" 1 "Title"))
(mk-text "p" "Body")))
(content-test
"valid doc keeps all blocks"
(doc-ids (content/sanitize good))
(list "h" "p"))
(content-test
"valid doc still valid after sanitize"
(content/valid? (content/sanitize good))
true)
;; ── a block with a bad field is dropped ──
(content-test
"bad-field block dropped"
(doc-ids
(content/sanitize
(doc-append
(doc-append (doc-empty "d") (mk-text "ok" "fine"))
(mk-heading "bad" "notnum" "T"))))
(list "ok"))
;; ── unknown block type dropped ──
(define raw (st-iv-set! (st-make-instance "CtBlock") "id" "z"))
(content-test
"unknown-type block dropped"
(doc-ids
(content/sanitize
(doc-append (doc-append (doc-empty "d") (mk-text "ok" "x")) raw)))
(list "ok"))
;; ── blank-id block dropped ──
(content-test
"blank-id block dropped"
(doc-ids
(content/sanitize
(doc-append
(doc-append (doc-empty "d") (mk-text "ok" "x"))
(mk-text "" "y"))))
(list "ok"))
;; ── result is render-safe: no id/field issues remain ──
(content-test
"sanitized has no field/id issues"
(len
(filter
(fn (i) (if (= (get i :kind) "field") true (= (get i :kind) "id")))
(content/validate
(content/sanitize
(doc-append
(doc-append (doc-empty "d") (mk-text "ok" "x"))
(mk-heading "bad" "notnum" "T"))))))
0)
;; ── immutability: original document untouched ──
(define
withbad
(doc-append
(doc-append (doc-empty "d") (mk-text "ok" "x"))
(mk-heading "bad" "notnum" "T")))
(define _ (content/sanitize withbad))
(content-test "original unchanged" (doc-ids withbad) (list "ok" "bad"))
;; ── tree-wide: invalid nested child pruned, valid sibling + section kept ──
(define
nested
(doc-append
(doc-empty "d")
(mk-section
"s"
(list (mk-text "good" "keep") (mk-heading "badc" "notnum" "X")))))
(content-test
"invalid nested child pruned, section kept"
(doc-tree-ids (content/sanitize nested))
(list "s" "good"))
;; ── a section whose own shell is invalid (children not a list) is dropped ──
(define
badsec
(doc-append
(doc-append (doc-empty "d") (mk-text "ok" "x"))
(st-iv-set! (mk-section "s" (list)) "children" "nope")))
(content-test
"invalid section shell dropped whole"
(doc-tree-ids (content/sanitize badsec))
(list "ok"))
;; ── a valid section that loses all children is kept (empty) — sanitize is not
;; normalize; it removes invalid, not empty ──
(define
allbadchildren
(doc-append
(doc-empty "d")
(mk-section "s" (list (mk-heading "b1" "x" "X") (mk-text "" "y")))))
(content-test
"section kept though emptied of invalid children"
(doc-tree-ids (content/sanitize allbadchildren))
(list "s"))
;; ── deeply nested: invalid block two levels down is pruned ──
(define
deep
(doc-append
(doc-empty "d")
(mk-section
"o"
(list (mk-section "i" (list (mk-text "dok" "x") (mk-text "" "bad")))))))
(content-test
"deep invalid pruned"
(doc-tree-ids (content/sanitize deep))
(list "o" "i" "dok"))
;; ── empty document sanitizes to empty ──
(content-test
"empty doc stays empty"
(doc-ids (content/sanitize (doc-empty "e")))
(list))

99
lib/content/tests/section.sx
View File

@@ -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"))

100
lib/content/tests/snapshot.sx
View File

@@ -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))

68
lib/content/tests/stats.sx
View File

@@ -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)

208
lib/content/tests/store.sx
View File

@@ -1,208 +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")
;; ── op-log update/delete reach NESTED blocks (tree-wide by id) ──
(content-bootstrap-section!)
(define B4 (persist/open))
(content/commit!
B4
"nest"
(op-insert (mk-section "sec" (list (mk-text "n" "orig"))) nil)
1)
(content/commit! B4 "nest" (op-update "n" "text" "edited") 2)
(content-test
"op-log nested update"
(str (blk-send (doc-deep-find (content/head B4 "nest") "n") "text"))
"edited")
(content-test
"op-log nested update tree intact"
(doc-tree-ids (content/head B4 "nest"))
(list "sec" "n"))
(content/commit! B4 "nest" (op-delete "n") 3)
(content-test
"op-log nested delete"
(doc-tree-ids (content/head B4 "nest"))
(list "sec"))
(content-test
"op-log nested delete via content/at seq2"
(doc-tree-ids (content/at B4 "nest" 2))
(list "sec" "n"))
;; ── diff is TREE-WIDE: nested-block add/change/remove are detected, and
;; section containers never appear in :changed (a top-level-only diff would miss
;; "n" entirely and instead flag the section). ──
(define dn01 (content/diff-versions B4 "nest" 0 1))
(content-test
"diff nested added (section + child)"
(get dn01 :added)
(list "sec" "n"))
(content-test "diff nested added removed empty" (get dn01 :removed) (list))
(content-test "diff nested added changed empty" (get dn01 :changed) (list))
(define dn12 (content/diff-versions B4 "nest" 1 2))
(content-test
"diff nested changed child only"
(get dn12 :changed)
(list "n"))
(content-test "diff nested changed no add" (get dn12 :added) (list))
(content-test "diff nested changed no remove" (get dn12 :removed) (list))
(define dn23 (content/diff-versions B4 "nest" 2 3))
(content-test "diff nested removed child" (get dn23 :removed) (list "n"))
(content-test "diff nested removed no change" (get dn23 :changed) (list))
(content-test
"diff nested no-op"
(get (content/diff-versions B4 "nest" 1 1) :changed)
(list))

74
lib/content/tests/summary.sx
View File

@@ -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)

74
lib/content/tests/sync.sx
View File

@@ -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