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

Compare commits

base: coop:loops/commerce
Branches Tags
coop:main coop:loops/events coop:loops/content coop:loops/fed-sx-m2 coop:loops/artdag coop:architecture coop:loops/maude 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/events coop:loops/content coop:loops/fed-sx-m2 coop:loops/artdag coop:architecture coop:loops/maude 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/comm ... 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
396 changed files with 20312 additions and 32002 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)))))

56
lib/commerce/api.sx
View File

@@ -1,56 +0,0 @@
;; lib/commerce/api.sx — public commerce surface.
;;
;; A session bundles a pricing context with a cart: {:ctx CTX :cart CART}.
;; All operations are pure and return a new session. The total and the
;; per-line breakdown are deterministic functions of (ctx, cart).
;;
;; commerce-checkout is a Phase-3 stub — the order lifecycle is a durable
;; flow that suspends at the SumUp payment boundary.
(define commerce-session (fn (ctx) {:cart empty-cart :ctx ctx}))
(define commerce-ctx (fn (sess) (get sess :ctx)))
(define commerce-cart (fn (sess) (get sess :cart)))
(define commerce-lines (fn (sess) (cart-lines (get sess :cart))))
(define commerce-count (fn (sess) (cart-count (get sess :cart))))
(define
commerce-add
(fn
(sess sku variant qty)
(assoc sess :cart (cart-add (get sess :cart) sku variant qty))))
(define
commerce-remove
(fn
(sess sku variant)
(assoc sess :cart (cart-remove (get sess :cart) sku variant))))
(define
commerce-set-qty
(fn
(sess sku variant qty)
(assoc sess :cart (cart-set-qty (get sess :cart) sku variant qty))))
;; True when the sku exists in the session's catalog snapshot.
(define
commerce-can-add?
(fn (sess sku) (catalog-has? (ctx-catalog (get sess :ctx)) sku)))
(define
commerce-total
(fn (sess) (cart-total (get sess :ctx) (get sess :cart))))
;; Per-line audit breakdown — the "which line contributed what" view.
(define
line-detail
(fn (ctx line) (let ((cat (ctx-catalog ctx))) {:sku (line-sku line) :unit (line-unit-price cat (line-sku line) (line-variant line)) :qty (line-qty line) :variant (line-variant line) :extended (line-extended cat line) :tax (line-tax ctx line)})))
(define
commerce-explain
(fn
(sess)
(map (fn (l) (line-detail (get sess :ctx) l)) (get sess :cart))))
;; Phase 3 — order lifecycle flow (reserve -> pay -> fulfil) lands here.
(define commerce-checkout (fn (sess) {:note "order lifecycle flow lands in Phase 3" :phase 3 :status :not-implemented}))

100
lib/commerce/attribution.sx
View File

@@ -1,100 +0,0 @@
;; lib/commerce/attribution.sx — line-level discount attribution.
;;
;; The briefing's marquee backward query: "which line item triggered this
;; discount?". promo.sx computes discount amounts at the class/order level;
;; this layer answers the *scope* question relationally and in both directions:
;; forward — which lines does code C touch? (lines-for-code)
;; backward — which codes touch this line? (codes-for-line)
;; Both are the same relation promo-toucheso run with different vars bound.
;;
;; A :fixed promo is order-level (touches no single line); query those with
;; order-level-codes. Only promos that actually apply (amount > 0) touch lines.
;; Lines whose sku is in product-class `cls`.
(define
class-lines
(fn
(ctx cart cls)
(filter
(fn (l) (= (catalog-class (ctx-catalog ctx) (line-sku l)) cls))
cart)))
;; The lines a promo applies to (its scope). :fixed is order-level → no lines.
(define
promo-lines
(fn
(ctx cart p)
(let
((k (promo-kind p)))
(cond
((= k :percent) (class-lines ctx cart (nth p 2)))
((= k :member)
(if
(= (get ctx :customer) :member)
(class-lines ctx cart (nth p 2))
(list)))
((= k :bundle)
(filter (fn (l) (= (line-sku l) (nth p 2))) cart))
(:else (list))))))
;; Relation: promo `code` touches `line`. Only applying promos (amount > 0)
;; touch anything, so an inapplicable promo contributes no pairs.
(define
promo-toucheso
(fn
(ctx cart ruleset code line)
(fresh
(p)
(membero p ruleset)
(project
(p)
(if
(> (promo-amount ctx cart p) 0)
(mk-conj
(== code (promo-code p))
(membero line (promo-lines ctx cart p)))
fail)))))
;; --- query helpers ---
(define
lines-for-code
(fn
(ctx cart ruleset code)
(run* line (promo-toucheso ctx cart ruleset code line))))
(define
codes-for-line
(fn
(ctx cart ruleset line)
(run* code (promo-toucheso ctx cart ruleset code line))))
(define
line-touched-by?
(fn
(ctx cart ruleset code line)
(not
(empty?
(run
1
c
(mk-conj (promo-toucheso ctx cart ruleset code line) (== c true)))))))
;; Applying order-level (:fixed) promos — discounts with no single line.
(define
order-level-codes
(fn
(ctx cart ruleset)
(run*
code
(fresh
(p)
(membero p ruleset)
(project
(p)
(if
(and
(> (promo-amount ctx cart p) 0)
(= (promo-kind p) :fixed))
(== code (promo-code p))
fail))))))

86
lib/commerce/cart.sx
View File

@@ -1,86 +0,0 @@
;; lib/commerce/cart.sx — cart as an ordered list of line items.
;;
;; A cart is a native list of lines; a line is (list sku variant qty).
;; All operations are pure: they return a new cart, never mutate. Line
;; order is insertion order (stable) so totals are reproducible.
;;
;; cart-lineo is the relational view — because a line *is* a (sku variant qty)
;; tuple, membero queries the cart directly, forward or backward.
(define empty-cart (list))
(define make-line (fn (sku variant qty) (list sku variant qty)))
(define line-sku (fn (l) (nth l 0)))
(define line-variant (fn (l) (nth l 1)))
(define line-qty (fn (l) (nth l 2)))
(define
same-line?
(fn
(l sku variant)
(and (= (line-sku l) sku) (= (line-variant l) variant))))
(define
cart-qty
(fn
(cart sku variant)
(let
((m (filter (fn (l) (same-line? l sku variant)) cart)))
(if (empty? m) 0 (line-qty (first m))))))
(define
cart-remove
(fn
(cart sku variant)
(filter (fn (l) (not (same-line? l sku variant))) cart)))
;; Add qty units; merges into an existing (sku,variant) line in place,
;; otherwise appends a new line at the end.
(define
cart-add
(fn
(cart sku variant qty)
(let
((existing (cart-qty cart sku variant)))
(if
(= existing 0)
(append cart (list (make-line sku variant qty)))
(map
(fn
(l)
(if
(same-line? l sku variant)
(make-line sku variant (+ existing qty))
l))
cart)))))
;; Set the absolute quantity; qty <= 0 removes the line.
(define
cart-set-qty
(fn
(cart sku variant qty)
(if
(<= qty 0)
(cart-remove cart sku variant)
(if
(= (cart-qty cart sku variant) 0)
(append cart (list (make-line sku variant qty)))
(map
(fn
(l)
(if (same-line? l sku variant) (make-line sku variant qty) l))
cart)))))
(define cart-empty? (fn (cart) (empty? cart)))
(define cart-lines (fn (cart) cart))
(define cart-skus (fn (cart) (map line-sku cart)))
;; Total number of units across all lines.
(define
cart-count
(fn (cart) (reduce (fn (acc l) (+ acc (line-qty l))) 0 cart)))
;; Relational view of cart lines.
(define
cart-lineo
(fn (cart sku variant qty) (membero (list sku variant qty) cart)))

83
lib/commerce/catalog.sx
View File

@@ -1,83 +0,0 @@
;; lib/commerce/catalog.sx — catalog snapshot + relational accessors.
;;
;; A catalog snapshot is an immutable dict:
;; {:products (list (list sku price class) ...)
;; :variants (list (list sku variant delta) ...)
;; :stock (list (list sku variant qty) ...)}
;;
;; Money is integer minor units (pence/cents). class is a keyword product
;; class consumed later by tax and promotion relations. delta is a signed
;; price adjustment for a variant; qty is on-hand stock for (sku,variant).
;;
;; Accessor relations take the snapshot as the first argument and are fully
;; multidirectional: (producto cat "widget" p c) binds p,c forward;
;; (producto cat s 1000 c) enumerates every sku priced 1000 backward.
(define empty-catalog {:products (list) :stock (list) :variants (list)})
(define make-catalog (fn (products variants stock) {:products products :stock stock :variants variants}))
(define cat-products (fn (cat) (get cat :products)))
(define cat-variants (fn (cat) (get cat :variants)))
(define cat-stock (fn (cat) (get cat :stock)))
;; --- core fact relations ---
(define
producto
(fn
(cat sku price class)
(membero (list sku price class) (get cat :products))))
(define
varianto
(fn
(cat sku variant delta)
(membero (list sku variant delta) (get cat :variants))))
(define
stocko
(fn
(cat sku variant qty)
(membero (list sku variant qty) (get cat :stock))))
;; --- derived relations ---
(define
priceo
(fn (cat sku price) (fresh (c) (producto cat sku price c))))
(define
classo
(fn (cat sku class) (fresh (p) (producto cat sku p class))))
;; Effective unit price of a (sku,variant): base + variant delta.
(define
unit-priceo
(fn
(cat sku variant price)
(fresh
(base delta)
(priceo cat sku base)
(varianto cat sku variant delta)
(pluso-i base delta price))))
;; --- deterministic lookups (first solution under fixed fact order) ---
(define
catalog-price
(fn
(cat sku)
(let
((rs (run 1 p (priceo cat sku p))))
(if (empty? rs) nil (first rs)))))
(define
catalog-class
(fn
(cat sku)
(let
((rs (run 1 c (classo cat sku c))))
(if (empty? rs) nil (first rs)))))
(define catalog-has? (fn (cat sku) (not (nil? (catalog-price cat sku)))))

153
lib/commerce/conformance.sh
View File

@@ -1,153 +0,0 @@
#!/usr/bin/env bash
# lib/commerce/conformance.sh — run commerce test suites in one sx_server
# process per suite, emit scoreboard.json + scoreboard.md.
#
# commerce-on-sx builds pricing/promotion as miniKanren relations, so every
# suite loads the miniKanren stack first, then the commerce modules.
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=(catalog cart price api promo stack quote ledger order recon federation attribution payment window nettax stock refund integration)
OUT_JSON="lib/commerce/scoreboard.json"
OUT_MD="lib/commerce/scoreboard.md"
run_suite() {
local suite=$1
local file="lib/commerce/tests/${suite}.sx"
local TMP
TMP=$(mktemp)
cat > "$TMP" << EPOCHS
(epoch 1)
(load "spec/stdlib.sx")
(load "lib/r7rs.sx")
(load "lib/guest/match.sx")
(load "lib/minikanren/unify.sx")
(load "lib/minikanren/stream.sx")
(load "lib/minikanren/goals.sx")
(load "lib/minikanren/fresh.sx")
(load "lib/minikanren/conde.sx")
(load "lib/minikanren/run.sx")
(load "lib/minikanren/relations.sx")
(load "lib/minikanren/project.sx")
(load "lib/minikanren/intarith.sx")
(load "lib/minikanren/matche.sx")
(load "lib/minikanren/defrel.sx")
(load "lib/persist/event.sx")
(load "lib/persist/backend.sx")
(load "lib/persist/log.sx")
(load "lib/persist/kv.sx")
(load "lib/persist/idempotency.sx")
(load "lib/guest/lex.sx")
(load "lib/guest/reflective/env.sx")
(load "lib/guest/reflective/quoting.sx")
(load "lib/scheme/parser.sx")
(load "lib/scheme/eval.sx")
(load "lib/scheme/runtime.sx")
(load "lib/flow/spec.sx")
(load "lib/flow/store.sx")
(load "lib/flow/remote.sx")
(load "lib/flow/host.sx")
(load "lib/flow/api.sx")
(load "lib/commerce/catalog.sx")
(load "lib/commerce/cart.sx")
(load "lib/commerce/price.sx")
(load "lib/commerce/api.sx")
(load "lib/commerce/promo.sx")
(load "lib/commerce/stack.sx")
(load "lib/commerce/quote.sx")
(load "lib/commerce/window.sx")
(load "lib/commerce/nettax.sx")
(load "lib/commerce/stock.sx")
(load "lib/commerce/ledger.sx")
(load "lib/commerce/order.sx")
(load "lib/commerce/refund.sx")
(load "lib/commerce/payment.sx")
(load "lib/commerce/recon.sx")
(load "lib/commerce/federation.sx")
(load "lib/commerce/attribution.sx")
(epoch 2)
(eval "(define ct-pass 0)")
(eval "(define ct-fail 0)")
(eval "(define ct-fails (list))")
(eval "(define commerce-test (fn (name got expected) (if (= got expected) (set! ct-pass (+ ct-pass 1)) (begin (set! ct-fail (+ ct-fail 1)) (append! ct-fails name)))))")
(epoch 3)
(load "${file}")
(epoch 4)
(eval "(list ct-pass ct-fail)")
(eval "ct-fails")
EPOCHS
local OUTPUT
OUTPUT=$(timeout 560 "$SX_SERVER" < "$TMP" 2>/dev/null)
rm -f "$TMP"
# The (list ct-pass ct-fail) result follows its (ok-len 2 N) ack line.
local LINE
LINE=$(echo "$OUTPUT" | grep -oE '^\([0-9]+ [0-9]+\)$' | tail -1)
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 commerce 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 '# commerce Conformance Scoreboard\n\n'
printf '_Generated by `lib/commerce/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 ]

86
lib/commerce/federation.sx
View File

@@ -1,86 +0,0 @@
;; lib/commerce/federation.sx — cross-instance catalog (federated marketplace).
;;
;; STUB: instances are registered in-process; there is no real network or
;; ActivityPub transport here (that lives in the federation service). The point
;; is the relational model: a federated catalog is just the UNION of each
;; instance's product facts, tagged with origin, so the same miniKanren
;; relations answer cross-instance questions — "which instances sell this sku?",
;; "which is cheapest?" — as backward queries, no new query engine.
(define federation-stub? true)
(define make-federation (fn (instance cat) {:instances (list (list instance cat))}))
(define
federation-add
(fn
(fed instance cat)
(assoc
fed
:instances (append (get fed :instances) (list (list instance cat))))))
(define federation-instances (fn (fed) (map first (get fed :instances))))
;; Flatten to (instance sku price class) origin-tagged tuples.
(define
fed-products
(fn
(fed)
(reduce
(fn
(acc pair)
(let
((instance (first pair)) (cat (nth pair 1)))
(append
acc
(map (fn (p) (cons instance p)) (get cat :products)))))
(list)
(get fed :instances))))
;; --- relations over the federated catalog (multidirectional) ---
(define
fed-producto
(fn
(fed instance sku price class)
(membero (list instance sku price class) (fed-products fed))))
(define
fed-priceo
(fn
(fed instance sku price)
(fresh (c) (fed-producto fed instance sku price c))))
;; --- query helpers ---
;; Which instances carry a sku? (backward query)
(define
instances-with-sku
(fn (fed sku) (run* inst (fresh (p c) (fed-producto fed inst sku p c)))))
;; All (price instance) offers for a sku, in federation order.
(define
sku-offers
(fn
(fed sku)
(run*
pair
(fresh
(inst p c)
(fed-producto fed inst sku p c)
(== pair (list p inst))))))
;; Cheapest (price instance) for a sku — the deterministic selection layer.
(define
cheapest-offer
(fn
(fed sku)
(let
((offers (sku-offers fed sku)))
(if
(empty? offers)
nil
(reduce
(fn (best x) (if (< (first x) (first best)) x best))
(first offers)
offers)))))

176
lib/commerce/ledger.sx
View File

@@ -1,176 +0,0 @@
;; lib/commerce/ledger.sx — the order ledger as a persist event stream.
;;
;; Each order is an append-only stream "order/<id>" in a persist backend.
;; Order state is never stored directly — it is a projection (fold) over the
;; events, so the ledger is the single source of truth and replays identically.
;;
;; Lifecycle events:
;; :created quote snapshot {:subtotal :discount :tax :total :codes ...}
;; :reserved stock reserved
;; :paid {:amount :ref} — recorded idempotently on the payment ref
;; :fulfilled order shipped/delivered
;; :cancelled / :refunded
;;
;; Idempotency: the SumUp webhook can fire twice for one payment. order-pay
;; uses persist/append-once keyed by the payment ref, so a replayed webhook
;; yields the SAME :paid event without double-recording. Reconciliation then
;; detects genuine mismatches (paid != ordered) across the whole ledger.
(define order-stream (fn (order-id) (str "order/" order-id)))
;; --- writes ---
(define
order-create
(fn
(b order-id at quote)
(persist/append b (order-stream order-id) :created at quote)))
(define
order-reserve
(fn
(b order-id at data)
(persist/append b (order-stream order-id) :reserved at data)))
;; Idempotent on payment ref — a replayed webhook does not double-record.
(define
order-pay
(fn
(b order-id ref at amount)
(persist/append-once b (order-stream order-id) ref :paid at {:amount amount :ref ref})))
(define
order-fulfil
(fn
(b order-id at data)
(persist/append b (order-stream order-id) :fulfilled at data)))
(define
order-cancel
(fn
(b order-id at reason)
(persist/append b (order-stream order-id) :cancelled at {:reason reason})))
(define
order-refund
(fn
(b order-id ref at amount)
(persist/append-once
b
(order-stream order-id)
(str "refund/" ref)
:refunded at
{:amount amount :ref ref})))
;; --- reads ---
(define
order-events
(fn (b order-id) (persist/read b (order-stream order-id))))
;; --- projections over an event list ---
(define
order-status-of
(fn
(events)
(reduce
(fn
(st e)
(let
((t (persist/event-type e)))
(cond
((= t :created) :pending)
((= t :reserved) :reserved)
((= t :paid) :paid)
((= t :fulfilled) :fulfilled)
((= t :cancelled) :cancelled)
((= t :refunded) :refunded)
(:else st))))
:new events)))
(define
order-total-of
(fn
(events)
(let
((created (filter (fn (e) (= (persist/event-type e) :created)) events)))
(if
(empty? created)
0
(get (persist/event-data (first created)) :total)))))
(define
order-paid-amount-of
(fn
(events)
(reduce
(fn
(acc e)
(if
(= (persist/event-type e) :paid)
(+ acc (get (persist/event-data e) :amount))
acc))
0
events)))
(define
order-refunded-amount-of
(fn
(events)
(reduce
(fn
(acc e)
(if
(= (persist/event-type e) :refunded)
(+ acc (get (persist/event-data e) :amount))
acc))
0
events)))
;; Net settled = paid - refunded. Reconciliation compares this to the order
;; total, but only once a payment exists.
(define
order-recon-of
(fn
(events)
(let
((net (- (order-paid-amount-of events) (order-refunded-amount-of events)))
(total (order-total-of events))
(has-paid (some (fn (e) (= (persist/event-type e) :paid)) events)))
(cond
((not has-paid) :unpaid)
((= net total) :ok)
((< net total) :underpaid)
(:else :overpaid)))))
;; --- backend-level helpers ---
(define
order-status
(fn (b order-id) (order-status-of (order-events b order-id))))
(define
order-total
(fn (b order-id) (order-total-of (order-events b order-id))))
(define
order-paid
(fn (b order-id) (order-paid-amount-of (order-events b order-id))))
(define
order-recon
(fn (b order-id) (order-recon-of (order-events b order-id))))
(define order-ids (fn (b) (persist/backend-streams b)))
;; Streams whose net payment does not match the order total (true mismatches,
;; excluding orders that are simply not yet paid).
(define
ledger-mismatches
(fn
(b)
(filter
(fn
(s)
(let
((r (order-recon-of (persist/read b s))))
(or (= r :underpaid) (= r :overpaid))))
(persist/backend-streams b))))

80
lib/commerce/nettax.sx
View File

@@ -1,80 +0,0 @@
;; lib/commerce/nettax.sx — discount-aware tax (alternative policy).
;;
;; price.sx / quote.sx tax the GROSS per-line amounts (discount reduces payable
;; but not the tax base). This module is the alternative explicit policy: tax the
;; NET (post-discount) base. The basket-level discount is allocated across lines
;; in proportion to each line's extended price, with a deterministic
;; largest-remainder pass so per-line shares sum EXACTLY to the discount; tax is
;; then charged on each line's net at its class rate.
;;
;; Both policies are reproducible from (ctx, cart, ruleset, exclusions); pick the
;; one the jurisdiction requires. cart-quote-net mirrors cart-quote's shape.
(define ct-sum (fn (xs) (reduce (fn (a x) (+ a x)) 0 xs)))
;; Add 1 to the first `rem` elements (deterministic remainder distribution).
(define
ct-add-rem
(fn
(xs rem)
(cond
((empty? xs) (list))
((> rem 0)
(cons
(+ (first xs) 1)
(ct-add-rem (rest xs) (- rem 1))))
(:else xs))))
;; Per-line discount allocation (parallel to cart), summing exactly to
;; total-discount, proportional to line-extended share.
(define
allocate-discount
(fn
(cat cart total-discount)
(let
((sub (cart-subtotal cat cart)))
(if
(= sub 0)
(map (fn (l) 0) cart)
(let
((floors (map (fn (l) (quotient (* total-discount (line-extended cat l)) sub)) cart)))
(ct-add-rem floors (- total-discount (ct-sum floors))))))))
;; Tax on one line's net (extended - allocated discount), clamped at 0.
(define
net-line-tax
(fn
(ctx line alloc)
(let
((cat (ctx-catalog ctx)))
(let
((net (- (line-extended cat line) alloc)))
(apply-bps
(if (< net 0) 0 net)
(rate-bps
(get ctx :tax-rules)
(get ctx :jurisdiction)
(catalog-class cat (line-sku line))
(get ctx :customer)))))))
(define
net-tax
(fn
(ctx cart allocations)
(ct-sum
(map (fn (line alloc) (net-line-tax ctx line alloc)) cart allocations))))
;; Discount-aware quote: tax computed on the net (post-discount) base.
(define
cart-quote-net
(fn
(ctx cart ruleset exclusions)
(let
((cat (ctx-catalog ctx)))
(let
((sub (cart-subtotal cat cart))
(disc (best-promo-discount ctx cart ruleset exclusions))
(codes (best-promo-codes ctx cart ruleset exclusions)))
(let
((tax (net-tax ctx cart (allocate-discount cat cart disc))))
{:codes codes :subtotal sub :discount disc :total (+ (- sub disc) tax) :tax tax})))))

119
lib/commerce/order.sx
View File

@@ -1,119 +0,0 @@
;; lib/commerce/order.sx — order lifecycle as a durable flow-on-sx flow.
;;
;; The lifecycle (reserve -> await payment -> fulfil) is a Scheme flow running
;; in the flow-on-sx guest (lib/flow). The flow is PURE ORCHESTRATION: it
;; carries only the order-id and enforces step ordering + the suspension at the
;; payment IO boundary. All IO/state lives in SX: the SX driver here services
;; each flow request by appending to the persist ledger (ledger.sx).
;;
;; reserve -> SX appends :reserved, resumes (synchronous host effect)
;; payment -> flow stays SUSPENDED until the SumUp webhook resumes it
;; fulfil -> SX appends :fulfilled, resumes (synchronous host effect)
;;
;; Durability: the flow's replay log is plain data (flow-store-export), so a
;; suspended order survives a process restart — order-flow-restart! simulates
;; that entirely Scheme-side. Idempotency: order-settle! only resumes a flow
;; still waiting on payment, so a replayed webhook is a no-op at the flow level,
;; and order-pay is idempotent at the ledger level.
;; The flow definition (Scheme source). oid is in scope throughout the begin.
(define
order-flow-src
"(defflow order-lifecycle (lambda (oid) (begin (request (quote reserve) oid) (request (quote payment) oid) (request (quote fulfil) oid))))")
;; Build a flow env with the order flow registered. Never returns the env from
;; an eval boundary (the env is large/cyclic — serializing it hangs).
(define
order-make-env
(fn
()
(let
((env (flow-make-env)))
(begin (flow-run-in env order-flow-src) env))))
;; --- thin Scheme bridge (string-interpolated flow ops) ---
(define
order-flow-start
(fn
(env oid)
(flow-run-in env (str "(flow/start order-lifecycle \"" oid "\")"))))
(define
order-flow-resume
(fn
(env id sym)
(flow-run-in env (str "(flow/resume " id " (quote " sym "))"))))
(define
order-flow-status
(fn (env id) (flow-run-in env (str "(flow/status " id ")"))))
(define
order-flow-result
(fn (env id) (flow-run-in env (str "(flow/result " id ")"))))
;; The request kind the flow with this id is waiting on, or nil if it is not
;; suspended on a host request (done / cancelled / unknown).
(define
order-flow-waiting
(fn
(env id)
(let
((reqs (flow-run-in env "(flow-host-requests)")))
(let
((mine (filter (fn (r) (= (first r) id)) reqs)))
(if (empty? mine) nil (nth (first mine) 1))))))
;; Id out of a (flow-suspended id tag) start/resume result.
(define order-susp-id (fn (susp) (nth susp 1)))
;; --- high-level lifecycle (flow + ledger composed) ---
;; Create the order, start the flow, service the reserve step, and leave the
;; flow suspended at payment. Returns the flow id (needed to settle later).
(define
order-begin!
(fn
(env b oid at quote)
(begin
(order-create b oid at quote)
(let
((id (order-susp-id (order-flow-start env oid))))
(begin
(order-reserve b oid (+ at 1) {})
(order-flow-resume env id :reserved)
id)))))
;; Settle a payment: record it, resume the flow past payment, service fulfil.
;; Idempotent — only acts when the flow is still waiting on payment, so a
;; replayed webhook returns :already-settled without double-charging.
(define
order-settle!
(fn
(env b id oid ref at amount)
(if
(= (order-flow-waiting env id) "payment")
(begin
(order-pay b oid ref at amount)
(order-flow-resume env id :paid)
(order-fulfil b oid (+ at 1) {})
(order-flow-resume env id :fulfilled)
:settled)
:already-settled)))
;; Simulate a process restart: export the flow store, reset the runtime, reload
;; the flow definition, reimport the store. Done entirely Scheme-side so the
;; (large) store is never marshalled across the boundary. The persist ledger is
;; a separate store and is unaffected. Suspended flows resume afterwards.
(define
order-flow-restart!
(fn
(env)
(flow-run-in
env
(str
"(begin (define _saved (flow-store-export)) "
flow-reset-src
" "
order-flow-src
" (flow-store-import! _saved) #t)"))))

41
lib/commerce/payment.sx
View File

@@ -1,41 +0,0 @@
;; lib/commerce/payment.sx — provider-neutral payment-request envelope.
;;
;; The order flow (order.sx) suspends on `(request 'payment oid)` — it carries
;; ONLY the order-id and calls no provider. This layer materialises, at the IO
;; edge, the envelope a provider adapter needs to initiate payment:
;;
;; {:order oid :amount <ledger total> :currency C :return-url U}
;;
;; amount comes from the ledger (the :created quote total); currency + return-url
;; are host/provider config (legitimately host-supplied). The engine stays
;; vendor-agnostic: SumUp/Stripe/etc. adapters consume this envelope, and
;; order-settle!(ref, amount) is the vendor-neutral resume seam. No provider
;; SDK, HTTP, or webhook parsing lives here — that is the orders service's job.
(define payment-request (fn (b oid currency return-url) {:order oid :amount (order-total b oid) :return-url return-url :currency currency}))
(define payment-request-order (fn (pr) (get pr :order)))
(define payment-request-amount (fn (pr) (get pr :amount)))
(define payment-request-currency (fn (pr) (get pr :currency)))
(define payment-request-return-url (fn (pr) (get pr :return-url)))
;; A Scheme string carried as a flow payload round-trips back to SX wrapped as
;; {:scm-string "..."}; unwrap it to the bare order-id.
(define
scm->string
(fn
(v)
(if (and (dict? v) (has-key? v :scm-string)) (get v :scm-string) v)))
;; Host poller seam: every order currently suspended awaiting payment, each with
;; its envelope. A provider adapter iterates these, initiates payment, and later
;; calls order-settle! when the webhook arrives. Needs the flow env.
(define
pending-payments
(fn
(env b currency return-url)
(let
((reqs (flow-run-in env "(flow-host-requests)")))
(map
(fn (r) {:id (first r) :request (payment-request b (scm->string (nth r 2)) currency return-url)})
(filter (fn (r) (= (nth r 1) "payment")) reqs)))))

110
lib/commerce/price.sx
View File

@@ -1,110 +0,0 @@
;; lib/commerce/price.sx — deterministic subtotal + jurisdiction-relational tax.
;;
;; A pricing context bundles the inputs that make a total reproducible:
;; {:catalog CAT :tax-rules RULES :jurisdiction J :customer C}
;; Same context + same cart => identical total, every run.
;;
;; Tax is NOT a hardcoded VAT rate. Rules are facts indexed by
;; (jurisdiction, product-class, customer-class) -> rate-bps
;; where rate-bps is an integer in basis points (2000 = 20%). taxo queries
;; them multidirectionally. Money stays in integer minor units; rounding is
;; half-up per line via integer arithmetic only — never floats.
(define
make-pricing-context
(fn (catalog tax-rules jurisdiction customer) {:customer customer :jurisdiction jurisdiction :catalog catalog :tax-rules tax-rules}))
(define ctx-catalog (fn (ctx) (get ctx :catalog)))
;; --- unit + line pricing ---
;; Variant delta, defaulting to 0 when the (sku,variant) has no variant fact.
(define
variant-delta
(fn
(cat sku variant)
(let
((rs (run 1 d (varianto cat sku variant d))))
(if (empty? rs) 0 (first rs)))))
;; Effective unit price = base price + variant delta. nil if sku unknown.
(define
line-unit-price
(fn
(cat sku variant)
(let
((base (catalog-price cat sku)))
(if (nil? base) nil (+ base (variant-delta cat sku variant))))))
;; Extended (line) price = unit price * quantity.
(define
line-extended
(fn
(cat line)
(*
(line-unit-price cat (line-sku line) (line-variant line))
(line-qty line))))
(define
cart-subtotal
(fn
(cat cart)
(reduce (fn (acc l) (+ acc (line-extended cat l))) 0 cart)))
;; --- tax (jurisdiction-relational) ---
;; rules: (list (list jurisdiction class customer bps) ...)
(define
taxo
(fn
(rules juris class cust bps)
(membero (list juris class cust bps) rules)))
;; Deterministic rate lookup; 0 when no rule matches.
(define
rate-bps
(fn
(rules juris class cust)
(let
((rs (run 1 b (taxo rules juris class cust b))))
(if (empty? rs) 0 (first rs)))))
;; Apply a basis-point rate to an integer amount, rounding half up.
(define
apply-bps
(fn (amount bps) (quotient (+ (* amount bps) 5000) 10000)))
(define
line-tax
(fn
(ctx line)
(let
((cat (ctx-catalog ctx)))
(let
((class (catalog-class cat (line-sku line))))
(apply-bps
(line-extended cat line)
(rate-bps
(get ctx :tax-rules)
(get ctx :jurisdiction)
class
(get ctx :customer)))))))
(define
cart-tax
(fn
(ctx cart)
(reduce (fn (acc l) (+ acc (line-tax ctx l))) 0 cart)))
;; --- total ---
;; Returns {:subtotal :discounts :tax :total}. discounts is 0 until Phase 2.
(define
cart-total
(fn
(ctx cart)
(let
((cat (ctx-catalog ctx)))
(let
((sub (cart-subtotal cat cart)) (tax (cart-tax ctx cart)))
{:subtotal sub :discounts 0 :total (+ sub tax) :tax tax}))))

153
lib/commerce/promo.sx
View File

@@ -1,153 +0,0 @@
;; lib/commerce/promo.sx — promotions as relations over the cart + catalog.
;;
;; A promo is a tagged tuple; the second field is always its code:
;; (:percent code class pct-bps) pct-bps off every line of product-class
;; (:fixed code threshold amount) amount off when subtotal >= threshold
;; (:bundle code sku n) every nth unit of sku is free
;; (:member code class pct-bps) like :percent, members only
;;
;; A ruleset is a list of promo tuples. The discount a promo yields on a
;; given cart is a pure integer computation (minor units); the *enumeration*
;; of which promos apply is relational, so promo-applieso runs forward
;; ("which codes apply and for how much?") and backward ("which code yields
;; this discount?"). Stacking precedence is a separate layer (stack.sx).
(define promo-kind (fn (p) (nth p 0)))
(define promo-code (fn (p) (nth p 1)))
;; Extended price of all lines whose sku is in product-class `class`.
(define
class-extended
(fn
(ctx cart class)
(let
((cat (ctx-catalog ctx)))
(reduce
(fn
(acc l)
(if
(= (catalog-class cat (line-sku l)) class)
(+ acc (line-extended cat l))
acc))
0
cart))))
(define
sku-qty
(fn
(cart sku)
(reduce
(fn (acc l) (if (= (line-sku l) sku) (+ acc (line-qty l)) acc))
0
cart)))
;; --- per-type discount amounts (pure, integer minor units) ---
(define
percent-amount
(fn
(ctx cart p)
(apply-bps
(class-extended ctx cart (nth p 2))
(nth p 3))))
(define
fixed-amount
(fn
(ctx cart p)
(let
((sub (cart-subtotal (ctx-catalog ctx) cart)))
(if
(>= sub (nth p 2))
(min (nth p 3) sub)
0))))
(define
bundle-amount
(fn
(ctx cart p)
(let
((sku (nth p 2)) (n (nth p 3)))
(let
((free (quotient (sku-qty cart sku) n)))
(* free (catalog-price (ctx-catalog ctx) sku))))))
(define
member-amount
(fn
(ctx cart p)
(if
(= (get ctx :customer) :member)
(apply-bps
(class-extended ctx cart (nth p 2))
(nth p 3))
0)))
;; Discount this promo yields on this cart (0 if it does not apply).
(define
promo-amount
(fn
(ctx cart p)
(let
((k (promo-kind p)))
(cond
((= k :percent) (percent-amount ctx cart p))
((= k :fixed) (fixed-amount ctx cart p))
((= k :bundle) (bundle-amount ctx cart p))
((= k :member) (member-amount ctx cart p))
(:else 0)))))
;; --- relational enumeration ---
;; (code, amount) for every promo in the ruleset (amount may be 0).
(define
promo-discounto
(fn
(ctx cart ruleset code amount)
(fresh
(p)
(membero p ruleset)
(project
(p)
(== code (promo-code p))
(== amount (promo-amount ctx cart p))))))
;; (code, amount) restricted to promos that actually apply (amount > 0).
(define
promo-applieso
(fn
(ctx cart ruleset code amount)
(fresh
(p)
(membero p ruleset)
(project
(p)
(if
(> (promo-amount ctx cart p) 0)
(mk-conj
(== code (promo-code p))
(== amount (promo-amount ctx cart p)))
fail)))))
;; --- deterministic helpers ---
;; List of (list code amount) for applicable promos, in ruleset order.
(define
applicable-promos
(fn
(ctx cart ruleset)
(run*
pair
(fresh
(code amount)
(promo-applieso ctx cart ruleset code amount)
(== pair (list code amount))))))
;; Discount for one code (0 if absent / inapplicable).
(define
promo-amount-for
(fn
(ctx cart ruleset code)
(let
((rs (run 1 a (promo-applieso ctx cart ruleset code a))))
(if (empty? rs) 0 (first rs)))))

36
lib/commerce/quote.sx
View File

@@ -1,36 +0,0 @@
;; lib/commerce/quote.sx — the final priced quote: price + promo + stacking.
;;
;; A quote is the deterministic composition of the pricing pipeline for a
;; (context, cart, ruleset, exclusions) tuple:
;; {:subtotal S :discount D :tax T :total (S - D + T) :codes (...)}
;;
;; Tax policy (explicit, for the determinism contract): tax is computed on the
;; GROSS per-line amounts (pre-discount), via price.sx cart-tax. The best
;; promo stacking reduces the payable total but not the tax base. Same inputs
;; always yield the same quote — this is the value the order flow carries.
(define
cart-quote
(fn
(ctx cart ruleset exclusions)
(let
((cat (ctx-catalog ctx)))
(let
((sub (cart-subtotal cat cart))
(disc (best-promo-discount ctx cart ruleset exclusions))
(tax (cart-tax ctx cart))
(codes (best-promo-codes ctx cart ruleset exclusions)))
{:codes codes :subtotal sub :discount disc :total (+ (- sub disc) tax) :tax tax}))))
(define quote-subtotal (fn (q) (get q :subtotal)))
(define quote-discount (fn (q) (get q :discount)))
(define quote-tax (fn (q) (get q :tax)))
(define quote-total (fn (q) (get q :total)))
(define quote-codes (fn (q) (get q :codes)))
;; Session-level convenience (a session is {:ctx :cart}).
(define
session-quote
(fn
(sess ruleset exclusions)
(cart-quote (get sess :ctx) (get sess :cart) ruleset exclusions)))

100
lib/commerce/recon.sx
View File

@@ -1,100 +0,0 @@
;; lib/commerce/recon.sx — reconciliation as relational queries over the ledger.
;;
;; The ledger (ledger.sx) is the source of truth; reconciliation projects it
;; into per-order summary tuples and then asks miniKanren questions about them.
;; "Which orders are overpaid?" / "which order settled to net N?" are backward
;; queries (run*) over the same relation, not separate code paths.
;;
;; A summary tuple is positional:
;; (order-stream total paid refunded net status)
;; net = paid - refunded; status = :unpaid|:ok|:underpaid|:overpaid.
(define
order-summary
(fn
(b stream)
(let
((events (persist/read b stream)))
(let
((total (order-total-of events))
(paid (order-paid-amount-of events))
(refunded (order-refunded-amount-of events)))
(list
stream
total
paid
refunded
(- paid refunded)
(order-recon-of events))))))
(define
ledger-summaries
(fn (b) (map (fn (s) (order-summary b s)) (persist/backend-streams b))))
;; --- relations over the summary set ---
(define
summaryo
(fn
(summaries id total paid refunded net status)
(membero (list id total paid refunded net status) summaries)))
(define
recon-statuso
(fn
(summaries id status)
(fresh (t p r n) (summaryo summaries id t p r n status))))
(define
neto
(fn
(summaries id net)
(fresh (t p r status) (summaryo summaries id t p r net status))))
;; A mismatch is any order whose money does not reconcile (over or under).
(define
mismatcho
(fn
(summaries id)
(fresh
(status)
(recon-statuso summaries id status)
(conde ((== status :underpaid)) ((== status :overpaid))))))
;; --- deterministic query helpers (run* over the live ledger) ---
(define
orders-with-status
(fn (b status) (run* id (recon-statuso (ledger-summaries b) id status))))
(define overpaid-orders (fn (b) (orders-with-status b :overpaid)))
(define underpaid-orders (fn (b) (orders-with-status b :underpaid)))
(define settled-orders (fn (b) (orders-with-status b :ok)))
(define unpaid-orders (fn (b) (orders-with-status b :unpaid)))
(define
mismatched-orders
(fn (b) (run* id (mismatcho (ledger-summaries b) id))))
;; Backward: which order(s) settled to a given net amount?
(define
orders-with-net
(fn (b net) (run* id (neto (ledger-summaries b) id net))))
;; Total signed discrepancy across the ledger (net - total over paid orders);
;; 0 when every settled order reconciles exactly.
(define
ledger-discrepancy
(fn
(b)
(reduce
(fn
(acc s)
(let
((status (nth s 5)))
(if
(= status :unpaid)
acc
(+ acc (- (nth s 4) (nth s 1))))))
0
(ledger-summaries b))))

97
lib/commerce/refund.sx
View File

@@ -1,97 +0,0 @@
;; lib/commerce/refund.sx — refund lifecycle as a second flow-on-sx flow.
;;
;; A refund is request → approve → settle, with TWO genuine suspension points:
;; approval (a human/policy decision) and settlement (the provider issuing the
;; refund). Like order.sx the flow is pure orchestration carrying only the
;; order-id; the SX driver does all ledger IO and reuses order.sx's generic flow
;; helpers (order-flow-waiting/-resume/-status, order-susp-id).
;;
;; refund-begin! → ledger :refund-requested, flow suspends at 'approve
;; refund-approve! → resume past approval, flow suspends at 'settle
;; refund-settle! → ledger :refunded (idempotent), flow completes
;; refund-reject! → ledger :refund-rejected, flow cancelled
;;
;; Only :refunded moves the books (recon.sx), so a requested-but-unsettled or
;; rejected refund leaves reconciliation unchanged.
(define
refund-flow-src
"(defflow refund-lifecycle (lambda (oid) (begin (request (quote approve) oid) (request (quote settle) oid))))")
(define
refund-make-env
(fn
()
(let
((env (flow-make-env)))
(begin (flow-run-in env refund-flow-src) env))))
;; Register the refund flow into an existing (e.g. order) env.
(define
refund-flow-load!
(fn (env) (begin (flow-run-in env refund-flow-src) env)))
(define
refund-flow-start
(fn
(env oid)
(flow-run-in env (str "(flow/start refund-lifecycle \"" oid "\")"))))
;; --- ledger writes ---
(define
refund-request
(fn
(b oid ref at amount)
(persist/append-once
b
(order-stream oid)
(str "refund-req/" ref)
:refund-requested at
{:amount amount :ref ref})))
;; --- lifecycle ---
;; Open a refund: record the request, start the flow, suspend at approval.
(define
refund-begin!
(fn
(env b oid ref at amount)
(begin
(refund-request b oid ref at amount)
(order-susp-id (refund-flow-start env oid)))))
(define
refund-approve!
(fn
(env id)
(if
(= (order-flow-waiting env id) "approve")
(begin (order-flow-resume env id :approved) :approved)
:not-pending-approval)))
(define
refund-reject!
(fn
(env b oid id at reason)
(if
(= (order-flow-waiting env id) "approve")
(begin
(persist/append b (order-stream oid) :refund-rejected at {:reason reason})
(flow-run-in env (str "(flow/cancel " id ")"))
:rejected)
:not-pending-approval)))
;; Settle (provider issued the refund): idempotent — only acts while waiting on
;; settle, so a replayed provider callback returns :already-settled.
(define
refund-settle!
(fn
(env b id oid ref at amount)
(if
(= (order-flow-waiting env id) "settle")
(begin
(order-refund b oid ref at amount)
(order-flow-resume env id :settled)
:settled)
:already-settled)))

25
lib/commerce/scoreboard.json
View File

@@ -1,25 +0,0 @@
{
"suites": {
"catalog": {"pass": 16, "fail": 0},
"cart": {"pass": 18, "fail": 0},
"price": {"pass": 20, "fail": 0},
"api": {"pass": 12, "fail": 0},
"promo": {"pass": 17, "fail": 0},
"stack": {"pass": 16, "fail": 0},
"quote": {"pass": 13, "fail": 0},
"ledger": {"pass": 20, "fail": 0},
"order": {"pass": 22, "fail": 0},
"recon": {"pass": 20, "fail": 0},
"federation": {"pass": 12, "fail": 0},
"attribution": {"pass": 16, "fail": 0},
"payment": {"pass": 7, "fail": 0},
"window": {"pass": 19, "fail": 0},
"nettax": {"pass": 11, "fail": 0},
"stock": {"pass": 19, "fail": 0},
"refund": {"pass": 20, "fail": 0},
"integration": {"pass": 19, "fail": 0}
},
"total_pass": 297,
"total_fail": 0,
"total": 297
}

25
lib/commerce/scoreboard.md
View File

@@ -1,25 +0,0 @@
# commerce Conformance Scoreboard
_Generated by `lib/commerce/conformance.sh`_
| Suite | Pass | Fail | Total |
|-------|-----:|-----:|------:|
| catalog | 16 | 0 | 16 |
| cart | 18 | 0 | 18 |
| price | 20 | 0 | 20 |
| api | 12 | 0 | 12 |
| promo | 17 | 0 | 17 |
| stack | 16 | 0 | 16 |
| quote | 13 | 0 | 13 |
| ledger | 20 | 0 | 20 |
| order | 22 | 0 | 22 |
| recon | 20 | 0 | 20 |
| federation | 12 | 0 | 12 |
| attribution | 16 | 0 | 16 |
| payment | 7 | 0 | 7 |
| window | 19 | 0 | 19 |
| nettax | 11 | 0 | 11 |
| stock | 19 | 0 | 19 |
| refund | 20 | 0 | 20 |
| integration | 19 | 0 | 19 |
| **Total** | **297** | **0** | **297** |

121
lib/commerce/stack.sx
View File

@@ -1,121 +0,0 @@
;; lib/commerce/stack.sx — promotion stacking precedence + best price.
;;
;; Per the miniKanren design rule, precedence is NOT encoded inside the promo
;; rules. promo.sx enumerates which promos apply; this layer enumerates which
;; *combinations* are legal and selects the best one by an explicit cost
;; function (max total discount = min price).
;;
;; Exclusivity is a list of unordered code pairs that may not both apply:
;; exclusions = (list (list code-a code-b) ...)
;; A stacking is a subset of applicable (code amount) pairs containing no
;; excluded pair. valid-stackings enumerates them; best-stacking is the
;; deterministic selection layer; stacking-by-totalo is the backward query
;; ("which legal stacking yields this total discount?").
(define
excluded-pair?
(fn
(exclusions a b)
(some
(fn
(p)
(or
(and (= (first p) a) (= (nth p 1) b))
(and (= (first p) b) (= (nth p 1) a))))
exclusions)))
;; True when no two distinct codes in the list are mutually excluded.
(define
compatible?
(fn
(exclusions codes)
(every?
(fn
(a)
(every?
(fn (b) (or (= a b) (not (excluded-pair? exclusions a b))))
codes))
codes)))
;; All subsets of xs, preserving element order. 2^n entries.
(define
powerset
(fn
(xs)
(if
(empty? xs)
(list (list))
(let
((r (powerset (cdr xs))))
(append r (map (fn (s) (cons (first xs) s)) r))))))
(define stacking-codes (fn (st) (map first st)))
(define
stacking-total
(fn
(st)
(reduce (fn (acc pair) (+ acc (nth pair 1))) 0 st)))
;; Every legal stacking of the applicable (code amount) pairs.
(define
valid-stackings
(fn
(exclusions applicable)
(filter
(fn (st) (compatible? exclusions (stacking-codes st)))
(powerset applicable))))
;; Deterministic selection: the legal stacking with the greatest total
;; discount; ties keep the earlier (stable) candidate, so the result is a
;; reproducible function of (exclusions, applicable).
(define
best-stacking
(fn
(exclusions applicable)
(reduce
(fn
(best st)
(if (> (stacking-total st) (stacking-total best)) st best))
(list)
(valid-stackings exclusions applicable))))
(define
best-discount
(fn
(exclusions applicable)
(stacking-total (best-stacking exclusions applicable))))
(define
best-codes
(fn
(exclusions applicable)
(stacking-codes (best-stacking exclusions applicable))))
;; Backward query: legal stackings (as code lists) whose total discount = D.
(define
stacking-by-totalo
(fn
(stackings codes total)
(fresh
(st)
(membero st stackings)
(project
(st)
(mk-conj
(== codes (stacking-codes st))
(== total (stacking-total st)))))))
;; --- top-level entry: best discount for a cart under a ruleset ---
(define
best-promo-discount
(fn
(ctx cart ruleset exclusions)
(best-discount exclusions (applicable-promos ctx cart ruleset))))
(define
best-promo-codes
(fn
(ctx cart ruleset exclusions)
(best-codes exclusions (applicable-promos ctx cart ruleset))))

106
lib/commerce/stock.sx
View File

@@ -1,106 +0,0 @@
;; lib/commerce/stock.sx — stock-constrained reservation.
;;
;; Reservation is a precondition the host checks BEFORE order-begin! (validate →
;; begin), so the order flow stays pure orchestration. Availability is read
;; relationally from the catalog stock facts (catalog.sx stocko); a stock view
;; subtracts already-reserved quantities so concurrent orders can't over-reserve.
;;
;; can-reserve? cat cart — every line fits available stock
;; reservation-shortfalls cat cart — the lines that do not, with detail
;; effective-available cat reservations … — availability net of reservations
;; sufficient-stocko cat sku variant qty — relational "can supply qty?" query
;; Deterministic on-hand stock for a (sku,variant); 0 if absent.
(define
available-stock
(fn
(cat sku variant)
(let
((rs (run 1 q (stocko cat sku variant q))))
(if (empty? rs) 0 (first rs)))))
;; Units a line cannot fulfil from on-hand stock (0 if it fits).
(define
line-shortfall
(fn
(cat line)
(let
((short (- (line-qty line) (available-stock cat (line-sku line) (line-variant line)))))
(if (< short 0) 0 short))))
(define
line-reservable?
(fn (cat line) (= (line-shortfall cat line) 0)))
;; Lines that cannot be fully reserved, each with requested/available/short.
(define
reservation-shortfalls
(fn
(cat cart)
(reduce
(fn
(acc line)
(let
((short (line-shortfall cat line)))
(if (> short 0) (append acc (list {:requested (line-qty line) :available (available-stock cat (line-sku line) (line-variant line)) :sku (line-sku line) :variant (line-variant line) :short short})) acc)))
(list)
cart)))
(define
can-reserve?
(fn (cat cart) (empty? (reservation-shortfalls cat cart))))
;; Validate → reject; the host gates order-begin! on this.
(define
reserve-check
(fn (cat cart) (if (can-reserve? cat cart) :ok {:shortfalls (reservation-shortfalls cat cart) :rejected :insufficient-stock})))
;; --- reservation view (concurrent-safety) ---
;; reservations: list of (sku variant qty) already held.
(define
reserved-qty
(fn
(reservations sku variant)
(reduce
(fn
(acc r)
(if
(and (= (first r) sku) (= (nth r 1) variant))
(+ acc (nth r 2))
acc))
0
reservations)))
;; On-hand minus already-reserved (clamped at 0).
(define
effective-available
(fn
(cat reservations sku variant)
(let
((eff (- (available-stock cat sku variant) (reserved-qty reservations sku variant))))
(if (< eff 0) 0 eff))))
;; Can a line be reserved given existing reservations?
(define
line-reservable-with?
(fn
(cat reservations line)
(<=
(line-qty line)
(effective-available
cat
reservations
(line-sku line)
(line-variant line)))))
;; --- relational availability query (the showcase) ---
;; Succeeds when on-hand stock for (sku,variant) covers qty. Multidirectional
;; over the stock facts: "which variants of widget can supply 5?" is a backward
;; query.
(define
sufficient-stocko
(fn
(cat sku variant qty)
(fresh (avail) (stocko cat sku variant avail) (lteo-i qty avail))))

73
lib/commerce/tests/api.sx
View File

@@ -1,73 +0,0 @@
;; lib/commerce/tests/api.sx — public commerce session surface.
;; Uses (commerce-test name got expected) provided by conformance.sh.
(define
acat
(make-catalog
(list
(list "widget" 1000 :standard)
(list "book" 800 :zero-rated))
(list (list "widget" :small -200))
(list)))
(define
arules
(list
(list :uk :standard :guest 2000)
(list :uk :zero-rated :guest 0)))
(define actx (make-pricing-context acat arules :uk :guest))
(define sess0 (commerce-session actx))
;; --- empty session ---
(commerce-test "new-session-empty" (commerce-cart sess0) empty-cart)
(commerce-test "new-count" (commerce-count sess0) 0)
(commerce-test "new-total" (commerce-total sess0) {:subtotal 0 :discounts 0 :total 0 :tax 0})
;; --- add + total ---
(define
sess1
(commerce-add
(commerce-add sess0 "widget" :small 2)
"book"
:none 1))
(commerce-test "add-count" (commerce-count sess1) 3)
(commerce-test
"add-lines"
(commerce-lines sess1)
(list (list "widget" :small 2) (list "book" :none 1)))
(commerce-test "add-total" (commerce-total sess1) {:subtotal 2400 :discounts 0 :total 2720 :tax 320})
;; --- mutate ---
(commerce-test
"set-qty"
(commerce-lines (commerce-set-qty sess1 "widget" :small 1))
(list (list "widget" :small 1) (list "book" :none 1)))
(commerce-test
"remove"
(commerce-lines (commerce-remove sess1 "book" :none))
(list (list "widget" :small 2)))
;; --- validation ---
(commerce-test "can-add-yes" (commerce-can-add? sess0 "widget") true)
(commerce-test "can-add-no" (commerce-can-add? sess0 "ghost") false)
;; --- audit breakdown ---
(commerce-test
"explain"
(commerce-explain sess1)
(list {:sku "widget" :unit 800 :qty 2 :variant :small :extended 1600 :tax 320} {:sku "book" :unit 800 :qty 1 :variant :none :extended 800 :tax 0}))
;; --- checkout stub ---
(commerce-test
"checkout-stub"
(get (commerce-checkout sess1) :status)
:not-implemented)

124
lib/commerce/tests/attribution.sx
View File

@@ -1,124 +0,0 @@
;; lib/commerce/tests/attribution.sx — line-level discount attribution.
;; Uses (commerce-test name got expected) provided by conformance.sh.
(define
pcat
(make-catalog
(list
(list "widget" 1000 :standard)
(list "gizmo" 2000 :standard)
(list "book" 800 :zero-rated)
(list "tea" 1000 :reduced))
(list)
(list)))
(define gctx (make-pricing-context pcat (list) :uk :guest))
(define mctx (make-pricing-context pcat (list) :uk :member))
(define
cart
(list
(list "widget" :none 2)
(list "gizmo" :none 1)
(list "book" :none 1)
(list "tea" :none 6)))
(define
ruleset
(list
(list :percent "TEN" :standard 1000)
(list :percent "TWENTY" :standard 2000)
(list :bundle "B3T" "tea" 3)
(list :fixed "FIVE" 0 500)
(list :member "MEM" :standard 1500)))
(define w-line (list "widget" :none 2))
(define t-line (list "tea" :none 6))
(define bk-line (list "book" :none 1))
;; --- scope helpers ---
(commerce-test
"class-lines-standard"
(class-lines gctx cart :standard)
(list (list "widget" :none 2) (list "gizmo" :none 1)))
(commerce-test
"promo-lines-bundle"
(promo-lines gctx cart (list :bundle "B3T" "tea" 3))
(list (list "tea" :none 6)))
(commerce-test
"promo-lines-fixed-none"
(promo-lines gctx cart (list :fixed "FIVE" 0 500))
(list))
;; --- forward: which lines does a code touch? ---
(commerce-test
"lines-for-ten"
(lines-for-code gctx cart ruleset "TEN")
(list (list "widget" :none 2) (list "gizmo" :none 1)))
(commerce-test
"lines-for-bundle"
(lines-for-code gctx cart ruleset "B3T")
(list (list "tea" :none 6)))
(commerce-test
"lines-for-fixed-empty"
(lines-for-code gctx cart ruleset "FIVE")
(list))
(commerce-test
"lines-for-mem-guest-empty"
(lines-for-code gctx cart ruleset "MEM")
(list))
;; --- backward: which codes touch this line? (the showcase) ---
(commerce-test
"codes-for-widget-guest"
(codes-for-line gctx cart ruleset w-line)
(list "TEN" "TWENTY"))
(commerce-test
"codes-for-tea"
(codes-for-line gctx cart ruleset t-line)
(list "B3T"))
(commerce-test
"codes-for-book-none"
(codes-for-line gctx cart ruleset bk-line)
(list))
;; member sees the member rate too
(commerce-test
"codes-for-widget-member"
(codes-for-line mctx cart ruleset w-line)
(list "TEN" "TWENTY" "MEM"))
(commerce-test
"lines-for-mem-member"
(lines-for-code mctx cart ruleset "MEM")
(list (list "widget" :none 2) (list "gizmo" :none 1)))
;; --- predicate ---
(commerce-test
"touched-yes"
(line-touched-by? gctx cart ruleset "TEN" w-line)
true)
(commerce-test
"touched-no-wrong-class"
(line-touched-by? gctx cart ruleset "B3T" w-line)
false)
(commerce-test
"touched-no-guest-mem"
(line-touched-by? gctx cart ruleset "MEM" w-line)
false)
;; --- order-level (fixed) codes ---
(commerce-test
"order-level"
(order-level-codes gctx cart ruleset)
(list "FIVE"))

103
lib/commerce/tests/cart.sx
View File

@@ -1,103 +0,0 @@
;; lib/commerce/tests/cart.sx — cart structure + line operations.
;; Uses (commerce-test name got expected) provided by conformance.sh.
;; --- add ---
(commerce-test
"add-to-empty"
(cart-add empty-cart "widget" :small 2)
(list (list "widget" :small 2)))
(commerce-test
"add-merges-same-line"
(cart-add
(cart-add empty-cart "widget" :small 2)
"widget"
:small 3)
(list (list "widget" :small 5)))
(commerce-test
"add-different-variant-separate"
(cart-add
(cart-add empty-cart "widget" :small 2)
"widget"
:large 1)
(list (list "widget" :small 2) (list "widget" :large 1)))
(commerce-test
"add-different-sku-separate"
(cart-add
(cart-add empty-cart "widget" :small 2)
"gadget"
:std 1)
(list (list "widget" :small 2) (list "gadget" :std 1)))
(commerce-test
"add-preserves-order"
(cart-skus
(cart-add
(cart-add (cart-add empty-cart "a" :v 1) "b" :v 1)
"c"
:v 1))
(list "a" "b" "c"))
;; --- qty queries ---
(define
c2
(cart-add
(cart-add empty-cart "widget" :small 2)
"gadget"
:std 4))
(commerce-test "cart-qty-found" (cart-qty c2 "widget" :small) 2)
(commerce-test "cart-qty-missing" (cart-qty c2 "widget" :large) 0)
(commerce-test "cart-count" (cart-count c2) 6)
(commerce-test "cart-empty-yes" (cart-empty? empty-cart) true)
(commerce-test "cart-empty-no" (cart-empty? c2) false)
;; --- set-qty ---
(commerce-test
"set-qty-existing"
(cart-set-qty c2 "widget" :small 10)
(list (list "widget" :small 10) (list "gadget" :std 4)))
(commerce-test
"set-qty-new-line"
(cart-set-qty empty-cart "book" :std 3)
(list (list "book" :std 3)))
(commerce-test
"set-qty-zero-removes"
(cart-set-qty c2 "widget" :small 0)
(list (list "gadget" :std 4)))
;; --- remove ---
(commerce-test
"remove-line"
(cart-remove c2 "gadget" :std)
(list (list "widget" :small 2)))
(commerce-test
"remove-missing-noop"
(cart-remove c2 "nope" :std)
(list (list "widget" :small 2) (list "gadget" :std 4)))
;; --- relational view ---
(commerce-test
"cart-lineo-forward"
(run* q (cart-lineo c2 "gadget" :std q))
(list 4))
(commerce-test
"cart-lineo-sku-by-qty-backward"
(run* sk (fresh (v) (cart-lineo c2 sk v 4)))
(list "gadget"))
(commerce-test
"cart-lineo-all-skus"
(run* sk (fresh (v q) (cart-lineo c2 sk v q)))
(list "widget" "gadget"))

93
lib/commerce/tests/catalog.sx
View File

@@ -1,93 +0,0 @@
;; lib/commerce/tests/catalog.sx — catalog facts + relational accessors.
;; Uses (commerce-test name got expected) provided by conformance.sh.
;; Query vars avoid the name `s` (the run-n macro binds `s` internally).
(define
cat
(make-catalog
(list
(list "widget" 1000 :standard)
(list "gadget" 2500 :standard)
(list "book" 800 :zero-rated)
(list "tea" 1000 :reduced))
(list
(list "widget" :small -200)
(list "widget" :large 500)
(list "gadget" :std 0))
(list
(list "widget" :small 5)
(list "widget" :large 0)
(list "gadget" :std 12))))
;; --- forward lookups ---
(commerce-test
"price-forward"
(run* p (priceo cat "widget" p))
(list 1000))
(commerce-test
"class-forward"
(run* c (classo cat "book" c))
(list :zero-rated))
(commerce-test
"product-forward"
(run* q (fresh (p c) (producto cat "gadget" p c) (== q (list p c))))
(list (list 2500 :standard)))
;; --- backward lookups (the showcase) ---
(commerce-test
"sku-by-price-backward"
(run* sk (priceo cat sk 1000))
(list "widget" "tea"))
(commerce-test
"sku-by-class-backward"
(run* sk (classo cat sk :standard))
(list "widget" "gadget"))
(commerce-test
"all-prices"
(run* p (fresh (sk) (priceo cat sk p)))
(list 1000 2500 800 1000))
;; --- variants + effective unit price ---
(commerce-test
"variant-delta-forward"
(run* d (varianto cat "widget" :small d))
(list -200))
(commerce-test
"unit-price-small"
(run* p (unit-priceo cat "widget" :small p))
(list 800))
(commerce-test
"unit-price-large"
(run* p (unit-priceo cat "widget" :large p))
(list 1500))
(commerce-test
"variant-by-delta-backward"
(run* v (varianto cat "widget" v -200))
(list :small))
;; --- stock ---
(commerce-test
"stock-forward"
(run* q (stocko cat "widget" :small q))
(list 5))
(commerce-test
"in-stock-skus-backward"
(run* sk (fresh (v q) (stocko cat sk v q) (lto-i 0 q)))
(list "widget" "gadget"))
;; --- deterministic helpers ---
(commerce-test "catalog-price-helper" (catalog-price cat "gadget") 2500)
(commerce-test "catalog-class-helper" (catalog-class cat "tea") :reduced)
(commerce-test "catalog-has-yes" (catalog-has? cat "book") true)
(commerce-test "catalog-has-no" (catalog-has? cat "nonesuch") false)

88
lib/commerce/tests/federation.sx
View File

@@ -1,88 +0,0 @@
;; lib/commerce/tests/federation.sx — federated catalog (out-of-scope stub).
;; Uses (commerce-test name got expected) provided by conformance.sh.
(define
cat-a
(make-catalog
(list
(list "widget" 1000 :standard)
(list "book" 800 :zero-rated))
(list)
(list)))
(define
cat-b
(make-catalog
(list
(list "widget" 900 :standard)
(list "tea" 1200 :reduced))
(list)
(list)))
(define
cat-c
(make-catalog (list (list "widget" 1100 :standard)) (list) (list)))
(define
fed
(federation-add
(federation-add (make-federation :alpha cat-a) :beta cat-b)
:gamma cat-c))
;; --- structure ---
(commerce-test "is-stub" federation-stub? true)
(commerce-test
"instances"
(federation-instances fed)
(list :alpha :beta :gamma))
(commerce-test "product-count" (len (fed-products fed)) 5)
;; --- forward query ---
(commerce-test
"price-at-instance"
(run* p (fed-priceo fed :beta "widget" p))
(list 900))
;; --- backward queries (the showcase) ---
(commerce-test
"instances-with-widget"
(instances-with-sku fed "widget")
(list :alpha :beta :gamma))
(commerce-test
"instances-with-book"
(instances-with-sku fed "book")
(list :alpha))
(commerce-test
"instances-with-tea"
(instances-with-sku fed "tea")
(list :beta))
(commerce-test
"instance-by-price-backward"
(run* inst (fresh (c) (fed-producto fed inst "widget" 1100 c)))
(list :gamma))
;; --- offers + cheapest (deterministic selection) ---
(commerce-test
"widget-offers"
(sku-offers fed "widget")
(list
(list 1000 :alpha)
(list 900 :beta)
(list 1100 :gamma)))
(commerce-test
"cheapest-widget"
(cheapest-offer fed "widget")
(list 900 :beta))
(commerce-test
"cheapest-book"
(cheapest-offer fed "book")
(list 800 :alpha))
(commerce-test "cheapest-missing" (cheapest-offer fed "ghost") nil)

104
lib/commerce/tests/integration.sx
View File

@@ -1,104 +0,0 @@
;; lib/commerce/tests/integration.sx — end-to-end composition proof.
;; Uses (commerce-test name got expected) provided by conformance.sh.
;;
;; One narrative across every module: catalog → stock check → quote
;; (promo+stack+tax) → order flow → payment envelope → settle → recon → refund.
;; Proves the seams tie together with consistent numbers (the project's thesis:
;; minikanren pricing + flow lifecycle + persist ledger compose).
;; Builds one flow env with BOTH the order and refund flows.
(define env (order-make-env))
(define _rf (refund-flow-load! env))
(define b (persist/mem-backend))
(define
cat
(make-catalog
(list
(list "widget" 1000 :standard)
(list "book" 800 :zero-rated))
(list (list "widget" :small -200))
(list (list "widget" :small 10) (list "book" :none 5))))
(define
rules
(list
(list :uk :standard :guest 2000)
(list :uk :zero-rated :guest 0)))
(define ctx (make-pricing-context cat rules :uk :guest))
(define
ruleset
(list
(list :percent "TEN" :standard 1000)
(list :fixed "FIVE" 0 50)))
;; widget :small x2 → unit 800, extended 1600 (standard); book x1 → 800 (zero-rated)
(define
cart
(list (list "widget" :small 2) (list "book" :none 1)))
;; 1. stock gating passes (widget:small 10 >= 2)
(commerce-test "int-can-reserve" (can-reserve? cat cart) true)
;; 2. quote ties the whole pricing pipeline together
;; subtotal 2400; discount TEN 160 + FIVE 50 = 210; tax 1600@20% = 320;
;; total 2400 - 210 + 320 = 2510
(define q (cart-quote ctx cart ruleset (list)))
(commerce-test "int-quote-subtotal" (quote-subtotal q) 2400)
(commerce-test "int-quote-discount" (quote-discount q) 210)
(commerce-test "int-quote-tax" (quote-tax q) 320)
(commerce-test "int-quote-total" (quote-total q) 2510)
;; 3. attribution explains where the discount landed
(commerce-test
"int-attribution"
(codes-for-line ctx cart ruleset (list "widget" :small 2))
(list "TEN"))
(commerce-test
"int-order-level"
(order-level-codes ctx cart ruleset)
(list "FIVE"))
;; 4. order carries the quote total into the ledger; suspends at payment
(define oid "INT-1")
(define id (order-begin! env b oid 1000 q))
(commerce-test "int-order-total-from-quote" (order-total b oid) 2510)
(commerce-test "int-waiting-payment" (order-flow-waiting env id) "payment")
;; 5. the payment envelope reflects the quoted total
(commerce-test
"int-payment-envelope"
(payment-request b oid :GBP "https://shop/return")
{:order "INT-1" :amount 2510 :return-url "https://shop/return" :currency :GBP})
;; 6. settle the quoted amount → reconciles exactly
(commerce-test
"int-settled"
(order-settle! env b id oid "pay-int" 1002 2510)
:settled)
(commerce-test "int-status-fulfilled" (order-status b oid) :fulfilled)
(commerce-test "int-recon-ok" (order-recon b oid) :ok)
;; 7. partial refund via its own flow → recon moves to underpaid
(define rid (refund-begin! env b oid "rf-int" 2000 510))
(commerce-test "int-refund-approve" (refund-approve! env rid) :approved)
(commerce-test
"int-refund-settle"
(refund-settle! env b rid oid "rf-int" 2001 510)
:settled)
(commerce-test
"int-refunded-amount"
(order-refunded-amount-of (order-events b oid))
510)
(commerce-test "int-recon-after-refund" (order-recon b oid) :underpaid)
;; 8. ledger reconciliation flags the now-mismatched order
(commerce-test
"int-mismatch"
(mismatched-orders b)
(list (order-stream "INT-1")))
;; 9. distinct flow ids for the order and the refund
(commerce-test "int-distinct-flow-ids" (not (= id rid)) true)

80
lib/commerce/tests/ledger.sx
View File

@@ -1,80 +0,0 @@
;; lib/commerce/tests/ledger.sx — order ledger on persist + idempotent recon.
;; Uses (commerce-test name got expected) provided by conformance.sh.
(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
;; --- lifecycle status projection ---
(define b1 (persist/mem-backend))
(define _c1 (order-create b1 "A1" 100 q1))
(commerce-test "status-pending" (order-status b1 "A1") :pending)
(define _r1 (order-reserve b1 "A1" 101 {:lines 2}))
(commerce-test "status-reserved" (order-status b1 "A1") :reserved)
(define _p1 (order-pay b1 "A1" "ref-1" 102 1200))
(commerce-test "status-paid" (order-status b1 "A1") :paid)
(define _f1 (order-fulfil b1 "A1" 103 {:carrier "post"}))
(commerce-test "status-fulfilled" (order-status b1 "A1") :fulfilled)
(commerce-test "total-projection" (order-total b1 "A1") 1200)
(commerce-test "paid-projection" (order-paid b1 "A1") 1200)
(commerce-test "recon-ok" (order-recon b1 "A1") :ok)
(commerce-test "event-count" (len (order-events b1 "A1")) 4)
;; --- idempotency: replayed webhook does not double-record ---
(define b2 (persist/mem-backend))
(define _c2 (order-create b2 "B1" 200 q1))
(define _p2a (order-pay b2 "B1" "sumup-9" 201 1200))
(define _p2b (order-pay b2 "B1" "sumup-9" 201 1200))
(define _p2c (order-pay b2 "B1" "sumup-9" 201 1200))
(commerce-test "idem-single-event" (len (order-events b2 "B1")) 2)
(commerce-test "idem-paid-once" (order-paid b2 "B1") 1200)
(commerce-test "idem-recon-ok" (order-recon b2 "B1") :ok)
(commerce-test "idem-same-event" (= _p2a _p2c) true)
;; --- mismatch detection ---
(define bun (persist/mem-backend))
(define _cu (order-create bun "U1" 300 q1))
(commerce-test "unpaid-recon" (order-recon bun "U1") :unpaid)
(define bup (persist/mem-backend))
(define _cp (order-create bup "U2" 300 q1))
(define _pp1 (order-pay bup "U2" "r-a" 301 1200))
(define _pp2 (order-pay bup "U2" "r-b" 302 1200))
(commerce-test "double-charge-overpaid" (order-recon bup "U2") :overpaid)
(commerce-test "double-charge-amount" (order-paid bup "U2") 2400)
(define bsh (persist/mem-backend))
(define _cs (order-create bsh "U3" 400 q1))
(define _ps (order-pay bsh "U3" "r-short" 401 1000))
(commerce-test "underpaid-recon" (order-recon bsh "U3") :underpaid)
;; --- refund (idempotent) reduces net ---
(define brf (persist/mem-backend))
(define _crf (order-create brf "R1" 500 q1))
(define _prf (order-pay brf "R1" "p-1" 501 1200))
(define _rf1 (order-refund brf "R1" "rf-1" 502 200))
(define _rf2 (order-refund brf "R1" "rf-1" 502 200))
(commerce-test "refund-idem-net" (order-recon brf "R1") :underpaid)
(commerce-test "refund-idem-events" (len (order-events brf "R1")) 3)
;; --- cross-ledger reconciliation ---
(define bL (persist/mem-backend))
(define _l1 (order-create bL "OK1" 600 q1))
(define _l1p (order-pay bL "OK1" "ok-ref" 601 1200))
(define _l2 (order-create bL "OVER1" 600 q1))
(define _l2a (order-pay bL "OVER1" "o-a" 602 1200))
(define _l2b (order-pay bL "OVER1" "o-b" 603 1200))
(define _l3 (order-create bL "UNDER1" 600 q1))
(define _l3p (order-pay bL "UNDER1" "u-ref" 604 900))
(define _l4 (order-create bL "PENDING1" 600 q1))
(commerce-test "ledger-order-count" (len (order-ids bL)) 4)
(commerce-test
"ledger-mismatches"
(sort (ledger-mismatches bL))
(sort (list (order-stream "OVER1") (order-stream "UNDER1"))))

92
lib/commerce/tests/nettax.sx
View File

@@ -1,92 +0,0 @@
;; lib/commerce/tests/nettax.sx — discount-aware (net) tax policy.
;; Uses (commerce-test name got expected) provided by conformance.sh.
(define
pcat
(make-catalog
(list
(list "widget" 1000 :standard)
(list "tea" 1000 :reduced))
(list)
(list)))
(define
rules
(list
(list :uk :standard :guest 2000)
(list :uk :reduced :guest 500)))
(define gctx (make-pricing-context pcat rules :uk :guest))
;; widget x3 = 3000 (standard), tea x6 = 6000 (reduced); subtotal 9000
(define
cart
(list (list "widget" :none 3) (list "tea" :none 6)))
(define ruleset (list (list :percent "TEN" :standard 1000)))
;; --- allocation: proportional, sums exactly to the discount ---
(commerce-test
"allocate-even"
(allocate-discount pcat cart 300)
(list 100 200))
(commerce-test
"allocate-sums-to-discount"
(ct-sum (allocate-discount pcat cart 300))
300)
;; remainder distribution: 100 over (3000,6000)/9000 = (33,66) rem 1 -> (34,66)
(commerce-test
"allocate-remainder"
(allocate-discount pcat cart 100)
(list 34 66))
(commerce-test
"allocate-remainder-sums"
(ct-sum (allocate-discount pcat cart 100))
100)
(commerce-test
"allocate-zero"
(allocate-discount pcat cart 0)
(list 0 0))
(commerce-test
"allocate-empty"
(allocate-discount pcat empty-cart 0)
(list))
;; --- net tax vs gross tax ---
;; discount = TEN 10% of standard 3000 = 300, allocated (100 200).
;; net: widget 2900@20%=580, tea 5800@5%=290 -> net tax 870 (gross was 900).
(commerce-test
"net-quote"
(cart-quote-net gctx cart ruleset (list))
{:codes (list "TEN") :subtotal 9000 :discount 300 :total 9570 :tax 870})
;; same cart through the gross policy taxes 900 (the documented default)
(commerce-test
"gross-quote-for-contrast"
(quote-tax (cart-quote gctx cart ruleset (list)))
900)
(commerce-test
"net-tax-lower"
(quote-tax (cart-quote-net gctx cart ruleset (list)))
870)
;; --- no discount: net policy == gross policy ---
(commerce-test
"no-discount-net-equals-gross"
(=
(cart-quote-net gctx cart (list) (list))
(cart-quote gctx cart (list) (list)))
true)
;; --- empty cart ---
(commerce-test
"net-empty"
(cart-quote-net gctx empty-cart ruleset (list))
{:codes (list) :subtotal 0 :discount 0 :total 0 :tax 0})

74
lib/commerce/tests/order.sx
View File

@@ -1,74 +0,0 @@
;; lib/commerce/tests/order.sx — order lifecycle as a flow-on-sx flow.
;; Uses (commerce-test name got expected) provided by conformance.sh.
;; Builds the (expensive) flow env once; all assertions share it.
(define env (order-make-env))
(define b (persist/mem-backend))
(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
;; --- happy path: begin suspends at payment ---
(define id1 (order-begin! env b "O1" 100 q1))
(commerce-test "begin-status-reserved" (order-status b "O1") :reserved)
(commerce-test "begin-waiting-payment" (order-flow-waiting env id1) "payment")
(commerce-test "begin-not-yet-paid" (order-paid b "O1") 0)
;; --- settle: payment webhook drives fulfilment ---
(define s1 (order-settle! env b id1 "O1" "ref-1" 102 1200))
(commerce-test "settle-result" s1 :settled)
(commerce-test "settle-status-fulfilled" (order-status b "O1") :fulfilled)
(commerce-test "settle-flow-done" (order-flow-status env id1) "done")
(commerce-test "settle-recon-ok" (order-recon b "O1") :ok)
(commerce-test "settle-event-count" (len (order-events b "O1")) 4)
;; --- webhook replay: a second settle is a no-op ---
(define s1b (order-settle! env b id1 "O1" "ref-1" 102 1200))
(commerce-test "replay-already-settled" s1b :already-settled)
(commerce-test
"replay-no-extra-events"
(len (order-events b "O1"))
4)
(commerce-test "replay-recon-still-ok" (order-recon b "O1") :ok)
;; --- a second order gets its own flow id and suspends independently ---
(define id2 (order-begin! env b "O2" 200 q1))
(commerce-test "second-distinct-id" (not (= id1 id2)) true)
(commerce-test
"second-waiting-payment"
(order-flow-waiting env id2)
"payment")
(commerce-test "first-unaffected" (order-status b "O1") :fulfilled)
;; --- durability: a suspended order survives a process restart ---
(define id3 (order-begin! env b "O3" 300 q1))
(commerce-test "pre-restart-waiting" (order-flow-waiting env id3) "payment")
(define _restart (order-flow-restart! env))
(commerce-test
"post-restart-still-waiting"
(order-flow-waiting env id3)
"payment")
(commerce-test "post-restart-ledger-intact" (order-status b "O3") :reserved)
(define s3 (order-settle! env b id3 "O3" "ref-3" 302 1200))
(commerce-test "post-restart-settled" s3 :settled)
(commerce-test "post-restart-status" (order-status b "O3") :fulfilled)
(commerce-test "post-restart-recon-ok" (order-recon b "O3") :ok)
(commerce-test "post-restart-flow-done" (order-flow-status env id3) "done")
;; --- payment-request envelope (provider-neutral) for the still-suspended O2 ---
(commerce-test
"pending-payments-lists-suspended"
(pending-payments env b :GBP "https://shop/return")
(list {:id id2 :request {:order "O2" :amount 1200 :return-url "https://shop/return" :currency :GBP}}))

43
lib/commerce/tests/payment.sx
View File

@@ -1,43 +0,0 @@
;; lib/commerce/tests/payment.sx — provider-neutral payment-request envelope.
;; Uses (commerce-test name got expected) provided by conformance.sh.
;; Envelope construction is ledger-only (no flow env); pending-payments (which
;; needs the flow env) is exercised in the order suite.
(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
(define q2 {:codes (list) :subtotal 5000 :discount 500 :total 4500 :tax 0})
(define b (persist/mem-backend))
(define _c1 (order-create b "P1" 1 q1))
(define _c2 (order-create b "P2" 1 q2))
(commerce-test
"envelope"
(payment-request b "P1" :GBP "https://shop/return")
{:order "P1" :amount 1200 :return-url "https://shop/return" :currency :GBP})
(commerce-test
"envelope-amount"
(payment-request-amount (payment-request b "P1" :GBP "x"))
1200)
(commerce-test
"envelope-currency"
(payment-request-currency (payment-request b "P1" :GBP "x"))
:GBP)
(commerce-test
"envelope-order"
(payment-request-order (payment-request b "P1" :GBP "x"))
"P1")
(commerce-test
"envelope-return-url"
(payment-request-return-url (payment-request b "P1" :GBP "https://r"))
"https://r")
;; amount tracks the ledger total, currency is per-call (provider/instance config)
(commerce-test
"envelope-amount-2"
(payment-request-amount (payment-request b "P2" :EUR "x"))
4500)
(commerce-test
"envelope-currency-2"
(payment-request-currency (payment-request b "P2" :EUR "x"))
:EUR)

100
lib/commerce/tests/price.sx
View File

@@ -1,100 +0,0 @@
;; lib/commerce/tests/price.sx — subtotal + jurisdiction-relational tax.
;; Uses (commerce-test name got expected) provided by conformance.sh.
(define
pcat
(make-catalog
(list
(list "widget" 1000 :standard)
(list "book" 800 :zero-rated)
(list "tea" 1000 :reduced))
(list
(list "widget" :small -200)
(list "widget" :large 500))
(list)))
(define
rules
(list
(list :uk :standard :guest 2000)
(list :uk :reduced :guest 500)
(list :uk :zero-rated :guest 0)
(list :uk :standard :member 1000)
(list :ie :standard :guest 2300)))
(define gctx (make-pricing-context pcat rules :uk :guest))
(define mctx (make-pricing-context pcat rules :uk :member))
;; --- unit + line pricing ---
(commerce-test
"unit-price-variant"
(line-unit-price pcat "widget" :small)
800)
(commerce-test
"unit-price-no-variant"
(line-unit-price pcat "widget" :none)
1000)
(commerce-test "unit-price-unknown" (line-unit-price pcat "ghost" :none) nil)
(commerce-test
"line-extended"
(line-extended pcat (list "widget" :small 2))
1600)
;; --- subtotal ---
(define
cart1
(list (list "widget" :small 2) (list "book" :none 1)))
(commerce-test "subtotal" (cart-subtotal pcat cart1) 2400)
(commerce-test "subtotal-empty" (cart-subtotal pcat empty-cart) 0)
;; --- tax rate lookup (relational, both directions) ---
(commerce-test
"rate-forward"
(rate-bps rules :uk :standard :guest)
2000)
(commerce-test
"rate-missing"
(rate-bps rules :fr :standard :guest)
0)
(commerce-test
"rate-juris-by-bps-backward"
(run* j (fresh (cust) (taxo rules j :standard cust 2300)))
(list :ie))
(commerce-test
"rate-customer-by-bps-backward"
(run* cust (taxo rules :uk :standard cust 1000))
(list :member))
;; --- apply-bps rounding (half up, integer only) ---
(commerce-test "bps-exact" (apply-bps 1600 2000) 320)
(commerce-test "bps-round-up" (apply-bps 799 2000) 160)
(commerce-test "bps-zero" (apply-bps 800 0) 0)
;; --- line + cart tax ---
(commerce-test
"line-tax-standard"
(line-tax gctx (list "widget" :small 2))
320)
(commerce-test
"line-tax-zero-rated"
(line-tax gctx (list "book" :none 1))
0)
(commerce-test
"line-tax-member"
(line-tax mctx (list "widget" :small 2))
160)
(commerce-test "cart-tax-guest" (cart-tax gctx cart1) 320)
;; --- total dict (deterministic) ---
(commerce-test "total-guest" (cart-total gctx cart1) {:subtotal 2400 :discounts 0 :total 2720 :tax 320})
(commerce-test "total-member" (cart-total mctx cart1) {:subtotal 2400 :discounts 0 :total 2560 :tax 160})
(commerce-test "total-empty" (cart-total gctx empty-cart) {:subtotal 0 :discounts 0 :total 0 :tax 0})

142
lib/commerce/tests/promo.sx
View File

@@ -1,142 +0,0 @@
;; lib/commerce/tests/promo.sx — promo rules + relational enumeration.
;; Uses (commerce-test name got expected) provided by conformance.sh.
(define
pcat
(make-catalog
(list
(list "widget" 1000 :standard)
(list "book" 800 :zero-rated)
(list "tea" 1000 :reduced))
(list)
(list)))
(define gctx (make-pricing-context pcat (list) :uk :guest))
(define mctx (make-pricing-context pcat (list) :uk :member))
(define
cart
(list
(list "widget" :none 3)
(list "book" :none 1)
(list "tea" :none 6)))
(define
ruleset
(list
(list :percent "TEN" :standard 1000)
(list :fixed "FIVER" 5000 500)
(list :bundle "B3T" "tea" 3)
(list :member "MEM" :standard 1500)))
;; --- per-type amounts ---
(commerce-test
"percent-amount"
(promo-amount gctx cart (list :percent "TEN" :standard 1000))
300)
(commerce-test
"fixed-amount-met"
(promo-amount gctx cart (list :fixed "FIVER" 5000 500))
500)
(commerce-test
"fixed-amount-not-met"
(promo-amount
gctx
(list (list "widget" :none 1))
(list :fixed "FIVER" 5000 500))
0)
(commerce-test
"fixed-amount-capped"
(promo-amount
gctx
(list (list "book" :none 1))
(list :fixed "BIG" 0 9999))
800)
(commerce-test
"bundle-amount"
(promo-amount gctx cart (list :bundle "B3T" "tea" 3))
2000)
(commerce-test
"member-amount-guest"
(promo-amount gctx cart (list :member "MEM" :standard 1500))
0)
(commerce-test
"member-amount-member"
(promo-amount mctx cart (list :member "MEM" :standard 1500))
450)
;; --- relational enumeration: forward ---
(commerce-test
"discounto-all-guest"
(run*
pair
(fresh
(code amount)
(promo-discounto gctx cart ruleset code amount)
(== pair (list code amount))))
(list
(list "TEN" 300)
(list "FIVER" 500)
(list "B3T" 2000)
(list "MEM" 0)))
(commerce-test
"applicable-guest"
(applicable-promos gctx cart ruleset)
(list
(list "TEN" 300)
(list "FIVER" 500)
(list "B3T" 2000)))
(commerce-test
"applicable-member"
(applicable-promos mctx cart ruleset)
(list
(list "TEN" 300)
(list "FIVER" 500)
(list "B3T" 2000)
(list "MEM" 450)))
;; --- relational enumeration: backward (the showcase) ---
(commerce-test
"code-by-discount-2000"
(run* code (promo-applieso gctx cart ruleset code 2000))
(list "B3T"))
(commerce-test
"code-by-discount-500"
(run* code (promo-applieso gctx cart ruleset code 500))
(list "FIVER"))
(commerce-test
"code-by-discount-none"
(run* code (promo-applieso gctx cart ruleset code 9999))
(list))
;; --- deterministic helpers ---
(commerce-test
"amount-for-ten"
(promo-amount-for gctx cart ruleset "TEN")
300)
(commerce-test
"amount-for-mem-guest"
(promo-amount-for gctx cart ruleset "MEM")
0)
(commerce-test
"amount-for-mem-member"
(promo-amount-for mctx cart ruleset "MEM")
450)
(commerce-test
"amount-for-absent"
(promo-amount-for gctx cart ruleset "NOPE")
0)

108
lib/commerce/tests/quote.sx
View File

@@ -1,108 +0,0 @@
;; lib/commerce/tests/quote.sx — composed priced quote (price+promo+stacking).
;; Uses (commerce-test name got expected) provided by conformance.sh.
(define
pcat
(make-catalog
(list
(list "widget" 1000 :standard)
(list "book" 800 :zero-rated)
(list "tea" 1000 :reduced))
(list)
(list)))
(define
tax-rules
(list
(list :uk :standard :guest 2000)
(list :uk :reduced :guest 500)
(list :uk :zero-rated :guest 0)
(list :uk :standard :member 2000)
(list :uk :reduced :member 500)
(list :uk :zero-rated :member 0)))
(define gctx (make-pricing-context pcat tax-rules :uk :guest))
(define mctx (make-pricing-context pcat tax-rules :uk :member))
(define
cart
(list
(list "widget" :none 3)
(list "book" :none 1)
(list "tea" :none 6)))
(define
ruleset
(list
(list :percent "TEN" :standard 1000)
(list :percent "TWENTY" :standard 2000)
(list :fixed "FIVER" 5000 500)
(list :bundle "B3T" "tea" 3)
(list :member "MEM" :standard 2500)))
(define
exclusions
(list (list "TEN" "TWENTY") (list "TEN" "MEM") (list "TWENTY" "MEM")))
;; subtotal: 3000 + 800 + 6000 = 9800
;; tax (gross): widget 600 + tea 300 + book 0 = 900
;; guest discount: TWENTY 600 + FIVER 500 + B3T 2000 = 3100
;; guest total: 9800 - 3100 + 900 = 7600
(define gq (cart-quote gctx cart ruleset exclusions))
(commerce-test "quote-subtotal" (quote-subtotal gq) 9800)
(commerce-test "quote-tax" (quote-tax gq) 900)
(commerce-test "quote-discount-guest" (quote-discount gq) 3100)
(commerce-test "quote-total-guest" (quote-total gq) 7600)
(commerce-test
"quote-codes-guest"
(quote-codes gq)
(list "TWENTY" "FIVER" "B3T"))
(commerce-test "quote-full-guest" gq {:codes (list "TWENTY" "FIVER" "B3T") :subtotal 9800 :discount 3100 :total 7600 :tax 900})
;; member discount: MEM 750 + FIVER 500 + B3T 2000 = 3250
;; member total: 9800 - 3250 + 900 = 7450
(define mq (cart-quote mctx cart ruleset exclusions))
(commerce-test "quote-discount-member" (quote-discount mq) 3250)
(commerce-test "quote-total-member" (quote-total mq) 7450)
(commerce-test
"quote-codes-member"
(quote-codes mq)
(list "FIVER" "B3T" "MEM"))
;; --- determinism: same inputs, identical quote ---
(commerce-test
"quote-deterministic"
(=
(cart-quote gctx cart ruleset exclusions)
(cart-quote gctx cart ruleset exclusions))
true)
;; --- no promos: discount 0, total = subtotal + tax ---
(commerce-test
"quote-no-promos"
(cart-quote gctx cart (list) (list))
{:codes (list) :subtotal 9800 :discount 0 :total 10700 :tax 900})
;; --- empty cart ---
(commerce-test
"quote-empty"
(cart-quote gctx empty-cart ruleset exclusions)
{:codes (list) :subtotal 0 :discount 0 :total 0 :tax 0})
;; --- session convenience ---
(define
sess
(commerce-add (commerce-session gctx) "widget" :none 3))
(commerce-test
"session-quote"
(quote-total (session-quote sess ruleset exclusions))
3000)

109
lib/commerce/tests/recon.sx
View File

@@ -1,109 +0,0 @@
;; lib/commerce/tests/recon.sx — reconciliation as relational ledger queries.
;; Uses (commerce-test name got expected) provided by conformance.sh.
(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
(define b (persist/mem-backend))
;; OK1 — clean payment
(define _ok (order-create b "OK1" 1 q1))
(define _okp (order-pay b "OK1" "ok-ref" 2 1200))
;; OVER1 — double charge under two different refs
(define _ov (order-create b "OVER1" 1 q1))
(define _ova (order-pay b "OVER1" "ov-a" 2 1200))
(define _ovb (order-pay b "OVER1" "ov-b" 3 1200))
;; UNDER1 — short payment
(define _un (order-create b "UNDER1" 1 q1))
(define _unp (order-pay b "UNDER1" "un-ref" 2 900))
;; PART1 — paid in full, then partially refunded
(define _pa (order-create b "PART1" 1 q1))
(define _pap (order-pay b "PART1" "pa-ref" 2 1200))
(define _par (order-refund b "PART1" "pa-rf" 3 200))
;; REPLAY1 — webhook fires twice with the same ref (idempotent)
(define _rp (order-create b "REPLAY1" 1 q1))
(define _rpa (order-pay b "REPLAY1" "rp-ref" 2 1200))
(define _rpb (order-pay b "REPLAY1" "rp-ref" 2 1200))
;; PEND1 — created, not yet paid
(define _pe (order-create b "PEND1" 1 q1))
;; --- summaries ---
(commerce-test "summary-count" (len (ledger-summaries b)) 6)
(commerce-test
"summary-ok1"
(order-summary b "order/OK1")
(list "order/OK1" 1200 1200 0 1200 :ok))
(commerce-test
"summary-part1"
(order-summary b "order/PART1")
(list "order/PART1" 1200 1200 200 1000 :underpaid))
;; --- forward status query ---
(commerce-test
"status-forward-ok"
(run* st (recon-statuso (ledger-summaries b) "order/OK1" st))
(list :ok))
;; --- backward status queries (the showcase) ---
(commerce-test
"settled"
(sort (settled-orders b))
(sort (list "order/OK1" "order/REPLAY1")))
(commerce-test "overpaid" (overpaid-orders b) (list "order/OVER1"))
(commerce-test
"underpaid"
(sort (underpaid-orders b))
(sort (list "order/UNDER1" "order/PART1")))
(commerce-test "unpaid" (unpaid-orders b) (list "order/PEND1"))
(commerce-test
"mismatched"
(sort (mismatched-orders b))
(sort (list "order/OVER1" "order/UNDER1" "order/PART1")))
;; --- backward net-amount query ---
(commerce-test
"net-1200"
(sort (orders-with-net b 1200))
(sort (list "order/OK1" "order/REPLAY1")))
(commerce-test
"net-2400"
(orders-with-net b 2400)
(list "order/OVER1"))
(commerce-test
"net-900"
(orders-with-net b 900)
(list "order/UNDER1"))
;; --- discrepancy: +1200 (over) - 300 (under) - 200 (refund) = 700 ---
(commerce-test "discrepancy" (ledger-discrepancy b) 700)
;; --- double-charge guard ---
(commerce-test "double-charge-detected" (order-recon b "OVER1") :overpaid)
(commerce-test "double-charge-amount" (order-paid b "OVER1") 2400)
;; --- partial refund ---
(commerce-test "partial-refund-net" (order-recon b "PART1") :underpaid)
(commerce-test
"partial-refund-amount"
(order-refunded-amount-of (order-events b "PART1"))
200)
;; --- webhook replay: same ref twice records once ---
(commerce-test
"replay-single-event"
(len (order-events b "REPLAY1"))
2)
(commerce-test "replay-paid-once" (order-paid b "REPLAY1") 1200)
(commerce-test "replay-settled" (order-recon b "REPLAY1") :ok)

78
lib/commerce/tests/refund.sx
View File

@@ -1,78 +0,0 @@
;; lib/commerce/tests/refund.sx — refund lifecycle as a flow-on-sx flow.
;; Uses (commerce-test name got expected) provided by conformance.sh.
;; Builds the (expensive) flow env once; all assertions share it.
(define env (refund-make-env))
(define b (persist/mem-backend))
(define q1 {:codes (list) :subtotal 1000 :discount 0 :total 1200 :tax 200})
;; a paid, fulfilled order to refund (set up directly via the ledger)
(define _c (order-create b "O1" 1 q1))
(define _p (order-pay b "O1" "pay-1" 2 1200))
(commerce-test "setup-recon-ok" (order-recon b "O1") :ok)
;; --- happy path: request -> approve -> settle ---
(define rid (refund-begin! env b "O1" "rf-1" 10 500))
(commerce-test "begin-waiting-approve" (order-flow-waiting env rid) "approve")
(commerce-test
"begin-not-yet-refunded"
(order-refunded-amount-of (order-events b "O1"))
0)
(commerce-test "begin-recon-unchanged" (order-recon b "O1") :ok)
(define a1 (refund-approve! env rid))
(commerce-test "approve-result" a1 :approved)
(commerce-test "approve-waiting-settle" (order-flow-waiting env rid) "settle")
(define s1 (refund-settle! env b rid "O1" "rf-1" 11 500))
(commerce-test "settle-result" s1 :settled)
(commerce-test "settle-flow-done" (order-flow-status env rid) "done")
(commerce-test
"settle-refunded-amount"
(order-refunded-amount-of (order-events b "O1"))
500)
;; net 1200 - 500 = 700 < total 1200 -> underpaid (partial refund)
(commerce-test "settle-recon-underpaid" (order-recon b "O1") :underpaid)
;; --- idempotent settle: replayed provider callback is a no-op ---
(define s1b (refund-settle! env b rid "O1" "rf-1" 11 500))
(commerce-test "replay-already-settled" s1b :already-settled)
(commerce-test
"replay-refunded-once"
(order-refunded-amount-of (order-events b "O1"))
500)
;; --- reject path: approval denied, books untouched ---
(define _c2 (order-create b "O2" 1 q1))
(define _p2 (order-pay b "O2" "pay-2" 2 1200))
(define rid2 (refund-begin! env b "O2" "rf-2" 20 1200))
(commerce-test
"reject-waiting-approve"
(order-flow-waiting env rid2)
"approve")
(define j2 (refund-reject! env b "O2" rid2 21 "policy"))
(commerce-test "reject-result" j2 :rejected)
(commerce-test "reject-flow-not-waiting" (order-flow-waiting env rid2) nil)
(commerce-test
"reject-no-refund"
(order-refunded-amount-of (order-events b "O2"))
0)
(commerce-test "reject-recon-ok" (order-recon b "O2") :ok)
;; settling a rejected/cancelled refund does nothing
(define s2 (refund-settle! env b rid2 "O2" "rf-2" 22 1200))
(commerce-test "reject-then-settle-noop" s2 :already-settled)
(commerce-test
"reject-still-no-refund"
(order-refunded-amount-of (order-events b "O2"))
0)
;; --- distinct flow ids ---
(commerce-test "distinct-refund-ids" (not (= rid rid2)) true)

127
lib/commerce/tests/stack.sx
View File

@@ -1,127 +0,0 @@
;; lib/commerce/tests/stack.sx — stacking precedence, exclusivity, best price.
;; Uses (commerce-test name got expected) provided by conformance.sh.
(define
pcat
(make-catalog
(list
(list "widget" 1000 :standard)
(list "book" 800 :zero-rated)
(list "tea" 1000 :reduced))
(list)
(list)))
(define gctx (make-pricing-context pcat (list) :uk :guest))
(define mctx (make-pricing-context pcat (list) :uk :member))
(define
cart
(list
(list "widget" :none 3)
(list "book" :none 1)
(list "tea" :none 6)))
(define
ruleset
(list
(list :percent "TEN" :standard 1000)
(list :percent "TWENTY" :standard 2000)
(list :fixed "FIVER" 5000 500)
(list :bundle "B3T" "tea" 3)
(list :member "MEM" :standard 2500)))
;; The three standard-class discounts are mutually exclusive.
(define
exclusions
(list (list "TEN" "TWENTY") (list "TEN" "MEM") (list "TWENTY" "MEM")))
;; --- exclusivity predicates ---
(commerce-test
"excluded-pair-direct"
(excluded-pair? exclusions "TEN" "TWENTY")
true)
(commerce-test
"excluded-pair-symmetric"
(excluded-pair? exclusions "TWENTY" "TEN")
true)
(commerce-test
"excluded-pair-none"
(excluded-pair? exclusions "TEN" "FIVER")
false)
(commerce-test
"compatible-yes"
(compatible? exclusions (list "FIVER" "B3T" "TWENTY"))
true)
(commerce-test
"compatible-no"
(compatible? exclusions (list "TEN" "TWENTY" "B3T"))
false)
;; --- powerset + valid stackings ---
(commerce-test
"powerset-size"
(len (powerset (list 1 2 3 4)))
16)
(define gappl (applicable-promos gctx cart ruleset))
(commerce-test "applicable-guest-count" (len gappl) 4)
;; 16 subsets minus the 4 containing both TEN and TWENTY = 12 legal.
(commerce-test
"valid-stackings-count"
(len (valid-stackings exclusions gappl))
12)
(commerce-test
"stacking-total"
(stacking-total (list (list "TWENTY" 600) (list "B3T" 2000)))
2600)
;; --- best price (deterministic selection) ---
(commerce-test
"best-discount-guest"
(best-promo-discount gctx cart ruleset exclusions)
3100)
(commerce-test
"best-codes-guest"
(best-promo-codes gctx cart ruleset exclusions)
(list "TWENTY" "FIVER" "B3T"))
;; exclusivity holds: the cheaper conflicting code is dropped.
(commerce-test
"best-excludes-ten"
(some
(fn (c) (= c "TEN"))
(best-promo-codes gctx cart ruleset exclusions))
false)
;; --- member vs guest ---
(commerce-test
"best-discount-member"
(best-promo-discount mctx cart ruleset exclusions)
3250)
(commerce-test
"best-codes-member"
(best-promo-codes mctx cart ruleset exclusions)
(list "FIVER" "B3T" "MEM"))
;; --- best price backward query (the showcase) ---
(commerce-test
"stacking-by-total-backward"
(run*
codes
(stacking-by-totalo (valid-stackings exclusions gappl) codes 3100))
(list (list "TWENTY" "FIVER" "B3T")))
;; --- edge: no applicable promos ---
(commerce-test
"best-empty"
(best-promo-discount gctx empty-cart ruleset exclusions)
0)

122
lib/commerce/tests/stock.sx
View File

@@ -1,122 +0,0 @@
;; lib/commerce/tests/stock.sx — stock-constrained reservation.
;; Uses (commerce-test name got expected) provided by conformance.sh.
(define
cat
(make-catalog
(list
(list "widget" 1000 :standard)
(list "gadget" 2500 :standard))
(list)
(list
(list "widget" :small 5)
(list "widget" :large 0)
(list "gadget" :std 12))))
;; --- availability ---
(commerce-test
"available-found"
(available-stock cat "widget" :small)
5)
(commerce-test
"available-zero"
(available-stock cat "widget" :large)
0)
(commerce-test
"available-absent"
(available-stock cat "widget" :none)
0)
;; --- per-line reservability ---
(commerce-test
"shortfall-fits"
(line-shortfall cat (list "widget" :small 5))
0)
(commerce-test
"shortfall-over"
(line-shortfall cat (list "widget" :small 8))
3)
(commerce-test
"reservable-yes"
(line-reservable? cat (list "gadget" :std 12))
true)
(commerce-test
"reservable-no"
(line-reservable? cat (list "widget" :large 1))
false)
;; --- cart-level reservation check ---
(commerce-test
"can-reserve-yes"
(can-reserve?
cat
(list (list "widget" :small 5) (list "gadget" :std 2)))
true)
(commerce-test
"can-reserve-no"
(can-reserve? cat (list (list "widget" :small 9)))
false)
(commerce-test
"shortfalls-detail"
(reservation-shortfalls
cat
(list (list "widget" :small 9) (list "gadget" :std 2)))
(list {:requested 9 :available 5 :sku "widget" :variant :small :short 4}))
(commerce-test
"reserve-check-ok"
(reserve-check cat (list (list "gadget" :std 1)))
:ok)
(commerce-test
"reserve-check-rejected"
(reserve-check cat (list (list "widget" :large 1)))
{:shortfalls (list {:requested 1 :available 0 :sku "widget" :variant :large :short 1}) :rejected :insufficient-stock})
;; --- reservation view: concurrent holds reduce availability ---
(define held (list (list "widget" :small 3)))
(commerce-test
"effective-after-hold"
(effective-available cat held "widget" :small)
2)
(commerce-test
"effective-other-unaffected"
(effective-available cat held "gadget" :std)
12)
(commerce-test
"reservable-with-fits"
(line-reservable-with? cat held (list "widget" :small 2))
true)
(commerce-test
"reservable-with-over"
(line-reservable-with? cat held (list "widget" :small 3))
false)
;; --- relational availability query (multidirectional) ---
(commerce-test
"sufficient-forward"
(run*
x
(fresh () (sufficient-stocko cat "widget" :small 5) (== x true)))
(list true))
(commerce-test
"sufficient-forward-over"
(run*
x
(fresh () (sufficient-stocko cat "widget" :small 6) (== x true)))
(list))
;; backward: which variants of widget can supply 1 unit?
(commerce-test
"variants-supplying-1"
(run* v (fresh (q) (stocko cat "widget" v q) (lteo-i 1 q)))
(list :small))

112
lib/commerce/tests/window.sx
View File

@@ -1,112 +0,0 @@
;; lib/commerce/tests/window.sx — time-windowed promotions.
;; Uses (commerce-test name got expected) provided by conformance.sh.
(define
pcat
(make-catalog (list (list "widget" 1000 :standard)) (list) (list)))
(define gctx (make-pricing-context pcat (list) :uk :guest))
(define cart (list (list "widget" :none 3)))
(define ten (list :percent "TEN" :standard 1000))
(define twenty (list :percent "TWENTY" :standard 2000))
(define always (list :fixed "ALWAYS" 0 100))
(define
windowed
(list
(windowed-promo ten 100 200)
(windowed-promo twenty 150 300)
(windowed-promo always nil nil)))
(define exclusions (list (list "TEN" "TWENTY")))
;; --- wp-active? boundaries (inclusive) ---
(commerce-test
"active-at-from"
(wp-active? (windowed-promo ten 100 200) 100)
true)
(commerce-test
"active-at-until"
(wp-active? (windowed-promo ten 100 200) 200)
true)
(commerce-test
"inactive-before"
(wp-active? (windowed-promo ten 100 200) 99)
false)
(commerce-test
"inactive-after"
(wp-active? (windowed-promo ten 100 200) 201)
false)
(commerce-test
"open-ended-always"
(wp-active? (windowed-promo always nil nil) 99999)
true)
(commerce-test
"open-lower"
(wp-active? (windowed-promo ten nil 200) 1)
true)
(commerce-test
"open-upper"
(wp-active? (windowed-promo ten 100 nil) 99999)
true)
;; --- active-ruleset filtering ---
(commerce-test
"active-ruleset-120"
(active-ruleset windowed 120)
(list ten always))
(commerce-test
"active-ruleset-160"
(active-ruleset windowed 160)
(list ten twenty always))
(commerce-test
"active-ruleset-250"
(active-ruleset windowed 250)
(list twenty always))
(commerce-test
"active-ruleset-50"
(active-ruleset windowed 50)
(list always))
;; --- active-codes (backward query) ---
(commerce-test
"active-codes-120"
(active-codes windowed 120)
(list "TEN" "ALWAYS"))
(commerce-test
"active-codes-160"
(active-codes windowed 160)
(list "TEN" "TWENTY" "ALWAYS"))
(commerce-test
"active-codes-50"
(active-codes windowed 50)
(list "ALWAYS"))
;; --- windowed-quote: discount changes with time (deterministic) ---
;; subtotal 3000, no tax. TEN=300, TWENTY=600, ALWAYS=100; TEN/TWENTY exclusive.
(commerce-test
"quote-50"
(quote-discount (windowed-quote gctx cart windowed exclusions 50))
100)
(commerce-test
"quote-120"
(quote-discount (windowed-quote gctx cart windowed exclusions 120))
400)
(commerce-test
"quote-160"
(quote-discount (windowed-quote gctx cart windowed exclusions 160))
700)
(commerce-test
"quote-250"
(quote-discount (windowed-quote gctx cart windowed exclusions 250))
700)
(commerce-test
"quote-total-160"
(quote-total (windowed-quote gctx cart windowed exclusions 160))
2300)

55
lib/commerce/window.sx
View File

@@ -1,55 +0,0 @@
;; lib/commerce/window.sx — time-windowed promotions.
;;
;; A promo's validity window is kept SEPARATE from the promo tuple (so promo.sx
;; is untouched): a windowed promo is (list promo from until) with inclusive
;; integer timestamps (same time model as the ledger `at`). nil from = no lower
;; bound; nil until = open-ended.
;;
;; `active-ruleset` filters a windowed ruleset to the plain promos live at a
;; given time, which feeds straight into promo/stack/quote — so a datetime-aware
;; quote is just the existing pipeline over the active set. Deterministic: the
;; quote is a pure function of (ctx, cart, windowed-ruleset, exclusions, at).
(define windowed-promo (fn (promo from until) (list promo from until)))
(define wp-promo (fn (wp) (nth wp 0)))
(define wp-from (fn (wp) (nth wp 1)))
(define wp-until (fn (wp) (nth wp 2)))
(define
wp-active?
(fn
(wp at)
(let
((from (wp-from wp)) (until (wp-until wp)))
(and (or (nil? from) (>= at from)) (or (nil? until) (<= at until))))))
;; Plain promo tuples live at time `at` — feed into cart-quote / best-promo-*.
(define
active-ruleset
(fn
(windowed at)
(map wp-promo (filter (fn (wp) (wp-active? wp at)) windowed))))
;; Relation: which promo codes are active at `at`? (backward query)
(define
active-promoo
(fn
(windowed at code)
(fresh
(wp)
(membero wp windowed)
(project
(wp)
(if (wp-active? wp at) (== code (promo-code (wp-promo wp))) fail)))))
(define
active-codes
(fn (windowed at) (run* code (active-promoo windowed at code))))
;; Datetime-aware quote: the existing pipeline over the time-active ruleset.
(define
windowed-quote
(fn
(ctx cart windowed exclusions at)
(cart-quote ctx cart (active-ruleset windowed at) exclusions)))

456
lib/erlang/runtime.sx
View File

@@ -731,7 +731,10 @@
0
(if
(= prev-k nil)
(er-apply-fun (er-proc-field pid :initial-fun) (list))
(er-apply-fun
(er-proc-field pid :initial-fun)
(let ((args (er-proc-field pid :pending-args)))
(cond (= args nil) (list) :else args)))
(do (er-proc-set! pid :continuation nil) (prev-k nil)))))
(let
((r (nth result-ref 0)))
@@ -956,8 +959,118 @@
(= ty "nil") (er-mk-nil)
:else v))))
;; ── HTTP request/response marshaling (Step 8b-start) ────────────
;; The native `http-listen` primitive hands the handler an SX dict
;; {:method :path :query :headers :body}
;; and expects an SX dict back
;; {:status :headers :body}
;; This layer converts so Erlang handlers see proper proplists:
;; [{method, <<"GET">>}, {path, <<"/foo">>}, {query, <<>>},
;; {headers, [{<<"content-type">>, <<"text/plain">>}, ...]},
;; {body, <<...>>}]
;; Headers ride as a nested proplist with binary keys — header names
;; are arbitrary user input, so they stay out of the atom table. The
;; outer request keys (method/path/query/headers/body) are fixed and
;; small, so they become atoms (cheap to pattern-match against).
(define er-of-sx-deep
(fn (v)
(cond
(= (type-of v) "dict") (er-dict-to-header-proplist v)
:else (er-of-sx v))))
(define er-dict-to-header-proplist
(fn (d)
(let ((ks (keys d)) (out (er-mk-nil)))
(for-each
(fn (i)
(let ((idx (- (- (len ks) 1) i)))
(let ((k (nth ks idx)))
(let ((v (get d k)))
(set!
out
(er-mk-cons
(er-mk-tuple
(list
(er-mk-binary (map char->integer (string->list k)))
(er-of-sx-deep v)))
out))))))
(range 0 (len ks)))
out)))
(define er-request-dict-to-proplist
(fn (d)
(cond
(not (= (type-of d) "dict")) (er-of-sx d)
:else
(let ((ks (keys d)) (out (er-mk-nil)))
(for-each
(fn (i)
(let ((idx (- (- (len ks) 1) i)))
(let ((k (nth ks idx)))
(let ((v (get d k)))
(set!
out
(er-mk-cons
(er-mk-tuple
(list (er-mk-atom k) (er-of-sx-deep v)))
out))))))
(range 0 (len ks)))
out))))
;; Inverse: handler's proplist response -> SX dict for native send.
;; Value rules:
;; Erlang binary -> SX string (bytes joined)
;; Erlang integer -> SX number passthrough
;; Erlang cons of 2-tuples -> nested SX dict (e.g. headers)
;; Erlang cons (other shapes) -> SX list via er-to-sx
;; anything else -> er-to-sx passthrough
(define er-proplist-2tuple?
(fn (v)
(cond
(er-nil? v) true
(er-cons? v)
(let ((h (get v :head)))
(cond
(and (er-tuple? h) (= (len (get h :elements)) 2))
(er-proplist-2tuple? (get v :tail))
:else false))
:else false)))
(define er-to-sx-deep
(fn (v)
(cond
(er-binary? v) (list->string (map integer->char (get v :bytes)))
(and (er-cons? v) (er-proplist-2tuple? v)) (er-proplist-to-dict v)
:else (er-to-sx v))))
(define er-proplist-to-dict
(fn (pl)
(let ((d (dict)))
(er-proplist-fill! pl d)
d)))
(define er-proplist-fill!
(fn (pl d)
(cond
(er-nil? pl) nil
(er-cons? pl)
(let ((head (get pl :head)) (tail (get pl :tail)))
(cond
(and (er-tuple? head) (= (len (get head :elements)) 2))
(let ((kv (get head :elements)))
(let ((k (nth kv 0)) (v (nth kv 1)))
(let ((key-str
(cond
(er-atom? k) (get k :name)
(er-binary? k)
(list->string (map integer->char (get k :bytes)))
:else (str k))))
(dict-set! d key-str (er-to-sx-deep v))
(er-proplist-fill! tail d))))
:else (er-proplist-fill! tail d)))
:else nil)))
;; Load an Erlang module declaration. Source must start with
;; `-module(Name).` and contain function definitions. Functions
@@ -1468,9 +1581,141 @@
;; entry is keyed by "Module/Name/Arity"; multi-arity BIFs register
;; once per arity. Called eagerly at the end of runtime.sx so the
;; registry is ready before any erlang-eval-ast call.
(define er-register-builtin-bifs!
(fn ()
;; erlang module — type predicates (all pure)
(define
er-bif-http-listen
(fn
(vs)
(let
((port (nth vs 0)) (handler (nth vs 1)))
(cond
(not (= (type-of port) "number"))
(raise (er-mk-error-marker (er-mk-atom "badarg")))
(not (er-fun? handler))
(raise (er-mk-error-marker (er-mk-atom "badarg")))
:else (let
;; Bridge between native http-listen and Erlang handler.
;;
;; Inbound: native passes Req as SX Dict
;; {:method :path :query :headers :body}
;; converted to Erlang request proplist via the live
;; er-request-dict-to-proplist marshaller — that's the
;; same shape http_server:route/2 consumes (binaries
;; for path/method/body, dict-like proplist for headers).
;;
;; Outbound: Erlang handler returns
;; [{status, Int}, {headers, [{Bin, Bin}, ...]}, {body, Bin}]
;; converted back to SX Dict via er-proplist-to-dict —
;; binary values become SX strings, the headers cons
;; flattens to a nested SX dict (via er-to-sx-deep's
;; proplist-2tuple detection). Matches what native
;; http-listen serialises to the wire.
;;
;; (Step 8b-bridge originally shipped parallel
;; er-http-req-of-sx / er-http-resp-to-sx helpers; commit
;; 78eae9ef deleted them as dead because the BIF body
;; still referenced them — Blockers #1. This rewrite
;; threads through the live marshallers instead.)
;; Run the handler as a SCHEDULED er-process so any
;; `receive` (e.g. gen_server:call inside a kernel-aware
;; route) suspends and resumes inside the SX scheduler.
;; Without this, native http-listen invokes the handler
;; closure on a fresh OCaml thread that has no scheduler
;; frame, so the receive's er-suspend-marker propagates
;; out and the connection writes nothing — the Blockers
;; #4 deadlock the m2 loop observed.
;;
;; er-spawn-fun requires an er-fun (Erlang-AST-shaped
;; dict); handler IS one (created by user `fun (Req) ->
;; route(Req, Cfg) end`). To feed req-pl as the call
;; argument we stash it on the process record's
;; :pending-args field — er-sched-step-alive! reads it
;; on first step (the alternative was a host-closure-to-
;; er-fun wrapper, which needs AST construction).
((sx-handler
(fn (req-dict)
(let ((req-pl (er-request-dict-to-proplist req-dict)))
(let ((proc (er-proc-new! (er-env-new))))
(dict-set! proc :initial-fun handler)
(dict-set! proc :pending-args (list req-pl))
(er-sched-run-all!)
(let ((resp-pl (er-proc-field (get proc :pid) :exit-result)))
(er-proplist-to-dict resp-pl)))))))
(http-listen port sx-handler))))))
;; httpc:request/4(Url, Method, Headers, Body) - BRIEFING-EXCEPTION:
;; the m2 briefing's one allowed scope exception for Step 8e, mirroring
;; M1 Step 8a's http:listen wrapper on the client side.
;;
;; Url is an Erlang binary (must start with http://).
;; Method is an Erlang atom or binary; passed through to the native
;; verbatim, so callers should supply 'get / 'post or <<"GET">> as
;; appropriate (the native compares uppercase).
;; Headers is an Erlang proplist [{Name, Value}, ...]; names and
;; values are binaries or atoms (er-proplist-to-dict handles both).
;; Body is an Erlang binary (use <<>> for empty).
;;
;; Returns a 4-tuple {ok, StatusInt, HeadersProplist, BodyBinary}.
;; The native primitive raises Eval_error on DNS / connect / bad URL;
;; we catch the host exception here and re-raise as an Erlang error
;; marker so callers can use try/catch error:{network, _} -> _ end.
(define
er-bif-httpc-request
(fn
(vs)
(let
((url (nth vs 0))
(method (nth vs 1))
(headers (nth vs 2))
(body (nth vs 3)))
(let
((url-str
(cond
(er-binary? url) (list->string (map integer->char (get url :bytes)))
:else (raise (er-mk-error-marker (er-mk-atom "badarg")))))
(method-str
(cond
;; Erlang convention is lowercase atoms (get/post/put/...);
;; the HTTP wire wants uppercase. Binaries pass through so
;; callers can override with mixed-case verbs if needed.
(er-atom? method) (upcase (get method :name))
(er-binary? method) (list->string (map integer->char (get method :bytes)))
:else (raise (er-mk-error-marker (er-mk-atom "badarg")))))
(headers-dict
(cond
(er-nil? headers) (dict)
(er-cons? headers) (er-proplist-to-dict headers)
:else (raise (er-mk-error-marker (er-mk-atom "badarg")))))
(body-str
(cond
(er-binary? body) (list->string (map integer->char (get body :bytes)))
(er-nil? body) ""
:else (raise (er-mk-error-marker (er-mk-atom "badarg"))))))
(let ((resp-ref (list nil)) (err-ref (list nil)))
(guard (c (:else (set-nth! err-ref 0 c)))
(set-nth! resp-ref 0
(http-request method-str url-str headers-dict body-str)))
(cond
(not (= (nth err-ref 0) nil))
;; Host error -> Erlang error:{network, ReasonBinary}
(raise (er-mk-error-marker
(er-mk-tuple (list
(er-mk-atom "network")
(er-mk-binary (map char->integer
(string->list (str (nth err-ref 0)))))))))
:else
(let ((resp (nth resp-ref 0)))
(er-mk-tuple
(list
(er-mk-atom "ok")
(get resp :status)
(er-of-sx-deep (get resp :headers))
(er-mk-binary (map char->integer (string->list (get resp :body)))))))))))))
;; Register everything at load time.
(define
er-register-builtin-bifs!
(fn
()
(er-register-pure-bif! "erlang" "is_integer" 1 er-bif-is-integer)
(er-register-pure-bif! "erlang" "is_atom" 1 er-bif-is-atom)
(er-register-pure-bif! "erlang" "is_list" 1 er-bif-is-list)
@@ -1479,27 +1724,61 @@
(er-register-pure-bif! "erlang" "is_float" 1 er-bif-is-float)
(er-register-pure-bif! "erlang" "is_boolean" 1 er-bif-is-boolean)
(er-register-pure-bif! "erlang" "is_pid" 1 er-bif-is-pid)
(er-register-pure-bif! "erlang" "is_reference" 1 er-bif-is-reference)
(er-register-pure-bif!
"erlang"
"is_reference"
1
er-bif-is-reference)
(er-register-pure-bif! "erlang" "is_binary" 1 er-bif-is-binary)
(er-register-pure-bif! "erlang" "is_function" 1 er-bif-is-function)
(er-register-pure-bif! "erlang" "is_function" 2 er-bif-is-function)
;; erlang module — pure data ops
(er-register-pure-bif!
"erlang"
"is_function"
1
er-bif-is-function)
(er-register-pure-bif!
"erlang"
"is_function"
2
er-bif-is-function)
(er-register-pure-bif! "erlang" "length" 1 er-bif-length)
(er-register-pure-bif! "erlang" "hd" 1 er-bif-hd)
(er-register-pure-bif! "erlang" "tl" 1 er-bif-tl)
(er-register-pure-bif! "erlang" "element" 2 er-bif-element)
(er-register-pure-bif! "erlang" "tuple_size" 1 er-bif-tuple-size)
(er-register-pure-bif! "erlang" "byte_size" 1 er-bif-byte-size)
(er-register-pure-bif! "erlang" "atom_to_list" 1 er-bif-atom-to-list)
(er-register-pure-bif! "erlang" "list_to_atom" 1 er-bif-list-to-atom)
(er-register-pure-bif!
"erlang"
"atom_to_list"
1
er-bif-atom-to-list)
(er-register-pure-bif!
"erlang"
"list_to_atom"
1
er-bif-list-to-atom)
(er-register-pure-bif! "erlang" "abs" 1 er-bif-abs)
(er-register-pure-bif! "erlang" "min" 2 er-bif-min)
(er-register-pure-bif! "erlang" "max" 2 er-bif-max)
(er-register-pure-bif! "erlang" "tuple_to_list" 1 er-bif-tuple-to-list)
(er-register-pure-bif! "erlang" "list_to_tuple" 1 er-bif-list-to-tuple)
(er-register-pure-bif! "erlang" "integer_to_list" 1 er-bif-integer-to-list)
(er-register-pure-bif! "erlang" "list_to_integer" 1 er-bif-list-to-integer)
;; erlang module — process / runtime (side-effecting)
(er-register-pure-bif!
"erlang"
"tuple_to_list"
1
er-bif-tuple-to-list)
(er-register-pure-bif!
"erlang"
"list_to_tuple"
1
er-bif-list-to-tuple)
(er-register-pure-bif!
"erlang"
"integer_to_list"
1
er-bif-integer-to-list)
(er-register-pure-bif!
"erlang"
"list_to_integer"
1
er-bif-list-to-integer)
(er-register-bif! "erlang" "self" 0 er-bif-self)
(er-register-bif! "erlang" "spawn" 1 er-bif-spawn)
(er-register-bif! "erlang" "spawn" 3 er-bif-spawn)
@@ -1515,12 +1794,16 @@
(er-register-bif! "erlang" "unregister" 1 er-bif-unregister)
(er-register-bif! "erlang" "whereis" 1 er-bif-whereis)
(er-register-bif! "erlang" "registered" 0 er-bif-registered)
;; erlang module — exception raising (modelled as side-effecting)
(er-register-bif! "erlang" "throw" 1
(er-register-bif!
"erlang"
"throw"
1
(fn (vs) (raise (er-mk-throw-marker (er-bif-arg1 vs "throw")))))
(er-register-bif! "erlang" "error" 1
(er-register-bif!
"erlang"
"error"
1
(fn (vs) (raise (er-mk-error-marker (er-bif-arg1 vs "error")))))
;; lists module — all pure
(er-register-pure-bif! "lists" "reverse" 1 er-bif-lists-reverse)
(er-register-pure-bif! "lists" "map" 2 er-bif-lists-map)
(er-register-pure-bif! "lists" "foldl" 3 er-bif-lists-foldl)
@@ -1534,11 +1817,13 @@
(er-register-pure-bif! "lists" "filter" 2 er-bif-lists-filter)
(er-register-pure-bif! "lists" "any" 2 er-bif-lists-any)
(er-register-pure-bif! "lists" "all" 2 er-bif-lists-all)
(er-register-pure-bif! "lists" "duplicate" 2 er-bif-lists-duplicate)
;; io module — side-effecting (writes to io buffer)
(er-register-pure-bif!
"lists"
"duplicate"
2
er-bif-lists-duplicate)
(er-register-bif! "io" "format" 1 er-bif-io-format)
(er-register-bif! "io" "format" 2 er-bif-io-format)
;; ets module — side-effecting (mutates table state)
(er-register-bif! "ets" "new" 2 er-bif-ets-new)
(er-register-bif! "ets" "insert" 2 er-bif-ets-insert)
(er-register-bif! "ets" "lookup" 2 er-bif-ets-lookup)
@@ -1546,82 +1831,89 @@
(er-register-bif! "ets" "delete" 2 er-bif-ets-delete)
(er-register-bif! "ets" "tab2list" 1 er-bif-ets-tab2list)
(er-register-bif! "ets" "info" 2 er-bif-ets-info)
;; code module — side-effecting (mutates module registry, kills procs)
(er-register-bif! "code" "load_binary" 3 er-bif-code-load-binary)
(er-register-bif! "code" "purge" 1 er-bif-code-purge)
(er-register-bif! "code" "soft_purge" 1 er-bif-code-soft-purge)
(er-register-bif! "code" "which" 1 er-bif-code-which)
(er-register-bif! "code" "is_loaded" 1 er-bif-code-is-loaded)
(er-register-bif! "code" "all_loaded" 0 er-bif-code-all-loaded)
;; file module
(er-register-bif! "file" "read_file" 1 er-bif-file-read-file)
(er-register-bif! "file" "write_file" 2 er-bif-file-write-file)
(er-register-bif! "file" "delete" 1 er-bif-file-delete)
;; Phase 8 FFI — host-primitive BIFs (loops/fed-prims)
(er-register-pure-bif! "crypto" "hash" 2 er-bif-crypto-hash)
(er-register-pure-bif! "cid" "from_bytes" 1 er-bif-cid-from-bytes)
(er-register-pure-bif! "cid" "to_string" 1 er-bif-cid-to-string)
;; ── binary_to_list / list_to_binary (Step 3b — term codec) ──────
;; Standard Erlang semantics:
;; binary_to_list(<<B1,B2,...>>) -> [B1, B2, ...] (Erlang cons of ints)
;; list_to_binary(IoList) -> <<...>> (flattens nested
;; iolists; elements are byte ints 0-255 or binaries)
;; Bad arg / out-of-range byte / non-iolist element -> error:badarg.
(define er-bif-binary-to-list
(fn (vs)
(let ((v (nth vs 0)))
(cond
(not (er-binary? v))
(raise (er-mk-error-marker (er-mk-atom "badarg")))
:else
(let ((bs (get v :bytes)) (out (er-mk-nil)))
(for-each
(fn (i)
(set! out (er-mk-cons (nth bs (- (- (len bs) 1) i)) out)))
(range 0 (len bs)))
out)))))
;; Walk an Erlang iolist, appending bytes to `acc` (a mutable SX list).
;; Accepts: nil, cons-of-X, binary, integer in 0..255. Anything else
;; signals failure by setting (nth fail 0) to true.
(define er-iolist-walk!
(fn (v acc fail)
(cond
(nth fail 0) nil
(er-nil? v) nil
(er-cons? v)
(do (er-iolist-walk! (get v :head) acc fail)
(er-iolist-walk! (get v :tail) acc fail))
(er-binary? v)
(for-each
(fn (i) (append! acc (nth (get v :bytes) i)))
(range 0 (len (get v :bytes))))
(= (type-of v) "number")
(define
er-bif-binary-to-list
(fn
(vs)
(let
((v (nth vs 0)))
(cond
(not (er-binary? v))
(raise (er-mk-error-marker (er-mk-atom "badarg")))
:else (let
((bs (get v :bytes)) (out (er-mk-nil)))
(for-each
(fn
(i)
(set!
out
(er-mk-cons (nth bs (- (- (len bs) 1) i)) out)))
(range 0 (len bs)))
out)))))
(define
er-iolist-walk!
(fn
(v acc fail)
(cond
(and (>= v 0) (<= v 255)) (append! acc v)
:else (set-nth! fail 0 true))
:else (set-nth! fail 0 true))))
(define er-bif-list-to-binary
(fn (vs)
(let ((v (nth vs 0)) (acc (list)) (fail (list false)))
(cond
(not (or (er-nil? v) (er-cons? v) (er-binary? v)))
(raise (er-mk-error-marker (er-mk-atom "badarg")))
:else
(nth fail 0)
nil
(er-nil? v)
nil
(er-cons? v)
(do
(er-iolist-walk! v acc fail)
(cond
(nth fail 0)
(er-iolist-walk! (get v :head) acc fail)
(er-iolist-walk! (get v :tail) acc fail))
(er-binary? v)
(for-each
(fn (i) (append! acc (nth (get v :bytes) i)))
(range 0 (len (get v :bytes))))
(= (type-of v) "number")
(cond
(and (>= v 0) (<= v 255))
(append! acc v)
:else (set-nth! fail 0 true))
:else (set-nth! fail 0 true))))
(define
er-bif-list-to-binary
(fn
(vs)
(let
((v (nth vs 0)) (acc (list)) (fail (list false)))
(cond
(not (or (er-nil? v) (er-cons? v) (er-binary? v)))
(raise (er-mk-error-marker (er-mk-atom "badarg")))
:else (do
(er-iolist-walk! v acc fail)
(cond
(nth fail 0)
(raise (er-mk-error-marker (er-mk-atom "badarg")))
:else (er-mk-binary acc)))))))
:else (er-mk-binary acc)))))))
(er-register-bif! "file" "list_dir" 1 er-bif-file-list-dir)
(er-register-pure-bif! "erlang" "binary_to_list" 1 er-bif-binary-to-list)
(er-register-pure-bif! "erlang" "list_to_binary" 1 er-bif-list-to-binary)
(er-register-pure-bif!
"erlang"
"binary_to_list"
1
er-bif-binary-to-list)
(er-register-pure-bif!
"erlang"
"list_to_binary"
1
er-bif-list-to-binary)
(er-mk-atom "ok")))
;; Register everything at load time.
(er-register-bif! "http" "listen" 2 er-bif-http-listen)
(er-register-bif! "httpc" "request" 4 er-bif-httpc-request)
(er-register-builtin-bifs!)

38
lib/feed/acl.sx
View File

@@ -1,38 +0,0 @@
; feed/acl — per-viewer visibility filtering. The same candidate stream yields
; different timelines for different viewers, so ACL is applied per request and
; pre-ACL timelines are never cached.
;
; permit? is injected: (permit? viewer activity) -> bool. Wire a real acl-sx
; predicate here; feed/permit-acl? is a self-contained default that reads an
; optional :visible-to allowlist on the activity.
;
; Requires: lib/feed/normalize.sx, lib/feed/stream.sx, lib/feed/fanout.sx
; (feed/-elem?), lib/feed/rank.sx (feed/top).
; default permit: actor always sees own activity; absent/nil :visible-to is
; public; otherwise viewer must be in the allowlist.
(define
feed/permit-acl?
(fn
(viewer a)
(or
(equal? viewer (get a :actor))
(let
((allowed (get a :visible-to nil)))
(if (= allowed nil) true (feed/-elem? viewer allowed))))))
(define feed/permit-public? (fn (viewer a) true))
; filter a stream to what viewer may read
(define
feed/visible
(fn
(stream viewer permit?)
(feed/filter stream (fn (a) (permit? viewer a)))))
; the capstone: candidate stream -> ACL for viewer -> rank -> top-N
(define
feed/timeline
(fn
(stream viewer permit? score-fn n)
(feed/top (feed/visible stream viewer permit?) score-fn n)))

62
lib/feed/aggregate.sx
View File

@@ -1,62 +0,0 @@
; feed/aggregate — group-by / counting via key-reduce. Keys must be strings
; (dict keys), so composite keys (actor, day) are joined into one string.
;
; Requires: lib/feed/normalize.sx, lib/feed/stream.sx.
; group activities into a dict: key-string -> (list of activities), order-preserving
(define
feed/group-by
(fn
(stream key-fn)
(reduce
(fn
(g a)
(let
((k (key-fn a)))
(assoc g k (append (get g k (list)) (list a)))))
{}
(feed/items stream))))
; key-string -> count
(define
feed/group-count
(fn
(stream key-fn)
(reduce
(fn
(g a)
(let
((k (key-fn a)))
(assoc g k (+ (get g k 0) 1))))
{}
(feed/items stream))))
; --- composite keys ---------------------------------------------------------
(define feed/day (fn (at window) (floor (/ at window))))
; (actor, day-bucket) -> "actor#day"
(define
feed/actor-day-key
(fn
(window)
(fn
(a)
(string-append
(get a :actor)
"#"
(number->string (feed/day (get a :at) window))))))
(define
feed/by-actor-day
(fn (stream window) (feed/group-count stream (feed/actor-day-key window))))
; per-actor activity counts
(define
feed/actor-counts
(fn (stream) (feed/group-count stream feed/actor)))
; per-object activity counts (engagement)
(define
feed/object-counts
(fn (stream) (feed/group-count stream feed/object)))

24
lib/feed/api.sx
View File

@@ -1,24 +0,0 @@
; feed/api — ergonomic API over the stream layer for non-APL callers.
; A single mutable activity log; post appends, all returns it as a stream.
;
; Requires: lib/feed/normalize.sx, lib/feed/stream.sx (loaded by harness).
(define feed/-log (list))
; post — normalize then append. Returns the stored activity.
(define
feed/post
(fn
(raw)
(let
((a (feed/normalize raw)))
(begin (set! feed/-log (append feed/-log (list a))) a))))
; all — the whole log as a stream (insertion order)
(define feed/all (fn () (feed/stream feed/-log)))
; reset! — clear the log (test hygiene)
(define feed/reset! (fn () (begin (set! feed/-log (list)) nil)))
; size — number of posted activities
(define feed/size (fn () (len feed/-log)))

125
lib/feed/conformance.sh
View File

@@ -1,125 +0,0 @@
#!/usr/bin/env bash
# lib/feed/conformance.sh — run feed 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=(basic fanout rank integration content notify home dedupe trending mute page thread)
OUT_JSON="lib/feed/scoreboard.json"
OUT_MD="lib/feed/scoreboard.md"
run_suite() {
local suite=$1
local file="lib/feed/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/feed/normalize.sx")
(load "lib/feed/stream.sx")
(load "lib/feed/api.sx")
(load "lib/feed/fanout.sx")
(load "lib/feed/dedupe.sx")
(load "lib/feed/aggregate.sx")
(load "lib/feed/rank.sx")
(load "lib/feed/acl.sx")
(load "lib/feed/fed.sx")
(load "lib/feed/content.sx")
(load "lib/feed/notify.sx")
(load "lib/feed/home.sx")
(load "lib/feed/trending.sx")
(load "lib/feed/mute.sx")
(load "lib/feed/page.sx")
(load "lib/feed/thread.sx")
(epoch 2)
(eval "(define feed-test-pass 0)")
(eval "(define feed-test-fail 0)")
(eval "(define feed-test (fn (name got expected) (if (= got expected) (set! feed-test-pass (+ feed-test-pass 1)) (set! feed-test-fail (+ feed-test-fail 1)))))")
(epoch 3)
(load "${file}")
(epoch 4)
(eval "(list feed-test-pass feed-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 feed 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 '# feed Conformance Scoreboard\n\n'
printf '_Generated by `lib/feed/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 ]

68
lib/feed/content.sx
View File

@@ -1,68 +0,0 @@
; feed/content — TF-IDF relevance over activity :tags. Rare tags carry more
; signal, so an activity matching an uncommon tag ranks above one matching a
; common tag. Composes with rank.sx: feed/tfidf-score is just another scorer.
;
; Requires: lib/feed/normalize.sx, lib/feed/stream.sx, lib/feed/fanout.sx
; (feed/-distinct), lib/feed/rank.sx (feed/rank).
; document frequency: tag -> number of activities whose :tags contain it
; (a tag repeated within one activity counts once toward df)
(define
feed/tag-df
(fn
(stream)
(reduce
(fn
(df a)
(reduce
(fn (d t) (assoc d t (+ (get d t 0) 1)))
df
(feed/-distinct (get a :tags))))
{}
(feed/items stream))))
; inverse document frequency: tag -> log(N / df)
(define
feed/tag-idf
(fn
(stream)
(let
((n (feed/count stream)) (df (feed/tag-df stream)))
(reduce
(fn (idf t) (assoc idf t (log (/ n (get df t)))))
{}
(keys df)))))
; term frequency within one activity: tag -> occurrence count
(define
feed/-tf
(fn
(a)
(reduce
(fn (tf t) (assoc tf t (+ (get tf t 0) 1)))
{}
(get a :tags))))
; relevance of an activity to a query (list of tags) given precomputed idf:
; sum over query tags of tf(tag in activity) * idf(tag in corpus)
(define
feed/tfidf-score
(fn
(idf query)
(fn
(a)
(let
((tf (feed/-tf a)))
(reduce
(fn
(acc t)
(+ acc (* (get tf t 0) (get idf t 0))))
0
query)))))
; rank a stream by relevance to query tags (idf computed over the stream itself)
(define
feed/by-relevance
(fn
(stream query)
(feed/rank stream (feed/tfidf-score (feed/tag-idf stream) query))))

76
lib/feed/dedupe.sx
View File

@@ -1,76 +0,0 @@
; feed/dedupe — collapse duplicate items, keeping first occurrence per key.
; Each verb may want its own key (see briefing): "alice posted X" keys on
; (actor verb object) — distinct per actor; "alice liked X / bob liked X"
; collapse on (verb object) so the cross-actor likes fold into one.
;
; Requires: lib/feed/normalize.sx, lib/feed/stream.sx, lib/feed/fanout.sx
; (feed/-elem? lives in fanout.sx).
; generic: dedupe a stream by key-fn, first occurrence wins (stable)
(define
feed/-dedup-by
(fn
(items key-fn)
(get
(reduce
(fn
(st x)
(let
((k (key-fn x)))
(if (feed/-elem? k (get st :seen)) st {:seen (append (get st :seen) (list k)) :out (append (get st :out) (list x))})))
{:seen (list) :out (list)}
items)
:out)))
(define
feed/dedupe
(fn
(stream key-fn)
(feed/stream (feed/-dedup-by (feed/items stream) key-fn))))
; --- keys -------------------------------------------------------------------
(define
feed/activity-key
(fn (a) (list (get a :actor) (get a :verb) (get a :object))))
; collapse cross-actor duplicates of the same verb+object (e.g. likes)
(define feed/collapse-key (fn (a) (list (get a :verb) (get a :object))))
; per-receiver inbox key — one inbox event per (receiver, actor, verb, object)
(define
feed/event-key
(fn
(ev)
(let
((a (get ev :activity)))
(list (get ev :to) (get a :actor) (get a :verb) (get a :object)))))
; verbs whose duplicates collapse across actors (reactions, not authorship).
; rebindable: callers can (set! feed/collapse-verbs ...) to tune the policy.
(define
feed/collapse-verbs
(list "like" "favourite" "follow" "boost" "repost"))
; per-verb key: collapse-verbs fold on (verb object); the rest key on
; (actor verb object).
(define
feed/smart-key
(fn
(a)
(if
(feed/-elem? (get a :verb) feed/collapse-verbs)
(feed/collapse-key a)
(feed/activity-key a))))
; --- ready-made dedupers ----------------------------------------------------
(define feed/dedupe-activities (fn (s) (feed/dedupe s feed/activity-key)))
(define feed/dedupe-collapse (fn (s) (feed/dedupe s feed/collapse-key)))
; verb-aware: reactions collapse cross-actor, posts stay distinct per actor
(define feed/dedupe-smart (fn (s) (feed/dedupe s feed/smart-key)))
; dedupe an inbox: at most one event per receiver per (actor verb object)
(define feed/dedupe-inbox (fn (inbox) (feed/dedupe inbox feed/event-key)))

114
lib/feed/fanout.sx
View File

@@ -1,114 +0,0 @@
; feed/fanout — THE SHOWCASE. Fan activities out to followers via the APL outer
; product (∘.×). activities ∘.× audience → an (activity × follower) matrix of
; inbox events; flatten to a vector; guard-keep only real follow edges.
;
; Requires: lib/apl/runtime.sx, lib/feed/normalize.sx, lib/feed/stream.sx.
;
; NOTE: apl-outer's combiner result is run through (if (scalar? r) (disclose r) r).
; A bare dict counts as a scalar (shape ()) and disclose nils it — so the combiner
; must (enclose ...) its event dict; apl-outer then discloses it back intact.
; --- graph: {followee -> (list of followers)} -------------------------------
(define feed/followers (fn (graph user) (get graph user (list))))
; build a graph from (follower followee) edges: "follower follows followee"
(define
feed/follow-graph
(fn
(edges)
(reduce
(fn
(g e)
(let
((follower (first e)) (followee (nth e 1)))
(assoc
g
followee
(append (feed/followers g followee) (list follower)))))
{}
edges)))
; --- helpers ----------------------------------------------------------------
; unwrap an apl-scalar (has :ravel) back to its value; pass activities through
(define
feed/-val
(fn
(x)
(if (and (= (type-of x) "dict") (has-key? x :ravel)) (disclose x) x)))
(define feed/-elem? (fn (x lst) (some (fn (y) (equal? x y)) lst)))
(define
feed/-distinct
(fn
(lst)
(if
(= (len lst) 0)
(list)
(get (apl-unique (make-array (list (len lst)) lst)) :ravel))))
; rank-2 matrix -> rank-1 stream of its ravel
(define feed/-flatten (fn (arr) (feed/stream (get arr :ravel))))
; distinct receivers across the whole graph, sorted for determinism
; (dict key order is unspecified, so sort to pin audience/recipient ordering)
(define
feed/audience
(fn
(graph)
(sort
(feed/-distinct
(reduce
(fn (acc k) (append acc (feed/followers graph k)))
(list)
(keys graph))))))
; --- the outer product ------------------------------------------------------
; one (activity, follower) inbox event, enclosed so apl-outer keeps the dict
(define feed/-mk-event (fn (a f) (enclose {:activity (feed/-val a) :to (feed/-val f)})))
; keep events where :to actually follows the activity's actor
(define
feed/-edge?
(fn
(graph)
(fn
(ev)
(feed/-elem?
(get ev :to)
(feed/followers graph (get (get ev :activity) :actor))))))
; fanout — activities ∘.× audience, flatten, guard-keep real edges
(define
feed/fanout
(fn
(stream graph)
(let
((matrix (apl-outer feed/-mk-event stream (feed/stream (feed/audience graph)))))
(feed/filter (feed/-flatten matrix) (feed/-edge? graph)))))
; --- inbox queries ----------------------------------------------------------
(define
feed/inbox-for
(fn
(inbox user)
(feed/filter inbox (fn (ev) (equal? (get ev :to) user)))))
(define
feed/recipients
(fn
(inbox)
(feed/-distinct (map (fn (ev) (get ev :to)) (feed/items inbox)))))
; the activities (unwrapped) destined for a user
(define
feed/inbox-activities
(fn
(inbox user)
(map
(fn (ev) (get ev :activity))
(feed/items (feed/inbox-for inbox user)))))

60
lib/feed/fed.sx
View File

@@ -1,60 +0,0 @@
; feed/fed — federation. Outbound: a local post fans out, then splits into local
; vs remote inboxes; remote events are handed to an injected send-fn. Inbound:
; peer activities merge into the local stream, deduped. Backfill: pull peer
; history via an injected fetch-fn and merge.
;
; remote? / send-fn / fetch-fn are injected so real fed-sx transport wires in here
; without feed depending on it.
;
; Requires: lib/feed/normalize.sx, lib/feed/stream.sx, lib/feed/fanout.sx,
; lib/feed/dedupe.sx.
; --- merge / ingest ---------------------------------------------------------
(define
feed/merge
(fn (s1 s2) (feed/stream (append (feed/items s1) (feed/items s2)))))
; merge a peer stream into local, dropping (actor verb object) duplicates
(define
feed/ingest
(fn (local peer) (feed/dedupe-activities (feed/merge local peer))))
; --- inbound ----------------------------------------------------------------
; peer pushes raw activities to the local inbox; normalize + ingest
(define
feed/inbound
(fn
(local raw-activities)
(feed/ingest local (feed/stream (map feed/normalize raw-activities)))))
; backfill on subscribe: pull peer history via fetch-fn, normalize, ingest
(define
feed/backfill
(fn (local fetch-fn peer-id) (feed/inbound local (fetch-fn peer-id))))
; --- outbound ---------------------------------------------------------------
; split an inbox into local vs remote deliveries by viewer-id predicate
(define feed/partition-inbox (fn (inbox remote?) {:local (feed/filter inbox (fn (ev) (not (remote? (get ev :to))))) :remote (feed/filter inbox (fn (ev) (remote? (get ev :to))))}))
; fan a stream out over the graph, then partition by locality
(define
feed/federate
(fn
(stream graph remote?)
(feed/partition-inbox (feed/fanout stream graph) remote?)))
; deliver: hand each remote event to send-fn, return the local inbox to enqueue
(define
feed/deliver
(fn
(stream graph remote? send-fn)
(let
((parts (feed/federate stream graph remote?)))
(begin
(for-each
(fn (ev) (send-fn (get ev :to) (get ev :activity)))
(feed/items (get parts :remote)))
(get parts :local)))))

23
lib/feed/home.sx
View File

@@ -1,23 +0,0 @@
; feed/home — the capstone. A user's home timeline is the whole pipeline as one
; line: fan all activities out over the follow graph, take the events landing in
; the viewer's inbox, dedupe cross-posts, apply the viewer's ACL, rank, take N.
;
; Requires: fanout.sx, dedupe.sx, acl.sx (feed/timeline), rank.sx, stream.sx.
; the activities in a user's inbox, as a stream
(define
feed/inbox-stream
(fn (inbox user) (feed/stream (feed/inbox-activities inbox user))))
; fanout ∘ inbox ∘ dedupe ∘ ACL ∘ rank ∘ take
(define
feed/home
(fn
(stream graph viewer permit? score-fn n)
(feed/timeline
(feed/dedupe-activities
(feed/inbox-stream (feed/fanout stream graph) viewer))
viewer
permit?
score-fn
n)))

44
lib/feed/mute.sx
View File

@@ -1,44 +0,0 @@
; feed/mute — viewer-controlled filtering. ACL (acl.sx) is author-controlled
; visibility; mute is the reader's own preference: hide muted actors or tags.
; Like ACL it is per-viewer and applied per request, never cached.
;
; Requires: lib/feed/normalize.sx, lib/feed/stream.sx, lib/feed/fanout.sx
; (feed/-elem?).
; drop activities authored by a muted actor
(define
feed/mute-actors
(fn
(stream actors)
(feed/filter
stream
(fn (a) (not (feed/-elem? (get a :actor) actors))))))
; drop activities carrying any muted tag
(define
feed/mute-tags
(fn
(stream tags)
(feed/filter
stream
(fn (a) (not (some (fn (t) (feed/-elem? t tags)) (get a :tags)))))))
; drop activities about a muted object (thread mute)
(define
feed/mute-objects
(fn
(stream objects)
(feed/filter
stream
(fn (a) (not (feed/-elem? (get a :object) objects))))))
; apply a viewer preference bag: {:mute-actors (...) :mute-tags (...) :mute-objects (...)}
(define
feed/apply-prefs
(fn
(stream prefs)
(feed/mute-objects
(feed/mute-tags
(feed/mute-actors stream (get prefs :mute-actors (list)))
(get prefs :mute-tags (list)))
(get prefs :mute-objects (list)))))

31
lib/feed/normalize.sx
View File

@@ -1,31 +0,0 @@
; feed/normalize — coerce arbitrary input into the canonical activity record.
; An activity is a small dict {:actor :verb :object :at :tags}; a stream is an
; APL vector of such dicts (see stream.sx). Extra keys on the raw input survive
; (e.g. :visible-to for ACL, peer metadata for federation) — :tags is the
; flexible bag but the record is not closed.
(define feed/activity-keys (list :actor :verb :object :at :tags))
(define
feed/normalize
(fn
(raw)
(let
((d (if (= (type-of raw) "dict") raw {})))
(merge d {:actor (get d :actor "") :object (get d :object nil) :at (get d :at 0) :tags (let ((t (get d :tags (list)))) (if (list? t) t (list t))) :verb (get d :verb "post")}))))
(define
feed/activity
(fn (actor verb object at tags) (feed/normalize {:actor actor :object object :at at :tags tags :verb verb})))
(define feed/actor (fn (a) (get a :actor)))
(define feed/verb (fn (a) (get a :verb)))
(define feed/object (fn (a) (get a :object)))
(define feed/at (fn (a) (get a :at)))
(define feed/tags (fn (a) (get a :tags)))
(define
feed/activity?
(fn
(a)
(and (= (type-of a) "dict") (has-key? a :actor) (has-key? a :verb))))

45
lib/feed/notify.sx
View File

@@ -1,45 +0,0 @@
; feed/notify — a notification feed is a thin layer over a recipient's inbox:
; the events directed at a user, optionally verb-filtered, and a digest that
; collapses "alice, bob and 1 other liked X" by (verb, object).
;
; Requires: lib/feed/normalize.sx, lib/feed/stream.sx, lib/feed/fanout.sx
; (feed/inbox-for, feed/-elem?).
; all inbox events for a user (their raw notifications)
(define feed/notifications (fn (inbox user) (feed/inbox-for inbox user)))
; restrict to notification-worthy verbs (e.g. (list "like" "reply" "follow"))
(define
feed/notify-verbs
(fn
(inbox user verbs)
(feed/filter
(feed/inbox-for inbox user)
(fn (ev) (feed/-elem? (get (get ev :activity) :verb) verbs)))))
; group key "verb|object" — deterministic, sortable
(define
feed/-notify-key
(fn
(ev)
(let
((a (get ev :activity)))
(string-append (get a :verb) "|" (get a :object)))))
; digest: one entry per (verb, object) with the distinct actors and a count,
; ordered by key for determinism.
(define
feed/notify-digest
(fn
(inbox user)
(let
((events (feed/items (feed/inbox-for inbox user))))
(let
((groups (reduce (fn (g ev) (let ((a (get ev :activity)) (k (feed/-notify-key ev))) (let ((cur (get g k {:object (get a :object) :actors (list) :verb (get a :verb)}))) (assoc g k (assoc cur :actors (append (get cur :actors) (list (get a :actor)))))))) {} events)))
(map
(fn
(k)
(let
((grp (get groups k)))
(assoc grp :count (len (get grp :actors)))))
(sort (keys groups)))))))

50
lib/feed/page.sx
View File

@@ -1,50 +0,0 @@
; feed/page — pagination. Offset/limit for indexed access, and cursor-based
; (by :at) for recency feeds, which is stable under inserts: a cursor is the
; :at of the last item seen, and the next page is the newest items older than it.
;
; Requires: lib/feed/stream.sx (feed/recent, feed/take, feed/filter).
; --- offset / limit ---------------------------------------------------------
(define
feed/page
(fn
(stream offset limit)
(feed/stream (take (drop (feed/items stream) offset) limit))))
(define
feed/page-count
(fn (stream limit) (ceil (/ (feed/count stream) limit))))
; --- cursor (recency feeds) -------------------------------------------------
; activities strictly older than cursor (scroll down / load older)
(define
feed/before
(fn
(stream cursor)
(feed/filter stream (fn (a) (< (get a :at) cursor)))))
; activities strictly newer than cursor (load newer / "N new posts")
(define
feed/after
(fn
(stream cursor)
(feed/filter stream (fn (a) (> (get a :at) cursor)))))
; one page: the `limit` newest activities older than cursor, newest first
(define
feed/page-before
(fn
(stream cursor limit)
(feed/take (feed/recent (feed/before stream cursor)) limit)))
; cursor to fetch the next (older) page: :at of the last item of a page,
; or nil when the page is empty (end of feed)
(define
feed/next-cursor
(fn
(page)
(let
((items (feed/items page)))
(if (= (len items) 0) nil (get (last items) :at)))))

92
lib/feed/rank.sx
View File

@@ -1,92 +0,0 @@
; feed/rank — scoring + ranking. Scorers are (activity -> number). Ranking is a
; stable two-pass grade-down: first by :at descending (the tiebreak), then by
; score descending — so ties resolve by recency, then by input order. Fully
; deterministic on ties.
;
; Requires: lib/apl/runtime.sx, lib/feed/normalize.sx, lib/feed/stream.sx.
; --- scorers ----------------------------------------------------------------
; recency: half-life decay. score = 0.5 ^ (age / half-life). at==now -> 1.0.
(define
feed/recency
(fn
(now half-life)
(fn (a) (expt 0.5 (/ (- now (get a :at)) half-life)))))
; velocity: how many of this actor's activities fall in (at-window, at] —
; a burst of recent activity scores higher.
(define
feed/velocity
(fn
(stream window)
(fn
(a)
(len
(filter
(fn
(b)
(and
(equal? (get b :actor) (get a :actor))
(<= (get b :at) (get a :at))
(> (get b :at) (- (get a :at) window))))
(feed/items stream))))))
; engagement: how many activities in the stream touch this activity's :object
(define
feed/engagement
(fn
(stream)
(fn
(a)
(len
(filter
(fn (b) (equal? (get b :object) (get a :object)))
(feed/items stream))))))
; composite: weighted sum. parts = (list (list weight scorer) ...)
(define
feed/composite
(fn
(parts)
(fn
(a)
(reduce
(fn (acc p) (+ acc (* (first p) ((nth p 1) a))))
0
parts))))
; --- ranking ----------------------------------------------------------------
; stable reorder of items by key-fn, descending (grade-down is stable)
(define
feed/-desc-by
(fn
(items key-fn)
(let
((keys (make-array (list (len items)) (map key-fn items))))
(let
((order (get (apl-grade-down keys) :ravel)))
(map (fn (i) (nth items (- i 1))) order)))))
; rank by score descending; ties -> :at descending -> input order
(define
feed/rank
(fn
(stream score-fn)
(let
((by-at (feed/-desc-by (feed/items stream) feed/at)))
(feed/stream (feed/-desc-by by-at score-fn)))))
; attach a :score to each activity (for inspection / debugging)
(define
feed/with-scores
(fn
(stream score-fn)
(feed/stream
(map (fn (a) (assoc a :score (score-fn a))) (feed/items stream)))))
; top-N ranked timeline
(define
feed/top
(fn (stream score-fn n) (feed/take (feed/rank stream score-fn) n)))

19
lib/feed/scoreboard.json
View File

@@ -1,19 +0,0 @@
{
"suites": {
"basic": {"pass": 30, "fail": 0},
"fanout": {"pass": 29, "fail": 0},
"rank": {"pass": 24, "fail": 0},
"integration": {"pass": 22, "fail": 0},
"content": {"pass": 15, "fail": 0},
"notify": {"pass": 8, "fail": 0},
"home": {"pass": 6, "fail": 0},
"dedupe": {"pass": 9, "fail": 0},
"trending": {"pass": 11, "fail": 0},
"mute": {"pass": 9, "fail": 0},
"page": {"pass": 14, "fail": 0},
"thread": {"pass": 12, "fail": 0}
},
"total_pass": 189,
"total_fail": 0,
"total": 189
}

19
lib/feed/scoreboard.md
View File

@@ -1,19 +0,0 @@
# feed Conformance Scoreboard
_Generated by `lib/feed/conformance.sh`_
| Suite | Pass | Fail | Total |
|-------|-----:|-----:|------:|
| basic | 30 | 0 | 30 |
| fanout | 29 | 0 | 29 |
| rank | 24 | 0 | 24 |
| integration | 22 | 0 | 22 |
| content | 15 | 0 | 15 |
| notify | 8 | 0 | 8 |
| home | 6 | 0 | 6 |
| dedupe | 9 | 0 | 9 |
| trending | 11 | 0 | 11 |
| mute | 9 | 0 | 9 |
| page | 14 | 0 | 14 |
| thread | 12 | 0 | 12 |
| **Total** | **189** | **0** | **189** |

75
lib/feed/stream.sx
View File

@@ -1,75 +0,0 @@
; feed/stream — a stream is an APL vector (rank-1 array) whose ravel holds
; activity dicts. Operations lift APL primitives onto this shape: filter via
; compress (/), sort via grade (⍋), take via ↑, reverse via ⌽.
;
; Requires: lib/apl/runtime.sx, lib/feed/normalize.sx (loaded by harness).
(define feed/stream (fn (acts) (make-array (list (len acts)) acts)))
(define feed/items (fn (s) (get s :ravel)))
(define feed/count (fn (s) (len (get s :ravel))))
(define feed/empty (feed/stream (list)))
(define feed/empty? (fn (s) (= (feed/count s) 0)))
; filter — bool mask ∘ compress. pred : activity -> truthy
(define
feed/filter
(fn
(s pred)
(let
((items (get s :ravel)))
(let
((mask (make-array (list (len items)) (map (fn (a) (if (pred a) 1 0)) items))))
(apl-compress mask s)))))
; sort-by — ascending, stable on ties (grade-up is stable). key-fn : activity -> number
(define
feed/sort-by
(fn
(s key-fn)
(let
((items (get s :ravel)))
(let
((keys (make-array (list (len items)) (map key-fn items))))
(let
((order (get (apl-grade-up keys) :ravel)))
(feed/stream (map (fn (i) (nth items (- i 1))) order)))))))
(define feed/sort-by-at (fn (s) (feed/sort-by s feed/at)))
; newest-first: ascending sort then reverse (⌽)
(define feed/recent (fn (s) (apl-reverse (feed/sort-by-at s))))
; take N (↑), clamped to stream length so it never over-takes/pads
(define
feed/take
(fn
(s n)
(let
((c (feed/count s)))
(if (>= n c) s (apl-take (apl-scalar n) s)))))
(define feed/reverse (fn (s) (apl-reverse s)))
; common predicates
(define
feed/by-actor
(fn (s actor) (feed/filter s (fn (a) (equal? (get a :actor) actor)))))
(define
feed/by-verb
(fn (s verb) (feed/filter s (fn (a) (equal? (get a :verb) verb)))))
(define
feed/by-object
(fn
(s object)
(feed/filter s (fn (a) (equal? (get a :object) object)))))
; activities at or after timestamp t
(define
feed/since
(fn (s t) (feed/filter s (fn (a) (>= (get a :at) t)))))

118
lib/feed/tests/basic.sx
View File

@@ -1,118 +0,0 @@
; Phase 1 — normalize, stream ops, api. Uses the feed-test harness
; (feed-test name got expected) provided by conformance.sh.
; ---------- normalize ----------
(feed-test
"normalize default actor"
(feed/actor (feed/normalize {}))
"")
(feed-test
"normalize default verb"
(feed/verb (feed/normalize {}))
"post")
(feed-test
"normalize default at"
(feed/at (feed/normalize {}))
0)
(feed-test
"normalize default object"
(feed/object (feed/normalize {}))
nil)
(feed-test
"normalize default tags"
(feed/tags (feed/normalize {}))
(list))
(feed-test
"normalize keeps actor"
(feed/actor (feed/normalize {:actor "alice"}))
"alice")
(feed-test
"normalize keeps verb"
(feed/verb (feed/normalize {:verb "like"}))
"like")
(feed-test
"normalize scalar tag -> list"
(feed/tags (feed/normalize {:tags "x"}))
(list "x"))
(feed-test
"normalize list tags kept"
(feed/tags (feed/normalize {:tags (list "a" "b")}))
(list "a" "b"))
(feed-test
"activity constructor at"
(feed/at (feed/activity "a" "post" "o" 5 (list)))
5)
(feed-test
"activity? on activity"
(feed/activity? (feed/normalize {:actor "a"}))
true)
(feed-test "activity? on number" (feed/activity? 5) false)
(feed-test "activity? on bare dict" (feed/activity? {:foo 1}) false)
; ---------- stream ----------
(define
S
(feed/stream
(list
(feed/activity "alice" "post" "p1" 30 (list))
(feed/activity "bob" "like" "p1" 10 (list))
(feed/activity "alice" "post" "p2" 20 (list)))))
(feed-test "stream count" (feed/count S) 3)
(feed-test "stream items len" (len (feed/items S)) 3)
(feed-test
"sort-by-at actors asc"
(map feed/actor (feed/items (feed/sort-by-at S)))
(list "bob" "alice" "alice"))
(feed-test
"recent newest first"
(map feed/at (feed/items (feed/recent S)))
(list 30 20 10))
(feed-test
"take 2 of recent"
(feed/count (feed/take (feed/recent S) 2))
2)
(feed-test
"take clamps past end"
(feed/count (feed/take S 10))
3)
(feed-test
"by-actor alice count"
(feed/count (feed/by-actor S "alice"))
2)
(feed-test
"by-verb like actor"
(map feed/actor (feed/items (feed/by-verb S "like")))
(list "bob"))
(feed-test
"by-object p1 count"
(feed/count (feed/by-object S "p1"))
2)
(feed-test
"since 20 count"
(feed/count (feed/since S 20))
2)
(feed-test
"reverse ats"
(map feed/at (feed/items (feed/reverse S)))
(list 20 10 30))
(feed-test "empty? on empty" (feed/empty? feed/empty) true)
(feed-test
"empty? on filtered-out"
(feed/empty? (feed/by-actor S "zzz"))
true)
; ---------- api ----------
(feed/reset!)
(feed/post {:actor "x" :at 1 :verb "post"})
(feed/post {:actor "y" :at 2 :verb "like"})
(feed-test "api size after posts" (feed/size) 2)
(feed-test "api all count" (feed/count (feed/all)) 2)
(feed-test
"post returns normalized verb"
(feed/verb (feed/post {:actor "z"}))
"post")
(feed-test "api size after third post" (feed/size) 3)

85
lib/feed/tests/content.sx
View File

@@ -1,85 +0,0 @@
; Follow-up — TF-IDF content ranking over :tags. (feed-test name got expected)
(define
corpus
(feed/stream
(list
(feed/normalize {:actor "u" :object "o1" :at 10 :tags (list "cats" "funny")})
(feed/normalize {:actor "u" :object "o2" :at 20 :tags (list "cats" "news")})
(feed/normalize {:actor "u" :object "o3" :at 30 :tags (list "politics" "news")})
(feed/normalize {:actor "u" :object "o4" :at 40 :tags (list "cats")}))))
; ---------- document frequency ----------
(feed-test "df cats" (get (feed/tag-df corpus) "cats") 3)
(feed-test "df news" (get (feed/tag-df corpus) "news") 2)
(feed-test "df funny" (get (feed/tag-df corpus) "funny") 1)
(feed-test "df politics" (get (feed/tag-df corpus) "politics") 1)
(feed-test "df full" (feed/tag-df corpus) {:news 2 :funny 1 :politics 1 :cats 3})
; ---------- inverse document frequency ----------
(feed-test
"idf news = log(4/2)"
(get (feed/tag-idf corpus) "news")
(log 2))
(feed-test
"idf funny = log(4/1)"
(get (feed/tag-idf corpus) "funny")
(log 4))
(feed-test
"rarer tag has higher idf"
(>
(get (feed/tag-idf corpus) "funny")
(get (feed/tag-idf corpus) "cats"))
true)
; ---------- tf-idf scoring ----------
(define idf (feed/tag-idf corpus))
(feed-test
"score query funny on o1"
((feed/tfidf-score idf (list "funny")) (feed/normalize {:actor "u" :object "x" :tags (list "cats" "funny")}))
(log 4))
(feed-test
"score query funny on non-match"
((feed/tfidf-score idf (list "funny")) (feed/normalize {:actor "u" :object "x" :tags (list "cats")}))
0)
(feed-test
"unknown query tag scores 0"
((feed/tfidf-score idf (list "zzz")) (feed/normalize {:actor "u" :object "x" :tags (list "cats")}))
0)
; ---------- ranking by relevance ----------
; query news: o2,o3 match (score log2), o1,o4 don't (0); ties break by :at desc
(feed-test
"by-relevance news order"
(map
(fn (a) (get a :object))
(feed/items (feed/by-relevance corpus (list "news"))))
(list "o3" "o2" "o4" "o1"))
; query funny: only o1 matches -> ranks first
(feed-test
"by-relevance funny first"
(get
(nth (feed/items (feed/by-relevance corpus (list "funny"))) 0)
:object)
"o1")
; query (cats news): o2 carries both tags -> highest combined tf-idf
(feed-test
"by-relevance cats+news top"
(get
(nth
(feed/items (feed/by-relevance corpus (list "cats" "news")))
0)
:object)
"o2")
(feed-test
"by-relevance preserves count"
(feed/count (feed/by-relevance corpus (list "cats")))
4)

56
lib/feed/tests/dedupe.sx
View File

@@ -1,56 +0,0 @@
; Follow-up — verb-aware (smart) dedupe. (feed-test name got expected)
; reactions (like/follow) collapse cross-actor; posts stay distinct per actor
(define
M
(feed/stream
(list
(feed/activity "alice" "like" "X" 1 (list))
(feed/activity "bob" "like" "X" 2 (list))
(feed/activity "alice" "post" "P" 3 (list))
(feed/activity "bob" "post" "P" 4 (list))
(feed/activity "alice" "follow" "C" 5 (list))
(feed/activity "bob" "follow" "C" 6 (list))))) ; collapses
(feed-test
"smart dedupe total"
(feed/count (feed/dedupe-smart M))
4)
(feed-test
"smart keeps both posts"
(feed/count (feed/by-verb (feed/dedupe-smart M) "post"))
2)
(feed-test
"smart collapses likes to one"
(feed/count (feed/by-verb (feed/dedupe-smart M) "like"))
1)
(feed-test
"smart collapses follows to one"
(feed/count (feed/by-verb (feed/dedupe-smart M) "follow"))
1)
(feed-test
"collapsed like keeps first actor"
(map feed/actor (feed/items (feed/by-verb (feed/dedupe-smart M) "like")))
(list "alice"))
; contrast: plain activity dedupe keeps cross-actor likes distinct
(feed-test
"activity dedupe keeps both likes"
(feed/count (feed/by-verb (feed/dedupe-activities M) "like"))
2)
; contrast: blanket collapse folds the two posts (same verb+object) too
(feed-test
"collapse dedupe folds posts"
(feed/count (feed/by-verb (feed/dedupe-collapse M) "post"))
1)
; smart-key dispatch
(feed-test
"smart-key reaction -> (verb object)"
(feed/smart-key (feed/activity "alice" "like" "X" 0 (list)))
(list "like" "X"))
(feed-test
"smart-key post -> (actor verb object)"
(feed/smart-key (feed/activity "alice" "post" "P" 0 (list)))
(list "alice" "post" "P"))

187
lib/feed/tests/fanout.sx
View File

@@ -1,187 +0,0 @@
; Phase 2 — fanout via outer product + dedupe. (feed-test name got expected)
; ---------- graph ----------
; edges: (follower followee). bob,carol follow alice; carol,dave follow bob.
(define
G
(feed/follow-graph
(list
(list "bob" "alice")
(list "carol" "alice")
(list "carol" "bob")
(list "dave" "bob"))))
(feed-test "followers alice" (feed/followers G "alice") (list "bob" "carol"))
(feed-test "followers bob" (feed/followers G "bob") (list "carol" "dave"))
(feed-test "followers unknown" (feed/followers G "zzz") (list))
(feed-test "audience distinct" (feed/audience G) (list "bob" "carol" "dave"))
; ---------- fanout ----------
(define
S
(feed/stream
(list
(feed/activity "alice" "post" "p1" 10 (list))
(feed/activity "alice" "post" "p2" 20 (list))
(feed/activity "bob" "like" "p1" 30 (list)))))
(define IB (feed/fanout S G))
(feed-test "fanout total edges" (feed/count IB) 6)
(feed-test
"inbox bob count"
(feed/count (feed/inbox-for IB "bob"))
2)
(feed-test
"inbox carol count"
(feed/count (feed/inbox-for IB "carol"))
3)
(feed-test
"inbox dave count"
(feed/count (feed/inbox-for IB "dave"))
1)
(feed-test
"inbox alice (follows none)"
(feed/count (feed/inbox-for IB "alice"))
0)
(feed-test
"recipients order"
(feed/recipients IB)
(list "bob" "carol" "dave"))
(feed-test
"bob inbox objects"
(map (fn (a) (get a :object)) (feed/inbox-activities IB "bob"))
(list "p1" "p2"))
(feed-test
"dave inbox objects"
(map (fn (a) (get a :object)) (feed/inbox-activities IB "dave"))
(list "p1"))
(feed-test
"dave inbox verb"
(map (fn (a) (get a :verb)) (feed/inbox-activities IB "dave"))
(list "like"))
; empty graph → no audience → no edges
(feed-test
"empty graph fanout"
(feed/count (feed/fanout S {}))
0)
; actor nobody follows produces no edges
(define
Sghost
(feed/stream (list (feed/activity "ghost" "post" "g1" 5 (list)))))
(feed-test
"unfollowed actor fanout"
(feed/count (feed/fanout Sghost G))
0)
; ---------- high fanout (popular actor) ----------
(define
Gstar
(feed/follow-graph
(list
(list "u1" "star")
(list "u2" "star")
(list "u3" "star")
(list "u4" "star")
(list "u5" "star"))))
(define
Sstar
(feed/stream (list (feed/activity "star" "post" "s1" 1 (list)))))
(feed-test
"star fanout count"
(feed/count (feed/fanout Sstar Gstar))
5)
(feed-test "star audience size" (len (feed/audience Gstar)) 5)
; ---------- mutual follow ----------
(define Gmut (feed/follow-graph (list (list "a" "b") (list "b" "a"))))
(define
Smut
(feed/stream
(list
(feed/activity "a" "post" "pa" 1 (list))
(feed/activity "b" "post" "pb" 2 (list)))))
(define IBmut (feed/fanout Smut Gmut))
(feed-test "mutual total" (feed/count IBmut) 2)
(feed-test
"mutual a gets pb"
(map (fn (x) (get x :object)) (feed/inbox-activities IBmut "a"))
(list "pb"))
(feed-test
"mutual b gets pa"
(map (fn (x) (get x :object)) (feed/inbox-activities IBmut "b"))
(list "pa"))
; ---------- dedupe ----------
(define
Sdup2
(feed/stream
(list
(feed/activity "alice" "post" "p1" 1 (list))
(feed/activity "alice" "post" "p1" 9 (list))
(feed/activity "alice" "post" "p2" 2 (list)))))
(feed-test
"dedupe-activities collapses dup"
(feed/count (feed/dedupe-activities Sdup2))
2)
(feed-test
"dedupe-activities keeps distinct"
(map
(fn (a) (get a :object))
(feed/items (feed/dedupe-activities Sdup2)))
(list "p1" "p2"))
(define
Slikes
(feed/stream
(list
(feed/activity "alice" "like" "X" 1 (list))
(feed/activity "bob" "like" "X" 2 (list))
(feed/activity "carol" "like" "Y" 3 (list)))))
(feed-test
"collapse cross-actor likes"
(feed/count (feed/dedupe-collapse Slikes))
2)
(feed-test
"collapse keeps distinct objects"
(map
(fn (a) (get a :object))
(feed/items (feed/dedupe-collapse Slikes)))
(list "X" "Y"))
(feed-test
"activity-key shape"
(feed/activity-key (feed/activity "a" "post" "o" 0 (list)))
(list "a" "post" "o"))
(feed-test
"collapse-key shape"
(feed/collapse-key (feed/activity "a" "like" "o" 0 (list)))
(list "like" "o"))
; cross-post: alice posts p1 twice → bob's inbox has it twice → dedupe-inbox → once
(define
Scross
(feed/stream
(list
(feed/activity "alice" "post" "p1" 1 (list))
(feed/activity "alice" "post" "p1" 5 (list)))))
(define IBcross (feed/fanout Scross G))
(feed-test
"cross-post raw bob count"
(feed/count (feed/inbox-for IBcross "bob"))
2)
(feed-test
"cross-post deduped bob count"
(feed/count (feed/inbox-for (feed/dedupe-inbox IBcross) "bob"))
1)
(feed-test
"dedupe-inbox keeps distinct receivers"
(feed/count (feed/dedupe-inbox IBcross))
2)

73
lib/feed/tests/home.sx
View File

@@ -1,73 +0,0 @@
; Follow-up — feed/home capstone pipeline. (feed-test name got expected)
; alice follows star and bob (edges: follower followee)
(define
G
(feed/follow-graph (list (list "alice" "star") (list "alice" "bob"))))
; star posts s1 then s2; bob posts b1; star re-posts s1 (cross-post dup);
; zoe posts z1 (alice does NOT follow zoe)
(define
S
(feed/stream
(list
(feed/activity "star" "post" "s1" 10 (list))
(feed/activity "star" "post" "s2" 20 (list))
(feed/activity "bob" "post" "b1" 15 (list))
(feed/activity "star" "post" "s1" 5 (list))
(feed/activity "zoe" "post" "z1" 30 (list)))))
(define rec (feed/recency 100 10))
(feed-test
"home count (deduped, followed only)"
(feed/count (feed/home S G "alice" feed/permit-public? rec 10))
3)
(feed-test
"home order by recency"
(map
(fn (a) (get a :object))
(feed/items (feed/home S G "alice" feed/permit-public? rec 10)))
(list "s2" "b1" "s1"))
(feed-test
"home excludes unfollowed zoe"
(feed/-elem?
"z1"
(map
(fn (a) (get a :object))
(feed/items (feed/home S G "alice" feed/permit-public? rec 10))))
false)
(feed-test
"home top-2"
(map
(fn (a) (get a :object))
(feed/items (feed/home S G "alice" feed/permit-public? rec 2)))
(list "s2" "b1"))
(feed-test
"home dedupes cross-post (one s1)"
(len
(filter
(fn (o) (equal? o "s1"))
(map
(fn (a) (get a :object))
(feed/items
(feed/home S G "alice" feed/permit-public? rec 10)))))
1)
; ACL applied per-viewer in the home pipeline
(define
Sacl
(feed/stream
(list (feed/normalize {:actor "star" :object "pub" :at 20}) (feed/normalize {:actor "star" :object "sec" :visible-to (list "carol") :at 25}))))
(define Gacl (feed/follow-graph (list (list "alice" "star"))))
(feed-test
"home hides activity alice not permitted"
(map
(fn (a) (get a :object))
(feed/items (feed/home Sacl Gacl "alice" feed/permit-acl? rec 10)))
(list "pub"))

155
lib/feed/tests/integration.sx
View File

@@ -1,155 +0,0 @@
; Phase 4 — visibility (ACL) + federation, and the end-to-end timeline.
; (feed-test name got expected)
; ---------- ACL visibility ----------
; pub: public. sec: bob, allows carol. dm: frank, allows dave.
(define
C
(feed/stream
(list
(feed/normalize {:actor "alice" :object "pub" :at 10})
(feed/normalize {:actor "bob" :object "sec" :visible-to (list "carol") :at 20})
(feed/normalize {:actor "frank" :object "dm" :visible-to (list "dave") :at 30}))))
(feed-test
"public visible to anyone"
(feed/count (feed/visible C "zoe" feed/permit-acl?))
1)
(feed-test
"carol sees allowlisted + public"
(feed/count (feed/visible C "carol" feed/permit-acl?))
2)
(feed-test
"dave sees dm + public"
(feed/count (feed/visible C "dave" feed/permit-acl?))
2)
(feed-test
"author always sees own private"
(feed/count (feed/visible C "frank" feed/permit-acl?))
2)
(feed-test
"permit-public? lets all through"
(feed/count (feed/visible C "zoe" feed/permit-public?))
3)
(feed-test
"visible objects for dave"
(map
(fn (a) (get a :object))
(feed/items (feed/visible C "dave" feed/permit-acl?)))
(list "pub" "dm"))
; per-viewer: same stream, different timelines
(feed-test
"zoe timeline differs from carol"
(not
(=
(feed/count (feed/visible C "zoe" feed/permit-acl?))
(feed/count (feed/visible C "carol" feed/permit-acl?))))
true)
; ---------- federation: merge / ingest ----------
(define
L
(feed/stream
(list
(feed/activity "alice" "post" "p1" 10 (list))
(feed/activity "alice" "post" "p2" 20 (list)))))
(define
P
(feed/stream
(list
(feed/activity "alice" "post" "p2" 20 (list))
(feed/activity "peer" "post" "p9" 25 (list)))))
(feed-test "merge concatenates" (feed/count (feed/merge L P)) 4)
(feed-test
"ingest dedupes overlap"
(feed/count (feed/ingest L P))
3)
(feed-test
"inbound normalizes + ingests"
(feed/count (feed/inbound L (list {:actor "peer" :object "p9" :at 25} {:actor "alice" :object "p1" :at 10})))
3)
; backfill via injected fetch-fn
(define peer-history (fn (peer-id) (list {:actor peer-id :object "h1" :at 1} {:actor peer-id :object "h2" :at 2})))
(feed-test
"backfill merges peer history"
(feed/count (feed/backfill L peer-history "remote"))
4)
(feed-test
"backfill objects present"
(map
(fn (a) (get a :object))
(feed/items
(feed/by-actor (feed/backfill L peer-history "remote") "remote")))
(list "h1" "h2"))
; ---------- federation: outbound partition ----------
; bob (local), alice@remote + carol@remote (remote) follow star
(define
Gf
(feed/follow-graph
(list
(list "bob" "star")
(list "alice@remote" "star")
(list "carol@remote" "star"))))
(define
Sf
(feed/stream (list (feed/activity "star" "post" "s1" 1 (list)))))
(define
remote?
(fn (id) (feed/-elem? id (list "alice@remote" "carol@remote"))))
(define parts (feed/federate Sf Gf remote?))
(feed-test "local deliveries" (feed/count (get parts :local)) 1)
(feed-test "remote deliveries" (feed/count (get parts :remote)) 2)
(feed-test
"local recipient is bob"
(feed/recipients (get parts :local))
(list "bob"))
; deliver: send-fn receives each remote event, local inbox returned
(define sent (list))
(define send-fn (fn (to act) (set! sent (append sent (list to)))))
(define local-inbox (feed/deliver Sf Gf remote? send-fn))
(feed-test "deliver returns local inbox" (feed/count local-inbox) 1)
(feed-test "deliver sent to both remotes" (len sent) 2)
(feed-test "deliver remote targets" sent (list "alice@remote" "carol@remote"))
; ---------- end-to-end: federated, ACL-filtered, ranked timeline ----------
(define
base
(feed/stream
(list
(feed/normalize {:actor "alice" :object "a1" :at 100})
(feed/normalize {:actor "bob" :object "b1" :visible-to (list "carol") :at 90})
(feed/normalize {:actor "eve" :object "e1" :visible-to (list "dave") :at 80}))))
(define federated (feed/inbound base (list {:actor "peer" :object "x1" :at 110})))
(define rec (feed/recency 120 10))
(define
carol-tl
(feed/timeline federated "carol" feed/permit-acl? rec 3))
; eve's :visible-to excludes carol -> filtered out; peer/alice public, bob allows carol
(feed-test "carol federated timeline count" (feed/count carol-tl) 3)
(feed-test
"carol timeline order (recency)"
(map (fn (a) (get a :object)) (feed/items carol-tl))
(list "x1" "a1" "b1"))
(feed-test
"eve dm excluded from carol"
(feed/-elem? "e1" (map (fn (a) (get a :object)) (feed/items carol-tl)))
false)
(feed-test
"dave sees eve dm not bob"
(map
(fn (a) (get a :object))
(feed/items
(feed/timeline federated "dave" feed/permit-acl? rec 5)))
(list "x1" "a1" "e1"))

68
lib/feed/tests/mute.sx
View File

@@ -1,68 +0,0 @@
; Follow-up — viewer mute/block filtering. (feed-test name got expected)
(define
S
(feed/stream
(list
(feed/normalize {:actor "alice" :object "P1" :at 1 :tags (list "news")})
(feed/normalize {:actor "bob" :object "P2" :at 2 :tags (list "spam")})
(feed/normalize {:actor "alice" :object "P3" :at 3 :tags (list "cats")})
(feed/normalize {:actor "carol" :object "P4" :at 4 :tags (list "news" "spam")}))))
; ---------- mute actors ----------
(feed-test
"mute bob drops his post"
(map
(fn (a) (get a :object))
(feed/items (feed/mute-actors S (list "bob"))))
(list "P1" "P3" "P4"))
(feed-test
"mute alice drops two"
(feed/count (feed/mute-actors S (list "alice")))
2)
(feed-test
"mute nobody keeps all"
(feed/count (feed/mute-actors S (list)))
4)
; ---------- mute tags ----------
(feed-test
"mute spam tag drops two"
(map
(fn (a) (get a :object))
(feed/items (feed/mute-tags S (list "spam"))))
(list "P1" "P3"))
(feed-test
"mute news+cats leaves spam-only"
(map
(fn (a) (get a :object))
(feed/items (feed/mute-tags S (list "news" "cats"))))
(list "P2"))
; ---------- mute objects ----------
(feed-test
"mute object P3 (thread mute)"
(feed/count (feed/mute-objects S (list "P3")))
3)
; ---------- combined prefs ----------
(feed-test
"apply-prefs actors + tags"
(map
(fn (a) (get a :object))
(feed/items (feed/apply-prefs S {:mute-actors (list "bob") :mute-tags (list "cats")})))
(list "P1" "P4"))
(feed-test
"apply-prefs empty keeps all"
(feed/count (feed/apply-prefs S {}))
4)
(feed-test
"apply-prefs all three filters"
(map
(fn (a) (get a :object))
(feed/items (feed/apply-prefs S {:mute-objects (list "P3") :mute-actors (list "carol") :mute-tags (list "spam")})))
(list "P1"))

69
lib/feed/tests/notify.sx
View File

@@ -1,69 +0,0 @@
; Follow-up — notification feed over an inbox. (feed-test name got expected)
; an inbox is a stream of {:to receiver :activity act} events
(define mk-ev (fn (to act) {:activity act :to to}))
(define
IB
(feed/stream
(list
(mk-ev "alice" (feed/activity "bob" "like" "P" 10 (list)))
(mk-ev "alice" (feed/activity "carol" "like" "P" 20 (list)))
(mk-ev "alice" (feed/activity "dave" "reply" "Q" 30 (list)))
(mk-ev "bob" (feed/activity "eve" "like" "R" 40 (list))))))
; ---------- raw notifications ----------
(feed-test
"alice notification count"
(feed/count (feed/notifications IB "alice"))
3)
(feed-test
"bob notification count"
(feed/count (feed/notifications IB "bob"))
1)
(feed-test
"zoe no notifications"
(feed/count (feed/notifications IB "zoe"))
0)
; ---------- verb filtering ----------
(feed-test
"alice likes only"
(feed/count (feed/notify-verbs IB "alice" (list "like")))
2)
(feed-test
"alice replies only"
(feed/count (feed/notify-verbs IB "alice" (list "reply")))
1)
(feed-test
"alice like+reply"
(feed/count (feed/notify-verbs IB "alice" (list "like" "reply")))
3)
(feed-test
"alice follow (none)"
(feed/count (feed/notify-verbs IB "alice" (list "follow")))
0)
; ---------- digest ----------
(define dig (feed/notify-digest IB "alice"))
(feed-test "digest group count" (len dig) 2)
(feed-test
"digest sorted by key (like|P before reply|Q)"
(map (fn (g) (get g :object)) dig)
(list "P" "Q"))
(feed-test
"like group actors"
(get (nth dig 0) :actors)
(list "bob" "carol"))
(feed-test "like group count" (get (nth dig 0) :count) 2)
(feed-test "like group verb" (get (nth dig 0) :verb) "like")
(feed-test "reply group count" (get (nth dig 1) :count) 1)
(feed-test
"reply group actors"
(get (nth dig 1) :actors)
(list "dave"))
(feed-test "empty digest for zoe" (feed/notify-digest IB "zoe") (list))

86
lib/feed/tests/page.sx
View File

@@ -1,86 +0,0 @@
; Follow-up — pagination (offset + cursor). (feed-test name got expected)
; ---------- offset / limit ----------
(define
O
(feed/stream
(list
(feed/activity "u" "post" "o1" 1 (list))
(feed/activity "u" "post" "o2" 2 (list))
(feed/activity "u" "post" "o3" 3 (list))
(feed/activity "u" "post" "o4" 4 (list))
(feed/activity "u" "post" "o5" 5 (list)))))
(feed-test
"page 1"
(map
(fn (a) (get a :object))
(feed/items (feed/page O 0 2)))
(list "o1" "o2"))
(feed-test
"page 2"
(map
(fn (a) (get a :object))
(feed/items (feed/page O 2 2)))
(list "o3" "o4"))
(feed-test
"page 3 (partial)"
(map
(fn (a) (get a :object))
(feed/items (feed/page O 4 2)))
(list "o5"))
(feed-test
"page past end empty"
(feed/count (feed/page O 10 2))
0)
(feed-test "page-count 5/2 = 3" (feed/page-count O 2) 3)
(feed-test "page-count 5/5 = 1" (feed/page-count O 5) 1)
; ---------- cursor (recency) ----------
(define
R
(feed/stream
(list
(feed/activity "u" "post" "a" 50 (list))
(feed/activity "u" "post" "b" 40 (list))
(feed/activity "u" "post" "c" 30 (list))
(feed/activity "u" "post" "d" 20 (list))
(feed/activity "u" "post" "e" 10 (list)))))
(define p1 (feed/page-before R 100 2))
(feed-test
"cursor page 1 newest first"
(map (fn (a) (get a :object)) (feed/items p1))
(list "a" "b"))
(feed-test "next cursor after page 1" (feed/next-cursor p1) 40)
(define p2 (feed/page-before R (feed/next-cursor p1) 2))
(feed-test
"cursor page 2"
(map (fn (a) (get a :object)) (feed/items p2))
(list "c" "d"))
(feed-test "next cursor after page 2" (feed/next-cursor p2) 20)
(define p3 (feed/page-before R (feed/next-cursor p2) 2))
(feed-test
"cursor page 3 (partial)"
(map (fn (a) (get a :object)) (feed/items p3))
(list "e"))
(feed-test
"empty page nil cursor"
(feed/next-cursor (feed/page-before R 5 2))
nil)
(feed-test
"after cursor loads newer"
(map
(fn (a) (get a :object))
(feed/items (feed/recent (feed/after R 30))))
(list "a" "b"))
(feed-test
"before cursor count"
(feed/count (feed/before R 30))
2)

160
lib/feed/tests/rank.sx
View File

@@ -1,160 +0,0 @@
; Phase 3 — aggregation + ranking. (feed-test name got expected)
; ---------- aggregation ----------
(define
A
(feed/stream
(list
(feed/activity "alice" "post" "p1" 5 (list))
(feed/activity "alice" "post" "p2" 15 (list))
(feed/activity "bob" "post" "p3" 25 (list))
(feed/activity "alice" "like" "p1" 35 (list)))))
(feed-test "actor-counts" (feed/actor-counts A) {:alice 3 :bob 1})
(feed-test "object-counts" (feed/object-counts A) {:p2 1 :p3 1 :p1 2})
(feed-test
"group-by actor alice len"
(len (get (feed/group-by A feed/actor) "alice"))
3)
(feed-test
"group-count empty"
(feed/group-count feed/empty feed/actor)
{})
; day bucketing
(define
D
(feed/stream
(list
(feed/activity "alice" "post" "p1" 5 (list))
(feed/activity "alice" "post" "p2" 8 (list))
(feed/activity "alice" "post" "p3" 12 (list)))))
(feed-test "feed/day floor" (feed/day 12 10) 1)
(feed-test "feed/day same bucket" (feed/day 8 10) 0)
(feed-test "by-actor-day" (feed/by-actor-day D 10) {:alice#0 2 :alice#1 1})
; ---------- recency ----------
(define rec (feed/recency 100 10))
(feed-test
"recency at=now -> 1"
(rec (feed/activity "x" "post" "o" 100 (list)))
1)
(feed-test
"recency age=hl -> .5"
(rec (feed/activity "x" "post" "o" 90 (list)))
0.5)
(feed-test
"recency age=2hl -> .25"
(rec (feed/activity "x" "post" "o" 80 (list)))
0.25)
; ---------- velocity ----------
(define vel (feed/velocity D 10))
(feed-test
"velocity burst (at=12)"
(vel (feed/activity "alice" "post" "z" 12 (list)))
3)
(feed-test
"velocity mid (at=8)"
(vel (feed/activity "alice" "post" "z" 8 (list)))
2)
(feed-test
"velocity first (at=5)"
(vel (feed/activity "alice" "post" "z" 5 (list)))
1)
(feed-test
"velocity other actor"
(vel (feed/activity "bob" "post" "z" 12 (list)))
0)
; ---------- engagement ----------
(define eng (feed/engagement A))
(feed-test
"engagement p1"
(eng (feed/activity "x" "post" "p1" 0 (list)))
2)
(feed-test
"engagement p2"
(eng (feed/activity "x" "post" "p2" 0 (list)))
1)
; ---------- composite ----------
(define
cmp1
(feed/composite (list (list 2 (fn (a) (get a :at))))))
(feed-test
"composite single part"
(cmp1 (feed/activity "x" "post" "o" 5 (list)))
10)
(define
cmp2
(feed/composite
(list
(list 2 (fn (a) (get a :at)))
(list 3 (fn (a) 1)))))
(feed-test
"composite two parts"
(cmp2 (feed/activity "x" "post" "o" 5 (list)))
13)
; ---------- ranking ----------
(define
R
(feed/stream
(list
(feed/activity "u" "post" "oC" 80 (list))
(feed/activity "u" "post" "oA" 100 (list))
(feed/activity "u" "post" "oB" 90 (list)))))
(feed-test
"rank by recency objects"
(map (fn (a) (get a :object)) (feed/items (feed/rank R rec)))
(list "oA" "oB" "oC"))
(feed-test
"top-2 by recency"
(map (fn (a) (get a :object)) (feed/items (feed/top R rec 2)))
(list "oA" "oB"))
(feed-test "top-2 count" (feed/count (feed/top R rec 2)) 2)
; constant score -> tiebreak by :at descending
(define
T
(feed/stream
(list
(feed/activity "u" "post" "f" 10 (list))
(feed/activity "u" "post" "g" 30 (list))
(feed/activity "u" "post" "h" 20 (list)))))
(feed-test
"tiebreak at-desc"
(map
(fn (a) (get a :object))
(feed/items (feed/rank T (fn (a) 0))))
(list "g" "h" "f"))
; equal score AND equal :at -> stable input order
(define
E
(feed/stream
(list
(feed/activity "u" "post" "first" 50 (list))
(feed/activity "u" "post" "second" 50 (list)))))
(feed-test
"stable equal-key input order"
(map
(fn (a) (get a :object))
(feed/items (feed/rank E (fn (a) 0))))
(list "first" "second"))
(feed-test
"with-scores attaches score"
(get (nth (feed/items (feed/with-scores R rec)) 1) :score)
1)
(feed-test "rank preserves count" (feed/count (feed/rank A rec)) 4)

49
lib/feed/tests/thread.sx
View File

@@ -1,49 +0,0 @@
; Follow-up — conversation threading via :reply-to closure. (feed-test name got expected)
(define
S
(feed/stream
(list
(feed/normalize {:actor "a" :object "root" :at 1})
(feed/normalize {:actor "b" :object "r1" :at 2 :verb "reply" :reply-to "root"})
(feed/normalize {:actor "c" :object "r2" :at 3 :verb "reply" :reply-to "root"})
(feed/normalize {:actor "d" :object "r3" :at 4 :verb "reply" :reply-to "r1"})
(feed/normalize {:actor "e" :object "x" :at 5}))))
; ---------- direct replies ----------
(feed-test "direct replies to root" (feed/reply-count S "root") 2)
(feed-test "direct replies to r1" (feed/reply-count S "r1") 1)
(feed-test "no replies to r3" (feed/reply-count S "r3") 0)
(feed-test
"replies objects to root"
(map (fn (a) (get a :object)) (feed/items (feed/replies S "root")))
(list "r1" "r2"))
; ---------- thread closure ----------
(feed-test
"thread objects root (transitive)"
(feed/thread-objects S "root")
(list "root" "r1" "r2" "r3"))
(feed-test
"thread root chronological"
(map (fn (a) (get a :object)) (feed/items (feed/thread S "root")))
(list "root" "r1" "r2" "r3"))
(feed-test "thread size root" (feed/thread-size S "root") 4)
(feed-test
"thread excludes unrelated x"
(feed/-elem?
"x"
(map (fn (a) (get a :object)) (feed/items (feed/thread S "root"))))
false)
; ---------- sub-thread ----------
(feed-test
"thread from r1 (sub-tree)"
(map (fn (a) (get a :object)) (feed/items (feed/thread S "r1")))
(list "r1" "r3"))
(feed-test "thread size r1" (feed/thread-size S "r1") 2)
(feed-test "leaf thread is itself" (feed/thread-size S "r3") 1)
(feed-test "unrelated thread is itself" (feed/thread-size S "x") 1)

82
lib/feed/tests/trending.sx
View File

@@ -1,82 +0,0 @@
; Follow-up — trending objects/actors by recent activity. (feed-test name got expected)
; window (50,100]: X@60,X@70 (a), Y@80 (b), Z@90 (c); W@40 is too old
(define
S
(feed/stream
(list
(feed/activity "a" "post" "X" 60 (list))
(feed/activity "a" "post" "X" 70 (list))
(feed/activity "b" "post" "Y" 80 (list))
(feed/activity "c" "post" "Z" 90 (list))
(feed/activity "d" "post" "W" 40 (list)))))
; ---------- trending objects ----------
(feed-test
"trending count (3 in window)"
(len (feed/trending S 100 50 10))
3)
(feed-test
"trending top object"
(get
(nth (feed/trending S 100 50 10) 0)
:object)
"X")
(feed-test
"trending top count"
(get
(nth (feed/trending S 100 50 10) 0)
:count)
2)
(feed-test
"trending order (count desc, key asc tiebreak)"
(map
(fn (e) (get e :object))
(feed/trending S 100 50 10))
(list "X" "Y" "Z"))
(feed-test
"trending top-2"
(map
(fn (e) (get e :object))
(feed/trending S 100 50 2))
(list "X" "Y"))
(feed-test
"old object W excluded"
(feed/-elem?
"W"
(map
(fn (e) (get e :object))
(feed/trending S 100 50 10)))
false)
(feed-test
"narrow window keeps only newest"
(map
(fn (e) (get e :object))
(feed/trending S 100 15 10))
(list "Z"))
(feed-test
"empty window -> nothing"
(feed/trending S 100 5 10)
(list))
; ---------- trending actors ----------
(feed-test
"trending actor top"
(get
(nth (feed/trending-actors S 100 50 10) 0)
:actor)
"a")
(feed-test
"trending actor count"
(get
(nth (feed/trending-actors S 100 50 10) 0)
:count)
2)
(feed-test
"trending actors order"
(map
(fn (e) (get e :actor))
(feed/trending-actors S 100 50 10))
(list "a" "b" "c"))

59
lib/feed/thread.sx
View File

@@ -1,59 +0,0 @@
; feed/thread — conversation threading. A reply carries :reply-to <parent-object>
; (normalize preserves it). A thread is the transitive closure over :reply-to from
; a root object: root + replies + replies-to-replies, gathered chronologically.
;
; Requires: lib/feed/normalize.sx, lib/feed/stream.sx, lib/feed/fanout.sx
; (feed/-elem?, feed/-distinct).
; direct replies to an object
(define
feed/replies
(fn
(stream object)
(feed/filter stream (fn (a) (equal? (get a :reply-to) object)))))
(define
feed/reply-count
(fn (stream object) (feed/count (feed/replies stream object))))
; iterate f from x until the result stops growing (set-closure fixpoint)
(define
feed/-fixpoint
(fn
(f x)
(let
((nx (f x)))
(if (= (len nx) (len x)) x (feed/-fixpoint f nx)))))
; the set of object-ids in the thread rooted at `root`
(define
feed/thread-objects
(fn
(stream root)
(let
((all (feed/items stream)))
(feed/-fixpoint
(fn
(acc)
(feed/-distinct
(append
acc
(map
(fn (a) (get a :object))
(filter (fn (a) (feed/-elem? (get a :reply-to) acc)) all)))))
(list root)))))
; the full thread as a chronological stream (root + all descendants)
(define
feed/thread
(fn
(stream root)
(let
((objs (feed/thread-objects stream root)))
(feed/sort-by-at
(feed/filter stream (fn (a) (feed/-elem? (get a :object) objs)))))))
; how many activities are in the thread (root counts as 1)
(define
feed/thread-size
(fn (stream root) (feed/count (feed/thread stream root))))

42
lib/feed/trending.sx
View File

@@ -1,42 +0,0 @@
; feed/trending — what's hot right now: objects (or actors) ranked by activity
; count within a recency window. Deterministic: count descending, ties broken by
; key ascending (entries are pre-sorted by key, then stable grade-down by count).
;
; Requires: lib/feed/stream.sx, lib/feed/aggregate.sx (object/actor-counts),
; lib/feed/rank.sx (feed/-desc-by).
; activities within (now-window, now]
(define
feed/-recent
(fn
(stream now window)
(feed/filter
stream
(fn (a) (and (<= (get a :at) now) (> (get a :at) (- now window)))))))
; counts dict -> top-N entries {label key, :count n}, count desc, key asc
(define
feed/-top-counts
(fn
(counts label n)
(let
((entries (map (fn (k) (assoc {:count (get counts k)} label k)) (sort (keys counts)))))
(take (feed/-desc-by entries (fn (e) (get e :count))) n))))
; top-N trending objects in the window
(define
feed/trending
(fn
(stream now window n)
(feed/-top-counts
(feed/object-counts (feed/-recent stream now window))
:object n)))
; top-N most active actors in the window
(define
feed/trending-actors
(fn
(stream now window n)
(feed/-top-counts
(feed/actor-counts (feed/-recent stream now window))
:actor n)))

141
lib/flow/README.md
View File

@@ -1,141 +0,0 @@
# flow — durable DAG workflows on Scheme
`flow` is a workflow engine for rose-ash: content pipelines (write → review →
publish → federate), scheduled jobs, and multi-step user flows (signup, confirm,
onboard) that **survive process restarts**. It is a thin Scheme prelude over the
Scheme-on-SX guest (`lib/scheme/`); a flow runs *inside* the interpreter.
Run the suite: `bash lib/flow/conformance.sh` → **151/151 across 10 suites**.
## Model
A **flow** is just a Scheme procedure of one argument — the upstream value:
```
node : input -> output
```
Combinators build composite nodes out of child nodes. A node that ignores its
argument is effectively a thunk. There is no separate "graph" object: composition
*is* function composition, so flows are values you can name, pass, and nest.
```scheme
(defflow publish
(sequence
(lambda (draft) (string-append draft "!"))
(branch (lambda (post) (>= (string-length post) 3))
(remote-node 'fed 'publish)
(flow-const 'rejected))))
(flow/start publish "hello") ; => federated, or a (flow-suspended id tag) state
```
## Building blocks (`spec.sx`)
| Combinator | Meaning |
|---|---|
| `(flow-node f)` / `(flow-id x)` / `(flow-const v)` | leaf nodes |
| `(sequence n ...)` | thread input left-to-right |
| `(parallel n ...)` | fan input to every child, join results into a list (sequential eval) |
| `(map-flow node)` | run `node` over each item of a list input, join results |
| `(flow-while pred body max)` / `(flow-until ...)` | bounded iteration (cap `max` steps) |
| `(defflow name body)` | bind + register a named flow (so it survives restart) |
## Control flow + errors (`spec.sx`)
| Combinator | Meaning |
|---|---|
| `(branch pred then else)` | `pred` on input selects `then`/`else` (`cond` is a Scheme special form) |
| `(retry n node)` | re-run on a *raised exception*, up to `n` attempts |
| `(timeout budget node)` | cooperative **step budget**: nodes call `(tick)`; the `(budget+1)`-th tick raises `flow-timeout` |
| `(try-catch node handler)` | catch a raised exception → `(handler error)` |
| `(fail reason)` / `(failed? x)` / `(fail-reason x)` | explicit failure *values* (flow downstream as data) |
| `(recover node handler)` | the fail-VALUE counterpart of try-catch |
| `(attempt n ...)` | railway sequence: stop at the first node returning a `(fail ...)` |
| `(tap effect)` | run a side effect, return input unchanged |
**Two error channels, on purpose.** Raised exceptions are for *bugs/transients*
(caught by `retry`/`try-catch`). `(fail reason)` values are for *expected business
outcomes* (validation rejected, declined) and compose via `attempt`/`recover`.
## Suspend / resume — the durable core (`spec.sx`, `store.sx`)
The guest Scheme's `call/cc` is **escape-only** — re-invoking a captured
continuation after it returns *hangs* the runtime. So flow does **not** serialize
continuations. Instead it uses **deterministic replay**:
- `(suspend tag)` — if `tag` is already in the replay log, return its logged value;
otherwise escape to the driver as `(flow-suspended tag)`.
- `resume` appends `(tag value)` to the log and **re-runs the flow from the start**.
Already-resolved suspends replay their values; the first unresolved one escapes
again (or the flow completes).
The entire persisted state is the replay log — plain data. No live continuation is
ever stored, so flows survive process restarts and even moves between instances.
> **Author contract:** suspend `tag`s must be unique and deterministic across
> replays, and **all** non-determinism / side effects must go through suspend
> points (so their results are logged) — otherwise they re-run on every replay.
### Lifecycle (`store.sx`)
```scheme
(flow/start flow input) ; raw result if it completes, else (flow-suspended id tag)
(flow/resume id value) ; inject value at the waiting tag, continue
(flow/cancel id) ; terminate; a later resume is rejected
```
### Introspection & hygiene
```scheme
(flow/status id) ; done | suspended | cancelled | unknown
(flow/result id) ; result if done, else (flow-error reason)
(flow/list) ; ((id status) ...)
(flow/pending) ; ((id waiting-tag) ...) — what each suspended flow awaits
(flow/gc) ; drop terminal records, keep live ones; returns count removed
(flow/forget id) ; drop one terminal record (refuses live flows)
```
### Crash recovery
```scheme
(flow-store-export) ; the store as plain data (live procs nulled)
(flow-store-import! d) ; restore the store from exported data
(flow-resumable-ids) ; ids of suspended flows to wake on restart
```
On restart the flow definitions are reloaded (`defflow` re-registers names) and the
exported store reimported; `resume` re-resolves each flow's procedure **by name**.
## Distribution via fed-sx (`remote.sx`)
```scheme
(flow-peer-register! addr table) ; mock a peer's exposed functions (fed-sx boundary)
(remote-node addr fn) ; run a node on a peer
(remote-failover addrs fn local) ; try peers in order, fall through to a local node
(flow-replicate-to addr) ; copy this store to a peer's replica slot
(flow-restore-from addr) ; import a peer's replica (handoff)
```
**Handoff** is crash recovery across instances: replicate → local instance dies →
peer restores the (plain-data) store and resumes. The replay log carries over, so
all resolved suspends survive the move.
## Files
| File | Contents |
|---|---|
| `spec.sx` | combinators (flow-combinators-src / flow-control-src / flow-suspend-src) |
| `store.sx` | durable store, lifecycle, crash recovery, introspection, hygiene |
| `remote.sx` | fed-sx transport (mock peer registry), failover, replication |
| `api.sx` | `flow-make-env` / `flow-run` SX helpers (one cached env, per-test reset) |
| `tests/*.sx` | 10 suites, 151 cases |
| `conformance.sh` | loads substrate + flow layer, runs every suite |
## Notes on the substrate
The guest Scheme (`lib/scheme/`, imported read-only) lacks dotted-rest params
`(a . rest)` and named `let`; combinators use `(lambda args ...)` variadics + top-
level recursion. `cons` is list-only (no dotted pairs), so log/assoc entries are
2-element lists. Strings box as `{:scm-string "..."}`. Timeout is a step budget
because there is no wall clock; `parallel` is sequential for the same reason.

65
lib/flow/api.sx
View File

@@ -1,65 +0,0 @@
;; lib/flow/api.sx — flow runtime entry points.
;;
;; Builds a Scheme env preloaded with the flow combinators (lib/flow/spec.sx),
;; the durable store + lifecycle (lib/flow/store.sx), the fed-sx remote layer
;; (lib/flow/remote.sx), and the host integration ABI (lib/flow/host.sx), and
;; provides SX helpers to run flow programs.
;;
;; Scheme-level API (available inside flow programs):
;; (flow/start flow input) — run a flow; raw result if it completes, else
;; (flow-suspended id tag). Defined in store.sx.
;; (flow/resume id value) — resume a suspended flow (store.sx)
;; (flow/cancel id) — cancel a flow (store.sx)
;; (suspend tag) — suspension point (spec.sx)
;; (request kind payload) — host request envelope over suspend (host.sx)
;; (remote-node addr fn) — node executed on a federation peer (remote.sx)
;;
;; SX-level helpers (for hosts and tests):
;; (flow-make-env) — fresh standard env + combinators + store + remote + host
;; (flow-run src) — eval a Scheme program string in a reset shared env
;; (flow-run-in env src) — eval a Scheme program string in a given env
;;
;; flow-run reuses ONE env (building the full standard env is expensive) and
;; resets the mutable flow globals before each program, so tests stay isolated
;; without paying for a fresh standard env each time. flow-registry persists (it
;; models reloaded flow definitions surviving a restart).
(define
flow-make-env
(fn
()
(let
((env (scheme-standard-env)))
(flow-load-combinators! env)
(flow-load-store! env)
(flow-load-remote! env)
(flow-load-host! env)
env)))
(define
flow-run-in
(fn (env src) (scheme-eval-program (scheme-parse-all src) env)))
(define
flow-reset-src
"(set! flow-store (list)) (set! flow-next-id 0) (set! flow-replay-log (list)) (set! flow-suspend-k #f) (set! flow-timeout-budget -1) (set! flow-peers (list)) (set! flow-replicas (list))")
(define flow-env-cache false)
(define
flow-shared-env
(fn
()
(begin
(if flow-env-cache nil (set! flow-env-cache (flow-make-env)))
flow-env-cache)))
(define
flow-run
(fn
(src)
(let
((env (flow-shared-env)))
(begin
(scheme-eval-program (scheme-parse-all flow-reset-src) env)
(scheme-eval-program (scheme-parse-all src) env)))))

103
lib/flow/conformance.sh
View File

@@ -1,103 +0,0 @@
#!/usr/bin/env bash
# flow-on-sx conformance runner — runs all flow test suites in one sx_server process.
#
# Usage:
# bash lib/flow/conformance.sh # run all suites
# bash lib/flow/conformance.sh -v # verbose (list each suite)
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
fi
if [ ! -x "$SX_SERVER" ]; then
echo "ERROR: sx_server.exe not found." >&2
exit 1
fi
VERBOSE="${1:-}"
# Suites: NAME RUNNER-FN PATH
SUITES=(
"basic flow-basic-tests-run! lib/flow/tests/basic.sx"
"control flow-ctl-tests-run! lib/flow/tests/control.sx"
"suspend flow-sus-tests-run! lib/flow/tests/suspend.sx"
"recovery flow-rec-tests-run! lib/flow/tests/recovery.sx"
"distributed flow-dist-tests-run! lib/flow/tests/distributed.sx"
"api flow-api-tests-run! lib/flow/tests/api.sx"
"combinators flow-cmb-tests-run! lib/flow/tests/combinators.sx"
"railway flow-rail-tests-run! lib/flow/tests/railway.sx"
"integration flow-int-tests-run! lib/flow/tests/integration.sx"
"hygiene flow-hyg-tests-run! lib/flow/tests/hygiene.sx"
"host flow-hst-tests-run! lib/flow/tests/host.sx"
)
TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT
EPOCH=1
emit_load () { echo "(epoch $EPOCH)"; echo "(load \"$1\")"; EPOCH=$((EPOCH+1)); }
emit_eval () { echo "(epoch $EPOCH)"; echo "(eval \"$1\")"; EPOCH=$((EPOCH+1)); }
{
emit_load "lib/guest/lex.sx"
emit_load "lib/guest/reflective/env.sx"
emit_load "lib/guest/reflective/quoting.sx"
emit_load "lib/scheme/parser.sx"
emit_load "lib/scheme/eval.sx"
emit_load "lib/scheme/runtime.sx"
emit_load "lib/flow/spec.sx"
emit_load "lib/flow/store.sx"
emit_load "lib/flow/remote.sx"
emit_load "lib/flow/host.sx"
emit_load "lib/flow/api.sx"
for SUITE in "${SUITES[@]}"; do
read -r _NAME _RUNNER FILE <<< "$SUITE"
emit_load "$FILE"
emit_eval "($_RUNNER)"
done
} > "$TMPFILE"
OUTPUT=$(timeout 540 "$SX_SERVER" < "$TMPFILE" 2>&1 || true)
TOTAL_PASS=0
TOTAL_FAIL=0
FAILED_SUITES=()
LAST_DICT_LINES=$(echo "$OUTPUT" | grep -E '^\{:' || true)
I=0
while read -r LINE; do
[ -z "$LINE" ] && continue
P=$(echo "$LINE" | grep -oE ':passed [0-9]+' | awk '{print $2}')
F=$(echo "$LINE" | grep -oE ':failed [0-9]+' | awk '{print $2}')
[ -z "$P" ] && P=0
[ -z "$F" ] && F=0
SUITE_INFO="${SUITES[$I]}"
SUITE_NAME=$(echo "$SUITE_INFO" | awk '{print $1}')
TOTAL_PASS=$((TOTAL_PASS + P))
TOTAL_FAIL=$((TOTAL_FAIL + F))
if [ "$F" -gt 0 ]; then
FAILED_SUITES+=("$SUITE_NAME: $P/$((P+F))")
printf 'X %-12s %d/%d\n' "$SUITE_NAME" "$P" "$((P+F))"
echo "$LINE" | grep -oE ':name "[^"]*"' | sed 's/:name / fail: /'
elif [ "$VERBOSE" = "-v" ]; then
printf 'ok %-12s %d passed\n' "$SUITE_NAME" "$P"
fi
I=$((I+1))
done <<< "$LAST_DICT_LINES"
TOTAL=$((TOTAL_PASS + TOTAL_FAIL))
if [ "$TOTAL" -eq 0 ]; then
echo "ERROR: no suite results parsed. Raw output:" >&2
echo "$OUTPUT" >&2
exit 1
fi
if [ $TOTAL_FAIL -eq 0 ]; then
echo "ok $TOTAL_PASS/$TOTAL flow-on-sx tests passed (${#SUITES[@]} suites)"
else
echo "FAIL $TOTAL_PASS/$TOTAL passed, $TOTAL_FAIL failed:"
for S in "${FAILED_SUITES[@]}"; do echo " $S"; done
exit 1
fi

42
lib/flow/host.sx
View File

@@ -1,42 +0,0 @@
;; lib/flow/host.sx — the host integration ABI (Phase 8).
;;
;; `suspend` is flow's seam to the outside world, but a bare (suspend tag) is just a
;; signal — every author would invent their own tag shape. This layer defines a
;; stable request/response contract so a host (e.g. an art-dag driver, or a human
;; review UI) can hook in WITHOUT reverse-engineering ad-hoc tags.
;;
;; A flow asks the host to do something and waits for the answer:
;; (request kind payload) — suspend with a typed envelope (flow-request kind
;; payload); evaluates to the host's resume value.
;; (await-human prompt) — request kind=human (a decision point)
;; (await-render recipe) — request kind=render (e.g. an art-dag job)
;; (await-effect kind p) — request of an arbitrary kind
;;
;; The host drives flows by polling its work queue and resuming:
;; (flow-host-requests) — ((id kind payload) ...) for every SUSPENDED flow whose
;; waiting tag is a host request. The host dispatches by kind (render -> submit a
;; Celery job; human -> show UI), then calls (flow/resume id answer).
;; (request? tag) / (request-kind tag) / (request-payload tag) — parse one tag.
;;
;; Reference driver — the host only supplies `dispatch`, a (kind payload) -> answer:
;; (flow-drive-host dispatch) — one tick: service every CURRENTLY pending
;; request (snapshot), resuming each with (dispatch kind payload); returns the
;; count serviced. Resumes may create new requests — serviced on the next tick.
;; (flow-run-host dispatch maxticks) — tick until quiescent (no pending requests)
;; or maxticks reached; returns total requests serviced. Bounded for determinism.
;;
;; Contract: the host owns IO and persistence. flow stays deterministic — a flow
;; never performs IO itself, it only `request`s; the host performs the effect and
;; feeds the result back via resume (which the replay log records, so the effect is
;; not re-run on recovery). Persist with flow-store-export after each transition and
;; flow-store-import! on boot.
(define
flow-host-src
"(define (request kind payload) (suspend (list (quote flow-request) kind payload)))\n (define (request? tag) (and (pair? tag) (eq? (car tag) (quote flow-request))))\n (define (request-kind tag) (car (cdr tag)))\n (define (request-payload tag) (car (cdr (cdr tag))))\n (define (await-human prompt) (request (quote human) prompt))\n (define (await-render recipe) (request (quote render) recipe))\n (define (await-effect kind payload) (request kind payload))\n (define (flow-host-req-step pend)\n (if (null? pend)\n (list)\n (let ((id (car (car pend))) (tag (car (cdr (car pend)))))\n (if (request? tag)\n (cons (list id (request-kind tag) (request-payload tag))\n (flow-host-req-step (cdr pend)))\n (flow-host-req-step (cdr pend))))))\n (define (flow-host-requests) (flow-host-req-step (flow/pending)))\n (define (flow-drive-host-step reqs dispatch)\n (if (null? reqs)\n 0\n (begin\n (flow/resume (car (car reqs)) (dispatch (car (cdr (car reqs))) (car (cdr (cdr (car reqs))))))\n (+ 1 (flow-drive-host-step (cdr reqs) dispatch)))))\n (define (flow-drive-host dispatch) (flow-drive-host-step (flow-host-requests) dispatch))\n (define (flow-run-host dispatch maxticks)\n (if (<= maxticks 0)\n 0\n (let ((n (flow-drive-host dispatch)))\n (if (= n 0) 0 (+ n (flow-run-host dispatch (- maxticks 1)))))))")
(define
flow-load-host!
(fn
(env)
(begin (scheme-eval-program (scheme-parse-all flow-host-src) env) env)))

34
lib/flow/remote.sx
View File

@@ -1,34 +0,0 @@
;; lib/flow/remote.sx — distributed nodes via fed-sx (Phase 4).
;;
;; A node can execute on a federation peer. The transport is the fed-sx boundary;
;; it is MOCKED in tests by a peer registry mapping addr -> function table. In
;; production flow-transport would issue a fed-sx call; here it dispatches locally.
;;
;; (flow-peer-register! addr table) — register a mock peer. table is a list of
;; (fn-name proc) entries — the functions that peer exposes.
;; (flow-transport addr fn input) — invoke fn on the peer with input. Raises
;; (flow-remote-unreachable) if the addr is unknown, (flow-remote-no-fn) if the
;; peer does not expose fn.
;; (remote-node addr fn) — a node that runs fn on the peer at addr.
;; (remote-failover addrs fn local) — try fn on each peer in addrs in order; on a
;; raised error move to the next peer; if every peer fails, run the `local`
;; node as a fallback.
;;
;; Persistence across instances + handoff. Each instance runs the same flow
;; definitions, so the only thing that needs to cross the wire is the (plain-data)
;; store — exactly flow-store-export from store.sx. Replication pushes that export
;; to a peer's replica slot; handoff = restore the replica on the peer and resume.
;;
;; (flow-replicate-to addr) — copy this instance's store to peer addr's replica
;; (flow-restore-from addr) — import the replica from peer addr (#t / #f)
;; (flow-replica-get addr) — the raw replicated store at addr (or #f)
(define
flow-remote-src
"(define flow-peers (list))\n (define (flow-assoc key alist)\n (if (null? alist)\n #f\n (if (eq? (car (car alist)) key) (car (cdr (car alist))) (flow-assoc key (cdr alist)))))\n (define (flow-peer-register! addr table) (set! flow-peers (cons (list addr table) flow-peers)))\n (define (flow-transport addr fn input)\n (let ((table (flow-assoc addr flow-peers)))\n (if table\n (let ((proc (flow-assoc fn table)))\n (if proc (proc input) (raise (quote flow-remote-no-fn))))\n (raise (quote flow-remote-unreachable)))))\n (define (remote-node addr fn) (lambda (input) (flow-transport addr fn input)))\n (define (flow-failover-step addrs fn input local)\n (if (null? addrs)\n (local input)\n (guard (e (#t (flow-failover-step (cdr addrs) fn input local)))\n (flow-transport (car addrs) fn input))))\n (define (remote-failover addrs fn local)\n (lambda (input) (flow-failover-step addrs fn input local)))\n\n (define flow-replicas (list))\n (define (flow-replicas-remove addr reps)\n (if (null? reps)\n (list)\n (if (eq? (car (car reps)) addr)\n (flow-replicas-remove addr (cdr reps))\n (cons (car reps) (flow-replicas-remove addr (cdr reps))))))\n (define (flow-replicate-to addr)\n (set! flow-replicas (cons (list addr (flow-store-export)) (flow-replicas-remove addr flow-replicas))))\n (define (flow-replica-get addr) (flow-assoc addr flow-replicas))\n (define (flow-restore-from addr)\n (let ((data (flow-replica-get addr)))\n (if data (begin (flow-store-import! data) #t) #f)))")
(define
flow-load-remote!
(fn
(env)
(begin (scheme-eval-program (scheme-parse-all flow-remote-src) env) env)))

19
lib/flow/scoreboard.json
View File

@@ -1,19 +0,0 @@
{
"total": 166,
"passed": 166,
"failed": 0,
"suites": {
"basic": { "passed": 18, "total": 18 },
"control": { "passed": 31, "total": 31 },
"suspend": { "passed": 17, "total": 17 },
"recovery": { "passed": 8, "total": 8 },
"distributed": { "passed": 19, "total": 19 },
"api": { "passed": 12, "total": 12 },
"combinators": { "passed": 17, "total": 17 },
"railway": { "passed": 10, "total": 10 },
"integration": { "passed": 10, "total": 10 },
"hygiene": { "passed": 9, "total": 9 },
"host": { "passed": 15, "total": 15 }
},
"phases": { "phase1": "done", "phase2": "done", "phase3": "done", "phase4": "done", "phase5": "done", "phase6": "done", "phase7": "done", "phase8": "done" }
}

53
lib/flow/scoreboard.md
View File

@@ -1,53 +0,0 @@
# flow-on-sx Scoreboard
**All tests pass: 166 / 166 across 11 suites. Phases 1-8 complete.**
`bash lib/flow/conformance.sh`
## Per-suite breakdown
| Suite | Passing | Covers |
|-------|--------:|--------|
| basic | 18 | Phase 1: single nodes, linear sequence, data-flow threading, defflow, parallel fan/join, nested composition, publish-shaped flow |
| control | 31 | Phase 2: `branch` (6); error model `fail`/`failed?`/`fail-reason` (6); `try-catch` (6); `retry n` (6); `timeout` cooperative step budget (7) |
| suspend | 17 | Phase 3: suspend/resume/cancel via deterministic replay; multi-step, replay determinism, lifecycle guards, suspend-in-branch |
| recovery | 8 | Phase 3: crash recovery — store export/import, resumable scan, restart-at-every-step, replay-log survival |
| distributed | 19 | Phase 4: `remote-node` (7); `remote-failover` (6); replication + handoff across instances (6) |
| api | 12 | Phase 5: introspection — `flow/status`, `flow/result`, `flow/list`, `flow/pending` |
| combinators | 17 | Phase 5: `tap`, `recover` (fail-value), `map-flow` fan-over-list, `flow-while`/`flow-until` bounded iteration |
| railway | 10 | Phase 6: `attempt` — fail-value short-circuiting sequence + recover rejoin |
| integration | 10 | Phase 7: end-to-end order + onboarding flows composing every phase (suspend, branch, federation, crash recovery, handoff, introspection) |
| hygiene | 9 | Phase 5: `flow/gc` (prune terminal flows), `flow/forget` (drop one terminal record) |
| host | 15 | Phase 8: host ABI — `request`/`await-human`/`await-render`, `flow-host-requests` queue, `flow-run-host` reference driver; art-dag-shaped render→review→publish loop |
## Architecture
Flow combinators are a **Scheme prelude** (`lib/flow/spec.sx`) loaded onto
`scheme-standard-env`. A flow is a Scheme procedure `input -> output`. The whole
flow executes inside the Scheme interpreter, so Phase 3's `suspend` (call/cc) will
capture the flow continuation directly.
- `lib/flow/spec.sx` — combinators: `flow-node`, `flow-id`, `flow-const`,
`sequence`, `parallel`, `defflow`; `flow-load-combinators!`.
- `lib/flow/api.sx` — `flow/start` (Scheme); `flow-make-env`, `flow-run`,
`flow-run-in` (SX helpers).
- `lib/flow/tests/basic.sx` — 18 cases.
- `lib/flow/conformance.sh` — loads substrate + flow layer, runs suites.
## Semantics notes
- **node** = 1-arg Scheme procedure; the upstream value is the argument. A node
ignoring its argument is effectively a thunk.
- **sequence** threads left-to-right; empty sequence = identity.
- **parallel** fans the same input to every branch and joins results into a list.
Evaluation is **sequential** for now; true concurrency arrives in Phase 3.
## Phases
- [x] Phase 1 — Declarative DAG + sequential execution (combinators + 18 tests, `flow/start`)
- [x] Phase 2 — Control flow + error handling (branch, error model, try-catch, retry, timeout)
- [x] Phase 3 — Suspend/resume (suspend/resume/cancel + crash recovery via deterministic replay)
- [x] Phase 4 — Distributed nodes via fed-sx (remote-node, failover, replication + handoff)
- [x] Phase 5 — Operational API + combinators (introspection, tap, recover, map-flow)
- [ ] Phase 3 — Suspend / resume (the showcase)
- [ ] Phase 4 — Distributed nodes via fed-sx

Some files were not shown because too many files have changed in this diff Show More