Add unification enforcement gates
ober
b0a3980d35f9e13ce11005331b67b0f64a66ad63
new file mode 100644 --- /dev/null +++ b/.jerboa-system @@ -0,0 +1,120 @@ +(system + (schema "jerboa.system/1") + (name jerboa) + (version "0.1.0") + (kind stack) + (language jerboa) + + (commands + (canonical "jerboa") + (links ("jerbuild" "jmcp" "jlsp")) + (modes + (jerboa + (role runtime) + (description "REPL, script runner, and explicit mode selector")) + (jerbuild + (role build) + (entry "jerbuild.ss") + (description "Compiler, package/build driver, and artifact generator")) + (jmcp + (role agent-tooling) + (entry "mcp/server.ss") + (description "MCP server and Jerboa tooling catalog")) + (jlsp + (role editor-tooling) + (entry "lsp/main-binary.ss") + (description "LSP server")))) + + (source + (entries ("jerbuild.ss" "mcp/server.ss" "lsp/main-binary.ss" + "tools/check-system-manifest.ss" "tools/system-report.ss" + "tools/system-provenance.ss" "tools/system-diff.ss" + "tools/check-audit-events.ss" + "tools/check-generated-policy.ss" + "tools/workspace-health.ss" + "tools/capability-plan.ss" + "tools/check-capability-use.ss" + "tools/check-native-boundary.ss" + "tools/check-install-policy.ss" + "tools/tcb-report.ss")) + (libraries ("lib/" "src/" "tools/")) + (tests ("tests/")) + (docs ("docs/")) + (examples ("examples/audit-events.sexp")) + (generated + ("build/" "dist/" "lsp/analysis/completion-tables.ss" + "*.sls" "*.so" "*.wpo" "*.boot"))) + + (dependencies + (vendored ("vendor/ChezScheme")) + (native ("jerboa-native-rs")) + (external-tools ("cc" "cargo" "make" "tar" "ln" "rm" "mkdir" "find" + "shasum|sha256sum"))) + + (capabilities + (filesystem + (read ".") + (write "build/" "dist/" ".chez/" ".chez-cross-*/") + (execute ".chez/bin/scheme" "cc" "cargo" "make" "tar" "ln" "rm" "mkdir" + "find" "shasum" "sha256sum")) + (network + (connect none) + (listen none)) + (process + (spawn ("scheme" "cc" "cargo" "make" "tar" "ln" "rm" "mkdir" "find" + "shasum" "sha256sum"))) + (environment + (read "JERBOA_HOME" "SCHEME" "CHEZ_DIR" "CC" "TARGET_MACHINE" + "JERBOA_CROSS_PREFIX" "JERBOA_XPATCH" "JERBOA_MCP_REPO" + "JERBOA_MCP_MODE") + (deny "*")) + (secrets + (read none)) + (eval + (modules declared-by-tooling)) + (native + (load ("jerboa-native-rs" "support/*.c"))) + (package + (install none) + (build declared) + (publish planned) + (sign planned))) + + (build + (mode multicall) + (primary-target "jerboa") + (test-targets ("system-check" "system-strict" "system-report" + "system-provenance" "system-diff" "audit-event-check" + "generated-policy-check" "unification-check" + "workspace-health" "capability-plan" + "capability-use-check" "native-boundary-check" + "install-policy-check" "tcb-report" + "unification-release-check" "jerboa-smoke" "mcp-test-binary" + "jlsp")) + (outputs ("dist/jerboa" "dist/jerbuild" "dist/jmcp" "dist/jlsp")) + (reproducible partial) + (install-code none) + (native rust-plus-audited-c-shims)) + + (provenance + (content-addressed planned) + (lock-file planned) + (signing planned) + (sbom planned) + (tcb ("Chez Scheme" "Jerboa stdlib" "jerboa-native-rs" + "support/multicall-main.c" "support/jerboa-embed.c" + "support/jerboa-embed.h" + "support/landlock-shim.c"))) + + (native-boundary + (rust ("jerboa-native-rs")) + (c-shims ("support/multicall-main.c" "support/jerboa-embed.c" + "support/jerboa-embed.h" "support/landlock-shim.c")) + (ffi-wrapper-policy explicit-safe-wrapper) + (fuzz planned)) + + (audit + (schema "jerboa.audit/1") + (required-events + (capability/check package/resolve build/start build/finish + provenance/sign native/load eval/run)))) --- a/AGENTS.md +++ b/AGENTS.md @@ -90,7 +90,7 @@ The following names from other Scheme dialects are aliased in `(jerboa prelude)` - `(string-split str delimiter)` where delimiter is a CHAR: `(string-split "a,b" #\,)` - `(make-rwlock)` — takes **0 args**, NOT `(make-rwlock 'name)` (Gerbil takes a name; Jerboa does not) - `(path-expand path)` — takes **1 arg**, NOT `(path-expand rel base)` (Gerbil takes 2; use `path-join` for 2-arg) -- `(sort predicate list)` — Chez arg order. NOT `(sort list predicate)` which is Gerbil/SRFI order +- `(sort list predicate)` — Jerboa `(std sort)`/prelude order. Raw Chez `sort` is predicate-first, but Jerboa-facing code should use list first. ### Core Forms (all from `(import (jerboa prelude))`) --- a/Makefile +++ b/Makefile @@ -56,6 +56,20 @@ help: @echo " binary-cross Build a jerboa-bin for a foreign target (same args as chez-cross)" @echo " jerboa Build the busybox-style multicall binary: dist/jerboa" @echo " + symlinks dist/{jmcp,jlsp,jerbuild} (one image, all four modes)" + @echo " system-check Validate .jerboa-system manifest" + @echo " system-strict Validate manifest and require declared outputs" + @echo " system-report Print unification health/provenance report" + @echo " system-provenance Emit machine-readable provenance S-expression" + @echo " system-diff Compare two manifests: OLD=path NEW=path" + @echo " audit-event-check Validate audit events: AUDIT=path" + @echo " generated-policy-check Validate generated artifact ignore policy" + @echo " workspace-health Summarize repo health: ROOT=path" + @echo " capability-plan Emit machine-readable capability plan" + @echo " capability-use-check Validate source capability use is declared" + @echo " native-boundary-check Validate native Rust/C/FFI boundaries" + @echo " install-policy-check Enforce no install-time code policy" + @echo " tcb-report Emit machine-readable TCB inventory" + @echo " unification-check Run manifest/report/provenance/diff/audit checks" @echo " jerboa-portable Build the multicall binary for host + linux-amd64 + freebsd-amd64" @echo " (cross targets need: make chez-cross CHEZ_TARGET_MACHINE=ta6le|ta6fb ...)" @echo " native-cross Cross-build Rust native lib for a target" @@ -235,6 +249,68 @@ jerbuild-smoke: jerbuild jerboa: chez build mcp-check lsp-gen $(SCHEME) --script support/build-jerboa-multicall.ss +.PHONY: system-check +system-check: + @$(SCHEME) --libdirs $(LIBDIRS) --script tools/check-system-manifest.ss .jerboa-system + +.PHONY: system-strict +system-strict: + @$(SCHEME) --libdirs $(LIBDIRS) --script tools/check-system-manifest.ss --strict .jerboa-system + +.PHONY: system-report +system-report: + @$(SCHEME) --libdirs $(LIBDIRS) --script tools/system-report.ss .jerboa-system + +.PHONY: system-provenance +system-provenance: + @$(SCHEME) --libdirs $(LIBDIRS) --script tools/system-provenance.ss .jerboa-system + +OLD ?= .jerboa-system +NEW ?= .jerboa-system +.PHONY: system-diff +system-diff: + @$(SCHEME) --libdirs $(LIBDIRS) --script tools/system-diff.ss "$(OLD)" "$(NEW)" + +AUDIT ?= examples/audit-events.sexp +.PHONY: audit-event-check +audit-event-check: + @$(SCHEME) --libdirs $(LIBDIRS) --script tools/check-audit-events.ss .jerboa-system "$(AUDIT)" + +.PHONY: generated-policy-check +generated-policy-check: + @$(SCHEME) --libdirs $(LIBDIRS) --script tools/check-generated-policy.ss .jerboa-system .gitignore + +ROOT ?= . +.PHONY: workspace-health +workspace-health: + @$(SCHEME) --libdirs $(LIBDIRS) --script tools/workspace-health.ss "$(ROOT)" + +.PHONY: capability-plan +capability-plan: + @$(SCHEME) --libdirs $(LIBDIRS) --script tools/capability-plan.ss .jerboa-system + +.PHONY: capability-use-check +capability-use-check: + @$(SCHEME) --libdirs $(LIBDIRS) --script tools/check-capability-use.ss .jerboa-system + +.PHONY: native-boundary-check +native-boundary-check: + @$(SCHEME) --libdirs $(LIBDIRS) --script tools/check-native-boundary.ss .jerboa-system + +.PHONY: install-policy-check +install-policy-check: + @$(SCHEME) --libdirs $(LIBDIRS) --script tools/check-install-policy.ss .jerboa-system + +.PHONY: tcb-report +tcb-report: + @$(SCHEME) --libdirs $(LIBDIRS) --script tools/tcb-report.ss .jerboa-system + +.PHONY: unification-check +unification-check: system-check generated-policy-check workspace-health capability-plan capability-use-check native-boundary-check install-policy-check system-report system-provenance tcb-report system-diff audit-event-check + +.PHONY: unification-release-check +unification-release-check: system-strict generated-policy-check workspace-health capability-plan capability-use-check native-boundary-check install-policy-check system-report system-provenance tcb-report system-diff audit-event-check + # End-to-end smoke test: all four modes from the single binary + its symlinks. jerboa-smoke: jerboa @D=$(CURDIR)/dist; fail=0; \ @@ -243,6 +319,9 @@ jerboa-smoke: jerboa $$D/jlsp --version >/dev/null 2>&1 && echo " jlsp: PASS" || { echo " jlsp: FAIL" >&2; fail=1; }; \ echo '{"jsonrpc":"2.0","id":1,"method":"initialize","params":{}}' | $$D/jmcp 2>/dev/null | grep -q '"jerboa-mcp"' && echo " jmcp: PASS" || { echo " jmcp: FAIL" >&2; fail=1; }; \ $$D/jerbuild --version | grep -q 'sha256=' && echo " jerbuild: PASS" || { echo " jerbuild: FAIL" >&2; fail=1; }; \ + $$D/jerboa jlsp --version >/dev/null 2>&1 && echo " jerboa jlsp: PASS" || { echo " jerboa jlsp: FAIL" >&2; fail=1; }; \ + echo '{"jsonrpc":"2.0","id":1,"method":"initialize","params":{}}' | $$D/jerboa jmcp 2>/dev/null | grep -q '"jerboa-mcp"' && echo " jerboa jmcp: PASS" || { echo " jerboa jmcp: FAIL" >&2; fail=1; }; \ + $$D/jerboa jerbuild --version | grep -q 'sha256=' && echo " jerboa build: PASS" || { echo " jerboa build: FAIL" >&2; fail=1; }; \ rm -f /tmp/jms.ss; \ [ $$fail -eq 0 ] && echo "jerboa-smoke: PASS" || { echo "jerboa-smoke: FAIL" >&2; exit 1; } --- a/data/cookbooks.sexp +++ b/data/cookbooks.sexp @@ -894,7 +894,7 @@ ("title" . "LZ4 Compression (Bytevector Format)")) (("code" . - "(import (std profile))\n\n;; Full profile: wall time, CPU time, bytes allocated\n(let-values ([(result stats) (with-profile (lambda () (sort < (iota 10000))))])\n (assq 'wall-ms stats) ;; => (wall-ms . N)\n (assq 'cpu-ms stats) ;; => (cpu-ms . N)\n (assq 'bytes-allocated stats)) ;; => (bytes-allocated . N)\n\n;; Quick timing with label (prints to stdout)\n(time-it \"sort\" (lambda () (sort < (iota 10000))))\n;; prints: sort: 5ms (4ms cpu, 40960 bytes allocated)\n;; returns: the sorted list\n\n;; Just wall clock time\n(let-values ([(result ms) (with-timing (lambda () (* 6 7)))])\n (printf \"took ~ams~n\" ms))\n\n;; Count allocation only\n(allocation-count (lambda () (make-vector 1000000)))\n;; => bytes allocated during thunk\n\n;; Stats-only (discard result)\n(profile-stats (lambda () (heavy-computation)))\n;; => ((wall-ms . N) (cpu-ms . N) (bytes-allocated . N))") ("id" . "jerboa-profile") ("imports" "(std profile)") + "(import (std profile))\n\n;; Full profile: wall time, CPU time, bytes allocated\n(let-values ([(result stats) (with-profile (lambda () (sort (iota 10000) <)))])\n (assq 'wall-ms stats) ;; => (wall-ms . N)\n (assq 'cpu-ms stats) ;; => (cpu-ms . N)\n (assq 'bytes-allocated stats)) ;; => (bytes-allocated . N)\n\n;; Quick timing with label (prints to stdout)\n(time-it \"sort\" (lambda () (sort (iota 10000) <)))\n;; prints: sort: 5ms (4ms cpu, 40960 bytes allocated)\n;; returns: the sorted list\n\n;; Just wall clock time\n(let-values ([(result ms) (with-timing (lambda () (* 6 7)))])\n (printf \"took ~ams~n\" ms))\n\n;; Count allocation only\n(allocation-count (lambda () (make-vector 1000000)))\n;; => bytes allocated during thunk\n\n;; Stats-only (discard result)\n(profile-stats (lambda () (heavy-computation)))\n;; => ((wall-ms . N) (cpu-ms . N) (bytes-allocated . N))") ("id" . "jerboa-profile") ("imports" "(std profile)") ("notes" . "with-profile uses time-monotonic for wall time and time-thread for CPU time. allocation-count forces a GC before measuring. time-it prints to current-output-port. All functions accept thunks (zero-argument lambdas).") @@ -2039,7 +2039,7 @@ "Gerbil→Jerboa: condition/report-string replacement")) (("code" . - ";; Quick reference for common Gerbil/Gambit→Chez translations:\\n\\n;; (user-info-home (user-info (user-name))) → (getenv \\\"HOME\\\")\\n;; (the-environment) → (interaction-environment)\\n;; (force-output port) → (flush-output-port port)\\n;; (random-integer n) → (random n)\\n;; (directory-exists? path) → (file-directory? path)\\n;; (arithmetic-shift n k) → (ash n k) or (bitwise-arithmetic-shift n k)\\n;; (eql? a b) → (eqv? a b)\\n;; (thread-yield!) → (sleep (make-time 'time-duration 0 0))\\n;; (make-rwlock 'name) → (make-rwlock) ; 0 args in Jerboa!\\n;; (sort lst pred) → (sort pred lst) ; reversed arg order!") ("id" . "gerbil-migration-misc") ("imports" "(chezscheme)") + ";; Quick reference for common Gerbil/Gambit→Chez translations:\\n\\n;; (user-info-home (user-info (user-name))) → (getenv \\\"HOME\\\")\\n;; (the-environment) → (interaction-environment)\\n;; (force-output port) → (flush-output-port port)\\n;; (random-integer n) → (random n)\\n;; (directory-exists? path) → (file-directory? path)\\n;; (arithmetic-shift n k) → (ash n k) or (bitwise-arithmetic-shift n k)\\n;; (eql? a b) → (eqv? a b)\\n;; (thread-yield!) → (sleep (make-time 'time-duration 0 0))\\n;; (make-rwlock 'name) → (make-rwlock) ; 0 args in Jerboa!\\n;; Jerboa sort is (sort lst pred); raw Chez sort is (sort pred lst).") ("id" . "gerbil-migration-misc") ("imports" "(chezscheme)") ("notes" . "Collected from 52 session transcripts. These are the most frequently hallucinated Gerbil/Gambit APIs. Each one has caused actual build failures in past sessions. The sort arg order reversal is especially common.") @@ -2049,16 +2049,16 @@ ("title" . "Gerbil→Jerboa: misc API translations")) (("code" . - ";; WRONG (Gerbil/SRFI order): (sort '(3 1 2) <) ;; list first\\n;; CORRECT (Chez/Jerboa order): (sort < '(3 1 2)) ;; predicate first!\\n;; → (1 2 3)\\n\\n;; R6RS alternative (same order as Chez):\\n;; (list-sort < '(3 1 2)) → (1 2 3)\\n\\n;; Sorting strings:\\n(sort string<? '(\\\"banana\\\" \\\"apple\\\" \\\"cherry\\\"))\\n;; → (\\\"apple\\\" \\\"banana\\\" \\\"cherry\\\")\\n\\n;; Sorting by a key:\\n(sort (lambda (a b) (< (cdr a) (cdr b)))\\n '((x . 3) (y . 1) (z . 2)))\\n;; → ((y . 1) (z . 2) (x . 3))") ("id" . "gerbil-migration-sort-order") + ";; Jerboa prelude/(std sort): list first, predicate second\n(sort '(3 1 2) <)\n;; → (1 2 3)\n\n;; Raw Chez/R6RS alternative: predicate first\n;; (list-sort < '(3 1 2)) → (1 2 3)\n\n;; Sorting strings:\n(sort '(\"banana\" \"apple\" \"cherry\") string<?)\n;; → (\"apple\" \"banana\" \"cherry\")\n\n;; Sorting by a key:\n(sort '((x . 3) (y . 1) (z . 2))\n (lambda (a b) (< (cdr a) (cdr b))))\n;; → ((y . 1) (z . 2) (x . 3))") ("id" . "gerbil-migration-sort-order") ("imports" "(jerboa prelude)") ("notes" . - "This is the #1 most confusing Gerbil→Chez difference. Gerbil uses (sort list pred), Chez uses (sort pred list). The Jerboa prelude re-exports Chez's sort. This has caused 80+ errors across sessions.") + "Jerboa prelude/(std sort) uses (sort list pred). Raw Chez sort and list-sort use (predicate list). Use the import context to choose the right order.") ("tags" "gerbil" "migration" "sort" "list-sort" "argument-order" "predicate") ("title" . - "Gerbil→Jerboa: sort argument order (pred list, NOT list pred)")) + "Jerboa sort argument order (list pred, NOT pred list)")) (("code" . ";; Lock current process to a directory (IRREVERSIBLE)\n;; Network access is preserved. Child processes inherit the cage.\n\n;; Minimal — lock to project dir with auto-detected system paths\n(cage! (make-cage-config 'root: \"/home/user/project\"))\n\n;; Full options\n(cage! (make-cage-config\n 'root: \"/home/user/project\" ;; read-write root (required)\n 'read-only: '(\"/usr/share/man\") ;; extra read-only paths\n 'read-write: '(\"/tmp/scratch\") ;; extra read-write paths\n 'execute: '(\"/opt/bin\") ;; extra execute paths\n 'network: #t ;; allow network (default #t)\n 'system-paths: 'auto ;; auto-detect runtime needs (default)\n 'temp-dir: \"/tmp\")) ;; writable temp (default: /tmp)\n\n;; Check cage state\n(cage-active?) ;; → #t after cage!\n(cage-root) ;; → resolved root path\n(cage-allowed-paths) ;; → alist of (mode . path)\n\n;; Platform dispatch:\n;; Linux → Landlock (kernel 5.13+, ABI v1-v7)\n;; macOS → Seatbelt (sandbox_init SBPL; irreversible for process lifetime)\n;; OpenBSD → pledge/unveil (stub, future)\n;; FreeBSD → Capsicum (stub, future)") ("id" . "cage-lock-directory") @@ -2246,17 +2246,17 @@ "jerbuild defstruct: positional constructors only, no transparent:")) (("code" . - ";; The prelude's sort uses Chez order: (sort predicate list)\n(sort < '(3 1 2)) ;; → (1 2 3) CORRECT\n\n;; DANGER: importing (std sort) shadows the prelude's sort with\n;; Gerbil/SRFI order: (sort list predicate)\n;; This causes a runtime crash — the list is passed as the comparator:\n;;\n;; (import (std sort))\n;; (sort < '(3 1 2))\n;; → Exception in list-sort: (3 1 2) is not a procedure\n;;\n;; The error is confusing because the list appears in the \"not a procedure\"\n;; message — it's being used as the predicate arg to the underlying list-sort.\n\n;; FIX: Never import (std sort) unless you deliberately want Gerbil order\n;; and flip all call sites to (sort list predicate).\n;; In .ss files processed by jerbuild, just use the prelude's sort directly.\n\n;; If you see \"is not a procedure\" in list-sort with a list as the argument,\n;; check all imports for (std sort) or :std/sort shadowing the prelude.") ("id" . "std-sort-import-shadows-prelude") + ";; The prelude and (std sort) both use Jerboa order: (sort list predicate)\n(sort '(3 1 2) <) ;; → (1 2 3) CORRECT\n\n;; Raw Chez sort is different:\n;; (import (chezscheme))\n;; (sort < '(3 1 2))\n;;\n;; In Jerboa-facing code, this predicate-first form causes a runtime crash —\n;; the list is eventually passed where a procedure is expected.\n\n;; FIX: Use (sort list predicate) in files that import (jerboa prelude) or\n;; (std sort). Use (list-sort predicate list) only when explicitly using the\n;; R6RS/Chez sorting API.") ("id" . "std-sort-import-shadows-prelude") ("imports" "(jerboa prelude)") ("notes" . - "This caused a silent UI-QUEUE-ERROR in a tabulated-list sort — the callback crashed silently and the buffer just stayed stuck showing \"Fetching...\". The error message 'Exception in list-sort: (...list of items...) is not a procedure' is the key signature: the list appears where a procedure is expected because (std sort) swapped the args. The fix is to remove the (std sort) import entirely and rely on the prelude's sort.") + "The error message 'Exception in list-sort: (...list of items...) is not a procedure' is the key signature for using raw Chez/predicate-first order in Jerboa-facing code.") ("related" "gerbil-migration-sort-order" "jerboa-sort") ("tags" "sort" "std sort" "import" "shadow" "argument-order" "prelude") ("title" . - "(std sort) import shadows prelude's sort with Gerbil arg order")) + "Jerboa sort uses list-first order")) (("code" . ";; SHA256 hash of string or bytevector\n(import (std crypto native))\n\n(define (sha256 data)\n (native-digest 'sha256\n (if (string? data) (string->utf8 data) data)))\n\n;; HMAC-SHA256 — key and data can be strings or bytevectors\n(define (hmac-sha256 key data)\n (native-hmac-sha256\n (if (string? key) (string->utf8 key) key)\n (if (string? data) (string->utf8 data) data)))\n\n;; Returns bytevectors. To get hex string:\n(define (bytes->hex bv)\n (apply string-append\n (map (lambda (b) (format \"~2,'0x\" b))\n (bytevector->u8-list bv))))\n\n(bytes->hex (sha256 \"hello world\"))\n;; => \"b94d27b9934d3e08a52e52d7da7dabfac484efe04294e576fbc9a08f\"...") ("id" . "std-crypto-native-sha256-hmac") @@ -3167,7 +3167,7 @@ "Stuart Sierra-style component lifecycle management")) (("code" . - ";; (std test check) provides QuickCheck-style property-based testing\n;; with automatic test-case generation and shrinking on failure.\n\n;; Define a property with for-all — binds generators to variables\n(def sort-preserves-length\n (for-all ([lst (gen:list (gen:integer))])\n (= (length (sort < lst)) (length lst))))\n\n;; Run with check-property — returns (ok N) or (fail i inputs shrunk depth)\n(check-property 100 sort-preserves-length) ;; => (ok 100)\n\n;; Generators\n(gen:sample (gen:integer) 5) ;; size-based integers: (-3 1 0 2 -1)\n(gen:sample (gen:nat) 5) ;; non-negative: (0 1 2 0 3)\n(gen:sample (gen:boolean) 4) ;; (#t #f #t #f)\n(gen:sample (gen:string) 3) ;; (\"\" \"a\" \"ab\")\n(gen:sample (gen:list (gen:integer)) 3) ;; (() (1) (-1 2))\n(gen:sample (gen:elements '(a b c)) 5) ;; (b a c a b)\n(gen:sample (gen:one-of (list (gen:integer) (gen:boolean))) 4)\n\n;; Combinator generators\n(gen:sample (gen:choose -100 100) 5) ;; uniform integers in range\n(gen:sample (gen:tuple (gen:integer) (gen:boolean)) 3) ;; paired\n(gen:sample (gen:such-that odd? (gen:integer)) 5) ;; filtered\n\n;; Custom generator via gen:fmap\n(def gen:positive-even\n (gen:fmap (lambda (n) (* 2 (abs n))) (gen:integer)))\n(gen:sample gen:positive-even 4)\n\n;; Property with multiple generators\n(check-property 50\n (for-all ([a (gen:nat)] [b (gen:nat)])\n (= (+ a b) (+ b a)))) ;; commutativity\n\n;; Example with shrinking (on failure, shrinks to minimal counter-example)\n(check-property 100\n (for-all ([n (gen:integer)])\n (< n 50))) ;; => (fail N (50) (50) 0) — shrunk to 50") ("id" . "test-check-property-based") + ";; (std test check) provides QuickCheck-style property-based testing\n;; with automatic test-case generation and shrinking on failure.\n\n;; Define a property with for-all — binds generators to variables\n(def sort-preserves-length\n (for-all ([lst (gen:list (gen:integer))])\n (= (length (sort lst <)) (length lst))))\n\n;; Run with check-property — returns (ok N) or (fail i inputs shrunk depth)\n(check-property 100 sort-preserves-length) ;; => (ok 100)\n\n;; Generators\n(gen:sample (gen:integer) 5) ;; size-based integers: (-3 1 0 2 -1)\n(gen:sample (gen:nat) 5) ;; non-negative: (0 1 2 0 3)\n(gen:sample (gen:boolean) 4) ;; (#t #f #t #f)\n(gen:sample (gen:string) 3) ;; (\"\" \"a\" \"ab\")\n(gen:sample (gen:list (gen:integer)) 3) ;; (() (1) (-1 2))\n(gen:sample (gen:elements '(a b c)) 5) ;; (b a c a b)\n(gen:sample (gen:one-of (list (gen:integer) (gen:boolean))) 4)\n\n;; Combinator generators\n(gen:sample (gen:choose -100 100) 5) ;; uniform integers in range\n(gen:sample (gen:tuple (gen:integer) (gen:boolean)) 3) ;; paired\n(gen:sample (gen:such-that odd? (gen:integer)) 5) ;; filtered\n\n;; Custom generator via gen:fmap\n(def gen:positive-even\n (gen:fmap (lambda (n) (* 2 (abs n))) (gen:integer)))\n(gen:sample gen:positive-even 4)\n\n;; Property with multiple generators\n(check-property 50\n (for-all ([a (gen:nat)] [b (gen:nat)])\n (= (+ a b) (+ b a)))) ;; commutativity\n\n;; Example with shrinking (on failure, shrinks to minimal counter-example)\n(check-property 100\n (for-all ([n (gen:integer)])\n (< n 50))) ;; => (fail N (50) (50) 0) — shrunk to 50") ("id" . "test-check-property-based") ("imports" "(std test check)") ("notes" . @@ -3443,7 +3443,7 @@ ";; Jerboa sort: LIST first, comparator second\n(sort '(3 1 2) <) ;; → (1 2 3)\n(sort '(\"c\" \"a\" \"b\") string<?) ;; → (\"a\" \"b\" \"c\")\n(sort items (lambda (a b) (> (car a) (car b)))) ;; descending by car\n\n;; WRONG (predicate first — causes \"not a procedure\" runtime error):\n;; (sort < '(3 1 2)) ← DO NOT USE") ("id" . "sort-list-argument-order") ("imports") ("notes" . - "CLAUDE.md incorrectly claims (sort predicate list) is 'Chez arg order'. The actual Jerboa/Chez sort is (sort list comparator) — list FIRST, comparator SECOND. Passing predicate first causes a cryptic 'Exception in list-sort: ... is not a procedure' error because sort tries to call the list as a procedure.") + "Jerboa prelude/(std sort) uses (sort list comparator) — list FIRST, comparator SECOND. Raw Chez sort is different. Passing predicate first in Jerboa-facing code causes a cryptic 'Exception in list-sort: ... is not a procedure' error because sort tries to call the list as a procedure.") ("tags" "sort" "list" "comparator" "argument-order" "prelude") ("title" @@ -4760,4 +4760,14 @@ "extra-archives" "c-shim") ("title" . - "Bundle SQLite for a jerbuild binary with a Rust static archive and C shim"))) + "Bundle SQLite for a jerbuild binary with a Rust static archive and C shim")) + (("code" + . + "(import (jerboa prelude))\n\n(def (read-one-form path)\n (call-with-input-file path\n (lambda (in)\n (let* ([form (get-datum in)]\n [extra (get-datum in)])\n (unless (eof-object? extra)\n (error 'read-one-form \"expected exactly one top-level form\"))\n form))))\n\n(def manifest (read-one-form \".jerboa-system\"))\n(unless (and (pair? manifest) (eq? (car manifest) 'system))\n (error 'manifest \"expected (system ...)\"))\n(displayln \"manifest ok\")") ("id" . "validate-sexpression-manifest-file") + ("imports" "(jerboa prelude)") + ("notes" + . + "Use `(jerboa prelude)` and `get-datum` for manifest/data files. Avoid bare `read` in validators so security tooling can distinguish data parsing from eval-like REPL reads. Use `let*` when reading multiple datums from the same port so the reads occur in order.") + ("tags" "manifest" "get-datum" "file-io" "validation" + "prelude") + ("title" . "Validate a single S-expression manifest file"))) --- a/data/divergence.sexp +++ b/data/divergence.sexp @@ -98,13 +98,13 @@ "(lambda (a b) (string<? (symbol->string a) (symbol->string b)))") ("correct_example" . - "(sort (lambda (a b) (string<? (symbol->string a) (symbol->string b))) '(b a c))") + "(sort '(b a c) (lambda (a b) (string<? (symbol->string a) (symbol->string b))))") ("id" . "gerbil-symbol-lt") ("imports") ("notes" . "No symbol<? in Jerboa/Chez. Compare via symbol->string + string<?.") ("severity" . "error") ("wrong" . "symbol<?") - ("wrong_example" . "(sort symbol<? '(b a c))") + ("wrong_example" . "(sort '(b a c) symbol<?)") ("wrong_source" "gerbil" "srfi-1")) (("available_via" "(std misc string-more)") ("category" . "strings") ("correct" . "string-contains") ("correct_example" @@ -346,15 +346,15 @@ . "(hash-table-ref ht \"k\" (lambda () 0))") ("wrong_source" "srfi-69")) - (("available_via" . #<void>) ("category" . "arg-order") ("correct" . "(sort pred lst)") - ("correct_example" . "(sort < '(3 1 2))") + (("available_via" . "(std sort), (jerboa prelude)") ("category" . "arg-order") ("correct" . "(sort lst pred)") + ("correct_example" . "(sort '(3 1 2) <)") ("id" . "arg-order-sort") ("imports") ("notes" . - "Chez arg order: predicate first, list second. This is the opposite of Gerbil/SRFI/Racket.") - ("severity" . "error") ("wrong" . "(sort lst pred)") - ("wrong_example" . "(sort '(3 1 2) <)") - ("wrong_source" "gerbil" "srfi-95" "common-lisp")) + "Jerboa (std sort) and the prelude use list first, predicate second. Raw Chez sort is predicate first.") + ("severity" . "error") ("wrong" . "(sort pred lst)") + ("wrong_example" . "(sort < '(3 1 2))") + ("wrong_source" "chez" "r6rs")) (("available_via" . #<void>) ("category" . "arg-order") ("correct" . "(hash-ref ht key)") ("correct_example" --- a/data/error-fixes.sexp +++ b/data/error-fixes.sexp @@ -1339,7 +1339,7 @@ ";; WRONG: curly braces inside a quoted list\n(cluster-transact! leader '({person/name \"Alice\" person/age 30}))")) (("code_example" . - "(sort (lambda (a b) (string<? (symbol->string a) (symbol->string b))) '(b a c))") + "(sort '(b a c) (lambda (a b) (string<? (symbol->string a) (symbol->string b))))") ("explanation" . "No symbol<? in Jerboa/Chez. Compare via symbol->string + string<?.") @@ -1355,7 +1355,7 @@ "(variable\\s+symbol<\\?\\s+is\\s+not\\s+bound|unbound\\s+identifier\\s+symbol<\\?)") ("related_divergence" . "gerbil-symbol-lt") ("type" . "Hallucinated Identifier") - ("wrong_example" . "(sort symbol<? '(b a c))")) + ("wrong_example" . "(sort '(b a c) symbol<?)")) (("code_example" . "(if (string-contains s \"foo\") ...) ;; returns index or #f — truthy if found") --- a/data/features.sexp +++ b/data/features.sexp @@ -1056,4 +1056,20 @@ ("use_case" . "Debugging failed MCP tool calls, especially cookbook/feature/security writer calls from direct JSON-RPC or the Claude MCP shim.") + ("votes" . 0)) + (("description" + . + "jerboa_verify and jerboa_compile_check can throw an internal string-ref index exception while scanning a valid .ss script, leaving no actionable Scheme diagnostic. The tools should catch scanner exceptions, report the phase and file/offset, and continue to syntax/expand checks when possible.") ("estimated_token_reduction" . "500") + ("example_scenario" . "") + ("id" . "verify-file-internal-error-reporting") + ("impact" + . + "Avoids falling back to bash/local scheme when the verifier scanner fails internally.") + ("tags" "verify" "compile-check" "diagnostics" "tooling") + ("title" + . + "Report verifier internal exceptions as tool bugs with file context") + ("use_case" + . + "Validating tools/check-system-manifest.ss hit `Exception in string-ref: 12290 is not a valid index` even though the script runs and security_scan passes.") ("votes" . 0))) --- a/docs/anti-cookbook.md +++ b/docs/anti-cookbook.md @@ -23,20 +23,19 @@ the odd one out. --- -## 2. `(sort lst <)` — arg order reversed +## 2. `(sort < lst)` — arg order reversed -**Wrong** (SRFI-95 / Clojure / Gerbil order): +**Wrong** (raw Chez order): ```scheme -(sort '(3 1 2) <) +(sort < '(3 1 2)) ``` -**Correct** (Chez order: comparator first): +**Correct** (Jerboa `(std sort)` / prelude order: list first): ```scheme -(sort < '(3 1 2)) +(sort '(3 1 2) <) ``` -**Why:** `(std sort)` matches Chez, not SRFI-95. LLMs trained on Gerbil -reliably get this wrong — and the wrong form compiles silently then -crashes at runtime with a type error because `<` is being applied as -`(< '(3 1 2) <)`. +**Why:** Jerboa wraps raw Chez sorting with a list-first API. The wrong form +compiles silently then crashes at runtime because the list is passed where a +procedure is expected. --- --- a/docs/divergence.md +++ b/docs/divergence.md @@ -51,21 +51,21 @@ _119 entries._ ## arg-order -### `(sort lst pred)` → `(sort pred lst)` +### `(sort pred lst)` → `(sort lst pred)` -****ERROR**** · from Gerbil, SRFI-95, Common Lisp · id: `arg-order-sort` +****ERROR**** · from raw Chez / R6RS · id: `arg-order-sort` **Wrong:** ```scheme -(sort '(3 1 2) <) +(sort < '(3 1 2)) ``` **Correct:** ```scheme -(sort < '(3 1 2)) +(sort '(3 1 2) <) ``` -_Chez arg order: predicate first, list second. This is the opposite of Gerbil/SRFI/Racket._ +_Jerboa `(std sort)` and the prelude use list first, comparator second. Raw Chez `sort` is predicate first._ ### `(hash-ref key ht)` → `(hash-ref ht key)` @@ -1920,12 +1920,12 @@ _Without fill arg, initial contents are unspecified in standard Scheme. Always p **Wrong:** ```scheme -(sort symbol<? '(b a c)) +(sort '(b a c) symbol<?) ``` **Correct:** ```scheme -(sort (lambda (a b) (string<? (symbol->string a) (symbol->string b))) '(b a c)) +(sort '(b a c) (lambda (a b) (string<? (symbol->string a) (symbol->string b)))) ``` _No symbol<? in Jerboa/Chez. Compare via symbol->string + string<?._ --- a/docs/import-conflicts.md +++ b/docs/import-conflicts.md @@ -38,7 +38,7 @@ overrides: | `mutex?` | Chez predicate | Gerbil predicate | `(except (chezscheme) mutex?)` | | `mutex-name` | Chez accessor | Gerbil accessor | `(except (chezscheme) mutex-name)` | | `box` / `box?` / `unbox` / `set-box!` | Chez 10 built-in | Re-exported cleanly | `(except (chezscheme) box box? unbox set-box!)` | -| `sort` | `(sort pred lst)` | `(sort lst pred)` — arg order swapped | `(except (chezscheme) sort)` | +| `sort` | `(sort pred lst)` | `(sort lst pred)` — Jerboa wrapper swaps raw Chez order | `(except (chezscheme) sort)` | | `format` | `(format fmt args...)` — no port | Gerbil: `(format fmt args...)` | Usually compatible | ### (chezscheme) vs (std sugar) --- a/docs/module-quickstarts.md +++ b/docs/module-quickstarts.md @@ -290,20 +290,20 @@ Exports: `open-process`, `open-input-process`, `open-output-process`, ## Data -### `(std sort)` — sort (Chez arg order: predicate first) +### `(std sort)` — sort (Jerboa arg order: list first) ```scheme (import (jerboa prelude) (std sort)) -(sort < '(3 1 4 1 5 9 2 6)) ; → (1 1 2 3 4 5 6 9) -(stable-sort string<? '("b" "a" "c")) ; → ("a" "b" "c") +(sort '(3 1 4 1 5 9 2 6) <) ; → (1 1 2 3 4 5 6 9) +(stable-sort '("b" "a" "c") string<?) ; → ("a" "b" "c") ;; In-place versions mutate the input list: -(sort! > (list 3 1 2)) ; → (3 2 1) +(sort! (list 3 1 2) >) ; → (3 2 1) ``` -**Do not** write `(sort '(3 1 2) <)` — that's SRFI-95 / Gerbil order, -wrong in Jerboa. +**Do not** write `(sort < '(3 1 2))` — that's raw Chez order, wrong in +Jerboa-facing code. --- --- a/docs/unification.md +++ b/docs/unification.md @@ -46,8 +46,10 @@ Jerboa becomes a full stack by making every layer obey the same contract: internal build artifact. 2. **One authority boundary.** Filesystem, network, process, environment, secrets, eval, devices, and signing are all capabilities. -3. **One build boundary.** `jerbuild` is the normal compiler, packager, - artifact generator, and source-of-truth checker. +3. **One command and build boundary.** `jerboa` is the normal command surface. + The installed `jerbuild`, `jmcp`, and `jlsp` commands are links to the same + multicall binary, so build, agent, and editor tooling share one runtime, + bundle, provenance record, and release path. 4. **One provenance boundary.** Packages and build outputs are content-addressed, locked, reproducible, and signed. 5. **One native boundary.** Rust is the preferred native core; C is an audited @@ -79,6 +81,21 @@ Unification does not mean merging every repository into one tree. It means every repository follows the same contract and can be composed without reintroducing ambient authority, text glue, or untracked provenance. +The command surface is part of that contract. First-party tools should install +as: + +```text +jerboa # canonical command, REPL/script runner and explicit mode selector +jerbuild # link to jerboa, build/package/provenance mode +jmcp # link to jerboa, MCP/code-agent tooling mode +jlsp # link to jerboa, LSP/editor tooling mode +``` + +`jerboa <mode> ...` is valid for environments where links are inconvenient; +the links are valid for existing tooling that expects dedicated commands. +There should not be separate first-party binaries with independent bundled +stdlibs, stale data snapshots, or different signing paths. + --- ## Security Invariants @@ -139,6 +156,26 @@ Every artifact that crosses a trust boundary should have: YubiKey-backed signing should become the normal root for high-trust releases. +The minimum provenance record should be small and boring enough to attach to +every build: + +```scheme +(provenance + (artifact "dist/jerboa") + (content-sha256 "...") + (source-revision "git:<commit>") + (lock-sha256 "...") + (build-recipe-sha256 "...") + (builder "jerbuild:<version-or-hash>") + (mode multicall) + (links ("jerbuild" "jmcp" "jlsp")) + (tcb ("chez" "jerboa-stdlib" "jerboa-native-rs")) + (signature "...")) +``` + +Tools can extend this, but package resolution and deployment should be able to +reject artifacts when these fields are missing or inconsistent. + ### 4. FFI is the unsafe block Pure Jerboa code is memory safe. The FFI boundary is where memory unsafety, @@ -258,6 +295,25 @@ Example shape: The manifest should be readable by humans, tooling, CI, package resolution, security scans, editors, and code agents. +The first implementation should treat this as a versioned schema, not just a +documentation example. A manifest MVP must support: + +- identity: `name`, `version`, `kind`, and `language` +- source: maintained `.ss` entries, generated directories, tests, and docs +- command surface: canonical command plus linked modes +- build: targets, outputs, reproducibility flag, install-time-code policy +- capabilities: declared filesystem, network, process, environment, secret, + eval, native, and package authority +- provenance: lock file, content addressing, signing policy, SBOM flag, TCB + summary +- native boundary: Rust crates, C shims, shared objects, FFI wrappers, and + fuzz status +- audit: event schema version and required security-relevant events + +Validation should start permissive but explicit: unknown fields are warnings, +missing required top-level sections are errors, and unsupported enforcement +must be reported as degraded rather than silently ignored. + --- ## Full Stack Reference Architecture @@ -471,6 +527,16 @@ Patterns: - Record authority grants in audit logs. - Treat capability leakage as a bug even when the leaked cap is valid. +Implementation should move through clear enforcement stages: + +| Stage | Behavior | Failure mode | +|-------|----------|--------------| +| Declare | Manifest records requested authority | Missing declaration is an error | +| Diff | Tooling shows authority changes in review | Widening authority requires approval | +| Audit | Runtime logs grants and denials | Denials are visible but may not stop tests | +| Test enforce | Tests run under declared caps | Undeclared authority fails tests | +| Hard enforce | OS/runtime sandbox enforces caps where supported | Unsupported axes degrade explicitly or fail by policy | + Example handler shape: ```scheme @@ -649,6 +715,24 @@ Responsibilities: - crash reports without secret leakage - deterministic error references for user-visible failures +The common audit event should be a structured record with stable keys: + +```scheme +(audit-event + (schema "jerboa.audit/1") + (timestamp "2026-05-28T00:00:00Z") + (actor "service:secure-notes") + (action 'capability/check) + (resource "filesystem:/srv/secure-notes/data") + (decision 'allow) + (capability-id "cap:...") + (correlation-id "req:...") + (detail '((permission . write)))) +``` + +Every subsystem can add details, but these keys are enough for cross-tool +queries, incident timelines, and policy regression tests. + ### 7. Release Responsibilities: @@ -804,8 +888,9 @@ that makes every application inherit the same guarantees. 1. **Workspace health tool.** Summarize all `jerboa*` and `chez*` repos: branch, dirty source, generated artifacts, build target, test target, manifest, native code, security findings. -2. **System manifest MVP.** Extend package metadata with capabilities, build - outputs, generated artifact policy, and native boundary declarations. +2. **System manifest MVP.** Extend package metadata with capabilities, command + links, build outputs, generated artifact policy, provenance, audit event + schema, and native boundary declarations. 3. **Capability test runner.** Run tests with the declared caps and report undeclared authority use. 4. **Generated FFI wrapper format.** Describe native functions with ownership @@ -819,6 +904,31 @@ that makes every application inherit the same guarantees. 8. **TCB report generator.** Produce a per-artifact list of Chez, Jerboa, Rust, C, wasm, kernel, and host assumptions. +### Current enforcement tools + +The first implementation slice lives in this repository and is driven by the +system manifest: + +| Target | Tool | Enforces | +|--------|------|----------| +| `make system-check` | `tools/check-system-manifest.ss` | Manifest schema, required sections, command links, capability domains, source paths, build/provenance/native/audit shape | +| `make system-strict` | `tools/check-system-manifest.ss --strict` | Same as `system-check`, plus declared build outputs must exist | +| `make generated-policy-check` | `tools/check-generated-policy.ss` | Every `source.generated` entry is covered by `.gitignore` | +| `make system-report` | `tools/system-report.ss` | Human-readable workspace health, command links, native boundary, capability domains, artifact hashes | +| `make system-provenance` | `tools/system-provenance.ss` | Machine-readable `jerboa.provenance/1` artifact record | +| `make system-diff` | `tools/system-diff.ss` | Review-visible changes to command links, build outputs, native boundary, capabilities, and audit actions | +| `make audit-event-check` | `tools/check-audit-events.ss` | `jerboa.audit/1` event schema and required action coverage | +| `make capability-use-check` | `tools/check-capability-use.ss` | Static scan of source entry points for capability-sensitive forms missing manifest authority | +| `make native-boundary-check` | `tools/check-native-boundary.ss` | Native Rust/C sources and FFI sites are visible and declared | +| `make install-policy-check` | `tools/check-install-policy.ss` | Install-time package code remains denied | +| `make tcb-report` | `tools/tcb-report.ss` | Machine-readable TCB inventory for dependencies, native code, C shims, and FFI sites | +| `make unification-check` | Makefile aggregate | Development unification gate | +| `make unification-release-check` | Makefile aggregate | Release gate requiring declared artifacts | + +These tools intentionally avoid shelling out for normal validation. Git dirty +state is reported as not computed until a capability-scoped process runner is +available for trusted local tooling. + --- ## Anti-Patterns @@ -897,6 +1007,7 @@ verified provenance, and explicit native boundaries. The way forward is not one large rewrite. It is a sequence of unifying contracts: - source layout +- unified command and linked tool modes - build targets - manifests - capabilities --- a/docs/whats-new.md +++ b/docs/whats-new.md @@ -933,7 +933,7 @@ Programmatic access to Chez's timing and allocation statistics (Chez has `(time ;; prints: fibonacci: 45ms (44ms cpu, 1024 bytes allocated) ;; Just measure wall time -(let-values ([(result ms) (with-timing (lambda () (sort < big-list)))]) +(let-values ([(result ms) (with-timing (lambda () (sort big-list <)))]) (printf "sorted in ~ams~n" ms)) ;; Count allocation new file mode 100644 --- /dev/null +++ b/examples/audit-events.sexp @@ -0,0 +1,76 @@ +(audit-event + (schema "jerboa.audit/1") + (timestamp "2026-05-28T00:00:00Z") + (actor "system:jerboa") + (action capability/check) + (resource "capability:filesystem") + (decision allow) + (capability-id "cap:example") + (correlation-id "example:capability-check") + (detail ((permission . read)))) + +(audit-event + (schema "jerboa.audit/1") + (timestamp "2026-05-28T00:00:00Z") + (actor "system:jerboa") + (action package/resolve) + (resource "package:jerboa") + (decision info) + (capability-id #f) + (correlation-id "example:package-resolve") + (detail ((resolver . local)))) + +(audit-event + (schema "jerboa.audit/1") + (timestamp "2026-05-28T00:00:00Z") + (actor "system:jerboa") + (action build/start) + (resource "target:jerboa") + (decision info) + (capability-id #f) + (correlation-id "example:build") + (detail ((target . jerboa)))) + +(audit-event + (schema "jerboa.audit/1") + (timestamp "2026-05-28T00:00:00Z") + (actor "system:jerboa") + (action build/finish) + (resource "target:jerboa") + (decision info) + (capability-id #f) + (correlation-id "example:build") + (detail ((status . ok)))) + +(audit-event + (schema "jerboa.audit/1") + (timestamp "2026-05-28T00:00:00Z") + (actor "system:jerboa") + (action provenance/sign) + (resource "artifact:dist/jerboa") + (decision deny) + (capability-id #f) + (correlation-id "example:provenance") + (detail ((reason . signing-planned)))) + +(audit-event + (schema "jerboa.audit/1") + (timestamp "2026-05-28T00:00:00Z") + (actor "system:jerboa") + (action native/load) + (resource "native:jerboa-native-rs") + (decision info) + (capability-id #f) + (correlation-id "example:native") + (detail ((boundary . rust)))) + +(audit-event + (schema "jerboa.audit/1") + (timestamp "2026-05-28T00:00:00Z") + (actor "system:jerboa") + (action eval/run) + (resource "eval:tooling") + (decision deny) + (capability-id #f) + (correlation-id "example:eval") + (detail ((reason . denied-by-default)))) new file mode 100644 --- /dev/null +++ b/tools/capability-plan.ss @@ -0,0 +1,115 @@ +#!/usr/bin/env -S scheme --libdirs lib --script +;;; capability-plan.ss -- emit manifest capability plan for runners/sandboxes. + +(import (jerboa prelude)) + +(define default-manifest ".jerboa-system") + +(define (usage) + (display "Usage: capability-plan.ss [MANIFEST]\n") + (display "Emit a jerboa.capability-plan/1 S-expression.\n")) + +(define (parse-args args) + (cond + [(null? args) default-manifest] + [(or (string=? (car args) "-h") (string=? (car args) "--help")) + (usage) + (exit 0)] + [else (car args)])) + +(define (read-one-form path) + (call-with-input-file path + (lambda (in) + (let* ([form (get-datum in)] + [extra (get-datum in)]) + (unless (eof-object? extra) + (error 'read-one-form "expected exactly one top-level form" path)) + form)))) + +(define (valid-section? form) + (and (pair? form) (symbol? (car form)))) + +(define (section-ref body key) + (let loop ([rest body]) + (cond + [(null? rest) #f] + [(and (valid-section? (car rest)) (eq? (car (car rest)) key)) + (car rest)] + [else (loop (cdr rest))]))) + +(define (section-value body key) + (let ([s (section-ref body key)]) + (and s (pair? (cdr s)) (cadr s)))) + +(define (section-values body key default) + (let ([s (section-ref body key)]) + (if s (cdr s) default))) + +(define (normalize-values xs) + (cond + [(and (pair? xs) (null? (cdr xs)) (list? (car xs))) (car xs)] + [(and (pair? xs) (null? (cdr xs)) (eq? (car xs) 'none)) 'none] + [else xs])) + +(define (manifest-body path) + (let ([form (read-one-form path)]) + (unless (and (pair? form) (eq? (car form) 'system)) + (error 'capability-plan "expected (system ...) manifest" path)) + (cdr form))) + +(define (cap-section caps key) + (let ([s (section-ref caps key)]) + (if s (cdr s) '()))) + +(define (cap-value caps domain key default) + (let ([domain-section (section-ref caps domain)]) + (or (and domain-section (section-value (cdr domain-section) key)) + default))) + +(define (cap-values caps domain key default) + (let ([domain-section (section-ref caps domain)]) + (if domain-section + (normalize-values (section-values (cdr domain-section) key default)) + default))) + +(define (unsupported-axes caps) + (let ([out '()]) + (when (section-ref caps 'secrets) + (set! out (cons 'secrets-runtime-enforcement out))) + (when (section-ref caps 'package) + (set! out (cons 'package-runtime-enforcement out))) + (when (section-ref caps 'native) + (set! out (cons 'native-load-runtime-enforcement out))) + (reverse out))) + +(define (emit-plan path) + (let* ([body (manifest-body path)] + [caps-section (section-ref body 'capabilities)] + [caps (if caps-section (cdr caps-section) '())]) + (write + `(capability-plan + (schema "jerboa.capability-plan/1") + (manifest ,path) + (system + (name ,(section-value body 'name)) + (version ,(section-value body 'version))) + (filesystem + (read ,(cap-values caps 'filesystem 'read '())) + (write ,(cap-values caps 'filesystem 'write '())) + (execute ,(cap-values caps 'filesystem 'execute '()))) + (network + (connect ,(cap-values caps 'network 'connect '(none))) + (listen ,(cap-values caps 'network 'listen '(none)))) + (process + (spawn ,(cap-values caps 'process 'spawn '(none)))) + (environment + (read ,(cap-values caps 'environment 'read '())) + (deny ,(cap-values caps 'environment 'deny '("*")))) + (secrets ,(cap-section caps 'secrets)) + (eval ,(cap-section caps 'eval)) + (native ,(cap-section caps 'native)) + (package ,(cap-section caps 'package)) + (unsupported-runtime-axes ,(unsupported-axes caps)))) + (newline))) + +(emit-plan (parse-args (command-line-arguments))) new file mode 100644 --- /dev/null +++ b/tools/check-audit-events.ss @@ -0,0 +1,159 @@ +#!/usr/bin/env -S scheme --libdirs lib --script +;;; check-audit-events.ss -- validate jerboa.audit/1 event streams. + +(import (jerboa prelude)) + +(define required-event-keys + '(schema timestamp actor action resource decision capability-id correlation-id detail)) + +(define allowed-decisions '(allow deny info error)) + +(define (usage) + (display "Usage: check-audit-events.ss MANIFEST EVENTS\n") + (display "Validate audit events and required action coverage.\n")) + +(define (parse-args args) + (unless (= (length args) 2) + (usage) + (exit 2)) + args) + +(define (read-one-form path) + (call-with-input-file path + (lambda (in) + (let* ([form (get-datum in)] + [extra (get-datum in)]) + (unless (eof-object? extra) + (error 'read-one-form "expected exactly one top-level form" path)) + form)))) + +(define (read-all-forms path) + (call-with-input-file path + (lambda (in) + (let loop ([out '()]) + (let ([form (get-datum in)]) + (if (eof-object? form) + (reverse out) + (loop (cons form out)))))))) + +(define (valid-section? form) + (and (pair? form) (symbol? (car form)))) + +(define (section-ref body key) + (let loop ([rest body]) + (cond + [(null? rest) #f] + [(and (valid-section? (car rest)) (eq? (car (car rest)) key)) + (car rest)] + [else (loop (cdr rest))]))) + +(define (section-value body key) + (let ([s (section-ref body key)]) + (and s (pair? (cdr s)) (cadr s)))) + +(define (manifest-required-events path) + (let ([form (read-one-form path)]) + (unless (and (pair? form) (eq? (car form) 'system)) + (error 'check-audit-events "expected (system ...) manifest" path)) + (let* ([audit (section-ref (cdr form) 'audit)] + [events (and audit (section-value (cdr audit) 'required-events))]) + (or events '())))) + +(define errors '()) +(define warnings '()) + +(define (add-error msg) + (set! errors (cons msg errors))) + +(define (add-warning msg) + (set! warnings (cons msg warnings))) + +(define (event-body ev) + (and (pair? ev) (eq? (car ev) 'audit-event) (cdr ev))) + +(define (event-value body key) + (section-value body key)) + +(define (symbol-member? x xs) + (cond + [(null? xs) #f] + [(eq? x (car xs)) #t] + [else (symbol-member? x (cdr xs))])) + +(define (validate-event ev index) + (let ([body (event-body ev)]) + (cond + [(not body) + (add-error (format "event ~a must be (audit-event ...)" index)) + #f] + [else + (for-each + (lambda (key)