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

Compare commits

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

106 Commits
loops/even ... loops/fed-

Author SHA1 Message Date
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
383 changed files with 19830 additions and 34319 deletions
Expand all files Collapse all files

2
.claude/scheduled_tasks.lock
View File

@@ -1 +1 @@
{"sessionId":"c4d97db1-361c-4a04-a99b-c838f9385469","pid":2426590,"procStart":"349789073","acquiredAt":1780789990975}
{"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)))))

431
lib/erlang/runtime.sx
View File

@@ -956,8 +956,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 +1578,121 @@
;; 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.)
((sx-handler
(fn (req-dict)
(let ((req-pl (er-request-dict-to-proplist req-dict)))
(let ((resp-pl (er-apply-fun handler (list req-pl))))
(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 +1701,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 +1771,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 +1794,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 +1808,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!)

329
lib/events/api.sx
View File

@@ -1,329 +0,0 @@
;; lib/events/api.sx — public events surface over calendar + availability.
;;
;; A `store` is an immutable value holding scheduled events and (in-memory)
;; bookings:
;;
;; {:events (event ...) :bookings ((actor key) ...)}
;;
;; The in-memory `:bookings` list supports pure, value-level queries. The
;; DURABLE booking path (ev/*-occ! and ev/*-p) keeps bookings in persist
;; streams via booking.sx — capacity-safe, cancellable, replayable — and
;; derives availability from those streams. Use the persist path for real
;; bookings; the in-memory path for projections and tests.
;;
;; All queries are windowed: agenda/free/next-free expand recurring events into
;; concrete occurrences within an explicit (or derived) window before running
;; the Datalog availability rules.
(define ev/store (fn (events bookings) {:bookings bookings :events events}))
(define ev/empty (fn () (ev/store (list) (list))))
(define ev/events (fn (store) (get store :events)))
(define ev/bookings (fn (store) (get store :bookings)))
;; Add a (constructed) event to the store.
(define
ev/add-event
(fn
(store event)
(ev/store (cons event (ev/events store)) (ev/bookings store))))
;; Schedule a fresh event from parts, returning the updated store. rrule may be
;; nil for a one-off. (Booking is separate — see ev/book.)
(define
ev/schedule
(fn
(store id dtstart duration rrule capacity)
(ev/add-event store (ev-event id dtstart duration rrule capacity))))
;; Record that `actor` holds the occurrence with `key` (in-memory only — see
;; ev/book-occ! for the durable, capacity-safe path).
(define
ev/book
(fn
(store actor key)
(ev/store
(ev/events store)
(cons (list actor key) (ev/bookings store)))))
;; The event with `id`, or nil.
(define
ev/event-by-id
(fn
(store id)
(reduce
(fn
(found ev)
(if (nil? found) (if (= (get ev :id) id) ev found) found))
nil
(ev/events store))))
;; Capacity of the event an occurrence belongs to (0 if unknown).
(define
ev/capacity-of
(fn
(store occ)
(let
((ev (ev/event-by-id store (get occ :id))))
(if (nil? ev) 0 (get ev :capacity)))))
;; The maximum event duration in the store (0 when empty) — used to widen
;; expansion windows so any occurrence overlapping a query is captured.
(define
ev/store-max-duration
(fn
(store)
(reduce
(fn (m ev) (max m (get ev :duration)))
0
(ev/events store))))
;; All occurrences across all events within [ws, we), ascending by start.
(define
ev/agenda
(fn (store ws we) (ev-expand-all (ev/events store) ws we)))
(define
ev-key-member?
(fn
(k keys)
(cond
((empty? keys) false)
((= k (first keys)) true)
(else (ev-key-member? k (rest keys))))))
;; Occurrence keys `actor` has booked (in-memory store).
(define
ev/actor-keys
(fn
(store actor)
(reduce
(fn
(acc b)
(if (= (first b) actor) (cons (first (rest b)) acc) acc))
(list)
(ev/bookings store))))
;; The agenda restricted to occurrences `actor` is booked into (in-memory).
(define
ev/agenda-for
(fn
(store actor ws we)
(let
((keys (ev/actor-keys store actor)))
(filter
(fn (o) (ev-key-member? (ev-occ-key o) keys))
(ev/agenda store ws we)))))
;; Build an availability db over occurrences expanded in [ws, we) using the
;; in-memory bookings.
(define
ev/avail-window-db
(fn
(store ws we)
(ev-avail-db (ev/agenda store ws we) (ev/bookings store))))
;; Is `actor` free across [qs, qe)? Expands a window wide enough (back by the
;; longest event) to capture any occurrence that could overlap.
(define
ev/free?
(fn
(store actor qs qe)
(ev-free?
(ev/avail-window-db store (- qs (ev/store-max-duration store)) qe)
actor
qs
qe)))
;; Earliest free slot of `duration` for `actor` in [after, horizon), or nil.
(define
ev/next-free
(fn
(store actor after duration horizon)
(ev-next-free
(ev/avail-window-db
store
(- after (ev/store-max-duration store))
horizon)
actor
after
duration
horizon)))
;; Overlapping double-bookings for `actor` among occurrences in [ws, we).
(define
ev/conflicts
(fn
(store actor ws we)
(ev-conflicts (ev/avail-window-db store ws we) actor)))
(define
ev/has-conflict?
(fn
(store actor ws we)
(> (len (ev/conflicts store actor ws we)) 0)))
;; ---- durable, persist-backed booking path ----
;; These take a persist backend `b` (persist/open) plus the schedule `store`.
;; Bookings live in per-occurrence streams (booking.sx); availability is derived
;; by replaying those streams for the occurrences in the query window.
;; Durably book `actor` into occurrence `occ` (dict {:id :start :end}),
;; capacity-safe. Returns the booking.sx result (:booked / :full / :already).
(define
ev/book-occ!
(fn
(b store actor occ)
(ev/book! b (ev-occ-key occ) (ev/capacity-of store occ) actor)))
;; Durably cancel `actor`'s seat on `occ`, freeing capacity.
(define
ev/cancel-occ!
(fn (b store actor occ) (ev/cancel! b (ev-occ-key occ) actor)))
;; Live roster / seats-left for a specific occurrence from persist.
(define ev/roster-occ (fn (b occ) (ev/roster b (ev-occ-key occ))))
(define
ev/seats-left-occ
(fn
(b store occ)
(ev/seats-left b (ev-occ-key occ) (ev/capacity-of store occ))))
;; Derive (actor key) booking pairs from the persist rosters of `occs`.
(define
ev/persist-bookings
(fn
(b occs)
(reduce
(fn
(acc occ)
(let
((key (ev-occ-key occ)))
(append
acc
(map (fn (actor) (list actor key)) (ev/roster b key)))))
(list)
occs)))
;; Availability db over [ws, we) with bookings sourced from persist streams.
(define
ev/avail-db-p
(fn
(b store ws we)
(let
((occs (ev/agenda store ws we)))
(ev-avail-db occs (ev/persist-bookings b occs)))))
;; Persist-backed availability queries (mirror the in-memory ev/free? etc).
(define
ev/free-p?
(fn
(b store actor qs qe)
(ev-free?
(ev/avail-db-p b store (- qs (ev/store-max-duration store)) qe)
actor
qs
qe)))
(define
ev/next-free-p
(fn
(b store actor after duration horizon)
(ev-next-free
(ev/avail-db-p b store (- after (ev/store-max-duration store)) horizon)
actor
after
duration
horizon)))
(define
ev/conflicts-p
(fn
(b store actor ws we)
(ev-conflicts (ev/avail-db-p b store ws we) actor)))
(define
ev/has-conflict-p?
(fn
(b store actor ws we)
(> (len (ev/conflicts-p b store actor ws we)) 0)))
;; ---- conflict-checked booking ----
;; Capacity is per-event, but an attendee should not be double-booked against
;; THEMSELVES across different events. Would booking `actor` into `occ` overlap
;; an existing booking of theirs elsewhere? (Derived from persist availability;
;; an existing booking into `occ` itself is excluded — that's idempotent.)
(define
ev/would-time-conflict?
(fn
(b store actor occ)
(and
(not (ev-actor-booked? b (ev-occ-key occ) actor))
(not (ev/free-p? b store actor (get occ :start) (get occ :end))))))
;; Book `actor` into `occ` only if it doesn't clash with their other bookings.
;; Re-booking the same occurrence is idempotent (:already); a clash returns
;; :time-conflict; otherwise the normal ev/book-occ! result (:booked / :full).
(define
ev/book-checked!
(fn
(b store actor occ)
(cond
((ev-actor-booked? b (ev-occ-key occ) actor) (ev/book-occ! b store actor occ))
((ev/would-time-conflict? b store actor occ)
{:status :time-conflict :actor actor :occ-key (ev-occ-key occ)})
(else (ev/book-occ! b store actor occ)))))
;; ---- whole-series operations ----
;; Apply a booking action to every occurrence of one event in [ws, we) — e.g.
;; "RSVP to the whole weekly class". Returns a list of (occ-key status) results,
;; one per occurrence (empty if the event id is unknown).
(define
ev/book-series!
(fn
(b store actor event-id ws we)
(let
((ev (ev/event-by-id store event-id)))
(if
(nil? ev)
(list)
(map
(fn (occ) (list (ev-occ-key occ) (get (ev/book-occ! b store actor occ) :status)))
(ev-expand ev ws we))))))
;; Cancel `actor` from every occurrence of one event in [ws, we).
(define
ev/cancel-series!
(fn
(b store actor event-id ws we)
(let
((ev (ev/event-by-id store event-id)))
(if
(nil? ev)
(list)
(map
(fn (occ) (list (ev-occ-key occ) (get (ev/cancel! b (ev-occ-key occ) actor) :status)))
(ev-expand ev ws we))))))
;; How many statuses in a series-result list equal `status`.
(define
ev/series-count
(fn
(results status)
(len (filter (fn (r) (= (first (rest r)) status)) results))))
;; The occurrences of one event in [ws, we) that `actor` is booked into.
(define
ev/series-booked
(fn
(b store actor event-id ws we)
(let
((ev (ev/event-by-id store event-id)))
(if
(nil? ev)
(list)
(filter
(fn (occ) (ev-actor-booked? b (ev-occ-key occ) actor))
(ev-expand ev ws we))))))

177
lib/events/availability.sx
View File

@@ -1,177 +0,0 @@
;; lib/events/availability.sx — free/busy + conflict detection on Datalog.
;;
;; Availability is per-actor and is forward-chained Datalog over two EDB
;; relations:
;;
;; (occurrence Key EventId Start End) ; an expanded calendar occurrence
;; (booking Actor Key) ; actor attends/holds that occurrence
;;
;; The derived relations are the whole policy:
;;
;; busy(A,S,E) — A is committed for [S,E) (a booked occurrence)
;; conflict(A,O1,O2) — A double-booked into two overlapping occurrences
;; busy_in(A,QS,QE) — A is busy somewhere inside query window [QS,QE)
;;
;; Intervals are half-open [Start,End) in epoch minutes (see calendar.sx), so
;; adjacent slots (E == next start) do NOT conflict. Conflict pairs are
;; canonical (O1 < O2 by key) so each overlap is reported once. The same `busy`
;; rule answers "is A free in [QS,QE)?" (busy_in is empty) and feeds "when is A
;; next free?" (ev-next-free probes candidate slots with the same rule).
;; A stable key for an occurrence dict {:id :start :end}.
(define ev-occ-key (fn (occ) (str (get occ :id) "@" (get occ :start))))
(define
ev-occurrence-fact
(fn
(occ)
(list
(quote occurrence)
(ev-occ-key occ)
(get occ :id)
(get occ :start)
(get occ :end))))
(define ev-occurrence-facts (fn (occs) (map ev-occurrence-fact occs)))
(define ev-booking-fact (fn (actor key) (list (quote booking) actor key)))
(define ev-qwindow-fact (fn (qs qe) (list (quote qwindow) qs qe)))
;; Range restriction: each comparison's variables are bound by an earlier
;; positive literal (qwindow / busy precede the < tests). Conflict uses
;; (< O1 O2) on the keys so each overlapping pair is reported once.
(define
ev-avail-rules
(quote
((busy A S E <- (booking A O) (occurrence O _ S E))
(conflict
A
O1
O2
<-
(booking A O1)
(booking A O2)
(occurrence O1 _ S1 E1)
(occurrence O2 _ S2 E2)
(< O1 O2)
(< S1 E2)
(< S2 E1))
(busy_in A QS QE <- (qwindow QS QE) (busy A S E) (< S QE) (< QS E)))))
;; Build a Datalog db from EDB facts under the availability ruleset.
(define ev-build-avail (fn (facts) (dl-program-data facts ev-avail-rules)))
;; Convenience: build a db from occurrence dicts + booking pairs.
;; bookings is a list of (actor key) pairs.
(define
ev-avail-db
(fn
(occs bookings)
(ev-build-avail
(append
(ev-occurrence-facts occs)
(map
(fn (b) (ev-booking-fact (first b) (first (rest b))))
bookings)))))
;; Helper: insertion sort a list of (S E ...) lists ascending by S then E.
(define
ev-list-before?
(fn
(a b)
(cond
((< (first a) (first b)) true)
((> (first a) (first b)) false)
(else (< (first (rest a)) (first (rest b)))))))
(define
ev-list-insert
(fn
(x sorted)
(cond
((empty? sorted) (list x))
((ev-list-before? x (first sorted)) (cons x sorted))
(else (cons (first sorted) (ev-list-insert x (rest sorted)))))))
(define
ev-sort-lists
(fn (xs) (reduce (fn (acc x) (ev-list-insert x acc)) (list) xs)))
(define
ev-dedup-sorted
(fn
(xs)
(cond
((empty? xs) xs)
((empty? (rest xs)) xs)
((= (first xs) (first (rest xs))) (ev-dedup-sorted (rest xs)))
(else (cons (first xs) (ev-dedup-sorted (rest xs)))))))
;; All busy intervals (list S E) for an actor, ascending by start.
(define
ev-busy
(fn
(db actor)
(let
((rows (dl-query db (list (quote busy) actor (quote S) (quote E)))))
(ev-sort-lists (map (fn (b) (list (get b :S) (get b :E))) rows)))))
;; Distinct conflicting occurrence-key pairs for an actor (each pair once).
(define
ev-conflicts
(fn
(db actor)
(dl-query db (list (quote conflict) actor (quote O1) (quote O2)))))
(define
ev-has-conflict?
(fn (db actor) (> (len (ev-conflicts db actor)) 0)))
;; Is `actor` free across the whole window [qs,qe)? (no booked occurrence
;; overlaps it). Asserts a transient qwindow fact, queries, retracts.
(define
ev-free?
(fn
(db actor qs qe)
(do
(dl-assert! db (ev-qwindow-fact qs qe))
(let
((rows (dl-query db (list (quote busy_in) actor (quote QS) (quote QE)))))
(begin (dl-retract! db (ev-qwindow-fact qs qe)) (empty? rows))))))
;; ---- next-free slot search ----
;; The earliest start s >= `after` such that [s, s+duration) is entirely free
;; for `actor` and ends at or before `horizon`, or nil if none. The earliest
;; such slot must begin either at `after` or immediately after some busy
;; interval ends (classic interval packing), so those are the only candidates
;; we probe — each probe reuses the busy_in rule via ev-free?.
(define
ev-first-free
(fn
(db actor cands duration horizon)
(cond
((empty? cands) nil)
(else
(let
((s (first cands)))
(if
(and
(<= (+ s duration) horizon)
(ev-free? db actor s (+ s duration)))
s
(ev-first-free db actor (rest cands) duration horizon)))))))
(define
ev-next-free
(fn
(db actor after duration horizon)
(let
((ends (filter (fn (e) (>= e after)) (map (fn (iv) (first (rest iv))) (ev-busy db actor)))))
(ev-first-free
db
actor
(ev-dedup-sorted (sort (cons after ends)))
duration
horizon))))

102
lib/events/booking-notify.sx
View File

@@ -1,102 +0,0 @@
;; lib/events/booking-notify.sx — derive lifecycle notifications from the
;; booking stream, for delivery via notify.sx.
;;
;; Walking the append-only booking stream yields one notification per state
;; change, in order, classified by kind:
;;
;; :booked a confirmed booking
;; :promoted a booking for an actor who was on the waitlist (auto-promote)
;; :held a provisional hold (pending payment)
;; :confirmed a held seat became confirmed (payment succeeded)
;; :released a held seat was released (payment failed/expired)
;; :cancelled a seat was given up
;; :waitlisted an actor joined the waitlist
;;
;; Promotion is detected by folding the waitlist as we walk: a :booking for an
;; actor currently on the waitlist is a promotion, not a fresh booking.
;;
;; Each notification's id is occ-key/seq (the stream seq is unique and stable),
;; so re-deriving and re-delivering is idempotent — the notify transport dedups
;; on this id and never double-pings.
(define
ev-bn-kind
(fn
(typ promoted?)
(cond
((= typ :hold) :held)
((= typ :booking) (if promoted? :promoted :booked))
((= typ :confirm) :confirmed)
((= typ :cancel) :cancelled)
((= typ :release) :released)
((= typ :waitlist) :waitlisted)
(else nil))))
(define
ev-bn-update-waiting
(fn
(typ actor waiting)
(cond
((= typ :waitlist)
(if
(ev-bk-member? actor waiting)
waiting
(ev-bk-append waiting actor)))
((= typ :unwaitlist) (ev-bk-remove waiting actor))
((= typ :booking) (ev-bk-remove waiting actor))
((= typ :hold) (ev-bk-remove waiting actor))
(else waiting))))
(define ev-bn-mk (fn (occ-key label actor kind seq) {:id (str occ-key "/" seq) :event label :kind kind :recipient actor :seq seq}))
(define
ev-bn-step
(fn
(occ-key label events waiting)
(if
(empty? events)
(list)
(let
((e (first events)))
(let
((typ (persist/event-type e))
(actor (get (persist/event-data e) :actor))
(seq (persist/event-seq e)))
(let
((promoted? (and (= typ :booking) (ev-bk-member? actor waiting))))
(let
((kind (ev-bn-kind typ promoted?))
(waiting2 (ev-bn-update-waiting typ actor waiting)))
(if
(nil? kind)
(ev-bn-step occ-key label (rest events) waiting2)
(cons
(ev-bn-mk occ-key label actor kind seq)
(ev-bn-step occ-key label (rest events) waiting2))))))))))
;; The ordered lifecycle notifications for an occurrence's bookings. `label` is
;; a human-facing event id carried on each notification.
(define
ev/booking-notifications
(fn
(b occ-key label)
(ev-bn-step
occ-key
label
(persist/read b (ev-booking-stream occ-key))
(list))))
;; Filter notifications to a single kind.
(define
ev/notify-of-kind
(fn (notifs kind) (filter (fn (n) (= (get n :kind) kind)) notifs)))
;; Project a notification to notify.sx's (id recipient body) wire shape.
(define
ev/booking-notify->msg
(fn
(n)
(list
(get n :id)
(get n :recipient)
(list :booking-event (get n :kind) (get n :event)))))

372
lib/events/booking.sx
View File

@@ -1,372 +0,0 @@
;; lib/events/booking.sx — transactional, capacity-safe booking on persist.
;;
;; Each bookable occurrence has an append-only stream of booking events:
;;
;; :booking free booking — actor immediately holds a confirmed seat
;; :hold provisional hold — seat reserved while payment is pending
;; :confirm a held seat becomes confirmed (payment succeeded)
;; :release a held seat is abandoned (payment failed/expired) — seat freed
;; :cancel a held or confirmed seat is given up — seat freed
;;
;; The live state is the stream FOLDED in order into per-actor seat states
;; (:held / :confirmed); an actor in ANY state occupies a seat, so both held and
;; confirmed seats count toward capacity — a pending payment cannot be
;; oversold. A freed seat (release/cancel) reopens capacity.
;;
;; Capacity safety is the contract: two writers racing for the last seat must
;; NEVER both succeed. Seat-ACQUIRING writes (:booking, :hold) go through
;; persist's optimistic concurrency — `persist/append-expect` appends only if
;; the stream's last-seq still equals what the writer observed; else it returns
;; a conflict the writer retries. Seat-FREEING writes (:cancel, :release) and
;; the state transition (:confirm) never oversell, so they append directly.
(define ev-booking-stream (fn (occ-key) (str "booking:" occ-key)))
(define
ev-bk-member?
(fn
(x xs)
(cond
((empty? xs) false)
((= x (first xs)) true)
(else (ev-bk-member? x (rest xs))))))
(define
ev-bk-index
(fn
(xs x i)
(cond
((empty? xs) -1)
((= (first xs) x) i)
(else (ev-bk-index (rest xs) x (+ i 1))))))
(define ev-bk-append (fn (xs a) (append xs (list a))))
(define ev-bk-remove (fn (xs a) (filter (fn (x) (not (= x a))) xs)))
;; ---- per-actor state association list: ((actor state) ...) in join order ----
(define
ev-state-has?
(fn
(states actor)
(cond
((empty? states) false)
((= (first (first states)) actor) true)
(else (ev-state-has? (rest states) actor)))))
(define
ev-state-get
(fn
(states actor)
(cond
((empty? states) :none)
((= (first (first states)) actor) (first (rest (first states))))
(else (ev-state-get (rest states) actor)))))
(define
ev-state-del
(fn (states actor) (filter (fn (p) (not (= (first p) actor))) states)))
(define
ev-state-set
(fn
(states actor st)
(if
(ev-state-has? states actor)
(map (fn (p) (if (= (first p) actor) (list actor st) p)) states)
(append states (list (list actor st))))))
;; Fold the booking stream into per-actor seat states (join order preserved).
(define
ev-fold-states
(fn
(events)
(reduce
(fn
(acc e)
(let
((typ (persist/event-type e))
(actor (get (persist/event-data e) :actor)))
(cond
((= typ :booking) (ev-state-set acc actor :confirmed))
((= typ :hold) (ev-state-set acc actor :held))
((= typ :confirm)
(if
(ev-state-has? acc actor)
(ev-state-set acc actor :confirmed)
acc))
((= typ :cancel) (ev-state-del acc actor))
((= typ :release) (ev-state-del acc actor))
(else acc))))
(list)
events)))
(define
ev-states-of
(fn
(b occ-key)
(ev-fold-states (persist/read b (ev-booking-stream occ-key)))))
;; Live roster (actors holding a seat — held or confirmed), oldest active first.
(define
ev-booked-actors
(fn (b occ-key) (map (fn (p) (first p)) (ev-states-of b occ-key))))
(define
ev-actor-booked?
(fn (b occ-key actor) (ev-bk-member? actor (ev-booked-actors b occ-key))))
;; Live seat count (folded roster size — both held and confirmed seats).
(define
ev-booking-count
(fn (b occ-key) (len (ev-booked-actors b occ-key))))
;; Seat state for an actor: :held / :confirmed / :none.
(define
ev/seat-state
(fn (b occ-key actor) (ev-state-get (ev-states-of b occ-key) actor)))
;; 1-based seat number for an actor on the roster (0 if not booked).
(define
ev-seat-of
(fn
(actors actor)
(let
((i (ev-bk-index actors actor 0)))
(if (< i 0) 0 (+ i 1)))))
;; ---- seat-acquiring writes (capacity-guarded via append-expect) ----
;; One seat-acquiring attempt of `kind` (:booking or :hold) against an OBSERVED
;; snapshot (roster the writer saw + the last-seq). Returns :already / :full /
;; :conflict, or a success dict tagged with `ok-status`. :conflict means a
;; concurrent append landed since the snapshot — the caller must re-observe.
(define
ev-acquire-with-observed
(fn
(b occ-key capacity actor observed-actors expected kind ok-status)
(cond
((ev-bk-member? actor observed-actors) {:seat (ev-seat-of observed-actors actor) :actor actor :status :already})
((>= (len observed-actors) capacity) {:actor actor :capacity capacity :status :full})
(else
(let
((r (persist/append-expect b (ev-booking-stream occ-key) expected kind 0 {:actor actor})))
(if (persist/conflict? r) {:actual (persist/conflict-actual r) :actor actor :status :conflict} {:seat (+ (len observed-actors) 1) :actor actor :status ok-status}))))))
(define
ev-acquire!
(fn
(b occ-key capacity actor kind ok-status)
(let
((res (ev-acquire-with-observed b occ-key capacity actor (ev-booked-actors b occ-key) (persist/last-seq b (ev-booking-stream occ-key)) kind ok-status)))
(if
(= (get res :status) :conflict)
(ev-acquire! b occ-key capacity actor kind ok-status)
res))))
;; Capacity-safe confirmed booking (retrying on conflict).
(define
ev/book!
(fn
(b occ-key capacity actor)
(ev-acquire! b occ-key capacity actor :booking :booked)))
;; Capacity-safe provisional hold (retrying on conflict). The seat is reserved
;; (counts toward capacity) until confirmed or released.
(define
ev/hold!
(fn
(b occ-key capacity actor)
(ev-acquire! b occ-key capacity actor :hold :held)))
;; Test seam: one attempt against a caller-supplied snapshot (book or hold).
(define
ev/book-with-observed
(fn
(b occ-key capacity actor observed-actors expected)
(ev-acquire-with-observed
b
occ-key
capacity
actor
observed-actors
expected
:booking :booked)))
(define
ev/hold-with-observed
(fn
(b occ-key capacity actor observed-actors expected)
(ev-acquire-with-observed
b
occ-key
capacity
actor
observed-actors
expected
:hold :held)))
;; ---- state transitions / seat-freeing writes (no oversell, append direct) ----
;; Confirm a held seat (payment succeeded). :confirmed on success,
;; :already-confirmed if it was confirmed, :not-held otherwise.
(define
ev/confirm!
(fn
(b occ-key actor)
(let
((st (ev/seat-state b occ-key actor)))
(cond
((= st :held)
(begin
(persist/append
b
(ev-booking-stream occ-key)
:confirm 0
{:actor actor})
{:actor actor :status :confirmed}))
((= st :confirmed) {:actor actor :status :already-confirmed})
(else {:actor actor :status :not-held})))))
;; Release a held seat (payment failed/expired), freeing it. Only valid for a
;; held seat — confirmed bookings are given up via ev/cancel!.
(define
ev/release!
(fn
(b occ-key actor)
(let
((st (ev/seat-state b occ-key actor)))
(if
(= st :held)
(begin
(persist/append
b
(ev-booking-stream occ-key)
:release 0
{:actor actor})
{:actor actor :status :released})
{:actor actor :status :not-held}))))
;; Cancel a held or confirmed seat, freeing it. :cancelled or :not-booked.
(define
ev/cancel!
(fn
(b occ-key actor)
(if
(ev-bk-member? actor (ev-booked-actors b occ-key))
(begin
(persist/append
b
(ev-booking-stream occ-key)
:cancel 0
{:actor actor})
{:actor actor :status :cancelled})
{:actor actor :status :not-booked})))
;; The roster as a plain list of actors (oldest active first).
(define ev/roster (fn (b occ-key) (ev-booked-actors b occ-key)))
;; Seats remaining for an occurrence of the given capacity.
(define
ev/seats-left
(fn
(b occ-key capacity)
(max 0 (- capacity (ev-booking-count b occ-key)))))
;; ---- waitlist ----
;; When an occurrence is full, actors join a FIFO waitlist (:waitlist /
;; :unwaitlist events on the same stream). Taking a seat (:booking / :hold)
;; removes an actor from the queue, so the waitlist fold is independent of the
;; seat fold. Cancelling/releasing a seat can auto-promote the head of the
;; queue (a :booking appended for them).
(define
ev-fold-waiting
(fn
(events)
(reduce
(fn
(acc e)
(let
((typ (persist/event-type e))
(actor (get (persist/event-data e) :actor)))
(cond
((= typ :waitlist) (if (ev-bk-member? actor acc) acc (ev-bk-append acc actor)))
((= typ :unwaitlist) (ev-bk-remove acc actor))
((= typ :booking) (ev-bk-remove acc actor))
((= typ :hold) (ev-bk-remove acc actor))
(else acc))))
(list)
events)))
;; The current waitlist queue (FIFO, oldest first).
(define
ev/waitlist
(fn (b occ-key) (ev-fold-waiting (persist/read b (ev-booking-stream occ-key)))))
;; 1-based queue position for an actor (0 if not waiting).
(define
ev/waitlist-position
(fn (b occ-key actor) (ev-seat-of (ev/waitlist b occ-key) actor)))
;; Book if a seat is free, else join the waitlist. Idempotent: already seated →
;; :already; already queued → :already-waiting.
(define
ev/waitlist!
(fn
(b occ-key capacity actor)
(let
((seats (ev-booked-actors b occ-key))
(waiting (ev/waitlist b occ-key)))
(cond
((ev-bk-member? actor seats)
{:status :already :seat (ev-seat-of seats actor) :actor actor})
((ev-bk-member? actor waiting)
{:status :already-waiting :position (ev-seat-of waiting actor) :actor actor})
(else
(let
((r (ev/book! b occ-key capacity actor)))
(if
(= (get r :status) :booked)
r
(begin
(persist/append b (ev-booking-stream occ-key) :waitlist 0 {:actor actor})
{:status :waitlisted
:position (+ (len waiting) 1)
:actor actor}))))))))
;; Leave the waitlist. :left or :not-waiting.
(define
ev/leave-waitlist!
(fn
(b occ-key actor)
(if
(ev-bk-member? actor (ev/waitlist b occ-key))
(begin
(persist/append b (ev-booking-stream occ-key) :unwaitlist 0 {:actor actor})
{:status :left :actor actor})
{:status :not-waiting :actor actor})))
;; Cancel a seat and, if that frees capacity, auto-promote the head of the
;; waitlist (a confirmed booking). Returns the cancel result plus :promoted
;; (the actor promoted, or nil).
(define
ev/cancel-promote!
(fn
(b occ-key capacity actor)
(let
((c (ev/cancel! b occ-key actor)))
(if
(= (get c :status) :cancelled)
(let
((waiting (ev/waitlist b occ-key))
(seats (ev-booked-actors b occ-key)))
(if
(and (not (empty? waiting)) (< (len seats) capacity))
(let
((promoted (first waiting)))
(begin
(persist/append b (ev-booking-stream occ-key) :booking 0 {:actor promoted})
{:status :cancelled :actor actor :promoted promoted}))
{:status :cancelled :actor actor :promoted nil}))
c))))

614
lib/events/calendar.sx
View File

@@ -1,614 +0,0 @@
;; lib/events/calendar.sx — civil date arithmetic + RRULE expansion in a window.
;;
;; Datetimes are integer "epoch minutes": days-since-1970-01-01 * 1440 plus
;; minute-of-day. Ordering, window bounds, and durations are plain integer
;; arithmetic. Civil <-> day-number conversion uses Howard Hinnant's algorithm
;; (exact, branch-free, correct for the proleptic Gregorian calendar).
;;
;; RRULE expansion is the bridge to Datalog: a recurring event expands to a
;; bounded list of occurrence dicts within an explicit (win-start, win-end)
;; window. Expansion is ALWAYS windowed — an RRULE without a window is an
;; infinite computation and is never permitted. Supported subset (RFC 5545):
;; FREQ=DAILY|WEEKLY|MONTHLY, INTERVAL, COUNT, UNTIL, BYDAY (weekly: weekday
;; numbers; monthly: {:ord N :wd W} ordinal weekdays), BYMONTHDAY (monthly,
;; negative = from month end). YEARLY and the rest are deferred.
;; ---- integer helpers ----
;; Floored integer division (modulo is already floored, so the remainder
;; subtraction makes the quotient exact and floor-correct for any sign).
(define ev-floor-div (fn (a b) (quotient (- a (modulo a b)) b)))
(define ev-or (fn (x d) (if (nil? x) d x)))
(define ev-filter-nil (fn (xs) (filter (fn (x) (not (nil? x))) xs)))
;; ---- civil date core (Hinnant) ----
;; Days since 1970-01-01 for civil (y, m, d). m in [1,12], d in [1,31].
(define
ev-days-from-civil
(fn
(y0 m d)
(let
((y (if (<= m 2) (- y0 1) y0)))
(let
((era (ev-floor-div (if (>= y 0) y (- y 399)) 400)))
(let
((yoe (- y (* era 400)))
(doy
(+
(ev-floor-div
(+
(*
153
(+ m (if (> m 2) -3 9)))
2)
5)
(- d 1))))
(let
((doe (+ (* yoe 365) (ev-floor-div yoe 4) (- (ev-floor-div yoe 100)) doy)))
(+ (* era 146097) doe -719468)))))))
;; Civil (y m d) list from a day-number.
(define
ev-civil-from-days
(fn
(z0)
(let
((z (+ z0 719468)))
(let
((era (ev-floor-div (if (>= z 0) z (- z 146096)) 146097)))
(let
((doe (- z (* era 146097))))
(let
((yoe (ev-floor-div (+ (- doe (ev-floor-div doe 1460)) (ev-floor-div doe 36524) (- (ev-floor-div doe 146096))) 365)))
(let
((y (+ yoe (* era 400)))
(doy
(-
doe
(+
(* 365 yoe)
(ev-floor-div yoe 4)
(- (ev-floor-div yoe 100))))))
(let
((mp (ev-floor-div (+ (* 5 doy) 2) 153)))
(let
((d (+ (- doy (ev-floor-div (+ (* 153 mp) 2) 5)) 1))
(m
(if
(< mp 10)
(+ mp 3)
(- mp 9))))
(list (if (<= m 2) (+ y 1) y) m d))))))))))
;; Weekday of a day-number: 0=Mon .. 6=Sun (1970-01-01 is Thursday = 3).
(define ev-weekday-of-days (fn (z) (modulo (+ z 3) 7)))
(define
ev-days-in-month
(fn
(y m)
(-
(ev-days-from-civil
(if (= m 12) (+ y 1) y)
(if (= m 12) 1 (+ m 1))
1)
(ev-days-from-civil y m 1))))
;; Add k months to (y,m), returning (list y2 m2).
(define
ev-add-months
(fn
(y m k)
(let
((total (+ (* y 12) (- m 1) k)))
(list
(ev-floor-div total 12)
(+ (modulo total 12) 1)))))
;; ---- datetime (epoch minutes) ----
(define
ev-dt
(fn
(y m d hh mm)
(+ (* (ev-days-from-civil y m d) 1440) (* hh 60) mm)))
(define ev-date (fn (y m d) (ev-dt y m d 0 0)))
(define ev-dt->days (fn (t) (ev-floor-div t 1440)))
(define ev-dt->civil (fn (t) (ev-civil-from-days (ev-dt->days t))))
(define ev-dt-weekday (fn (t) (ev-weekday-of-days (ev-dt->days t))))
(define ev-dt-tod (fn (t) (modulo t 1440)))
(define ev-civ-y (fn (c) (first c)))
(define ev-civ-m (fn (c) (first (rest c))))
(define ev-civ-d (fn (c) (first (rest (rest c)))))
;; ---- event + occurrence constructors ----
;; rrule is nil (single event) or a dict:
;; {:freq :daily|:weekly|:monthly :interval N :count N|nil :until DT|nil
;; :byday ...|nil :bymonthday (list 15 -1)|nil}
;; weekly :byday -> (list 0 2 4) weekday numbers, 0=Mon
;; monthly :byday -> (list {:ord 2 :wd 1}) nth weekday (ord<0 from end)
;; monthly :bymonthday -> (list 15 -1) day of month (negative from end)
(define ev-event (fn (id dtstart duration rrule capacity) {:duration duration :id id :dtstart dtstart :capacity capacity :rrule rrule}))
;; Event with EXDATE/RDATE exceptions. exdate/rdate are lists of epoch-minute
;; starts to exclude from / add to the expansion (RFC 5545 VEVENT properties).
(define
ev-event-full
(fn
(id dtstart duration rrule capacity exdate rdate)
{:duration duration
:id id
:dtstart dtstart
:capacity capacity
:rrule rrule
:exdate exdate
:rdate rdate}))
(define ev-occ (fn (id start dur) {:id id :start start :end (+ start dur)}))
;; ---- DAILY expansion ----
;; occ starts at dtstart; n counts every generated occurrence (window-
;; independent, so COUNT/UNTIL bound the rule, not the view). Emits only
;; occurrences inside [win-start, win-end].
(define
ev-daily-loop
(fn
(id occ duration step count until dtstart win-start win-end acc n)
(cond
((> occ win-end) acc)
((and (not (nil? count)) (>= n count)) acc)
((and (not (nil? until)) (> occ until)) acc)
(else
(begin
(when (>= occ win-start) (append! acc (ev-occ id occ duration)))
(ev-daily-loop
id
(+ occ step)
duration
step
count
until
dtstart
win-start
win-end
acc
(+ n 1)))))))
;; ---- shared per-period emit ----
;; Walk a start-ascending list of candidate occurrence datetimes for one
;; period, generating (count toward COUNT) those >= dtstart within UNTIL, and
;; emitting those also inside the window. Returns the updated running n.
(define
ev-emit-occs
(fn
(id occs duration count until dtstart win-start win-end acc n)
(if
(empty? occs)
n
(let
((occ (first occs)))
(let
((generates? (and (>= occ dtstart) (or (nil? until) (<= occ until)) (or (nil? count) (< n count)))))
(begin
(when
(and generates? (>= occ win-start) (<= occ win-end))
(append! acc (ev-occ id occ duration)))
(ev-emit-occs
id
(rest occs)
duration
count
until
dtstart
win-start
win-end
acc
(if generates? (+ n 1) n))))))))
;; ---- WEEKLY expansion ----
;; Iterate week by week from the Monday of dtstart's week; within each active
;; week emit each BYDAY (sorted). n counts every generated occurrence.
(define
ev-week0-days
(fn (dtstart) (- (ev-dt->days dtstart) (ev-dt-weekday dtstart))))
(define
ev-byday-default
(fn
(byday dtstart)
(if (nil? byday) (list (ev-dt-weekday dtstart)) (sort byday))))
(define
ev-weekly-loop
(fn
(id
week-days
tod
duration
week-step
bd
count
until
dtstart
win-start
win-end
acc
n)
(let
((week-start-dt (* week-days 1440)))
(cond
((> week-start-dt win-end) acc)
((and (not (nil? count)) (>= n count)) acc)
(else
(let
((occs (map (fn (wd) (+ (* (+ week-days wd) 1440) tod)) bd)))
(let
((n2 (ev-emit-occs id occs duration count until dtstart win-start win-end acc n)))
(ev-weekly-loop
id
(+ week-days week-step)
tod
duration
week-step
bd
count
until
dtstart
win-start
win-end
acc
n2))))))))
;; ---- MONTHLY expansion ----
;; Iterate month by month from dtstart's month, stepping by INTERVAL months.
;; Candidate days per month come from BYMONTHDAY, then ordinal BYDAY, else the
;; day-of-month of dtstart (skipped in months too short to contain it).
;; Resolve a BYMONTHDAY value to a valid day-of-month, or nil.
(define
ev-resolve-monthday
(fn
(y m bmd)
(let
((dim (ev-days-in-month y m)))
(let
((day (if (< bmd 0) (+ dim 1 bmd) bmd)))
(if (and (>= day 1) (<= day dim)) day nil)))))
;; Resolve an ordinal weekday {:ord :wd} to a day-of-month, or nil.
(define
ev-resolve-nth-weekday
(fn
(y m ord wd)
(let
((dim (ev-days-in-month y m)))
(if
(> ord 0)
(let
((first-wd (ev-weekday-of-days (ev-days-from-civil y m 1))))
(let
((day (+ 1 (modulo (- wd first-wd) 7) (* (- ord 1) 7))))
(if (<= day dim) day nil)))
(let
((last-wd (ev-weekday-of-days (ev-days-from-civil y m dim))))
(let
((day (- dim (modulo (- last-wd wd) 7) (* (- (- ord) 1) 7))))
(if (>= day 1) day nil)))))))
(define
ev-month-candidates
(fn
(y m rrule dtstart)
(let
((bmd (get rrule :bymonthday)) (byday (get rrule :byday)))
(cond
((not (nil? bmd))
(ev-filter-nil (map (fn (d) (ev-resolve-monthday y m d)) bmd)))
((not (nil? byday))
(ev-filter-nil
(map
(fn
(e)
(ev-resolve-nth-weekday y m (get e :ord) (get e :wd)))
byday)))
(else
(ev-filter-nil
(list
(ev-resolve-monthday y m (ev-civ-d (ev-dt->civil dtstart))))))))))
(define
ev-monthly-loop
(fn
(id
y
m
rrule
duration
tod
interval
count
until
dtstart
win-start
win-end
acc
n)
(let
((month-start (ev-dt y m 1 0 0)))
(cond
((> month-start win-end) acc)
((and (not (nil? count)) (>= n count)) acc)
(else
(let
((days (sort (ev-month-candidates y m rrule dtstart))))
(let
((occs (map (fn (d) (+ (* (ev-days-from-civil y m d) 1440) tod)) days)))
(let
((n2 (ev-emit-occs id occs duration count until dtstart win-start win-end acc n))
(nm (ev-add-months y m interval)))
(ev-monthly-loop
id
(ev-civ-y nm)
(ev-civ-m nm)
rrule
duration
tod
interval
count
until
dtstart
win-start
win-end
acc
n2)))))))))
;; ---- top-level expansion ----
;; Raw expansion (RRULE / single event), before EXDATE/RDATE are applied.
;; Returns a list of occurrence dicts {:id :start :end} within the window.
(define
ev-expand-base
(fn
(event win-start win-end)
(let
((id (get event :id))
(dtstart (get event :dtstart))
(duration (get event :duration))
(rrule (get event :rrule)))
(if
(nil? rrule)
(if
(and (>= dtstart win-start) (<= dtstart win-end))
(list (ev-occ id dtstart duration))
(list))
(let
((freq (get rrule :freq))
(interval (ev-or (get rrule :interval) 1))
(count (get rrule :count))
(until (get rrule :until))
(byday (get rrule :byday))
(acc (list)))
(begin
(cond
((= freq :daily)
(ev-daily-loop
id
dtstart
duration
(* interval 1440)
count
until
dtstart
win-start
win-end
acc
0))
((= freq :weekly)
(ev-weekly-loop
id
(ev-week0-days dtstart)
(ev-dt-tod dtstart)
duration
(* interval 7)
(ev-byday-default byday dtstart)
count
until
dtstart
win-start
win-end
acc
0))
((= freq :monthly)
(let
((civ (ev-dt->civil dtstart)))
(ev-monthly-loop
id
(ev-civ-y civ)
(ev-civ-m civ)
rrule
duration
(ev-dt-tod dtstart)
interval
count
until
dtstart
win-start
win-end
acc
0)))
(else (error (str "ev-expand-base: unsupported freq: " freq))))
acc))))))
;; ---- EXDATE / RDATE (RFC 5545 exceptions) ----
;; Applied AFTER raw expansion: RDATE adds explicit occurrences within the
;; window, EXDATE removes occurrences whose start matches (EXDATE wins over
;; RDATE). Both are VEVENT-level: (get event :exdate) / (get event :rdate) are
;; lists of epoch-minute starts; nil for plain events.
(define
ev-num-member?
(fn
(n xs)
(cond
((empty? xs) false)
((= n (first xs)) true)
(else (ev-num-member? n (rest xs))))))
;; Drop duplicate-start occurrences from a start-sorted list (keep one).
(define
ev-dedupe-by-start
(fn
(occs)
(cond
((empty? occs) occs)
((empty? (rest occs)) occs)
((= (get (first occs) :start) (get (first (rest occs)) :start))
(ev-dedupe-by-start (rest occs)))
(else (cons (first occs) (ev-dedupe-by-start (rest occs)))))))
(define
ev-apply-exceptions
(fn
(event base win-start win-end)
(let
((id (get event :id))
(duration (get event :duration))
(exdate (ev-or (get event :exdate) (list)))
(rdate (ev-or (get event :rdate) (list))))
(let
((rdate-occs
(reduce
(fn
(acc d)
(if
(and (>= d win-start) (<= d win-end))
(cons (ev-occ id d duration) acc)
acc))
(list)
rdate)))
(let
((no-ex
(filter
(fn (o) (not (ev-num-member? (get o :start) exdate)))
(append base rdate-occs))))
(ev-dedupe-by-start (ev-sort-occs no-ex)))))))
;; ---- per-occurrence overrides (RFC 5545 RECURRENCE-ID) ----
;; A single instance of a recurring series can be detached and rescheduled. The
;; event carries :overrides — a list of (orig-start {:start :duration}) — keyed
;; by the occurrence's ORIGINAL start. Applied after EXDATE/RDATE. A moved
;; instance whose new start leaves the window is dropped from this window (the
;; original slot is vacated); an instance moved INTO the window from outside is
;; out of scope for a windowed expansion (known stub limitation).
(define
ev-assoc-lookup
(fn
(k pairs)
(cond
((empty? pairs) nil)
((= (first (first pairs)) k) (first (rest (first pairs))))
(else (ev-assoc-lookup k (rest pairs))))))
(define
ev-apply-overrides
(fn
(id base overrides)
(map
(fn
(o)
(let
((ov (ev-assoc-lookup (get o :start) overrides)))
(if (nil? ov) o (ev-occ id (get ov :start) (get ov :duration)))))
base)))
;; Add an override that reschedules the occurrence originally at `orig-start`
;; to `new-start` with `new-duration`.
(define
ev-with-override
(fn
(event orig-start new-start new-duration)
(assoc
event
:overrides
(cons
(list orig-start {:start new-start :duration new-duration})
(ev-or (get event :overrides) (list))))))
;; Naive (single time-domain) expansion: RRULE + EXDATE/RDATE + overrides.
(define
ev-expand-naive
(fn
(event win-start win-end)
(let
((excepted
(ev-apply-exceptions
event
(ev-expand-base event win-start win-end)
win-start
win-end))
(overrides (ev-or (get event :overrides) (list)))
(id (get event :id)))
(if
(empty? overrides)
excepted
(filter
(fn (o) (and (>= (get o :start) win-start) (<= (get o :start) win-end)))
(ev-sort-occs (ev-apply-overrides id excepted overrides)))))))
;; Public entry point. A tz-aware event (`:tz` set) expands in local wall-clock
;; time and converts each occurrence to UTC (ev-expand-tz, timezone.sx); a plain
;; event expands naively in a single time domain. The window is UTC either way.
(define
ev-expand
(fn
(event win-start win-end)
(let
((tz (get event :tz)))
(if
(nil? tz)
(ev-expand-naive event win-start win-end)
(ev-expand-tz event tz win-start win-end)))))
;; ---- multi-event expansion (sorted by start) ----
;; Insertion of one occurrence into a start-ascending list.
(define
ev-occ-insert
(fn
(o sorted)
(cond
((empty? sorted) (list o))
((<= (get o :start) (get (first sorted) :start)) (cons o sorted))
(else (cons (first sorted) (ev-occ-insert o (rest sorted)))))))
(define
ev-sort-occs
(fn (occs) (reduce (fn (acc o) (ev-occ-insert o acc)) (list) occs)))
;; Expand many events into one occurrence list, ascending by start.
(define
ev-expand-all
(fn
(events win-start win-end)
(let
((acc (list)))
(begin
(for-each
(fn
(ev)
(for-each
(fn (o) (append! acc o))
(ev-expand ev win-start win-end)))
events)
(ev-sort-occs acc)))))

63
lib/events/conformance.conf
View File

@@ -1,63 +0,0 @@
# events-on-sx conformance config — sourced by lib/guest/conformance.sh.
LANG_NAME=events
MODE=dict
SCOREBOARD_DIR=lib/events
PRELOADS=(
spec/stdlib.sx
lib/r7rs.sx
lib/datalog/tokenizer.sx
lib/datalog/parser.sx
lib/datalog/unify.sx
lib/datalog/db.sx
lib/datalog/builtins.sx
lib/datalog/aggregates.sx
lib/datalog/strata.sx
lib/datalog/eval.sx
lib/datalog/api.sx
lib/datalog/magic.sx
lib/events/calendar.sx
lib/events/timezone.sx
lib/events/ical.sx
lib/events/availability.sx
lib/persist/event.sx
lib/persist/backend.sx
lib/persist/log.sx
lib/persist/kv.sx
lib/persist/concurrency.sx
lib/persist/api.sx
lib/events/booking.sx
lib/events/booking-notify.sx
lib/events/ticket.sx
lib/guest/lex.sx
lib/guest/reflective/env.sx
lib/guest/reflective/quoting.sx
lib/scheme/parser.sx
lib/scheme/eval.sx
lib/scheme/runtime.sx
lib/flow/spec.sx
lib/flow/store.sx
lib/flow/remote.sx
lib/flow/host.sx
lib/flow/api.sx
lib/events/notify.sx
lib/events/api.sx
lib/events/reminders.sx
lib/events/federation.sx
)
SUITES=(
"calendar:lib/events/tests/calendar.sx:(ev-calendar-tests-run!)"
"timezone:lib/events/tests/timezone.sx:(ev-timezone-tests-run!)"
"ical:lib/events/tests/ical.sx:(ev-ical-tests-run!)"
"availability:lib/events/tests/availability.sx:(ev-availability-tests-run!)"
"api:lib/events/tests/api.sx:(ev-api-tests-run!)"
"booking:lib/events/tests/booking.sx:(ev-booking-tests-run!)"
"booking-notify:lib/events/tests/booking-notify.sx:(ev-booking-notify-tests-run!)"
"ticket:lib/events/tests/ticket.sx:(ev-ticket-tests-run!)"
"notify:lib/events/tests/notify.sx:(ev-notify-tests-run!)"
"reminders:lib/events/tests/reminders.sx:(ev-reminders-tests-run!)"
"federation:lib/events/tests/federation.sx:(ev-federation-tests-run!)"
"integration:lib/events/tests/integration.sx:(ev-integration-tests-run!)"
)

3
lib/events/conformance.sh
View File

@@ -1,3 +0,0 @@
#!/usr/bin/env bash
# Thin wrapper — see lib/guest/conformance.sh and lib/events/conformance.conf.
exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@"

232
lib/events/federation.sx
View File

@@ -1,232 +0,0 @@
;; lib/events/federation.sx — cross-instance calendar federation (trust-gated).
;;
;; A peer is another events instance that publishes a schedule (an events
;; store). We merge a peer's agenda into ours ONLY if we trust it — trust is a
;; set of peer ids, re-checked on every merge, so revoking a peer takes effect
;; immediately. Merged occurrences carry :origin provenance (:local for ours, or
;; the peer id) so a consumer always knows where a slot came from.
;;
;; This is the trust-gated stub: peers publish plain schedules and we fold the
;; trusted ones into a single sorted agenda. Real transport (fed-sx / signed
;; fetch) slots in behind `ev/peer-agenda` without changing the merge.
;;
;; Federated FREE/BUSY follows the iCal model: a peer publishes BUSY intervals
;; for an actor (not event details — privacy-preserving), and we union local +
;; trusted-peer busy to answer "is this actor free?" across instances.
(define ev/peer (fn (id store) {:id id :busy (list) :store store}))
;; A peer that also publishes free/busy: `busy` is a list of
;; (actor ((start end) ...)) pairs.
(define ev/peer-with-busy (fn (id store busy) {:id id :busy busy :store store}))
(define ev/peer-id (fn (p) (get p :id)))
(define ev/peer-store (fn (p) (get p :store)))
(define ev/peer-busy-table (fn (p) (get p :busy)))
(define
ev-fed-member?
(fn
(x xs)
(cond
((empty? xs) false)
((= x (first xs)) true)
(else (ev-fed-member? x (rest xs))))))
;; Do we trust this peer id? (trust is a list of trusted peer ids.)
(define ev/trusts? (fn (trust peer-id) (ev-fed-member? peer-id trust)))
;; The trusted subset of a peer list.
(define
ev/trusted-peers
(fn
(peers trust)
(filter (fn (p) (ev/trusts? trust (ev/peer-id p))) peers)))
;; Tag occurrences with provenance.
(define ev-tag-origin (fn (occs origin) (map (fn (o) {:id (get o :id) :start (get o :start) :end (get o :end) :origin origin}) occs)))
;; A peer's agenda over [ws, we), tagged with the peer's id as :origin.
(define
ev/peer-agenda
(fn
(peer ws we)
(ev-tag-origin (ev/agenda (ev/peer-store peer) ws we) (ev/peer-id peer))))
;; ---- merge (sorted by start, then origin for ties) ----
(define
ev-fed-before?
(fn
(a c)
(cond
((< (get a :start) (get c :start)) true)
((> (get a :start) (get c :start)) false)
(else (< (str (get a :origin)) (str (get c :origin)))))))
(define
ev-fed-insert
(fn
(x sorted)
(cond
((empty? sorted) (list x))
((ev-fed-before? x (first sorted)) (cons x sorted))
(else (cons (first sorted) (ev-fed-insert x (rest sorted)))))))
(define
ev-fed-sort
(fn (xs) (reduce (fn (acc x) (ev-fed-insert x acc)) (list) xs)))
;; Local agenda (origin :local) merged with every TRUSTED peer's agenda,
;; sorted by start. Untrusted peers contribute nothing.
(define
ev/federated-agenda
(fn
(local-store peers trust ws we)
(let
((acc (list)))
(begin
(for-each
(fn (o) (append! acc o))
(ev-tag-origin (ev/agenda local-store ws we) :local))
(for-each
(fn
(peer)
(when
(ev/trusts? trust (ev/peer-id peer))
(for-each
(fn (o) (append! acc o))
(ev/peer-agenda peer ws we))))
peers)
(ev-fed-sort acc)))))
;; Filter a federated agenda to occurrences from one origin.
(define
ev/from-origin
(fn
(agenda origin)
(filter (fn (o) (= (get o :origin) origin)) agenda)))
;; ---- federated free/busy ----
;; A peer's published busy intervals for `actor` ((start end) ...), or empty.
(define
ev/peer-busy
(fn
(peer actor)
(let
((row (ev-fed-assoc actor (ev/peer-busy-table peer))))
(if (nil? row) (list) (first (rest row))))))
(define
ev-fed-assoc
(fn
(k pairs)
(cond
((empty? pairs) nil)
((= (first (first pairs)) k) (first pairs))
(else (ev-fed-assoc k (rest pairs))))))
;; All busy intervals for `actor` across the LOCAL availability db plus every
;; TRUSTED peer's published free/busy, merged and sorted by start.
;; `local-db` is an availability db (see availability.sx ev-build-avail).
(define
ev/federated-busy
(fn
(local-db peers trust actor)
(let
((acc (list)))
(begin
(for-each (fn (iv) (append! acc iv)) (ev-busy local-db actor))
(for-each
(fn
(peer)
(when
(ev/trusts? trust (ev/peer-id peer))
(for-each
(fn (iv) (append! acc iv))
(ev/peer-busy peer actor))))
peers)
(ev-sort-lists acc)))))
;; Half-open overlap of interval (s e) with window [qs, qe).
(define
ev-fed-overlaps?
(fn (iv qs qe) (and (< (first iv) qe) (< qs (first (rest iv))))))
;; Is `actor` free across [qs, qe) considering local + trusted-peer busy?
(define
ev/federated-free?
(fn
(local-db peers trust actor qs qe)
(not
(some
(fn (iv) (ev-fed-overlaps? iv qs qe))
(ev/federated-busy local-db peers trust actor)))))
;; ---- injected transport (real fed-sx / signed fetch) ----
;; The in-process merge above expands a peer's local :store directly. In
;; production a peer's agenda arrives over a transport. `fetch` abstracts that:
;; (fetch peer-id ws we) -> {:status :ok :occurrences (...)} | {:status :error :reason ...}
;; The same merge works for any transport; an unreachable peer (:error) is
;; skipped (graceful degradation), never breaking the agenda.
(define
ev-find-peer
(fn
(peers pid)
(cond
((empty? peers) nil)
((= (ev/peer-id (first peers)) pid) (first peers))
(else (ev-find-peer (rest peers) pid)))))
;; In-process transport adapter: resolves a peer-id against a peer list and
;; expands its :store. Lets the in-process model run through the same `fetch`
;; interface a remote transport implements.
(define
ev/peer-fetch
(fn
(peers)
(fn
(pid ws we)
(let
((p (ev-find-peer peers pid)))
(if
(nil? p)
{:status :error :reason :unknown-peer}
{:status :ok :occurrences (ev/agenda (ev/peer-store p) ws we)})))))
;; Local agenda (:local) merged with each trusted peer's agenda fetched via the
;; injected `fetch` transport, sorted by start, tagged with :origin. Peers that
;; fail to fetch contribute nothing.
(define
ev/federated-agenda-via
(fn
(local-store trusted-ids ws we fetch)
(let
((acc (list)))
(begin
(for-each
(fn (o) (append! acc o))
(ev-tag-origin (ev/agenda local-store ws we) :local))
(for-each
(fn
(pid)
(let
((res (fetch pid ws we)))
(when
(= (get res :status) :ok)
(for-each
(fn (o) (append! acc o))
(ev-tag-origin (get res :occurrences) pid)))))
trusted-ids)
(ev-fed-sort acc)))))
;; Reachability report: ((peer-id :ok|:error) ...) for the trusted peers.
(define
ev/federation-status
(fn
(trusted-ids ws we fetch)
(map
(fn (pid) (list pid (get (fetch pid ws we) :status)))
trusted-ids)))

191
lib/events/ical.sx
View File

@@ -1,191 +0,0 @@
;; lib/events/ical.sx — iCalendar (RFC 5545) export.
;;
;; Serializes events to VEVENT / VCALENDAR text so a rose-ash calendar can be
;; imported by any standard client (Google/Apple/Outlook). Datetimes are UTC
;; epoch-minutes, emitted as basic-format UTC stamps (YYYYMMDDTHHMM00Z). The
;; full RRULE / EXDATE / RDATE model maps directly to the standard properties.
;;
;; Export is line-oriented: `ev/event->ical-lines` returns the VEVENT as a list
;; of content lines (no folding/CRLF — easy to assert on); `ev/ical-render`
;; joins lines with CRLF, the on-the-wire format. Requires calendar.sx.
;; ---- formatting helpers ----
(define ev-ical-pad2 (fn (n) (if (< n 10) (str "0" n) (str n))))
(define
ev-ical-pad4
(fn
(n)
(cond
((< n 10) (str "000" n))
((< n 100) (str "00" n))
((< n 1000) (str "0" n))
(else (str n)))))
(define
ev-ical-nth
(fn
(xs i)
(if
(= i 0)
(first xs)
(ev-ical-nth (rest xs) (- i 1)))))
(define
ev-ical-join
(fn
(parts sep)
(if
(empty? parts)
""
(reduce (fn (acc p) (str acc sep p)) (first parts) (rest parts)))))
;; A UTC epoch-minute as an iCal basic-format UTC stamp.
(define
ev-ical-dt
(fn
(t)
(let
((civ (ev-dt->civil t)) (tod (ev-dt-tod t)))
(str
(ev-ical-pad4 (ev-civ-y civ))
(ev-ical-pad2 (ev-civ-m civ))
(ev-ical-pad2 (ev-civ-d civ))
"T"
(ev-ical-pad2 (quotient tod 60))
(ev-ical-pad2 (modulo tod 60))
"00Z"))))
;; A duration in minutes as an iCal DURATION value (PT#H#M).
(define
ev-ical-duration
(fn
(mins)
(let
((h (quotient mins 60)) (m (modulo mins 60)))
(cond
((and (> h 0) (> m 0)) (str "PT" h "H" m "M"))
((> h 0) (str "PT" h "H"))
(else (str "PT" m "M"))))))
(define
ev-ical-wd
(fn (w) (ev-ical-nth (list "MO" "TU" "WE" "TH" "FR" "SA" "SU") w)))
(define
ev-ical-freq
(fn
(f)
(cond
((= f :daily) "DAILY")
((= f :weekly) "WEEKLY")
((= f :monthly) "MONTHLY")
(else "DAILY"))))
;; One BYDAY token: a weekly weekday number -> "MO"; a monthly ordinal weekday
;; {:ord :wd} -> "2TU" / "-1FR".
(define
ev-ical-byday-token
(fn
(e)
(if
(dict? e)
(str (get e :ord) (ev-ical-wd (get e :wd)))
(ev-ical-wd e))))
;; ---- RRULE ----
(define
ev-ical-rrule
(fn
(rrule)
(let
((parts (list (str "FREQ=" (ev-ical-freq (get rrule :freq))))))
(begin
(when
(and
(not (nil? (get rrule :interval)))
(> (get rrule :interval) 1))
(append! parts (str "INTERVAL=" (get rrule :interval))))
(when
(not (nil? (get rrule :count)))
(append! parts (str "COUNT=" (get rrule :count))))
(when
(not (nil? (get rrule :until)))
(append! parts (str "UNTIL=" (ev-ical-dt (get rrule :until)))))
(when
(not (nil? (get rrule :byday)))
(append!
parts
(str
"BYDAY="
(ev-ical-join (map ev-ical-byday-token (get rrule :byday)) ","))))
(when
(not (nil? (get rrule :bymonthday)))
(append!
parts
(str
"BYMONTHDAY="
(ev-ical-join
(map (fn (d) (str d)) (get rrule :bymonthday))
","))))
(str "RRULE:" (ev-ical-join parts ";"))))))
;; ---- VEVENT / VCALENDAR ----
;; The VEVENT content lines for an event (list of strings).
(define
ev/event->ical-lines
(fn
(event)
(let
((lines (list "BEGIN:VEVENT")))
(begin
(append! lines (str "UID:" (get event :id)))
(append! lines (str "SUMMARY:" (get event :id)))
(append! lines (str "DTSTART:" (ev-ical-dt (get event :dtstart))))
(append!
lines
(str "DURATION:" (ev-ical-duration (get event :duration))))
(when
(not (nil? (get event :rrule)))
(append! lines (ev-ical-rrule (get event :rrule))))
(when
(and
(not (nil? (get event :exdate)))
(> (len (get event :exdate)) 0))
(append!
lines
(str
"EXDATE:"
(ev-ical-join (map ev-ical-dt (get event :exdate)) ","))))
(when
(and
(not (nil? (get event :rdate)))
(> (len (get event :rdate)) 0))
(append!
lines
(str
"RDATE:"
(ev-ical-join (map ev-ical-dt (get event :rdate)) ","))))
(append! lines "END:VEVENT")
lines))))
;; A full VCALENDAR (list of content lines) wrapping every event.
(define
ev/events->ical-lines
(fn
(events)
(let
((lines (list "BEGIN:VCALENDAR" "VERSION:2.0" "PRODID:-//rose-ash//events-on-sx//EN")))
(begin
(for-each
(fn
(ev)
(for-each (fn (l) (append! lines l)) (ev/event->ical-lines ev)))
events)
(append! lines "END:VCALENDAR")
lines))))
;; Render content lines to the on-the-wire iCalendar text (CRLF-separated).
(define ev/ical-render (fn (lines) (ev-ical-join lines "\r\n")))

97
lib/events/notify.sx
View File

@@ -1,97 +0,0 @@
;; lib/events/notify.sx — durable notification delivery flows over an injected
;; transport (lib/flow).
;;
;; Reminders and digests are durable `flow`s: a flow `request`s delivery (a
;; suspend point), the HOST performs the actual send via an injected `dispatch`
;; (the transport — email/push/etc.), and resumes the flow with the outcome.
;; Because flow uses deterministic replay, a completed delivery is never re-run
;; on recovery; the host owns IO and persistence.
;;
;; Delivery is AT-LEAST-ONCE with idempotency. Each message carries an id (the
;; idempotency key). Two protections stop double-delivery:
;; 1. The transport dedups by id — a re-send of a delivered id is a no-op
;; that still reports ok, so a retry never produces two pings.
;; 2. flow's replay log records each resolved request, so recovery replays the
;; logged outcome instead of re-issuing the send.
;;
;; Retry/backoff rides flow suspend/resume: each attempt issues a request with a
;; DISTINCT tag `(deliver <id> <n>)` — distinct tags keep deterministic replay
;; correct across retries. The dispatch returns (ok info) to finish or
;; (retry reason) to try again, bounded by `maxn` (then (failed id reason)).
;;
;; A message is a 3-element list (id recipient body). The transport is generic
;; and injected — when feed/notify lands, both consumers share one transport,
;; so this delivery core is a candidate for extraction to `delivery-on-sx`.
;;
;; The Scheme flow source below loads into a flow env (see lib/flow/api.sx).
;; `ev/notify-run` prepends it to a caller program and evaluates in the shared
;; flow env.
(define
ev-notify-flows-src
"(define (ev-msg-id m) (car m))\n (define (ev-msg-recipient m) (car (cdr m)))\n (define (ev-msg-body m) (car (cdr (cdr m))))\n (define (ev-mem x xs)\n (if (null? xs) #f (if (equal? x (car xs)) #t (ev-mem x (cdr xs)))))\n (define (ev-notify-attempt m n maxn)\n (let ((r (request (list (quote deliver) (ev-msg-id m) n) m)))\n (if (eq? (car r) (quote ok))\n (list (quote delivered) (ev-msg-id m) n)\n (if (>= n maxn)\n (list (quote failed) (ev-msg-id m) (car (cdr r)))\n (ev-notify-attempt m (+ n 1) maxn)))))\n (define (ev-deliver-reminder maxn)\n (flow-node (lambda (m) (ev-notify-attempt m 1 maxn))))\n (define (ev-digest-step ms maxn)\n (if (null? ms)\n (list)\n (cons (ev-notify-attempt (car ms) 1 maxn)\n (ev-digest-step (cdr ms) maxn))))\n (define (ev-deliver-digest maxn)\n (flow-node (lambda (ms) (ev-digest-step ms maxn))))")
;; Run a Scheme flow program with the notify flows preloaded, in the shared
;; flow env. Returns the program's value (SX-native).
(define
ev/notify-run
(fn (prog) (flow-run (str ev-notify-flows-src "\n" prog))))
;; ---- end-to-end delivery: SX messages -> the notify flow ----
;; Bridges the SX notification-derivation modules (reminders / booking-notify /
;; reschedule) to the durable delivery flow. An SX message (id recipient body)
;; is serialized to s-expression text and spliced into the Scheme program as
;; quoted data, then the digest flow delivers the batch over an injected
;; transport. Strings round-trip through the guest Scheme as {:scm-string ...}
;; boxes; results are unboxed back to plain SX.
;; A default transport (Scheme source): always reports delivered.
(define ev-notify-ok-transport "(lambda (k p) (list (quote ok) (quote sent)))")
(define
ev-notify-join
(fn
(parts sep)
(if
(empty? parts)
""
(reduce (fn (acc p) (str acc sep p)) (first parts) (rest parts)))))
(define ev-msg->quoted (fn (m) (str "(quote " (serialize m) ")")))
(define
ev-msgs->scheme
(fn
(msgs)
(str "(list " (ev-notify-join (map ev-msg->quoted msgs) " ") ")")))
(define
ev-unbox-str
(fn
(x)
(if (and (dict? x) (has-key? x :scm-string)) (get x :scm-string) x)))
(define
ev-unbox-result
(fn (r) (map (fn (item) (map ev-unbox-str item)) r)))
;; Deliver a list of SX messages through the digest flow over `transport-src`
;; (a Scheme (kind payload) -> (ok ..)|(retry reason) lambda source). `maxn`
;; bounds retries per message, `maxticks` bounds host service ticks. Returns the
;; per-message outcomes unboxed: (("delivered"|"failed" <id> <n-or-reason>) ...)
(define
ev/deliver-messages
(fn
(msgs transport-src maxn maxticks)
(ev-unbox-result
(ev/notify-run
(str
"(define msgs "
(ev-msgs->scheme msgs)
") (if (null? msgs) (list) (let ((s (flow/start (ev-deliver-digest "
maxn
") msgs))) (begin (flow-run-host "
transport-src
" "
maxticks
") (flow/result (car (cdr s))))))")))))

147
lib/events/reminders.sx
View File

@@ -1,147 +0,0 @@
;; lib/events/reminders.sx — derive reminder + digest messages from the agenda.
;;
;; Bridges the schedule (calendar) and the durable roster (booking on persist)
;; to the notification layer (notify.sx). For each booked attendee of each
;; upcoming occurrence we derive a reminder message that fires `lead` minutes
;; before the occurrence starts. Each message has a deterministic idempotency
;; key — occ-key / recipient / lead — so re-deriving over an overlapping window
;; never produces a duplicate ping (the notify transport dedups on this id).
;;
;; A reminder is a dict:
;; {:id :recipient :event :start :fire-at}
;; `ev/reminder->msg` projects it to notify's (id recipient body) wire shape.
;; Reminders for one occurrence: one per booked attendee (durable roster).
(define
ev/occurrence-reminders
(fn
(b occ lead)
(let
((occ-key (ev-occ-key occ))
(start (get occ :start))
(evid (get occ :id)))
(map (fn (actor) {:id (str occ-key "/" actor "/" lead) :event evid :start start :fire-at (- start lead) :recipient actor}) (ev/roster-occ b occ)))))
;; Insertion sort of reminder dicts ascending by :fire-at (then :id for ties).
(define
ev-rem-before?
(fn
(a c)
(cond
((< (get a :fire-at) (get c :fire-at)) true)
((> (get a :fire-at) (get c :fire-at)) false)
(else (< (get a :id) (get c :id))))))
(define
ev-rem-insert
(fn
(r sorted)
(cond
((empty? sorted) (list r))
((ev-rem-before? r (first sorted)) (cons r sorted))
(else (cons (first sorted) (ev-rem-insert r (rest sorted)))))))
(define
ev-rem-sort
(fn (rs) (reduce (fn (acc r) (ev-rem-insert r acc)) (list) rs)))
;; All reminders across the agenda in [ws, we), ascending by fire-at.
(define
ev/agenda-reminders
(fn
(b store ws we lead)
(let
((acc (list)))
(begin
(for-each
(fn
(occ)
(for-each
(fn (r) (append! acc r))
(ev/occurrence-reminders b occ lead)))
(ev/agenda store ws we))
(ev-rem-sort acc)))))
;; Reminders whose fire-at has arrived (fire-at <= now) — what a scheduler
;; should hand to the notify transport at time `now`.
(define
ev/due-reminders
(fn
(reminders now)
(filter (fn (r) (<= (get r :fire-at) now)) reminders)))
;; Project a reminder to notify's (id recipient body) wire shape.
(define
ev/reminder->msg
(fn
(r)
(list
(get r :id)
(get r :recipient)
(list :reminder (get r :event) (get r :start)))))
;; ---- digests ----
;; The occurrences `actor` is booked into (durable roster), within window.
(define
ev/agenda-for-p
(fn
(b store actor ws we)
(filter
(fn (occ) (ev-bk-member? actor (ev/roster-occ b occ)))
(ev/agenda store ws we))))
;; A single digest message summarising an actor's upcoming booked occurrences.
;; :items is ({:event :start} ...); empty when the actor has nothing booked.
(define ev/agenda-digest (fn (b store actor ws we) {:items (map (fn (occ) {:event (get occ :id) :start (get occ :start)}) (ev/agenda-for-p b store actor ws we)) :id (str actor "/digest/" ws "-" we) :recipient actor}))
;; ---- reschedule notifications ----
;; When an event carries per-occurrence overrides (ev-with-override), every
;; attendee booked at the ORIGINAL start should be told the new time. Bookings
;; were made against the original occ-key (id@orig-start), so we read that
;; roster. Idempotency key encodes the original key and the new start, so
;; re-deriving the same reschedule never double-notifies.
(define
ev/reschedule-notifications
(fn
(b event)
(let
((overrides (ev-or (get event :overrides) (list)))
(evid (get event :id))
(dur (get event :duration)))
(reduce
(fn
(acc entry)
(let
((orig-start (first entry))
(ov (first (rest entry))))
(let
((occ (ev-occ evid orig-start dur))
(new-start (get ov :start))
(new-duration (get ov :duration)))
(let
((key (ev-occ-key occ)))
(append
acc
(map
(fn
(actor)
{:id (str key "/reschedule/" new-start)
:recipient actor
:event evid
:old-start orig-start
:new-start new-start
:new-duration new-duration})
(ev/roster-occ b occ)))))))
(list)
overrides))))
;; Project a reschedule notification to notify's (id recipient body) shape.
(define
ev/reschedule-notify->msg
(fn
(r)
(list
(get r :id)
(get r :recipient)
(list :rescheduled (get r :event) (get r :old-start) (get r :new-start)))))

21
lib/events/scoreboard.json
View File

@@ -1,21 +0,0 @@
{
"lang": "events",
"total_passed": 341,
"total_failed": 0,
"total": 341,
"suites": [
{"name":"calendar","passed":51,"failed":0,"total":51},
{"name":"timezone","passed":17,"failed":0,"total":17},
{"name":"ical","passed":21,"failed":0,"total":21},
{"name":"availability","passed":22,"failed":0,"total":22},
{"name":"api","passed":41,"failed":0,"total":41},
{"name":"booking","passed":82,"failed":0,"total":82},
{"name":"booking-notify","passed":11,"failed":0,"total":11},
{"name":"ticket","passed":31,"failed":0,"total":31},
{"name":"notify","passed":7,"failed":0,"total":7},
{"name":"reminders","passed":21,"failed":0,"total":21},
{"name":"federation","passed":29,"failed":0,"total":29},
{"name":"integration","passed":8,"failed":0,"total":8}
],
"generated": "2026-06-07T15:20:08+00:00"
}

18
lib/events/scoreboard.md
View File

@@ -1,18 +0,0 @@
# events scoreboard
**341 / 341 passing** (0 failure(s)).
| Suite | Passed | Total | Status |
|-------|--------|-------|--------|
| calendar | 51 | 51 | ok |
| timezone | 17 | 17 | ok |
| ical | 21 | 21 | ok |
| availability | 22 | 22 | ok |
| api | 41 | 41 | ok |
| booking | 82 | 82 | ok |
| booking-notify | 11 | 11 | ok |
| ticket | 31 | 31 | ok |
| notify | 7 | 7 | ok |
| reminders | 21 | 21 | ok |
| federation | 29 | 29 | ok |
| integration | 8 | 8 | ok |

392
lib/events/tests/api.sx
View File

@@ -1,392 +0,0 @@
;; lib/events/tests/api.sx — public events facade (schedule/agenda/free/book).
(define ev-api-pass 0)
(define ev-api-fail 0)
(define ev-api-failures (list))
(define
ev-api-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-api-pass (+ ev-api-pass 1))
(do
(set! ev-api-fail (+ ev-api-fail 1))
(append!
ev-api-failures
(str name "\n expected: " expected "\n got: " got))))))
;; A store with a weekly yoga class (Mon+Wed 18:00, 60m, 4 occurrences).
(define
ev-api-store
(fn
()
(ev/schedule
(ev/empty)
(quote yoga)
(ev-dt 2026 6 1 18 0)
60
{:freq :weekly :count 4 :byday (list 0 2)}
20)))
(define
ev-api-run-all!
(fn
()
(let
((s0 (ev-api-store)))
(let
((occs (ev/agenda s0 (ev-date 2026 6 1) (ev-date 2026 7 1))))
(let
((s1 (ev/book (ev/book s0 (quote nia) (ev-occ-key (first occs))) (quote nia) (ev-occ-key (first (rest occs))))))
(do
(ev-api-check!
"agenda expands weekly class to four occurrences"
(map (fn (o) (ev-dt->civil (get o :start))) occs)
(list
(list 2026 6 1)
(list 2026 6 3)
(list 2026 6 8)
(list 2026 6 10)))
(ev-api-check!
"empty store has empty agenda"
(ev/agenda
(ev/empty)
(ev-date 2026 6 1)
(ev-date 2026 7 1))
(list))
(ev-api-check!
"max duration reflects scheduled events"
(ev/store-max-duration s0)
60)
(ev-api-check!
"max duration of empty store is zero"
(ev/store-max-duration (ev/empty))
0)
(ev-api-check!
"event-by-id finds the scheduled event"
(get (ev/event-by-id s0 (quote yoga)) :capacity)
20)
(ev-api-check!
"event-by-id is nil for unknown id"
(ev/event-by-id s0 (quote nope))
nil)
(ev-api-check!
"agenda-for lists only booked occurrences"
(map
(fn (o) (ev-dt->civil (get o :start)))
(ev/agenda-for
s1
(quote nia)
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
(list
(list 2026 6 1)
(list 2026 6 3)))
(ev-api-check!
"agenda-for empty for unbooked actor"
(ev/agenda-for
s1
(quote zed)
(ev-date 2026 6 1)
(ev-date 2026 7 1))
(list))
(ev-api-check!
"free? false during a booked occurrence"
(ev/free?
s1
(quote nia)
(ev-dt 2026 6 1 18 30)
(ev-dt 2026 6 1 19 0))
false)
(ev-api-check!
"free? true in an open window"
(ev/free?
s1
(quote nia)
(ev-dt 2026 6 1 9 0)
(ev-dt 2026 6 1 10 0))
true)
(ev-api-check!
"free? half-open at occurrence end"
(ev/free?
s1
(quote nia)
(ev-dt 2026 6 1 19 0)
(ev-dt 2026 6 1 20 0))
true)
(ev-api-check!
"free? true for an actor who booked nothing"
(ev/free?
s1
(quote zed)
(ev-dt 2026 6 1 18 0)
(ev-dt 2026 6 1 19 0))
true)
(ev-api-check!
"next-free skips the booked slot to the hour after"
(ev-dt-tod
(ev/next-free
s1
(quote nia)
(ev-dt
2026
6
1
18
0)
60
(ev-dt
2026
6
1
23
0)))
(* 19 60))
(ev-api-check!
"next-free returns `after` when already open"
(ev/next-free
s1
(quote nia)
(ev-dt 2026 6 1 9 0)
60
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 9 0))
(ev-api-check!
"no conflict among disjoint bookings"
(ev/has-conflict?
s1
(quote nia)
(ev-date 2026 6 1)
(ev-date 2026 7 1))
false)
(let
((sc (ev/book (ev/schedule s1 (quote talk) (ev-dt 2026 6 1 18 30) 60 nil 5) (quote nia) (ev-occ-key (ev-occ (quote talk) (ev-dt 2026 6 1 18 30) 60)))))
(ev-api-check!
"overlapping second booking creates a conflict"
(ev/has-conflict?
sc
(quote nia)
(ev-date 2026 6 1)
(ev-date 2026 7 1))
true))
(let
((b (persist/open)) (occ1 (first occs)))
(do
(let
((sp (ev/schedule (ev/empty) (quote clinic) (ev-dt 2026 6 5 9 0) 30 nil 2)))
(let
((occ (ev-occ (quote clinic) (ev-dt 2026 6 5 9 0) 30)))
(do
(ev-api-check!
"durable book returns booked"
(get (ev/book-occ! b sp (quote a) occ) :status)
:booked)
(ev/book-occ! b sp (quote c) occ)
(ev-api-check!
"durable book past capacity is full"
(get (ev/book-occ! b sp (quote d) occ) :status)
:full)
(ev-api-check!
"durable roster reflects persisted bookings"
(ev/roster-occ b occ)
(list (quote a) (quote c)))
(ev-api-check!
"durable seats-left honours capacity"
(ev/seats-left-occ b sp occ)
0)
(ev-api-check!
"persist free? false during a durable booking"
(ev/free-p?
b
sp
(quote a)
(ev-dt
2026
6
5
9
10)
(ev-dt
2026
6
5
9
20))
false)
(ev-api-check!
"persist free? true in an open window"
(ev/free-p?
b
sp
(quote a)
(ev-dt
2026
6
5
10
0)
(ev-dt
2026
6
5
10
30))
true)
(ev/cancel-occ! b sp (quote a) occ)
(ev-api-check!
"durable cancel frees a seat"
(ev/seats-left-occ b sp occ)
1)
(ev-api-check!
"persist free? true after cancellation"
(ev/free-p?
b
sp
(quote a)
(ev-dt
2026
6
5
9
10)
(ev-dt
2026
6
5
9
20))
true))))))))))))
;; ---- conflict-checked booking ----
(define
ev-api-cf-run-all!
(fn
()
(let
((b (persist/open))
(store
(ev/schedule
(ev/schedule
(ev/schedule (ev/empty) (quote a) (ev-dt 2026 6 1 9 0) 60 nil 10)
(quote bb)
(ev-dt 2026 6 1 9 30)
60
nil
10)
(quote c)
(ev-dt 2026 6 1 11 0)
60
nil
10)))
(let
((oa (ev-occ (quote a) (ev-dt 2026 6 1 9 0) 60))
(ob (ev-occ (quote bb) (ev-dt 2026 6 1 9 30) 60))
(oc (ev-occ (quote c) (ev-dt 2026 6 1 11 0) 60)))
(do
(ev-api-check!
"first checked booking succeeds"
(get (ev/book-checked! b store (quote nia) oa) :status)
:booked)
(ev-api-check!
"overlapping different-event booking is a time conflict"
(get (ev/book-checked! b store (quote nia) ob) :status)
:time-conflict)
(ev-api-check!
"the clashing booking did not land on the roster"
(ev/roster-occ b ob)
(list))
(ev-api-check!
"a non-overlapping booking is allowed"
(get (ev/book-checked! b store (quote nia) oc) :status)
:booked)
(ev-api-check!
"re-booking the same occurrence is idempotent, not a conflict"
(get (ev/book-checked! b store (quote nia) oa) :status)
:already)
;; a different actor is unaffected by nia's bookings
(ev-api-check!
"another actor may take the overlapping slot"
(get (ev/book-checked! b store (quote ola) ob) :status)
:booked)
(ev-api-check!
"would-time-conflict? predicate agrees"
(ev/would-time-conflict? b store (quote nia) ob)
true)
(ev-api-check!
"would-time-conflict? false for a free slot"
(ev/would-time-conflict? b store (quote zed) ob)
false))))))
;; ---- whole-series booking ----
(define
ev-api-sr-run-all!
(fn
()
(let
((b (persist/open))
(store
(ev/schedule
(ev/empty)
(quote yoga)
(ev-dt 2026 6 1 18 0)
60
{:freq :weekly :byday (list 0 2) :count 4}
20))
(ws (ev-date 2026 6 1))
(we (ev-date 2026 7 1)))
(do
(let
((res (ev/book-series! b store (quote nia) (quote yoga) ws we)))
(do
(ev-api-check! "series booking covers all four occurrences" (len res) 4)
(ev-api-check! "all occurrences booked" (ev/series-count res :booked) 4)
(ev-api-check!
"actor is now booked into the whole series"
(len (ev/series-booked b store (quote nia) (quote yoga) ws we))
4)))
;; re-booking the series is idempotent
(ev-api-check!
"re-booking the series is idempotent"
(ev/series-count (ev/book-series! b store (quote nia) (quote yoga) ws we) :already)
4)
;; cancel the whole series
(let
((res (ev/cancel-series! b store (quote nia) (quote yoga) ws we)))
(do
(ev-api-check! "series cancel reports four cancellations" (ev/series-count res :cancelled) 4)
(ev-api-check!
"actor booked into nothing after series cancel"
(len (ev/series-booked b store (quote nia) (quote yoga) ws we))
0)))
;; capacity interacts per-occurrence: fill one occurrence first
(let
((b2 (persist/open))
(s2
(ev/schedule (ev/empty) (quote clinic) (ev-dt 2026 6 1 9 0) 30 {:freq :daily :count 3} 1)))
(do
(ev/book-occ! b2 s2 (quote x) (ev-occ (quote clinic) (ev-dt 2026 6 2 9 0) 30))
(let
((res (ev/book-series! b2 s2 (quote nia) (quote clinic) (ev-date 2026 6 1) (ev-date 2026 6 10))))
(do
(ev-api-check! "series booking succeeds on free occurrences" (ev/series-count res :booked) 2)
(ev-api-check! "series booking hits :full where capacity is taken" (ev/series-count res :full) 1)))))
;; unknown event id
(ev-api-check!
"series booking an unknown event yields no results"
(ev/book-series! b store (quote nia) (quote nope) ws we)
(list))))))
(define
ev-api-tests-run!
(fn
()
(do
(set! ev-api-pass 0)
(set! ev-api-fail 0)
(set! ev-api-failures (list))
(ev-api-run-all!)
(ev-api-cf-run-all!)
(ev-api-sr-run-all!)
{:failures ev-api-failures :total (+ ev-api-pass ev-api-fail) :passed ev-api-pass :failed ev-api-fail})))

331
lib/events/tests/availability.sx
View File

@@ -1,331 +0,0 @@
;; lib/events/tests/availability.sx — free/busy + conflict rules on Datalog.
(define ev-av-pass 0)
(define ev-av-fail 0)
(define ev-av-failures (list))
(define
ev-av-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-av-pass (+ ev-av-pass 1))
(do
(set! ev-av-fail (+ ev-av-fail 1))
(append!
ev-av-failures
(str name "\n expected: " expected "\n got: " got))))))
;; Fixture: three occurrences on 2026-06-01.
;; standup 09:00–09:30 review 09:15–10:15 (overlaps standup)
;; lunch 12:00–13:00
(define
ev-av-occs
(fn
()
(list
(ev-occ
(quote standup)
(ev-dt 2026 6 1 9 0)
30)
(ev-occ
(quote review)
(ev-dt 2026 6 1 9 15)
60)
(ev-occ
(quote lunch)
(ev-dt 2026 6 1 12 0)
60))))
(define ev-av-key (fn (id start) (str id "@" start)))
;; alice: standup + review (overlap → conflict). bob: lunch only.
(define
ev-av-db
(fn
()
(ev-avail-db
(ev-av-occs)
(list
(list
(quote alice)
(ev-av-key
(quote standup)
(ev-dt 2026 6 1 9 0)))
(list
(quote alice)
(ev-av-key
(quote review)
(ev-dt 2026 6 1 9 15)))
(list
(quote bob)
(ev-av-key
(quote lunch)
(ev-dt 2026 6 1 12 0)))))))
;; Disjoint fixture for slot search: 09:00–10:00 then 10:30–11:30 (a 30m gap).
(define
ev-av-gap-db
(fn
()
(ev-avail-db
(list
(ev-occ
(quote a)
(ev-dt 2026 6 1 9 0)
60)
(ev-occ
(quote b)
(ev-dt 2026 6 1 10 30)
60))
(list
(list
(quote sam)
(ev-av-key
(quote a)
(ev-dt 2026 6 1 9 0)))
(list
(quote sam)
(ev-av-key
(quote b)
(ev-dt 2026 6 1 10 30)))))))
(define
ev-av-run-all!
(fn
()
(let
((db (ev-av-db)))
(do
(ev-av-check!
"busy lists alice committed intervals ascending"
(ev-busy db (quote alice))
(list
(list
(ev-dt 2026 6 1 9 0)
(ev-dt 2026 6 1 9 30))
(list
(ev-dt 2026 6 1 9 15)
(ev-dt 2026 6 1 10 15))))
(ev-av-check!
"busy lists bob single interval"
(ev-busy db (quote bob))
(list
(list
(ev-dt 2026 6 1 12 0)
(ev-dt 2026 6 1 13 0))))
(ev-av-check!
"busy empty for unknown actor"
(ev-busy db (quote carol))
(list))
(ev-av-check!
"alice has an overlap conflict"
(ev-has-conflict? db (quote alice))
true)
(ev-av-check!
"alice conflict reported once (canonical pair)"
(len (ev-conflicts db (quote alice)))
1)
(ev-av-check!
"bob has no conflict"
(ev-has-conflict? db (quote bob))
false)
(ev-av-check!
"non-overlapping bookings do not conflict"
(ev-has-conflict?
(ev-avail-db
(list
(ev-occ
(quote a)
(ev-dt
2026
6
1
9
0)
30)
(ev-occ
(quote b)
(ev-dt
2026
6
1
9
30)
30))
(list
(list
(quote dave)
(ev-av-key
(quote a)
(ev-dt
2026
6
1
9
0)))
(list
(quote dave)
(ev-av-key
(quote b)
(ev-dt
2026
6
1
9
30)))))
(quote dave))
false)
(ev-av-check!
"alice free in an empty window"
(ev-free?
db
(quote alice)
(ev-dt 2026 6 1 13 0)
(ev-dt 2026 6 1 14 0))
true)
(ev-av-check!
"alice not free overlapping a booking"
(ev-free?
db
(quote alice)
(ev-dt 2026 6 1 9 20)
(ev-dt 2026 6 1 9 40))
false)
(ev-av-check!
"free? is half-open at the trailing edge"
(ev-free?
db
(quote alice)
(ev-dt 2026 6 1 10 15)
(ev-dt 2026 6 1 11 0))
true)
(ev-av-check!
"free? is half-open at the leading edge"
(ev-free?
db
(quote bob)
(ev-dt 2026 6 1 11 0)
(ev-dt 2026 6 1 12 0))
true)
(ev-av-check!
"free? false when window straddles a booking edge"
(ev-free?
db
(quote bob)
(ev-dt 2026 6 1 11 0)
(ev-dt 2026 6 1 12 1))
false)
(ev-av-check!
"free? query leaves db reusable (no leaked qwindow)"
(do
(ev-free?
db
(quote alice)
(ev-dt 2026 6 1 9 0)
(ev-dt 2026 6 1 9 30))
(ev-busy db (quote bob)))
(list
(list
(ev-dt 2026 6 1 12 0)
(ev-dt 2026 6 1 13 0))))
(let
((gdb (ev-av-gap-db)))
(do
(ev-av-check!
"next-free finds the gap between bookings"
(ev-next-free
gdb
(quote sam)
(ev-dt 2026 6 1 9 0)
30
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 10 0))
(ev-av-check!
"next-free skips a gap too short for the duration"
(ev-next-free
gdb
(quote sam)
(ev-dt 2026 6 1 9 0)
60
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 11 30))
(ev-av-check!
"next-free returns `after` when already free"
(ev-next-free
gdb
(quote sam)
(ev-dt 2026 6 1 14 0)
60
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 14 0))
(ev-av-check!
"next-free returns nil when nothing fits before horizon"
(ev-next-free
gdb
(quote sam)
(ev-dt 2026 6 1 9 0)
120
(ev-dt 2026 6 1 11 0))
nil)
(ev-av-check!
"next-free for actor with no bookings is `after`"
(ev-next-free
gdb
(quote nobody)
(ev-dt 2026 6 1 9 0)
60
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 9 0))
(ev-av-check!
"next-free at exact edge of a booking (half-open)"
(ev-next-free
gdb
(quote sam)
(ev-dt 2026 6 1 10 0)
30
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 10 0))))
(let
((daily (ev-expand (ev-event (quote class) (ev-dt 2026 6 1 9 0) 60 {:freq :daily :count 3} 1) (ev-date 2026 6 1) (ev-date 2026 7 1))))
(let
((db2 (ev-avail-db daily (map (fn (o) (list (quote sam) (ev-occ-key o))) daily))))
(do
(ev-av-check!
"expanded daily occurrences become busy intervals"
(len (ev-busy db2 (quote sam)))
3)
(ev-av-check!
"no conflicts among disjoint daily occurrences"
(ev-has-conflict? db2 (quote sam))
false)
(ev-av-check!
"busy on day two of the series"
(ev-free?
db2
(quote sam)
(ev-dt
2026
6
2
9
30)
(ev-dt
2026
6
2
9
45))
false))))))))
(define
ev-availability-tests-run!
(fn
()
(do
(set! ev-av-pass 0)
(set! ev-av-fail 0)
(set! ev-av-failures (list))
(ev-av-run-all!)
{:failures ev-av-failures :total (+ ev-av-pass ev-av-fail) :passed ev-av-pass :failed ev-av-fail})))

137
lib/events/tests/booking-notify.sx
View File

@@ -1,137 +0,0 @@
;; lib/events/tests/booking-notify.sx — lifecycle notifications from the stream.
(define ev-bn-pass 0)
(define ev-bn-fail 0)
(define ev-bn-failures (list))
(define
ev-bn-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-bn-pass (+ ev-bn-pass 1))
(do
(set! ev-bn-fail (+ ev-bn-fail 1))
(append!
ev-bn-failures
(str name "\n expected: " expected "\n got: " got))))))
(define
ev-bn-kinds
(fn
(notifs)
(map (fn (n) (list (get n :recipient) (get n :kind))) notifs)))
(define
ev-bn-run-all!
(fn
()
(do
(let
((b (persist/open)))
(do
(ev/book! b "o" 1 (quote a))
(ev/waitlist! b "o" 1 (quote x))
(ev/cancel-promote! b "o" 1 (quote a))
(let
((ns (ev/booking-notifications b "o" (quote yoga))))
(do
(ev-bn-check!
"lifecycle notifications in order"
(ev-bn-kinds ns)
(list
(list (quote a) :booked)
(list (quote x) :waitlisted)
(list (quote a) :cancelled)
(list (quote x) :promoted)))
(ev-bn-check!
"promotion targets the waitlisted actor"
(map
(fn (n) (get n :recipient))
(ev/notify-of-kind ns :promoted))
(list (quote x)))
(ev-bn-check!
"a fresh booking is not flagged as a promotion"
(len (ev/notify-of-kind ns :booked))
1)
(ev-bn-check!
"every notification carries the event label"
(get (first ns) :event)
(quote yoga))))))
(let
((b (persist/open)))
(do
(ev/hold! b "p" 3 (quote q))
(ev/confirm! b "p" (quote q))
(ev-bn-check!
"hold then confirm notifications"
(ev-bn-kinds (ev/booking-notifications b "p" (quote gig)))
(list (list (quote q) :held) (list (quote q) :confirmed)))))
(let
((b (persist/open)))
(do
(ev/hold! b "r" 1 (quote q))
(ev/release! b "r" (quote q))
(ev-bn-check!
"hold then release notifications"
(ev-bn-kinds (ev/booking-notifications b "r" (quote gig)))
(list (list (quote q) :held) (list (quote q) :released)))))
(let
((b (persist/open)))
(do
(ev/book! b "k" 5 (quote a))
(ev/book! b "k" 5 (quote c))
(let
((ns (ev/booking-notifications b "k" (quote talk))))
(do
(ev-bn-check!
"notification ids are occ-key/seq"
(map (fn (n) (get n :id)) ns)
(list "k/1" "k/2"))
(ev-bn-check!
"re-deriving yields identical ids (idempotent)"
(map
(fn (n) (get n :id))
(ev/booking-notifications b "k" (quote talk)))
(list "k/1" "k/2"))))))
(let
((b (persist/open)))
(do
(ev/book! b "w" 5 (quote a))
(ev-bn-check!
"notification projects to (id recipient body)"
(ev/booking-notify->msg
(first (ev/booking-notifications b "w" (quote talk))))
(list
"w/1"
(quote a)
(list :booking-event :booked (quote talk))))))
(let
((b (persist/open)))
(do
(ev/book! b "u" 1 (quote a))
(ev/waitlist! b "u" 1 (quote x))
(ev/leave-waitlist! b "u" (quote x))
(ev-bn-check!
"leaving the waitlist emits no notification"
(len
(ev/notify-of-kind
(ev/booking-notifications b "u" (quote e))
:left-waitlist))
0)
(ev-bn-check!
"unbooked occurrence has no notifications"
(ev/booking-notifications b "empty" (quote e))
(list)))))))
(define
ev-booking-notify-tests-run!
(fn
()
(do
(set! ev-bn-pass 0)
(set! ev-bn-fail 0)
(set! ev-bn-failures (list))
(ev-bn-run-all!)
{:failures ev-bn-failures :total (+ ev-bn-pass ev-bn-fail) :passed ev-bn-pass :failed ev-bn-fail})))

431
lib/events/tests/booking.sx
View File

@@ -1,431 +0,0 @@
;; lib/events/tests/booking.sx — capacity-safe booking, cancel, and holds.
(define ev-bk-pass 0)
(define ev-bk-fail 0)
(define ev-bk-failures (list))
(define
ev-bk-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-bk-pass (+ ev-bk-pass 1))
(do
(set! ev-bk-fail (+ ev-bk-fail 1))
(append!
ev-bk-failures
(str name "\n expected: " expected "\n got: " got))))))
;; Take a consistent (roster, last-seq) snapshot of an occurrence's stream.
(define ev-bk-snap (fn (b k) (ev-booked-actors b k)))
(define ev-bk-seq (fn (b k) (persist/last-seq b (ev-booking-stream k))))
(define
ev-bk-run-all!
(fn
()
(do
(let
((b (persist/open)))
(do
(ev-bk-check!
"first booking takes seat 1"
(get (ev/book! b "o1" 3 (quote a)) :seat)
1)
(ev-bk-check!
"second booking takes seat 2"
(get (ev/book! b "o1" 3 (quote c)) :seat)
2)
(ev-bk-check!
"booked status reported"
(get (ev/book! b "o1" 3 (quote d)) :status)
:booked)
(ev-bk-check!
"roster is oldest-first"
(ev/roster b "o1")
(list (quote a) (quote c) (quote d)))
(ev-bk-check!
"seats-left is zero when full"
(ev/seats-left b "o1" 3)
0)
(ev-bk-check!
"free booking is confirmed state"
(ev/seat-state b "o1" (quote a))
:confirmed)))
(let
((b (persist/open)))
(do
(ev/book! b "o2" 1 (quote a))
(ev-bk-check!
"booking past capacity is refused"
(get (ev/book! b "o2" 1 (quote c)) :status)
:full)
(ev-bk-check!
"full does not grow the roster"
(ev/roster b "o2")
(list (quote a)))
(ev-bk-check!
"seats-left zero at capacity"
(ev/seats-left b "o2" 1)
0)))
(let
((b (persist/open)))
(do
(ev/book! b "o3" 5 (quote a))
(ev-bk-check!
"re-booking the same actor is idempotent"
(get (ev/book! b "o3" 5 (quote a)) :status)
:already)
(ev-bk-check!
"idempotent re-book reports existing seat"
(get (ev/book! b "o3" 5 (quote a)) :seat)
1)
(ev-bk-check!
"roster unchanged after re-book"
(ev/roster b "o3")
(list (quote a)))
(ev-bk-check!
"count unchanged after re-book"
(ev-booking-count b "o3")
1)))
(let
((b (persist/open)))
(do
(ev/book! b "last" 2 (quote x))
(let
((snap (ev-bk-snap b "last")) (exp (ev-bk-seq b "last")))
(let
((ra (ev/book-with-observed b "last" 2 (quote a) snap exp))
(rb
(ev/book-with-observed
b
"last"
2
(quote bee)
snap
exp)))
(do
(ev-bk-check!
"race winner is booked"
(get ra :status)
:booked)
(ev-bk-check!
"race winner takes the last seat"
(get ra :seat)
2)
(ev-bk-check!
"race loser is rejected with a conflict"
(get rb :status)
:conflict)
(ev-bk-check!
"conflict reports the advanced seq"
(get rb :actual)
(+ exp 1))
(ev-bk-check!
"no overbooking: exactly two on roster"
(ev-booking-count b "last")
2)
(ev-bk-check!
"race loser is NOT on the roster"
(ev-bk-member? (quote bee) (ev/roster b "last"))
false)
(ev-bk-check!
"race loser retrying gets full"
(get (ev/book! b "last" 2 (quote bee)) :status)
:full))))))
(let
((b (persist/open)))
(do
(ev/book! b "room" 3 (quote x))
(let
((snap (ev-bk-snap b "room")) (exp (ev-bk-seq b "room")))
(let
((ra (ev/book-with-observed b "room" 3 (quote a) snap exp))
(rb
(ev/book-with-observed
b
"room"
3
(quote bee)
snap
exp)))
(do
(ev-bk-check!
"room winner booked seat 2"
(get ra :seat)
2)
(ev-bk-check!
"room loser first conflicts"
(get rb :status)
:conflict)
(ev-bk-check!
"room loser retry books seat 3"
(get (ev/book! b "room" 3 (quote bee)) :seat)
3)
(ev-bk-check!
"room roster is x,a,bee"
(ev/roster b "room")
(list (quote x) (quote a) (quote bee)))
(ev-bk-check!
"room is now full"
(ev/seats-left b "room" 3)
0))))))
(let
((b (persist/open)))
(do
(ev/book! b "cx" 2 (quote a))
(ev/book! b "cx" 2 (quote c))
(ev-bk-check!
"occupied to capacity before cancel"
(ev/seats-left b "cx" 2)
0)
(ev-bk-check!
"booking when full (pre-cancel) is refused"
(get (ev/book! b "cx" 2 (quote d)) :status)
:full)
(ev-bk-check!
"cancel reports cancelled"
(get (ev/cancel! b "cx" (quote a)) :status)
:cancelled)
(ev-bk-check!
"cancel removes actor from roster"
(ev/roster b "cx")
(list (quote c)))
(ev-bk-check!
"cancel frees a seat"
(ev/seats-left b "cx" 2)
1)
(ev-bk-check!
"freed seat is bookable again"
(get (ev/book! b "cx" 2 (quote d)) :status)
:booked)
(ev-bk-check!
"roster after rebook is c,d"
(ev/roster b "cx")
(list (quote c) (quote d)))))
(let
((b (persist/open)))
(do
(ev/book! b "ce" 3 (quote a))
(ev-bk-check!
"cancelling an unbooked actor is a no-op"
(get (ev/cancel! b "ce" (quote z)) :status)
:not-booked)
(ev-bk-check!
"no-op cancel leaves roster intact"
(ev/roster b "ce")
(list (quote a)))
(ev/cancel! b "ce" (quote a))
(ev-bk-check!
"double cancel is not-booked the second time"
(get (ev/cancel! b "ce" (quote a)) :status)
:not-booked)
(ev-bk-check!
"empty roster after cancel"
(ev/roster b "ce")
(list))
(ev-bk-check!
"cancelled actor may re-book"
(get (ev/book! b "ce" 3 (quote a)) :status)
:booked)
(ev-bk-check!
"re-booked actor back on roster"
(ev/roster b "ce")
(list (quote a)))))
(let
((b (persist/open)))
(do
(ev/book! b "h" 2 (quote a))
(ev-bk-check!
"hold reports held"
(get (ev/hold! b "h" 2 (quote p)) :status)
:held)
(ev-bk-check!
"held seat is :held state"
(ev/seat-state b "h" (quote p))
:held)
(ev-bk-check!
"held actor is on the roster"
(ev/roster b "h")
(list (quote a) (quote p)))
(ev-bk-check!
"held seat blocks the last booking"
(get (ev/book! b "h" 2 (quote x)) :status)
:full)
(ev-bk-check!
"no seats left with one held"
(ev/seats-left b "h" 2)
0)))
(let
((b (persist/open)))
(do
(ev/hold! b "hc" 3 (quote p))
(ev-bk-check!
"confirm reports confirmed"
(get (ev/confirm! b "hc" (quote p)) :status)
:confirmed)
(ev-bk-check!
"confirmed seat is :confirmed state"
(ev/seat-state b "hc" (quote p))
:confirmed)
(ev-bk-check!
"re-confirm is already-confirmed"
(get (ev/confirm! b "hc" (quote p)) :status)
:already-confirmed)
(ev-bk-check!
"confirming a non-holder is not-held"
(get (ev/confirm! b "hc" (quote z)) :status)
:not-held)
(ev-bk-check!
"confirmed seat still occupies"
(ev/seats-left b "hc" 3)
2)))
(let
((b (persist/open)))
(do
(ev/book! b "hr" 2 (quote a))
(ev/hold! b "hr" 2 (quote p))
(ev-bk-check!
"full while hold pending"
(ev/seats-left b "hr" 2)
0)
(ev-bk-check!
"release reports released"
(get (ev/release! b "hr" (quote p)) :status)
:released)
(ev-bk-check!
"release frees the held seat"
(ev/seats-left b "hr" 2)
1)
(ev-bk-check!
"released actor off the roster"
(ev/roster b "hr")
(list (quote a)))
(ev-bk-check!
"freed seat bookable after release"
(get (ev/book! b "hr" 2 (quote x)) :status)
:booked)
(ev/hold! b "hr2" 1 (quote q))
(ev/confirm! b "hr2" (quote q))
(ev-bk-check!
"release on a confirmed seat is not-held"
(get (ev/release! b "hr2" (quote q)) :status)
:not-held)
(ev-bk-check!
"cancel frees a confirmed-from-hold seat"
(get (ev/cancel! b "hr2" (quote q)) :status)
:cancelled)))
(let
((b (persist/open)))
(do
(ev/book! b "hlast" 2 (quote x))
(let
((snap (ev-bk-snap b "hlast")) (exp (ev-bk-seq b "hlast")))
(let
((ra (ev/hold-with-observed b "hlast" 2 (quote p) snap exp))
(rb
(ev/hold-with-observed
b
"hlast"
2
(quote q)
snap
exp)))
(do
(ev-bk-check! "hold race winner held" (get ra :status) :held)
(ev-bk-check!
"hold race loser conflicts"
(get rb :status)
:conflict)
(ev-bk-check!
"no oversell via concurrent holds"
(ev-booking-count b "hlast")
2)
(ev-bk-check!
"hold loser retry gets full"
(get (ev/hold! b "hlast" 2 (quote q)) :status)
:full))))))
(let
((b (persist/open)))
(do
(ev/hold! b "hi" 4 (quote p))
(ev-bk-check!
"re-holding the same actor is idempotent"
(get (ev/hold! b "hi" 4 (quote p)) :status)
:already)
(ev-bk-check!
"hold idempotency keeps one seat"
(ev-booking-count b "hi")
1))))))
;; ---- waitlist ----
(define
ev-bk-wl-run-all!
(fn
()
(do
;; join the waitlist when full; book directly when a seat is free
(let
((b (persist/open)))
(do
(ev-bk-check! "waitlist! books when a seat is free" (get (ev/waitlist! b "w" 2 (quote a)) :status) :booked)
(ev-bk-check! "second booking still fits" (get (ev/waitlist! b "w" 2 (quote c)) :status) :booked)
(ev-bk-check! "third joins the waitlist when full" (get (ev/waitlist! b "w" 2 (quote x)) :status) :waitlisted)
(ev-bk-check! "fourth is next in line" (get (ev/waitlist! b "w" 2 (quote y)) :position) 2)
(ev-bk-check! "waitlist is FIFO" (ev/waitlist b "w") (list (quote x) (quote y)))
(ev-bk-check! "seats unaffected by waitlisting" (ev/roster b "w") (list (quote a) (quote c)))
(ev-bk-check! "waitlist-position reports a queued actor" (ev/waitlist-position b "w" (quote y)) 2)
(ev-bk-check! "waitlist-position 0 for a seated actor" (ev/waitlist-position b "w" (quote a)) 0)))
;; idempotency
(let
((b (persist/open)))
(do
(ev/waitlist! b "wi" 1 (quote a))
(ev/waitlist! b "wi" 1 (quote x))
(ev-bk-check! "re-joining as a seated actor is :already" (get (ev/waitlist! b "wi" 1 (quote a)) :status) :already)
(ev-bk-check! "re-joining the queue is :already-waiting" (get (ev/waitlist! b "wi" 1 (quote x)) :status) :already-waiting)
(ev-bk-check! "queue did not grow on re-join" (ev/waitlist b "wi") (list (quote x)))))
;; leaving the waitlist
(let
((b (persist/open)))
(do
(ev/waitlist! b "wl" 1 (quote a))
(ev/waitlist! b "wl" 1 (quote x))
(ev/waitlist! b "wl" 1 (quote y))
(ev-bk-check! "leave-waitlist reports left" (get (ev/leave-waitlist! b "wl" (quote x)) :status) :left)
(ev-bk-check! "leaving removes from the queue" (ev/waitlist b "wl") (list (quote y)))
(ev-bk-check! "leaving when not queued is not-waiting" (get (ev/leave-waitlist! b "wl" (quote z)) :status) :not-waiting)))
;; auto-promotion on cancel
(let
((b (persist/open)))
(do
(ev/waitlist! b "wp" 1 (quote a))
(ev/waitlist! b "wp" 1 (quote x))
(ev/waitlist! b "wp" 1 (quote y))
(let
((r (ev/cancel-promote! b "wp" 1 (quote a))))
(do
(ev-bk-check! "cancel-promote cancels the seat holder" (get r :status) :cancelled)
(ev-bk-check! "cancel-promote promotes the head of the queue" (get r :promoted) (quote x))))
(ev-bk-check! "promoted actor now holds the seat" (ev/roster b "wp") (list (quote x)))
(ev-bk-check! "promoted actor left the queue" (ev/waitlist b "wp") (list (quote y)))
(ev-bk-check! "promoted seat is confirmed" (ev/seat-state b "wp" (quote x)) :confirmed)
;; cancelling with an empty waitlist promotes nobody
(ev/leave-waitlist! b "wp" (quote y))
(let
((r2 (ev/cancel-promote! b "wp" 1 (quote x))))
(ev-bk-check! "cancel with empty waitlist promotes nobody" (get r2 :promoted) nil))
(ev-bk-check! "seat is free after the last cancel" (ev/seats-left b "wp" 1) 1))))))
(define
ev-booking-tests-run!
(fn
()
(do
(set! ev-bk-pass 0)
(set! ev-bk-fail 0)
(set! ev-bk-failures (list))
(ev-bk-run-all!)
(ev-bk-wl-run-all!)
{:failures ev-bk-failures :total (+ ev-bk-pass ev-bk-fail) :passed ev-bk-pass :failed ev-bk-fail})))

592
lib/events/tests/calendar.sx
View File

@@ -1,592 +0,0 @@
;; lib/events/tests/calendar.sx — civil date core + RRULE window expansion.
(define ev-cal-pass 0)
(define ev-cal-fail 0)
(define ev-cal-failures (list))
(define
ev-cal-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-cal-pass (+ ev-cal-pass 1))
(do
(set! ev-cal-fail (+ ev-cal-fail 1))
(append!
ev-cal-failures
(str name "\n expected: " expected "\n got: " got))))))
;; Project occurrences to (civil weekday) pairs for legible assertions.
(define
ev-cal-shape
(fn
(occs)
(map
(fn
(o)
(list (ev-dt->civil (get o :start)) (ev-dt-weekday (get o :start))))
occs)))
(define
ev-cal-starts
(fn (occs) (map (fn (o) (ev-dt->civil (get o :start))) occs)))
(define
ev-cal-run-all!
(fn
()
(do
(ev-cal-check!
"epoch day zero"
(ev-days-from-civil 1970 1 1)
0)
(ev-cal-check!
"y2k day number"
(ev-days-from-civil 2000 1 1)
10957)
(ev-cal-check!
"leap day round trip"
(ev-civil-from-days
(ev-days-from-civil 2024 2 29))
(list 2024 2 29))
(ev-cal-check!
"pre-epoch round trip"
(ev-civil-from-days
(ev-days-from-civil 1969 12 31))
(list 1969 12 31))
(ev-cal-check!
"epoch is thursday"
(ev-weekday-of-days 0)
3)
(ev-cal-check!
"2026-06-06 is saturday"
(ev-dt-weekday (ev-date 2026 6 6))
5)
(ev-cal-check!
"dt carries time of day"
(ev-dt-tod
(ev-dt 2026 6 1 9 30))
570)
(ev-cal-check!
"civil from dt"
(ev-dt->civil
(ev-dt 2026 12 25 8 0))
(list 2026 12 25))
(ev-cal-check!
"days in feb 2024 (leap)"
(ev-days-in-month 2024 2)
29)
(ev-cal-check!
"days in feb 2026"
(ev-days-in-month 2026 2)
28)
(ev-cal-check!
"add months wraps year"
(ev-add-months 2026 11 3)
(list 2027 2))
(ev-cal-check!
"add months within year"
(ev-add-months 2026 1 5)
(list 2026 6))
(let
((ev (ev-event (quote one) (ev-dt 2026 6 10 14 0) 60 nil 1)))
(do
(ev-cal-check!
"single inside window emits once"
(len
(ev-expand
ev
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
1)
(ev-cal-check!
"single before window omitted"
(len
(ev-expand
ev
(ev-date 2026 7 1)
(ev-date 2026 8 1)))
0)
(ev-cal-check!
"single after window omitted"
(len
(ev-expand
ev
(ev-date 2026 1 1)
(ev-date 2026 2 1)))
0)
(ev-cal-check!
"occurrence end is start plus duration"
(get
(first
(ev-expand
ev
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
:end)
(+
(ev-dt 2026 6 10 14 0)
60))))
(let
((daily (ev-event (quote d) (ev-dt 2026 6 1 9 0) 30 {:freq :daily :count 5} 1)))
(do
(ev-cal-check!
"daily count caps occurrences"
(ev-cal-starts
(ev-expand
daily
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
(list
(list 2026 6 1)
(list 2026 6 2)
(list 2026 6 3)
(list 2026 6 4)
(list 2026 6 5)))
(ev-cal-check!
"daily preserves time of day"
(ev-dt-tod
(get
(first
(ev-expand
daily
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
:start))
540)))
(let
((di (ev-event (quote di) (ev-dt 2026 6 1 0 0) 30 {:interval 3 :freq :daily :until (ev-date 2026 6 30)} 1)))
(ev-cal-check!
"daily interval 3 steps by three days"
(ev-cal-starts
(ev-expand
di
(ev-date 2026 6 1)
(ev-date 2026 6 13)))
(list
(list 2026 6 1)
(list 2026 6 4)
(list 2026 6 7)
(list 2026 6 10)
(list 2026 6 13))))
(let
((dc (ev-event (quote dc) (ev-dt 2026 6 1 0 0) 30 {:freq :daily :count 10} 1)))
(ev-cal-check!
"count is window-independent (clip middle)"
(ev-cal-starts
(ev-expand
dc
(ev-date 2026 6 5)
(ev-date 2026 6 8)))
(list
(list 2026 6 5)
(list 2026 6 6)
(list 2026 6 7)
(list 2026 6 8))))
(let
((dc2 (ev-event (quote dc2) (ev-dt 2026 6 1 0 0) 30 {:freq :daily :count 3} 1)))
(ev-cal-check!
"count exhausted before window yields nothing"
(len
(ev-expand
dc2
(ev-date 2026 6 10)
(ev-date 2026 6 20)))
0))
(let
((wk (ev-event (quote w) (ev-dt 2026 6 1 18 0) 90 {:freq :weekly :byday (list 0 2 4)} 1)))
(ev-cal-check!
"weekly byday mon/wed/fri first two weeks"
(ev-cal-shape
(ev-expand
wk
(ev-date 2026 6 1)
(ev-date 2026 6 13)))
(list
(list (list 2026 6 1) 0)
(list (list 2026 6 3) 2)
(list (list 2026 6 5) 4)
(list (list 2026 6 8) 0)
(list (list 2026 6 10) 2)
(list (list 2026 6 12) 4))))
(let
((wu (ev-event (quote wu) (ev-dt 2026 6 1 18 0) 90 {:freq :weekly :until (ev-dt 2026 6 10 23 0) :byday (list 0 2)} 1)))
(ev-cal-check!
"weekly until clips trailing occurrences"
(ev-cal-starts
(ev-expand
wu
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
(list
(list 2026 6 1)
(list 2026 6 3)
(list 2026 6 8)
(list 2026 6 10))))
(let
((wi (ev-event (quote wi) (ev-dt 2026 6 1 18 0) 90 {:interval 2 :freq :weekly :byday (list 0)} 1)))
(ev-cal-check!
"weekly interval 2 skips alternate weeks"
(ev-cal-starts
(ev-expand
wi
(ev-date 2026 6 1)
(ev-date 2026 7 6)))
(list
(list 2026 6 1)
(list 2026 6 15)
(list 2026 6 29))))
(let
((wd (ev-event (quote wd) (ev-dt 2026 6 3 12 0) 60 {:freq :weekly :count 3} 1)))
(ev-cal-check!
"weekly default byday is dtstart weekday"
(ev-cal-shape
(ev-expand
wd
(ev-date 2026 6 1)
(ev-date 2026 8 1)))
(list
(list (list 2026 6 3) 2)
(list (list 2026 6 10) 2)
(list (list 2026 6 17) 2))))
(let
((wc (ev-event (quote wc) (ev-dt 2026 6 1 18 0) 90 {:freq :weekly :count 10 :byday (list 0 2)} 1)))
(ev-cal-check!
"weekly count window-independent (clip middle)"
(ev-cal-starts
(ev-expand
wc
(ev-date 2026 6 15)
(ev-date 2026 7 5)))
(list
(list 2026 6 15)
(list 2026 6 17)
(list 2026 6 22)
(list 2026 6 24)
(list 2026 6 29)
(list 2026 7 1))))
(let
((wf (ev-event (quote wf) (ev-dt 2026 6 3 18 0) 90 {:freq :weekly :count 4 :byday (list 0 2 4)} 1)))
(ev-cal-check!
"first week skips byday earlier than dtstart"
(ev-cal-starts
(ev-expand
wf
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
(list
(list 2026 6 3)
(list 2026 6 5)
(list 2026 6 8)
(list 2026 6 10))))
(let
((md (ev-event (quote md) (ev-dt 2026 1 15 9 0) 60 {:bymonthday (list 15) :freq :monthly} 1)))
(do
(ev-cal-check!
"monthly bymonthday 15th"
(ev-cal-starts
(ev-expand
md
(ev-date 2026 1 1)
(ev-date 2026 4 1)))
(list
(list 2026 1 15)
(list 2026 2 15)
(list 2026 3 15)))
(ev-cal-check!
"monthly preserves time of day"
(ev-dt-tod
(get
(first
(ev-expand
md
(ev-date 2026 1 1)
(ev-date 2026 4 1)))
:start))
540)))
(let
((mm (ev-event (quote mm) (ev-dt 2026 1 1 9 0) 60 {:bymonthday (list 1 15) :freq :monthly :count 4} 1)))
(ev-cal-check!
"monthly multiple bymonthday sorted within month"
(ev-cal-starts
(ev-expand
mm
(ev-date 2026 1 1)
(ev-date 2026 12 1)))
(list
(list 2026 1 1)
(list 2026 1 15)
(list 2026 2 1)
(list 2026 2 15))))
(let
((ml (ev-event (quote ml) (ev-dt 2026 1 31 9 0) 60 {:bymonthday (list -1) :freq :monthly} 1)))
(ev-cal-check!
"monthly bymonthday -1 is last day"
(ev-cal-starts
(ev-expand
ml
(ev-date 2026 1 1)
(ev-date 2026 4 1)))
(list
(list 2026 1 31)
(list 2026 2 28)
(list 2026 3 31))))
(let
((mn (ev-event (quote mn) (ev-dt 2026 1 1 9 0) 60 {:freq :monthly :byday (list {:ord 2 :wd 1})} 1)))
(ev-cal-check!
"monthly 2nd tuesday"
(ev-cal-shape
(ev-expand
mn
(ev-date 2026 1 1)
(ev-date 2026 4 1)))
(list
(list (list 2026 1 13) 1)
(list (list 2026 2 10) 1)
(list (list 2026 3 10) 1))))
(let
((mz (ev-event (quote mz) (ev-dt 2026 1 1 9 0) 60 {:freq :monthly :byday (list {:ord -1 :wd 4})} 1)))
(ev-cal-check!
"monthly last friday"
(ev-cal-shape
(ev-expand
mz
(ev-date 2026 1 1)
(ev-date 2026 4 1)))
(list
(list (list 2026 1 30) 4)
(list (list 2026 2 27) 4)
(list (list 2026 3 27) 4))))
(let
((m31 (ev-event (quote m31) (ev-dt 2026 1 31 9 0) 60 {:freq :monthly :count 4} 1)))
(ev-cal-check!
"monthly default day-of-month skips short months"
(ev-cal-starts
(ev-expand
m31
(ev-date 2026 1 1)
(ev-date 2026 12 1)))
(list
(list 2026 1 31)
(list 2026 3 31)
(list 2026 5 31)
(list 2026 7 31))))
(let
((mi (ev-event (quote mi) (ev-dt 2026 1 10 9 0) 60 {:interval 3 :freq :monthly :count 3} 1)))
(ev-cal-check!
"monthly interval 3 steps by quarter"
(ev-cal-starts
(ev-expand
mi
(ev-date 2026 1 1)
(ev-date 2027 1 1)))
(list
(list 2026 1 10)
(list 2026 4 10)
(list 2026 7 10))))
(let
((mc (ev-event (quote mc) (ev-dt 2026 1 5 9 0) 60 {:freq :monthly :count 12} 1)))
(ev-cal-check!
"monthly count window-independent (clip middle)"
(ev-cal-starts
(ev-expand
mc
(ev-date 2026 4 1)
(ev-date 2026 6 30)))
(list
(list 2026 4 5)
(list 2026 5 5)
(list 2026 6 5))))
(let
((a (ev-event (quote a) (ev-dt 2026 6 2 10 0) 30 {:freq :daily :count 2} 1))
(b
(ev-event
(quote b)
(ev-dt 2026 6 1 9 0)
30
{:freq :daily :count 2}
1)))
(ev-cal-check!
"expand-all sorts merged occurrences by start"
(map
(fn (o) (list (get o :id) (ev-dt->civil (get o :start))))
(ev-expand-all
(list a b)
(ev-date 2026 6 1)
(ev-date 2026 7 1)))
(list
(list (quote b) (list 2026 6 1))
(list (quote b) (list 2026 6 2))
(list (quote a) (list 2026 6 2))
(list (quote a) (list 2026 6 3))))))))
;; ---- EXDATE / RDATE exceptions ----
(define
ev-cal-ex-run-all!
(fn
()
(do
;; EXDATE removes a matching occurrence from the recurrence
(let
((ex
(ev-event-full
(quote standup)
(ev-dt 2026 6 1 9 0)
30
{:freq :daily :count 5}
1
(list (ev-dt 2026 6 3 9 0))
(list))))
(ev-cal-check!
"EXDATE excludes the matching occurrence"
(ev-cal-starts (ev-expand ex (ev-date 2026 6 1) (ev-date 2026 7 1)))
(list (list 2026 6 1) (list 2026 6 2) (list 2026 6 4) (list 2026 6 5))))
;; EXDATE that matches nothing is a no-op
(let
((ex2
(ev-event-full
(quote s)
(ev-dt 2026 6 1 9 0)
30
{:freq :daily :count 3}
1
(list (ev-dt 2026 6 9 9 0))
(list))))
(ev-cal-check!
"EXDATE not matching any occurrence is a no-op"
(len (ev-expand ex2 (ev-date 2026 6 1) (ev-date 2026 7 1)))
3))
;; RDATE adds an explicit occurrence (within the window)
(let
((rd
(ev-event-full
(quote s)
(ev-dt 2026 6 1 9 0)
30
{:freq :daily :count 3}
1
(list)
(list (ev-dt 2026 6 10 9 0)))))
(do
(ev-cal-check!
"RDATE adds an explicit occurrence, sorted in"
(ev-cal-starts (ev-expand rd (ev-date 2026 6 1) (ev-date 2026 7 1)))
(list (list 2026 6 1) (list 2026 6 2) (list 2026 6 3) (list 2026 6 10)))
(ev-cal-check!
"RDATE outside the window is dropped"
(len (ev-expand rd (ev-date 2026 6 1) (ev-date 2026 6 5)))
3)))
;; RDATE coinciding with an rrule occurrence is de-duplicated
(let
((rdup
(ev-event-full
(quote s)
(ev-dt 2026 6 1 9 0)
30
{:freq :daily :count 3}
1
(list)
(list (ev-dt 2026 6 2 9 0)))))
(ev-cal-check!
"RDATE duplicating an occurrence does not double it"
(len (ev-expand rdup (ev-date 2026 6 1) (ev-date 2026 7 1)))
3))
;; EXDATE wins over RDATE for the same datetime
(let
((both
(ev-event-full
(quote s)
(ev-dt 2026 6 1 9 0)
30
{:freq :daily :count 3}
1
(list (ev-dt 2026 6 2 9 0))
(list (ev-dt 2026 6 2 9 0)))))
(ev-cal-check!
"EXDATE wins over RDATE and the rrule for the same date"
(ev-cal-starts (ev-expand both (ev-date 2026 6 1) (ev-date 2026 7 1)))
(list (list 2026 6 1) (list 2026 6 3))))
;; RDATE-only event (no rrule)
(let
((ronly
(ev-event-full
(quote s)
(ev-dt 2026 6 1 9 0)
30
nil
1
(list)
(list (ev-dt 2026 6 5 9 0) (ev-dt 2026 6 3 9 0)))))
(ev-cal-check!
"RDATE-only event yields dtstart plus the extra dates, sorted"
(ev-cal-starts (ev-expand ronly (ev-date 2026 6 1) (ev-date 2026 7 1)))
(list (list 2026 6 1) (list 2026 6 3) (list 2026 6 5))))
;; plain ev-event (no exception keys) is unaffected
(let
((plain (ev-event (quote p) (ev-dt 2026 6 1 9 0) 30 {:freq :daily :count 3} 1)))
(ev-cal-check!
"plain event without exceptions expands unchanged"
(len (ev-expand plain (ev-date 2026 6 1) (ev-date 2026 7 1)))
3)))))
;; ---- per-occurrence overrides (reschedule one instance) ----
(define
ev-cal-ov-run-all!
(fn
()
(let
((base (ev-event (quote standup) (ev-dt 2026 6 1 9 0) 30 {:freq :daily :count 4} 1)))
(do
;; reschedule one instance to a new time + duration
(let
((moved (ev-with-override base (ev-dt 2026 6 2 9 0) (ev-dt 2026 6 2 14 0) 45)))
(let
((occs (ev-expand moved (ev-date 2026 6 1) (ev-date 2026 6 5))))
(do
(ev-cal-check!
"override moves only the targeted instance"
(map (fn (o) (ev-dt-tod (get o :start))) occs)
(list 540 840 540 540))
(ev-cal-check!
"override applies the new duration"
(map (fn (o) (- (get o :end) (get o :start))) occs)
(list 30 45 30 30))
(ev-cal-check!
"override keeps the series length"
(len occs)
4))))
;; an instance moved out of the window vacates its slot
(let
((movedout (ev-with-override base (ev-dt 2026 6 2 9 0) (ev-dt 2026 6 20 9 0) 30)))
(ev-cal-check!
"instance moved out of window is dropped, slot vacated"
(ev-cal-starts (ev-expand movedout (ev-date 2026 6 1) (ev-date 2026 6 5)))
(list (list 2026 6 1) (list 2026 6 3) (list 2026 6 4))))
;; override for a non-existent original start is a no-op
(let
((noop (ev-with-override base (ev-dt 2026 6 9 9 0) (ev-dt 2026 6 9 14 0) 45)))
(ev-cal-check!
"override for a non-occurring start is a no-op"
(len (ev-expand noop (ev-date 2026 6 1) (ev-date 2026 6 5)))
4))
;; overrides re-sort the agenda when an instance moves earlier
(let
((early (ev-with-override base (ev-dt 2026 6 3 9 0) (ev-dt 2026 6 1 7 0) 30)))
(ev-cal-check!
"an instance moved earlier re-sorts into place"
(map (fn (o) (ev-dt-tod (get o :start))) (ev-expand early (ev-date 2026 6 1) (ev-date 2026 6 5)))
(list 420 540 540 540)))))))
(define
ev-calendar-tests-run!
(fn
()
(do
(set! ev-cal-pass 0)
(set! ev-cal-fail 0)
(set! ev-cal-failures (list))
(ev-cal-run-all!)
(ev-cal-ex-run-all!)
(ev-cal-ov-run-all!)
{:failures ev-cal-failures :total (+ ev-cal-pass ev-cal-fail) :passed ev-cal-pass :failed ev-cal-fail})))

289
lib/events/tests/federation.sx
View File

@@ -1,289 +0,0 @@
;; lib/events/tests/federation.sx — trust-gated cross-instance agenda merge.
(define ev-fd-pass 0)
(define ev-fd-fail 0)
(define ev-fd-failures (list))
(define
ev-fd-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-fd-pass (+ ev-fd-pass 1))
(do
(set! ev-fd-fail (+ ev-fd-fail 1))
(append!
ev-fd-failures
(str name "\n expected: " expected "\n got: " got))))))
;; Local schedule + two peers. Distinct start times make ordering legible.
(define
ev-fd-local
(fn
()
(ev/schedule
(ev/empty)
(quote yoga)
(ev-dt 2026 6 1 9 0)
60
nil
20)))
(define
ev-fd-berlin
(fn
()
(ev/peer
(quote berlin)
(ev/schedule
(ev/empty)
(quote meetup)
(ev-dt 2026 6 1 12 0)
90
nil
100))))
(define
ev-fd-paris
(fn
()
(ev/peer
(quote paris)
(ev/schedule
(ev/empty)
(quote salon)
(ev-dt 2026 6 1 15 0)
60
nil
30))))
(define
ev-fd-run-all!
(fn
()
(let
((local (ev-fd-local))
(peers (list (ev-fd-berlin) (ev-fd-paris)))
(ws (ev-date 2026 6 1))
(we (ev-date 2026 6 2)))
(do
(ev-fd-check!
"trusts a peer in the trust set"
(ev/trusts? (list (quote berlin)) (quote berlin))
true)
(ev-fd-check!
"does not trust a peer outside the set"
(ev/trusts? (list (quote berlin)) (quote paris))
false)
(ev-fd-check!
"trusted-peers filters to the trust set"
(map ev/peer-id (ev/trusted-peers peers (list (quote berlin))))
(list (quote berlin)))
(let
((fed (ev/federated-agenda local peers (list (quote berlin)) ws we)))
(do
(ev-fd-check!
"merge includes local + trusted peer only"
(map (fn (o) (list (get o :origin) (get o :id))) fed)
(list
(list :local (quote yoga))
(list (quote berlin) (quote meetup))))
(ev-fd-check!
"merge is sorted by start"
(map (fn (o) (get o :start)) fed)
(list
(ev-dt 2026 6 1 9 0)
(ev-dt 2026 6 1 12 0)))
(ev-fd-check!
"untrusted peer (paris) contributes nothing"
(len (ev/from-origin fed (quote paris)))
0)
(ev-fd-check!
"local occurrences tagged :local"
(map (fn (o) (get o :id)) (ev/from-origin fed :local))
(list (quote yoga)))
(ev-fd-check!
"peer occurrences tagged with the peer id"
(map
(fn (o) (get o :id))
(ev/from-origin fed (quote berlin)))
(list (quote meetup)))))
(let
((fed2 (ev/federated-agenda local peers (list (quote berlin) (quote paris)) ws we)))
(ev-fd-check!
"trusting both peers merges all three, sorted"
(map (fn (o) (list (get o :origin) (get o :id))) fed2)
(list
(list :local (quote yoga))
(list (quote berlin) (quote meetup))
(list (quote paris) (quote salon)))))
(let
((fed3 (ev/federated-agenda local peers (list) ws we)))
(do
(ev-fd-check!
"empty trust yields only local occurrences"
(map (fn (o) (get o :origin)) fed3)
(list :local))
(ev-fd-check!
"empty trust still includes local"
(len fed3)
1)))
(let
((rpeer (ev/peer (quote tokyo) (ev/schedule (ev/empty) (quote standup) (ev-dt 2026 6 1 8 0) 15 {:freq :daily :count 3} 5))))
(let
((pa (ev/peer-agenda rpeer ws (ev-date 2026 6 4))))
(do
(ev-fd-check!
"peer recurrence expands in the window"
(len pa)
3)
(ev-fd-check!
"every peer occurrence is tagged with the peer id"
(map (fn (o) (get o :origin)) pa)
(list (quote tokyo) (quote tokyo) (quote tokyo))))))))))
;; ---- federated free/busy ----
(define
ev-fd-fb-run-all!
(fn
()
(let
((local-db
(ev-avail-db
(list (ev-occ (quote yoga) (ev-dt 2026 6 1 9 0) 60))
(list (list (quote nia) (str (quote yoga) "@" (ev-dt 2026 6 1 9 0))))))
(berlin
(ev/peer-with-busy
(quote berlin)
(ev/empty)
(list
(list (quote nia)
(list (list (ev-dt 2026 6 1 14 0) (ev-dt 2026 6 1 15 0)))))))
(paris
(ev/peer-with-busy
(quote paris)
(ev/empty)
(list
(list (quote nia)
(list (list (ev-dt 2026 6 1 11 0) (ev-dt 2026 6 1 12 0))))))))
(let
((peers (list berlin paris)))
(do
;; peer-busy reads a peer's published intervals
(ev-fd-check!
"peer-busy returns published intervals for an actor"
(ev/peer-busy berlin (quote nia))
(list (list (ev-dt 2026 6 1 14 0) (ev-dt 2026 6 1 15 0))))
(ev-fd-check!
"peer-busy empty for an actor with nothing published"
(ev/peer-busy berlin (quote zed))
(list))
;; federated-busy unions local + trusted-peer busy, sorted
(ev-fd-check!
"federated-busy unions local + trusted peer, sorted"
(ev/federated-busy local-db (list berlin) (list (quote berlin)) (quote nia))
(list
(list (ev-dt 2026 6 1 9 0) (ev-dt 2026 6 1 10 0))
(list (ev-dt 2026 6 1 14 0) (ev-dt 2026 6 1 15 0))))
(ev-fd-check!
"untrusted peer busy is excluded from federated-busy"
(ev/federated-busy local-db peers (list (quote berlin)) (quote nia))
(list
(list (ev-dt 2026 6 1 9 0) (ev-dt 2026 6 1 10 0))
(list (ev-dt 2026 6 1 14 0) (ev-dt 2026 6 1 15 0))))
;; federated-free? considers both local and trusted-peer commitments
(ev-fd-check!
"free locally and on peers in an open window"
(ev/federated-free? local-db peers (list (quote berlin)) (quote nia) (ev-dt 2026 6 1 16 0) (ev-dt 2026 6 1 17 0))
true)
(ev-fd-check!
"not free during a LOCAL booking"
(ev/federated-free? local-db peers (list (quote berlin)) (quote nia) (ev-dt 2026 6 1 9 30) (ev-dt 2026 6 1 9 45))
false)
(ev-fd-check!
"not free during a TRUSTED PEER busy interval"
(ev/federated-free? local-db peers (list (quote berlin)) (quote nia) (ev-dt 2026 6 1 14 30) (ev-dt 2026 6 1 14 45))
false)
(ev-fd-check!
"free during an UNTRUSTED peer's busy interval (paris not trusted)"
(ev/federated-free? local-db peers (list (quote berlin)) (quote nia) (ev-dt 2026 6 1 11 15) (ev-dt 2026 6 1 11 45))
true)
(ev-fd-check!
"not free once paris is trusted too"
(ev/federated-free? local-db peers (list (quote berlin) (quote paris)) (quote nia) (ev-dt 2026 6 1 11 15) (ev-dt 2026 6 1 11 45))
false)
(ev-fd-check!
"federated-free? half-open at a busy edge"
(ev/federated-free? local-db peers (list (quote berlin)) (quote nia) (ev-dt 2026 6 1 15 0) (ev-dt 2026 6 1 16 0))
true))))))
;; ---- injected transport (fed-sx) ----
(define
ev-fd-tx-run-all!
(fn
()
(let
((local (ev/schedule (ev/empty) (quote yoga) (ev-dt 2026 6 1 9 0) 60 nil 20))
(berlin (ev/peer (quote berlin) (ev/schedule (ev/empty) (quote meetup) (ev-dt 2026 6 1 12 0) 90 nil 100)))
(ws (ev-date 2026 6 1))
(we (ev-date 2026 6 2)))
(let
((fetch (ev/peer-fetch (list berlin))))
(do
;; in-process adapter merges through the transport interface
(ev-fd-check!
"federated-agenda-via merges local + fetched peer"
(map (fn (o) (list (get o :origin) (get o :id)))
(ev/federated-agenda-via local (list (quote berlin)) ws we fetch))
(list (list :local (quote yoga)) (list (quote berlin) (quote meetup))))
;; an unreachable / unknown peer degrades gracefully
(ev-fd-check!
"an unreachable peer is skipped, agenda still served"
(map (fn (o) (get o :origin))
(ev/federated-agenda-via local (list (quote berlin) (quote ghost)) ws we fetch))
(list :local (quote berlin)))
;; reachability report
(ev-fd-check!
"federation-status reports per-peer reachability"
(ev/federation-status (list (quote berlin) (quote ghost)) ws we fetch)
(list (list (quote berlin) :ok) (list (quote ghost) :error)))
;; an explicit remote transport (returns occurrences directly)
(let
((remote-fetch
(fn
(pid rws rwe)
(if (= pid (quote tokyo))
{:status :ok
:occurrences (list (ev-occ (quote standup) (ev-dt 2026 6 1 8 0) 15))}
{:status :error :reason :unreachable}))))
(do
(ev-fd-check!
"a remote transport's occurrences merge with origin tags"
(map (fn (o) (list (get o :origin) (get o :id)))
(ev/federated-agenda-via local (list (quote tokyo)) ws we remote-fetch))
(list (list (quote tokyo) (quote standup)) (list :local (quote yoga))))
(ev-fd-check!
"remote transport error degrades to local only"
(map (fn (o) (get o :origin))
(ev/federated-agenda-via local (list (quote osaka)) ws we remote-fetch))
(list :local))))
;; no trusted peers -> only local
(ev-fd-check!
"no trusted peer ids yields only local"
(map (fn (o) (get o :origin))
(ev/federated-agenda-via local (list) ws we fetch))
(list :local)))))))
(define
ev-federation-tests-run!
(fn
()
(do
(set! ev-fd-pass 0)
(set! ev-fd-fail 0)
(set! ev-fd-failures (list))
(ev-fd-run-all!)
(ev-fd-fb-run-all!)
(ev-fd-tx-run-all!)
{:failures ev-fd-failures :total (+ ev-fd-pass ev-fd-fail) :passed ev-fd-pass :failed ev-fd-fail})))

192
lib/events/tests/ical.sx
View File

@@ -1,192 +0,0 @@
;; lib/events/tests/ical.sx — iCalendar (RFC 5545) export.
(define ev-ic-pass 0)
(define ev-ic-fail 0)
(define ev-ic-failures (list))
(define
ev-ic-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-ic-pass (+ ev-ic-pass 1))
(do
(set! ev-ic-fail (+ ev-ic-fail 1))
(append!
ev-ic-failures
(str name "\n expected: " expected "\n got: " got))))))
;; Find the value of a "KEY:value" line in a VEVENT line list (or nil).
(define
ev-ic-line
(fn
(lines key)
(cond
((empty? lines) nil)
((ev-ic-prefix? (first lines) (str key ":")) (first lines))
(else (ev-ic-line (rest lines) key)))))
(define
ev-ic-prefix?
(fn
(s p)
(and (>= (len s) (len p)) (= (substring s 0 (len p)) p))))
(define
ev-ic-run-all!
(fn
()
(do
(let
((lines (ev/event->ical-lines (ev-event (quote one) (ev-dt 2026 6 10 14 0) 60 nil 1))))
(do
(ev-ic-check! "VEVENT opens" (first lines) "BEGIN:VEVENT")
(ev-ic-check! "VEVENT closes" (ev-ic-line lines "END") "END:VEVENT")
(ev-ic-check!
"UID is the event id"
(ev-ic-line lines "UID")
"UID:one")
(ev-ic-check!
"DTSTART is a UTC basic-format stamp"
(ev-ic-line lines "DTSTART")
"DTSTART:20260610T140000Z")
(ev-ic-check!
"DURATION of 60m is PT1H"
(ev-ic-line lines "DURATION")
"DURATION:PT1H")
(ev-ic-check!
"a one-off event has no RRULE"
(ev-ic-line lines "RRULE")
nil)))
(ev-ic-check!
"30m duration is PT30M"
(ev-ic-line
(ev/event->ical-lines
(ev-event
(quote e)
(ev-dt 2026 1 1 9 0)
30
nil
1))
"DURATION")
"DURATION:PT30M")
(ev-ic-check!
"90m duration is PT1H30M"
(ev-ic-line
(ev/event->ical-lines
(ev-event
(quote e)
(ev-dt 2026 1 1 9 0)
90
nil
1))
"DURATION")
"DURATION:PT1H30M")
(let
((lines (ev/event->ical-lines (ev-event-full (quote yoga) (ev-dt 2026 6 1 18 0) 90 {:interval 2 :freq :weekly :until (ev-dt 2026 6 30 23 0) :byday (list 0 2)} 20 (list (ev-dt 2026 6 8 18 0)) (list (ev-dt 2026 6 20 18 0))))))
(do
(ev-ic-check!
"weekly RRULE serializes interval/until/byday in order"
(ev-ic-line lines "RRULE")
"RRULE:FREQ=WEEKLY;INTERVAL=2;UNTIL=20260630T230000Z;BYDAY=MO,WE")
(ev-ic-check!
"EXDATE line"
(ev-ic-line lines "EXDATE")
"EXDATE:20260608T180000Z")
(ev-ic-check!
"RDATE line"
(ev-ic-line lines "RDATE")
"RDATE:20260620T180000Z")))
(ev-ic-check!
"daily COUNT RRULE"
(ev-ic-line
(ev/event->ical-lines
(ev-event
(quote d)
(ev-dt 2026 6 1 9 0)
30
{:freq :daily :count 5}
1))
"RRULE")
"RRULE:FREQ=DAILY;COUNT=5")
(ev-ic-check!
"monthly nth-weekday BYDAY (2nd Tuesday)"
(ev-ic-line
(ev/event->ical-lines
(ev-event
(quote b)
(ev-dt 2026 1 13 9 0)
60
{:freq :monthly :byday (list {:ord 2 :wd 1})}
5))
"RRULE")
"RRULE:FREQ=MONTHLY;BYDAY=2TU")
(ev-ic-check!
"monthly last-Friday BYDAY"
(ev-ic-line
(ev/event->ical-lines
(ev-event
(quote b)
(ev-dt 2026 1 30 9 0)
60
{:freq :monthly :byday (list {:ord -1 :wd 4})}
5))
"RRULE")
"RRULE:FREQ=MONTHLY;BYDAY=-1FR")
(ev-ic-check!
"monthly BYMONTHDAY (incl. negative)"
(ev-ic-line
(ev/event->ical-lines
(ev-event
(quote b)
(ev-dt 2026 1 15 9 0)
60
{:bymonthday (list 15 -1) :freq :monthly}
5))
"RRULE")
"RRULE:FREQ=MONTHLY;BYMONTHDAY=15,-1")
(ev-ic-check!
"all seven weekday tokens map correctly"
(ev-ic-line
(ev/event->ical-lines
(ev-event
(quote w)
(ev-dt 2026 6 1 9 0)
30
{:freq :weekly :byday (list 0 1 2 3 4 5 6)}
1))
"RRULE")
"RRULE:FREQ=WEEKLY;BYDAY=MO,TU,WE,TH,FR,SA,SU")
(let
((cal (ev/events->ical-lines (list (ev-event (quote a) (ev-dt 2026 6 1 9 0) 30 nil 1) (ev-event (quote b) (ev-dt 2026 6 2 9 0) 30 nil 1)))))
(do
(ev-ic-check! "VCALENDAR opens" (first cal) "BEGIN:VCALENDAR")
(ev-ic-check!
"VCALENDAR declares VERSION"
(ev-ic-line cal "VERSION")
"VERSION:2.0")
(ev-ic-check!
"two events -> two VEVENT blocks"
(len (filter (fn (l) (= l "BEGIN:VEVENT")) cal))
2)
(ev-ic-check!
"VCALENDAR has exactly one closing line"
(len (filter (fn (l) (= l "END:VCALENDAR")) cal))
1)))
(ev-ic-check!
"render joins lines with CRLF"
(ev/ical-render
(list "BEGIN:VCALENDAR" "VERSION:2.0" "END:VCALENDAR"))
"BEGIN:VCALENDAR\r\nVERSION:2.0\r\nEND:VCALENDAR"))))
(define
ev-ical-tests-run!
(fn
()
(do
(set! ev-ic-pass 0)
(set! ev-ic-fail 0)
(set! ev-ic-failures (list))
(ev-ic-run-all!)
{:failures ev-ic-failures :total (+ ev-ic-pass ev-ic-fail) :passed ev-ic-pass :failed ev-ic-fail})))

144
lib/events/tests/integration.sx
View File

@@ -1,144 +0,0 @@
;; lib/events/tests/integration.sx — end-to-end pipeline: derive notification
;; messages (SX) -> deliver them through the durable notify flow (Scheme).
(define ev-it-pass 0)
(define ev-it-fail 0)
(define ev-it-failures (list))
(define
ev-it-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-it-pass (+ ev-it-pass 1))
(do
(set! ev-it-fail (+ ev-it-fail 1))
(append!
ev-it-failures
(str name "\n expected: " expected "\n got: " got))))))
(define ev-it-status (fn (outcome) (first outcome)))
(define ev-it-id (fn (outcome) (first (rest outcome))))
;; A store with a weekly class; nia + ola booked into the first occurrence.
(define
ev-it-setup
(fn
(b)
(let
((store (ev/schedule (ev/empty) (quote yoga) (ev-dt 2026 6 1 18 0) 60 {:freq :weekly :count 4 :byday (list 0 2)} 20)))
(let
((occ1 (ev-occ (quote yoga) (ev-dt 2026 6 1 18 0) 60)))
(do
(ev/book-occ! b store (quote nia) occ1)
(ev/book-occ! b store (quote ola) occ1)
store)))))
(define
ev-it-run-all!
(fn
()
(do
(let
((b (persist/open)))
(let
((store (ev-it-setup b)))
(let
((reminders (ev/agenda-reminders b store (ev-date 2026 6 1) (ev-date 2026 7 1) 60)))
(let
((msgs (map ev/reminder->msg reminders))
(outcomes
(ev/deliver-messages
(map ev/reminder->msg reminders)
ev-notify-ok-transport
3
20)))
(do
(ev-it-check!
"every booked attendee's reminder is delivered"
(map ev-it-status outcomes)
(list "delivered" "delivered"))
(ev-it-check!
"one delivery per derived reminder"
(len outcomes)
(len msgs))
(ev-it-check!
"delivered ids match the reminder idempotency keys"
(map ev-it-id outcomes)
(map (fn (r) (get r :id)) reminders)))))))
(let
((b (persist/open)))
(let
((store (ev-it-setup b)))
(let
((msgs (map ev/reminder->msg (ev/agenda-reminders b store (ev-date 2026 6 1) (ev-date 2026 7 1) 60))))
(ev-it-check!
"a permanently-failing transport reports failed deliveries"
(map
ev-it-status
(ev/deliver-messages
msgs
"(lambda (k p) (list (quote retry) (quote down)))"
2
20))
(list "failed" "failed")))))
(let
((b (persist/open)))
(do
(ev/book! b "occ" 1 (quote nia))
(ev/waitlist! b "occ" 1 (quote ola))
(ev/cancel-promote! b "occ" 1 (quote nia))
(let
((promoted (ev/notify-of-kind (ev/booking-notifications b "occ" (quote yoga)) :promoted)))
(let
((outcomes (ev/deliver-messages (map ev/booking-notify->msg promoted) ev-notify-ok-transport 3 12)))
(do
(ev-it-check!
"the waitlist-promotion notification is delivered"
(map ev-it-status outcomes)
(list "delivered"))
(ev-it-check!
"exactly one promotion was delivered"
(len outcomes)
1))))))
(let
((b (persist/open)))
(let
((ev (ev-event (quote yoga) (ev-dt 2026 6 1 18 0) 60 {:freq :daily :count 3} 20)))
(do
(ev/book-occ!
b
(ev/add-event (ev/empty) ev)
(quote nia)
(ev-occ
(quote yoga)
(ev-dt 2026 6 2 18 0)
60))
(let
((moved (ev-with-override ev (ev-dt 2026 6 2 18 0) (ev-dt 2026 6 2 20 0) 60)))
(let
((outcomes (ev/deliver-messages (map ev/reschedule-notify->msg (ev/reschedule-notifications b moved)) ev-notify-ok-transport 3 12)))
(ev-it-check!
"the reschedule notice is delivered to the booked attendee"
(map ev-it-status outcomes)
(list "delivered")))))))
(ev-it-check!
"delivering no messages yields no outcomes"
(ev/deliver-messages
(list)
ev-notify-ok-transport
3
12)
(list)))))
(define
ev-integration-tests-run!
(fn
()
(do
(set! ev-it-pass 0)
(set! ev-it-fail 0)
(set! ev-it-failures (list))
(ev-it-run-all!)
{:failures ev-it-failures :total (+ ev-it-pass ev-it-fail) :passed ev-it-pass :failed ev-it-fail})))

77
lib/events/tests/notify.sx
View File

@@ -1,77 +0,0 @@
;; lib/events/tests/notify.sx — durable notification delivery flows.
(define ev-nt-pass 0)
(define ev-nt-fail 0)
(define ev-nt-failures (list))
(define
ev-nt-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-nt-pass (+ ev-nt-pass 1))
(do
(set! ev-nt-fail (+ ev-nt-fail 1))
(append!
ev-nt-failures
(str name "\n expected: " expected "\n got: " got))))))
;; Each case runs a Scheme flow program (notify flows preloaded) and asserts on
;; the SX-native result. Scheme symbols come back as strings.
(define
ev-nt-run-all!
(fn
()
(do
(ev-nt-check!
"reminder delivers on the first attempt"
(ev/notify-run
"(define s (flow/start (ev-deliver-reminder 3) (list (quote m1) (quote alice) (quote hello))))\n (flow-run-host (lambda (k p) (list (quote ok) (quote sent))) 5)\n (list (flow/status (car (cdr s))) (flow/result (car (cdr s))))")
(list "done" (list "delivered" "m1" 1)))
(ev-nt-check!
"reminder retries a transient failure then delivers"
(ev/notify-run
"(define hits 0)\n (define s (flow/start (ev-deliver-reminder 3) (list (quote m1) (quote bob) (quote hi))))\n (flow-run-host (lambda (k p) (begin (set! hits (+ hits 1)) (if (< hits 2) (list (quote retry) (quote down)) (list (quote ok) (quote sent))))) 10)\n (list (flow/result (car (cdr s))) hits)")
(list (list "delivered" "m1" 2) 2))
(ev-nt-check!
"reminder gives up after maxn attempts"
(ev/notify-run
"(define s (flow/start (ev-deliver-reminder 2) (list (quote m1) (quote x) (quote y))))\n (flow-run-host (lambda (k p) (list (quote retry) (quote down))) 10)\n (flow/result (car (cdr s)))")
(list "failed" "m1" "down"))
(ev-nt-check!
"redelivery of the same id sends only once (at-least-once, idempotent)"
(ev/notify-run
"(define sent (list)) (define deliveries 0)\n (define (xport k p)\n (let ((id (ev-msg-id p)))\n (if (ev-mem id sent)\n (list (quote ok) (quote duplicate))\n (begin (set! sent (cons id sent)) (set! deliveries (+ deliveries 1)) (list (quote ok) (quote sent))))))\n (define s1 (flow/start (ev-deliver-reminder 3) (list (quote m1) (quote a) (quote hi))))\n (flow-run-host xport 5)\n (define s2 (flow/start (ev-deliver-reminder 3) (list (quote m1) (quote a) (quote hi))))\n (flow-run-host xport 5)\n (list deliveries (flow/result (car (cdr s2))))")
(list 1 (list "delivered" "m1" 1)))
(ev-nt-check!
"digest delivers every message in the batch"
(ev/notify-run
"(define s (flow/start (ev-deliver-digest 3) (list (list (quote a) (quote u1) (quote hi)) (list (quote b) (quote u2) (quote yo)))))\n (flow-run-host (lambda (k p) (list (quote ok) (quote sent))) 10)\n (flow/result (car (cdr s)))")
(list
(list "delivered" "a" 1)
(list "delivered" "b" 1)))
(ev-nt-check!
"digest reports per-message outcomes independently"
(ev/notify-run
"(define (xport k p)\n (let ((id (ev-msg-id p)))\n (if (equal? id (quote b)) (list (quote retry) (quote flaky)) (list (quote ok) (quote sent)))))\n (define s (flow/start (ev-deliver-digest 2) (list (list (quote a) (quote u1) (quote hi)) (list (quote b) (quote u2) (quote yo)) (list (quote c) (quote u3) (quote ya)))))\n (flow-run-host xport 12)\n (flow/result (car (cdr s)))")
(list
(list "delivered" "a" 1)
(list "failed" "b" "flaky")
(list "delivered" "c" 1)))
(ev-nt-check!
"delivery suspends until the transport responds"
(ev/notify-run
"(define s (flow/start (ev-deliver-reminder 3) (list (quote m1) (quote a) (quote hi))))\n (flow/status (car (cdr s)))")
"suspended"))))
(define
ev-notify-tests-run!
(fn
()
(do
(set! ev-nt-pass 0)
(set! ev-nt-fail 0)
(set! ev-nt-failures (list))
(ev-nt-run-all!)
{:failures ev-nt-failures :total (+ ev-nt-pass ev-nt-fail) :passed ev-nt-pass :failed ev-nt-fail})))

276
lib/events/tests/reminders.sx
View File

@@ -1,276 +0,0 @@
;; lib/events/tests/reminders.sx — reminder + digest derivation from the agenda.
(define ev-rm-pass 0)
(define ev-rm-fail 0)
(define ev-rm-failures (list))
(define
ev-rm-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-rm-pass (+ ev-rm-pass 1))
(do
(set! ev-rm-fail (+ ev-rm-fail 1))
(append!
ev-rm-failures
(str name "\n expected: " expected "\n got: " got))))))
;; A store with a weekly class (Mon+Wed 18:00, 60m, 4 occurrences) and a one-off
;; talk; durable bookings on a persist backend.
(define
ev-rm-store
(fn
()
(ev/schedule
(ev/schedule
(ev/empty)
(quote yoga)
(ev-dt 2026 6 1 18 0)
60
{:freq :weekly :count 4 :byday (list 0 2)}
20)
(quote talk)
(ev-dt 2026 6 2 12 0)
30
nil
50)))
(define
ev-rm-run-all!
(fn
()
(let
((store (ev-rm-store)) (b (persist/open)))
(let
((occs (ev/agenda store (ev-date 2026 6 1) (ev-date 2026 7 1))))
(do
(ev/book-occ! b store (quote nia) (first occs))
(ev/book-occ! b store (quote ola) (first occs))
(ev/book-occ!
b
store
(quote ola)
(ev-occ
(quote talk)
(ev-dt 2026 6 2 12 0)
30))
(do
(let
((rs (ev/occurrence-reminders b (first occs) 60)))
(do
(ev-rm-check!
"one reminder per booked attendee"
(len rs)
2)
(ev-rm-check!
"reminder fires lead minutes before start"
(get (first rs) :fire-at)
(-
(ev-dt
2026
6
1
18
0)
60))
(ev-rm-check!
"reminder idempotency key encodes occ/recipient/lead"
(get (first rs) :id)
(str
(ev-occ-key (first occs))
"/"
(quote nia)
"/"
60))
(ev-rm-check!
"reminder names the event"
(get (first rs) :event)
(quote yoga))))
(ev-rm-check!
"unbooked occurrence has no reminders"
(len
(ev/occurrence-reminders b (ev-occ (quote yoga) (ev-dt 2026 6 3 18 0) 60) 60))
0)
(let
((all (ev/agenda-reminders b store (ev-date 2026 6 1) (ev-date 2026 7 1) 60)))
(do
(ev-rm-check!
"agenda reminders cover all bookings"
(len all)
3)
(ev-rm-check!
"agenda reminders sorted by fire-at"
(map (fn (r) (get r :fire-at)) all)
(list
(-
(ev-dt
2026
6
1
18
0)
60)
(-
(ev-dt
2026
6
1
18
0)
60)
(-
(ev-dt
2026
6
2
12
0)
60)))))
(let
((all (ev/agenda-reminders b store (ev-date 2026 6 1) (ev-date 2026 7 1) 60)))
(do
(ev-rm-check!
"nothing due before the first fire-at"
(len
(ev/due-reminders
all
(-
(ev-dt
2026
6
1
17
0)
1)))
0)
(ev-rm-check!
"the two yoga reminders are due at 17:00"
(len
(ev/due-reminders
all
(ev-dt
2026
6
1
17
0)))
2)
(ev-rm-check!
"all reminders due once past the last fire-at"
(len
(ev/due-reminders
all
(ev-dt
2026
6
2
12
0)))
3)))
(let
((r (first (ev/occurrence-reminders b (first occs) 60))))
(ev-rm-check!
"reminder projects to (id recipient body)"
(ev/reminder->msg r)
(list
(str
(ev-occ-key (first occs))
"/"
(quote nia)
"/"
60)
(quote nia)
(list
:reminder (quote yoga)
(ev-dt
2026
6
1
18
0)))))
(let
((dig (ev/agenda-digest b store (quote ola) (ev-date 2026 6 1) (ev-date 2026 7 1))))
(do
(ev-rm-check!
"digest is addressed to the actor"
(get dig :recipient)
(quote ola))
(ev-rm-check!
"digest lists the actor's booked occurrences"
(map (fn (it) (get it :event)) (get dig :items))
(list (quote yoga) (quote talk)))))
(let
((empty-dig (ev/agenda-digest b store (quote nobody) (ev-date 2026 6 1) (ev-date 2026 7 1))))
(ev-rm-check!
"digest empty for an actor with no bookings"
(get empty-dig :items)
(list)))))))))
;; ---- reschedule notifications ----
(define
ev-rm-rs-run-all!
(fn
()
(let
((b (persist/open))
(ev (ev-event (quote yoga) (ev-dt 2026 6 1 9 0) 60 {:freq :daily :count 3} 20)))
(let
((occ2 (ev-occ (quote yoga) (ev-dt 2026 6 2 9 0) 60)))
(do
(ev/book-occ! b (ev/add-event (ev/empty) ev) (quote nia) occ2)
(ev/book-occ! b (ev/add-event (ev/empty) ev) (quote ola) occ2)
;; reschedule the Jun 2 occurrence to 14:00 / 90 min
(let
((moved (ev-with-override ev (ev-dt 2026 6 2 9 0) (ev-dt 2026 6 2 14 0) 90)))
(let
((ns (ev/reschedule-notifications b moved)))
(do
(ev-rm-check!
"every booked attendee is notified of the reschedule"
(map (fn (n) (get n :recipient)) ns)
(list (quote nia) (quote ola)))
(ev-rm-check!
"reschedule carries old and new start"
(list (get (first ns) :old-start) (get (first ns) :new-start))
(list (ev-dt 2026 6 2 9 0) (ev-dt 2026 6 2 14 0)))
(ev-rm-check!
"reschedule carries the new duration"
(get (first ns) :new-duration)
90)
(ev-rm-check!
"reschedule idempotency key encodes original key + new start"
(get (first ns) :id)
(str (ev-occ-key occ2) "/reschedule/" (ev-dt 2026 6 2 14 0)))
(ev-rm-check!
"reschedule projects to notify wire shape"
(ev/reschedule-notify->msg (first ns))
(list
(str (ev-occ-key occ2) "/reschedule/" (ev-dt 2026 6 2 14 0))
(quote nia)
(list :rescheduled (quote yoga) (ev-dt 2026 6 2 9 0) (ev-dt 2026 6 2 14 0)))))))
;; an override on an occurrence nobody booked notifies no one
(let
((moved2 (ev-with-override ev (ev-dt 2026 6 3 9 0) (ev-dt 2026 6 3 10 0) 60)))
(ev-rm-check!
"rescheduling an unbooked occurrence notifies no one"
(len (ev/reschedule-notifications b moved2))
0))
;; an event with no overrides yields no reschedule notifications
(ev-rm-check!
"event without overrides has no reschedule notifications"
(len (ev/reschedule-notifications b ev))
0))))))
(define
ev-reminders-tests-run!
(fn
()
(do
(set! ev-rm-pass 0)
(set! ev-rm-fail 0)
(set! ev-rm-failures (list))
(ev-rm-run-all!)
(ev-rm-rs-run-all!)
{:failures ev-rm-failures :total (+ ev-rm-pass ev-rm-fail) :passed ev-rm-pass :failed ev-rm-fail})))

252
lib/events/tests/ticket.sx
View File

@@ -1,252 +0,0 @@
;; lib/events/tests/ticket.sx — paid-ticket contract + settlement orchestration.
(define ev-tk-pass 0)
(define ev-tk-fail 0)
(define ev-tk-failures (list))
(define
ev-tk-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-tk-pass (+ ev-tk-pass 1))
(do
(set! ev-tk-fail (+ ev-tk-fail 1))
(append!
ev-tk-failures
(str name "\n expected: " expected "\n got: " got))))))
(define
ev-tk-run-all!
(fn
()
(do
(let
((req (ev/checkout-request "occ1" (quote nia) 1500 "GBP" "ref-1")))
(do
(ev-tk-check!
"checkout-request is tagged"
(ev/checkout-request? req)
true)
(ev-tk-check!
"payment-result is not a checkout-request"
(ev/checkout-request? (ev/payment-paid "o" (quote a) "r"))
false)
(ev-tk-check!
"request occ-key accessor"
(ev/req-occ-key req)
"occ1")
(ev-tk-check!
"request actor accessor"
(ev/req-actor req)
(quote nia))
(ev-tk-check!
"request amount accessor"
(ev/req-amount req)
1500)
(ev-tk-check!
"request currency accessor"
(ev/req-currency req)
"GBP")
(ev-tk-check! "request ref accessor" (ev/req-ref req) "ref-1")))
(let
((res (ev/payment-paid "occ1" (quote nia) "ref-1")))
(do
(ev-tk-check!
"payment-result is tagged"
(ev/payment-result? res)
true)
(ev-tk-check! "result status accessor" (ev/result-status res) :paid)
(ev-tk-check!
"failed constructor carries status"
(ev/result-status (ev/payment-failed "o" (quote a) "r"))
:failed)
(ev-tk-check!
"expired constructor carries status"
(ev/result-status (ev/payment-expired "o" (quote a) "r"))
:expired)))
(let
((b (persist/open)))
(do
(let
((r (ev/request-ticket! b "show" 1 (quote a) 2000 "GBP" "ref-a")))
(do
(ev-tk-check!
"request-ticket awaiting-payment"
(get r :status)
:awaiting-payment)
(ev-tk-check!
"request-ticket returns a checkout-request"
(ev/checkout-request? (get r :request))
true)
(ev-tk-check!
"checkout-request carries the amount"
(ev/req-amount (get r :request))
2000)))
(ev-tk-check!
"held seat reserves capacity"
(ev/seats-left b "show" 1)
0)
(ev-tk-check!
"second buyer is full while payment pends"
(get
(ev/request-ticket!
b
"show"
1
(quote c)
2000
"GBP"
"ref-c")
:status)
:full)
(ev-tk-check!
"held seat state pending"
(ev/seat-state b "show" (quote a))
:held)))
(let
((b (persist/open)))
(do
(ev/request-ticket!
b
"gig"
2
(quote a)
2000
"GBP"
"ref-a")
(let
((s (ev/settle-payment! b (ev/payment-paid "gig" (quote a) "ref-a"))))
(ev-tk-check! "settle paid confirms" (get s :status) :confirmed))
(ev-tk-check!
"confirmed seat state"
(ev/seat-state b "gig" (quote a))
:confirmed)
(ev-tk-check!
"redelivered paid is still confirmed (idempotent)"
(get
(ev/settle-payment!
b
(ev/payment-paid "gig" (quote a) "ref-a"))
:status)
:confirmed)
(ev-tk-check!
"still exactly one seat taken"
(ev-booking-count b "gig")
1)))
(let
((b (persist/open)))
(do
(ev/request-ticket!
b
"fail"
1
(quote a)
2000
"GBP"
"ref-a")
(ev-tk-check!
"seat held before failure"
(ev/seats-left b "fail" 1)
0)
(let
((s (ev/settle-payment! b (ev/payment-failed "fail" (quote a) "ref-a"))))
(ev-tk-check! "settle failed releases" (get s :status) :released))
(ev-tk-check!
"released seat frees capacity"
(ev/seats-left b "fail" 1)
1)
(ev-tk-check!
"redelivered failure is a noop"
(get
(ev/settle-payment!
b
(ev/payment-failed "fail" (quote a) "ref-a"))
:status)
:noop)
(ev-tk-check!
"freed seat available to next buyer"
(get
(ev/request-ticket!
b
"fail"
1
(quote c)
2000
"GBP"
"ref-c")
:status)
:awaiting-payment)
(ev/request-ticket!
b
"exp"
1
(quote a)
2000
"GBP"
"ref-a")
(ev-tk-check!
"settle expired releases"
(get
(ev/settle-payment!
b
(ev/payment-expired "exp" (quote a) "ref-a"))
:status)
:released)))
(let
((b (persist/open)))
(do
(ev/request-ticket!
b
"race"
1
(quote a)
2000
"GBP"
"ref-a")
(ev/settle-payment!
b
(ev/payment-expired "race" (quote a) "ref-a"))
(ev-tk-check!
"late paid for a vanished hold needs a refund"
(get
(ev/settle-payment!
b
(ev/payment-paid "race" (quote a) "ref-a"))
:status)
:paid-but-no-hold)
(ev-tk-check!
"no phantom seat created"
(ev-booking-count b "race")
0)))
(let
((b (persist/open)))
(do
(let
((start (ev/request-ticket! b "e2e" 3 (quote nia) 2500 "GBP" "ref-nia")))
(ev/settle-payment!
b
(ev/payment-paid
(ev/req-occ-key (get start :request))
(ev/req-actor (get start :request))
(ev/req-ref (get start :request)))))
(ev-tk-check!
"e2e roster holds the buyer"
(ev/roster b "e2e")
(list (quote nia)))
(ev-tk-check!
"e2e seat confirmed"
(ev/seat-state b "e2e" (quote nia))
:confirmed))))))
(define
ev-ticket-tests-run!
(fn
()
(do
(set! ev-tk-pass 0)
(set! ev-tk-fail 0)
(set! ev-tk-failures (list))
(ev-tk-run-all!)
{:failures ev-tk-failures :total (+ ev-tk-pass ev-tk-fail) :passed ev-tk-pass :failed ev-tk-fail})))

173
lib/events/tests/timezone.sx
View File

@@ -1,173 +0,0 @@
;; lib/events/tests/timezone.sx — timezones + DST.
(define ev-tz-pass 0)
(define ev-tz-fail 0)
(define ev-tz-failures (list))
(define
ev-tz-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-tz-pass (+ ev-tz-pass 1))
(do
(set! ev-tz-fail (+ ev-tz-fail 1))
(append!
ev-tz-failures
(str name "\n expected: " expected "\n got: " got))))))
;; Wall-clock (civil + minute-of-day) an occurrence's UTC start maps to in a tz.
(define
ev-tz-local-of
(fn
(tz utc-dt)
(let
((l (ev-tz-utc->local tz utc-dt)))
(list (ev-dt->civil l) (ev-dt-tod l)))))
(define
ev-tz-run-all!
(fn
()
(do
(let
((nyc (ev-tz-fixed "EST" -300)))
(do
(ev-tz-check!
"fixed zone: utc -> local subtracts 5h"
(ev-tz-utc->local
nyc
(ev-dt 2026 1 1 17 0))
(ev-dt 2026 1 1 12 0))
(ev-tz-check!
"fixed zone: local -> utc adds 5h back"
(ev-tz-local->utc
nyc
(ev-dt 2026 1 1 12 0))
(ev-dt 2026 1 1 17 0))
(ev-tz-check!
"UTC zone is identity"
(ev-tz-local->utc
ev-tz-utc
(ev-dt 2026 6 1 9 0))
(ev-dt 2026 6 1 9 0))))
(ev-tz-check!
"London winter offset is 0 (GMT)"
(ev-tz-offset
ev-tz-london
(ev-dt 2026 1 15 12 0))
0)
(ev-tz-check!
"London summer offset is 60 (BST)"
(ev-tz-offset
ev-tz-london
(ev-dt 2026 7 15 12 0))
60)
(ev-tz-check!
"Paris winter offset is 60 (CET)"
(ev-tz-offset
ev-tz-paris
(ev-dt 2026 1 15 12 0))
60)
(ev-tz-check!
"Paris summer offset is 120 (CEST)"
(ev-tz-offset
ev-tz-paris
(ev-dt 2026 7 15 12 0))
120)
(ev-tz-check!
"DST starts last Sunday of March"
(ev-dt->civil
(ev-tz-transition
2026
(ev-tz-rule 3 -1 6 60)))
(list 2026 3 29))
(ev-tz-check!
"DST ends last Sunday of October"
(ev-dt->civil
(ev-tz-transition
2026
(ev-tz-rule 10 -1 6 60)))
(list 2026 10 25))
(ev-tz-check!
"09:00 London in winter is 09:00 UTC"
(ev-tz-local->utc
ev-tz-london
(ev-dt 2026 1 15 9 0))
(ev-dt 2026 1 15 9 0))
(ev-tz-check!
"09:00 London in summer is 08:00 UTC"
(ev-tz-local->utc
ev-tz-london
(ev-dt 2026 7 15 9 0))
(ev-dt 2026 7 15 8 0))
(ev-tz-check!
"round trip utc -> local -> utc"
(ev-tz-local->utc
ev-tz-london
(ev-tz-utc->local
ev-tz-london
(ev-dt 2026 7 15 8 0)))
(ev-dt 2026 7 15 8 0))
(let
((ev (ev-event-tz (quote standup) (ev-dt 2026 3 27 9 0) 60 {:freq :daily :count 5} 10 ev-tz-london)))
(let
((occs (ev-expand ev (ev-date 2026 3 1) (ev-date 2026 4 5))))
(do
(ev-tz-check!
"daily occurrences shift in UTC across the DST boundary"
(map (fn (o) (ev-dt-tod (get o :start))) occs)
(list 540 540 480 480 480))
(ev-tz-check!
"but every occurrence stays 09:00 local wall-clock"
(map
(fn
(o)
(first
(rest (ev-tz-local-of ev-tz-london (get o :start)))))
occs)
(list 540 540 540 540 540))
(ev-tz-check!
"occurrence dates are stable in local time"
(map
(fn
(o)
(ev-civ-d
(first (ev-tz-local-of ev-tz-london (get o :start)))))
occs)
(list 27 28 29 30 31)))))
(let
((wk (ev-event-tz (quote class) (ev-dt 2026 3 23 18 0) 90 {:freq :weekly :byday (list 0)} 5 ev-tz-london)))
(let
((occs (ev-expand wk (ev-date 2026 3 1) (ev-date 2026 4 20))))
(ev-tz-check!
"weekly Monday 18:00 London stays 18:00 local each week"
(map
(fn
(o)
(first (rest (ev-tz-local-of ev-tz-london (get o :start)))))
occs)
(list 1080 1080 1080 1080))))
(let
((plain (ev-event (quote p) (ev-dt 2026 3 27 9 0) 60 {:freq :daily :count 3} 1)))
(ev-tz-check!
"plain event expands naively (no UTC shift)"
(map
(fn (o) (ev-dt-tod (get o :start)))
(ev-expand
plain
(ev-date 2026 3 1)
(ev-date 2026 4 5)))
(list 540 540 540))))))
(define
ev-timezone-tests-run!
(fn
()
(do
(set! ev-tz-pass 0)
(set! ev-tz-fail 0)
(set! ev-tz-failures (list))
(ev-tz-run-all!)
{:failures ev-tz-failures :total (+ ev-tz-pass ev-tz-fail) :passed ev-tz-pass :failed ev-tz-fail})))

101
lib/events/ticket.sx
View File

@@ -1,101 +0,0 @@
;; lib/events/ticket.sx — paid-ticket contract between events and commerce.
;;
;; A paid booking spans two subsystems. events does NOT import commerce; instead
;; this module defines the CONTRACT — the two messages on the wire — and the
;; events-side orchestration over provisional holds (booking.sx). commerce
;; imports these shapes; the dependency only points one way.
;;
;; checkout-request events -> commerce "take payment for this seat"
;; {:kind :events.checkout :occ-key :actor :amount :currency :ref}
;;
;; payment-result commerce -> events "here's how payment went"
;; {:kind :events.payment :occ-key :actor :ref :status}
;; :status ∈ :paid | :failed | :expired
;;
;; Flow: ev/request-ticket! places a capacity-safe HOLD (reserving the seat so
;; it can't be oversold while payment pends) and returns a checkout-request to
;; hand to commerce. When commerce reports back, ev/settle-payment! confirms the
;; hold on :paid or releases it otherwise. Settlement is idempotent — an
;; at-least-once redelivery of the same result is safe. `ref` is the opaque
;; correlation/idempotency id; occ-key + actor locate the hold, so settlement
;; needs no side table.
;; ---- contract: checkout request (events -> commerce) ----
(define
ev/checkout-request
(fn (occ-key actor amount currency ref) {:actor actor :amount amount :kind :events.checkout :ref ref :currency currency :occ-key occ-key}))
(define
ev/checkout-request?
(fn (m) (and (dict? m) (= (get m :kind) :events.checkout))))
(define ev/req-occ-key (fn (r) (get r :occ-key)))
(define ev/req-actor (fn (r) (get r :actor)))
(define ev/req-amount (fn (r) (get r :amount)))
(define ev/req-currency (fn (r) (get r :currency)))
(define ev/req-ref (fn (r) (get r :ref)))
;; ---- contract: payment result (commerce -> events) ----
(define ev/payment-result (fn (occ-key actor ref status) {:actor actor :kind :events.payment :status status :ref ref :occ-key occ-key}))
(define
ev/payment-result?
(fn (m) (and (dict? m) (= (get m :kind) :events.payment))))
(define ev/result-occ-key (fn (r) (get r :occ-key)))
(define ev/result-actor (fn (r) (get r :actor)))
(define ev/result-ref (fn (r) (get r :ref)))
(define ev/result-status (fn (r) (get r :status)))
(define
ev/payment-paid
(fn (occ-key actor ref) (ev/payment-result occ-key actor ref :paid)))
(define
ev/payment-failed
(fn (occ-key actor ref) (ev/payment-result occ-key actor ref :failed)))
(define
ev/payment-expired
(fn (occ-key actor ref) (ev/payment-result occ-key actor ref :expired)))
;; ---- orchestration ----
;; Begin a paid booking: place a capacity-safe hold and, if reserved, return a
;; checkout-request for commerce. :full when no seat; :already when the actor
;; already holds/booked this occurrence (no duplicate request).
(define
ev/request-ticket!
(fn
(b occ-key capacity actor amount currency ref)
(let
((h (ev/hold! b occ-key capacity actor)))
(cond
((= (get h :status) :held) {:seat (get h :seat) :request (ev/checkout-request occ-key actor amount currency ref) :status :awaiting-payment})
((= (get h :status) :already) {:seat (get h :seat) :status :already})
(else {:capacity capacity :status :full})))))
;; Settle a payment result from commerce. :paid confirms the hold; :failed /
;; :expired release it. Idempotent: a redelivered :paid stays :confirmed, a
;; redelivered release is a :noop. If a :paid arrives for a hold that is already
;; gone (released/expired first), returns :paid-but-no-hold so the caller can
;; trigger a refund.
(define
ev/settle-payment!
(fn
(b result)
(let
((occ-key (ev/result-occ-key result))
(actor (ev/result-actor result))
(ref (ev/result-ref result)))
(if
(= (ev/result-status result) :paid)
(let
((c (ev/confirm! b occ-key actor)))
(cond
((= (get c :status) :confirmed) {:actor actor :status :confirmed :ref ref})
((= (get c :status) :already-confirmed) {:actor actor :status :confirmed :ref ref})
(else {:actor actor :status :paid-but-no-hold :ref ref})))
(let
((r (ev/release! b occ-key actor)))
(if (= (get r :status) :released) {:actor actor :status :released :ref ref} {:actor actor :status :noop :ref ref}))))))

131
lib/events/timezone.sx
View File

@@ -1,131 +0,0 @@
;; lib/events/timezone.sx — timezones + DST for the calendar.
;;
;; Datetimes in calendar.sx are naive epoch-minutes (wall clock). A timezone
;; maps between wall-clock LOCAL time and absolute UTC. An event is authored in
;; local time + a tz; recurrence is expanded in local time (so a "09:00 weekly"
;; meeting stays 09:00 across a DST change), then each occurrence is converted
;; to UTC for storage/comparison.
;;
;; Offset convention: offset = local - utc (minutes). London summer (BST) = +60.
;; UTC = local - offset; local = utc + offset.
;;
;; Two kinds of zone, no IANA database:
;; :fixed — a constant offset.
;; :dst — std/dst offsets + two transition rules. Transitions are given in
;; UTC (EU zones all switch at 01:00 UTC), so the offset at any UTC
;; instant is a direct range check; no recursion. Northern-hemisphere
;; ordering (dst-start < dst-end within a year) is assumed.
;;
;; Requires calendar.sx (ev-dt, ev-days-from-civil, ev-civil-from-days,
;; ev-civ-y, ev-floor-div, ev-resolve-nth-weekday).
;; A DST transition rule: the ord-th weekday `wd` (0=Mon..6=Sun) of `month`, at
;; `time` minutes-of-day UTC. EU: last Sunday (ord -1, wd 6) at 01:00 UTC.
(define ev-tz-rule (fn (month ord wd time) {:ord ord :wd wd :month month :time time}))
(define ev-tz-fixed (fn (name offset) {:name name :offset offset :kind :fixed}))
(define ev-tz-dst (fn (name std dst start-rule end-rule) {:name name :kind :dst :dst-end end-rule :dst-start start-rule :std-offset std :dst-offset dst}))
;; Standard (winter) offset — the initial guess when inverting local -> utc.
(define
ev-tz-std-offset
(fn
(tz)
(if (= (get tz :kind) :fixed) (get tz :offset) (get tz :std-offset))))
;; The UTC instant (epoch-minutes) of a transition rule in a given year.
(define
ev-tz-transition
(fn
(year rule)
(let
((day (ev-resolve-nth-weekday year (get rule :month) (get rule :ord) (get rule :wd))))
(+
(* (ev-days-from-civil year (get rule :month) day) 1440)
(get rule :time)))))
;; The offset (minutes) in effect at a UTC instant.
(define
ev-tz-offset
(fn
(tz utc-dt)
(cond
((= (get tz :kind) :fixed) (get tz :offset))
((= (get tz :kind) :dst)
(let
((year (ev-civ-y (ev-civil-from-days (ev-floor-div utc-dt 1440)))))
(let
((start (ev-tz-transition year (get tz :dst-start)))
(end (ev-tz-transition year (get tz :dst-end))))
(if
(and (>= utc-dt start) (< utc-dt end))
(get tz :dst-offset)
(get tz :std-offset)))))
(else 0))))
;; UTC instant -> local wall-clock.
(define
ev-tz-utc->local
(fn (tz utc-dt) (+ utc-dt (ev-tz-offset tz utc-dt))))
;; Local wall-clock -> UTC instant. The offset depends on the instant, so we
;; guess with the standard offset and refine once (correct except within the
;; one-hour DST gap/overlap, where it resolves to the pre-transition offset).
(define
ev-tz-local->utc
(fn
(tz local-dt)
(let
((utc1 (- local-dt (ev-tz-offset tz (- local-dt (ev-tz-std-offset tz))))))
(- local-dt (ev-tz-offset tz utc1)))))
;; ---- predefined zones ----
(define ev-tz-utc (ev-tz-fixed "UTC" 0))
(define
ev-tz-london
(ev-tz-dst
"Europe/London"
0
60
(ev-tz-rule 3 -1 6 60)
(ev-tz-rule 10 -1 6 60)))
(define
ev-tz-paris
(ev-tz-dst
"Europe/Paris"
60
120
(ev-tz-rule 3 -1 6 60)
(ev-tz-rule 10 -1 6 60)))
;; ---- tz-aware event expansion ----
;; An event authored in local time + a tz. dtstart-local / rrule / exceptions
;; are all wall-clock in `tz`; expansion converts each occurrence to UTC.
(define
ev-event-tz
(fn (id dtstart-local duration rrule capacity tz) {:id id :duration duration :dtstart dtstart-local :rrule rrule :capacity capacity :tz tz}))
;; Expand a tz-aware event over a UTC window. Local recurrence is expanded over
;; a window widened by a day each side (to catch occurrences whose UTC lands in
;; range), converted to UTC, then filtered to [win-start, win-end].
(define
ev-expand-tz
(fn
(event tz win-start win-end)
(let
((local-ws (- (ev-tz-utc->local tz win-start) 1440))
(local-we (+ (ev-tz-utc->local tz win-end) 1440)))
(let
((local-occs (ev-expand-naive event local-ws local-we)))
(let
((utc-occs (map (fn (o) (let ((u (ev-tz-local->utc tz (get o :start))) (dur (- (get o :end) (get o :start)))) {:id (get o :id) :start u :end (+ u dur)})) local-occs)))
(ev-sort-occs
(filter
(fn
(o)
(and
(>= (get o :start) win-start)
(<= (get o :start) win-end)))
utc-occs)))))))

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

61
lib/flow/spec.sx
View File

@@ -1,61 +0,0 @@
;; lib/flow/spec.sx — flow combinators as a Scheme prelude.
;;
;; A flow is a Scheme procedure of one argument: the upstream value.
;; node : input -> output
;; A leaf node ignoring its argument is effectively a thunk. Combinators
;; build composite nodes out of child nodes. The whole flow runs INSIDE the
;; Scheme interpreter.
;;
;; Phase 1 combinators (flow-combinators-src):
;; flow-node / flow-id / flow-const / sequence / parallel / defflow
;; defflow both binds the flow and registers it by name (flow-register!, in
;; store.sx) so it can be re-resolved after a process restart.
;; map-flow (Phase 5): run a node over each item of a list input, join results.
;; flow-while / flow-until (Phase 5): bounded iteration — re-run body, threading
;; the value, while/until pred holds, up to `max` steps (deterministic bound; no
;; unbounded loops in pure SX).
;;
;; Phase 2 combinators (flow-control-src):
;; branch / fail / failed? / fail-reason / try-catch / retry / timeout / tick
;; tap (Phase 5): side-effecting pass-through (returns input unchanged).
;; recover (Phase 5): the fail-VALUE counterpart of try-catch.
;; attempt (Phase 6): railway sequence — thread nodes left-to-right but stop at
;; the first node that returns a (fail ...) value, returning that failure.
;;
;; Phase 3 suspend core (flow-suspend-src):
;; The guest Scheme's call/cc is ESCAPE-ONLY (re-invoking a captured k after it
;; returns hangs the runtime), so suspend/resume CANNOT re-enter a continuation.
;; Instead, durability uses DETERMINISTIC REPLAY: a flow re-runs from the start
;; on each resume; suspend points that have already been resolved replay their
;; logged value, and the first unresolved suspend escapes back to the driver.
;; The entire persisted state is the replay log (plain (tag value) data), which
;; survives process restart — no live continuation is ever serialized.
;;
;; (suspend tag) — if tag is in the replay log, return its value; else escape
;; to the driver as (flow-suspended tag). tags must be unique & deterministic
;; across replays. ALL effects/non-determinism must go through suspend so their
;; results are logged (otherwise they re-run on every replay).
;; (flow-drive flow input log) — run flow with the given replay log; returns
;; (flow-done result) or (flow-suspended tag).
(define
flow-combinators-src
"(define (flow-node f) f)\n (define (flow-id input) input)\n (define (flow-const v) (lambda (input) v))\n (define (flow-seq-step ns v)\n (if (null? ns) v (flow-seq-step (cdr ns) ((car ns) v))))\n (define sequence (lambda ns (lambda (input) (flow-seq-step ns input))))\n (define parallel (lambda ns (lambda (input) (map (lambda (n) (n input)) ns))))\n (define (map-flow node) (lambda (items) (map node items)))\n (define (flow-while-step pred body input n)\n (if (<= n 0)\n input\n (if (pred input) (flow-while-step pred body (body input) (- n 1)) input)))\n (define (flow-while pred body max) (lambda (input) (flow-while-step pred body input max)))\n (define (flow-until-step pred body input n)\n (if (<= n 0)\n input\n (if (pred input) input (flow-until-step pred body (body input) (- n 1)))))\n (define (flow-until pred body max) (lambda (input) (flow-until-step pred body input max)))\n (define-syntax defflow\n (syntax-rules ()\n ((defflow nm body)\n (begin (define nm body) (flow-register! (quote nm) nm)))))")
(define
flow-control-src
"(define (branch pred then else)\n (lambda (input) (if (pred input) (then input) (else input))))\n (define (fail reason) (list (quote flow-fail) reason))\n (define (failed? x) (and (pair? x) (eq? (car x) (quote flow-fail))))\n (define (fail-reason x) (car (cdr x)))\n (define (recover node handler)\n (lambda (input)\n (let ((r (node input)))\n (if (failed? r) (handler (fail-reason r)) r))))\n (define (tap effect)\n (lambda (input) (begin (effect input) input)))\n (define (flow-attempt-step ns v)\n (if (failed? v)\n v\n (if (null? ns) v (flow-attempt-step (cdr ns) ((car ns) v)))))\n (define attempt (lambda ns (lambda (input) (flow-attempt-step ns input))))\n (define (try-catch node handler)\n (lambda (input) (guard (e (#t (handler e))) (node input))))\n (define (flow-retry-step n node input)\n (guard (e (#t (if (<= n 1) (raise e) (flow-retry-step (- n 1) node input))))\n (node input)))\n (define (retry n node) (lambda (input) (flow-retry-step n node input)))\n (define flow-timeout-budget -1)\n (define (tick)\n (if (< flow-timeout-budget 0)\n 0\n (begin\n (set! flow-timeout-budget (- flow-timeout-budget 1))\n (if (< flow-timeout-budget 0)\n (raise (quote flow-timeout))\n flow-timeout-budget))))\n (define (timeout budget node)\n (lambda (input)\n (let ((saved flow-timeout-budget))\n (set! flow-timeout-budget budget)\n (guard (e (#t (begin (set! flow-timeout-budget saved) (raise e))))\n (let ((result (node input)))\n (set! flow-timeout-budget saved)\n result)))))")
(define
flow-suspend-src
"(define flow-replay-log (list))\n (define flow-suspend-k #f)\n (define (flow-log-lookup tag log)\n (if (null? log)\n (list #f #f)\n (if (eq? (car (car log)) tag)\n (list #t (car (cdr (car log))))\n (flow-log-lookup tag (cdr log)))))\n (define (suspend tag)\n (let ((hit (flow-log-lookup tag flow-replay-log)))\n (if (car hit)\n (car (cdr hit))\n (flow-suspend-k (list (quote flow-suspended) tag)))))\n (define (flow-drive flow input log)\n (set! flow-replay-log log)\n (call/cc\n (lambda (k)\n (set! flow-suspend-k k)\n (list (quote flow-done) (flow input)))))")
(define
flow-load-combinators!
(fn
(env)
(begin
(scheme-eval-program (scheme-parse-all flow-combinators-src) env)
(scheme-eval-program (scheme-parse-all flow-control-src) env)
(scheme-eval-program (scheme-parse-all flow-suspend-src) env)
env)))

45
lib/flow/store.sx
View File

File diff suppressed because one or more lines are too long

79
lib/flow/tests/api.sx
View File

@@ -1,79 +0,0 @@
;; lib/flow/tests/api.sx — Phase 5: operational introspection API.
(define flow-api-pass 0)
(define flow-api-fail 0)
(define flow-api-fails (list))
(define
flow-api-test
(fn
(name actual expected)
(if
(= actual expected)
(set! flow-api-pass (+ flow-api-pass 1))
(begin
(set! flow-api-fail (+ flow-api-fail 1))
(append! flow-api-fails {:name name :expected expected :actual actual})))))
(define flow-a (fn (src) (flow-run src)))
;; ── flow/status ─────────────────────────────────────────────────
(flow-api-test "status: unknown id" (flow-a "(flow/status 999)") "unknown")
(flow-api-test
"status: suspended flow"
(flow-a
"(defflow w (lambda (x) (suspend (quote q)))) (define id (car (cdr (flow/start w 0)))) (flow/status id)")
"suspended")
(flow-api-test
"status: completed flow"
(flow-a
"(defflow w (sequence (lambda (x) (suspend (quote q))) (lambda (v) v))) (define id (car (cdr (flow/start w 0)))) (flow/resume id 5) (flow/status id)")
"done")
(flow-api-test
"status: cancelled flow"
(flow-a
"(defflow w (lambda (x) (suspend (quote q)))) (define id (car (cdr (flow/start w 0)))) (flow/cancel id) (flow/status id)")
"cancelled")
;; ── flow/result ─────────────────────────────────────────────────
(flow-api-test
"result: returns the value of a completed flow"
(flow-a
"(defflow w (sequence (lambda (x) (suspend (quote q))) (lambda (v) (list (quote got) v)))) (define id (car (cdr (flow/start w 0)))) (flow/resume id 9) (flow/result id)")
(list "got" 9))
(flow-api-test
"result: a still-suspended flow has no result"
(flow-a
"(defflow w (lambda (x) (suspend (quote q)))) (define id (car (cdr (flow/start w 0)))) (flow/result id)")
(list "flow-error" "not-done"))
(flow-api-test
"result: unknown id errors"
(flow-a "(flow/result 999)")
(list "flow-error" "no-such-flow"))
;; ── flow/list ───────────────────────────────────────────────────
(flow-api-test "list: empty store" (flow-a "(flow/list)") (list))
(flow-api-test
"list: reports id + status for each flow (newest first)"
(flow-a
"(defflow w (lambda (x) (suspend (quote q)))) (flow/start w 0) (flow/start (lambda (x) (* x 2)) 5) (flow/list)")
(list (list 2 "done") (list 1 "suspended")))
;; ── flow/pending ────────────────────────────────────────────────
(flow-api-test
"pending: lists suspended flows with their waiting tag"
(flow-a
"(defflow w (lambda (x) (suspend (quote review)))) (flow/start w 0) (flow/pending)")
(list (list 1 "review")))
(flow-api-test
"pending: excludes completed and cancelled flows"
(flow-a
"(defflow w (lambda (x) (suspend (quote q)))) (defflow v (sequence (lambda (x) (suspend (quote r))) (lambda (y) y))) (define i1 (car (cdr (flow/start w 0)))) (define i2 (car (cdr (flow/start v 0)))) (define i3 (car (cdr (flow/start w 0)))) (flow/resume i2 1) (flow/cancel i3) (flow/pending)")
(list (list 1 "q")))
(flow-api-test
"pending: operator can drain all pending flows"
(flow-a
"(defflow w (sequence (lambda (x) (suspend (quote q))) (lambda (v) (* v 10)))) (flow/start w 0) (flow/start w 0) (define ps (flow/pending)) (flow/resume (car (car ps)) 1) (flow/resume (car (car (cdr ps))) 2) (flow/list)")
(list (list 1 "done") (list 2 "done")))
(define flow-api-tests-run! (fn () {:total (+ flow-api-pass flow-api-fail) :passed flow-api-pass :failed flow-api-fail :fails flow-api-fails}))

121
lib/flow/tests/basic.sx
View File

@@ -1,121 +0,0 @@
;; lib/flow/tests/basic.sx — Phase 1: declarative DAG + sequential execution.
(define flow-basic-pass 0)
(define flow-basic-fail 0)
(define flow-basic-fails (list))
(define
flow-basic-test
(fn
(name actual expected)
(if
(= actual expected)
(set! flow-basic-pass (+ flow-basic-pass 1))
(begin
(set! flow-basic-fail (+ flow-basic-fail 1))
(append! flow-basic-fails {:name name :expected expected :actual actual})))))
;; Run a Scheme flow-program string and return its final value.
(define flow-b (fn (src) (flow-run src)))
;; Scheme strings are boxed as {:scm-string "..."}; unwrap to a host string.
(define flow-bs (fn (src) (get (flow-run src) :scm-string)))
;; ── single node ─────────────────────────────────────────────────
(flow-basic-test
"node: identity passes input through"
(flow-b "(flow/start flow-id 7)")
7)
(flow-basic-test
"node: const ignores input"
(flow-b "(flow/start (flow-const 99) 1)")
99)
(flow-basic-test
"node: bare lambda is a node"
(flow-b "(flow/start (lambda (x) (* x x)) 6)")
36)
;; ── linear sequence ─────────────────────────────────────────────
(flow-basic-test
"sequence: empty is identity"
(flow-b "(flow/start (sequence) 42)")
42)
(flow-basic-test
"sequence: single child"
(flow-b "(flow/start (sequence (lambda (x) (+ x 1))) 41)")
42)
(flow-basic-test
"sequence: two children thread"
(flow-b
"(flow/start (sequence (lambda (x) (+ x 1)) (lambda (x) (* x 10))) 4)")
50)
(flow-basic-test
"sequence: three children thread"
(flow-b
"(flow/start (sequence (lambda (x) (+ x 1)) (lambda (x) (* x 2)) (lambda (x) (- x 3))) 5)")
9)
;; ── data flow between nodes ─────────────────────────────────────
(flow-basic-test
"data flow: string accumulation"
(flow-bs
"(flow/start (sequence (lambda (s) (string-append s \"-a\")) (lambda (s) (string-append s \"-b\"))) \"x\")")
"x-a-b")
(flow-basic-test
"data flow: list build"
(flow-b
"(flow/start (sequence (lambda (x) (cons x (list))) (lambda (xs) (cons 0 xs))) 7)")
(list 0 7))
;; ── defflow ─────────────────────────────────────────────────────
(flow-basic-test
"defflow: names a flow"
(flow-b
"(defflow inc2 (sequence (lambda (x) (+ x 1)) (lambda (x) (+ x 1)))) (flow/start inc2 40)")
42)
(flow-basic-test
"defflow: reusable"
(flow-b
"(defflow dbl (lambda (x) (* x 2))) (+ (flow/start dbl 3) (flow/start dbl 10))")
26)
;; ── parallel (sequential semantics, join into list) ─────────────
(flow-basic-test
"parallel: fans input to all branches"
(flow-b
"(flow/start (parallel (lambda (x) (+ x 1)) (lambda (x) (* x 2)) (lambda (x) (- x 3))) 10)")
(list 11 20 7))
(flow-basic-test
"parallel: empty joins to empty list"
(flow-b "(flow/start (parallel) 5)")
(list))
(flow-basic-test
"parallel: single branch"
(flow-b "(flow/start (parallel (lambda (x) (* x x))) 9)")
(list 81))
;; ── nested composition ──────────────────────────────────────────
(flow-basic-test
"nested: sequence of sequences"
(flow-b
"(flow/start (sequence (sequence (lambda (x) (+ x 1)) (lambda (x) (+ x 1))) (sequence (lambda (x) (* x 3)))) 0)")
6)
(flow-basic-test
"nested: parallel inside sequence, join then reduce"
(flow-b
"(flow/start (sequence (parallel (lambda (x) (+ x 1)) (lambda (x) (* x 2))) (lambda (xs) (apply + xs))) 10)")
31)
(flow-basic-test
"nested: sequence inside parallel branch"
(flow-b
"(flow/start (parallel (sequence (lambda (x) (+ x 1)) (lambda (x) (* x 2))) (lambda (x) x)) 5)")
(list 12 5))
;; ── publish-shaped flow (the architecture sketch) ───────────────
(flow-basic-test
"publish: write -> (review | spell) -> join lengths"
(flow-b
"(defflow publish (sequence (lambda (draft) (string-append draft \"!\")) (parallel (lambda (c) (string-length c)) (lambda (c) (string-length (string-append c \"?\")))))) (flow/start publish \"hi\")")
(list 3 4))
(define flow-basic-tests-run! (fn () {:total (+ flow-basic-pass flow-basic-fail) :passed flow-basic-pass :failed flow-basic-fail :fails flow-basic-fails}))

108
lib/flow/tests/combinators.sx
View File

@@ -1,108 +0,0 @@
;; lib/flow/tests/combinators.sx — Phase 5: combinator library (tap, recover, map-flow, iteration).
(define flow-cmb-pass 0)
(define flow-cmb-fail 0)
(define flow-cmb-fails (list))
(define
flow-cmb-test
(fn
(name actual expected)
(if
(= actual expected)
(set! flow-cmb-pass (+ flow-cmb-pass 1))
(begin
(set! flow-cmb-fail (+ flow-cmb-fail 1))
(append! flow-cmb-fails {:name name :expected expected :actual actual})))))
(define flow-m (fn (src) (flow-run src)))
;; ── tap (side-effecting pass-through) ───────────────────────────
(flow-cmb-test
"tap: returns input unchanged"
(flow-m "(flow/start (tap (lambda (x) (* x 999))) 7)")
7)
(flow-cmb-test
"tap: runs the side effect"
(flow-m
"(define seen 0) (flow/start (tap (lambda (x) (set! seen x))) 42) seen")
42)
(flow-cmb-test
"tap: value flows on while the effect observes it"
(flow-m
"(define log 0) (flow/start (sequence (lambda (x) (+ x 1)) (tap (lambda (x) (set! log x))) (lambda (x) (* x 2))) 10) (list log (flow/result 1))")
(list 11 22))
;; ── recover (fail-value counterpart of try-catch) ───────────────
(flow-cmb-test
"recover: passes a non-fail value through"
(flow-m "(flow/start (recover (lambda (x) (* x 2)) (lambda (r) -1)) 5)")
10)
(flow-cmb-test
"recover: handles a fail value via the reason"
(flow-m
"(flow/start (recover (lambda (x) (fail (quote too-small))) (lambda (r) (list (quote recovered) r))) 1)")
(list "recovered" "too-small"))
(flow-cmb-test
"recover: handler can supply a default value"
(flow-m
"(flow/start (sequence (recover (lambda (x) (if (> x 0) x (fail (quote neg))) ) (flow-const 0)) (lambda (x) (* x 10))) -3)")
0)
(flow-cmb-test
"recover: does not catch raised exceptions (those are try-catch's job)"
(flow-m
"(flow/start (try-catch (recover (lambda (x) (raise (quote boom))) (flow-const 0)) (lambda (e) e)) 1)")
"boom")
;; ── map-flow (run a node over a list, join) ─────────────────────
(flow-cmb-test
"map-flow: applies the node to each item"
(flow-m "(flow/start (map-flow (lambda (x) (* x x))) (list 1 2 3 4))")
(list 1 4 9 16))
(flow-cmb-test
"map-flow: empty list joins to empty"
(flow-m "(flow/start (map-flow (lambda (x) (+ x 1))) (list))")
(list))
(flow-cmb-test
"map-flow: each item runs an independent sub-flow"
(flow-m
"(flow/start (map-flow (sequence (lambda (x) (+ x 1)) (lambda (x) (* x 2)))) (list 0 4 9))")
(list 2 10 20))
(flow-cmb-test
"map-flow: composes — fan over a list then reduce the join"
(flow-m
"(flow/start (sequence (map-flow (lambda (x) (* x 10))) (lambda (xs) (apply + xs))) (list 1 2 3))")
60)
;; ── flow-while / flow-until (bounded iteration) ─────────────────
(flow-cmb-test
"flow-while: iterates while the predicate holds"
(flow-m
"(flow/start (flow-while (lambda (x) (< x 10)) (lambda (x) (+ x 1)) 100) 0)")
10)
(flow-cmb-test
"flow-while: a false predicate leaves input unchanged"
(flow-m
"(flow/start (flow-while (lambda (x) (< x 0)) (lambda (x) (+ x 1)) 100) 5)")
5)
(flow-cmb-test
"flow-while: respects the max-iteration bound"
(flow-m "(flow/start (flow-while (lambda (x) #t) (lambda (x) (+ x 1)) 3) 0)")
3)
(flow-cmb-test
"flow-while: doubles until past a threshold"
(flow-m
"(flow/start (flow-while (lambda (x) (< x 50)) (lambda (x) (* x 2)) 100) 3)")
96)
(flow-cmb-test
"flow-until: iterates until the predicate becomes true"
(flow-m
"(flow/start (flow-until (lambda (x) (>= x 10)) (lambda (x) (+ x 3)) 100) 0)")
12)
(flow-cmb-test
"flow-until: composes inside a sequence"
(flow-m
"(flow/start (sequence (flow-until (lambda (x) (> x 100)) (lambda (x) (* x 3)) 100) (lambda (x) (- x 100))) 5)")
35)
(define flow-cmb-tests-run! (fn () {:total (+ flow-cmb-pass flow-cmb-fail) :passed flow-cmb-pass :failed flow-cmb-fail :fails flow-cmb-fails}))

179
lib/flow/tests/control.sx
View File

@@ -1,179 +0,0 @@
;; lib/flow/tests/control.sx — Phase 2: control flow + error handling.
(define flow-ctl-pass 0)
(define flow-ctl-fail 0)
(define flow-ctl-fails (list))
(define
flow-ctl-test
(fn
(name actual expected)
(if
(= actual expected)
(set! flow-ctl-pass (+ flow-ctl-pass 1))
(begin
(set! flow-ctl-fail (+ flow-ctl-fail 1))
(append! flow-ctl-fails {:name name :expected expected :actual actual})))))
(define flow-c (fn (src) (flow-run src)))
(define flow-cs (fn (src) (get (flow-run src) :scm-string)))
;; ── branch ──────────────────────────────────────────────────────
(flow-ctl-test
"branch: true selects then"
(flow-c
"(flow/start (branch (lambda (x) (> x 0)) (lambda (x) (* x 100)) (lambda (x) (- 0 x))) 5)")
500)
(flow-ctl-test
"branch: false selects else"
(flow-c
"(flow/start (branch (lambda (x) (> x 0)) (lambda (x) (* x 100)) (lambda (x) (- 0 x))) -3)")
3)
(flow-ctl-test
"branch: predicate sees the threaded input"
(flow-c
"(flow/start (sequence (lambda (x) (+ x 1)) (branch (lambda (x) (> x 3)) (flow-const 100) (flow-const 0))) 3)")
100)
(flow-ctl-test
"branch: branches are full nodes (sequence inside)"
(flow-c
"(flow/start (branch (lambda (x) (< x 10)) (sequence (lambda (x) (+ x 1)) (lambda (x) (* x 2))) (flow-const 0)) 4)")
10)
(flow-ctl-test
"branch: nested branch (3-way sign)"
(flow-c
"(defflow sign (branch (lambda (x) (> x 0)) (flow-const 1) (branch (lambda (x) (< x 0)) (flow-const -1) (flow-const 0)))) (list (flow/start sign 7) (flow/start sign -7) (flow/start sign 0))")
(list 1 -1 0))
(flow-ctl-test
"branch: publish-shaped approval gate"
(flow-cs
"(defflow publish (branch (lambda (post) (>= (string-length post) 3)) (lambda (post) (string-append post \" [published]\")) (lambda (post) (string-append post \" [rejected]\")))) (flow/start publish \"ok\")")
"ok [rejected]")
;; ── error model — explicit (fail reason) values ─────────────────
(flow-ctl-test
"fail: failed? is true for a failure value"
(flow-c "(failed? (fail 404))")
true)
(flow-ctl-test
"fail: fail-reason extracts the reason"
(flow-c "(fail-reason (fail 404))")
404)
(flow-ctl-test
"fail: failed? is false for a plain value"
(flow-c "(failed? 7)")
false)
(flow-ctl-test
"fail: failed? is false for an ordinary list"
(flow-c "(failed? (list 1 2 3))")
false)
(flow-ctl-test
"fail: a node may emit a failure as data"
(flow-c
"(defflow validate (lambda (s) (if (>= (string-length s) 3) s (fail (quote too-short))))) (failed? (flow/start validate \"hi\"))")
true)
(flow-ctl-test
"fail: failure flows downstream, branch recovers"
(flow-c
"(defflow guarded (sequence (lambda (s) (if (>= (string-length s) 3) (string-length s) (fail (quote too-short)))) (branch failed? (lambda (f) (list (quote recovered) (fail-reason f))) (lambda (n) (list (quote ok) n))))) (flow/start guarded \"hi\")")
(list "recovered" "too-short"))
;; ── try-catch — reify raised exceptions ─────────────────────────
(flow-ctl-test
"try-catch: no exception returns node result"
(flow-c "(flow/start (try-catch (lambda (x) (* x 2)) (lambda (e) -1)) 5)")
10)
(flow-ctl-test
"try-catch: handler runs on raise"
(flow-c
"(flow/start (try-catch (lambda (x) (raise (quote boom))) (flow-const 99)) 1)")
99)
(flow-ctl-test
"try-catch: handler receives the reified error"
(flow-c "(flow/start (try-catch (lambda (x) (raise 42)) (lambda (e) e)) 0)")
42)
(flow-ctl-test
"try-catch: catches exception from deep inside a sequence"
(flow-c
"(flow/start (try-catch (sequence (lambda (x) (+ x 1)) (lambda (x) (raise (quote deep)))) (flow-const -99)) 5)")
-99)
(flow-ctl-test
"try-catch: handler may convert to a failure value"
(flow-c
"(failed? (flow/start (try-catch (lambda (x) (raise (quote bad))) (lambda (e) (fail e))) 0))")
true)
(flow-ctl-test
"try-catch: composes — recover then continue"
(flow-c
"(flow/start (sequence (try-catch (lambda (x) (raise (quote x))) (flow-const 10)) (lambda (n) (* n 5))) 0)")
50)
;; ── retry — re-run on raised exceptions ─────────────────────────
(flow-ctl-test
"retry: succeeds after transient failures"
(flow-c
"(define ctr 0) (defflow flaky (lambda (x) (set! ctr (+ ctr 1)) (if (< ctr 3) (raise (quote nope)) (* x 10)))) (list (flow/start (retry 5 flaky) 7) ctr)")
(list 70 3))
(flow-ctl-test
"retry: exhausted re-raises (caught by try-catch)"
(flow-c
"(flow/start (try-catch (retry 2 (lambda (x) (raise (quote always)))) (flow-const (quote gaveup))) 0)")
"gaveup")
(flow-ctl-test
"retry: n=1 means a single attempt"
(flow-c
"(define ctr 0) (flow/start (try-catch (retry 1 (lambda (x) (set! ctr (+ ctr 1)) (raise (quote bad)))) (lambda (e) ctr)) 0)")
1)
(flow-ctl-test
"retry: success on first attempt does not re-run"
(flow-c
"(define ctr 0) (flow/start (sequence (retry 5 (lambda (x) (set! ctr (+ ctr 1)) (* x 2))) (lambda (n) ctr)) 21)")
1)
(flow-ctl-test
"retry: does not retry explicit failure values"
(flow-c
"(define ctr 0) (failed? (flow/start (retry 5 (lambda (x) (set! ctr (+ ctr 1)) (fail (quote bad)))) 0))")
true)
(flow-ctl-test
"retry: failure-value path runs node exactly once"
(flow-c
"(define ctr 0) (flow/start (sequence (retry 5 (lambda (x) (set! ctr (+ ctr 1)) (fail (quote bad)))) (lambda (f) ctr)) 0)")
1)
;; ── timeout — cooperative step budget ───────────────────────────
(flow-ctl-test
"timeout: work within budget completes"
(flow-c
"(define (cd n) (if (<= n 0) 99 (begin (tick) (cd (- n 1))))) (flow/start (try-catch (timeout 10 (lambda (x) (cd x))) (flow-const (quote timed-out))) 5)")
99)
(flow-ctl-test
"timeout: work exceeding budget raises flow-timeout"
(flow-c
"(define (cd n) (if (<= n 0) 99 (begin (tick) (cd (- n 1))))) (flow/start (try-catch (timeout 10 (lambda (x) (cd x))) (flow-const (quote timed-out))) 20)")
"timed-out")
(flow-ctl-test
"timeout: exact budget boundary completes"
(flow-c
"(define (cd n) (if (<= n 0) 99 (begin (tick) (cd (- n 1))))) (flow/start (try-catch (timeout 5 (lambda (x) (cd x))) (flow-const (quote timed-out))) 5)")
99)
(flow-ctl-test
"timeout: one tick over the budget raises"
(flow-c
"(define (cd n) (if (<= n 0) 99 (begin (tick) (cd (- n 1))))) (flow/start (try-catch (timeout 5 (lambda (x) (cd x))) (flow-const (quote timed-out))) 6)")
"timed-out")
(flow-ctl-test
"timeout: the raised error is identifiable"
(flow-c
"(define (cd n) (if (<= n 0) 99 (begin (tick) (cd (- n 1))))) (flow/start (try-catch (timeout 2 (lambda (x) (cd x))) (lambda (e) e)) 9)")
"flow-timeout")
(flow-ctl-test
"timeout: a node that never ticks is unbounded"
(flow-c "(flow/start (timeout 0 (lambda (x) (* x 2))) 5)")
10)
(flow-ctl-test
"timeout: budget is restored across sequential timeouts"
(flow-c
"(define (cd n) (if (<= n 0) 1 (begin (tick) (cd (- n 1))))) (flow/start (sequence (timeout 4 (lambda (x) (cd x))) (timeout 4 (lambda (x) (cd 3))) (lambda (x) (begin (tick) (+ x 100)))) 3)")
101)
(define flow-ctl-tests-run! (fn () {:total (+ flow-ctl-pass flow-ctl-fail) :passed flow-ctl-pass :failed flow-ctl-fail :fails flow-ctl-fails}))

120
lib/flow/tests/distributed.sx
View File

@@ -1,120 +0,0 @@
;; lib/flow/tests/distributed.sx — Phase 4: distributed nodes via fed-sx (mocked).
(define flow-dist-pass 0)
(define flow-dist-fail 0)
(define flow-dist-fails (list))
(define
flow-dist-test
(fn
(name actual expected)
(if
(= actual expected)
(set! flow-dist-pass (+ flow-dist-pass 1))
(begin
(set! flow-dist-fail (+ flow-dist-fail 1))
(append! flow-dist-fails {:name name :expected expected :actual actual})))))
(define flow-d (fn (src) (flow-run src)))
;; ── remote-node ─────────────────────────────────────────────────
(flow-dist-test
"remote: a node executes on a peer"
(flow-d
"(flow-peer-register! (quote edge) (list (list (quote double) (lambda (x) (* x 2))))) (flow/start (remote-node (quote edge) (quote double)) 21)")
42)
(flow-dist-test
"remote: remote nodes compose in a sequence"
(flow-d
"(flow-peer-register! (quote edge) (list (list (quote inc) (lambda (x) (+ x 1))) (list (quote double) (lambda (x) (* x 2))))) (flow/start (sequence (remote-node (quote edge) (quote inc)) (remote-node (quote edge) (quote double))) 4)")
10)
(flow-dist-test
"remote: a remote node mixes with local nodes"
(flow-d
"(flow-peer-register! (quote edge) (list (list (quote double) (lambda (x) (* x 2))))) (flow/start (sequence (lambda (x) (+ x 5)) (remote-node (quote edge) (quote double)) (lambda (x) (- x 1))) 10)")
29)
(flow-dist-test
"remote: unreachable peer raises flow-remote-unreachable"
(flow-d
"(flow/start (try-catch (remote-node (quote ghost) (quote double)) (lambda (e) e)) 1)")
"flow-remote-unreachable")
(flow-dist-test
"remote: unknown function on a peer raises flow-remote-no-fn"
(flow-d
"(flow-peer-register! (quote edge) (list (list (quote double) (lambda (x) (* x 2))))) (flow/start (try-catch (remote-node (quote edge) (quote missing)) (lambda (e) e)) 1)")
"flow-remote-no-fn")
(flow-dist-test
"remote: a remote node can suspend the flow (peer returns control)"
(flow-d
"(flow-peer-register! (quote edge) (list (list (quote review) (lambda (x) x)))) (flow/start (sequence (remote-node (quote edge) (quote review)) (lambda (x) (suspend (quote human))) (lambda (v) (list (quote published) v))) 7)")
(list "flow-suspended" 1 "human"))
(flow-dist-test
"remote: a transient remote failure is recoverable with retry"
(flow-d
"(define hits 0) (flow-peer-register! (quote edge) (list (list (quote flaky) (lambda (x) (begin (set! hits (+ hits 1)) (if (< hits 2) (raise (quote down)) (* x 3))))))) (list (flow/start (retry 3 (remote-node (quote edge) (quote flaky))) 7) hits)")
(list 21 2))
;; ── failover (retry on a different peer, fall through to local) ──
(flow-dist-test
"failover: first reachable peer serves the request"
(flow-d
"(flow-peer-register! (quote p2) (list (list (quote f) (lambda (x) (+ x 100))))) (flow/start (remote-failover (list (quote p2) (quote down)) (quote f) (flow-const (quote local))) 5)")
105)
(flow-dist-test
"failover: skips an unreachable peer to the next one"
(flow-d
"(flow-peer-register! (quote p2) (list (list (quote f) (lambda (x) (+ x 100))))) (flow/start (remote-failover (list (quote down) (quote p2)) (quote f) (flow-const (quote local))) 5)")
105)
(flow-dist-test
"failover: skips a peer whose function raises"
(flow-d
"(flow-peer-register! (quote bad) (list (list (quote f) (lambda (x) (raise (quote boom)))))) (flow-peer-register! (quote good) (list (list (quote f) (lambda (x) (* x 10))))) (flow/start (remote-failover (list (quote bad) (quote good)) (quote f) (flow-const 0)) 4)")
40)
(flow-dist-test
"failover: all peers fail, the local fallback runs"
(flow-d
"(flow/start (remote-failover (list (quote down1) (quote down2)) (quote f) (lambda (x) (* x -1))) 9)")
-9)
(flow-dist-test
"failover: threads the input through to the chosen peer"
(flow-d
"(flow-peer-register! (quote p) (list (list (quote f) (lambda (x) (list (quote got) x))))) (flow/start (sequence (lambda (x) (+ x 1)) (remote-failover (list (quote p)) (quote f) (flow-const 0))) 41)")
(list "got" 42))
(flow-dist-test
"failover: composes inside a larger sequence"
(flow-d
"(flow-peer-register! (quote p) (list (list (quote f) (lambda (x) (* x 2))))) (flow/start (sequence (remote-failover (list (quote down) (quote p)) (quote f) (flow-const 1)) (lambda (x) (+ x 3))) 5)")
13)
;; ── replication + handoff ───────────────────────────────────────
(flow-dist-test
"replicate: a peer holds the exported store"
(flow-d
"(defflow w (lambda (x) (suspend (quote q)))) (flow/start w 10) (flow-replicate-to (quote peerB)) (if (flow-replica-get (quote peerB)) (quote replicated) (quote missing))")
"replicated")
(flow-dist-test
"handoff: a peer resumes a flow after the local instance dies"
(flow-d
"(defflow w (sequence (lambda (x) (suspend (quote q))) (lambda (v) (list (quote done) v)))) (define id (car (cdr (flow/start w 10)))) (flow-replicate-to (quote peerB)) (set! flow-store (list)) (flow-restore-from (quote peerB)) (flow/resume id 55)")
(list "done" 55))
(flow-dist-test
"handoff: restored peer reports the flow as resumable"
(flow-d
"(defflow w (lambda (x) (suspend (quote q)))) (define id (car (cdr (flow/start w 10)))) (flow-replicate-to (quote peerB)) (set! flow-store (list)) (flow-restore-from (quote peerB)) (flow-resumable-ids)")
(list 1))
(flow-dist-test
"handoff: without restore the dead instance has lost the flow"
(flow-d
"(defflow w (lambda (x) (suspend (quote q)))) (define id (car (cdr (flow/start w 10)))) (flow-replicate-to (quote peerB)) (set! flow-store (list)) (flow/resume id 1)")
(list "flow-error" "no-such-flow"))
(flow-dist-test
"restore: from an unknown peer yields false"
(flow-d "(flow-restore-from (quote nowhere))")
false)
(flow-dist-test
"handoff: replication preserves the replay log across the move"
(flow-d
"(defflow two (sequence (lambda (x) (suspend (quote a))) (lambda (x) (suspend (quote b))) (lambda (x) (list x)))) (define id (car (cdr (flow/start two 0)))) (flow/resume id 11) (flow-replicate-to (quote peerB)) (set! flow-store (list)) (flow-restore-from (quote peerB)) (flow/resume id 22)")
(list 22))
(define flow-dist-tests-run! (fn () {:total (+ flow-dist-pass flow-dist-fail) :passed flow-dist-pass :failed flow-dist-fail :fails flow-dist-fails}))

106
lib/flow/tests/host.sx
View File

@@ -1,106 +0,0 @@
;; lib/flow/tests/host.sx — Phase 8: host integration ABI (request/await/host-queue/driver).
(define flow-hst-pass 0)
(define flow-hst-fail 0)
(define flow-hst-fails (list))
(define
flow-hst-test
(fn
(name actual expected)
(if
(= actual expected)
(set! flow-hst-pass (+ flow-hst-pass 1))
(begin
(set! flow-hst-fail (+ flow-hst-fail 1))
(append! flow-hst-fails {:name name :expected expected :actual actual})))))
(define flow-hst (fn (src) (flow-run src)))
;; ── request envelope ────────────────────────────────────────────
(flow-hst-test
"request: suspends with a typed envelope"
(flow-hst
"(car (cdr (cdr (flow/start (lambda (x) (request (quote render) x)) 5))))")
(list "flow-request" "render" 5))
(flow-hst-test
"request?: recognizes an envelope"
(flow-hst "(request? (list (quote flow-request) (quote human) 1))")
true)
(flow-hst-test
"request?: a plain tag is not a request"
(flow-hst "(request? (list (quote review) 1))")
false)
(flow-hst-test
"request-kind / request-payload: parse the envelope"
(flow-hst
"(define t (list (quote flow-request) (quote render) (list (quote recipe) 7))) (list (request-kind t) (request-payload t))")
(list "render" (list "recipe" 7)))
;; ── named decision points ───────────────────────────────────────
(flow-hst-test
"await-human: is a request of kind human"
(flow-hst
"(car (cdr (cdr (flow/start (lambda (x) (await-human x)) (quote approve?)))))")
(list "flow-request" "human" "approve?"))
(flow-hst-test
"await-render: is a request of kind render"
(flow-hst
"(car (cdr (cdr (flow/start (lambda (x) (await-render x)) (quote recipe)))))")
(list "flow-request" "render" "recipe"))
(flow-hst-test
"request: the host's resume value flows back into the flow"
(flow-hst
"(defflow f (sequence (lambda (x) (await-render x)) (lambda (art) (list (quote got) art)))) (define id (car (cdr (flow/start f 1)))) (flow/resume id (quote the-artifact))")
(list "got" "the-artifact"))
;; ── host work queue ─────────────────────────────────────────────
(flow-hst-test
"flow-host-requests: lists (id kind payload) for pending requests"
(flow-hst
"(flow/start (lambda (x) (await-render x)) 99) (flow-host-requests)")
(list (list 1 "render" 99)))
(flow-hst-test
"flow-host-requests: excludes bare (non-request) suspends"
(flow-hst
"(defflow a (lambda (x) (await-render x))) (defflow b (lambda (x) (suspend (quote plain)))) (flow/start a 1) (flow/start b 2) (flow-host-requests)")
(list (list 1 "render" 1)))
;; ── the art-dag-shaped host driver loop (manual resumes) ────────
(flow-hst-test
"host driver: render then human-review then publish"
(flow-hst
"(defflow pipeline (sequence (lambda (recipe) (await-render recipe)) (lambda (art) (await-human (list (quote review) art))) (branch (lambda (d) (eq? d (quote approve))) (flow-const (quote published)) (flow-const (fail (quote rejected)))))) (define id (car (cdr (flow/start pipeline 99)))) (define r1 (flow-host-requests)) (flow/resume id (list (quote art) 99)) (define r2 (flow-host-requests)) (flow/resume id (quote approve)) (list r1 r2 (flow/status id) (flow/result id))")
(list
(list (list 1 "render" 99))
(list (list 1 "human" (list "review" (list "art" 99))))
"done"
"published"))
(flow-hst-test
"host driver: rejection at the human gate yields a failure"
(flow-hst
"(defflow pipeline (sequence (lambda (recipe) (await-render recipe)) (lambda (art) (await-human (list (quote review) art))) (branch (lambda (d) (eq? d (quote approve))) (flow-const (quote published)) (flow-const (fail (quote rejected)))))) (define id (car (cdr (flow/start pipeline 1)))) (flow/resume id (quote artifact)) (failed? (flow/resume id (quote reject)))")
true)
;; ── reference driver: host supplies only a dispatch fn ──────────
(flow-hst-test
"flow-drive-host: one tick services every pending request"
(flow-hst
"(flow/start (lambda (x) (await-render x)) 5) (define n (flow-drive-host (lambda (k p) (list (quote done) p)))) (list n (flow/status 1) (flow/result 1))")
(list 1 "done" (list "done" 5)))
(flow-hst-test
"flow-run-host: drives a render -> human pipeline to completion"
(flow-hst
"(defflow pipeline (sequence (lambda (recipe) (await-render recipe)) (lambda (art) (await-human (list (quote review) art))) (branch (lambda (d) (eq? d (quote approve))) (flow-const (quote published)) (flow-const (fail (quote rejected)))))) (define id (car (cdr (flow/start pipeline 99)))) (define serviced (flow-run-host (lambda (kind payload) (if (eq? kind (quote render)) (list (quote art) payload) (quote approve))) 10)) (list serviced (flow/status id) (flow/result id))")
(list 2 "done" "published"))
(flow-hst-test
"flow-run-host: returns 0 when nothing is pending"
(flow-hst "(flow-run-host (lambda (k p) p) 5)")
0)
(flow-hst-test
"flow-run-host: respects the maxticks bound"
(flow-hst
"(defflow pipe2 (sequence (lambda (r) (await-render r)) (lambda (a) (await-human a)) (lambda (d) d))) (define id (car (cdr (flow/start pipe2 1)))) (define serviced (flow-run-host (lambda (k p) p) 1)) (list serviced (flow/status id))")
(list 1 "suspended"))
(define flow-hst-tests-run! (fn () {:total (+ flow-hst-pass flow-hst-fail) :passed flow-hst-pass :failed flow-hst-fail :fails flow-hst-fails}))

67
lib/flow/tests/hygiene.sx
View File

@@ -1,67 +0,0 @@
;; lib/flow/tests/hygiene.sx — Phase 5: store hygiene (flow/gc, flow/forget).
(define flow-hyg-pass 0)
(define flow-hyg-fail 0)
(define flow-hyg-fails (list))
(define
flow-hyg-test
(fn
(name actual expected)
(if
(= actual expected)
(set! flow-hyg-pass (+ flow-hyg-pass 1))
(begin
(set! flow-hyg-fail (+ flow-hyg-fail 1))
(append! flow-hyg-fails {:name name :expected expected :actual actual})))))
(define flow-h (fn (src) (flow-run src)))
;; ── flow/gc ─────────────────────────────────────────────────────
(flow-hyg-test
"gc: empty store removes nothing"
(flow-h "(flow/gc)")
0)
(flow-hyg-test
"gc: removes a done flow, keeps a suspended one"
(flow-h
"(defflow w (lambda (x) (suspend (quote q)))) (flow/start w 0) (flow/start (lambda (x) x) 5) (define removed (flow/gc)) (list removed (flow/list))")
(list 1 (list (list 1 "suspended"))))
(flow-hyg-test
"gc: removes a cancelled flow"
(flow-h
"(defflow w (lambda (x) (suspend (quote q)))) (define id (car (cdr (flow/start w 0)))) (flow/cancel id) (flow/gc)")
1)
(flow-hyg-test
"gc: a kept suspended flow is still resumable"
(flow-h
"(defflow w (sequence (lambda (x) (suspend (quote q))) (lambda (v) (* v 2)))) (define id (car (cdr (flow/start w 0)))) (flow/start (lambda (x) x) 1) (flow/gc) (flow/resume id 21)")
42)
(flow-hyg-test
"gc: counts every terminal flow it drops"
(flow-h
"(flow/start (lambda (x) x) 1) (flow/start (lambda (x) x) 2) (defflow w (lambda (x) (suspend (quote q)))) (flow/start w 0) (flow/gc)")
2)
;; ── flow/forget ─────────────────────────────────────────────────
(flow-hyg-test
"forget: drops a completed flow"
(flow-h
"(defflow w (sequence (lambda (x) (suspend (quote q))) (lambda (v) v))) (define id (car (cdr (flow/start w 0)))) (flow/resume id 7) (list (flow/forget id) (flow/status id))")
(list true "unknown"))
(flow-hyg-test
"forget: refuses to drop a live (suspended) flow"
(flow-h
"(defflow w (lambda (x) (suspend (quote q)))) (define id (car (cdr (flow/start w 0)))) (list (flow/forget id) (flow/status id))")
(list false "suspended"))
(flow-hyg-test
"forget: drops a cancelled flow"
(flow-h
"(defflow w (lambda (x) (suspend (quote q)))) (define id (car (cdr (flow/start w 0)))) (flow/cancel id) (list (flow/forget id) (flow/status id))")
(list true "unknown"))
(flow-hyg-test
"forget: unknown id yields false"
(flow-h "(flow/forget 999)")
false)
(define flow-hyg-tests-run! (fn () {:total (+ flow-hyg-pass flow-hyg-fail) :passed flow-hyg-pass :failed flow-hyg-fail :fails flow-hyg-fails}))

115
lib/flow/tests/integration.sx
View File

@@ -1,115 +0,0 @@
;; lib/flow/tests/integration.sx — Phase 7: end-to-end flows composing every phase.
(define flow-int-pass 0)
(define flow-int-fail 0)
(define flow-int-fails (list))
(define
flow-int-test
(fn
(name actual expected)
(if
(= actual expected)
(set! flow-int-pass (+ flow-int-pass 1))
(begin
(set! flow-int-fail (+ flow-int-fail 1))
(append! flow-int-fails {:name name :expected expected :actual actual})))))
(define flow-i (fn (src) (flow-run src)))
;; The order-processing flow, defined once per program via this prelude string:
;; validate amount (attempt: fail if <= 0)
;; -> suspend for payment confirmation (resume value = confirmed amount)
;; -> branch: confirmed>0 ? record on the ledger peer : declined failure
(define
order-prelude
"(flow-peer-register! (quote ledger) (list (list (quote record) (lambda (amt) (list (quote recorded) amt)))))\n (defflow order\n (attempt\n (lambda (amt) (if (> amt 0) amt (fail (quote invalid-amount))))\n (lambda (amt) (suspend (quote await-payment)))\n (branch (lambda (amt) (> amt 0))\n (remote-node (quote ledger) (quote record))\n (flow-const (fail (quote declined))))))")
;; ── happy path through every phase ──────────────────────────────
(flow-int-test
"order: validate -> suspend -> resume -> branch -> federate"
(flow-i
(str
order-prelude
"(define id (car (cdr (flow/start order 100)))) (flow/resume id 250)"))
(list "recorded" 250))
(flow-int-test
"order: starting suspends awaiting payment"
(flow-i
(str
order-prelude
"(define s (flow/start order 100)) (list (car s) (car (cdr (cdr s))))"))
(list "flow-suspended" "await-payment"))
(flow-int-test
"order: invalid amount fails up front and never suspends"
(flow-i
(str
order-prelude
"(define r (flow/start order -5)) (list (failed? r) (fail-reason r))"))
(list true "invalid-amount"))
(flow-int-test
"order: a declined payment yields a failure value"
(flow-i
(str
order-prelude
"(define id (car (cdr (flow/start order 100)))) (failed? (flow/resume id 0))"))
true)
;; ── crash recovery mid-flow ─────────────────────────────────────
(flow-int-test
"order: survives a simulated crash between suspend and resume"
(flow-i
(str
order-prelude
"(define id (car (cdr (flow/start order 100)))) (define saved (flow-store-export)) (set! flow-store (list)) (flow-store-import! saved) (flow/resume id 250)"))
(list "recorded" 250))
;; ── handoff to a peer mid-flow ──────────────────────────────────
(flow-int-test
"order: hands off to a peer that resumes and completes"
(flow-i
(str
order-prelude
"(define id (car (cdr (flow/start order 100)))) (flow-replicate-to (quote nodeB)) (set! flow-store (list)) (flow-restore-from (quote nodeB)) (flow/resume id 250)"))
(list "recorded" 250))
;; ── introspection during the flow's life ────────────────────────
(flow-int-test
"order: pending shows what the flow awaits, then result after resume"
(flow-i
(str
order-prelude
"(define id (car (cdr (flow/start order 100)))) (define p (flow/pending)) (flow/resume id 250) (list p (flow/status id) (flow/result id))"))
(list
(list (list 1 "await-payment"))
"done"
(list "recorded" 250)))
;; ── onboarding: two human steps + cancellation ──────────────────
(define
onboard-prelude
"(defflow onboard\n (sequence\n (lambda (user) (+ user 1))\n (lambda (x) (suspend (quote confirm-email)))\n (lambda (x) (suspend (quote complete-profile)))\n (lambda (x) (list (quote onboarded) x))))")
(flow-int-test
"onboard: two suspends resume in order to completion"
(flow-i
(str
onboard-prelude
"(define id (car (cdr (flow/start onboard 0)))) (flow/resume id 7) (flow/resume id 9)"))
(list "onboarded" 9))
(flow-int-test
"onboard: the second pending tag appears after the first resume"
(flow-i
(str
onboard-prelude
"(define id (car (cdr (flow/start onboard 0)))) (flow/resume id 7) (car (cdr (car (flow/pending))))"))
"complete-profile")
(flow-int-test
"onboard: cancelling abandons the flow"
(flow-i
(str
onboard-prelude
"(define id (car (cdr (flow/start onboard 0)))) (flow/cancel id) (list (flow/status id) (car (flow/resume id 7)))"))
(list "cancelled" "flow-error"))
(define flow-int-tests-run! (fn () {:total (+ flow-int-pass flow-int-fail) :passed flow-int-pass :failed flow-int-fail :fails flow-int-fails}))

73
lib/flow/tests/railway.sx
View File

@@ -1,73 +0,0 @@
;; lib/flow/tests/railway.sx — Phase 6: railway-oriented composition (attempt).
(define flow-rail-pass 0)
(define flow-rail-fail 0)
(define flow-rail-fails (list))
(define
flow-rail-test
(fn
(name actual expected)
(if
(= actual expected)
(set! flow-rail-pass (+ flow-rail-pass 1))
(begin
(set! flow-rail-fail (+ flow-rail-fail 1))
(append! flow-rail-fails {:name name :expected expected :actual actual})))))
(define flow-r (fn (src) (flow-run src)))
;; ── attempt — short-circuit on the first (fail ...) ─────────────
(flow-rail-test
"attempt: threads like sequence when nothing fails"
(flow-r
"(flow/start (attempt (lambda (x) (+ x 1)) (lambda (x) (* x 10))) 4)")
50)
(flow-rail-test
"attempt: empty is identity"
(flow-r "(flow/start (attempt) 7)")
7)
(flow-rail-test
"attempt: returns the first failure"
(flow-r
"(failed? (flow/start (attempt (lambda (x) (fail (quote bad))) (lambda (x) (* x 10))) 4))")
true)
(flow-rail-test
"attempt: the failure carries its reason"
(flow-r
"(fail-reason (flow/start (attempt (lambda (x) x) (lambda (x) (fail (quote rejected)))) 4))")
"rejected")
(flow-rail-test
"attempt: nodes after a failure do not run"
(flow-r
"(define ran 0) (flow/start (attempt (lambda (x) (fail (quote stop))) (lambda (x) (begin (set! ran (+ ran 1)) x))) 0) ran")
0)
(flow-rail-test
"attempt: a failed input short-circuits immediately"
(flow-r
"(define ran 0) (fail-reason (flow/start (attempt (lambda (x) (begin (set! ran (+ ran 1)) x))) (fail (quote pre))))")
"pre")
(flow-rail-test
"attempt: middle failure halts the chain"
(flow-r
"(define ran 0) (flow/start (attempt (lambda (x) (+ x 1)) (lambda (x) (fail (quote mid))) (lambda (x) (begin (set! ran (+ ran 1)) x))) 5) ran")
0)
;; ── attempt + recover (rejoin the happy track) ──────────────────
(flow-rail-test
"attempt + recover: recover turns a failure into a value"
(flow-r
"(flow/start (recover (attempt (lambda (x) (if (> x 0) x (fail (quote non-positive)))) (lambda (x) (* x 2))) (flow-const 0)) -5)")
0)
(flow-rail-test
"attempt + recover: happy path passes recover through"
(flow-r
"(flow/start (recover (attempt (lambda (x) (if (> x 0) x (fail (quote non-positive)))) (lambda (x) (* x 2))) (flow-const 0)) 5)")
10)
(flow-rail-test
"attempt: validation pipeline reports the failing stage"
(flow-r
"(defflow validate (attempt (lambda (s) (if (>= (string-length s) 3) s (fail (quote too-short)))) (lambda (s) (if (<= (string-length s) 8) s (fail (quote too-long)))) (lambda (s) (list (quote ok) (string-length s))))) (list (fail-reason (flow/start validate \"hi\")) (flow/start validate \"hello\"))")
(list "too-short" (list "ok" 5)))
(define flow-rail-tests-run! (fn () {:total (+ flow-rail-pass flow-rail-fail) :passed flow-rail-pass :failed flow-rail-fail :fails flow-rail-fails}))

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