coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
b308effb9f27ea6418bc5a75381c5e14b2a57e85
rose-ash/lib/acl/tests/fed.sx
giles 40be9cd074
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 10m25s
Details
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>
2026-06-06 16:54:34 +00:00

274 lines
10 KiB
Plaintext
Raw Blame History

;; 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})))
Reference in New Issue View Git Blame Copy Permalink