acl: Phase 4 federation (trust-gated delegation, revocation) + 31 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 10m25s

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>
This commit is contained in:
2026-06-06 16:54:34 +00:00
parent 15c97119e4
commit 40be9cd074
9 changed files with 436 additions and 18 deletions

View File

@@ -19,6 +19,7 @@ PRELOADS=(
lib/acl/engine.sx
lib/acl/explain.sx
lib/acl/audit.sx
lib/acl/federation.sx
lib/acl/api.sx
)
@@ -26,4 +27,5 @@ 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!)"
)

View File

@@ -4,12 +4,14 @@
;; 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 with deny-overrides:
;; 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
@@ -18,15 +20,22 @@
;; 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. Deny inherits through the *same* group
;; and resource chains as grant, so a group-level or ancestor-resource deny is
;; authoritative for members/descendants — not just a deny naming the exact
;; (S,A,R). This is the principled, fail-safe reading of "deny wins".
;; (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).
;; 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).
@@ -37,6 +46,14 @@
(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))

View File

@@ -6,6 +6,7 @@
;; 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)))
@@ -25,3 +26,22 @@
(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 Normal file
View File

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

View File

@@ -16,7 +16,9 @@
;; Phase 1: actor/resource/grant/deny.
;; Phase 2: member_of (subject->group/role), child_of (resource->parent),
;; role_grant (role->action,resource).
(define acl-edb-arity {:role_grant 3 :child_of 2 :actor 2 :member_of 2 :deny 3 :grant 3 :resource 2})
;; 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?

View File

@@ -1,12 +1,13 @@
{
"lang": "acl",
"total_passed": 89,
"total_passed": 120,
"total_failed": 0,
"total": 89,
"total": 120,
"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":"explain","passed":35,"failed":0,"total":35},
{"name":"fed","passed":31,"failed":0,"total":31}
],
"generated": "2026-06-06T16:46:37+00:00"
"generated": "2026-06-06T16:53:44+00:00"
}

View File

@@ -1,9 +1,10 @@
# acl scoreboard
**89 / 89 passing** (0 failure(s)).
**120 / 120 passing** (0 failure(s)).
| Suite | Passed | Total | Status |
|-------|--------|-------|--------|
| direct | 24 | 24 | ok |
| inherit | 30 | 30 | ok |
| explain | 35 | 35 | ok |
| fed | 31 | 31 | ok |

273
lib/acl/tests/fed.sx Normal file
View File

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

View File

@@ -15,7 +15,7 @@ and federation extension. Reuses `lib/datalog/` evaluator and term model where p
## Status (rolling)
`bash lib/acl/conformance.sh`**89/89** (Phases 1-3 complete)
`bash lib/acl/conformance.sh`**120/120** (all four phases complete)
## Ground rules
@@ -122,11 +122,33 @@ pure.
## Phase 4 — Federation
- [ ] peer trust facts — `peer(addr, kind)`, `trust(peer, level)`
- [ ] delegated grants — `delegate(peer, actor, action, resource)`
- [ ] cross-instance permit chain — query asks local + queries trusted peers via fed-sx
- [ ] revocation propagation — fact retraction across federation
- [ ] `lib/acl/tests/fed.sx` — federated grant chains (mock fed-sx transport in tests)
- [x] peer trust facts — `peer(addr, kind)`, `trust(peer, level)`
- [x] delegated grants — `delegate(peer, actor, action, resource)`
- [x] cross-instance permit chain — query asks local + queries trusted peers via fed-sx
- [x] revocation propagation — fact retraction across federation
- [x] `lib/acl/tests/fed.sx` — federated grant chains (mock fed-sx transport in tests)
### federation policy (the choice)
One engine rule carries federation:
`eff_grant(S,A,R) :- delegate(Peer,S,A,R), trust(Peer,L), level_covers(L,A)`.
- **Non-transitive trust.** A peer's `delegate` only grants if a *local*
`trust(Peer,L)` exists and that level `level_covers` the action. There is no
peer-to-peer trust propagation — trusting α never extends to peers α trusts.
- **Trust re-checked every query.** `trust`/`level_covers` are body literals
evaluated at decision time, never baked in at ingestion. Revoking trust or
narrowing a level takes effect on the next `acl-permit?`.
- **Deny still wins.** Federated grants are `eff_grant`, so local (and inherited)
deny overrides them exactly as for local grants.
- **Composes with inheritance.** A delegate to a group flows to members; a
delegate on a parent resource flows to children (federated `eff_grant` feeds
the same recursion).
- **Revocation = retraction.** `acl-revoke!` wraps `dl-retract!`; the next query
re-saturates. `acl-fed-assert!` wraps `dl-assert!` for newly-replicated facts.
- **Transport is fed-sx's job.** `lib/acl/federation.sx` mocks the pull as a
dict {peer-addr → delegate-facts}; `acl-fed-build-db` merges local policy +
pulled delegates.
## Progress log
@@ -177,6 +199,25 @@ pure.
name-based `acl-et-eq?` (compare symbols via `symbol->string`), matching the
datalog suite's `dl-api-deep=?` convention. Worth flagging to the kernel
owners but out of acl scope.
- **Phase 4 complete (120/120, +31 fed).** Added `federation.sx` (mock
transport + `acl-fed-build-db`/`acl-revoke!`/`acl-fed-assert!`), one engine
rule (the trust-gated delegate rule), 4 fact constructors, 4 schema arities.
Federated proofs reconstruct for free — `explain.sx` iterates `acl-rules`, so
the delegate rule's EDB body (`delegate`/`trust`/`level_covers`) shows up as
proof leaves with no explain changes. **Roadmap done: all four phases green.**
- **Shared-plumbing final note (for `lib/guest/rules/`):** the durable
reusable seam across acl-sx and the coming mod-sx is exactly four
pass-throughs to the rule engine — `build-db(facts)`, `decide(ground-query)
-> bool`, `explain(goal) -> proof-tree`, and the revoke/assert mutators.
The *rulesets* and *vocabulary* are language-specific (ACL: grant/deny/
member_of/...; mod-sx: Prolog moderation predicates). When mod-sx lands,
extract those four functions (engine.sx + the generic half of explain.sx's
goal-directed reconstructor) into `lib/guest/rules/`, leaving each consumer
its own rules + fact constructors. Proof reconstruction is the non-obvious
reusable piece: it only needs the ruleset as data + a saturated db, both of
which any datalog-backed guest has.
- **dict-mode conformance is slow, not hung:** all suites load + run in one
process (~30-40s for 120 tests, no per-suite timeout). Do not kill early.
- **Tooling note:** sx-tree path-based edit tools (`sx_replace_node`,
`sx_read_subtree` with a path) ignored the path argument in this worktree
(always resolved to index 0 / `[0,..]`), in BOTH `(a b c)` and `(a,b,c)`