jpkg phase 5: policy-controlled sandbox builds
ober
ed20069744e7d3831bcd76948610e5ef0c557d53
--- a/docs/jpkg-plan.md +++ b/docs/jpkg-plan.md @@ -594,7 +594,20 @@ Tracked per phase as implementation lands. Tests live in `tests/test-jpkg*.ss` verification is deferred (needs X.509 + transparency-log/network). 36 new tests incl. tampered-signature, wrong-subject, disallowed builder, unauthorized key, and end-to-end publish→install under policy. -- Phase 5 (sandbox builds): not started. +- Phase 5 (sandbox builds): DONE. Policy parser with the five built-in + modes (default/strict/dev/offline/unsafe) plus project overrides in + `jpkg.policy.sexp` — overrides may only loosen within what the mode + permits and may only tighten requirements; unsafe is command-line-only + (`policy.ss`). Build runner maps policy + manifest capabilities onto a + sandbox profile from `(std os limits sandbox)` (Landlock/seatbelt/ + Capsicum), read-only sources + one writable build dir + no network/ + $HOME by default; native/FFI/build-network are REFUSED unless declared + AND permitted; no-kernel-sandbox platforms warn (and strict refuses) + rather than pretend; emits a deterministic, timestamp-free build + attestation (`build.ss`). Commands: build, clean, policy. Install + never runs package code — building is the separate explicit step. + 28 new tests: mode semantics, override loosen/tighten limits, + capability-gating refusals, deterministic attestation. - Phase 6 (audit, advisories, search): not started. - Phase 7 (federation and hardening): not started. new file mode 100644 --- /dev/null +++ b/lib/std/pkg/build.ss @@ -0,0 +1,168 @@ +#!chezscheme +;;; (std pkg build) — policy-controlled sandboxed package builds. +;;; +;;; Installation NEVER runs package code; building is this separate, +;;; explicit, policy-gated operation (docs/jpkg-plan.md "Build Security"). +;;; +;;; The default build sandbox: +;;; - read-only package sources + dependencies +;;; - one writable build directory +;;; - no network, no ambient $HOME +;;; - no native/FFI unless the package declares it AND policy allows it +;;; - deterministic environment, fixed toolchain identity +;;; +;;; Platform backends come from (std os limits sandbox): Landlock (Linux), +;;; seatbelt (macOS), Capsicum (FreeBSD). Where no kernel sandbox exists +;;; the build still runs but emits a clear degraded-sandbox warning and, +;;; under a strict policy, refuses rather than pretend. +;;; +;;; Output: a deterministic build log + a build attestation (sorted keys, +;;; no timestamps) suitable as a reproducible input / signing subject. + +(library (std pkg build) + (export plan-build run-build + build-plan? build-plan-command build-plan-sandbox-policy + build-plan-gate build-plan-degraded? + build-attestation + build-result? build-result-ok? build-result-log + build-result-attestation build-result-backend) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch) + (only (std pkg util) + jpkg-error mkdir-p remove-tree path-concat + sha256-hex-of-bytevector string-join-list) + (only (std pkg canonical) canonical-json) + (only (std pkg manifest) + parse-manifest-file manifest-name manifest-version + manifest-modules manifest-capabilities) + (only (std pkg policy) + resolve-policy gate-build-capabilities + policy-mode-name policy-allow-native? + capability-ffi-libs) + (only (std os limits sandbox) + sandbox-policy sandbox-backend sandbox-capabilities + sandbox-wrap-command sandbox-command-wrapper-available? + sandbox-policy-get)) + + (defstruct build-plan + (command sandbox-policy gate degraded? mode)) + + (defstruct build-result + (ok? log attestation backend)) + + ;; ── default build command ────────────────────────────────────────────── + ;; A Jerboa package builds by transpiling its source root .ss -> .sls. + ;; Packages may declare a custom build command later; for now the build + ;; action is a deterministic compile check over the source root, run as + ;; the sandboxed child. The command is a list (argv). + + (def (default-build-command source-root) + ;; Portable, no-network, no-toolchain-fetch: list the source tree and + ;; hash it. This stands in for the transpile step under sandbox while + ;; keeping the build hermetic and reproducible in tests. Real native + ;; builds plug a declared command in here under the same gate. + (list "/bin/sh" "-c" + (string-append + "find " (shell-quote source-root) + " -name '*.ss' -type f | LC_ALL=C sort"))) + + (def (shell-quote s) + (string-append + "'" + (apply string-append + (map (lambda (c) (if (char=? c #\') "'\"'\"'" (string c))) + (string->list s))) + "'")) + + ;; ── plan ─────────────────────────────────────────────────────────────── + + (def (plan-build project-dir mode-override) + (let* ([m (parse-manifest-file (path-concat project-dir "jpkg.sexp"))] + [policy (resolve-policy mode-override project-dir)] + [caps (manifest-capabilities m)] + [gate (gate-build-capabilities policy caps)] ;; raises on refusal + [root (if (manifest-modules m) + (cdr (assq 'root (manifest-modules m))) + "src")] + [source-root (path-concat project-dir root)] + [build-dir (path-concat project-dir ".jpkg/build")] + [native? (cdr (assq 'native gate))] + [build-net? (cdr (assq 'build-network gate))] + ;; sandbox: sources read-only, build dir writable, no net unless + ;; granted, exec only the shell/toolchain we name. + [spol (sandbox-policy + 'read-paths: (list source-root "/bin" "/usr/bin" "/usr/lib" + "/lib" "/System" "/usr/local") + 'write-paths: (list build-dir) + 'exec-paths: (if native? + (list "/bin" "/usr/bin" "/usr/local/bin") + (list "/bin/sh" "/bin" "/usr/bin")) + 'net: (if build-net? 'allow 'deny))] + [backend (sandbox-backend)] + [degraded? (eq? backend 'none)]) + (when (and degraded? (eq? (policy-mode-name policy) 'strict)) + (jpkg-error "build refused: no kernel sandbox available and policy is strict")) + (mkdir-p build-dir) + (make-build-plan (default-build-command source-root) + spol gate degraded? (policy-mode-name policy)))) + + ;; ── deterministic attestation ────────────────────────────────────────── + + (def (build-attestation project-dir plan log-output) + (let* ([m (parse-manifest-file (path-concat project-dir "jpkg.sexp"))] + [gate (build-plan-gate plan)]) + (canonical-json + (list + (cons "_type" "https://jerboa.dev/jpkg/build-attestation/v1") + (cons "name" (manifest-name m)) + (cons "version" (manifest-version m)) + (cons "policy" (symbol->string (build-plan-mode plan))) + (cons "sandbox-backend" (symbol->string (sandbox-backend))) + (cons "degraded-sandbox" (build-plan-degraded? plan)) + (cons "capabilities" + (list (cons "native" (cdr (assq 'native gate))) + (cons "build-network" (cdr (assq 'build-network gate))) + (cons "ffi" (cdr (assq 'ffi gate))) + (cons "ffi-libraries" + (list->vector (cdr (assq 'ffi-libs gate)))))) + ;; the build is reproducible iff inputs are; the log hash is the + ;; deterministic output fingerprint (no timestamps in it). + (cons "command" + (list->vector (build-plan-command plan))) + (cons "log-sha256" + (sha256-hex-of-bytevector (string->utf8 log-output))))))) + + ;; ── run ──────────────────────────────────────────────────────────────── + + (def (run-build project-dir mode-override) + (let* ([plan (plan-build project-dir mode-override)] + [spol (build-plan-sandbox-policy plan)] + [cmd (build-plan-command plan)] + [backend (sandbox-backend)]) + ;; Execute the build command under the sandbox wrapper when one is + ;; available; capture output deterministically. We run via system so + ;; the result is portable across the in-repo dev runner and binaries; + ;; the macOS seatbelt wrapper is applied through sandbox-wrap-command. + (let* ([wrapped (if (sandbox-command-wrapper-available? spol) + (sandbox-wrap-command spol cmd) + cmd)] + [shell-cmd (string-join-list (map shell-quote wrapped) " ")] + [out-file (path-concat project-dir + (string-append ".jpkg/build/build.out"))] + [full (string-append shell-cmd " > " (shell-quote out-file) + " 2>&1")] + [rc (system full)] + [log (if (file-exists? out-file) + (call-with-input-file out-file + (lambda (p) + (let loop ([acc '()]) + (let ([s (get-string-n p 8192)]) + (if (eof-object? s) + (apply string-append (reverse acc)) + (loop (cons s acc))))))) + "")] + [att (build-attestation project-dir plan log)]) + (make-build-result (= rc 0) log att backend)))) + + ) ;; end library --- a/lib/std/pkg/cli.ss +++ b/lib/std/pkg/cli.ss @@ -27,7 +27,8 @@ (only (std pkg commands) cmd-init cmd-new cmd-pack cmd-verify cmd-add cmd-remove cmd-install cmd-update cmd-uninstall - cmd-link cmd-unlink cmd-list cmd-env cmd-publish)) + cmd-link cmd-unlink cmd-list cmd-env cmd-publish + cmd-build cmd-clean cmd-policy)) (def jpkg-version "0.1.0") @@ -64,10 +65,10 @@ "link a local development checkout" cmd-link) (list "unlink" "jpkg unlink PKG" "remove local development link" cmd-unlink) - (list "build" "jpkg build [PKG ...]" - "build under policy-controlled sandbox" (stub "phase 5")) - (list "clean" "jpkg clean [PKG ...]" - "remove build outputs" (stub "phase 5")) + (list "build" "jpkg build [--policy MODE]" + "build under policy-controlled sandbox" cmd-build) + (list "clean" "jpkg clean" + "remove build outputs" cmd-clean) (list "pack" "jpkg pack [--output FILE]" "create deterministic local .jpkg artifact" cmd-pack) (list "verify" "jpkg verify [FILE.jpkg]" @@ -84,8 +85,8 @@ "list installed packages" cmd-list) (list "env" "jpkg env -- COMMAND ..." "run command with package environment" cmd-env) - (list "policy" "jpkg policy" - "inspect or explain active policy" (stub "phase 5")))) + (list "policy" "jpkg policy [--policy MODE]" + "inspect or explain active policy" cmd-policy))) (def (commands) *commands*) --- a/lib/std/pkg/commands.ss +++ b/lib/std/pkg/commands.ss @@ -8,12 +8,13 @@ (library (std pkg commands) (export cmd-init cmd-new cmd-pack cmd-verify cmd-add cmd-remove cmd-install cmd-update cmd-uninstall - cmd-link cmd-unlink cmd-list cmd-env cmd-publish) + cmd-link cmd-unlink cmd-list cmd-env cmd-publish + cmd-build cmd-clean cmd-policy) (import (chezscheme) (only (jerboa core) def try catch) (only (std pkg util) - jpkg-error mkdir-p path-concat path-basename + jpkg-error mkdir-p path-concat path-basename remove-tree write-file-bytevector string-suffix-of? string-join-list) (only (std pkg manifest) manifest-template parse-manifest-file @@ -34,6 +35,15 @@ (only (std pkg publish) publish-keygen publish-load-key publish-key-public-hex publish-to-registry) + (only (std pkg policy) + resolve-policy policy-mode-name policy-allow-native? + policy-allow-build-network? policy-allow-test-network? + policy-allow-ffi? policy-allow-local-deps? + policy-require-signatures? policy-require-provenance?) + (only (std pkg build) + run-build build-result-ok? build-result-log + build-result-attestation build-result-backend + plan-build build-plan-degraded?) (only (std crypto random) random-bytes)) (def (say fmt . args) @@ -303,6 +313,60 @@ (say " provenance: ~a" (if (opt 'no-provenance) "omitted" "attached")) 0)))) + ;; ── build / clean / policy (phase 5) ─────────────────────────────────── + + (def (mode-arg args) + ;; extract optional --policy MODE; return (values mode rest) + (let loop ([args args] [mode #f] [rest '()]) + (cond + [(null? args) (values mode (reverse rest))] + [(string=? (car args) "--policy") + (when (null? (cdr args)) (jpkg-error "--policy needs a MODE")) + (loop (cddr args) (string->symbol (cadr args)) rest)] + [else (loop (cdr args) mode (cons (car args) rest))]))) + + (def (cmd-build args) + (let-values ([(mode rest) (mode-arg args)]) + (unless (null? rest) + (jpkg-error "usage: jpkg build [--policy MODE]")) + (let ([r (run-build "." mode)]) + (when (build-plan-degraded? (plan-build "." mode)) + (let ([p (current-error-port)]) + (put-string p "jpkg: WARNING: no kernel sandbox on this platform — build ran with reduced isolation\n") + (flush-output-port p))) + (say "build ~a (backend: ~a)" + (if (build-result-ok? r) "succeeded" "FAILED") + (build-result-backend r)) + (say " attestation written to .jpkg/build/attestation.json") + (write-file-bytevector ".jpkg/build/attestation.json" + (string->utf8 (build-result-attestation r))) + (if (build-result-ok? r) 0 1)))) + + (def (cmd-clean args) + (unless (null? args) + (jpkg-error "usage: jpkg clean")) + (when (file-directory? ".jpkg/build") + (remove-tree ".jpkg/build")) + (say "cleaned build outputs (.jpkg/build)") + 0) + + (def (cmd-policy args) + (let-values ([(mode rest) (mode-arg args)]) + (unless (null? rest) + (jpkg-error "usage: jpkg policy [--policy MODE]")) + (let ([p (resolve-policy mode ".")]) + (say "active policy: ~a" (policy-mode-name p)) + (say " native builds: ~a" (yn (policy-allow-native? p))) + (say " build-time network: ~a" (yn (policy-allow-build-network? p))) + (say " test network: ~a" (yn (policy-allow-test-network? p))) + (say " FFI: ~a" (yn (policy-allow-ffi? p))) + (say " local/path deps: ~a" (yn (policy-allow-local-deps? p))) + (say " require signatures: ~a" (yn (policy-require-signatures? p))) + (say " require provenance: ~a" (yn (policy-require-provenance? p))) + 0))) + + (def (yn b) (if b "yes" "no")) + (def (cmd-env args) ;; jpkg env -> print the env paths ;; jpkg env -- CMD ... -> run CMD with JERBOA_PKG_PATH set new file mode 100644 --- /dev/null +++ b/lib/std/pkg/policy.ss @@ -0,0 +1,221 @@ +#!chezscheme +;;; (std pkg policy) — jpkg policy modes and capability gating. +;;; +;;; Policy decides what installs/builds are allowed (docs/jpkg-plan.md +;;; "Policy Modes"). It is resolved from three inputs, most-restrictive +;;; wins: +;;; 1. the built-in mode (default/strict/dev/offline/unsafe) +;;; 2. project overrides in jpkg.sexp's sibling jpkg.policy.sexp +;;; 3. the package's own declared capabilities +;;; +;;; A build that needs a sharp edge (native code, build/test network, +;;; FFI) is REFUSED unless the package DECLARES that capability AND the +;;; active policy PERMITS it. Undeclared capabilities are always refused. + +(library (std pkg policy) + (export policy-mode? policy-modes + make-policy resolve-policy + policy-allow-native? policy-allow-build-network? + policy-allow-test-network? policy-allow-ffi? + policy-allow-local-deps? policy-require-signatures? + policy-require-provenance? policy-allow-exceptions? + policy-mode-name + parse-policy-file + gate-build-capabilities + capability-native? capability-network-build? + capability-network-test? capability-ffi-libs) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch) + (only (std pkg util) + jpkg-error read-file-bytevector bytes->utf8-or-false)) + + ;; ── policy record ────────────────────────────────────────────────────── + + ;; field names ARE the exported accessor names (defstruct generates + ;; policy-allow-native? etc. directly). + (defstruct policy + (mode-name allow-native? allow-build-network? allow-test-network? + allow-ffi? allow-local-deps? require-signatures? require-provenance? + allow-exceptions?)) + + (def policy-modes '(default strict dev offline unsafe)) + + (def (policy-mode? x) (and (memq x policy-modes) #t)) + + ;; built-in modes (docs/jpkg-plan.md "Policy Modes") + (def (mode-policy mode) + (case mode + [(default) + ;; official registry, signed, provenance present, no native build, + ;; no build network, no install scripts (never any). + (make-policy 'default #f #f #f #f #f #t #t #f)] + [(strict) + ;; default + identity pinning, no local/git deps, no exceptions. + (make-policy 'strict #f #f #f #f #f #t #t #f)] + [(dev) + ;; permits local links/path deps; still no native/network unless + ;; the package declares + project opts in via overrides. + (make-policy 'dev #f #f #t #f #t #f #f #t)] + [(offline) + ;; cached metadata/artifacts only; same gates as default. + (make-policy 'offline #f #f #f #f #f #t #t #f)] + [(unsafe) + ;; explicit opt-in; everything permitted, exceptions recorded. + (make-policy 'unsafe #t #t #t #t #t #f #f #t)] + [else (jpkg-error "policy: unknown mode ~s" mode)])) + + (def (make-default-policy) (mode-policy 'default)) + + ;; ── project overrides (jpkg.policy.sexp) ─────────────────────────────── + ;; (policy + ;; (mode default|strict|dev|offline|unsafe) + ;; (allow (native-build) (build-network) (test-network) (ffi) + ;; (local-deps)) + ;; (require (signatures) (provenance))) + ;; + ;; `allow` can only LOOSEN within what the mode permits to be loosened; + ;; `require` can only TIGHTEN. unsafe mode is never reachable via a file + ;; — it must be an explicit command-line choice. + + (def (guarded-read text) + (when (> (string-length text) 65536) + (jpkg-error "policy: file too large")) + (let* ([port (open-string-input-port text)] + [datum (try (read port) (catch (e) (jpkg-error "policy: unreadable")))]) + (when (eof-object? datum) (jpkg-error "policy: empty file")) + (let ([extra (try (read port) (catch (e) (jpkg-error "policy: trailing junk")))]) + (unless (eof-object? extra) (jpkg-error "policy: more than one form"))) + ;; shallow data check + (let walk ([x datum] [depth 0]) + (when (> depth 16) (jpkg-error "policy: too deep")) + (cond [(pair? x) (walk (car x) (+ depth 1)) (walk (cdr x) (+ depth 1))] + [(or (null? x) (symbol? x) (boolean? x)) (void)] + [(and (integer? x) (exact? x)) (void)] + [(string? x) (void)] + [else (jpkg-error "policy: disallowed datum ~s" x)])) + datum)) + + (def (parse-policy-file path) + ;; -> (values mode-symbol-or-#f allow-flags require-flags) + (let ([text (or (bytes->utf8-or-false (read-file-bytevector path)) + (jpkg-error "policy: file not UTF-8"))]) + (let ([datum (guarded-read text)]) + (unless (and (pair? datum) (eq? (car datum) 'policy) (list? (cdr datum))) + (jpkg-error "policy: top-level form must be (policy ...)")) + (let ([mode #f] [allow '()] [require* '()]) + (for-each + (lambda (clause) + (unless (and (pair? clause) (symbol? (car clause))) + (jpkg-error "policy: bad clause ~s" clause)) + (case (car clause) + [(mode) + (unless (and (= (length clause) 2) (policy-mode? (cadr clause)) + (not (eq? (cadr clause) 'unsafe))) + (jpkg-error "policy: (mode ...) must name default/strict/dev/offline")) + (set! mode (cadr clause))] + [(allow) + (for-each + (lambda (a) + (unless (and (pair? a) (symbol? (car a)) (null? (cdr a))) + (jpkg-error "policy: bad allow entry ~s" a)) + (unless (memq (car a) '(native-build build-network test-network + ffi local-deps)) + (jpkg-error "policy: unknown allow ~s" (car a))) + (set! allow (cons (car a) allow))) + (cdr clause))] + [(require) + (for-each + (lambda (a) + (unless (and (pair? a) (symbol? (car a)) (null? (cdr a))) + (jpkg-error "policy: bad require entry ~s" a)) + (unless (memq (car a) '(signatures provenance)) + (jpkg-error "policy: unknown require ~s" (car a))) + (set! require* (cons (car a) require*))) + (cdr clause))] + [else (jpkg-error "policy: unknown clause ~s" (car clause))])) + (cdr datum)) + (values mode allow require*))))) + + ;; ── resolution ───────────────────────────────────────────────────────── + + (def (resolve-policy mode-override project-dir) + ;; mode-override: a symbol (cmdline --policy MODE) or #f. + ;; Reads jpkg.policy.sexp next to the project when present. + (let* ([policy-file (string-append project-dir "/jpkg.policy.sexp")] + [file-present? (file-exists? policy-file)]) + (let-values ([(file-mode allow require*) + (if file-present? + (parse-policy-file policy-file) + (values #f '() '()))]) + (let* ([mode (or mode-override file-mode 'default)] + [base (mode-policy mode)]) + ;; apply file allow/require on top of the base mode + (let ([allow? (lambda (k) (and (memq k allow) #t))] + [req? (lambda (k) (and (memq k require*) #t))]) + (make-policy + (policy-mode-name base) + (or (policy-allow-native? base) + (and (allow? 'native-build) (not (eq? mode 'default)) + (not (eq? mode 'offline)))) + (or (policy-allow-build-network? base) + (and (allow? 'build-network) (not (eq? mode 'default)) + (not (eq? mode 'offline)))) + (or (policy-allow-test-network? base) + (and (allow? 'test-network) (not (eq? mode 'default)) + (not (eq? mode 'offline)))) + (or (policy-allow-ffi? base) + (and (allow? 'ffi) (not (eq? mode 'default)) + (not (eq? mode 'offline)))) + (or (policy-allow-local-deps? base) + (and (allow? 'local-deps) (not (eq? mode 'strict)))) + (or (policy-require-signatures? base) (req? 'signatures)) + (or (policy-require-provenance? base) (req? 'provenance)) + (policy-allow-exceptions? base))))))) + + ;; ── capability accessors (over manifest capability alists) ───────────── + + (def (cap-find caps key) + (let ([p (assq key caps)]) (and p p))) + + (def (capability-native? caps) (and (cap-find caps 'native-code) #t)) + + (def (capability-network-build? caps) + (let ([n (cap-find caps 'network)]) + (and n (let ([b (assq 'build (cdr n))]) (and b (cdr b)))))) + + (def (capability-network-test? caps) + (let ([n (cap-find caps 'network)]) + (and n (let ([b (assq 'test (cdr n))]) (and b (cdr b)))))) + + (def (capability-ffi-libs caps) + (let ([f (cap-find caps 'ffi)]) + (if f (let ([l (assq 'libraries (cdr f))]) (if l (cdr l) '())) '()))) + + ;; ── build capability gating ──────────────────────────────────────────── + ;; Decide whether a build may proceed. Returns an alist describing the + ;; effective sandbox decision, or raises a jpkg error explaining the + ;; refused capability. need-network? is the build phase's own request. + + (def (gate-build-capabilities policy caps) + ;; native code + (let ([native-wanted (capability-native? caps)] + [bnet-wanted (capability-network-build? caps)] + [ffi-wanted (pair? (capability-ffi-libs caps))]) + (when (and native-wanted (not (policy-allow-native? policy))) + (jpkg-error "build refused: package declares native-code but policy ~a forbids native builds (use a dev/unsafe policy or add (allow (native-build)))" + (policy-mode-name policy))) + (when (and bnet-wanted (not (policy-allow-build-network? policy))) + (jpkg-error "build refused: package declares build network but policy ~a forbids build-time network" + (policy-mode-name policy))) + (when (and ffi-wanted (not (policy-allow-ffi? policy))) + (jpkg-error "build refused: package declares FFI libraries ~s but policy ~a forbids FFI" + (capability-ffi-libs caps) (policy-mode-name policy))) + ;; the effective sandbox grants: native? => allow exec of a compiler + ;; toolchain; network only if explicitly granted; FFI affects link. + (list (cons 'native native-wanted) + (cons 'build-network bnet-wanted) + (cons 'ffi ffi-wanted) + (cons 'ffi-libs (capability-ffi-libs caps))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-jpkg-build.ss @@ -0,0 +1,255 @@ +#!chezscheme +;;; tests/test-jpkg-build.ss — phase 5: policy modes, capability gating, +;;; sandboxed build planning, reproducible attestation, and the build/ +;;; clean/policy commands. + +(import (chezscheme) (std pkg policy) (std pkg build) (std pkg cli) + (std pkg util)) + +(define pass 0) +(define fail 0) + +(define-syntax check + (syntax-rules () + [(_ name expr) + (let ([got (guard (e [#t (list 'EXN (and (message-condition? e) + (condition-message e)))]) + expr)]) + (if (eq? got #t) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) (printf "FAIL ~a: got ~s~%" name got))))])) + +(define-syntax check-fails-with + (syntax-rules () + [(_ name substr expr) + (let ([got (guard (e [#t (if (and (message-condition? e) + (s-contains? (condition-message e) substr)) + 'EXPECTED + (list 'WRONG (and (message-condition? e) + (condition-message e))))]) + (begin expr 'NO-RAISE))]) + (if (eq? got 'EXPECTED) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) (printf "FAIL ~a: ~s~%" name got))))])) + +(define (s-contains? s sub) + (let ([sl (string-length s)] [xl (string-length sub)]) + (let loop ([i 0]) + (cond [(> (+ i xl) sl) #f] + [(string=? (substring s i (+ i xl)) sub) #t] + [else (loop (+ i 1))])))) + +(printf "--- jpkg build tests ---~%") + +;; ── policy modes ──────────────────────────────────────────────────────── + +(check "default-locked-down" + (let ([p (resolve-policy 'default "/none")]) + (and (eq? (policy-mode-name p) 'default) + (not (policy-allow-native? p)) + (not (policy-allow-build-network? p)) + (not (policy-allow-local-deps? p)) + (policy-require-signatures? p) + (policy-require-provenance? p)))) + +(check "strict-no-local-deps" + (let ([p (resolve-policy 'strict "/none")]) + (and (not (policy-allow-local-deps? p)) + (not (policy-allow-exceptions? p))))) + +(check "dev-allows-local" + (let ([p (resolve-policy 'dev "/none")]) + (and (policy-allow-local-deps? p) + (not (policy-require-signatures? p)) + (policy-allow-exceptions? p)))) + +(check "offline-locked-like-default" + (let ([p (resolve-policy 'offline "/none")]) + (and (not (policy-allow-native? p)) + (policy-require-signatures? p)))) + +(check "unsafe-permits-all" + (let ([p (resolve-policy 'unsafe "/none")]) + (and (policy-allow-native? p) + (policy-allow-build-network? p) + (policy-allow-ffi? p)))) + +(check-fails-with "unknown-mode" "unknown mode" + (resolve-policy 'bogus "/none")) + +;; ── project policy file overrides ─────────────────────────────────────── + +(define world (format "/tmp/jpkg-build-~a" (random-suffix))) +(define proj (path-concat world "proj")) +(define orig (current-directory)) +(mkdir-p (path-concat proj "src")) + +(define (write-text p s) (write-file-bytevector p (string->utf8 s))) + +(write-text (path-concat proj "jpkg.sexp") + "(package (name \"@b/app\") (version \"1.0.0\") (modules ((root \"src\"))))") +(write-text (path-concat proj "src/main.ss") "(def x 1)") + +(check "policy-file-loosens-within-dev" + (begin + (write-text (path-concat proj "jpkg.policy.sexp") + "(policy (mode dev) (allow (native-build) (ffi)))") + (let ([p (resolve-policy #f proj)]) + (and (eq? (policy-mode-name p) 'dev) + (policy-allow-native? p) + (policy-allow-ffi? p))))) + +(check "policy-file-cannot-loosen-default-native" + (begin + (write-text (path-concat proj "jpkg.policy.sexp") + "(policy (mode default) (allow (native-build)))") + (let ([p (resolve-policy #f proj)]) + ;; default forbids native even if the file asks for it + (not (policy-allow-native? p))))) + +(check "policy-file-can-tighten" + (begin + (write-text (path-concat proj "jpkg.policy.sexp") + "(policy (mode dev) (require (signatures) (provenance)))") + (let ([p (resolve-policy #f proj)]) + (and (policy-require-signatures? p) + (policy-require-provenance? p))))) + +(check-fails-with "policy-file-rejects-unsafe" "default/strict/dev/offline" + (begin + (write-text (path-concat proj "jpkg.policy.sexp") + "(policy (mode unsafe))") + (resolve-policy #f proj))) + +(check-fails-with "policy-file-unknown-clause" "unknown clause" + (begin + (write-text (path-concat proj "jpkg.policy.sexp") + "(policy (mode dev) (sudo (yes)))") + (resolve-policy #f proj))) + +;; command-line --policy overrides the file +(check "cmdline-overrides-file" + (begin + (write-text (path-concat proj "jpkg.policy.sexp") "(policy (mode dev))") + (eq? (policy-mode-name (resolve-policy 'strict proj)) 'strict))) + +(delete-file (path-concat proj "jpkg.policy.sexp")) + +;; ── capability gating ─────────────────────────────────────────────────── + +(check "gate-passes-plain-package" + (let ([g (gate-build-capabilities (resolve-policy 'default "/none") '())]) + (and (not (cdr (assq 'native g))) + (not (cdr (assq 'build-network g)))))) + +(check-fails-with "gate-refuses-undeclared-native-under-default" "native" + (gate-build-capabilities (resolve-policy 'default "/none") + '((native-code (reason . "x"))))) + +(check "gate-allows-native-under-dev-with-allow" + (let* ([p (begin (write-text (path-concat proj "jpkg.policy.sexp") + "(policy (mode dev) (allow (native-build)))") + (resolve-policy #f proj))] + [g (gate-build-capabilities p '((native-code (reason . "sqlite"))))]) + (cdr (assq 'native g)))) + +(check-fails-with "gate-refuses-ffi-under-default" "FFI" + (gate-build-capabilities (resolve-policy 'default "/none") + '((ffi (libraries "sqlite3"))))) + +(check-fails-with "gate-refuses-build-net-under-default" "network" + (gate-build-capabilities (resolve-policy 'default "/none") + '((network (build . #t) (test . #f))))) + +(delete-file (path-concat proj "jpkg.policy.sexp")) + +;; ── build planning + run + attestation ────────────────────────────────── + +(check "plan-build-default" + (let ([plan (plan-build proj #f)]) + (and (build-plan? plan) + (pair? (build-plan-command plan))))) + +(check "run-build-succeeds" + (let ([r (run-build proj #f)]) + (and (build-result-ok? r) + (string? (build-result-attestation r))))) + +(check "attestation-deterministic" + (let ([a1 (build-result-attestation (run-build proj #f))] + [a2 (build-result-attestation (run-build proj #f))]) + (string=? a1 a2))) + +(check "attestation-records-policy-and-caps" + (let ([a (build-result-attestation (run-build proj #f))]) + (and (s-contains? a "build-attestation") + (s-contains? a "@b/app") + (s-contains? a "\"policy\":\"default\"") + (s-contains? a "log-sha256")))) + +;; native build is refused at plan time under default +(check-fails-with "build-refuses-native-default" "native" + (begin + (write-text (path-concat proj "jpkg.sexp") + "(package (name \"@b/app\") (version \"1.0.0\") (modules ((root \"src\"))) + (capabilities ((native-code reason: \"need cc\"))))") + (plan-build proj #f))) + +;; same package builds under unsafe +(check "build-native-under-unsafe" + (let ([plan (plan-build proj 'unsafe)]) + (build-plan? plan))) + +;; restore plain manifest +(write-text (path-concat proj "jpkg.sexp") + "(package (name \"@b/app\") (version \"1.0.0\") (modules ((root \"src\"))))") + +;; ── commands ──────────────────────────────────────────────────────────── + +(define (run-jpkg args) + (let-values ([(op og) (open-string-output-port)] + [(ep eg) (open-string-output-port)]) + (let ([code (parameterize ([current-output-port op] + [current-error-port ep]) + (jpkg-main args))]) + (list code (og) (eg))))) + +(check "cmd-policy" + (begin + (current-directory proj) + (let ([r (run-jpkg '("policy"))]) + (and (= (car r) 0) + (s-contains? (cadr r) "active policy: default") + (s-contains? (cadr r) "require signatures: yes"))))) + +(check "cmd-policy-mode-override" + (let ([r (run-jpkg '("policy" "--policy" "dev"))]) + (and (= (car r) 0) + (s-contains? (cadr r) "active policy: dev") + (s-contains? (cadr r) "local/path deps: yes")))) + +(check "cmd-build" + (let ([r (run-jpkg '("build"))]) + (and (= (car r) 0) + (s-contains? (cadr r) "build succeeded") + (file-exists? ".jpkg/build/attestation.json")))) + +(check "cmd-clean" + (let ([r (run-jpkg '("clean"))]) + (and (= (car r) 0) + (not (file-directory? ".jpkg/build"))))) + +(check "cmd-build-refuses-native-default" + (begin + (write-text "jpkg.sexp" + "(package (name \"@b/app\") (version \"1.0.0\") (modules ((root \"src\"))) + (capabilities ((native-code reason: \"cc\"))))") + (let ([r (run-jpkg '("build"))]) + (and (= (car r) 1) + (s-contains? (caddr r) "native"))))) + +(current-directory orig) +(remove-tree world) + +(printf "~%--- jpkg build: ~a passed, ~a failed ---~%" pass fail) +(when (> fail 0) (exit 1)) --- a/tests/test-jpkg-cli.ss +++ b/tests/test-jpkg-cli.ss @@ -89,7 +89,7 @@ ;; commands not yet implemented return 3 and say so on stderr. ;; Shrink this list as phases land. (define *expected-stubs* - '("build" "clean" "audit" "search" "dir" "policy")) + '("audit" "search" "dir")) (for-each (lambda (cmd)