acl: Phase 4 federation (trust-gated delegation, revocation) + 31 tests

federation.sx adds peer/trust/delegate/level_covers facts and one engine
rule: delegated grants apply only when local trust covers the action,
re-checked every query (non-transitive, fail-safe). Local/inherited deny
overrides federated grants; delegation composes with group and resource
inheritance. acl-revoke!/acl-fed-assert! propagate retraction/assertion;
mock fed-sx transport for tests. Federated proofs reconstruct via the
existing explainer. Roadmap complete: 120/120.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>

lib/acl/tests/fed.sx

@@ -0,0 +1,273 @@
+;; 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})))