Compare commits
13 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
| 9437f99e28 | |||
| 40be9cd074 | |||
| 15c97119e4 | |||
| 9261d69cc5 | |||
| fe47334e52 | |||
| c3a0727645 | |||
| 1b94082a71 | |||
| 57184daaee | |||
| d9e2627b89 | |||
| bcabed6bce | |||
| 5098a8f015 | |||
| 9fe5c9044d | |||
| c6f397c3d9 |
45
lib/acl/api.sx
Normal file
45
lib/acl/api.sx
Normal file
@@ -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)))
|
||||
110
lib/acl/audit.sx
Normal file
110
lib/acl/audit.sx
Normal file
@@ -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)))
|
||||
32
lib/acl/conformance.conf
Normal file
32
lib/acl/conformance.conf
Normal file
@@ -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!)"
|
||||
)
|
||||
3
lib/acl/conformance.sh
Executable file
3
lib/acl/conformance.sh
Executable file
@@ -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" "$@"
|
||||
72
lib/acl/engine.sx
Normal file
72
lib/acl/engine.sx
Normal file
@@ -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)))
|
||||
125
lib/acl/explain.sx
Normal file
125
lib/acl/explain.sx
Normal file
@@ -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 <lit> :via "edb"} — base EDB fact
|
||||
;; {:fact <lit> :rule <head> :body (<node|negleaf> ...)} — derived
|
||||
;; {:neg-ok <lit>} — negation verified to fail
|
||||
;; {:fact <lit> :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? <bool> :proof <node|nil> :reason <eff_deny proof|nil>}
|
||||
;; 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}))))
|
||||
47
lib/acl/facts.sx
Normal file
47
lib/acl/facts.sx
Normal file
@@ -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)))
|
||||
61
lib/acl/federation.sx
Normal file
61
lib/acl/federation.sx
Normal file
@@ -0,0 +1,61 @@
|
||||
;; lib/acl/federation.sx — cross-instance ACL facts + revocation.
|
||||
;;
|
||||
;; fed-sx replicates ACL facts between instances; this module models the local
|
||||
;; side. A peer's authority arrives as `delegate(Peer, S, A, R)` facts, which
|
||||
;; only take effect when a local `trust(Peer, L)` and `level_covers(L, A)`
|
||||
;; authorise them (enforced by the engine rule, re-checked every query). The
|
||||
;; actual network transport is fed-sx's job and is mocked in tests as a dict.
|
||||
;;
|
||||
;; Trust is NOT transitive: trusting peer α does not extend to peers α trusts.
|
||||
;; Only delegate facts that α itself asserts, and that local trust covers, flow.
|
||||
|
||||
;; Mock fed-sx pull: `transport` is a dict mapping a peer address (its string
|
||||
;; name) to the list of delegate facts that peer asserts. Returns the facts for
|
||||
;; `addr`, or an empty list if the peer is unknown / unreachable.
|
||||
(define
|
||||
acl-fed-fetch
|
||||
(fn
|
||||
(transport addr)
|
||||
(let
|
||||
((k (if (symbol? addr) (symbol->string addr) addr)))
|
||||
(if (has-key? transport k) (get transport k) (list)))))
|
||||
|
||||
;; Gather delegate facts from every peer in `addrs` via the transport.
|
||||
(define
|
||||
acl-fed-collect
|
||||
(fn
|
||||
(transport addrs)
|
||||
(let
|
||||
((acc (list)))
|
||||
(do
|
||||
(for-each
|
||||
(fn
|
||||
(addr)
|
||||
(for-each
|
||||
(fn (f) (append! acc f))
|
||||
(acl-fed-fetch transport addr)))
|
||||
addrs)
|
||||
acc))))
|
||||
|
||||
;; Build a db from local facts plus delegate facts pulled from `peers`. Local
|
||||
;; facts must include the `trust`/`level_covers` policy; replicated delegate
|
||||
;; facts are gated against it by the engine rule at query time.
|
||||
(define
|
||||
acl-fed-build-db
|
||||
(fn
|
||||
(local-facts transport peers)
|
||||
(let
|
||||
((all (list)))
|
||||
(do
|
||||
(for-each (fn (f) (append! all f)) local-facts)
|
||||
(for-each
|
||||
(fn (f) (append! all f))
|
||||
(acl-fed-collect transport peers))
|
||||
(acl-build-db all)))))
|
||||
|
||||
;; Propagated revocation: retract a replicated fact (e.g. a peer's delegate, or
|
||||
;; local trust) from a live db. The next decision re-saturates and reflects it.
|
||||
(define acl-revoke! (fn (db fact) (do (dl-retract! db fact) db)))
|
||||
|
||||
;; Propagated assertion: ingest a newly replicated fact into a live db.
|
||||
(define acl-fed-assert! (fn (db fact) (do (dl-assert! db fact) db)))
|
||||
71
lib/acl/schema.sx
Normal file
71
lib/acl/schema.sx
Normal file
@@ -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)))
|
||||
14
lib/acl/scoreboard.json
Normal file
14
lib/acl/scoreboard.json
Normal file
@@ -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"
|
||||
}
|
||||
11
lib/acl/scoreboard.md
Normal file
11
lib/acl/scoreboard.md
Normal file
@@ -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 |
|
||||
170
lib/acl/tests/direct.sx
Normal file
170
lib/acl/tests/direct.sx
Normal file
@@ -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})))
|
||||
316
lib/acl/tests/explain.sx
Normal file
316
lib/acl/tests/explain.sx
Normal file
@@ -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})))
|
||||
273
lib/acl/tests/fed.sx
Normal file
273
lib/acl/tests/fed.sx
Normal file
@@ -0,0 +1,273 @@
|
||||
;; lib/acl/tests/fed.sx — Phase 4: federation (peer trust, delegation,
|
||||
;; cross-instance chains, revocation). fed-sx transport is mocked as a dict.
|
||||
|
||||
(define acl-ft-pass 0)
|
||||
(define acl-ft-fail 0)
|
||||
(define acl-ft-failures (list))
|
||||
|
||||
;; Name-based deep equality (host `=` compares symbols by unstable interned
|
||||
;; identity; see lib/acl/tests/explain.sx).
|
||||
(define
|
||||
acl-ft-eq?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((and (list? a) (list? b))
|
||||
(and (= (len a) (len b)) (acl-ft-eq-l? a b 0)))
|
||||
((and (symbol? a) (symbol? b))
|
||||
(= (symbol->string a) (symbol->string b)))
|
||||
(else (= a b)))))
|
||||
(define
|
||||
acl-ft-eq-l?
|
||||
(fn
|
||||
(a b i)
|
||||
(cond
|
||||
((>= i (len a)) true)
|
||||
((not (acl-ft-eq? (nth a i) (nth b i))) false)
|
||||
(else (acl-ft-eq-l? a b (+ i 1))))))
|
||||
|
||||
(define
|
||||
acl-ft-check!
|
||||
(fn
|
||||
(name got expected)
|
||||
(if
|
||||
(acl-ft-eq? got expected)
|
||||
(set! acl-ft-pass (+ acl-ft-pass 1))
|
||||
(do
|
||||
(set! acl-ft-fail (+ acl-ft-fail 1))
|
||||
(append!
|
||||
acl-ft-failures
|
||||
(str name "\n expected: " expected "\n got: " got))))))
|
||||
|
||||
;; proof leaf walker (federated proofs reconstruct through the engine rule).
|
||||
(define
|
||||
acl-ft-has-leaf?
|
||||
(fn
|
||||
(node target)
|
||||
(cond
|
||||
((= node nil) false)
|
||||
((and (dict? node) (has-key? node :via))
|
||||
(acl-ft-eq? (get node :fact) target))
|
||||
((and (dict? node) (has-key? node :body))
|
||||
(acl-ft-any-leaf? (get node :body) target))
|
||||
(else false))))
|
||||
(define
|
||||
acl-ft-any-leaf?
|
||||
(fn
|
||||
(nodes target)
|
||||
(cond
|
||||
((= (len nodes) 0) false)
|
||||
((acl-ft-has-leaf? (first nodes) target) true)
|
||||
(else (acl-ft-any-leaf? (rest nodes) target)))))
|
||||
|
||||
(define acl-ft-p? (fn (db s a r) (acl-permit? db s a r)))
|
||||
|
||||
;; A standard federation fixture: local trusts peer alpha at "readonly", which
|
||||
;; covers read+comment. alpha delegates several capabilities to alice.
|
||||
(define
|
||||
acl-ft-fixture
|
||||
(fn
|
||||
()
|
||||
(acl-build-db
|
||||
(list
|
||||
(acl-trust (quote alpha) (quote readonly))
|
||||
(acl-level-covers (quote readonly) (quote read))
|
||||
(acl-level-covers (quote readonly) (quote comment))
|
||||
(acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))
|
||||
(acl-delegate (quote alpha) (quote alice) (quote edit) (quote doc))))))
|
||||
|
||||
(define
|
||||
acl-ft-run-all!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(let
|
||||
((db (acl-ft-fixture)))
|
||||
(do
|
||||
(acl-ft-check!
|
||||
"trusted delegate, level covers action -> permit"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"trusted delegate, level does NOT cover action -> deny"
|
||||
(acl-ft-p? db (quote alice) (quote edit) (quote doc))
|
||||
false)
|
||||
(acl-ft-check!
|
||||
"delegated but action class uncovered (comment has no delegate)"
|
||||
(acl-ft-p? db (quote alice) (quote comment) (quote doc))
|
||||
false)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-level-covers (quote readonly) (quote read)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
|
||||
(acl-ft-check!
|
||||
"untrusted peer delegate -> deny"
|
||||
(acl-ft-p? db (quote bob) (quote read) (quote doc))
|
||||
false))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote readonly)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
|
||||
(acl-ft-check!
|
||||
"trust but no level_covers -> deny"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
false))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
|
||||
(do
|
||||
(acl-ft-check!
|
||||
"trust is per-peer: alpha's delegate applies"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"trust not transitive: beta's delegate does not apply"
|
||||
(acl-ft-p? db (quote bob) (quote read) (quote doc))
|
||||
false)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc))))))
|
||||
(acl-ft-check!
|
||||
"local deny overrides federated grant"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
false))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-member-of (quote alice) (quote team)) (acl-delegate (quote alpha) (quote team) (quote read) (quote doc))))))
|
||||
(acl-ft-check!
|
||||
"federated grant to group reaches member"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
true))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-child-of (quote sec) (quote book)) (acl-delegate (quote alpha) (quote u) (quote read) (quote book))))))
|
||||
(acl-ft-check!
|
||||
"federated grant on parent resource reaches child"
|
||||
(acl-ft-p? db (quote u) (quote read) (quote sec))
|
||||
true))
|
||||
(let
|
||||
((transport {:gamma (list (acl-delegate (quote gamma) (quote carol) (quote read) (quote post))) :alpha (list (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)))}))
|
||||
(do
|
||||
(acl-ft-check!
|
||||
"fetch known peer returns its delegates"
|
||||
(len (acl-fed-fetch transport (quote alpha)))
|
||||
1)
|
||||
(acl-ft-check!
|
||||
"fetch unknown peer returns empty"
|
||||
(len (acl-fed-fetch transport (quote delta)))
|
||||
0)
|
||||
(acl-ft-check!
|
||||
"collect across peers"
|
||||
(len
|
||||
(acl-fed-collect transport (list (quote alpha) (quote gamma))))
|
||||
2)
|
||||
(let
|
||||
((db (acl-fed-build-db (list (acl-trust (quote alpha) (quote readonly)) (acl-trust (quote gamma) (quote readonly)) (acl-level-covers (quote readonly) (quote read))) transport (list (quote alpha) (quote gamma)))))
|
||||
(do
|
||||
(acl-ft-check!
|
||||
"fed-build-db: alpha delegate permits"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"fed-build-db: gamma delegate permits"
|
||||
(acl-ft-p? db (quote carol) (quote read) (quote post))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"fed-build-db: untrusted action still denied"
|
||||
(acl-ft-p? db (quote alice) (quote edit) (quote doc))
|
||||
false)))))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
|
||||
(do
|
||||
(acl-ft-check!
|
||||
"before revoke: permitted"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
true)
|
||||
(acl-revoke!
|
||||
db
|
||||
(acl-delegate
|
||||
(quote alpha)
|
||||
(quote alice)
|
||||
(quote read)
|
||||
(quote doc)))
|
||||
(acl-ft-check!
|
||||
"after delegate revoked: denied"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
false)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
|
||||
(do
|
||||
(acl-ft-check!
|
||||
"before trust revoke: permitted"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
true)
|
||||
(acl-revoke! db (acl-trust (quote alpha) (quote full)))
|
||||
(acl-ft-check!
|
||||
"after trust revoked: denied"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
false)))
|
||||
(let
|
||||
((db (acl-build-db (list (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
|
||||
(do
|
||||
(acl-ft-check!
|
||||
"delegate without trust: denied"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
false)
|
||||
(acl-fed-assert! db (acl-trust (quote alpha) (quote full)))
|
||||
(acl-ft-check!
|
||||
"trust ingested then re-checked: permitted"
|
||||
(acl-ft-p? db (quote alice) (quote read) (quote doc))
|
||||
true)))
|
||||
(let
|
||||
((db (acl-ft-fixture)))
|
||||
(let
|
||||
((e (acl-explain db (quote alice) (quote read) (quote doc))))
|
||||
(do
|
||||
(acl-ft-check! "federated proof allowed?" (get e :allowed?) true)
|
||||
(acl-ft-check!
|
||||
"federated proof has delegate leaf"
|
||||
(acl-ft-has-leaf?
|
||||
(get e :proof)
|
||||
(list
|
||||
(quote delegate)
|
||||
(quote alpha)
|
||||
(quote alice)
|
||||
(quote read)
|
||||
(quote doc)))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"federated proof has trust leaf"
|
||||
(acl-ft-has-leaf?
|
||||
(get e :proof)
|
||||
(list (quote trust) (quote alpha) (quote readonly)))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"federated proof has level_covers leaf"
|
||||
(acl-ft-has-leaf?
|
||||
(get e :proof)
|
||||
(list (quote level_covers) (quote readonly) (quote read)))
|
||||
true))))
|
||||
(acl-ft-check!
|
||||
"schema delegate arity valid"
|
||||
(acl-fact-valid?
|
||||
(acl-delegate (quote p) (quote s) (quote a) (quote r)))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"schema trust arity valid"
|
||||
(acl-fact-valid? (acl-trust (quote p) (quote l)))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"schema peer arity valid"
|
||||
(acl-fact-valid? (acl-peer (quote p) (quote peer)))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"schema level_covers arity valid"
|
||||
(acl-fact-valid? (acl-level-covers (quote l) (quote read)))
|
||||
true)
|
||||
(acl-ft-check!
|
||||
"schema delegate bad arity invalid"
|
||||
(acl-fact-valid? (list (quote delegate) (quote p) (quote s)))
|
||||
false))))
|
||||
|
||||
(define
|
||||
acl-fed-tests-run!
|
||||
(fn
|
||||
()
|
||||
(do
|
||||
(set! acl-ft-pass 0)
|
||||
(set! acl-ft-fail 0)
|
||||
(set! acl-ft-failures (list))
|
||||
(acl-ft-run-all!)
|
||||
{:failures acl-ft-failures :total (+ acl-ft-pass acl-ft-fail) :passed acl-ft-pass :failed acl-ft-fail})))
|
||||
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})))
|
||||
202
lib/acl/tests/inherit.sx
Normal file
202
lib/acl/tests/inherit.sx
Normal file
@@ -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})))
|
||||
@@ -1561,7 +1561,66 @@
|
||||
(er-register-pure-bif! "crypto" "hash" 2 er-bif-crypto-hash)
|
||||
(er-register-pure-bif! "cid" "from_bytes" 1 er-bif-cid-from-bytes)
|
||||
(er-register-pure-bif! "cid" "to_string" 1 er-bif-cid-to-string)
|
||||
|
||||
;; ── binary_to_list / list_to_binary (Step 3b — term codec) ──────
|
||||
;; Standard Erlang semantics:
|
||||
;; binary_to_list(<<B1,B2,...>>) -> [B1, B2, ...] (Erlang cons of ints)
|
||||
;; list_to_binary(IoList) -> <<...>> (flattens nested
|
||||
;; iolists; elements are byte ints 0-255 or binaries)
|
||||
;; Bad arg / out-of-range byte / non-iolist element -> error:badarg.
|
||||
|
||||
(define er-bif-binary-to-list
|
||||
(fn (vs)
|
||||
(let ((v (nth vs 0)))
|
||||
(cond
|
||||
(not (er-binary? v))
|
||||
(raise (er-mk-error-marker (er-mk-atom "badarg")))
|
||||
:else
|
||||
(let ((bs (get v :bytes)) (out (er-mk-nil)))
|
||||
(for-each
|
||||
(fn (i)
|
||||
(set! out (er-mk-cons (nth bs (- (- (len bs) 1) i)) out)))
|
||||
(range 0 (len bs)))
|
||||
out)))))
|
||||
|
||||
;; Walk an Erlang iolist, appending bytes to `acc` (a mutable SX list).
|
||||
;; Accepts: nil, cons-of-X, binary, integer in 0..255. Anything else
|
||||
;; signals failure by setting (nth fail 0) to true.
|
||||
(define er-iolist-walk!
|
||||
(fn (v acc fail)
|
||||
(cond
|
||||
(nth fail 0) nil
|
||||
(er-nil? v) nil
|
||||
(er-cons? v)
|
||||
(do (er-iolist-walk! (get v :head) acc fail)
|
||||
(er-iolist-walk! (get v :tail) acc fail))
|
||||
(er-binary? v)
|
||||
(for-each
|
||||
(fn (i) (append! acc (nth (get v :bytes) i)))
|
||||
(range 0 (len (get v :bytes))))
|
||||
(= (type-of v) "number")
|
||||
(cond
|
||||
(and (>= v 0) (<= v 255)) (append! acc v)
|
||||
:else (set-nth! fail 0 true))
|
||||
:else (set-nth! fail 0 true))))
|
||||
|
||||
(define er-bif-list-to-binary
|
||||
(fn (vs)
|
||||
(let ((v (nth vs 0)) (acc (list)) (fail (list false)))
|
||||
(cond
|
||||
(not (or (er-nil? v) (er-cons? v) (er-binary? v)))
|
||||
(raise (er-mk-error-marker (er-mk-atom "badarg")))
|
||||
:else
|
||||
(do
|
||||
(er-iolist-walk! v acc fail)
|
||||
(cond
|
||||
(nth fail 0)
|
||||
(raise (er-mk-error-marker (er-mk-atom "badarg")))
|
||||
:else (er-mk-binary acc)))))))
|
||||
|
||||
(er-register-bif! "file" "list_dir" 1 er-bif-file-list-dir)
|
||||
(er-register-pure-bif! "erlang" "binary_to_list" 1 er-bif-binary-to-list)
|
||||
(er-register-pure-bif! "erlang" "list_to_binary" 1 er-bif-list-to-binary)
|
||||
(er-mk-atom "ok")))
|
||||
|
||||
;; Register everything at load time.
|
||||
|
||||
@@ -1,18 +1,18 @@
|
||||
{
|
||||
"language": "erlang",
|
||||
"total_pass": 729,
|
||||
"total": 729,
|
||||
"total_pass": 761,
|
||||
"total": 761,
|
||||
"suites": [
|
||||
{"name":"tokenize","pass":62,"total":62,"status":"ok"},
|
||||
{"name":"parse","pass":52,"total":52,"status":"ok"},
|
||||
{"name":"eval","pass":385,"total":385,"status":"ok"},
|
||||
{"name":"eval","pass":408,"total":408,"status":"ok"},
|
||||
{"name":"runtime","pass":93,"total":93,"status":"ok"},
|
||||
{"name":"ring","pass":4,"total":4,"status":"ok"},
|
||||
{"name":"ping-pong","pass":4,"total":4,"status":"ok"},
|
||||
{"name":"bank","pass":8,"total":8,"status":"ok"},
|
||||
{"name":"echo","pass":7,"total":7,"status":"ok"},
|
||||
{"name":"fib","pass":8,"total":8,"status":"ok"},
|
||||
{"name":"ffi","pass":28,"total":28,"status":"ok"},
|
||||
{"name":"ffi","pass":37,"total":37,"status":"ok"},
|
||||
{"name":"vm","pass":78,"total":78,"status":"ok"}
|
||||
]
|
||||
}
|
||||
|
||||
@@ -1,19 +1,19 @@
|
||||
# Erlang-on-SX Scoreboard
|
||||
|
||||
**Total: 729 / 729 tests passing**
|
||||
**Total: 761 / 761 tests passing**
|
||||
|
||||
| | Suite | Pass | Total |
|
||||
|---|---|---|---|
|
||||
| ✅ | tokenize | 62 | 62 |
|
||||
| ✅ | parse | 52 | 52 |
|
||||
| ✅ | eval | 385 | 385 |
|
||||
| ✅ | eval | 408 | 408 |
|
||||
| ✅ | runtime | 93 | 93 |
|
||||
| ✅ | ring | 4 | 4 |
|
||||
| ✅ | ping-pong | 4 | 4 |
|
||||
| ✅ | bank | 8 | 8 |
|
||||
| ✅ | echo | 7 | 7 |
|
||||
| ✅ | fib | 8 | 8 |
|
||||
| ✅ | ffi | 28 | 28 |
|
||||
| ✅ | ffi | 37 | 37 |
|
||||
| ✅ | vm | 78 | 78 |
|
||||
|
||||
|
||||
|
||||
@@ -228,9 +228,10 @@
|
||||
(er-eval-test "tuple_size 0" (ev "tuple_size({})") 0)
|
||||
|
||||
;; ── BIFs: atom / list conversions ───────────────────────────────
|
||||
(er-eval-test "atom_to_list" (ev "atom_to_list(hello)") "hello")
|
||||
(er-eval-test "atom_to_list -> charlist length" (ev "length(atom_to_list(hello))") 5)
|
||||
(er-eval-test "atom_to_list -> head $h" (ev "hd(atom_to_list(hello))") 104)
|
||||
(er-eval-test "list_to_atom roundtrip"
|
||||
(nm (ev "list_to_atom(atom_to_list(foo))")) "foo")
|
||||
(nm (ev "list_to_atom(atom_to_list(foo))")) "foo") ;; round-trip via charlist
|
||||
(er-eval-test "list_to_atom fresh"
|
||||
(nm (ev "list_to_atom(\"bar\")")) "bar")
|
||||
|
||||
@@ -1060,11 +1061,13 @@
|
||||
(er-eval-test "list_to_tuple roundtrip"
|
||||
(ev "tuple_size(list_to_tuple([10, 20, 30]))") 3)
|
||||
|
||||
(er-eval-test "integer_to_list" (ev "integer_to_list(42)") "42")
|
||||
(er-eval-test "integer_to_list neg" (ev "integer_to_list(-99)") "-99")
|
||||
(er-eval-test "integer_to_list -> charlist length" (ev "length(integer_to_list(42))") 2)
|
||||
(er-eval-test "integer_to_list 42 head $4" (ev "hd(integer_to_list(42))") 52)
|
||||
(er-eval-test "integer_to_list neg -> charlist length" (ev "length(integer_to_list(-99))") 3)
|
||||
(er-eval-test "integer_to_list -99 head $-" (ev "hd(integer_to_list(-99))") 45)
|
||||
(er-eval-test "list_to_integer" (ev "list_to_integer(\"123\")") 123)
|
||||
(er-eval-test "list_to_integer roundtrip"
|
||||
(ev "list_to_integer(integer_to_list(7))") 7)
|
||||
(ev "list_to_integer(integer_to_list(7))") 7) ;; round-trip via charlist
|
||||
|
||||
(er-eval-test "is_function fun"
|
||||
(nm (ev "F = fun (X) -> X end, is_function(F)")) "true")
|
||||
@@ -1341,6 +1344,42 @@
|
||||
(get (nth (get er-rt-cap-result :elements) 4) :name) "true")
|
||||
|
||||
|
||||
|
||||
;; ── $X char literals (Step 3b substrate fix 2026-06-04) ──────────
|
||||
(er-eval-test "char $A" (ev "$A") 65)
|
||||
(er-eval-test "char $a" (ev "$a") 97)
|
||||
(er-eval-test "char $0 is digit, not escape-NUL" (ev "$0") 48)
|
||||
(er-eval-test "char $\\n is newline (10)" (ev "$\\n") 10)
|
||||
(er-eval-test "char $\\t is tab (9)" (ev "$\\t") 9)
|
||||
(er-eval-test "char $\\r is CR (13)" (ev "$\\r") 13)
|
||||
(er-eval-test "char $\\s is space (32)" (ev "$\\s") 32)
|
||||
(er-eval-test "char $\\0 is NUL (0)" (ev "$\\0") 0)
|
||||
(er-eval-test "char $\\\\ is backslash (92)" (ev "$\\\\") 92)
|
||||
(er-eval-test "[$h,$i] head is 104" (ev "hd([$h, $i])") 104)
|
||||
(er-eval-test "list_to_binary char-list -> bytes"
|
||||
(ev "byte_size(list_to_binary([$f, $e, $d]))") 3)
|
||||
(er-eval-test "list_to_binary char-list round-trip"
|
||||
(nm (ev "list_to_binary([$h, $i]) =:= <<104, 105>>")) "true")
|
||||
|
||||
|
||||
;; ── atom_to_list / integer_to_list charlist semantics (Step 3b substrate fix #3) ──
|
||||
(er-eval-test "atom_to_list hd is char code"
|
||||
(ev "hd(atom_to_list(hi))") 104)
|
||||
(er-eval-test "atom_to_list maps to bytes via list_to_binary"
|
||||
(ev "byte_size(list_to_binary(atom_to_list(hello)))") 5)
|
||||
(er-eval-test "atom_to_list -> list_to_binary -> bytes content"
|
||||
(nm (ev "list_to_binary(atom_to_list(ok)) =:= <<111, 107>>")) "true")
|
||||
(er-eval-test "integer_to_list 12345 -> 5 chars"
|
||||
(ev "length(integer_to_list(12345))") 5)
|
||||
(er-eval-test "integer_to_list -> bytes -> back"
|
||||
(ev "list_to_integer(integer_to_list(99999))") 99999)
|
||||
(er-eval-test "list_to_atom from charlist"
|
||||
(nm (ev "list_to_atom([$f, $o, $o])")) "foo")
|
||||
(er-eval-test "list_to_atom from SX-string back-compat"
|
||||
(nm (ev "list_to_atom(\"bar\")")) "bar")
|
||||
(er-eval-test "list_to_integer from charlist"
|
||||
(ev "list_to_integer([$1, $0, $0])") 100)
|
||||
|
||||
(define
|
||||
er-eval-test-summary
|
||||
(str "eval " er-eval-test-pass "/" er-eval-test-count))
|
||||
|
||||
@@ -160,6 +160,51 @@
|
||||
(ffi-nm (ffi-ev "element(2, file:list_dir(\"/no/such/dir/xyz\"))"))
|
||||
"enoent")
|
||||
|
||||
(er-ffi-test
|
||||
"binary_to_list <<1,2,3>> length"
|
||||
(ffi-ev "length(binary_to_list(<<1,2,3,4,5>>))")
|
||||
5)
|
||||
|
||||
(er-ffi-test
|
||||
"binary_to_list hd byte"
|
||||
(ffi-ev "hd(binary_to_list(<<7,8,9>>))")
|
||||
7)
|
||||
|
||||
(er-ffi-test
|
||||
"binary_to_list empty -> []"
|
||||
(ffi-nm (ffi-ev "case binary_to_list(<<>>) of [] -> empty end"))
|
||||
"empty")
|
||||
|
||||
(er-ffi-test
|
||||
"list_to_binary flat list bytes"
|
||||
(ffi-ev "byte_size(list_to_binary([1,2,3]))")
|
||||
3)
|
||||
|
||||
(er-ffi-test
|
||||
"list_to_binary nested iolist"
|
||||
(ffi-ev "byte_size(list_to_binary([1, <<2,3>>, [4, [5]]]))")
|
||||
5)
|
||||
|
||||
(er-ffi-test
|
||||
"list_to_binary round-trip via binary_to_list"
|
||||
(ffi-nm (ffi-ev "list_to_binary(binary_to_list(<<10,20,30>>)) =:= <<10,20,30>>"))
|
||||
"true")
|
||||
|
||||
(er-ffi-test
|
||||
"binary_to_list non-binary -> error:badarg"
|
||||
(ffi-nm (ffi-ev "try binary_to_list(42) catch error:badarg -> ok end"))
|
||||
"ok")
|
||||
|
||||
(er-ffi-test
|
||||
"list_to_binary out-of-range byte -> error:badarg"
|
||||
(ffi-nm (ffi-ev "try list_to_binary([300]) catch error:badarg -> ok end"))
|
||||
"ok")
|
||||
|
||||
(er-ffi-test
|
||||
"list_to_binary non-iolist -> error:badarg"
|
||||
(ffi-nm (ffi-ev "try list_to_binary(42) catch error:badarg -> ok end"))
|
||||
"ok")
|
||||
|
||||
;; ── Still deferred (no host primitive): httpc (HTTP client, v2),
|
||||
;; sqlite-* (v2 indexes). Assert NOT registered so a future iteration
|
||||
;; that wires them without updating this suite fails fast.
|
||||
|
||||
@@ -229,13 +229,37 @@
|
||||
(= ch "$")
|
||||
(do
|
||||
(er-advance! 1)
|
||||
(if
|
||||
(and (< pos src-len) (= (er-cur) "\\"))
|
||||
(do
|
||||
(er-advance! 1)
|
||||
(when (< pos src-len) (er-advance! 1)))
|
||||
(when (< pos src-len) (er-advance! 1)))
|
||||
(er-emit! "integer" (slice src start pos) start)
|
||||
;; Emit the char's decimal code as the integer token value
|
||||
;; (was: raw "$X" text — parse-number then returned nil).
|
||||
(let
|
||||
((code (cond
|
||||
(>= pos src-len) 0
|
||||
(= (er-cur) "\\")
|
||||
(do
|
||||
(er-advance! 1)
|
||||
(let ((esc (if (< pos src-len) (er-cur) "")))
|
||||
(when (< pos src-len) (er-advance! 1))
|
||||
(cond
|
||||
(= esc "n") 10
|
||||
(= esc "t") 9
|
||||
(= esc "r") 13
|
||||
(= esc "s") 32
|
||||
(= esc "b") 8
|
||||
(= esc "e") 27
|
||||
(= esc "f") 12
|
||||
(= esc "v") 11
|
||||
(= esc "d") 127
|
||||
(= esc "0") 0
|
||||
(= esc "\\") 92
|
||||
(= esc "\"") 34
|
||||
(= esc "'") 39
|
||||
(= esc "") 0
|
||||
:else (char->integer (nth (string->list esc) 0)))))
|
||||
:else
|
||||
(let ((c (er-cur)))
|
||||
(er-advance! 1)
|
||||
(char->integer (nth (string->list c) 0))))))
|
||||
(er-emit! "integer" (str code) start))
|
||||
(scan!))
|
||||
(er-lower? ch)
|
||||
(do
|
||||
|
||||
@@ -107,7 +107,12 @@
|
||||
(let
|
||||
((ty (get node :type)))
|
||||
(cond
|
||||
(= ty "integer") (parse-number (get node :value))
|
||||
(= ty "integer")
|
||||
(let ((n (parse-number (get node :value))))
|
||||
(cond
|
||||
(= n nil) (error (str "Erlang: invalid integer literal: "
|
||||
(get node :value)))
|
||||
:else (truncate n)))
|
||||
(= ty "float") (parse-number (get node :value))
|
||||
(= ty "atom") (er-mk-atom (get node :value))
|
||||
(= ty "string") (get node :value)
|
||||
@@ -821,16 +826,30 @@
|
||||
(len (get v :elements))
|
||||
(error "Erlang: tuple_size: not a tuple")))))
|
||||
|
||||
(define er-string->charlist
|
||||
(fn (s)
|
||||
(let ((cs (string->list s)) (out (er-mk-nil)))
|
||||
(for-each
|
||||
(fn (i)
|
||||
(set! out (er-mk-cons
|
||||
(char->integer (nth cs (- (- (len cs) 1) i)))
|
||||
out)))
|
||||
(range 0 (len cs)))
|
||||
out)))
|
||||
|
||||
(define
|
||||
er-bif-atom-to-list
|
||||
(fn
|
||||
(vs)
|
||||
(let
|
||||
((v (er-bif-arg1 vs "atom_to_list")))
|
||||
;; Standard Erlang: atom_to_list/1 returns an Erlang charlist
|
||||
;; (list of integer char codes). Was: SX string of :name —
|
||||
;; unusable from Erlang-land for [Char|T] / ++ / binary segments.
|
||||
(if
|
||||
(er-atom? v)
|
||||
(get v :name)
|
||||
(error "Erlang: atom_to_list: not an atom")))))
|
||||
(er-string->charlist (get v :name))
|
||||
(raise (er-mk-error-marker (er-mk-atom "badarg")))))))
|
||||
|
||||
(define
|
||||
er-bif-list-to-atom
|
||||
@@ -838,10 +857,11 @@
|
||||
(vs)
|
||||
(let
|
||||
((v (er-bif-arg1 vs "list_to_atom")))
|
||||
(if
|
||||
(= (type-of v) "string")
|
||||
(er-mk-atom v)
|
||||
(error "Erlang: list_to_atom: not a string")))))
|
||||
;; Accept Erlang charlist (cons of ints) or SX string.
|
||||
(let ((s (er-source-to-string v)))
|
||||
(cond
|
||||
(= s nil) (raise (er-mk-error-marker (er-mk-atom "badarg")))
|
||||
:else (er-mk-atom s))))))
|
||||
|
||||
;; ── lists module ─────────────────────────────────────────────────
|
||||
(define
|
||||
@@ -1597,10 +1617,12 @@
|
||||
(vs)
|
||||
(let
|
||||
((v (er-bif-arg1 vs "integer_to_list")))
|
||||
;; Standard Erlang: integer_to_list/1 returns an Erlang charlist
|
||||
;; (e.g. integer_to_list(42) -> [$4, $2] -> [52, 50]).
|
||||
(cond
|
||||
(not (= (type-of v) "number"))
|
||||
(raise (er-mk-error-marker (er-mk-atom "badarg")))
|
||||
:else (str v)))))
|
||||
:else (er-string->charlist (str v))))))
|
||||
|
||||
(define
|
||||
er-bif-list-to-integer
|
||||
@@ -1608,15 +1630,14 @@
|
||||
(vs)
|
||||
(let
|
||||
((v (er-bif-arg1 vs "list_to_integer")))
|
||||
(cond
|
||||
(not (= (type-of v) "string"))
|
||||
(raise (er-mk-error-marker (er-mk-atom "badarg")))
|
||||
:else (let
|
||||
((n (parse-number v)))
|
||||
(cond
|
||||
(= n nil)
|
||||
(raise (er-mk-error-marker (er-mk-atom "badarg")))
|
||||
:else n))))))
|
||||
;; Accept Erlang charlist (cons of ints) or SX string.
|
||||
(let ((s (er-source-to-string v)))
|
||||
(cond
|
||||
(= s nil) (raise (er-mk-error-marker (er-mk-atom "badarg")))
|
||||
:else (let ((n (parse-number s)))
|
||||
(cond
|
||||
(= n nil) (raise (er-mk-error-marker (er-mk-atom "badarg")))
|
||||
:else n)))))))
|
||||
|
||||
(define
|
||||
er-bif-is-function
|
||||
|
||||
281
plans/acl-on-sx.md
Normal file
281
plans/acl-on-sx.md
Normal file
@@ -0,0 +1,281 @@
|
||||
# acl-on-sx: Access Control on Datalog
|
||||
|
||||
rose-ash needs fine-grained, explainable, federation-aware access control. Subjects
|
||||
(users, groups, roles, services) × actions (read, edit, comment, moderate, federate)
|
||||
× resources (pages, posts, threads, peers). Decisions must come with a trace — not just
|
||||
permit/deny, but **why**.
|
||||
|
||||
Datalog's bottom-up rule engine produces transparent permit/deny chains: the proof tree
|
||||
is the audit trail. Inheritance over groups + resource hierarchies is recursive Datalog
|
||||
in one rule. Federation extends naturally — fed-sx replicates ACL facts, peers reason
|
||||
over the union.
|
||||
|
||||
End-state: a Datalog-on-SX layer specifically for ACL, with explanation API, audit log,
|
||||
and federation extension. Reuses `lib/datalog/` evaluator and term model where possible.
|
||||
|
||||
## Status (rolling)
|
||||
|
||||
`bash lib/acl/conformance.sh` → **145/145** (all four phases + hardening)
|
||||
|
||||
## Ground rules
|
||||
|
||||
- **Scope:** only touch `lib/acl/**` and `plans/acl-on-sx.md`. Do **not** edit `spec/`,
|
||||
`hosts/`, `shared/`, `lib/datalog/**`, or other `lib/<lang>/`. You may **import**
|
||||
from `lib/datalog/` (its public API in `lib/datalog/datalog.sx`); do **not** copy or
|
||||
modify Datalog code.
|
||||
- **Shared-file issues** go under "Blockers" with a minimal repro; do not fix here.
|
||||
- **SX files:** use `sx-tree` MCP tools only.
|
||||
- **Architecture:** thin layer on top of `lib/datalog/`. Define schema, surface API,
|
||||
audit + federation hooks. The rule engine itself is Datalog's.
|
||||
- **Watch for shared patterns** going into `lib/guest/` — both acl-sx and mod-sx need
|
||||
rule-engine plumbing. If you find shared shape, flag it for extraction (don't
|
||||
extract yet — wait for mod-sx to start).
|
||||
- **Commits:** one feature per commit. Keep Progress log updated and tick boxes.
|
||||
|
||||
## Architecture sketch
|
||||
|
||||
```
|
||||
ACL declarations (SX) User query
|
||||
│ │
|
||||
▼ ▼
|
||||
lib/acl/schema.sx lib/acl/api.sx
|
||||
— subject sorts — (acl/permit? subj act res)
|
||||
— resource sorts — (acl/explain subj act res)
|
||||
— action sorts — (acl/audit subj act res :allowed?)
|
||||
— fact schema │
|
||||
│ ▼
|
||||
▼ lib/acl/engine.sx
|
||||
lib/acl/facts.sx — builds Datalog query
|
||||
— actor(id, kind) — invokes lib/datalog/
|
||||
— resource(id, kind) — extracts proof tree
|
||||
— member_of(actor, group) │
|
||||
— child_of(res, parent) ▼
|
||||
— grant(actor, act, res) lib/acl/audit.sx
|
||||
— deny (actor, act, res) — persistent decision log
|
||||
— query API
|
||||
```
|
||||
|
||||
## Phase 1 — Direct grants
|
||||
|
||||
- [x] `lib/acl/schema.sx` — sorts: subject {user, group, role, service}, action,
|
||||
resource {page, post, thread, peer}
|
||||
- [x] `lib/acl/facts.sx` — `actor`, `resource`, `grant`, `deny` predicates as Datalog
|
||||
EDB
|
||||
- [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
|
||||
|
||||
- [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
|
||||
- [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
|
||||
|
||||
- [x] `(acl/explain subj act res)` → `{:allowed? T :proof <tree>}`
|
||||
- [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
|
||||
|
||||
- [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
|
||||
|
||||
- **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
|
||||
|
||||
- **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.
|
||||
93
plans/agent-briefings/acl-loop.md
Normal file
93
plans/agent-briefings/acl-loop.md
Normal file
@@ -0,0 +1,93 @@
|
||||
# acl-on-sx loop agent (single agent, queue-driven)
|
||||
|
||||
Role: iterates `plans/acl-on-sx.md` forever. **First subsystem loop after fed-sx.**
|
||||
Sits on `lib/datalog/` — rule engine reused, schema/api/audit/federation added on
|
||||
top. The deliverable isn't "implement Datalog ACL"; it's *also* to surface shared
|
||||
rule-engine plumbing into `lib/guest/` (the mod-sx loop will be the second consumer,
|
||||
validating extraction).
|
||||
|
||||
```
|
||||
description: acl-on-sx queue loop
|
||||
subagent_type: general-purpose
|
||||
run_in_background: true
|
||||
isolation: worktree
|
||||
```
|
||||
|
||||
## Prompt
|
||||
|
||||
You are the sole background agent working `/root/rose-ash/plans/acl-on-sx.md`.
|
||||
Isolated worktree, forever, one commit per feature. Push to `origin/loops/acl`
|
||||
after every commit.
|
||||
|
||||
## Restart baseline — check before iterating
|
||||
|
||||
1. Read `plans/acl-on-sx.md` — roadmap + Progress log.
|
||||
2. `ls lib/acl/` — pick up from the most advanced file.
|
||||
3. If `lib/acl/tests/*.sx` exist, run them via `bash lib/acl/conformance.sh`. Green
|
||||
before new work.
|
||||
4. If `lib/acl/scoreboard.md` exists, that's your baseline.
|
||||
5. Read `lib/datalog/datalog.sx` public API once — that's your substrate.
|
||||
|
||||
## The queue
|
||||
|
||||
Phase order per `plans/acl-on-sx.md`:
|
||||
|
||||
- **Phase 1** — direct grants. Schema, EDB facts, engine, api, 15+ tests
|
||||
- **Phase 2** — inheritance (member_of, child_of, role expansion, deny-overrides)
|
||||
- **Phase 3** — explanation + audit (proof tree, audit log)
|
||||
- **Phase 4** — federation (peer trust, delegation, cross-instance permit chain)
|
||||
|
||||
Within a phase, pick the checkbox that unlocks the most tests per effort.
|
||||
|
||||
Every iteration: implement → test → commit → tick `[ ]` → Progress log → next.
|
||||
|
||||
## Ground rules (hard)
|
||||
|
||||
- **Scope:** only `lib/acl/**` and `plans/acl-on-sx.md`. Do **not** edit `spec/`,
|
||||
`hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root.
|
||||
May **import** from `lib/datalog/` only (its public API).
|
||||
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers
|
||||
entry, stop.
|
||||
- **Shared-file issues** → plan's Blockers with minimal repro.
|
||||
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
|
||||
- **Worktree:** commit, then push to `origin/loops/acl`. Never touch `main` or
|
||||
`architecture`.
|
||||
- **Commit granularity:** one feature per commit. Short factual messages
|
||||
(`acl: child_of resource inheritance + 8 tests`).
|
||||
- **Plan file:** update Progress log + tick boxes every commit.
|
||||
- **Watch for shared infrastructure** with future mod-sx (Prolog moderation). If you
|
||||
build a generic rule-engine adapter, note it in Progress log so the eventual
|
||||
`lib/guest/rules/` extraction has both consumers identified.
|
||||
|
||||
## ACL-specific gotchas
|
||||
|
||||
- **Datalog is bottom-up.** No goal-directed search. Don't reach for cut or
|
||||
backtracking — that's mod-sx's job. Your decisions emerge from fixpoint.
|
||||
- **Deny-overrides** is the policy: if both an allow and deny rule fire, deny wins.
|
||||
Encode this via stratified negation; document the choice clearly in plan.
|
||||
- **Inheritance termination:** recursive rules with `member_of` chains must
|
||||
terminate. Datalog guarantees this absent function symbols — don't introduce them
|
||||
in your schema.
|
||||
- **Proof tree shape:** Datalog's derivation graph is a DAG, not a tree, when the
|
||||
same fact is derived multiple ways. For audit, pick one canonical derivation
|
||||
(shortest, or first); document choice.
|
||||
- **Federation isn't transitive trust.** A peer's `delegate(...)` fact only applies
|
||||
if local `trust(peer, level)` covers the action class. Re-check trust on every
|
||||
query, not at fact-ingestion time.
|
||||
|
||||
## General gotchas (all loops)
|
||||
|
||||
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
|
||||
- `cond`/`when`/`let` clauses evaluate only the last expr — wrap multiples in `begin`.
|
||||
- `env-bind!` creates a binding; `env-set!` mutates an existing one (walks scope chain).
|
||||
- `sx_validate` after every structural edit.
|
||||
- `list?` returns false on raw JS Arrays — host data must be SX-converted.
|
||||
|
||||
## Style
|
||||
|
||||
- No comments in `.sx` unless non-obvious.
|
||||
- No new planning docs — update `plans/acl-on-sx.md` inline.
|
||||
- Short, factual commit messages.
|
||||
- One feature per iteration. Commit. Log. Push. Next.
|
||||
|
||||
Go. Start by reading the plan; find the first unchecked `[ ]`; implement it.
|
||||
99
plans/agent-briefings/feed-loop.md
Normal file
99
plans/agent-briefings/feed-loop.md
Normal file
@@ -0,0 +1,99 @@
|
||||
# feed-on-sx loop agent (single agent, queue-driven)
|
||||
|
||||
Role: iterates `plans/feed-on-sx.md` forever. **Activity feeds on APL** — timelines,
|
||||
notifications, fanout, ranking, all as APL array math on activity vectors. Densest
|
||||
possible expression of feed composition. Sits on `lib/apl/` (450+/450+ tests
|
||||
already); adds a feed-shaped vocabulary on top.
|
||||
|
||||
```
|
||||
description: feed-on-sx queue loop
|
||||
subagent_type: general-purpose
|
||||
run_in_background: true
|
||||
isolation: worktree
|
||||
```
|
||||
|
||||
## Prompt
|
||||
|
||||
You are the sole background agent working `/root/rose-ash/plans/feed-on-sx.md`.
|
||||
Isolated worktree, forever, one commit per feature. Push to `origin/loops/feed`
|
||||
after every commit.
|
||||
|
||||
## Restart baseline — check before iterating
|
||||
|
||||
1. Read `plans/feed-on-sx.md` — roadmap + Progress log.
|
||||
2. `ls lib/feed/` — pick up from the most advanced file.
|
||||
3. If `lib/feed/tests/*.sx` exist, run them via `bash lib/feed/conformance.sh`. Green
|
||||
before new work.
|
||||
4. If `lib/feed/scoreboard.md` exists, that's your baseline.
|
||||
5. Read `lib/apl/apl.sx` public API once — that's your substrate. Familiarize
|
||||
yourself with at least: `⍳ ⍴ / ⌽ ↑ ↓ ⌷ ∊ ∘.× /\ ⍋` (you will use all of these).
|
||||
|
||||
## The queue
|
||||
|
||||
Phase order per `plans/feed-on-sx.md`:
|
||||
|
||||
- **Phase 1** — stream model + basic ops (record schema, filter, sort, take)
|
||||
- **Phase 2** — **THE SHOWCASE**: fanout via outer product. activities `∘.×`
|
||||
followers → inbox matrix, flatten + dedupe
|
||||
- **Phase 3** — aggregation + ranking (group-by, velocity, recency, top-N)
|
||||
- **Phase 4** — visibility filter (acl-sx) + federation (fed-sx inbox + backfill)
|
||||
|
||||
Within a phase, pick the checkbox that unlocks the most tests per effort.
|
||||
|
||||
Every iteration: implement → test → commit → tick `[ ]` → Progress log → next.
|
||||
|
||||
## Ground rules (hard)
|
||||
|
||||
- **Scope:** only `lib/feed/**` and `plans/feed-on-sx.md`. Do **not** edit `spec/`,
|
||||
`hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root.
|
||||
May **import** from `lib/apl/` only (its public API).
|
||||
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers
|
||||
entry, stop.
|
||||
- **Shared-file issues** → plan's Blockers with minimal repro.
|
||||
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
|
||||
- **Unicode in `.sx`:** raw UTF-8 only, never `\uXXXX` escapes. APL glyphs land
|
||||
directly in source.
|
||||
- **Worktree:** commit, then push to `origin/loops/feed`. Never touch `main` or
|
||||
`architecture`.
|
||||
- **Commit granularity:** one feature per commit. Short factual messages
|
||||
(`feed: outer-product fanout + dedupe by (actor,verb,object) + 9 tests`).
|
||||
- **Plan file:** update Progress log + tick boxes every commit.
|
||||
|
||||
## feed-specific gotchas
|
||||
|
||||
- **Activities are heterogeneous.** Different verbs carry different shapes
|
||||
(`:object` might be page-id, post-id, user-id). Don't over-normalize — keep
|
||||
`:tags` as a flexible bag. APL operations over heterogeneous records work fine
|
||||
via dict lookups; only the indexed fields need uniform shape.
|
||||
- **Fanout produces matrices fast.** N activities × M followers → NM items. Apply
|
||||
filter/dedupe early, not after materialization. Use guard predicates *inside*
|
||||
the outer product where possible (compose with `∘.{a v ⊢ ...}`).
|
||||
- **Dedupe key isn't always `(actor,verb,object)`.** For "alice liked X" and "bob
|
||||
liked X" the dedupe key is `(verb,object)` (collapse the actors into a list).
|
||||
For "alice posted X" each `:actor` is distinct. Each verb may want its own
|
||||
dedupe rule; codify these in `lib/feed/dedupe.sx`.
|
||||
- **Recency decay matters more than score precision.** Use a simple half-life decay
|
||||
(e.g. score × 0.5^(age/window)) rather than a clever curve. Calibrate the
|
||||
window via tests, not theory.
|
||||
- **Ranking should be deterministic on ties.** Always include a tiebreaker (id, or
|
||||
hash). Otherwise tests will flake.
|
||||
- **The ACL filter is per-viewer.** A timeline is computed *for* a user; the same
|
||||
candidate stream produces different timelines for different viewers. Don't
|
||||
cache pre-ACL timelines.
|
||||
|
||||
## General gotchas (all loops)
|
||||
|
||||
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
|
||||
- `cond`/`when`/`let` clauses evaluate only the last expr — wrap multiples in `begin`.
|
||||
- `env-bind!` creates a binding; `env-set!` mutates an existing one (walks scope chain).
|
||||
- `sx_validate` after every structural edit.
|
||||
- `list?` returns false on raw JS Arrays — host data must be SX-converted.
|
||||
|
||||
## Style
|
||||
|
||||
- No comments in `.sx` unless non-obvious.
|
||||
- No new planning docs — update `plans/feed-on-sx.md` inline.
|
||||
- Short, factual commit messages.
|
||||
- One feature per iteration. Commit. Log. Push. Next.
|
||||
|
||||
Go. Start by reading the plan; find the first unchecked `[ ]`; implement it.
|
||||
98
plans/agent-briefings/flow-loop.md
Normal file
98
plans/agent-briefings/flow-loop.md
Normal file
@@ -0,0 +1,98 @@
|
||||
# flow-on-sx loop agent (single agent, queue-driven)
|
||||
|
||||
Role: iterates `plans/flow-on-sx.md` forever. **Durable workflows on Scheme** — the
|
||||
call/cc + delimited continuation showcase that justifies pulling R7RS into
|
||||
production. art-dag's natural successor: DAG-of-tasks with pause/resume across
|
||||
process restarts. fed-sx extension turns local flows into distributed ones.
|
||||
|
||||
```
|
||||
description: flow-on-sx queue loop
|
||||
subagent_type: general-purpose
|
||||
run_in_background: true
|
||||
isolation: worktree
|
||||
```
|
||||
|
||||
## Prompt
|
||||
|
||||
You are the sole background agent working `/root/rose-ash/plans/flow-on-sx.md`.
|
||||
Isolated worktree, forever, one commit per feature. Push to `origin/loops/flow`
|
||||
after every commit.
|
||||
|
||||
## Restart baseline — check before iterating
|
||||
|
||||
1. Read `plans/flow-on-sx.md` — roadmap + Progress log.
|
||||
2. `ls lib/flow/` — pick up from the most advanced file.
|
||||
3. If `lib/flow/tests/*.sx` exist, run them via `bash lib/flow/conformance.sh`. Green
|
||||
before new work.
|
||||
4. If `lib/flow/scoreboard.md` exists, that's your baseline.
|
||||
5. Read `lib/scheme/scheme.sx` public API once — that's your substrate.
|
||||
|
||||
## The queue
|
||||
|
||||
Phase order per `plans/flow-on-sx.md`:
|
||||
|
||||
- **Phase 1** — declarative DAG: `defflow`, `sequence`, `parallel`, sync runtime,
|
||||
basic api
|
||||
- **Phase 2** — control flow + error handling: `cond`, `retry`, `timeout`,
|
||||
`try-catch`
|
||||
- **Phase 3** — **THE SHOWCASE**: `suspend`/`resume` via `call/cc`, persistent
|
||||
store, crash recovery
|
||||
- **Phase 4** — distributed nodes via fed-sx (remote-node, handoff, replication)
|
||||
|
||||
Within a phase, pick the checkbox that unlocks the most tests per effort.
|
||||
|
||||
Every iteration: implement → test → commit → tick `[ ]` → Progress log → next.
|
||||
|
||||
## Ground rules (hard)
|
||||
|
||||
- **Scope:** only `lib/flow/**` and `plans/flow-on-sx.md`. Do **not** edit `spec/`,
|
||||
`hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root.
|
||||
May **import** from `lib/scheme/` only (its public API).
|
||||
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers
|
||||
entry, stop.
|
||||
- **Shared-file issues** → plan's Blockers with minimal repro.
|
||||
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
|
||||
- **Worktree:** commit, then push to `origin/loops/flow`. Never touch `main` or
|
||||
`architecture`.
|
||||
- **Commit granularity:** one feature per commit. Short factual messages
|
||||
(`flow: retry combinator with exponential backoff + 6 tests`).
|
||||
- **Plan file:** update Progress log + tick boxes every commit.
|
||||
|
||||
## flow-specific gotchas
|
||||
|
||||
- **Continuations must be re-entrant.** Phase 3's `suspend` captures a continuation
|
||||
that may be re-entered after a process restart. That means: no captured file
|
||||
descriptors, no captured sockets, no captured live runtime references that won't
|
||||
survive serialization. State referenced by the continuation must be plain SX data
|
||||
or live in the flow store.
|
||||
- **call/cc, not call-with-escape-continuation.** R7RS distinguishes. Use the full
|
||||
call/cc for resume; escape-only continuations cannot be re-entered. Read
|
||||
`lib/scheme/r7rs.md` (or equivalent) to confirm semantics.
|
||||
- **`parallel` in Phase 1 is sequential.** Don't try threading until Phase 3+. Just
|
||||
evaluate branches in order, collect results, return joined value. Document the
|
||||
semantics clearly so users don't assume true concurrency.
|
||||
- **Retry doesn't retry continuations.** If a node has already suspended, retry on
|
||||
resume doesn't re-run it from scratch — it resumes. `retry` only applies to
|
||||
exceptions raised before suspend. Be explicit in the API.
|
||||
- **Cancellation invalidates the continuation.** `(flow/cancel id)` must remove the
|
||||
stored continuation so a stale `resume` cannot wake it. Document semantics.
|
||||
- **Timeouts in pure SX are tricky.** Without a scheduler, `timeout` is a budget on
|
||||
step count or wall-clock probed at safe points. Pick one approach (probably step
|
||||
budget for determinism) and document.
|
||||
|
||||
## General gotchas (all loops)
|
||||
|
||||
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
|
||||
- `cond`/`when`/`let` clauses evaluate only the last expr — wrap multiples in `begin`.
|
||||
- `env-bind!` creates a binding; `env-set!` mutates an existing one (walks scope chain).
|
||||
- `sx_validate` after every structural edit.
|
||||
- `list?` returns false on raw JS Arrays — host data must be SX-converted.
|
||||
|
||||
## Style
|
||||
|
||||
- No comments in `.sx` unless non-obvious.
|
||||
- No new planning docs — update `plans/flow-on-sx.md` inline.
|
||||
- Short, factual commit messages.
|
||||
- One feature per iteration. Commit. Log. Push. Next.
|
||||
|
||||
Go. Start by reading the plan; find the first unchecked `[ ]`; implement it.
|
||||
106
plans/agent-briefings/kernel-loop.md
Normal file
106
plans/agent-briefings/kernel-loop.md
Normal file
@@ -0,0 +1,106 @@
|
||||
# kernel-on-sx loop agent (single agent, queue-driven)
|
||||
|
||||
Role: iterates `plans/kernel-on-sx.md` forever. **First chisel of the Phase B stratification work** — natural successor to env-as-value, validates SX's reflection story (first-class environments, evaluators, operatives). Goal isn't just "implement Kernel"; it's *also* to surface common patterns into `lib/guest/` (specifically motivating a future `lib/guest/reflective/` sub-layer). One feature per commit.
|
||||
|
||||
```
|
||||
description: kernel-on-sx queue loop
|
||||
subagent_type: general-purpose
|
||||
run_in_background: true
|
||||
isolation: worktree
|
||||
```
|
||||
|
||||
## DO NOT START WITHOUT THE PREREQUISITES
|
||||
|
||||
This loop **must not** start until the lib-guest core kits are in place. Kernel's parser consumes `lib/guest/core/lex.sx` and `lib/guest/core/pratt.sx` (s-expression-shaped, minimal demand); its evaluator's pattern dispatch consumes `lib/guest/core/match.sx`.
|
||||
|
||||
**Pre-flight check:**
|
||||
```
|
||||
ls /root/rose-ash/lib/guest/lex.sx /root/rose-ash/lib/guest/pratt.sx \
|
||||
/root/rose-ash/lib/guest/match.sx /root/rose-ash/lib/guest/ast.sx
|
||||
```
|
||||
If any of those `lib/guest/*.sx` files are missing, **stop and report**. Do not start.
|
||||
|
||||
## Prompt
|
||||
|
||||
You are the sole background agent working `/root/rose-ash/plans/kernel-on-sx.md`. You run in an isolated git worktree on branch `loops/kernel`. You work the plan's roadmap in phase order, forever, one commit per feature. Push to `origin/loops/kernel` after every commit.
|
||||
|
||||
## Restart baseline — check before iterating
|
||||
|
||||
1. Read `plans/kernel-on-sx.md` — Roadmap + Progress log + Blockers tell you where you are.
|
||||
2. Run the pre-flight check above. If any lib/guest kit is missing, stop immediately and update the plan's Blockers section.
|
||||
3. `ls lib/kernel/` — pick up from the most advanced file that exists. If the directory does not exist, you are at Phase 1.
|
||||
4. If `lib/kernel/tests/*.sx` exist, run them via the epoch protocol against `sx_server.exe`. They must be green before new work.
|
||||
|
||||
## The queue
|
||||
|
||||
Phase order per `plans/kernel-on-sx.md`:
|
||||
|
||||
- **Phase 1** — Parser (s-expression reader, minimal — consumes `lib/guest/lex` + `lib/guest/pratt`)
|
||||
- **Phase 2** — Core evaluator with first-class environments
|
||||
- **Phase 3** — `$vau` / `$lambda` / `wrap` / `unwrap` (the operative–applicative distinction)
|
||||
- **Phase 4** — Standard environment construction
|
||||
- **Phase 5** — Encapsulations (Kernel's opaque-type idiom)
|
||||
- **Phase 6** — Hygienic operatives (Shutt's later work — operatives that don't capture)
|
||||
- **Phase 7** — Propose `lib/guest/reflective/` (extraction phase — see chiselling discipline)
|
||||
|
||||
Within a phase, pick the checkbox with the best tests-per-effort ratio.
|
||||
|
||||
Every iteration: implement → test → commit → tick `[ ]` in plan → append Progress log → push → next.
|
||||
|
||||
## Lib/guest chiselling discipline (the defining feature of this loop)
|
||||
|
||||
You are not just implementing Kernel — you are *chiselling* the substrate to surface what `lib/guest/reflective/` should contain. Every commit must end with a one-line **"chisel note"** appended to the plan's Progress log entry, in this format:
|
||||
|
||||
```
|
||||
chisel: <one of: consumes-X | shapes-reflective | proposes-Y | nothing>
|
||||
```
|
||||
|
||||
- `consumes-X` — this commit used an existing `lib/guest/X` kit (e.g., `consumes-pratt`, `consumes-match`).
|
||||
- `shapes-reflective` — this commit revealed something about what `lib/guest/reflective/` should look like (e.g., env-reification helper signatures, applicative-vs-operative dispatch protocol). Add a paragraph to the plan's "lib/guest feedback loop" section describing the insight.
|
||||
- `proposes-Y` — this commit revealed a gap in another existing kit (e.g., `match.sx` doesn't quite handle X). Open a Blockers entry describing the gap.
|
||||
- `nothing` — pure Kernel work that didn't touch the substrate or lib/guest story (rare; if you write this twice in a row, stop and reflect on why).
|
||||
|
||||
**Phase 7 (extraction)** is **gated** by the two-consumer rule. Kernel alone is one consumer. The natural second consumer is a future MetaScheme port, a Common-Lisp meta-evaluator port, or a Kernel dialect (cKanren-style). **Until a second consumer exists, do NOT actually extract** — instead, mark Phase 7 `[partial — pending second consumer]` and document the proposed `lib/guest/reflective/` API surface in the plan's progress log. The extraction itself happens later, when a second consumer materialises.
|
||||
|
||||
This discipline is the point of the loop, not a bookkeeping tax. The chisel notes are what tell us — at the end of Kernel's run — whether a `lib/guest/reflective/` sub-layer is real or just one-language-shaped.
|
||||
|
||||
## Ground rules (hard)
|
||||
|
||||
- **Scope:** only `lib/kernel/**` and `plans/kernel-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, `lib/guest/**` (read-only consumer at this phase), or other `lib/<lang>/`.
|
||||
- **Consume `lib/guest/core/`** wherever it covers a need. Hand-rolling defeats the chiselling goal.
|
||||
- **Do not extract into `lib/guest/reflective/` from this loop.** That's Phase 7 territory, gated by the two-consumer rule. Until there's a second consumer, document the API surface only.
|
||||
- **Substrate gaps** (env-as-value not exposing X, `eval` semantics drift, JIT not handling reflective patterns) → Blockers entry with minimal repro. Do **not** fix substrate from this loop. Substrate work belongs to `sx-improvements.md` / `jit-perf-regression.md`.
|
||||
- **NEVER call `sx_build`.** 600s watchdog will kill you. If `sx_server.exe` is broken, add a Blockers entry and stop.
|
||||
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after every edit. Never `Edit`/`Read`/`Write` on `.sx`.
|
||||
- **Worktree:** commit, then push to `origin/loops/kernel`. Never touch `main`. Never push to `architecture`.
|
||||
- **Commit granularity:** one feature per commit. Short factual messages: `kernel: $vau operative + 6 tests`.
|
||||
- **Plan file:** update Progress log + tick boxes every commit. Include the chisel note.
|
||||
- **If blocked** for two iterations on the same issue, add to Blockers and move on.
|
||||
|
||||
## Kernel-specific gotchas
|
||||
|
||||
- **Operatives don't evaluate their arguments.** `$vau` builds an operative; the body sees the *unevaluated* argument expressions plus the dynamic environment. This is the opposite of every other guest in the set. `(define-via-vau)` builds a binding by calling `eval` inside the body on the (still-syntax) argument.
|
||||
- **Applicatives wrap operatives.** `(wrap op)` produces an applicative that evaluates its args first, then calls `op` with the values. `$lambda` is sugar for `wrap` ∘ `$vau`.
|
||||
- **Dynamic vs static environments.** Operative body sees both: the static env where the `$vau` was created (closure-style), AND the dynamic env where the call happens (passed as the env-param). Different from lexical-only languages.
|
||||
- **No special forms in the evaluator.** `$if`, `$define!`, `$lambda` are all just operatives bound in the standard environment. The evaluator is `lookup-and-call` — no hardcoded switch on symbols. This is the whole point: the language is reified as data.
|
||||
- **`eval` is a primitive callable on user environments.** This is where SX's env-as-value matters most. If env-as-value isn't fully landed in the substrate, this is where it'll break.
|
||||
- **Encapsulations (Phase 5) are Kernel's opaque-types idiom.** `make-encapsulation-type` returns three operatives: encapsulator (constructs), predicate (tests), decapsulator (extracts). Used to define promises, streams, modules.
|
||||
- **Hygienic operatives (Phase 6) are research-grade.** Shutt's later work. Operatives that don't accidentally capture caller bindings. Likely uses scope sets / frame stamps. Treat as exploration, not implementation-deadline.
|
||||
|
||||
## General gotchas (all loops)
|
||||
|
||||
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
|
||||
- `cond`/`when`/`let` clauses evaluate only the last expr — wrap multiples in `begin`.
|
||||
- `env-bind!` creates a binding; `env-set!` mutates an existing one (walks scope chain).
|
||||
- `sx_validate` after every structural edit.
|
||||
- `list?` returns false on raw JS Arrays — host data must be SX-converted.
|
||||
- Shell heredoc `||` gets eaten — escape or use `case`.
|
||||
|
||||
## Style
|
||||
|
||||
- No comments in `.sx` unless non-obvious.
|
||||
- No new planning docs — update `plans/kernel-on-sx.md` inline.
|
||||
- Short, factual commit messages with chisel note: `kernel: $vau operative + 6 tests [shapes-reflective]`.
|
||||
- One feature per iteration. Commit. Log. Push. Next.
|
||||
|
||||
Go. Run the pre-flight check. If lib/guest kits are missing, stop. Otherwise read the plan, find the first unchecked `[ ]`, implement it. Remember: every commit ends with a chisel note, and Phase 7 extraction waits for a second consumer.
|
||||
105
plans/feed-on-sx.md
Normal file
105
plans/feed-on-sx.md
Normal file
@@ -0,0 +1,105 @@
|
||||
# feed-on-sx: Activity Feeds on APL
|
||||
|
||||
Timelines, notifications, activity aggregation. The math is array math: filter, sort,
|
||||
reduce, scan, outer product. APL is the densest possible expression of feed
|
||||
composition — a fanout-and-rank pipeline reads as a single line.
|
||||
|
||||
rose-ash needs: per-user home timeline, notification feed, activity stream digestion,
|
||||
backfill for new follows, deduplication across cross-posts. Every operation is an
|
||||
array-shaped transformation.
|
||||
|
||||
End-state: an APL-flavored layer on `lib/apl/` with feed-specific combinators
|
||||
(`fanout`, `dedupe`, `score`, `rank`), an SX adapter for callers who don't want raw
|
||||
APL, ACL visibility filtering via `lib/acl/`, federation via fed-sx.
|
||||
|
||||
## Status (rolling)
|
||||
|
||||
`bash lib/feed/conformance.sh` → **0/0** (not yet started)
|
||||
|
||||
## Ground rules
|
||||
|
||||
- **Scope:** only touch `lib/feed/**` and `plans/feed-on-sx.md`. Do **not** edit
|
||||
`spec/`, `hosts/`, `shared/`, `lib/apl/**`, or other `lib/<lang>/`. You may
|
||||
**import** from `lib/apl/` (public API in `lib/apl/apl.sx`); do **not** modify APL.
|
||||
- **Shared-file issues** go under "Blockers" with a minimal repro; do not fix here.
|
||||
- **SX files:** use `sx-tree` MCP tools only.
|
||||
- **Architecture:** an activity is a small dict (`{:actor :verb :object :at :tags}`); a
|
||||
stream is an APL vector of such dicts. Operations are APL primitives lifted onto
|
||||
this shape. SX adapter exposes ergonomic API to non-APL callers.
|
||||
- **Unicode:** raw UTF-8 in `.sx` files. APL glyphs land directly.
|
||||
- **Commits:** one feature per commit. Keep Progress log updated and tick boxes.
|
||||
|
||||
## Architecture sketch
|
||||
|
||||
```
|
||||
Raw activities (any shape) Per-user view
|
||||
│ ▲
|
||||
▼ │
|
||||
lib/feed/normalize.sx lib/feed/timeline.sx
|
||||
— {:actor :verb :object — (timeline user)
|
||||
:at :tags} record — applies filter ∘ rank ∘ take
|
||||
│ ▲
|
||||
▼ │
|
||||
lib/feed/stream.sx lib/feed/rank.sx
|
||||
— APL vector of activities — velocity, recency
|
||||
— filter, sort, take — TF-IDF-ish over :tags
|
||||
│ ▲
|
||||
▼ │
|
||||
lib/feed/fanout.sx lib/feed/dedupe.sx
|
||||
— followers vector — group by :object
|
||||
— activities ∘.× followers — collapse cross-posts
|
||||
— flatten + dedupe
|
||||
│
|
||||
▼
|
||||
lib/feed/api.sx lib/feed/fed.sx
|
||||
— (feed/post activity) — inbox via fed-sx
|
||||
— (feed/timeline user) — backfill on subscribe
|
||||
— (feed/notify user)
|
||||
```
|
||||
|
||||
## Phase 1 — Stream model + basic ops
|
||||
|
||||
- [ ] `lib/feed/normalize.sx` — activity record schema; coerce arbitrary inputs
|
||||
- [ ] `lib/feed/stream.sx` — APL vector representation; filter by predicate; sort by
|
||||
`:at`; take N (`↑`); reverse (`⌽`)
|
||||
- [ ] `lib/feed/api.sx` — `(feed/post activity)`, `(feed/all)`
|
||||
- [ ] `lib/feed/tests/basic.sx` — 15+ cases: post, query, filter, sort
|
||||
- [ ] `lib/feed/scoreboard.{json,md}`
|
||||
- [ ] `lib/feed/conformance.sh`
|
||||
|
||||
## Phase 2 — Fanout via outer product
|
||||
|
||||
- [ ] follower graph: `followers user → vector of user ids`
|
||||
- [ ] fanout: activities `∘.×` followers → matrix `(activity, follower)` pairs
|
||||
- [ ] flatten to inbox events vector
|
||||
- [ ] dedupe — group by `(actor, verb, object)` collapse to one inbox event per
|
||||
receiver
|
||||
- [ ] `lib/feed/tests/fanout.sx` — 20+ cases: small graph, mutual follow, popular
|
||||
actor (high-fanout), cross-post dedupe
|
||||
|
||||
## Phase 3 — Aggregation + ranking
|
||||
|
||||
- [ ] group-by — `(actor, day) → count` via key-reduce
|
||||
- [ ] velocity score — recent activity count over window
|
||||
- [ ] recency score — decay by age
|
||||
- [ ] composite rank — weighted sum of components
|
||||
- [ ] top-N per timeline
|
||||
- [ ] `lib/feed/tests/rank.sx` — 20+ cases: ranking stable on tie, decay shape,
|
||||
per-user weighting
|
||||
|
||||
## Phase 4 — Visibility filter + federation
|
||||
|
||||
- [ ] ACL filter — each candidate activity passed through `(acl/permit? viewer :read
|
||||
activity)`
|
||||
- [ ] fed-sx outbound — local `feed/post` fans out to remote followers' inboxes
|
||||
- [ ] fed-sx inbound — peer activities arrive at local inbox
|
||||
- [ ] backfill on subscribe — request peer history, merge into local stream
|
||||
- [ ] `lib/feed/tests/integration.sx` — federated timeline with ACL applied
|
||||
|
||||
## Progress log
|
||||
|
||||
(loop fills this in)
|
||||
|
||||
## Blockers
|
||||
|
||||
(loop fills this in)
|
||||
108
plans/flow-on-sx.md
Normal file
108
plans/flow-on-sx.md
Normal file
@@ -0,0 +1,108 @@
|
||||
# flow-on-sx: Durable DAG Workflows on Scheme
|
||||
|
||||
rose-ash needs workflows that survive restarts: content pipelines (write → review →
|
||||
publish → federate), scheduled jobs (digest emails), multi-step user flows (signup,
|
||||
confirm, onboard). art-dag is the precedent — DAG-of-tasks with pause/resume at IO
|
||||
boundaries.
|
||||
|
||||
Scheme's `call/cc` + delimited continuations make pause/resume natural: a `suspend`
|
||||
captures the continuation, serializes it as part of the flow record, and `resume`
|
||||
re-enters at exactly that point. No state-machine bookkeeping by hand. R7RS-small is
|
||||
already at 2644/2644 (see kernel/architecture status).
|
||||
|
||||
End-state: a Scheme-on-SX layer over the existing scheme runtime, with combinators
|
||||
for sequence/parallel/branch/retry/timeout/suspend, persistent flow store, and a
|
||||
federation extension via fed-sx for remote-node execution.
|
||||
|
||||
## Status (rolling)
|
||||
|
||||
`bash lib/flow/conformance.sh` → **0/0** (not yet started)
|
||||
|
||||
## Ground rules
|
||||
|
||||
- **Scope:** only touch `lib/flow/**` and `plans/flow-on-sx.md`. Do **not** edit
|
||||
`spec/`, `hosts/`, `shared/`, `lib/scheme/**`, or other `lib/<lang>/`. You may
|
||||
**import** from `lib/scheme/` (public API via `lib/scheme/scheme.sx`); do **not**
|
||||
modify Scheme.
|
||||
- **Shared-file issues** go under "Blockers" with a minimal repro; do not fix here.
|
||||
- **SX files:** use `sx-tree` MCP tools only.
|
||||
- **Architecture:** flow combinators are Scheme macros + procedures. Runtime is a
|
||||
driver loop that walks the flow graph and invokes `call/cc` at `suspend` points.
|
||||
Persistence layer serializes the continuation + open file/socket placeholders are
|
||||
forbidden (continuations must be resumable across process restart).
|
||||
- **art-dag awareness:** read `plans/art-dag*` if it exists for design lineage; do not
|
||||
import code.
|
||||
- **Commits:** one feature per commit. Keep Progress log updated and tick boxes.
|
||||
|
||||
## Architecture sketch
|
||||
|
||||
```
|
||||
(defflow publish
|
||||
(sequence
|
||||
(write-content)
|
||||
(parallel
|
||||
(review)
|
||||
(spell-check))
|
||||
(cond approved?
|
||||
(sequence (publish) (federate))
|
||||
(notify-author))))
|
||||
│
|
||||
▼
|
||||
lib/flow/spec.sx lib/flow/runtime.sx lib/flow/store.sx
|
||||
— defflow — driver loop — append-only flow log
|
||||
— sequence/parallel — node dispatch — checkpoint serialize
|
||||
— cond/retry/timeout — call/cc at suspend — restart loader
|
||||
— suspend/resume │ │
|
||||
▼ ▼
|
||||
lib/flow/api.sx lib/flow/remote.sx
|
||||
— (flow/start name args) — fed-sx adapter
|
||||
— (flow/resume id value) — node-on-peer execution
|
||||
— (flow/cancel id) — failure handling
|
||||
```
|
||||
|
||||
## Phase 1 — Declarative DAG + sequential execution
|
||||
|
||||
- [ ] `lib/flow/spec.sx` — `defflow` macro, `sequence` combinator
|
||||
- [ ] node = Scheme thunk; output threads to next node (data flow)
|
||||
- [ ] `parallel` combinator (sequential semantics for now — TRUE parallelism in Phase 3)
|
||||
- [ ] runtime executes a flow synchronously, returns final value
|
||||
- [ ] `lib/flow/api.sx` — `(flow/start name args)` entry point
|
||||
- [ ] `lib/flow/tests/basic.sx` — 15+ cases: linear sequence, nested sequences,
|
||||
data flow between nodes, parallel-with-join
|
||||
- [ ] `lib/flow/scoreboard.{json,md}`
|
||||
- [ ] `lib/flow/conformance.sh`
|
||||
|
||||
## Phase 2 — Control flow + error handling
|
||||
|
||||
- [ ] `cond` combinator — predicate selects branch
|
||||
- [ ] `retry n [backoff]` — re-runs node up to n times on exception
|
||||
- [ ] `timeout ms` — bounds node execution
|
||||
- [ ] `try-catch` — exception handler with reified error
|
||||
- [ ] error model — exceptions vs explicit `(fail :reason ...)` results
|
||||
- [ ] `lib/flow/tests/control.sx` — 25+ cases: each combinator + composition
|
||||
|
||||
## Phase 3 — Suspend / resume (the showcase)
|
||||
|
||||
- [ ] `(suspend reason)` — `call/cc` captures continuation, returns flow-id to caller
|
||||
- [ ] `lib/flow/store.sx` — serialize flow state (continuation + open vars)
|
||||
- [ ] `(flow/resume id value)` — load continuation, inject value, re-enter
|
||||
- [ ] `(flow/cancel id)` — explicit termination
|
||||
- [ ] crash recovery — on restart, scan store for paused flows, mark resumable
|
||||
- [ ] `lib/flow/tests/suspend.sx` — pause-resume scenarios, cancellation, "restart"
|
||||
scenarios (simulated by re-loading store)
|
||||
|
||||
## Phase 4 — Distributed nodes via fed-sx
|
||||
|
||||
- [ ] `(remote-node addr fn args)` — execute node on a federation peer
|
||||
- [ ] failure semantics — retry on different peer, fall through to local
|
||||
- [ ] persistence across instances — flow state replicates via fed-sx
|
||||
- [ ] handoff — flow started here can resume on a peer if the local instance is down
|
||||
- [ ] `lib/flow/tests/distributed.sx` — federated flow scenarios (mock fed-sx in tests)
|
||||
|
||||
## Progress log
|
||||
|
||||
(loop fills this in)
|
||||
|
||||
## Blockers
|
||||
|
||||
(loop fills this in)
|
||||
112
plans/mod-on-sx.md
Normal file
112
plans/mod-on-sx.md
Normal file
@@ -0,0 +1,112 @@
|
||||
# mod-on-sx: Moderation on Prolog
|
||||
|
||||
rose-ash needs moderation infrastructure: reports flagged by users, automated
|
||||
classifications (spam, abuse), tiered escalation (auto → human → appeal), audit
|
||||
trails. Each decision is the conclusion of a backtracking search over evidence and
|
||||
policy rules — exactly what Prolog does.
|
||||
|
||||
Where acl-sx says "may this happen?", mod-sx says "should this stay?" The former is
|
||||
a positive decision (proof of grant); the latter often a negative one (proof of
|
||||
violation), and policy chains naturally backtrack: if the first rule doesn't apply,
|
||||
try the next.
|
||||
|
||||
End-state: a Prolog-on-SX layer for moderation policy declaration and evaluation,
|
||||
with persistent report lifecycle, audit log, escalation state machine, and
|
||||
federation extension.
|
||||
|
||||
## Status (rolling)
|
||||
|
||||
`bash lib/mod/conformance.sh` → **0/0** (not yet started)
|
||||
|
||||
## Ground rules
|
||||
|
||||
- **Scope:** only touch `lib/mod/**` and `plans/mod-on-sx.md`. Do **not** edit
|
||||
`spec/`, `hosts/`, `shared/`, `lib/prolog/**`, or other `lib/<lang>/`. You may
|
||||
**import** from `lib/prolog/` (public API in `lib/prolog/prolog.sx`); do **not**
|
||||
modify Prolog.
|
||||
- **Shared-file issues** go under "Blockers" with a minimal repro; do not fix here.
|
||||
- **SX files:** use `sx-tree` MCP tools only.
|
||||
- **Architecture:** policies are Prolog rules over `report(...)` and `evidence(...)`
|
||||
facts. Decisions are query results. Proof trees become audit records. The state
|
||||
machine for report lifecycle is separate (an SX module on top).
|
||||
- **Shared with acl-sx:** rule-engine plumbing may be liftable into `lib/guest/`.
|
||||
Watch for it; flag in Progress log but do not extract until both subsystems are
|
||||
past Phase 2.
|
||||
- **Commits:** one feature per commit. Keep Progress log updated and tick boxes.
|
||||
|
||||
## Architecture sketch
|
||||
|
||||
```
|
||||
Report Decision
|
||||
{:by :about :reason :at} {:action :proof :next-state}
|
||||
│ ▲
|
||||
▼ │
|
||||
lib/mod/schema.sx lib/mod/engine.sx
|
||||
— report/4, evidence/2, — query Prolog with report fact
|
||||
classification/3 predicates — extract proof tree
|
||||
│ ▲
|
||||
▼ │
|
||||
lib/mod/policy.sx lib/mod/lifecycle.sx
|
||||
— rule syntax → Prolog — state machine
|
||||
— action heads: — open → triaged → decided
|
||||
{:keep :hide :remove — appeal handling
|
||||
:escalate :ban} │
|
||||
│ ▼
|
||||
▼ lib/mod/audit.sx
|
||||
lib/mod/api.sx — append-only decision log
|
||||
— (mod/report ...) — proof tree persistence
|
||||
— (mod/decide report) — query API
|
||||
— (mod/appeal id)
|
||||
│
|
||||
▼
|
||||
lib/mod/fed.sx
|
||||
— cross-instance reports via fed-sx
|
||||
— decision sharing / trust model
|
||||
```
|
||||
|
||||
## Phase 1 — Report representation + simple policy
|
||||
|
||||
- [ ] `lib/mod/schema.sx` — `report(id, by, about, reason)`, `evidence(id, kind, val)`,
|
||||
`policy-action(report, action)` predicates as Prolog facts/rules
|
||||
- [ ] `lib/mod/policy.sx` — rule declarations: `(defrule action :when conditions)`
|
||||
desugars to Prolog clause
|
||||
- [ ] `lib/mod/engine.sx` — `(decide report-id)` runs Prolog query, returns first
|
||||
matching action
|
||||
- [ ] `lib/mod/api.sx` — `(mod/report by about reason)`, `(mod/decide id)`
|
||||
- [ ] `lib/mod/tests/decide.sx` — 15+ cases: spam keyword → hide, repeated reports →
|
||||
escalate, no rule matches → keep
|
||||
- [ ] `lib/mod/scoreboard.{json,md}`
|
||||
- [ ] `lib/mod/conformance.sh`
|
||||
|
||||
## Phase 2 — Evidence + audit trail
|
||||
|
||||
- [ ] evidence accumulation — additional facts asserted before query
|
||||
- [ ] proof tree from Prolog derivation tree
|
||||
- [ ] `lib/mod/audit.sx` — append-only log (decision + proof + evidence snapshot)
|
||||
- [ ] `(mod/audit id)` retrieval
|
||||
- [ ] `lib/mod/tests/audit.sx` — proof correctness, trail completeness
|
||||
|
||||
## Phase 3 — Escalation + lifecycle state machine
|
||||
|
||||
- [ ] state machine: `:open → :triaged → :decided → :appealed → :final`
|
||||
- [ ] auto-tier: first-pass rules decide quick cases
|
||||
- [ ] human-tier: rules that emit `:escalate` move to next state
|
||||
- [ ] appeal: re-runs with appeal evidence, may override prior decision
|
||||
- [ ] `(mod/appeal id new-evidence)` API
|
||||
- [ ] `lib/mod/tests/escalation.sx` — full lifecycle traversal cases
|
||||
|
||||
## Phase 4 — Federation
|
||||
|
||||
- [ ] cross-instance reports — peer raises report about local content (or vice versa)
|
||||
- [ ] decision sharing — actions taken locally propagate to peers via fed-sx
|
||||
- [ ] trust model — peer's decision is advisory unless `(trust peer :mod)` is granted
|
||||
- [ ] revocation — undo applied moderation if proof was invalidated
|
||||
- [ ] `lib/mod/tests/fed.sx` — federated decision chains (mock fed-sx in tests)
|
||||
|
||||
## Progress log
|
||||
|
||||
(loop fills this in)
|
||||
|
||||
## Blockers
|
||||
|
||||
(loop fills this in)
|
||||
106
plans/search-on-sx.md
Normal file
106
plans/search-on-sx.md
Normal file
@@ -0,0 +1,106 @@
|
||||
# search-on-sx: Full-text + structured search on Haskell
|
||||
|
||||
rose-ash needs search across pages, posts, threads, federated content. Tokenize,
|
||||
index, query, rank, filter by visibility. Typed ADTs make query parsing clean,
|
||||
lazy lists make posting-list iteration efficient, and Haskell-on-SX is at 1514/1514.
|
||||
|
||||
End-state: a Haskell-on-SX layer with inverted index, query AST, boolean +
|
||||
phrase + ranked queries (TF-IDF, BM25), ACL-aware post-filter, and a federation
|
||||
extension that merges per-peer indices.
|
||||
|
||||
## Status (rolling)
|
||||
|
||||
`bash lib/search/conformance.sh` → **0/0** (not yet started)
|
||||
|
||||
## Ground rules
|
||||
|
||||
- **Scope:** only touch `lib/search/**` and `plans/search-on-sx.md`. Do **not** edit
|
||||
`spec/`, `hosts/`, `shared/`, `lib/haskell/**`, or other `lib/<lang>/`. You may
|
||||
**import** from `lib/haskell/` (public API in `lib/haskell/haskell.sx`); do **not**
|
||||
modify Haskell.
|
||||
- **Shared-file issues** go under "Blockers" with a minimal repro; do not fix here.
|
||||
- **SX files:** use `sx-tree` MCP tools only.
|
||||
- **Architecture:** index = `Map Term [(DocId, [Pos])]`. Query AST = ADT. Eval =
|
||||
fold of posting lists with set ops + ranking math. Ranking is pure (no IO until
|
||||
result emission).
|
||||
- **Commits:** one feature per commit. Keep Progress log updated and tick boxes.
|
||||
|
||||
## Architecture sketch
|
||||
|
||||
```
|
||||
Document Query
|
||||
{:id :text :tags} "alice AND bob OR phrase \"x y\""
|
||||
│ │
|
||||
▼ ▼
|
||||
lib/search/tokenize.sx lib/search/parse.sx
|
||||
— tokenize :: Text → [Term] — parse :: Text → Query
|
||||
— normalize (lowercase, strip) — Query = Term | And | Or
|
||||
— (optionally) stem | Not | Phrase
|
||||
│ │
|
||||
▼ ▼
|
||||
lib/search/index.sx lib/search/eval.sx
|
||||
— Map Term [(DocId, [Pos])] — eval :: Index → Query → [DocId]
|
||||
— insert / delete / lookup — boolean + phrase positions
|
||||
— persistence (optional later) │
|
||||
│ ▼
|
||||
└────────────────► lib/search/rank.sx
|
||||
— TF-IDF / BM25 scoring
|
||||
— top-N
|
||||
│
|
||||
▼
|
||||
lib/search/api.sx
|
||||
— (search/index doc)
|
||||
— (search/query q)
|
||||
— (search/top n q)
|
||||
│
|
||||
▼
|
||||
lib/search/fed.sx
|
||||
— federated query (merge peer results)
|
||||
— ACL filter post-merge
|
||||
```
|
||||
|
||||
## Phase 1 — Tokenize + index
|
||||
|
||||
- [ ] `lib/search/tokenize.sx` — normalize (lowercase, strip punctuation), split on
|
||||
whitespace, return positions
|
||||
- [ ] `lib/search/index.sx` — inverted index data structure (typed `Map` from
|
||||
haskell lib); `insert`, `delete`, `lookup`
|
||||
- [ ] `lib/search/api.sx` — `(search/index doc)`, `(search/lookup term)`
|
||||
- [ ] `lib/search/tests/index.sx` — 15+ cases: tokenize, insert + lookup, update,
|
||||
delete, multi-doc
|
||||
- [ ] `lib/search/scoreboard.{json,md}`
|
||||
- [ ] `lib/search/conformance.sh`
|
||||
|
||||
## Phase 2 — Query AST + boolean evaluation
|
||||
|
||||
- [ ] Query ADT: `Term Text | And Query Query | Or Query Query | Not Query |
|
||||
Phrase [Text]`
|
||||
- [ ] `lib/search/parse.sx` — query syntax parser (boolean operators, quoted phrases)
|
||||
- [ ] `lib/search/eval.sx` — boolean eval via set ops on posting lists
|
||||
- [ ] phrase eval — adjacency check using positions
|
||||
- [ ] `lib/search/tests/boolean.sx` — 25+ cases: term, and, or, not, phrase,
|
||||
composition, parser edge cases
|
||||
|
||||
## Phase 3 — Ranking
|
||||
|
||||
- [ ] document frequency tracking — extend index with `df` per term
|
||||
- [ ] TF-IDF scoring
|
||||
- [ ] BM25 scoring (configurable k1, b)
|
||||
- [ ] top-N retrieval (heap-based)
|
||||
- [ ] `lib/search/tests/rank.sx` — 20+ cases: TF-IDF behavior, BM25 vs TF-IDF,
|
||||
ranking stability, top-N correctness
|
||||
|
||||
## Phase 4 — ACL filter + federation
|
||||
|
||||
- [ ] post-filter — each candidate result tested via `(acl/permit? viewer :read doc)`
|
||||
- [ ] federated query — fan out to peer instances via fed-sx, merge results
|
||||
- [ ] merge policy — interleave by rank, dedupe by `(peer, doc-id)`
|
||||
- [ ] `lib/search/tests/integration.sx` — federated search with ACL filter
|
||||
|
||||
## Progress log
|
||||
|
||||
(loop fills this in)
|
||||
|
||||
## Blockers
|
||||
|
||||
(loop fills this in)
|
||||
Reference in New Issue
Block a user