diff --git a/lib/acl/api.sx b/lib/acl/api.sx new file mode 100644 index 00000000..acb8c97b --- /dev/null +++ b/lib/acl/api.sx @@ -0,0 +1,45 @@ +;; lib/acl/api.sx — public ACL surface over an implicit current db. +;; +;; Callers load a fact set once, then issue decisions without threading the db +;; through every call. The current db is module state; (acl/load! facts) rebuilds +;; it. This is the boundary the rest of rose-ash imports. + +(define acl-current-db nil) + +;; Replace the current fact base. Rebuilds the Datalog db under the active +;; ruleset (see lib/acl/engine.sx). +(define + acl/load! + (fn + (facts) + (do (set! acl-current-db (acl-build-db facts)) acl-current-db))) + +;; Ensure a db exists, building an empty one on first use. +(define + acl-ensure-db! + (fn + () + (do + (when + (= acl-current-db nil) + (set! acl-current-db (acl-build-db (list)))) + acl-current-db))) + +;; Public decision against the current db (pure, no logging). +(define + acl/permit? + (fn (subj act res) (acl-permit? (acl-ensure-db!) subj act res))) + +;; Decision-with-proof against the current db. See lib/acl/explain.sx. +(define + acl/explain + (fn (subj act res) (acl-explain (acl-ensure-db!) subj act res))) + +;; Audited decision: logs the outcome to the append-only audit log and returns +;; the boolean. See lib/acl/audit.sx. +(define + acl/audit + (fn (subj act res) (acl-audit-decide! (acl-ensure-db!) subj act res))) + +;; Recent audited decisions (chronological). +(define acl/audit-tail (fn (n) (acl-audit-tail n))) diff --git a/lib/acl/audit.sx b/lib/acl/audit.sx new file mode 100644 index 00000000..94324db5 --- /dev/null +++ b/lib/acl/audit.sx @@ -0,0 +1,110 @@ +;; lib/acl/audit.sx — append-only decision log. +;; +;; Every decision routed through acl-audit-decide! is appended to an in-memory +;; log with a monotonic sequence number (no wall-clock — deterministic and +;; testable; a host can stamp time at the serializer boundary). The log is +;; append-only: there is no mutate or delete, only append, tail, clear, +;; snapshot/restore, and serialize-for-disk. + +(define acl-audit-log (list)) +(define acl-audit-seq 0) + +;; Copy a list into a fresh, append!-able list. `map`/`rest`-derived lists are +;; NOT extensible by append! in this runtime (it silently no-ops), so the live +;; log must always be a list built with `list` + `append!`. +(define + acl-audit-copy + (fn + (xs) + (let + ((fresh (list))) + (do (for-each (fn (e) (append! fresh e)) xs) fresh)))) + +(define + acl-audit-clear! + (fn + () + (do (set! acl-audit-log (list)) (set! acl-audit-seq 0) nil))) + +;; Append a decision record. Returns the record. +(define + acl-audit-record! + (fn + (subj act res allowed?) + (let + ((entry {:allowed? allowed? :act act :subj subj :res res :seq acl-audit-seq})) + (do + (set! acl-audit-seq (+ acl-audit-seq 1)) + (append! acl-audit-log entry) + entry)))) + +;; Decide against db, log the outcome, and return the boolean. This is the +;; audited path; acl-permit? remains the pure, side-effect-free decision. +(define + acl-audit-decide! + (fn + (db subj act res) + (let + ((allowed? (acl-permit? db subj act res))) + (do (acl-audit-record! subj act res allowed?) allowed?)))) + +(define acl-audit-count (fn () (len acl-audit-log))) + +;; Most recent n entries (in chronological order). n >= log size returns all. +(define + acl-audit-tail + (fn + (n) + (let + ((total (len acl-audit-log))) + (if + (<= total n) + acl-audit-log + (acl-audit-drop acl-audit-log (- total n)))))) + +(define + acl-audit-drop + (fn + (xs k) + (if (<= k 0) xs (acl-audit-drop (rest xs) (- k 1))))) + +;; Structured snapshot for save/restore — a {:seq :entries} value carrying a +;; copy of the log (so later appends don't mutate a held snapshot). +(define acl-audit-snapshot (fn () {:seq acl-audit-seq :entries (acl-audit-copy acl-audit-log)})) + +;; Replace the live log from a snapshot. Restores both entries and the seq +;; counter so subsequent records continue numbering correctly. The log is +;; rebuilt as a fresh append!-able list (see acl-audit-copy). +(define + acl-audit-restore! + (fn + (snap) + (do + (set! acl-audit-log (acl-audit-copy (get snap :entries))) + (set! acl-audit-seq (get snap :seq)) + nil))) + +;; Serialize the whole log to a disk-ready string: one record per line, +;; "seq\tsubj\tact\tres\tallowed?". A host writes this; structured reload is via +;; snapshot/restore. +(define + acl-audit-serialize + (fn + () + (reduce + (fn + (acc e) + (str + acc + (get e :seq) + "\t" + (get e :subj) + "\t" + (get e :act) + "\t" + (get e :res) + "\t" + (get e :allowed?) + "\n")) + "" + acl-audit-log))) diff --git a/lib/acl/conformance.conf b/lib/acl/conformance.conf new file mode 100644 index 00000000..5992b8ce --- /dev/null +++ b/lib/acl/conformance.conf @@ -0,0 +1,32 @@ +# ACL conformance config — sourced by lib/guest/conformance.sh. + +LANG_NAME=acl +MODE=dict + +PRELOADS=( + lib/datalog/tokenizer.sx + lib/datalog/parser.sx + lib/datalog/unify.sx + lib/datalog/db.sx + lib/datalog/builtins.sx + lib/datalog/aggregates.sx + lib/datalog/strata.sx + lib/datalog/eval.sx + lib/datalog/api.sx + lib/datalog/magic.sx + lib/acl/schema.sx + lib/acl/facts.sx + lib/acl/engine.sx + lib/acl/explain.sx + lib/acl/audit.sx + lib/acl/federation.sx + lib/acl/api.sx +) + +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!)" + "harden:lib/acl/tests/harden.sx:(acl-harden-tests-run!)" +) diff --git a/lib/acl/conformance.sh b/lib/acl/conformance.sh new file mode 100755 index 00000000..225bea24 --- /dev/null +++ b/lib/acl/conformance.sh @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +# Thin wrapper — see lib/guest/conformance.sh and lib/acl/conformance.conf. +exec bash "$(dirname "$0")/../guest/conformance.sh" "$(dirname "$0")/conformance.conf" "$@" diff --git a/lib/acl/engine.sx b/lib/acl/engine.sx new file mode 100644 index 00000000..77efd55a --- /dev/null +++ b/lib/acl/engine.sx @@ -0,0 +1,72 @@ +;; lib/acl/engine.sx — ACL ruleset + decision reducer over lib/datalog/. +;; +;; The engine is a thin layer: it owns the permit ruleset (SX data rules) and +;; 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 + 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 +;; eff_deny(S,A,R) :- child_of(R,P), eff_deny(S,A,P). ; resource tree +;; +;; 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 — 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). 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). + +(define + acl-rules + (quote + ((eff_grant S A R <- (grant S A R)) + (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)) + (permit S A R <- (eff_grant S A R) {:neg (eff_deny S A R)})))) + +;; Build a Datalog db from a list of EDB facts under the ACL ruleset. +(define acl-build-db (fn (facts) (dl-program-data facts acl-rules))) + +;; Core decision: does the db permit subject S to perform action A on +;; resource R? Reduces to a ground Datalog query on the derived `permit` +;; relation — non-empty result means permitted. +(define + acl-permit? + (fn + (db subj act res) + (> (len (dl-query db (list (quote permit) subj act res))) 0))) diff --git a/lib/acl/explain.sx b/lib/acl/explain.sx new file mode 100644 index 00000000..c452e520 --- /dev/null +++ b/lib/acl/explain.sx @@ -0,0 +1,125 @@ +;; lib/acl/explain.sx — proof-tree reconstruction over the saturated db. +;; +;; lib/datalog/ records derived facts but not their provenance, so the proof is +;; reconstructed here by goal-directed search over the *saturated* db: for a +;; ground goal we find the first ACL rule (in rule order) whose body holds, take +;; the first solution binding its remaining variables, and recurse on each body +;; literal. Negated literals are recorded as verified `:neg-ok` leaves. +;; +;; CANONICAL DERIVATION: the Datalog derivation graph is a DAG (a fact may hold +;; many ways). We pick ONE canonical proof — first matching rule, first solution +;; — matching the rule order in lib/acl/engine.sx (direct/EDB rules first). A +;; depth cap guards against pathological cyclic data producing unbounded search. +;; +;; A proof node is one of: +;; {:fact :via "edb"} — base EDB fact +;; {:fact :rule :body ( ...)} — derived +;; {:neg-ok } — negation verified to fail +;; {:fact :truncated true} — depth cap hit + +(define acl-proof-max-depth 64) + +;; Substitute a body literal, descending into {:neg ...} dicts (dl-apply-subst +;; does not recurse into dicts, which would leak the neg's free vars). +(define + acl-subst-lit + (fn + (lit s) + (if + (and (dict? lit) (has-key? lit :neg)) + {:neg (dl-apply-subst (get lit :neg) s)} + (dl-apply-subst lit s)))) + +(define + acl-lit-edb? + (fn + (lit) + (and + (list? lit) + (> (len lit) 0) + (symbol? (first lit)) + (has-key? acl-edb-arity (symbol->string (first lit)))))) + +(define + acl-subst-zip! + (fn + (d ks vs) + (when + (> (len ks) 0) + (do + (dict-set! d (symbol->string (first ks)) (first vs)) + (acl-subst-zip! d (rest ks) (rest vs)))))) + +;; Bind a rule head's variables to a ground goal's arguments (positional). +(define + acl-bind-head + (fn + (head goal) + (let + ((d {})) + (do (acl-subst-zip! d (rest head) (rest goal)) d)))) + +(define + acl-subst-union + (fn + (a b) + (let + ((d {})) + (do + (for-each (fn (k) (dict-set! d k (get a k))) (keys a)) + (for-each (fn (k) (dict-set! d k (get b k))) (keys b)) + d)))) + +(define acl-prove (fn (db goal) (acl-prove-d db goal 0))) + +(define + acl-prove-d + (fn + (db goal depth) + (cond + ((> depth acl-proof-max-depth) {:truncated true :fact goal}) + ((acl-lit-edb? goal) + (if (> (len (dl-query db goal)) 0) {:via "edb" :fact goal} nil)) + (else (acl-prove-rules db goal acl-rules depth))))) + +(define + acl-prove-rules + (fn + (db goal rules depth) + (if + (= (len rules) 0) + nil + (let + ((p (dl-rule-from-list (first rules)))) + (if + (= (first (get p :head)) (first goal)) + (let + ((hs (acl-bind-head (get p :head) goal))) + (let + ((qbody (map (fn (l) (acl-subst-lit l hs)) (get p :body)))) + (let + ((sols (dl-query db qbody))) + (if + (> (len sols) 0) + (acl-prove-build db goal p hs (first sols) depth) + (acl-prove-rules db goal (rest rules) depth))))) + (acl-prove-rules db goal (rest rules) depth)))))) + +(define + acl-prove-build + (fn + (db goal p hs sol depth) + (let ((full (acl-subst-union hs sol))) {:body (map (fn (l) (let ((g (acl-subst-lit l full))) (if (and (dict? g) (has-key? g :neg)) {:neg-ok (get g :neg)} (acl-prove-d db g (+ depth 1))))) (get p :body)) :rule (get p :head) :fact goal}))) + +;; Public decision-with-proof. Returns: +;; {:allowed? :proof :reason } +;; When permitted, :proof is the permit derivation. When denied, :proof is nil +;; and :reason carries the blocking eff_deny proof if one exists (an explicit or +;; inherited deny), else nil (simply no grant). +(define + acl-explain + (fn + (db subj act res) + (let + ((proof (acl-prove db (list (quote permit) subj act res)))) + (if (= proof nil) {:allowed? false :proof nil :reason (acl-prove db (list (quote eff_deny) subj act res))} {:allowed? true :proof proof :reason nil})))) diff --git a/lib/acl/facts.sx b/lib/acl/facts.sx new file mode 100644 index 00000000..3b6ed468 --- /dev/null +++ b/lib/acl/facts.sx @@ -0,0 +1,47 @@ +;; lib/acl/facts.sx — EDB fact constructors. +;; +;; Each constructor returns a Datalog fact tuple (a list whose head is the +;; predicate symbol). These are the only shapes lib/acl/engine.sx feeds to +;; lib/datalog/. +;; 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))) + +(define acl-resource-fact (fn (id kind) (list (quote resource) id kind))) + +(define acl-grant (fn (subj act res) (list (quote grant) subj act res))) + +(define acl-deny (fn (subj act res) (list (quote deny) subj act res))) + +;; subject S is a member of group/role G (one hop; transitivity is derived). +(define acl-member-of (fn (subj grp) (list (quote member_of) subj grp))) + +;; resource R is a child of parent P (one hop; transitivity is derived). +(define acl-child-of (fn (res parent) (list (quote child_of) res parent))) + +;; role confers capability (act on res) to every member of the role. +(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))) diff --git a/lib/acl/federation.sx b/lib/acl/federation.sx new file mode 100644 index 00000000..68a59151 --- /dev/null +++ b/lib/acl/federation.sx @@ -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))) diff --git a/lib/acl/schema.sx b/lib/acl/schema.sx new file mode 100644 index 00000000..21f78c46 --- /dev/null +++ b/lib/acl/schema.sx @@ -0,0 +1,71 @@ +;; lib/acl/schema.sx — ACL sorts and EDB predicate vocabulary. +;; +;; Datalog is untyped; this module is the schema-as-data layer. It declares +;; the subject/resource/action sorts and the arity of every EDB predicate the +;; ACL engine recognises, plus light validators. Facts that pass these checks +;; are well-formed inputs to lib/acl/engine.sx. + +(define acl-subject-kinds (quote (user group role service))) +(define acl-resource-kinds (quote (page post thread peer))) + +;; Actions are open-ended (a grant may name any action symbol), but these are +;; the platform's well-known verbs. +(define acl-actions (quote (read edit comment moderate federate))) + +;; EDB predicate name -> arity. +;; Phase 1: actor/resource/grant/deny. +;; Phase 2: member_of (subject->group/role), child_of (resource->parent), +;; role_grant (role->action,resource). +;; 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? + (fn + (x xs) + (cond + ((= (len xs) 0) false) + ((= (first xs) x) true) + (else (acl-member? x (rest xs)))))) + +(define acl-subject-kind? (fn (k) (acl-member? k acl-subject-kinds))) + +(define acl-resource-kind? (fn (k) (acl-member? k acl-resource-kinds))) + +(define acl-known-action? (fn (a) (acl-member? a acl-actions))) + +;; A fact is a list whose head is a predicate symbol. Valid when the predicate +;; is known and the argument count matches the declared arity. +(define + acl-fact-valid? + (fn + (f) + (and + (list? f) + (> (len f) 0) + (symbol? (first f)) + (let + ((pred (symbol->string (first f)))) + (and + (has-key? acl-edb-arity pred) + (= (- (len f) 1) (get acl-edb-arity pred))))))) + +;; Return the sublist of facts that fail acl-fact-valid?. Empty list means the +;; whole set is well-formed. acl-build-db stays lenient (Datalog accepts any +;; tuple, and custom action symbols are allowed); callers opt in to checking. +(define + acl-validate-facts + (fn + (facts) + (let + ((bad (list))) + (do + (for-each + (fn (f) (when (not (acl-fact-valid? f)) (append! bad f))) + facts) + bad)))) + +(define + acl-facts-valid? + (fn (facts) (= (len (acl-validate-facts facts)) 0))) diff --git a/lib/acl/scoreboard.json b/lib/acl/scoreboard.json new file mode 100644 index 00000000..2eb9ee59 --- /dev/null +++ b/lib/acl/scoreboard.json @@ -0,0 +1,14 @@ +{ + "lang": "acl", + "total_passed": 145, + "total_failed": 0, + "total": 145, + "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":"fed","passed":31,"failed":0,"total":31}, + {"name":"harden","passed":25,"failed":0,"total":25} + ], + "generated": "2026-06-06T22:43:27+00:00" +} diff --git a/lib/acl/scoreboard.md b/lib/acl/scoreboard.md new file mode 100644 index 00000000..7de786ea --- /dev/null +++ b/lib/acl/scoreboard.md @@ -0,0 +1,11 @@ +# acl scoreboard + +**145 / 145 passing** (0 failure(s)). + +| Suite | Passed | Total | Status | +|-------|--------|-------|--------| +| direct | 24 | 24 | ok | +| inherit | 30 | 30 | ok | +| explain | 35 | 35 | ok | +| fed | 31 | 31 | ok | +| harden | 25 | 25 | ok | diff --git a/lib/acl/tests/direct.sx b/lib/acl/tests/direct.sx new file mode 100644 index 00000000..279f6ba8 --- /dev/null +++ b/lib/acl/tests/direct.sx @@ -0,0 +1,170 @@ +;; lib/acl/tests/direct.sx — Phase 1: direct grants + deny-overrides. + +(define acl-dt-pass 0) +(define acl-dt-fail 0) +(define acl-dt-failures (list)) + +(define + acl-dt-check! + (fn + (name got expected) + (if + (= got expected) + (set! acl-dt-pass (+ acl-dt-pass 1)) + (do + (set! acl-dt-fail (+ acl-dt-fail 1)) + (append! + acl-dt-failures + (str name "\n expected: " expected "\n got: " got)))))) + +;; A small fixture used by most cases: alice can read page1, is denied edit on +;; page1, and a service may federate peer1. +(define + acl-dt-fixture + (fn + () + (acl-build-db + (list + (acl-actor (quote alice) (quote user)) + (acl-actor (quote svc1) (quote service)) + (acl-resource-fact (quote page1) (quote page)) + (acl-resource-fact (quote peer1) (quote peer)) + (acl-grant (quote alice) (quote read) (quote page1)) + (acl-grant (quote alice) (quote edit) (quote page1)) + (acl-deny (quote alice) (quote edit) (quote page1)) + (acl-grant (quote svc1) (quote federate) (quote peer1)))))) + +(define + acl-dt-run-all! + (fn + () + (let + ((db (acl-dt-fixture))) + (do + (acl-dt-check! + "direct grant permits" + (acl-permit? db (quote alice) (quote read) (quote page1)) + true) + (acl-dt-check! + "service grant permits federate" + (acl-permit? db (quote svc1) (quote federate) (quote peer1)) + true) + (acl-dt-check! + "missing action denied" + (acl-permit? db (quote alice) (quote comment) (quote page1)) + false) + (acl-dt-check! + "missing resource denied" + (acl-permit? db (quote alice) (quote read) (quote page2)) + false) + (acl-dt-check! + "missing subject denied" + (acl-permit? db (quote bob) (quote read) (quote page1)) + false) + (acl-dt-check! + "wrong subject for service grant denied" + (acl-permit? db (quote alice) (quote federate) (quote peer1)) + false) + (acl-dt-check! + "grant plus deny -> deny wins" + (acl-permit? db (quote alice) (quote edit) (quote page1)) + false) + (acl-dt-check! + "deny alone still denies" + (acl-permit? + (acl-build-db + (list (acl-deny (quote alice) (quote read) (quote page1)))) + (quote alice) + (quote read) + (quote page1)) + false) + (acl-dt-check! + "deny on edit does not block read" + (acl-permit? db (quote alice) (quote read) (quote page1)) + true) + (acl-dt-check! + "empty db denies" + (acl-permit? + (acl-build-db (list)) + (quote alice) + (quote read) + (quote page1)) + false) + (let + ((db2 (acl-build-db (list (acl-grant (quote a) (quote read) (quote r)) (acl-grant (quote b) (quote read) (quote r)) (acl-deny (quote b) (quote read) (quote r)))))) + (do + (acl-dt-check! + "subject a allowed" + (acl-permit? db2 (quote a) (quote read) (quote r)) + true) + (acl-dt-check! + "subject b denied by override" + (acl-permit? db2 (quote b) (quote read) (quote r)) + false))) + (let + ((db3 (acl-build-db (list (acl-actor (quote editors) (quote role)) (acl-grant (quote editors) (quote edit) (quote post1)))))) + (acl-dt-check! + "role subject direct grant" + (acl-permit? db3 (quote editors) (quote edit) (quote post1)) + true)) + (do + (acl/load! + (list + (acl-grant (quote carol) (quote moderate) (quote thread1)))) + (acl-dt-check! + "api permit via current db" + (acl/permit? (quote carol) (quote moderate) (quote thread1)) + true) + (acl-dt-check! + "api deny via current db" + (acl/permit? (quote carol) (quote read) (quote thread1)) + false)) + (do + (acl/load! (list)) + (acl-dt-check! + "api reload clears prior grants" + (acl/permit? (quote carol) (quote moderate) (quote thread1)) + false)) + (acl-dt-check! + "schema grant arity valid" + (acl-fact-valid? (acl-grant (quote x) (quote read) (quote y))) + true) + (acl-dt-check! + "schema bad arity invalid" + (acl-fact-valid? (list (quote grant) (quote x))) + false) + (acl-dt-check! + "schema unknown predicate invalid" + (acl-fact-valid? (list (quote frobnicate) (quote x))) + false) + (acl-dt-check! + "schema subject kind known" + (acl-subject-kind? (quote service)) + true) + (acl-dt-check! + "schema resource kind unknown" + (acl-resource-kind? (quote galaxy)) + false) + (acl-dt-check! + "schema known action" + (acl-known-action? (quote moderate)) + true) + (acl-dt-check! + "grant constructor shape" + (acl-grant (quote u) (quote read) (quote p)) + (list (quote grant) (quote u) (quote read) (quote p))) + (acl-dt-check! + "actor constructor shape" + (acl-actor (quote u) (quote user)) + (list (quote actor) (quote u) (quote user))))))) + +(define + acl-direct-tests-run! + (fn + () + (do + (set! acl-dt-pass 0) + (set! acl-dt-fail 0) + (set! acl-dt-failures (list)) + (acl-dt-run-all!) + {:failures acl-dt-failures :total (+ acl-dt-pass acl-dt-fail) :passed acl-dt-pass :failed acl-dt-fail}))) diff --git a/lib/acl/tests/explain.sx b/lib/acl/tests/explain.sx new file mode 100644 index 00000000..a58a740e --- /dev/null +++ b/lib/acl/tests/explain.sx @@ -0,0 +1,316 @@ +;; lib/acl/tests/explain.sx — Phase 3: proof correctness + audit completeness. + +(define acl-et-pass 0) +(define acl-et-fail 0) +(define acl-et-failures (list)) + +;; Name-based deep equality. The host `=` compares symbols by interned +;; identity, which is unstable across substitution/saturation; comparing by +;; name (as the datalog suite does) makes structural assertions deterministic. +(define + acl-et-eq? + (fn + (a b) + (cond + ((and (list? a) (list? b)) + (and (= (len a) (len b)) (acl-et-eq-l? a b 0))) + ((and (dict? a) (dict? b)) + (let + ((ka (keys a)) (kb (keys b))) + (and (= (len ka) (len kb)) (acl-et-eq-d? a b ka 0)))) + ((and (symbol? a) (symbol? b)) + (= (symbol->string a) (symbol->string b))) + (else (= a b))))) + +(define + acl-et-eq-l? + (fn + (a b i) + (cond + ((>= i (len a)) true) + ((not (acl-et-eq? (nth a i) (nth b i))) false) + (else (acl-et-eq-l? a b (+ i 1)))))) + +(define + acl-et-eq-d? + (fn + (a b ka i) + (cond + ((>= i (len ka)) true) + ((let ((k (nth ka i))) (not (acl-et-eq? (get a k) (get b k)))) + false) + (else (acl-et-eq-d? a b ka (+ i 1)))))) + +(define + acl-et-check! + (fn + (name got expected) + (if + (acl-et-eq? got expected) + (set! acl-et-pass (+ acl-et-pass 1)) + (do + (set! acl-et-fail (+ acl-et-fail 1)) + (append! + acl-et-failures + (str name "\n expected: " expected "\n got: " got)))))) + +;; --- proof-tree walkers --- + +;; True if EDB fact `target` appears as a base leaf anywhere in the proof. +(define + acl-et-has-leaf? + (fn + (node target) + (cond + ((= node nil) false) + ((and (dict? node) (has-key? node :via)) + (acl-et-eq? (get node :fact) target)) + ((and (dict? node) (has-key? node :body)) + (acl-et-any-leaf? (get node :body) target)) + (else false)))) + +(define + acl-et-any-leaf? + (fn + (nodes target) + (cond + ((= (len nodes) 0) false) + ((acl-et-has-leaf? (first nodes) target) true) + (else (acl-et-any-leaf? (rest nodes) target))))) + +;; True if the proof records a verified negation (deny did not fire). +(define + acl-et-has-negok? + (fn + (node) + (cond + ((= node nil) false) + ((and (dict? node) (has-key? node :neg-ok)) true) + ((and (dict? node) (has-key? node :body)) + (acl-et-any-negok? (get node :body))) + (else false)))) + +(define + acl-et-any-negok? + (fn + (nodes) + (cond + ((= (len nodes) 0) false) + ((acl-et-has-negok? (first nodes)) true) + (else (acl-et-any-negok? (rest nodes)))))) + +(define + acl-et-run-all! + (fn + () + (do + (let + ((db (acl-build-db (list (acl-grant (quote u) (quote read) (quote p)))))) + (let + ((e (acl-explain db (quote u) (quote read) (quote p)))) + (do + (acl-et-check! "direct: allowed?" (get e :allowed?) true) + (acl-et-check! + "direct: proof root fact" + (get (get e :proof) :fact) + (list (quote permit) (quote u) (quote read) (quote p))) + (acl-et-check! + "direct: grant leaf present" + (acl-et-has-leaf? + (get e :proof) + (list (quote grant) (quote u) (quote read) (quote p))) + true) + (acl-et-check! + "direct: negation verified" + (acl-et-has-negok? (get e :proof)) + true) + (acl-et-check! + "direct: reason nil when allowed" + (get e :reason) + nil)))) + (let + ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-member-of (quote team) (quote org)) (acl-grant (quote org) (quote read) (quote doc)))))) + (let + ((e (acl-explain db (quote alice) (quote read) (quote doc)))) + (do + (acl-et-check! "group: allowed?" (get e :allowed?) true) + (acl-et-check! + "group: member_of alice leaf" + (acl-et-has-leaf? + (get e :proof) + (list (quote member_of) (quote alice) (quote team))) + true) + (acl-et-check! + "group: member_of team leaf" + (acl-et-has-leaf? + (get e :proof) + (list (quote member_of) (quote team) (quote org))) + true) + (acl-et-check! + "group: grant org leaf at base" + (acl-et-has-leaf? + (get e :proof) + (list (quote grant) (quote org) (quote read) (quote doc))) + true)))) + (let + ((db (acl-build-db (list (acl-child-of (quote sec) (quote book)) (acl-grant (quote u) (quote read) (quote book)))))) + (let + ((e (acl-explain db (quote u) (quote read) (quote sec)))) + (do + (acl-et-check! "resource: allowed?" (get e :allowed?) true) + (acl-et-check! + "resource: child_of leaf" + (acl-et-has-leaf? + (get e :proof) + (list (quote child_of) (quote sec) (quote book))) + true) + (acl-et-check! + "resource: grant on parent leaf" + (acl-et-has-leaf? + (get e :proof) + (list (quote grant) (quote u) (quote read) (quote book))) + true)))) + (let + ((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-role-grant (quote editor) (quote edit) (quote page1)))))) + (let + ((e (acl-explain db (quote bob) (quote edit) (quote page1)))) + (do + (acl-et-check! "role: allowed?" (get e :allowed?) true) + (acl-et-check! + "role: member_of leaf" + (acl-et-has-leaf? + (get e :proof) + (list (quote member_of) (quote bob) (quote editor))) + true) + (acl-et-check! + "role: role_grant leaf" + (acl-et-has-leaf? + (get e :proof) + (list + (quote role_grant) + (quote editor) + (quote edit) + (quote page1))) + true)))) + (let + ((db (acl-build-db (list (acl-grant (quote u) (quote edit) (quote p)) (acl-deny (quote u) (quote edit) (quote p)))))) + (let + ((e (acl-explain db (quote u) (quote edit) (quote p)))) + (do + (acl-et-check! "deny: not allowed" (get e :allowed?) false) + (acl-et-check! "deny: no proof" (get e :proof) nil) + (acl-et-check! + "deny: reason root is eff_deny" + (get (get e :reason) :fact) + (list (quote eff_deny) (quote u) (quote edit) (quote p))) + (acl-et-check! + "deny: reason has deny leaf" + (acl-et-has-leaf? + (get e :reason) + (list (quote deny) (quote u) (quote edit) (quote p))) + true)))) + (let + ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote alice) (quote read) (quote doc)) (acl-deny (quote team) (quote read) (quote doc)))))) + (let + ((e (acl-explain db (quote alice) (quote read) (quote doc)))) + (do + (acl-et-check! + "inherited deny: not allowed" + (get e :allowed?) + false) + (acl-et-check! + "inherited deny: reason has member_of leaf" + (acl-et-has-leaf? + (get e :reason) + (list (quote member_of) (quote alice) (quote team))) + true) + (acl-et-check! + "inherited deny: reason has group deny leaf" + (acl-et-has-leaf? + (get e :reason) + (list (quote deny) (quote team) (quote read) (quote doc))) + true)))) + (let + ((db (acl-build-db (list)))) + (let + ((e (acl-explain db (quote u) (quote read) (quote p)))) + (do + (acl-et-check! "no grant: not allowed" (get e :allowed?) false) + (acl-et-check! "no grant: proof nil" (get e :proof) nil) + (acl-et-check! "no grant: reason nil" (get e :reason) nil)))) + (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-et-check! "audit: starts empty" (acl-audit-count) 0) + (acl-et-check! + "audit decide allowed returns true" + (acl-audit-decide! db (quote u) (quote read) (quote p)) + true) + (acl-et-check! + "audit decide denied returns false" + (acl-audit-decide! db (quote u) (quote edit) (quote p)) + false) + (acl-audit-decide! db (quote u) (quote comment) (quote p)) + (acl-et-check! + "audit: count after three decisions" + (acl-audit-count) + 3) + (acl-et-check! + "audit: tail size respects n" + (len (acl-audit-tail 2)) + 2) + (acl-et-check! + "audit: tail returns most recent" + (get (first (acl-audit-tail 1)) :act) + (quote comment)) + (acl-et-check! + "audit: first record seq is 0" + (get (first (acl-audit-tail 3)) :seq) + 0) + (acl-et-check! + "audit: allowed flag recorded" + (get (first (acl-audit-tail 3)) :allowed?) + true) + (acl-et-check! + "audit: serialize line count" + (len (acl-et-lines (acl-audit-serialize))) + 3) + (acl-audit-clear!) + (acl-et-check! + "audit: clear resets count" + (acl-audit-count) + 0)))))) + +;; count newline-terminated lines in a serialized log +(define acl-et-lines (fn (s) (acl-et-count-nl s 0 0))) +(define + acl-et-count-nl + (fn + (s i n) + (if + (>= i (len s)) + (if (= n 0) (list) (acl-et-rangelist n)) + (acl-et-count-nl + s + (+ i 1) + (if (= (slice s i (+ i 1)) "\n") (+ n 1) n))))) +(define + acl-et-rangelist + (fn + (n) + (if + (<= n 0) + (list) + (cons n (acl-et-rangelist (- n 1)))))) + +(define + acl-explain-tests-run! + (fn + () + (do + (set! acl-et-pass 0) + (set! acl-et-fail 0) + (set! acl-et-failures (list)) + (acl-et-run-all!) + {:failures acl-et-failures :total (+ acl-et-pass acl-et-fail) :passed acl-et-pass :failed acl-et-fail}))) diff --git a/lib/acl/tests/fed.sx b/lib/acl/tests/fed.sx new file mode 100644 index 00000000..5be69958 --- /dev/null +++ b/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}))) diff --git a/lib/acl/tests/harden.sx b/lib/acl/tests/harden.sx new file mode 100644 index 00000000..b32c3098 --- /dev/null +++ b/lib/acl/tests/harden.sx @@ -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}))) diff --git a/lib/acl/tests/inherit.sx b/lib/acl/tests/inherit.sx new file mode 100644 index 00000000..11722481 --- /dev/null +++ b/lib/acl/tests/inherit.sx @@ -0,0 +1,202 @@ +;; lib/acl/tests/inherit.sx — Phase 2: inheritance (groups, resource trees, +;; role expansion) with deny-overrides. + +(define acl-it-pass 0) +(define acl-it-fail 0) +(define acl-it-failures (list)) + +(define + acl-it-check! + (fn + (name got expected) + (if + (= got expected) + (set! acl-it-pass (+ acl-it-pass 1)) + (do + (set! acl-it-fail (+ acl-it-fail 1)) + (append! + acl-it-failures + (str name "\n expected: " expected "\n got: " got)))))) + +(define acl-it-p? (fn (db s a r) (acl-permit? db s a r))) + +(define + acl-it-run-all! + (fn + () + (do + (let + ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc)))))) + (do + (acl-it-check! + "group grant reaches member" + (acl-it-p? db (quote alice) (quote read) (quote doc)) + true) + (acl-it-check! + "group grant: non-member excluded" + (acl-it-p? db (quote bob) (quote read) (quote doc)) + false) + (acl-it-check! + "group grant: wrong action" + (acl-it-p? db (quote alice) (quote edit) (quote doc)) + false))) + (let + ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-member-of (quote team) (quote org)) (acl-member-of (quote org) (quote company)) (acl-grant (quote company) (quote read) (quote doc)))))) + (do + (acl-it-check! + "deep nested group grant reaches leaf member" + (acl-it-p? db (quote alice) (quote read) (quote doc)) + true) + (acl-it-check! + "intermediate group also covered" + (acl-it-p? db (quote team) (quote read) (quote doc)) + true) + (acl-it-check! + "mid group org covered" + (acl-it-p? db (quote org) (quote read) (quote doc)) + true))) + (let + ((db (acl-build-db (list (acl-member-of (quote a) (quote b)) (acl-member-of (quote b) (quote a)) (acl-grant (quote b) (quote read) (quote r)))))) + (do + (acl-it-check! + "cyclic membership terminates and grants" + (acl-it-p? db (quote a) (quote read) (quote r)) + true) + (acl-it-check! + "cyclic membership covers both" + (acl-it-p? db (quote b) (quote read) (quote r)) + true))) + (let + ((db (acl-build-db (list (acl-child-of (quote sec) (quote chap)) (acl-child-of (quote chap) (quote book)) (acl-grant (quote u) (quote read) (quote book)))))) + (do + (acl-it-check! + "parent grant reaches direct child" + (acl-it-p? db (quote u) (quote read) (quote chap)) + true) + (acl-it-check! + "parent grant reaches deep descendant" + (acl-it-p? db (quote u) (quote read) (quote sec)) + true) + (acl-it-check! + "parent grant covers parent itself" + (acl-it-p? db (quote u) (quote read) (quote book)) + true) + (acl-it-check! + "child grant does not climb to parent" + (acl-it-p? + (acl-build-db + (list + (acl-child-of (quote sec) (quote book)) + (acl-grant (quote u) (quote read) (quote sec)))) + (quote u) + (quote read) + (quote book)) + false))) + (let + ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-child-of (quote post1) (quote board)) (acl-grant (quote team) (quote comment) (quote board)))))) + (do + (acl-it-check! + "group + resource: member on child resource" + (acl-it-p? db (quote alice) (quote comment) (quote post1)) + true) + (acl-it-check! + "group + resource: member on parent resource" + (acl-it-p? db (quote alice) (quote comment) (quote board)) + true))) + (let + ((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-role-grant (quote editor) (quote edit) (quote page1)) (acl-role-grant (quote editor) (quote read) (quote page1)))))) + (do + (acl-it-check! + "role confers edit to member" + (acl-it-p? db (quote bob) (quote edit) (quote page1)) + true) + (acl-it-check! + "role confers read to member" + (acl-it-p? db (quote bob) (quote read) (quote page1)) + true) + (acl-it-check! + "role: capability not in tuple denied" + (acl-it-p? db (quote bob) (quote moderate) (quote page1)) + false) + (acl-it-check! + "role: non-member excluded" + (acl-it-p? db (quote eve) (quote edit) (quote page1)) + false))) + (let + ((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-child-of (quote draft) (quote page1)) (acl-role-grant (quote editor) (quote edit) (quote page1)))))) + (acl-it-check! + "role grant flows to child resource" + (acl-it-p? db (quote bob) (quote edit) (quote draft)) + true)) + (let + ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc)))))) + (acl-it-check! + "explicit deny beats inherited group allow" + (acl-it-p? db (quote alice) (quote read) (quote doc)) + false)) + (let + ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote alice) (quote read) (quote doc)) (acl-deny (quote team) (quote read) (quote doc)))))) + (do + (acl-it-check! + "group deny inherits and overrides direct grant" + (acl-it-p? db (quote alice) (quote read) (quote doc)) + false) + (acl-it-check! + "group deny: another member also blocked" + (acl-it-p? db (quote team) (quote read) (quote doc)) + false))) + (let + ((db (acl-build-db (list (acl-child-of (quote sec) (quote book)) (acl-grant (quote u) (quote read) (quote sec)) (acl-deny (quote u) (quote read) (quote book)))))) + (acl-it-check! + "ancestor deny overrides descendant grant" + (acl-it-p? db (quote u) (quote read) (quote sec)) + false)) + (let + ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc)) (acl-grant (quote team) (quote edit) (quote doc)) (acl-deny (quote alice) (quote edit) (quote doc)))))) + (do + (acl-it-check! + "deny on edit leaves inherited read intact" + (acl-it-p? db (quote alice) (quote read) (quote doc)) + true) + (acl-it-check! + "deny on edit blocks edit" + (acl-it-p? db (quote alice) (quote edit) (quote doc)) + false))) + (let + ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-deny (quote team) (quote read) (quote doc)))))) + (acl-it-check! + "inherited deny, no grant: denied" + (acl-it-p? db (quote alice) (quote read) (quote doc)) + false)) + (let + ((db (acl-build-db (list (acl-child-of (quote a) (quote root)) (acl-child-of (quote b) (quote root)) (acl-grant (quote u) (quote read) (quote root)) (acl-deny (quote u) (quote read) (quote a)))))) + (do + (acl-it-check! + "deny on sibling a blocks a" + (acl-it-p? db (quote u) (quote read) (quote a)) + false) + (acl-it-check! + "deny on sibling a leaves b permitted" + (acl-it-p? db (quote u) (quote read) (quote b)) + true) + (acl-it-check! + "root itself still permitted" + (acl-it-p? db (quote u) (quote read) (quote root)) + true))) + (let + ((db (acl-build-db (list (acl-grant (quote x) (quote read) (quote y)))))) + (acl-it-check! + "direct grant under inheritance ruleset" + (acl-it-p? db (quote x) (quote read) (quote y)) + true))))) + +(define + acl-inherit-tests-run! + (fn + () + (do + (set! acl-it-pass 0) + (set! acl-it-fail 0) + (set! acl-it-failures (list)) + (acl-it-run-all!) + {:failures acl-it-failures :total (+ acl-it-pass acl-it-fail) :passed acl-it-pass :failed acl-it-fail}))) diff --git a/plans/acl-on-sx.md b/plans/acl-on-sx.md index 898c8138..b100b2a3 100644 --- a/plans/acl-on-sx.md +++ b/plans/acl-on-sx.md @@ -15,7 +15,7 @@ and federation extension. Reuses `lib/datalog/` evaluator and term model where p ## Status (rolling) -`bash lib/acl/conformance.sh` → **0/0** (not yet started) +`bash lib/acl/conformance.sh` → **145/145** (all four phases + hardening) ## Ground rules @@ -57,46 +57,225 @@ lib/acl/facts.sx — builds Datalog query ## Phase 1 — Direct grants -- [ ] `lib/acl/schema.sx` — sorts: subject {user, group, role, service}, action, +- [x] `lib/acl/schema.sx` — sorts: subject {user, group, role, service}, action, resource {page, post, thread, peer} -- [ ] `lib/acl/facts.sx` — `actor`, `resource`, `grant`, `deny` predicates as Datalog +- [x] `lib/acl/facts.sx` — `actor`, `resource`, `grant`, `deny` predicates as Datalog EDB -- [ ] `lib/acl/engine.sx` — `(permit? subj act res db)` reduces to Datalog query -- [ ] `lib/acl/api.sx` — public `(acl/permit? ...)` taking implicit current db -- [ ] `lib/acl/tests/direct.sx` — 15+ cases: direct grant, missing grant, explicit deny -- [ ] `lib/acl/scoreboard.{json,md}` baseline -- [ ] `lib/acl/conformance.sh` runs the suite +- [x] `lib/acl/engine.sx` — `(permit? subj act res db)` reduces to Datalog query +- [x] `lib/acl/api.sx` — public `(acl/permit? ...)` taking implicit current db +- [x] `lib/acl/tests/direct.sx` — 15+ cases: direct grant, missing grant, explicit deny +- [x] `lib/acl/scoreboard.{json,md}` baseline +- [x] `lib/acl/conformance.sh` runs the suite ## Phase 2 — Inheritance -- [ ] `member_of(actor, group)` chain — group grants apply to members (transitive) -- [ ] `child_of(res, parent)` chain — parent grants apply to children (transitive) -- [ ] role expansion — role contains list of (action, resource) tuples -- [ ] deny-overrides — explicit deny wins over inherited allow -- [ ] `lib/acl/tests/inherit.sx` — 25+ cases: nested groups, deep resource trees, +- [x] `member_of(actor, group)` chain — group grants apply to members (transitive) +- [x] `child_of(res, parent)` chain — parent grants apply to children (transitive) +- [x] role expansion — role contains list of (action, resource) tuples +- [x] deny-overrides — explicit deny wins over inherited allow +- [x] `lib/acl/tests/inherit.sx` — 25+ cases: nested groups, deep resource trees, conflict resolution, deny precedence -- [ ] document the deny-overrides choice in plan +- [x] document the deny-overrides choice in plan + +### deny-overrides policy (the choice) + +Encoded as stratified negation: `permit(S,A,R) :- eff_grant(S,A,R), not +eff_deny(S,A,R)`. Both `eff_grant` and `eff_deny` inherit through the *same* +`member_of` (group/role) and `child_of` (resource) chains. Consequences: + +- An explicit deny on the exact (S,A,R) defeats any inherited allow. +- A **group-level** or **ancestor-resource** deny inherits down and defeats a + member's/descendant's grant — deny is authoritative across the closure, not + only at the leaf. This is the fail-safe reading: the most permissive + interpretation of "deny wins" would let a narrow grant escape a broad deny; + we chose the opposite. +- Deny is dimension-scoped: a deny on (S, edit, R) never blocks (S, read, R). + +Stratifiable because neither `eff_grant` nor `eff_deny` depends on `permit`; +`permit` sits in a strictly higher stratum. Termination is guaranteed — +recursion is only over EDB `member_of`/`child_of` (no function symbols), so +cyclic membership/containment reaches a fixpoint rather than looping (tested). ## Phase 3 — Explanation + audit -- [ ] `(acl/explain subj act res)` → `{:allowed? T :proof }` -- [ ] proof tree extracts from Datalog's derivation -- [ ] `lib/acl/audit.sx` — append-only decision log (in-memory + serializer for disk) -- [ ] `(acl/audit-tail n)` for recent decisions -- [ ] `lib/acl/tests/explain.sx` — proof correctness, audit completeness +- [x] `(acl/explain subj act res)` → `{:allowed? T :proof }` +- [x] proof tree extracts from Datalog's derivation +- [x] `lib/acl/audit.sx` — append-only decision log (in-memory + serializer for disk) +- [x] `(acl/audit-tail n)` for recent decisions +- [x] `lib/acl/tests/explain.sx` — proof correctness, audit completeness + +### proof reconstruction (the choice) + +`lib/datalog/` records derived facts but not provenance, so `lib/acl/explain.sx` +reconstructs the proof by goal-directed search over the *saturated* db: for a +ground goal, find the first ACL rule (in `acl-rules` order) whose body holds, +take the first `dl-query` solution binding the rest, recurse on each body +literal; negated literals become verified `:neg-ok` leaves. The Datalog +derivation graph is a DAG (a fact may hold many ways) — we pick ONE **canonical +proof: first-rule, first-solution**, with EDB/direct rules ordered first so +proofs bottom out quickly. A depth cap (64) guards pathological cyclic data. +`acl-explain` returns `{:allowed? :proof :reason}`; on denial `:reason` carries +the blocking `eff_deny` proof (explicit or inherited) when one exists, else nil +(no grant). Audit log is append-only with monotonic seq numbers (no wall-clock, +for determinism); `acl-audit-decide!` is the logged path, `acl-permit?` stays +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 -(loop fills this in) +- **Phase 1 complete (24/24).** ACL is a thin layer over `lib/datalog/`: + - `schema.sx` — sorts (subject/resource kinds, well-known actions) + EDB + predicate arity table + `acl-fact-valid?` validator. Schema is data, since + Datalog is untyped. + - `facts.sx` — `acl-actor`/`acl-resource-fact`/`acl-grant`/`acl-deny` + constructors returning Datalog fact tuples. + - `engine.sx` — owns the ruleset `acl-phase1-rules` and reduces decisions to + `dl-query`. `acl-build-db` = `dl-program-data facts rules`; `acl-permit?` = + non-empty `(permit S A R)` query. + - `api.sx` — `acl/load!` rebuilds an implicit current db; `acl/permit?` queries + it. (Slash-symbols like `acl/permit?` parse fine as single tokens.) + - **deny-overrides** encoded as `permit(S,A,R) :- grant(S,A,R), not deny(S,A,R)`. + Stratifies cleanly because `deny` is EDB-only (no rule derives it). Verified: + grant+deny on same (S,A,R) → denied. + - Conformance: `conformance.conf` (datalog preloads + acl modules) + thin + `conformance.sh` wrapper over `lib/guest/conformance.sh`. Scoreboard + generated by the shared driver. + - **Shared-plumbing note (for eventual `lib/guest/rules/`):** the + `build-db = dl-program-data(facts, rules)` + `decide = non-empty ground query` + shape is exactly what mod-sx (Prolog moderation) will also need. The reusable + seam is engine.sx's two functions — facts→db and ground-query→bool — both + pure pass-throughs to the rule engine. Not extracting yet (wait for mod-sx as + second consumer per ground rules). +- **Phase 2 complete (54/54, +30 inherit).** Extended `acl-rules` with + `eff_grant`/`eff_deny` derived relations; `member_of` carries both group and + role membership, `child_of` carries resource trees, `role_grant` confers a + role's (action,resource) capabilities. Direct grants unchanged (base case of + `eff_grant`), Phase 1 suite still green. Constructors `acl-member-of`, + `acl-child-of`, `acl-role-grant` added; schema arity table extended. See the + deny-overrides policy section above. Verified cyclic membership terminates. + - **Shared-plumbing update:** the reusable seam is still just engine.sx's + `facts -> db` + `ground-query -> bool`. The inheritance *rules* are + ACL-specific (group/resource/role vocabulary); mod-sx will have its own. So + the `lib/guest/rules/` extraction stays at the build/decide level, not the + ruleset level. +- **Phase 3 complete (89/89, +35 explain).** Added `explain.sx` (proof + reconstruction, see policy section above), `audit.sx` (append-only log), and + extended `api.sx` with `acl/explain`/`acl/audit`/`acl/audit-tail`. No engine + changes — explanation reads the same saturated db the decision uses. + - **Substrate gotcha:** the host `=` compares symbols by interned identity, + which is *unstable* across `dl-query` saturation/substitution within a + single image — the same two structurally-equal symbol-lists compared `=` + true once and false moments later in the REPL. Conformance runs in a fresh + process per suite so it's deterministic there, but test assertions now use a + 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)` + forms. `sx_write_file`, `sx_validate`, `sx_find_all`, `sx_summarise`, + `sx_eval` all work; used full-file rewrites instead of path edits throughout. + +## Hardening (post-roadmap) + +- **`lib/acl/tests/harden.sx` (+25).** Adversarial / cross-phase coverage beyond + the per-phase suites. **Prover-free by design** (see JIT blocker below): only + `acl-permit?` (compiled Datalog, safe at any depth) + pure data ops, never + `acl-explain`/`acl-prove-d`. + - Diamond hierarchies (resource and group): grant on one path + deny on + another → deny wins; both-grant → permit; deny does not leak to siblings. + - Chain inheritance (literal 4-link): top-group grant reaches leaf member and + intermediates; leaf-member deny overrides the top grant; deny on the leaf + doesn't block a higher level. + - Cycle termination: self-membership, self-child, and 2-node membership cycles + all reach a fixpoint and decide correctly. + - Federation conflicts: federated group-grant with a locally-denied member → + deny; multi-peer delegation (one trusted, or both trusted) → permit. + - Degenerate inputs: empty db permits nothing. + - Fact validation: `acl-validate-facts` surfaces wrong-arity + unknown + predicates; `acl-facts-valid?` on clean/empty sets. + - Audit save/restore: snapshot → clear → restore round-trips entries + seq; + seq continues without collision after restore; snapshot is an immutable copy. + - Proof reconstruction itself is covered by tests/explain.sx + tests/fed.sx + (both stay under the warm-process JIT depth threshold); the depth-cap safety + net is verified manually in a warm REPL image but excluded from conformance. +- **New API:** `acl-validate-facts`/`acl-facts-valid?` (schema.sx, opt-in — build + stays lenient); `acl-audit-snapshot`/`acl-audit-restore!`/`acl-audit-copy` + (audit.sx). +- **Substrate gotcha (recorded):** `append!` extends a list built with `(list)` + but **silently no-ops on a `map`/`rest`-derived list** in this runtime. Bit the + first cut of `acl-audit-restore!` (rebuilt the live log via `map`, so later + records didn't append). Fix: always rebuild mutable lists via `(list)` + + `append!` (`acl-audit-copy`). Worth flagging to kernel owners; out of acl scope. ## Blockers -(loop fills this in) +- **JIT loops on deep proof reconstruction (substrate, not acl).** Once the + kernel JIT-compiles the mutually-recursive prover (`acl-prove-d`/ + `acl-prove-rules`/`acl-prove-build` in `explain.sx`) — which happens after a + process has run enough explains to cross the compile threshold — the compiled + version **loops indefinitely** on a `member_of`/`child_of` chain deeper than + ~3. Symptoms: `acl-explain` over a 4+-deep chain returns instantly in a cold / + warm-REPL image but **hangs** in a long-lived process. The per-phase explain + and fed suites pass only because their proofs stay ≤3 deep; a 5th suite that + explained deeper chains hung the whole conformance run (no per-suite timeout + in dict mode). Matches `[[project_jit_bytecode_bug]]` (ACTIVE). + - *Impact beyond tests:* `acl-explain` is unsafe for deep hierarchies in a + warm production OCaml server. `acl-permit?` is unaffected (it reduces to + compiled Datalog, no SX-side recursion) — only the SX proof reconstructor is. + - *Workaround in acl:* harden suite is prover-free; explain is exercised only + at shallow depth. *Real fix is in the kernel JIT* (out of acl scope) — e.g. + the `_jit_compiling` guard / disabling JIT for the recursive prover, or + fixing the bytecode loop. Recommend the kernel owners reproduce with: + `acl-explain` over a 6-deep `member_of` chain after ~70 prior explains. + - *Minimal repro recorded.* Until fixed, callers needing explanations for + deep hierarchies should flatten or cap depth, or run explain in a cold + worker.