acl: hardening suite (+25) — diamonds, cycles, validation, audit save/restore
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 35s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 35s
New adversarial/cross-phase coverage: diamond resource+group hierarchies (deny wins per path), chain inheritance + leaf deny, cycle termination, multi-peer delegation, fact validation, audit snapshot/restore round-trip. Adds acl-validate-facts/acl-facts-valid? (schema) and acl-audit-snapshot/ restore!/copy (audit). Fixed acl-audit-restore! rebuilding the live log via map (append! silently no-ops on map-derived lists). Suite is prover-free: a substrate JIT bug loops the recursive proof reconstructor on deep chains in warm processes (documented in Blockers); acl-permit? is unaffected. 145/145. Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
This commit is contained in:
228
lib/acl/tests/harden.sx
Normal file
228
lib/acl/tests/harden.sx
Normal file
@@ -0,0 +1,228 @@
|
||||
;; lib/acl/tests/harden.sx — adversarial / cross-phase hardening.
|
||||
;;
|
||||
;; Diamond hierarchies, conflict resolution where deny must win through every
|
||||
;; path, chain inheritance, cycle termination, multi-peer delegation, fact
|
||||
;; validation, and audit save/restore.
|
||||
;;
|
||||
;; PROVER-FREE BY DESIGN: this suite calls only acl-permit? (which runs in
|
||||
;; compiled Datalog, safe at any depth) plus pure data ops — never acl-explain /
|
||||
;; acl-prove-d. The SX-side proof reconstructor recurses, and once the kernel
|
||||
;; JIT-compiles it (after the explain/fed suites warm the process) it loops on
|
||||
;; chains deeper than ~3 (substrate JIT bug — see plan Blockers). Proof
|
||||
;; reconstruction is covered by tests/explain.sx (and federated proofs by
|
||||
;; tests/fed.sx), both of which stay under the warm-process depth threshold.
|
||||
|
||||
(define acl-hd-pass 0)
|
||||
(define acl-hd-fail 0)
|
||||
(define acl-hd-failures (list))
|
||||
|
||||
(define
|
||||
acl-hd-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! acl-hd-pass (+ acl-hd-pass 1))
|
||||
(do
|
||||
(set! acl-hd-fail (+ acl-hd-fail 1))
|
||||
(append!
|
||||
acl-hd-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
(define acl-hd-p? (fn (db s a r) (acl-permit? db s a r)))
|
||||
|
||||
(define
|
||||
acl-hd-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(let
|
||||
((grant-deny (acl-build-db (list (acl-child-of (quote r) (quote p1)) (acl-child-of (quote r) (quote p2)) (acl-grant (quote u) (quote read) (quote p1)) (acl-deny (quote u) (quote read) (quote p2)))))
|
||||
(both-grant
|
||||
(acl-build-db
|
||||
(list
|
||||
(acl-child-of (quote r) (quote p1))
|
||||
(acl-child-of (quote r) (quote p2))
|
||||
(acl-grant (quote u) (quote read) (quote p1))
|
||||
(acl-grant (quote u) (quote read) (quote p2))))))
|
||||
(do
|
||||
(acl-hd-check!
|
||||
"diamond resource: grant+deny parents -> deny wins"
|
||||
(acl-hd-p? grant-deny (quote u) (quote read) (quote r))
|
||||
false)
|
||||
(acl-hd-check!
|
||||
"diamond resource: both grant -> permit"
|
||||
(acl-hd-p? both-grant (quote u) (quote read) (quote r))
|
||||
true)
|
||||
(acl-hd-check!
|
||||
"diamond resource: deny does not leak to other parent"
|
||||
(acl-hd-p? grant-deny (quote u) (quote read) (quote p1))
|
||||
true)))
|
||||
(let
|
||||
((grant-deny (acl-build-db (list (acl-member-of (quote alice) (quote g1)) (acl-member-of (quote alice) (quote g2)) (acl-grant (quote g1) (quote read) (quote doc)) (acl-deny (quote g2) (quote read) (quote doc)))))
|
||||
(both-grant
|
||||
(acl-build-db
|
||||
(list
|
||||
(acl-member-of (quote alice) (quote g1))
|
||||
(acl-member-of (quote alice) (quote g2))
|
||||
(acl-grant (quote g1) (quote read) (quote doc))
|
||||
(acl-grant (quote g2) (quote read) (quote doc))))))
|
||||
(do
|
||||
(acl-hd-check!
|
||||
"diamond group: grant+deny groups -> deny wins"
|
||||
(acl-hd-p? grant-deny (quote alice) (quote read) (quote doc))
|
||||
false)
|
||||
(acl-hd-check!
|
||||
"diamond group: both grant -> permit"
|
||||
(acl-hd-p? both-grant (quote alice) (quote read) (quote doc))
|
||||
true)))
|
||||
(let
|
||||
((chain (acl-build-db (list (acl-member-of (quote a0) (quote a1)) (acl-member-of (quote a1) (quote a2)) (acl-member-of (quote a2) (quote a3)) (acl-member-of (quote a3) (quote a4)) (acl-grant (quote a4) (quote read) (quote res)))))
|
||||
(chain-deny
|
||||
(acl-build-db
|
||||
(list
|
||||
(acl-member-of (quote a0) (quote a1))
|
||||
(acl-member-of (quote a1) (quote a2))
|
||||
(acl-member-of (quote a2) (quote a3))
|
||||
(acl-member-of (quote a3) (quote a4))
|
||||
(acl-grant (quote a4) (quote read) (quote res))
|
||||
(acl-deny (quote a0) (quote read) (quote res))))))
|
||||
(do
|
||||
(acl-hd-check!
|
||||
"chain: top-group grant reaches leaf member"
|
||||
(acl-hd-p? chain (quote a0) (quote read) (quote res))
|
||||
true)
|
||||
(acl-hd-check!
|
||||
"chain: intermediate also covered"
|
||||
(acl-hd-p? chain (quote a2) (quote read) (quote res))
|
||||
true)
|
||||
(acl-hd-check!
|
||||
"chain: leaf-member deny overrides top grant"
|
||||
(acl-hd-p? chain-deny (quote a0) (quote read) (quote res))
|
||||
false)
|
||||
(acl-hd-check!
|
||||
"chain: deny on leaf does not block sibling level"
|
||||
(acl-hd-p? chain-deny (quote a1) (quote read) (quote res))
|
||||
true)))
|
||||
(let
|
||||
((self-member (acl-build-db (list (acl-member-of (quote a) (quote a)) (acl-grant (quote a) (quote read) (quote r)))))
|
||||
(self-child
|
||||
(acl-build-db
|
||||
(list
|
||||
(acl-child-of (quote r) (quote r))
|
||||
(acl-grant (quote u) (quote read) (quote r)))))
|
||||
(two-cycle
|
||||
(acl-build-db
|
||||
(list
|
||||
(acl-member-of (quote x) (quote y))
|
||||
(acl-member-of (quote y) (quote x))
|
||||
(acl-grant (quote y) (quote read) (quote r))))))
|
||||
(do
|
||||
(acl-hd-check!
|
||||
"self-membership cycle terminates and grants"
|
||||
(acl-hd-p? self-member (quote a) (quote read) (quote r))
|
||||
true)
|
||||
(acl-hd-check!
|
||||
"self-child cycle terminates and grants"
|
||||
(acl-hd-p? self-child (quote u) (quote read) (quote r))
|
||||
true)
|
||||
(acl-hd-check!
|
||||
"two-node membership cycle terminates"
|
||||
(acl-hd-p? two-cycle (quote x) (quote read) (quote r))
|
||||
true)))
|
||||
(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-deny (quote alice) (quote read) (quote doc))))))
|
||||
(acl-hd-check!
|
||||
"federated group grant, local member deny -> deny wins"
|
||||
(acl-hd-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 bob) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
|
||||
(acl-hd-check!
|
||||
"two peers delegate, one trusted -> permit"
|
||||
(acl-hd-p? db (quote bob) (quote read) (quote doc))
|
||||
true))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-trust (quote beta) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote bob) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
|
||||
(acl-hd-check!
|
||||
"two peers both trusted -> permit"
|
||||
(acl-hd-p? db (quote bob) (quote read) (quote doc))
|
||||
true))
|
||||
(let
|
||||
((empty (acl-build-db (list))))
|
||||
(acl-hd-check!
|
||||
"empty db: nothing permitted"
|
||||
(acl-hd-p? empty (quote u) (quote read) (quote r))
|
||||
false))
|
||||
(do
|
||||
(acl-hd-check!
|
||||
"validate: clean set has no bad facts"
|
||||
(len
|
||||
(acl-validate-facts
|
||||
(list
|
||||
(acl-grant (quote u) (quote read) (quote p))
|
||||
(acl-member-of (quote u) (quote g))
|
||||
(acl-delegate (quote pe) (quote u) (quote read) (quote p)))))
|
||||
0)
|
||||
(acl-hd-check!
|
||||
"validate: facts-valid? true on clean set"
|
||||
(acl-facts-valid?
|
||||
(list (acl-grant (quote u) (quote read) (quote p))))
|
||||
true)
|
||||
(acl-hd-check!
|
||||
"validate: surfaces wrong-arity and unknown predicate"
|
||||
(len
|
||||
(acl-validate-facts
|
||||
(list
|
||||
(acl-grant (quote u) (quote read) (quote p))
|
||||
(list (quote grant) (quote u))
|
||||
(list (quote bogus) (quote x) (quote y)))))
|
||||
2)
|
||||
(acl-hd-check!
|
||||
"validate: empty set is valid"
|
||||
(acl-facts-valid? (list))
|
||||
true))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-grant (quote u) (quote read) (quote p)) (acl-deny (quote u) (quote edit) (quote p))))))
|
||||
(do
|
||||
(acl-audit-clear!)
|
||||
(acl-audit-decide! db (quote u) (quote read) (quote p))
|
||||
(acl-audit-decide! db (quote u) (quote edit) (quote p))
|
||||
(let
|
||||
((snap (acl-audit-snapshot)))
|
||||
(do
|
||||
(acl-audit-clear!)
|
||||
(acl-hd-check!
|
||||
"audit: cleared count is 0"
|
||||
(acl-audit-count)
|
||||
0)
|
||||
(acl-audit-restore! snap)
|
||||
(acl-hd-check!
|
||||
"audit: restored count"
|
||||
(acl-audit-count)
|
||||
2)
|
||||
(acl-hd-check!
|
||||
"audit: restored last act"
|
||||
(get (first (acl-audit-tail 1)) :act)
|
||||
(quote edit))
|
||||
(acl-audit-decide! db (quote u) (quote comment) (quote p))
|
||||
(acl-hd-check!
|
||||
"audit: seq continues after restore"
|
||||
(get (first (acl-audit-tail 1)) :seq)
|
||||
2)
|
||||
(acl-hd-check!
|
||||
"audit: snapshot is an immutable copy"
|
||||
(len (get snap :entries))
|
||||
2)
|
||||
(acl-audit-clear!))))))))
|
||||
|
||||
(define
|
||||
acl-harden-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! acl-hd-pass 0)
|
||||
(set! acl-hd-fail 0)
|
||||
(set! acl-hd-failures (list))
|
||||
(acl-hd-run-all!)
|
||||
{:failures acl-hd-failures :total (+ acl-hd-pass acl-hd-fail) :passed acl-hd-pass :failed acl-hd-fail})))
|
||||
Reference in New Issue
Block a user