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) <noreply@anthropic.com>

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
+;; A relations db is a live Datalog db holding rel(Src,Dst,Kind) facts (and, for
-;; engine ruleset (lib/relations/engine.sx). Direct children/parents are plain
+;; federation, peer_rel/trust facts) under the engine ruleset
-;; queries on the rel relation; transitive reachability/roots/leaves/cycles come
+;; (lib/relations/engine.sx). The query functions live in engine.sx; this module
-;; from the engine's recursive rules.
+;; owns db construction, the assert/retract lifecycle, and a current-db
-;;
+;; convenience layer for callers that load a fact base once and query without
-;; Two surfaces: db-threading core fns (relations-children-of db ...) and a
+;; threading the db around. This mirrors lib/acl/api.sx.
-;; 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.
 
 (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

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

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
+;; The whole engine is one Datalog ruleset, derived from the EFFECTIVE relation
-;; transitive closure acl-on-sx uses for inheritance, but parameterised by Kind
+;; `erel`, not raw `rel`. `erel` unions local edges with trust-gated federated
-;; so closures never leak across kinds: `reach` carries the kind as its first
+;; edges:
-;; argument, so a `parent` walk can never cross a `reply` edge.
 ;;
-;;   reach(K,X,Y) :- rel(X,Y,K).                  ; one hop
+;;   erel(S,D,K) :- rel(S,D,K).                       ; local edge, always
-;;   reach(K,X,Y) :- rel(X,Z,K), reach(K,Z,Y).    ; transitive
+;;   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))
+    ((erel S D K <- (rel S D K))
-      (reach K X Y <- (rel X Z K) (reach K Z Y))
+      (erel S D K <- (peer_rel P S D K) (trust P))
-      (reach_any X Y <- (rel X Y K))
+      (reach K X Y <- (erel X Y K))
-      (reach_any X Y <- (rel X Z K) (reach_any Z Y))
+      (reach K X Y <- (erel X Z K) (reach K Z Y))
-      (rnode K X <- (rel X Y K))
+      (reach_any X Y <- (erel X Y K))
-      (rnode K Y <- (rel X Y K))
+      (reach_any X Y <- (erel X Z K) (reach_any Z Y))
-      (has_parent K Y <- (rel X Y K))
+      (rnode K X <- (erel X Y K))
-      (has_child K X <- (rel 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

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

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

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 |

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

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
+- [x] revocation — retract a replicated link; reachability re-saturates
-- [ ] `lib/relations/tests/fed.sx` — federated reachability chains, trust gating,
+- [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