From 1dacb0c8ddd6ff9cb0c5eee95451ab70f4b71f05 Mon Sep 17 00:00:00 2001 From: giles Date: Sun, 7 Jun 2026 12:14:38 +0000 Subject: [PATCH] relations: Phase 4 federation (erel trust-gating, peer_rel/trust, fed-sx mock transport, revocation) + 22 tests Co-Authored-By: Claude Opus 4.8 (1M context) --- lib/relations/api.sx | 45 ++------ lib/relations/conformance.conf | 2 + lib/relations/engine.sx | 67 ++++++++--- lib/relations/federation.sx | 70 ++++++++++++ lib/relations/scoreboard.json | 9 +- lib/relations/scoreboard.md | 3 +- lib/relations/tests/fed.sx | 203 +++++++++++++++++++++++++++++++++ plans/relations-on-sx.md | 29 ++++- 8 files changed, 366 insertions(+), 62 deletions(-) create mode 100644 lib/relations/federation.sx create mode 100644 lib/relations/tests/fed.sx diff --git a/lib/relations/api.sx b/lib/relations/api.sx index 3212e03e..1cdbedbf 100644 --- a/lib/relations/api.sx +++ b/lib/relations/api.sx @@ -1,47 +1,16 @@ -;; lib/relations/api.sx — relationship lifecycle + queries over lib/datalog/. +;; lib/relations/api.sx — relationship lifecycle + current-db convenience layer. ;; -;; A relations db is a live Datalog db holding rel(Src,Dst,Kind) facts under the -;; engine ruleset (lib/relations/engine.sx). Direct children/parents are plain -;; queries on the rel relation; transitive reachability/roots/leaves/cycles come -;; from the engine's recursive rules. -;; -;; Two surfaces: db-threading core fns (relations-children-of db ...) and a -;; current-db convenience layer (relations/relate ...) for callers that load a -;; fact base once and query without passing the db around. This mirrors lib/acl. +;; A relations db is a live Datalog db holding rel(Src,Dst,Kind) facts (and, for +;; federation, peer_rel/trust facts) under the engine ruleset +;; (lib/relations/engine.sx). The query functions live in engine.sx; this module +;; owns db construction, the assert/retract lifecycle, and a current-db +;; convenience layer for callers that load a fact base once and query without +;; threading the db around. This mirrors lib/acl/api.sx. (define relations-build-db (fn (facts) (dl-program-data facts relations-rules))) -;; Direct children: every Dst with rel(node, Dst, kind). -(define - relations-children-of - (fn - (db node kind) - (relations-pluck - (dl-query db (list (quote rel) node (quote Dst) kind)) - :Dst))) - -;; Direct parents: every Src with rel(Src, node, kind). -(define - relations-parents-of - (fn - (db node kind) - (relations-pluck - (dl-query db (list (quote rel) (quote Src) node kind)) - :Src))) - -;; Directly related: neighbours in either direction under kind. -(define - relations-related - (fn - (db node kind) - (append - (relations-children-of db node kind) - (relations-parents-of db node kind)))) - -;; --- current-db convenience layer --- - (define relations-current-db nil) (define diff --git a/lib/relations/conformance.conf b/lib/relations/conformance.conf index dbc8652b..eb83b880 100644 --- a/lib/relations/conformance.conf +++ b/lib/relations/conformance.conf @@ -18,10 +18,12 @@ PRELOADS=( lib/relations/engine.sx lib/relations/api.sx lib/relations/explain.sx + lib/relations/federation.sx ) SUITES=( "direct:lib/relations/tests/direct.sx:(relations-direct-tests-run!)" "reach:lib/relations/tests/reach.sx:(relations-reach-tests-run!)" "path:lib/relations/tests/path.sx:(relations-path-tests-run!)" + "fed:lib/relations/tests/fed.sx:(relations-fed-tests-run!)" ) diff --git a/lib/relations/engine.sx b/lib/relations/engine.sx index d8ac6f6f..b165cd47 100644 --- a/lib/relations/engine.sx +++ b/lib/relations/engine.sx @@ -1,12 +1,22 @@ ;; lib/relations/engine.sx — recursive reachability + roots/leaves + cycles. ;; -;; The whole engine is one Datalog ruleset. Reachability is the bottom-up -;; transitive closure acl-on-sx uses for inheritance, but parameterised by Kind -;; so closures never leak across kinds: `reach` carries the kind as its first -;; argument, so a `parent` walk can never cross a `reply` edge. +;; The whole engine is one Datalog ruleset, derived from the EFFECTIVE relation +;; `erel`, not raw `rel`. `erel` unions local edges with trust-gated federated +;; edges: ;; -;; reach(K,X,Y) :- rel(X,Y,K). ; one hop -;; reach(K,X,Y) :- rel(X,Z,K), reach(K,Z,Y). ; transitive +;; erel(S,D,K) :- rel(S,D,K). ; local edge, always +;; erel(S,D,K) :- peer_rel(P,S,D,K), trust(P). ; peer edge, gated by trust +;; +;; Trust is a body literal, re-checked every query, so revoking trust (or a peer +;; link) takes effect on the next saturation. Trust is NOT transitive — only a +;; peer's own links, under a local trust(P) fact, bind. With no peer_rel/trust +;; facts, erel ≡ rel, so non-federated behaviour is unchanged. +;; +;; Reachability is the bottom-up transitive closure acl-on-sx uses for +;; inheritance, parameterised by Kind so closures never leak across kinds: +;; +;; reach(K,X,Y) :- erel(X,Y,K). ; one hop +;; reach(K,X,Y) :- erel(X,Z,K), reach(K,Z,Y). ; transitive ;; ;; `reach_any` is the kind-agnostic closure (any edge, any kind) used for ;; mixed-kind reachability — distinct from single-kind `reach`. @@ -19,14 +29,16 @@ (define relations-rules (quote - ((reach K X Y <- (rel X Y K)) - (reach K X Y <- (rel X Z K) (reach K Z Y)) - (reach_any X Y <- (rel X Y K)) - (reach_any X Y <- (rel X Z K) (reach_any Z Y)) - (rnode K X <- (rel X Y K)) - (rnode K Y <- (rel X Y K)) - (has_parent K Y <- (rel X Y K)) - (has_child K X <- (rel X Y K)) + ((erel S D K <- (rel S D K)) + (erel S D K <- (peer_rel P S D K) (trust P)) + (reach K X Y <- (erel X Y K)) + (reach K X Y <- (erel X Z K) (reach K Z Y)) + (reach_any X Y <- (erel X Y K)) + (reach_any X Y <- (erel X Z K) (reach_any Z Y)) + (rnode K X <- (erel X Y K)) + (rnode K Y <- (erel X Y K)) + (has_parent K Y <- (erel X Y K)) + (has_child K X <- (erel X Y K)) (root K X <- (rnode K X) {:neg (has_parent K X)}) (leaf K X <- (rnode K X) {:neg (has_child K X)})))) @@ -35,6 +47,33 @@ relations-pluck (fn (substs key) (map (fn (s) (get s key)) substs))) +;; Direct children: every Dst with an effective edge erel(node, Dst, kind). +(define + relations-children-of + (fn + (db node kind) + (relations-pluck + (dl-query db (list (quote erel) node (quote Dst) kind)) + :Dst))) + +;; Direct parents: every Src with an effective edge erel(Src, node, kind). +(define + relations-parents-of + (fn + (db node kind) + (relations-pluck + (dl-query db (list (quote erel) (quote Src) node kind)) + :Src))) + +;; Directly related: neighbours in either direction under kind. +(define + relations-related + (fn + (db node kind) + (append + (relations-children-of db node kind) + (relations-parents-of db node kind)))) + ;; Transitive descendants of node under kind (everything reachable forward). (define relations-descendants diff --git a/lib/relations/federation.sx b/lib/relations/federation.sx new file mode 100644 index 00000000..24867d5a --- /dev/null +++ b/lib/relations/federation.sx @@ -0,0 +1,70 @@ +;; lib/relations/federation.sx — cross-instance links + trust + revocation. +;; +;; fed-sx replicates relationship facts between instances; this module models the +;; local side. A peer's link arrives as `peer_rel(Peer, Src, Dst, Kind)` and only +;; becomes an effective edge when a local `trust(Peer)` fact authorises it — the +;; gating is the engine rule (lib/relations/engine.sx), re-checked every query, +;; so revoking trust or a link takes effect on the next saturation. The network +;; transport is fed-sx's job and is mocked here as a dict. +;; +;; Trust is NOT transitive: trusting peer α binds only links α itself asserts; +;; α's own trust in some β does not flow. + +;; A federated link asserted by `peer`: peer claims rel(src,dst,kind) holds. +(define + relations-peer-rel + (fn (peer src dst kind) (list (quote peer_rel) peer src dst kind))) + +;; Local trust in a peer. Gates that peer's links at query time. +(define relations-trust (fn (peer) (list (quote trust) peer))) + +;; Mock fed-sx pull: `transport` maps a peer address (its string name) to the +;; list of peer_rel facts that peer asserts. Returns the facts for `addr`, or an +;; empty list if the peer is unknown / unreachable. +(define + relations-fed-fetch + (fn + (transport addr) + (let + ((k (if (symbol? addr) (symbol->string addr) addr))) + (if (has-key? transport k) (get transport k) (list))))) + +;; Gather peer_rel facts from every peer in `addrs` via the transport. +(define + relations-fed-collect + (fn + (transport addrs) + (let + ((acc (list))) + (do + (for-each + (fn + (addr) + (for-each + (fn (f) (append! acc f)) + (relations-fed-fetch transport addr))) + addrs) + acc)))) + +;; Build a db from local facts plus peer_rel facts pulled from `peers`. Local +;; facts must carry the trust policy (trust(...) facts); replicated links are +;; gated against it by the engine rule at query time. +(define + relations-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)) + (relations-fed-collect transport peers)) + (relations-build-db all))))) + +;; Ingest a newly replicated fact into a live db (re-saturates). +(define relations-fed-assert! (fn (db fact) (do (dl-assert! db fact) db))) + +;; Propagated revocation: retract a replicated link or a local trust fact from a +;; live db. The next query re-saturates and reflects it. +(define relations-revoke! (fn (db fact) (do (dl-retract! db fact) db))) diff --git a/lib/relations/scoreboard.json b/lib/relations/scoreboard.json index 40b93347..29896f59 100644 --- a/lib/relations/scoreboard.json +++ b/lib/relations/scoreboard.json @@ -1,12 +1,13 @@ { "lang": "relations", - "total_passed": 70, + "total_passed": 92, "total_failed": 0, - "total": 70, + "total": 92, "suites": [ {"name":"direct","passed":22,"failed":0,"total":22}, {"name":"reach","passed":24,"failed":0,"total":24}, - {"name":"path","passed":24,"failed":0,"total":24} + {"name":"path","passed":24,"failed":0,"total":24}, + {"name":"fed","passed":22,"failed":0,"total":22} ], - "generated": "2026-06-07T12:04:11+00:00" + "generated": "2026-06-07T12:14:10+00:00" } diff --git a/lib/relations/scoreboard.md b/lib/relations/scoreboard.md index e662ad83..e67ca3c1 100644 --- a/lib/relations/scoreboard.md +++ b/lib/relations/scoreboard.md @@ -1,9 +1,10 @@ # relations scoreboard -**70 / 70 passing** (0 failure(s)). +**92 / 92 passing** (0 failure(s)). | Suite | Passed | Total | Status | |-------|--------|-------|--------| | direct | 22 | 22 | ok | | reach | 24 | 24 | ok | | path | 24 | 24 | ok | +| fed | 22 | 22 | ok | diff --git a/lib/relations/tests/fed.sx b/lib/relations/tests/fed.sx new file mode 100644 index 00000000..b5a2747b --- /dev/null +++ b/lib/relations/tests/fed.sx @@ -0,0 +1,203 @@ +;; lib/relations/tests/fed.sx — Phase 4: federation (peer links, trust gating, +;; cross-instance chains, revocation). fed-sx transport is mocked as a dict. + +(define relations-ft-pass 0) +(define relations-ft-fail 0) +(define relations-ft-failures (list)) + +(define + relations-ft-check! + (fn + (name got expected) + (if + (= got expected) + (set! relations-ft-pass (+ relations-ft-pass 1)) + (do + (set! relations-ft-fail (+ relations-ft-fail 1)) + (append! + relations-ft-failures + (str name "\n expected: " expected "\n got: " got)))))) + +(define + relations-ft-subset? + (fn + (xs ys) + (cond + ((= (len xs) 0) true) + ((relations-member? (first xs) ys) + (relations-ft-subset? (rest xs) ys)) + (else false)))) + +(define + relations-ft-set=? + (fn + (xs ys) + (and + (= (len xs) (len ys)) + (relations-ft-subset? xs ys) + (relations-ft-subset? ys xs)))) + +;; Local edge a->b; peerA claims b->c; peerB claims c->d. Local trust only in +;; peerA. With trust gating, a reaches c (via peerA's b->c) but not d. +(define + relations-ft-facts + (fn + () + (list + (relations-rel (quote a) (quote b) (quote parent)) + (relations-peer-rel (quote peerA) (quote b) (quote c) (quote parent)) + (relations-peer-rel (quote peerB) (quote c) (quote d) (quote parent)) + (relations-trust (quote peerA))))) + +(define + relations-ft-run-all! + (fn + () + (do + (let + ((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-peer-rel (quote peerX) (quote b) (quote c) (quote parent)))))) + (do + (relations-ft-check! + "untrusted link: c not a child of b" + (relations-children-of db (quote b) (quote parent)) + (list)) + (relations-ft-check! + "untrusted link: a cannot reach c" + (relations-reachable? db (quote a) (quote c) (quote parent)) + false))) + (let + ((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-peer-rel (quote peerX) (quote b) (quote c) (quote parent)) (relations-trust (quote peerX)))))) + (do + (relations-ft-check! + "trusted link: c is a child of b" + (relations-ft-set=? + (relations-children-of db (quote b) (quote parent)) + (list (quote c))) + true) + (relations-ft-check! + "trusted link: federated reachability a->c" + (relations-reachable? db (quote a) (quote c) (quote parent)) + true) + (relations-ft-check! + "trusted link: connecting path crosses the federated edge" + (relations-path db (quote a) (quote c) (quote parent)) + (list (quote a) (quote b) (quote c))))) + (let + ((db (relations-build-db (relations-ft-facts)))) + (do + (relations-ft-check! + "non-transitive: a reaches c (peerA trusted)" + (relations-reachable? db (quote a) (quote c) (quote parent)) + true) + (relations-ft-check! + "non-transitive: a does not reach d (peerB untrusted)" + (relations-reachable? db (quote a) (quote d) (quote parent)) + false) + (relations-ft-check! + "non-transitive: d is not a child of c" + (relations-children-of db (quote c) (quote parent)) + (list)))) + (let + ((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-peer-rel (quote peerX) (quote b) (quote c) (quote parent)) (relations-trust (quote peerX)))))) + (do + (relations-ft-check! + "before link revoke: a reaches c" + (relations-reachable? db (quote a) (quote c) (quote parent)) + true) + (relations-revoke! + db + (relations-peer-rel + (quote peerX) + (quote b) + (quote c) + (quote parent))) + (relations-ft-check! + "after link revoke: a cannot reach c" + (relations-reachable? db (quote a) (quote c) (quote parent)) + false))) + (let + ((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-peer-rel (quote peerX) (quote b) (quote c) (quote parent)) (relations-trust (quote peerX)))))) + (do + (relations-ft-check! + "before trust revoke: c is a child of b" + (relations-ft-set=? + (relations-children-of db (quote b) (quote parent)) + (list (quote c))) + true) + (relations-revoke! db (relations-trust (quote peerX))) + (relations-ft-check! + "after trust revoke: federated edge gone" + (relations-children-of db (quote b) (quote parent)) + (list)) + (relations-ft-check! + "after trust revoke: local edge survives" + (relations-ft-set=? + (relations-children-of db (quote a) (quote parent)) + (list (quote b))) + true))) + (let + ((transport {:peerB (list (relations-peer-rel (quote peerB) (quote c) (quote d) (quote parent))) :peerA (list (relations-peer-rel (quote peerA) (quote b) (quote c) (quote parent)))})) + (do + (relations-ft-check! + "fed-fetch returns a peer's links" + (len (relations-fed-fetch transport (quote peerA))) + 1) + (relations-ft-check! + "fed-fetch unknown peer -> empty" + (relations-fed-fetch transport (quote nobody)) + (list)) + (relations-ft-check! + "fed-collect over two peers" + (len + (relations-fed-collect + transport + (list (quote peerA) (quote peerB)))) + 2) + (let + ((db (relations-fed-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-trust (quote peerA))) transport (list (quote peerA) (quote peerB))))) + (do + (relations-ft-check! + "fed-build: trusted peerA link binds (a->c)" + (relations-reachable? db (quote a) (quote c) (quote parent)) + true) + (relations-ft-check! + "fed-build: untrusted peerB link does not bind (a->d)" + (relations-reachable? db (quote a) (quote d) (quote parent)) + false))))) + (let + ((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-trust (quote peerX)))))) + (do + (relations-ft-check! + "before fed-assert: a cannot reach c" + (relations-reachable? db (quote a) (quote c) (quote parent)) + false) + (relations-fed-assert! + db + (relations-peer-rel + (quote peerX) + (quote b) + (quote c) + (quote parent))) + (relations-ft-check! + "after fed-assert: a reaches c" + (relations-reachable? db (quote a) (quote c) (quote parent)) + true))) + (relations-ft-check! + "peer-rel constructor shape" + (relations-peer-rel (quote p) (quote s) (quote d) (quote k)) + (list (quote peer_rel) (quote p) (quote s) (quote d) (quote k))) + (relations-ft-check! + "trust constructor shape" + (relations-trust (quote p)) + (list (quote trust) (quote p)))))) + +(define + relations-fed-tests-run! + (fn + () + (do + (set! relations-ft-pass 0) + (set! relations-ft-fail 0) + (set! relations-ft-failures (list)) + (relations-ft-run-all!) + {:failures relations-ft-failures :total (+ relations-ft-pass relations-ft-fail) :passed relations-ft-pass :failed relations-ft-fail}))) diff --git a/plans/relations-on-sx.md b/plans/relations-on-sx.md index 669c82ee..56ec10e6 100644 --- a/plans/relations-on-sx.md +++ b/plans/relations-on-sx.md @@ -18,7 +18,7 @@ links. Reuses `lib/datalog/` — does not reimplement the engine. ## Status (rolling) -`bash lib/relations/conformance.sh` → **70/70** (Phases 1–3 complete) +`bash lib/relations/conformance.sh` → **92/92** (Phases 1–4 complete) ## Ground rules @@ -89,17 +89,36 @@ lib/relations/federation.sx ## Phase 4 — Federation -- [ ] cross-instance relationships — a peer asserts `rel(local, remote, kind)`; +- [x] cross-instance relationships — a peer asserts `rel(local, remote, kind)`; replicate rel facts via fed-sx (mock the transport in tests) -- [ ] trust gating — a peer's link binds locally only under a local trust fact +- [x] trust gating — a peer's link binds locally only under a local trust fact (mirror acl's non-transitive `trust`/gate-in-engine model; do NOT copy acl code, re-derive the shape) -- [ ] revocation — retract a replicated link; reachability re-saturates -- [ ] `lib/relations/tests/fed.sx` — federated reachability chains, trust gating, +- [x] revocation — retract a replicated link; reachability re-saturates +- [x] `lib/relations/tests/fed.sx` — federated reachability chains, trust gating, revocation ## Progress log +- **Phase 4 — federation** (92/92). Re-derived acl's trust-gate shape (not + copied). engine.sx now derives the whole engine from an EFFECTIVE relation + `erel` rather than raw `rel`: `erel(S,D,K) :- rel(S,D,K)` (local, always) and + `erel(S,D,K) :- peer_rel(P,S,D,K), trust(P)` (peer link, gated by a local trust + fact). reach/reach_any/rnode/has_parent/has_child all read `erel`, and the + direct-query fns moved into engine.sx to query `erel` too — so with no + peer_rel/trust facts `erel ≡ rel` and Phases 1–3 are unchanged. Trust is a body + literal, re-checked every saturation, so it is non-transitive (only a peer's own + links bind, only under local trust(P)) and revocation is immediate. New + federation.sx: `relations-peer-rel`/`relations-trust` constructors, a mock + fed-sx transport (`relations-fed-fetch`/`-collect` over a peer→links dict), + `relations-fed-build-db` (local facts + pulled peer links), and + `relations-fed-assert!`/`relations-revoke!` over a live db. fed.sx covers + untrusted-link-doesn't-bind, trusted-link-binds (child + federated reachability + + connecting path through the federated edge), non-transitive trust (peerB's + link inert without trust(peerB)), link revocation, trust revocation (local edge + survives), transport pull with selective trust, and live fed-assert!. The shared + recursive-reachability shape with acl is flagged (Phase 2 note); the trust-gate + is the same convergence — still NOT extracted, per ground rules. - **Phase 3 — typed relations + path explanation** (70/70). New `explain.sx`: `relations-path(db,a,b,kind)` is relations' answer to acl's proof tree — the `reach(K,a,b)` derivation read off as the node chain. lib/datalog/ keeps no