security: add exec worker facade
ober
7f52b200535919b92e5259c5a7f5c85d31e3115e
--- a/.jerboa-system +++ b/.jerboa-system @@ -32,6 +32,7 @@ "tools/check-audit-events.ss" "tools/check-generated-policy.ss" "tools/check-restrict-closure.ss" + "support/security-worker-main.ss" "tools/workspace-health.ss" "tools/capability-plan.ss" "tools/check-capability-use.ss" @@ -87,7 +88,8 @@ (test-targets ("system-check" "system-strict" "system-report" "system-provenance" "system-diff" "audit-event-check" "generated-policy-check" "unification-check" - "restrict-closure-check" "workspace-health" "capability-plan" + "restrict-closure-check" "test-worker" + "workspace-health" "capability-plan" "capability-use-check" "native-boundary-check" "install-policy-check" "tcb-report" "unification-release-check" "jerboa-smoke" "mcp-test-binary" --- a/Makefile +++ b/Makefile @@ -80,7 +80,7 @@ TYPED_WRAPPER_DIR ?= build/typed/jerboa .PHONY: check-cross-tools docker fuzz-websocket-fuzz jlsp jlsp-freebsd-amd64 \ jlsp-install jlsp-linux-amd64 jlsp-portable jmcp-freebsd-amd64 \ jmcp-freebsd-arm64 jmcp-linux-amd64 jmcp-linux-arm64 \ - jmcp-macos-amd64 test-all test-nrepl-auth test-phase2 \ + jmcp-macos-amd64 test-all test-nrepl-auth test-worker test-phase2 \ test-phase3 test-phase5a test-phase5b test-phase5c test-phase5d \ test-typed-fuzz typed-project-build test-web-large-response \ test-secure-link-argv test-jerboa-build-argv @@ -195,6 +195,7 @@ help: @echo " test-ergo Ergonomic contract marker tests" @echo " test-sqlite-robustness SQLite native robustness tests" @echo " test-limits-primitives Limits/sandbox/supervisor/audit primitive tests" + @echo " test-worker Exec worker boundary tests" @echo " test-known-flaky Known flaky/unresolved tests excluded from test" @echo " test-typed-parser Typed Jerboa parser tests" @echo " test-typed-checker Typed Jerboa checker tests" @@ -1336,6 +1337,9 @@ test-sqlite-robustness: native test-limits-primitives: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-limits-primitives.ss +test-worker: native + @$(NATIVE_TEST_ENV) $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-worker.ss + test-typed-core: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed-core.ss --- a/data/anti-patterns.sexp +++ b/data/anti-patterns.sexp @@ -5241,4 +5241,25 @@ "jerboa_verify" "jerboa_compile_check" "jerboa_check_balance" - "jerboa_repair_balance"))) + "jerboa_repair_balance")) + (("advice" + . + "Make native-backed aproc tests depend on the native target and invoke them with $(NATIVE_TEST_ENV) $(SCHEME) --libdirs $(LIBDIRS). Prefer absolute argv paths in pure-env child commands.") + ("avoid" + . + "Do not treat a passing compile check as proof that aproc is using the native argv backend. Without libjerboa_native loaded, aproc-run/status* may fall back through shell construction and fail or weaken the no-shell guarantee.") + ("id" . "aproc-native-test-without-native-env") + ("kinds" "testing" "security" "subprocess") + ("pattern" + . + "A test or security worker uses aproc-run/status* or aproc-spawn* with env-pure, but the Makefile target does not depend on native and does not run under NATIVE_TEST_ENV.") + ("severity" . "medium") + ("tags" "aproc" "env-pure" "NATIVE_TEST_ENV" "argv-spawn" + "native-loader") + ("title" + . + "Testing aproc argv execution without native test env hits shell fallback") + ("tools" + "jerboa_make" + "jerboa_verify" + "jerboa_check_balance"))) --- a/docs/ai-threat.md +++ b/docs/ai-threat.md @@ -88,10 +88,12 @@ separately exec'd worker; `run-safe-eval` does not install them. ### Exec-Based Isolation Limits Blast Radius -The safe production boundary is a bounded worker started through `exec`. The -worker begins with a fresh Chez runtime, installs its irreversible controls, -then accepts a bounded request. Its supervisor owns deadlines, process-group -termination, and bounded stdin/stdout/stderr channels. +The safe production boundary is `(std security worker)`: a bounded worker +started through argv `exec` with a fresh Chez runtime, pure child environment, +parent deadline, process-group termination, and returned output caps. Kernel +controls that must be installed before the child reads input still require the +native pre-exec backend; worker policies fail closed when callers require an +unavailable axis. `run-safe`'s former Scheme-thunk callback is retired and always fails closed. Returning into the Chez evaluator after raw `fork(2)` can corrupt runtime state @@ -149,8 +151,9 @@ control. 'max-memory-size #f)) ``` -Adversarial workloads need a separately exec'd worker with OS resource limits. -The supervisor must terminate and reap the worker on deadline. +Adversarial workloads should use `(std security worker)`. The supervisor +terminates and reaps the worker on deadline; OS resource limits become part of +the same policy once the native pre-exec backend lands. ### Retired `run-safe` Result Path @@ -158,8 +161,8 @@ The supervisor must terminate and reap the worker on deadline. `&sandbox-error` before invoking the thunk. `run-safe-eval` returns directly from in-process evaluation and creates no temporary result file. -An exec-worker implementation must use bounded pipes or sockets rather than a -predictable temporary filename. +The current exec-worker facade uses stdin/stdout/stderr pipes and returned +output caps rather than a predictable temporary filename. ### The Pre-Existing Import Conflict @@ -180,7 +183,7 @@ wrong version of a function (safe vs unsafe) in edge cases. | Eval injection | Allowlist-blocked | Ahead | Far ahead | Ahead | | FFI boundary bugs | Risk (manual) | Comparable | Comparable | N/A (JNI) | | Logic bugs | No advantage | No advantage | No advantage | No advantage | -| DoS / resource exhaustion | Partial in-process; worker-defined for isolation | Behind | Behind | Behind (JVM has memlimits) | +| DoS / resource exhaustion | Worker deadline/output caps; memory rlimit still pending | Behind | Behind | Behind (JVM has memlimits) | | Deserialization attacks | Depth-limited | Comparable | Ahead (limits) | Comparable | | Supply chain attacks | TUF metadata, Ed25519 signatures, transparency log, SBOM, OSV audit, content-addressed artifacts | Comparable | Comparable | Comparable | --- a/docs/kimi3-security-recommmendations.md +++ b/docs/kimi3-security-recommmendations.md @@ -148,13 +148,14 @@ never pattern-based: memory-corruption patterns *exist* in a Jerboa application. [`Philosophy.md`](Philosophy.md) Principle 4 and open tension #5 both name this. -- **The process-isolation boundary is currently missing from the tree.** - Every doc says "put adversarial work in a bounded, separately exec'd - worker." No such worker launcher exists in-tree today: - `sandbox-launch` returns status 126 `pre-exec-refused`, - `supervise-available?` returns `#f`, and the raw-fork launchers all fail - closed by design ([`limits.md`](limits.md), [`security-reference.md`](security-reference.md) §5–6). - **This is the single most important gap.** P0-02 builds it. +- **The process-isolation boundary now has a first exec facade, but not the + full kernel-control backend.** `(std security worker)` launches restricted + evaluation through argv `exec` with a pure environment, parent deadline, + process-group kill, output caps, and fail-closed refused axes. + `sandbox-launch` still returns status 126 `pre-exec-refused`, + `supervise-available?` returns `#f`, and the remaining P0-02 work is the + native pre-exec backend for rlimits, Landlock/seccomp, Seatbelt/Capsicum, + egress proxy wiring, and audit-log start/end. --- @@ -210,7 +211,8 @@ when" must be answerable from `dist/release-evidence/` in minutes. | macOS / FreeBSD confinement | `(std security seatbelt)`, `(std security capsicum)` | exist | lib listing | | Self-confinement (pledge/unveil-style `cage!`) | `(std security cage)` | exists; **absent from security-reference.md** — doc gap | `lib/std/security/cage.ss` | | Privilege-separation pipe channels (no launcher) | `(std security privsep)` | channels only, by design | security-reference §5 | -| Launch policy planner + egress policy objects (no launcher) | `(std os limits sandbox)` | passive policy only, `pre-exec-refused` | [limits.md](limits.md) | +| Launch policy planner + egress policy objects (no native pre-exec backend) | `(std os limits sandbox)` | passive policy only, `pre-exec-refused`; `(std security worker)` handles argv exec facade | [limits.md](limits.md) | +| Exec restricted worker facade | `(std security worker)` | exists; pure env, deadline, process-group kill, output caps, fail-closed refused axes; pre-exec kernel controls pending | security-reference §5 | | Native async exec launcher (collect-safe) | `(std os aproc)` | exists — the primitive P0-02 should build on | [aproc.md](aproc.md) | | Parser hardening (depth/size/backtrack budgets: reader, JSON, XML, YAML, DNS, HTTP/2, WS, zlib, base64, hex, CSV, pregexp, format) | various | phases 1–4 done, 42 tests; **phase 5 (FFI audit) not started** | security-reference §7 | | Safe deserialization (tagged-JSON envelope, no native FASL on untrusted paths) | `(std safe-fasl)`, `(std fasl)` (trusted-only) | exists; raw-FASL callers still need triage (P0-04) | [safety-guide.md](safety-guide.md) §10 | @@ -271,8 +273,10 @@ when" must be answerable from `dist/release-evidence/` in minutes. breakage was reported for `lib/std/pipeline.ss`, `tests/test-pipeline.ss`, `tests/test-security2-parsers.ss` in the checklist appended to `security-reference.md` — re-verify all four. -2. **No exec-based confined worker exists** (see §2.3). All confinement - docs point at a boundary that isn't built. +2. **The exec worker facade exists, but the native pre-exec confined backend + remains open** (see §2.3). The launcher composes argv exec, pure env, + deadline, output caps, and refused-axis reporting; rlimits, kernel + sandboxes, egress proxy wiring, and audit-log start/end still need to land. 3. **No fuzz seed corpora and no crash-regression corpus** — fuzzing is harness-only; nothing preserves found crashes as tests. 4. **`docs/ai-threat.md` comparative table is stale**: it rates supply @@ -296,7 +300,7 @@ when" must be answerable from `dist/release-evidence/` in minutes. | Goal | Where we stand | The gap | |---|---|---| | G1 shrink target | Managed core is memory-safe; parsers budgeted; safe prelude exists | FFI surface (91 files / 225 symbols / 432 `unsafe`) never systematically audited (phase 5); `vendor/jsqlite` is C in the TCB; safe prelude not the default entry; import conflict undermines "safe symbol wins" confidence | -| G2 cap blast radius | Capabilities, taint, kernel sandbox, egress policy objects all exist | **No worker launcher to assemble them at runtime**; taint opt-in; TOCTOU on paths; distributed actors unauthenticated; no memory limit story; `define-syntax` in sandbox | +| G2 cap blast radius | Capabilities, taint, kernel sandbox, egress policy objects, and worker facade all exist | **No native pre-exec worker backend to install kernel controls before child input**; taint opt-in; TOCTOU on paths; distributed actors unauthenticated; no memory limit story; `define-syntax` in sandbox | | G3 find it first | 13 harnesses, scanner w/ rule DB, lint | No corpora, no crash regression, no scheduled fuzzing, no standing AI-red-team, no exploit-shaped regression suite | | G4 fail closed | Raw-fork launchers retired correctly; `allow-degraded?` explicit | New controls must keep the invariant; degraded-mode warnings must be test-locked | | G5 recover fast | SBOM/repro/signing gates exist | TCB accounting manual; doc drift (stale tables, undocumented modules); independent-builder reproducibility not yet routine | @@ -332,11 +336,14 @@ the code that ships. This violates the repo's own pre-commit rule. succeeds; `make audit` fails when a synthetic unbalanced file is added. ### K3-P0-02 — Build the exec-based confined worker (`(std security worker)`) -**Serves:** G2, G3, G4. **Effort:** 1–2 weeks. **This is the keystone.** +**Serves:** G2, G3, G4. **Effort:** 1–2 weeks. **Status:** initial +`(std security worker)` facade landed 2026-07-27 with `tests/test-worker.ss`; +native pre-exec controls, egress proxy wiring, memory rlimit, and audit-log +events remain open. Every security doc routes adversarial work to "a bounded, separately exec'd -worker" that does not exist. Build it as the assembly point for controls -that already exist individually. +worker". The initial facade exists; finish it as the assembly point for +controls that already exist individually. - **Where:** new `lib/std/security/worker.ss`; build on `(std os aproc)` (collect-safe argv exec, no shell) for launch; reuse policy records from @@ -880,7 +887,7 @@ Track these in `docs/status.md` per release: | Metric | Baseline (2026-07-27) | Target | |---|---|---| | Build balance clean | `pattern.ss` repaired 2026-07-27; `source-balance` in `make audit` | always clean | -| Confined worker exists | no | yes, tested (P0-02) | +| Confined worker exists | initial facade landed 2026-07-27; native pre-exec backend pending | yes, tested (P0-02) | | Unclassified raw `read`/FASL sites | unknown (4+ named) | 0 | | FFI bindings audited | 0 / 91 files | 100% with verdicts | | Un-annotated Rust `unsafe` blocks | unknown / 432 matches | 0 | @@ -970,9 +977,9 @@ fake confidence happens. - FFI audit (phase 5) unstarted until P1-01; `vendor/jsqlite` is C in the TCB pending its decision. - No independent red-team evaluation yet (P2-04 starts the practice). -- The confined exec worker does not exist yet (P0-02); until it lands, - every doc sentence saying "use an exec worker" describes an aspiration, - not an API. +- The confined exec worker facade exists as `(std security worker)`, but the + native pre-exec backend for rlimits, kernel sandboxes, egress proxy wiring, + and audit-log lifecycle events is still pending (P0-02/P1-07/P1-08). - The committed `pattern.ss` balance blocker named in P0-01 was repaired on 2026-07-27. The `pipeline.ss` and `test-pipeline.ss` reports were traced to escaped-identifier false positives in the balance scanner; the scanner now --- a/docs/safety-guide.md +++ b/docs/safety-guide.md @@ -24,6 +24,8 @@ default. Specifically, you get: - **Safe serialization** — `safe-fasl-read`/`safe-fasl-write` use a bounded, non-executable pure-data format and reject native FASL/runtime objects - **Restricted evaluator** — `run-safe-eval` for bounded, allowlisted evaluation +- **Exec worker facade** — `worker-run-eval` for running restricted eval in a + fresh process with pure env, deadline, and output caps - **Error conditions** — structured hierarchy instead of bare `(error ...)` What you do NOT get (intentionally): @@ -52,10 +54,16 @@ timeout and a cap on the formatted result. It does **not** create a process, install kernel protections, set a memory limit, or isolate the evaluator from the application. -Production code that needs a process boundary, Landlock, seccomp, Seatbelt, -Capsicum, capabilities, or an address-space limit must start a bounded worker -through `exec` and install those controls in that fresh process before handling -untrusted input. Do not execute Scheme between `fork` and `exec`. +Production code that needs a process boundary should use `(std security +worker)`. It starts a fresh process through argv execution, uses a pure +environment policy, enforces a parent deadline, and caps returned stdout/stderr. +Do not execute Scheme between `fork` and `exec`. + +Landlock, seccomp, Seatbelt, Capsicum, capabilities, deny-default egress, and +address-space limits are requested as worker policy axes. They still require the +native pre-exec backend before they can be installed inside the child; until +then, requiring an unavailable axis returns `launched? = #f` instead of silently +running degraded. ### Basic Usage @@ -85,6 +93,27 @@ untrusted input. Do not execute Scheme between `fork` and `exec`. (run-safe (lambda () (+ 1 2))) ;; raises &sandbox-error, phase 'fork ``` +### Exec Worker Usage + +```scheme +(import (std security worker)) + +(define r + (worker-run-eval + "(map (lambda (x) (* x x)) '(1 2 3))" + (worker-policy + 'timeout-ms: 1000 + 'stdout-cap-bytes: 65536 + 'stderr-cap-bytes: 65536))) + +(when (worker-result-launched? r) + (worker-result-stdout r)) +``` + +Use `worker-result-refused-axes` and `worker-result-diagnostics` when a worker +does not launch. That is the expected fail-closed path for requested controls +that are not available on the current platform/backend. + ### Degradation Must Be Explicit ```scheme --- a/docs/security-reference.md +++ b/docs/security-reference.md @@ -16,6 +16,7 @@ Jerboa's security model is layered defense-in-depth. No single layer is trusted | **Taint tracking** | Mark untrusted data, reject at dangerous sinks | `(std security taint)` | | **Kernel enforcement** | Landlock filesystem rules, seccomp-BPF syscall filtering | `(std security landlock)`, `(std security seccomp)` | | **Privilege separation** | Pipe channels for separately exec'd supervisor/worker processes | `(std security privsep)` | +| **Exec worker** | Run restricted eval in a fresh argv-exec'd process with pure env, deadline, and output caps | `(std security worker)` | | **Parser hardening** | Depth limits, size limits, backtracking budgets | Various (see section 7) | | **Crypto** | AEAD, CSPRNG, HMAC, KDF, timing-safe comparison, secure memory | `(std crypto ...)` | | **Input sanitization** | Context-aware escaping for HTML, SQL, paths, headers, URLs | `(std security sanitize)` | @@ -215,12 +216,54 @@ the intended descriptors, and impose explicit message and process limits. --- +### Exec Worker -- `(std security worker)` + +`(std security worker)` is the supported process-boundary facade for +adversarial evaluation. It launches a fresh Scheme process with argv execution +through `(std os aproc)`, builds a pure child environment from `(std security +env)`, sends the expression on stdin, and runs it through `run-safe-eval` in the +child entrypoint `support/security-worker-main.ss`. + +```scheme +(import (std security worker)) + +(define result + (worker-run-eval + "(+ 1 2)" + (worker-policy + 'timeout-ms: 1000 + 'stdout-cap-bytes: 65536 + 'stderr-cap-bytes: 65536))) + +(and (worker-result-launched? result) + (worker-result-status result) + (worker-result-stdout result)) +``` + +Worker results are structured: `worker-result-launched?`, +`worker-result-status`, `worker-result-stdout`, `worker-result-stderr`, +`worker-result-refused-axes`, and `worker-result-diagnostics`. Requested axes +are fail-closed: if a policy requires an unavailable sandbox axis, the worker +returns `launched? = #f`, status `126`, and the refused axis list instead of +silently running with weaker controls. + +Current limitation: the worker has a real exec boundary, pure environment, +parent deadline, process-group kill through `aproc`, and returned output caps. +The remaining pre-exec kernel-control backend is not complete, so rlimit, +Landlock/seccomp, Seatbelt/Capsicum installation, deny-default egress proxy +wiring, and audit-log start/end records remain tracked by the K3 handoff. + +--- + ### Sandbox Launch Policies and Egress Reports -- `(std os limits sandbox)` The launch-policy sandbox layer provides a passive policy object plus per-axis planning and diagnostic reports. Its Scheme-side launcher is retired: `sandbox-launch` currently returns an unlaunched result whose process result has -status 126 and reason `pre-exec-refused`. It does not create a child. +status 126 and reason `pre-exec-refused`. It does not create a child. Use +`(std security worker)` for the current exec worker facade; use +`sandbox-launch` diagnostics to decide which axes a future pre-exec backend +must satisfy. Network egress can be declared as an ordered policy: new file mode 100644 --- /dev/null +++ b/lib/std/security/worker.ss @@ -0,0 +1,257 @@ +#!chezscheme +;;; (std security worker) -- exec-based restricted worker facade +;;; +;;; This module is the supervisor-facing API for running adversarial work out +;;; of process. It uses argv execution through (std os aproc), builds a pure +;;; child environment through (std security env), and refuses requested sandbox +;;; axes that the current platform cannot report as installed. +;;; +;;; Kernel controls that require child pre-exec installation still depend on +;;; the native supervisor backend. Until that backend exists, callers must pass +;;; required axes and treat launched?=#f as the fail-closed result. + +(library (std security worker) + (export + worker-policy? + worker-policy + make-worker-policy + worker-policy-command + worker-policy-env-policy + worker-policy-cwd + worker-policy-timeout-ms + worker-policy-stdout-cap-bytes + worker-policy-stderr-cap-bytes + worker-policy-require + worker-policy-fail-closed? + + worker-result? + make-worker-result + worker-result-launched? + worker-result-status + worker-result-stdout + worker-result-stderr + worker-result-refused-axes + worker-result-diagnostics + worker-result-command + + worker-default-command + worker-run-command + worker-run-eval) + + (import (chezscheme) + (only (jerboa core) def defstruct) + (only (std os aproc) aproc-run/status*) + (only (std os limits sandbox) sandbox-capabilities sandbox-backend) + (only (std security env) + env-policy? + env-policy-default + env-policy-build + env-policy-validate-command + env-policy-audit-summary)) + + (defstruct %worker-policy + (command env-policy cwd timeout-ms stdout-cap-bytes stderr-cap-bytes + require fail-closed?)) + + (def make-worker-policy make-%worker-policy) + (def worker-policy? %worker-policy?) + (def worker-policy-command %worker-policy-command) + (def worker-policy-env-policy %worker-policy-env-policy) + (def worker-policy-cwd %worker-policy-cwd) + (def worker-policy-timeout-ms %worker-policy-timeout-ms) + (def worker-policy-stdout-cap-bytes %worker-policy-stdout-cap-bytes) + (def worker-policy-stderr-cap-bytes %worker-policy-stderr-cap-bytes) + (def worker-policy-require %worker-policy-require) + (def worker-policy-fail-closed? %worker-policy-fail-closed?) + + (defstruct %worker-result + (launched? status stdout stderr refused-axes diagnostics command)) + + (def make-worker-result make-%worker-result) + (def worker-result? %worker-result?) + (def worker-result-launched? %worker-result-launched?) + (def worker-result-status %worker-result-status) + (def worker-result-stdout %worker-result-stdout) + (def worker-result-stderr %worker-result-stderr) + (def worker-result-refused-axes %worker-result-refused-axes) + (def worker-result-diagnostics %worker-result-diagnostics) + (def worker-result-command %worker-result-command) + + (def (absolute-path path) + (cond + [(or (not path) (string=? path "")) path] + [(char=? (string-ref path 0) #\/) path] + [else + (let ([cwd (current-directory)]) + (if (char=? (string-ref cwd (- (string-length cwd) 1)) #\/) + (string-append cwd path) + (string-append cwd "/" path)))])) + (def (worker-default-command) + (let ([scheme (or (getenv "JERBOA_WORKER_SCHEME") + (absolute-path ".chez/bin/scheme"))] + [libdirs (or (getenv "JERBOA_WORKER_LIBDIRS") + (string-append (absolute-path "lib") ":" + (absolute-path "vendor/jsqlite/src")))] + [main (or (getenv "JERBOA_WORKER_MAIN") + (absolute-path "support/security-worker-main.ss"))]) + (list scheme "--libdirs" libdirs "--script" main))) + + (def (worker-policy . opts) + (let ([command #f] + [env-pol (env-policy-default)] + [cwd #f] + [timeout-ms 5000] + [stdout-cap-bytes (* 1024 1024)] + [stderr-cap-bytes (* 256 1024)] + [require '()] + [fail-closed? #t]) + (let loop ([xs opts]) + (cond + [(null? xs) + (make-worker-policy command env-pol cwd timeout-ms + stdout-cap-bytes stderr-cap-bytes + require fail-closed?)] + [(null? (cdr xs)) + (error 'worker-policy "dangling keyword" (car xs))] + [else + (let ([key (car xs)] [val (cadr xs)]) + (case key + [(command:) (set! command val)] + [(env-policy:) (set! env-pol val)] + [(cwd:) (set! cwd val)] + [(timeout-ms:) (set! timeout-ms val)] + [(stdout-cap-bytes:) (set! stdout-cap-bytes val)] + [(stderr-cap-bytes:) (set! stderr-cap-bytes val)] + [(require:) (set! require val)] + [(fail-closed?:) (set! fail-closed? (and val #t))] + [else (error 'worker-policy "unknown keyword" key)]) + (loop (cddr xs)))])))) + + (def (valid-command? argv) + (and (list? argv) + (pair? argv) + (let lp ([xs argv]) + (cond + [(null? xs) #t] + [(string? (car xs)) (lp (cdr xs))] + [else #f])))) + + (def (axis-status axis caps) + (cond + [(assq axis caps) => cdr] + [else 'unavailable])) + + (def (axis-installed? axis caps) + (eq? (axis-status axis caps) 'installed)) + + (def (missing-required-axes required caps) + (let lp ([xs required] [out '()]) + (cond + [(null? xs) (reverse out)] + [(axis-installed? (car xs) caps) (lp (cdr xs) out)] + [else (lp (cdr xs) (cons (car xs) out))]))) + + (def (truncate-string s cap) + (cond + [(not cap) s] + [(and (integer? cap) (>= cap 0) (> (string-length s) cap)) + (substring s 0 cap)] + [else s])) + + (def (truncated? original capped) + (> (string-length original) (string-length capped))) + + (def (worker-refusal-result command pol caps missing reason) + (make-worker-result + #f + 126 + "" + "" + missing + `((backend . ,(sandbox-backend)) + (capabilities . ,caps) + (env . ,(env-policy-audit-summary (worker-policy-env-policy pol))) + (reason . ,reason)) + command)) + + (def (run-aproc-captured command pol env stdin-data) + (let* ([args (append + (list 'env-pure: env) + (if (worker-policy-cwd pol) + (list 'dir: (worker-policy-cwd pol)) + '()) + (if stdin-data (list 'stdin: stdin-data) '()) + (list 'timeout-ms: (worker-policy-timeout-ms pol) + 'encoding: 'utf8-lossy + 'new-pgroup: #t))]) + (let-values ([(stdout stderr status) + (apply aproc-run/status* command args)]) + (list stdout stderr status)))) + + (def (worker-finish-result command pol caps captured) + (let* ([stdout (car captured)] + [stderr (cadr captured)] + [status (caddr captured)] + [stdout* (truncate-string stdout (worker-policy-stdout-cap-bytes pol))] + [stderr* (truncate-string stderr (worker-policy-stderr-cap-bytes pol))]) + (make-worker-result + #t + status + stdout* + stderr* + '() + `((backend . ,(sandbox-backend)) + (capabilities . ,caps) + (stdout-truncated? . ,(truncated? stdout stdout*)) + (stderr-truncated? . ,(truncated? stderr stderr*)) + (env . ,(env-policy-audit-summary (worker-policy-env-policy pol)))) + command))) + + (def (worker-run-command* command pol stdin-data) + (unless (worker-policy? pol) + (error 'worker-run-command "expected worker-policy" pol)) + (unless (valid-command? command) + (error 'worker-run-command "command must be a non-empty list of strings" command)) + (unless (env-policy? (worker-policy-env-policy pol)) + (error 'worker-run-command "expected env-policy" (worker-policy-env-policy pol))) + (let* ([caps (sandbox-capabilities)] + [missing (missing-required-axes (worker-policy-require pol) caps)]) + (cond + [(and (worker-policy-fail-closed? pol) (pair? missing)) + (worker-refusal-result command pol caps missing 'required-axis-unavailable)] + [else + (let* ([env (env-policy-build (worker-policy-env-policy pol) getenv)] + [validation (env-policy-validate-command + (worker-policy-env-policy pol) '() command)]) + (cond + [(eq? (car validation) 'error) + (worker-refusal-result command pol caps '() (cdr validation))] + [else + (worker-finish-result + command + pol + caps + (run-aproc-captured command pol env stdin-data))]))]))) + + (def (worker-run-command argv . maybe-policy) + (let* ([pol (if (null? maybe-policy) (worker-policy) (car maybe-policy))] + [command (or argv (worker-policy-command pol))]) + (worker-run-command* command pol #f))) + + (def (worker-run-eval expr-string . maybe-policy) + (unless (string? expr-string) + (error 'worker-run-eval "expected expression string" expr-string)) + (let* ([pol0 (if (null? maybe-policy) (worker-policy) (car maybe-policy))] + [command (or (worker-policy-command pol0) (worker-default-command))] + [pol (make-worker-policy + command + (worker-policy-env-policy pol0) + (worker-policy-cwd pol0) + (worker-policy-timeout-ms pol0) + (worker-policy-stdout-cap-bytes pol0) + (worker-policy-stderr-cap-bytes pol0) + (worker-policy-require pol0) + (worker-policy-fail-closed? pol0))]) + (worker-run-command* command pol expr-string))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/support/security-worker-main.ss @@ -0,0 +1,56 @@ +#!chezscheme +;;; Child entrypoint for (std security worker). +;;; +;;; The parent supplies one expression on stdin. This process evaluates it with +;;; the in-process restricted evaluator after exec, then reports a compact +;;; s-expression. The parent treats the whole child as untrusted output and caps +;;; it at the process boundary. + +(import (jerboa prelude) + (std security sandbox)) + +(def (read-port-all port) + (let ([out (open-output-string)]) + (let loop () + (let ([ch (read-char port)]) + (cond + [(eof-object? ch) (get-output-string out)] + [else + (write-char ch out) + (loop)]))))) + +(def (condition->worker-string exn) + (cond + [(message-condition? exn) (condition-message exn)] + [else + (with-output-to-string + (lambda () (display-condition exn)))])) + +(def (main) + (let ([expr (read-port-all (current-input-port))]) + (try + (let* ([captured (open-output-string)] + [value (parameterize ([current-output-port captured] + [current-error-port captured]) + (run-safe-eval + expr + (make-sandbox-config + 'timeout 60 + 'seccomp #f + 'landlock #f + 'seatbelt #f + 'capsicum #f + 'capabilities '() + 'max-memory-size #f + 'max-output-size (* 64 1024) + 'allow-degraded? #f)))] + [printed (get-output-string captured)]) + (write `(ok (value . ,value) (output . ,printed))) + (newline) + (exit 0)) + (catch (exn) + (write `(error . ,(condition->worker-string exn))) + (newline) + (exit 1))))) + +(main) new file mode 100644 --- /dev/null +++ b/tests/test-worker.ss @@ -0,0 +1,129 @@ +#!chezscheme +;;; Tests for (std security worker). + +(import (scheme) + (std security worker)) + +(define pass 0) +(define fail 0) + +(define (string-contains? s sub) + (and (string? s) + (string? sub) + (let ([ns (string-length s)] + [nsub (string-length sub)]) + (let lp ([i 0]) + (cond + [(> (+ i nsub) ns) #f] + [(string=? (substring s i (+ i nsub)) sub) #t] + [else (lp (+ i 1))]))))) +(define (alist-ref/default al key default) + (cond + [(and (pair? al) (assq key al)) => cdr] + [else default])) + +(define (test-pred name expr pred) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: threw ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (pred got) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: ~s did not satisfy predicate~%" name got)))))) + +(define (absolute-path path) + (cond + [(or (not path) (string=? path "")) path] + [(char=? (string-ref path 0) #\/) path] + [else + (let ([cwd (current-directory)]) + (if (char=? (string-ref cwd (- (string-length cwd) 1)) #\/) + (string-append cwd path) + (string-append cwd "/" path)))])) +(define worker-command + (list (or (getenv "SCHEME") (absolute-path ".chez/bin/scheme")) + "--libdirs" + (or (getenv "JERBOA_TEST_LIBDIRS") + (string-append (absolute-path "lib") ":" + (absolute-path "vendor/jsqlite/src"))) + "--script" + (absolute-path "support/security-worker-main.ss"))) + +(define (test-policy timeout-ms) + (worker-policy + 'command: worker-command + 'timeout-ms: timeout-ms + 'stdout-cap-bytes: 65536 + 'stderr-cap-bytes: 65536)) + +(define (ok-result? r) + (and (worker-result? r) + (worker-result-launched? r) + (equal? (worker-result-status r) 0) + (string-contains? (worker-result-stdout r) "(ok"))) + +(define (error-result? r) + (and (worker-result? r) + (worker-result-launched? r) + (not (equal? (worker-result-status r) 0)) + (string-contains? (worker-result-stdout r) "(error"))) + +(printf "--- worker tests ---~%") + +(test-pred "restricted eval arithmetic" + (worker-run-eval "(+ 1 2)" (test-policy 3000)) + ok-result?) + +(test-pred "system unavailable in worker" + (worker-run-eval "(system \"true\")" (test-policy 3000)) + error-result?) + +(test-pred "eval unavailable in worker" + (worker-run-eval "(eval '(+ 1 2))" (test-policy 3000)) + error-result?) + +(test-pred "foreign-procedure unavailable in worker" + (worker-run-eval "(foreign-procedure \"system\" (string) int)" (test-policy 3000)) + error-result?) + +(test-pred "cpu spin times out" + (worker-run-eval "(let loop () (loop))" (test-policy 200)) + (lambda (r) + (and (worker-result? r) + (worker-result-launched? r) + (eq? (worker-result-status r) 'timeout)))) +(test-pred "stdout cap truncates result" + (worker-run-eval + "(begin (display \"abcdefghijklmnopqrstuvwxyz\") 'done)" + (worker-policy + 'command: worker-command + 'timeout-ms: 3000 + 'stdout-cap-bytes: 12 + 'stderr-cap-bytes: 65536)) + (lambda (r) + (and (worker-result? r) + (worker-result-launched? r) + (equal? (worker-result-status r) 0) + (<= (string-length (worker-result-stdout r)) 12) + (eq? (alist-ref/default (worker-result-diagnostics r) + 'stdout-truncated? #f) + #t)))) + +(test-pred "required unavailable axis refuses before launch" + (worker-run-eval + "(+ 1 1)" + (worker-policy + 'command: worker-command + 'timeout-ms: 3000 + 'require: '(definitely-unavailable-worker-axis) + 'fail-closed?: #t)) + (lambda (r) + (and (worker-result? r) + (not (worker-result-launched? r)) + (equal? (worker-result-status r) 126) + (equal? (worker-result-refused-axes r) + '(definitely-unavailable-worker-axis))))) + +(printf "worker tests: ~a passed, ~a failed~%" pass fail) +(when (> fail 0) (exit 1))