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