Report pre-exec sandbox install status
ober
6c31e89804f4beba9da08563bcb8a440fe54ebab
--- a/docs/limits-followup.md +++ b/docs/limits-followup.md @@ -1,25 +1,26 @@ # Limits Follow-Up: Missing Enforcement and Test Work Reviewed: 2026-05-21 -Status updated: 2026-05-21 (post-`1e4aba7` follow-up) +Status updated: 2026-05-21 (post child-status handshake phase) This document is a follow-up to `docs/limits.md` after reviewing the new limits/sandbox/audit module set added around commit `97eea41`. -The short version after the follow-up commit: the new modules are wired far -enough for callers to choose safe fail-closed behavior, and the focused -primitive tests are now part of `make test`. Some backend work remains: -per-child sandbox install status still needs a parent-visible status pipe, -Linux cgroup enforcement is not implemented, and tracefs is still a strace -wrapper/parser rather than a full normalized filesystem-event backend. +The short version after the child-status phase: the new modules are wired far +enough for callers to choose safe fail-closed behavior based on actual +pre-exec child setup status. The focused primitive tests are part of +`make test`. Some backend work remains: Linux cgroup enforcement is not +implemented, tracefs is still a strace wrapper/parser rather than a full +normalized filesystem-event backend, and deeper backend-specific filesystem +and network denial tests are still needed. ## Status After Follow-Up Fixes | § | Topic | Status | |----|------------------------|--------| -| 1 | Unified sandbox API | SAFE PARTIAL — `sandbox-launch` has `require:` + `fail-closed?:`; macOS path policies wrap with `sandbox-exec`; **GAP**: child-to-parent install-status pipe | -| 2 | Process supervision | DONE — timeout/capture handling and `128 + signal` statuses are covered by focused tests | -| 3 | Resource limits | SAFE PARTIAL — requested-limit plans and installs are per-kind; parent-side time/output markers exist; **GAP**: cgroup v2 and parent-visible child install reports | +| 1 | Unified sandbox API | SAFE PARTIAL — `sandbox-launch` has `require:` + `fail-closed?:`, parent-visible child install status, dynamic reports, and macOS path-policy wrapping; **GAP**: deeper path/net denial tests and backend-specific degraded cases | +| 2 | Process supervision | DONE — timeout/capture handling, `128 + signal` statuses, output caps, and pre-exec go/no-go handshakes are covered by focused tests | +| 3 | Resource limits | SAFE PARTIAL — requested-limit plans and child install reports are per-kind; `require: '(limits)` fails closed before exec; parent-side time/output markers exist; **GAP**: cgroup v2 | | 4 | Executable identity | DONE — path search, realpath/stat identity, comparison helper, and TOCTOU caveat are present | | 5 | Filesystem tracing | SAFE PARTIAL — `tracefs-capabilities` + fail-closed wrapper exist; **GAP**: fd/cwd tracking and normalized fs-event output | | 6 | Network allowlist | DONE for decision layer — IP literals and localnet ranges are denied before wildcard matching; **GAP**: DNS recheck + child network sandbox/proxy handoff | @@ -60,7 +61,7 @@ make test # includes tests/test-limits-primitives.ss /Users/user/mine/jerboa/.chez/bin/scheme --libdirs lib --script tests/test-limits-primitives.ss -# 43 passed, 0 failed, 0 skipped +# 58 passed, 0 failed, 0 skipped ``` ## Required Standard Before Calling This Done @@ -87,11 +88,10 @@ here so we do not redefine it per axis: > failure. Refusal must happen *before* the target binary runs. For backends where install happens in the child between fork and exec -(Landlock, Seatbelt, pledge, setrlimit), the child must write install status -to a status pipe, and the parent must read that status and explicitly signal -go/no-go *before* the child calls exec. Otherwise the child has already -exec'd into untrusted code by the time the parent learns the sandbox was -degraded. See section 1 for the protocol. +(Landlock, Seatbelt, pledge, setrlimit), `(std os supervise)` now supports this +ordering with `child-status-proc:` and `child-status-accept?:`. The child writes +status to the parent and waits for a one-byte go/no-go decision before calling +`execve`. ## 1. Unified Sandbox API @@ -102,22 +102,19 @@ Implemented: - `sandbox-policy` record with read, write, exec, net, syscall, ptrace, and no-new-privs fields. - `sandbox-capabilities`. -- `sandbox-launch`. +- `sandbox-launch` keyword form with `require:` and `fail-closed?:`. +- Parent-visible pre-exec status reporting through `(std os supervise)`. +- Dynamic `sandbox-result-report` from the per-launch child install report, + merged with static capability metadata for axes not reported by the backend. +- `sandbox-result-limit-report` reports only the requested limits and their + actual child-side install status when a limit policy is present. +- `require: '(limits)` fails closed before target exec unless every requested + limit reports `installed` or `parent`. - macOS SBPL generation for path policies. - Linux Landlock hook via `jerboa_landlock_sandbox`. -Missing or wrong: - -- There is no fail-closed API. `docs/limits.md` says a caller must be able to - require full filesystem confinement or fail. The current API reports support - but does not let the caller say "abort if fs is degraded/unavailable". -- `sandbox-launch` returns static capability data, not per-launch install - results. The child calls `sandbox-prepare-child!`, but that report cannot - cross the fork boundary, so the parent result cannot say whether Landlock, - Seatbelt, pledge, or limits were actually installed. -- `sandbox-result-limit-report` is misleading. A test with only `(mem . 1)` - requested reported every limit capability as `attempted`, including - `platform`. It should report only requested limits and their actual status. +Still incomplete: + - Default policy semantics are unclear for callers. The policy record defaults `net` to `deny`, but a simple macOS `sandbox-launch` with no path policy ran `/bin/echo` successfully. That may be correct for a network-only SBPL, but it @@ -135,21 +132,7 @@ Missing or wrong: Required next work: -1. Add a `sandbox-requirements` or keyword options to `sandbox-launch`, for - example `fail-closed?: #t`, `require-fs?: #t`, `require-net?: #t`. -2. Create a child-to-parent status pipe so `sandbox-prepare-child!` and - `limit-policy-install!` can report actual install status before exec. - Required protocol: - - parent: fork, then read status records from the pipe in a loop until - EOF or until the child writes a final `ready` marker. - - child: install each axis, write a status record per axis, then write - `ready` and block reading a one-byte `go`/`no-go` from a second pipe. - - parent: if any required axis is not `installed`, write `no-go` and - `kill(child, SIGKILL)`. The child must NOT call exec until it reads - `go`. This ordering is the whole point — anything else lets the target - exec into a partially-confined process. -3. Make `sandbox-result-report` dynamic per launch. -4. Add tests for: +1. Add backend-denial tests for: - readable path allowed - unreadable path denied - writable path allowed @@ -158,6 +141,9 @@ Required next work: - net denied - degraded/unavailable reported when backend cannot enforce - fail-closed aborts when a required axis is not fully enforced +2. Split macOS capability reporting so "can wrap target with sandbox-exec" is + distinguishable from "this already-running child process is confined". +3. Add a first-class network allowlist/proxy handoff requirement. ## 2. Process Supervision @@ -171,8 +157,11 @@ Implemented: - process-group setup. - optional stdout/stderr capture. - parent-side timeout and output caps. +- `child-status-proc:` for setup code that must report status before exec. +- `child-status-accept?:` for parent-side go/no-go decisions. +- `process-result-child-status`. -Observed problems: +Fixed historical problems: - Timeout behavior is wrong when output capture is enabled. Running `/bin/sleep 2` with `timeout-ms: 100` and capture enabled waited roughly the @@ -185,24 +174,18 @@ Observed problems: A stdout cap test returned status `119` for SIGKILL instead of `137`. - The timeout loop should not sleep or wait in a way that lets a captured child finish normally after the timeout has been marked. + +Remaining limitations: + - There is no exact tree tracking yet. Process-group kill is useful, but `docs/limits.md` asks for the support precision to be tested and reported. Required next work: -1. Fix signal-derived statuses to `128 + signal`. -2. Fix timeout handling with captured pipes. After killing a timed-out process, - continue draining only until the process is reaped, and preserve the killed - status. -3. Add regression tests for: - - timeout without capture - - timeout with stdout capture - - timeout with stderr capture - - stdout cap - - stderr cap - - child that forks a background process and gets process-group killed -4. Include a test that verifies elapsed time is below a sane threshold for a - timed-out command. +1. Add a regression test for a child that forks a background process and gets + process-group killed. +2. Keep documenting tree tracking as process-group precision unless a platform + backend grows exact tree accounting. ## 3. Resource Limits @@ -214,6 +197,11 @@ Implemented: - `limit-policy-set!`. - `limit-policy-install!`. - support statuses for setrlimit-backed and parent-side limits. +- `limit-policy-plan` for preflight decisions. +- Actual child-side install reports are returned through `sandbox-launch` when + a limit policy is present. +- `require: '(limits)` refuses before target exec when requested limits are + unavailable, degraded, or missing. Missing or incomplete: @@ -221,7 +209,7 @@ Missing or incomplete: creation or delegated-controller integration for tree-wide memory, pids, or CPU. - `time-ms` and `out-bytes` are only parent-side markers. They depend on - `(std os supervise)`, and supervise currently has timeout/capture bugs. + `(std os supervise)`. - macOS memory is reported as degraded or unavailable, which is honest, but a caller needs fail-closed semantics if memory enforcement is required. - `RLIMIT_NPROC` is known to be user-wide or otherwise not tree-local on some @@ -233,9 +221,7 @@ Required next work: 1. Add cgroup v2 support where a delegated cgroup is available. 2. Keep setrlimit fallback, but expose exact caveats per platform. -3. Make `limit-policy-install!` return exact requested-limit results, not a - capability summary. -4. Add tests for `mem`, `cpu-sec`, `nofile`, `fsize`, `core`, `time-ms`, and +3. Add tests for `mem`, `cpu-sec`, `nofile`, `fsize`, `core`, `time-ms`, and `out-bytes`, with platform-aware skips. ## 4. Executable Identity @@ -437,22 +423,24 @@ Required next work: 3. Use this module from the other new primitives instead of leaving audit as a separate optional tool. -## 10. Tests Missing From This Repo +## 10. Focused Primitive Tests At review time, searching `tests/` did not find dedicated tests for the new -modules by name. Add a focused test file, for example: +modules by name. This is now covered by: ```text tests/test-limits-primitives.ss ``` -Minimum coverage: +Current coverage: - `limits-capabilities` shape. -- `limit-policy-install!` per requested kind. -- `supervise-run` success, failure, timeout, output cap, process-group kill. +- `limit-policy-install!` through `sandbox-launch` actual child reports for + requested limits. +- `supervise-run` timeout, output cap, signal status math, and pre-exec + child-status go/no-go. - `sandbox-capabilities` shape and fail-closed behavior. -- `sandbox-launch` dynamic report. +- `sandbox-launch` dynamic report, `require: '(limits)`, and pre-exec refusal. - `exec-id-resolve` path, symlink, missing, hash. - `tracefs-parse-strace` for basic syscalls. - `allow-proxy-host-allowed?` exact, wildcard, localnet denial. @@ -462,14 +450,12 @@ Minimum coverage: ## Suggested Implementation Order -1. Fix `(std os supervise)` status and timeout behavior first. Many other - features depend on the supervisor being correct. -2. Add dynamic child-to-parent status reporting for sandbox and limits. -3. Add fail-closed support to sandbox and limits. -4. Fix allow-proxy IP/localnet denial and DNS recheck. -5. Add tests for all of the above. -6. Wire audit-log into the primitives. -7. Expand tracefs from a parser prototype into a real traced-run API. +1. Add backend-specific filesystem and network denial tests for + `(std os limits sandbox)`. +2. Add cgroup v2 support where a delegated controller is available. +3. Fix allow-proxy DNS recheck and proxy handoff. +4. Wire audit-log into the primitives. +5. Expand tracefs from a parser prototype into a real traced-run API. ## Commands Used During Review --- a/docs/limits.md +++ b/docs/limits.md @@ -77,6 +77,12 @@ Support query should be first-class: The API should make degraded behavior explicit. A caller must be able to say "fail closed if full filesystem confinement is unavailable." +Current implementation note: `(std os limits sandbox)` provides +`sandbox-policy`, `sandbox-capabilities`, and `sandbox-launch`. The keyword +form accepts `require:` and `fail-closed?:`; required axes are checked before +the target binary is allowed to exec. Child-side sandbox and limit installers +report status to the parent through `(std os supervise)` before exec. + ## 2. Process Supervision Jerboa needs a portable process supervisor that can launch and control child process trees. This is the foundation for timeouts, tracing, audit, and tree kill. @@ -108,7 +114,10 @@ Suggested result shape: command: '("/usr/bin/node" "tool.js") elapsed-ms: 1250 stdout-bytes: 4096 - stderr-bytes: 512) + stderr-bytes: 512 + child-status: '((ok . #t) + (value . ((sandbox . ...) + (limits . ...))))) ``` Tracking subprocesses is platform-specific. Jerboa should expose the best available method and report precision: @@ -155,6 +164,10 @@ Important caveats: The API should return which limits were actually installed. +Current implementation note: `limit-policy-plan` gives the trusted parent a +preflight prediction, while `sandbox-launch` returns the requested limits' +actual child-side install results in `sandbox-result-limit-report`. + ## 4. Executable Identity Name-based policy is ergonomic but weak. Jerboa needs an executable identity API so callers can flag `node`, `npm`, `npx`, `bun`, etc. by resolved identity. @@ -439,4 +452,3 @@ Jerboa should not know about those user-facing commands. Jerboa should only know - npm-specific logic in the Jerboa stdlib. The design should be honest about partial support. A caller must be able to require fail-closed behavior when degraded enforcement is not acceptable. - --- a/lib/std/os/limits/sandbox.ss +++ b/lib/std/os/limits/sandbox.ss @@ -96,12 +96,16 @@ launch-spec-stderr-cap-bytes launch-spec-timeout-ms launch-spec-child-pre-exec + launch-spec-child-status-proc + launch-spec-child-status-accept? launch-spec-search-path? supervise-run process-result? process-result-status process-result-signal - process-result-pid)) + process-result-pid + process-result-killed-reason + process-result-child-status)) ;; ---------- Policy record ---------- @@ -306,7 +310,10 @@ [needs-wrap? (or (pair? read) (pair? write) (pair? exec))] [fs-status (cond - [needs-wrap? 'installed] ;; handled by sandbox-exec wrap + [needs-wrap? + (if (file-exists? "/usr/bin/sandbox-exec") + 'installed ;; handled by sandbox-exec wrap + 'unavailable)] [else (let ([sbpl (build-sbpl read write exec net)]) (try @@ -538,14 +545,72 @@ (let ([cell (assq axis capabilities)]) (and cell (eq? (cdr cell) 'installed)))) - (def (missing-required-axes capabilities required) + (def (limit-status-satisfied? status actual?) + (if actual? + (memq status '(installed parent)) + (memq status '(attempt-installed parent)))) + + (def (limit-report-satisfied? limit-report actual?) + (and limit-report + (pair? limit-report) + (let lp ([xs limit-report]) + (cond + [(null? xs) #t] + [(limit-status-satisfied? (cdr (car xs)) actual?) + (lp (cdr xs))] + [else #f])))) + + (def (required-axis-satisfied? report limit-report axis actual?) + (cond + [(eq? axis 'limits) + (limit-report-satisfied? limit-report actual?)] + [else + (axis-installed? report axis)])) + + (def (missing-required-axes/report report limit-report required actual?) (let lp ([xs required] [out '()]) (cond [(null? xs) (reverse out)] - [(axis-installed? capabilities (car xs)) + [(required-axis-satisfied? report limit-report (car xs) actual?) (lp (cdr xs) out)] [else (lp (cdr xs) (cons (car xs) out))]))) + (def (missing-required-axes capabilities required) + (missing-required-axes/report capabilities #f required #f)) + + (def (replace-assq key val xs) + (let lp ([rest xs] [acc '()] [hit? #f]) + (cond + [(null? rest) + (reverse (if hit? acc (cons (cons key val) acc)))] + [(eq? (car (car rest)) key) + (lp (cdr rest) (cons (cons key val) acc) #t)] + [else + (lp (cdr rest) (cons (car rest) acc) hit?)]))) + + (def (merge-capability-report static dynamic) + (let lp ([xs dynamic] [out static]) + (cond + [(null? xs) out] + [else + (lp (cdr xs) + (replace-assq (car (car xs)) (cdr (car xs)) out))]))) + + (def (child-status-ok? st) + (let ([cell (and (pair? st) (assq 'ok st))]) + (and cell (cdr cell)))) + + (def (child-status-value st) + (let ([cell (and (pair? st) (assq 'value st))]) + (and cell (cdr cell)))) + + (def (status-field st key) + (let ([v (child-status-value st)]) + (and (pair? v) + (cond + [(assq key v) => cdr] + [else #f])))) + (def sandbox-launch ;; Two call shapes: ;; @@ -563,11 +628,11 @@ ;; before the sandbox slams shut. (case-lambda [(spec pol) - (sandbox-launch-spec spec pol #f)] + (sandbox-launch-spec spec pol #f '() #f)] [(spec pol limit-pol) (cond [(launch-spec? spec) - (sandbox-launch-spec spec pol limit-pol)] + (sandbox-launch-spec spec pol limit-pol '() #f)] [else (error 'sandbox-launch "expected launch-spec or keyword form")])] [(pol . args) @@ -584,8 +649,10 @@ [require-axes (launch-arg args 'require: '())] [fail-closed? (launch-arg args 'fail-closed?: #t)] [limit-pol (launch-arg args 'limit-policy: #f)] + [limit-plan (and limit-pol (limit-policy-plan limit-pol))] [capabilities (sandbox-capabilities)] - [missing (missing-required-axes capabilities require-axes)]) + [missing (missing-required-axes/report + capabilities limit-plan require-axes #f)]) (unless command (error 'sandbox-launch "missing 'command:")) (cond @@ -593,7 +660,7 @@ ;; Refuse to launch. Return a sandbox-result with launched?=#f ;; so callers can decide between raising and inspecting. (make-sandbox-result-rec - #f capabilities (sandbox-backend) #f #f missing)] + #f capabilities (sandbox-backend) limit-plan #f missing)] [else (let* ([spec (launch-spec 'command: command @@ -606,22 +673,37 @@ 'timeout-ms: (launch-arg args 'timeout-ms: #f) 'child-pre-exec: (launch-arg args 'child-pre-exec: #f) 'search-path?: (launch-arg args 'search-path?: #t))]) - (sandbox-launch-spec spec pol limit-pol))]))) + (sandbox-launch-spec + spec pol limit-pol require-axes fail-closed?))]))) - (def (sandbox-launch-spec spec pol limit-pol) + (def (sandbox-launch-spec spec pol limit-pol require-axes fail-closed?) (let* ([user-pre (launch-spec-child-pre-exec spec)] - [combined + [status-proc (lambda () - (when user-pre (user-pre)) - (sandbox-prepare-child! pol) - (when limit-pol - (limit-policy-install! limit-pol)))] + `((sandbox . ,(sandbox-prepare-child! pol)) + (limits . ,(and limit-pol + (limit-policy-install! limit-pol)))))] [orig-cmd (launch-spec-command spec)] [final-cmd (cond [(platform-macos?) (macos-wrap-command pol orig-cmd)] [else orig-cmd])] [search? (and (eq? final-cmd orig-cmd) (launch-spec-search-path? spec))] + [static-report (sandbox-capabilities)] + [status-accept? + (lambda (st) + (and (child-status-ok? st) + (let* ([dynamic-report (or (status-field st 'sandbox) + static-report)] + [limit-report (and limit-pol + (status-field st 'limits))] + [report (merge-capability-report + static-report dynamic-report)] + [missing (if fail-closed? + (missing-required-axes/report + report limit-report require-axes #t) + '())]) + (null? missing))))] [spec* (launch-spec 'command: final-cmd @@ -632,14 +714,36 @@ 'stdout-cap-bytes: (launch-spec-stdout-cap-bytes spec) 'stderr-cap-bytes: (launch-spec-stderr-cap-bytes spec) 'timeout-ms: (launch-spec-timeout-ms spec) - 'child-pre-exec: combined + 'child-pre-exec: user-pre + 'child-status-proc: status-proc + 'child-status-accept?: status-accept? 'search-path?: search?)] - [report (sandbox-capabilities)] [lim-report (and limit-pol (limit-policy-plan limit-pol))]) (let ([proc (supervise-run spec*)]) - (make-sandbox-result-rec - proc report (sandbox-backend) lim-report #t '())))) + (let* ([st (process-result-child-status proc)] + [dynamic-report (or (status-field st 'sandbox) + static-report)] + [actual-limit-report (if limit-pol + (or (status-field st 'limits) + lim-report) + #f)] + [report (merge-capability-report + static-report dynamic-report)] + [missing (if fail-closed? + (missing-required-axes/report + report actual-limit-report require-axes #t) + '())] + [pre-refused? + (eq? (process-result-killed-reason proc) + 'pre-exec-refused)] + [refused (cond + [(and pre-refused? (null? missing)) + '(pre-exec)] + [else missing])]) + (make-sandbox-result-rec + proc report (sandbox-backend) actual-limit-report + (not pre-refused?) refused))))) ;; ---------- Explain ---------- --- a/lib/std/os/supervise.ss +++ b/lib/std/os/supervise.ss @@ -45,6 +45,8 @@ launch-spec-stderr-cap-bytes launch-spec-timeout-ms launch-spec-child-pre-exec + launch-spec-child-status-proc + launch-spec-child-status-accept? launch-spec-search-path? process-result @@ -61,6 +63,7 @@ process-result-stdout process-result-stderr process-result-killed-reason + process-result-child-status process-result->alist supervise-run @@ -72,7 +75,7 @@ (only (std os posix) posix-fork posix-execve posix-exit posix-waitpid posix-setpgid posix-getpid posix-getppid - posix-pipe posix-close posix-dup2 posix-read + posix-pipe posix-close posix-dup2 posix-read posix-write posix-kill posix-fcntl-setfl posix-fcntl-getfl posix-chdir O_NONBLOCK WNOHANG WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG @@ -87,6 +90,8 @@ stdout-cap-bytes stderr-cap-bytes timeout-ms child-pre-exec + child-status-proc + child-status-accept? search-path?)) (def launch-spec? launch-spec-rec?) @@ -99,6 +104,8 @@ (def launch-spec-stderr-cap-bytes launch-spec-rec-stderr-cap-bytes) (def launch-spec-timeout-ms launch-spec-rec-timeout-ms) (def launch-spec-child-pre-exec launch-spec-rec-child-pre-exec) + (def launch-spec-child-status-proc launch-spec-rec-child-status-proc) + (def launch-spec-child-status-accept? launch-spec-rec-child-status-accept?) (def launch-spec-search-path? launch-spec-rec-search-path?) (def (launch-spec . opts) @@ -107,7 +114,8 @@ (let ([cmd #f] [env #f] [cwd #f] [cap-out? #f] [cap-err? #f] [cap-out-bytes #f] [cap-err-bytes #f] - [timeout #f] [pre #f] [path? #t]) + [timeout #f] [pre #f] [status-proc #f] [status-accept? #f] + [path? #t]) (let lp ([xs opts]) (cond [(null? xs) #t] @@ -124,6 +132,8 @@ [(stderr-cap-bytes:) (set! cap-err-bytes (cadr xs))] [(timeout-ms:) (set! timeout (cadr xs))] [(child-pre-exec:) (set! pre (cadr xs))] + [(child-status-proc:) (set! status-proc (cadr xs))] + [(child-status-accept?:) (set! status-accept? (cadr xs))] [(search-path?:) (set! path? (and (cadr xs) #t))] [else (error 'launch-spec "unknown option" (car xs))]) (lp (cddr xs))])) @@ -132,11 +142,11 @@ (make-launch-spec-rec cmd env cwd cap-out? cap-err? cap-out-bytes cap-err-bytes - timeout pre path?))) + timeout pre status-proc status-accept? path?))) (defstruct process-result-rec (status signal pid pgid command env elapsed-ms - stdout-bytes stderr-bytes stdout stderr killed-reason)) + stdout-bytes stderr-bytes stdout stderr killed-reason child-status)) (def process-result? process-result-rec?) (def process-result-status process-result-rec-status) @@ -151,6 +161,7 @@ (def process-result-stdout process-result-rec-stdout) (def process-result-stderr process-result-rec-stderr) (def process-result-killed-reason process-result-rec-killed-reason) + (def process-result-child-status process-result-rec-child-status) (def process-result make-process-result-rec) (def (process-result->alist r) @@ -162,7 +173,8 @@ (elapsed-ms . ,(process-result-elapsed-ms r)) (stdout-bytes . ,(process-result-stdout-bytes r)) (stderr-bytes . ,(process-result-stderr-bytes r)) - (killed-reason . ,(process-result-killed-reason r)))) + (killed-reason . ,(process-result-killed-reason r)) + (child-status . ,(process-result-child-status r)))) ;; ---------- Capabilities ---------- @@ -311,6 +323,122 @@ (let ([fl (posix-fcntl-getfl fd)]) (posix-fcntl-setfl fd (bitwise-ior fl O_NONBLOCK)))) + ;; ---------- Child pre-exec status handshake ---------- + + (def (condition->safe-string e) + (cond + [(message-condition? e) (condition-message e)] + [else + (let ([p (open-output-string)]) + (write e p) + (get-output-string p))])) + + (def (status-ok? st) + (let ([cell (and (pair? st) (assq 'ok st))]) + (and cell (cdr cell)))) + + (def (status-value st) + (let ([cell (and (pair? st) (assq 'value st))]) + (and cell (cdr cell)))) + + (def (write-all-small fd bv) + ;; Status/control messages stay below PIPE_BUF. A single blocking + ;; write is atomic on POSIX pipes and is enough for this protocol. + (posix-write fd bv (bytevector-length bv))) + + (def (write-status-record! fd st) + (let ([p (open-output-string)]) + (write st p) + (newline p) + (let ([bv (string->utf8 (get-output-string p))]) + (write-all-small fd bv)))) + + (def (decode-status-record acc) + (let* ([bv (byte-accum->bytevector acc)] + [s (utf8->string bv)]) + (cond + [(= (string-length s) 0) + `((ok . #f) + (where . child-status) + (error . "empty child status"))] + [else + (try + (read (open-input-string s)) + (catch (e) + `((ok . #f) + (where . child-status) + (error . ,(condition->safe-string e)))))]))) + + (def (control-byte go?) + (let ([bv (make-bytevector 1)]) + (bytevector-u8-set! bv 0 (if go? 71 78)) ;; G / N + bv)) + + (def (write-control! fd go?) + (try (write-all-small fd (control-byte go?)) + (catch (e) #f))) + + (def (status-accepted? accept? st) + (cond + [accept? + (try (and (accept? st) #t) + (catch (e) #f))] + [else (status-ok? st)])) + + (def (run-child-status-handshake pre status-proc status-w control-r) + (let ([st + (try + (begin + (when pre (pre)) + `((ok . #t) + (value . ,(if status-proc (status-proc) '())))) + (catch (e) + `((ok . #f) + (where . pre-exec) + (error . ,(condition->safe-string e)))))]) + (try (write-status-record! status-w st) (catch (e) #f)) + (try (posix-close status-w) (catch (e) #f)) + (let ([buf (make-bytevector 1)]) + (let ([n (try (posix-read control-r buf 1) + (catch (e) 0))]) + (try (posix-close control-r) (catch (e) #f)) + (unless (and (= n 1) + (= (bytevector-u8-ref buf 0) 71) + (status-ok? st)) + (posix-exit 126)))))) + + (def (parent-status-handshake status-r control-w accept? timeout-ms start pid pgid) + ;; Returns (values child-status accepted? killed-reason). The child + ;; cannot exec until this writes G to CONTROL-W. + (let ([acc (new-byte-accum)] + [timed-out? (list #f)]) + (let loop () + (let ([state (read-available status-r #f acc)]) + (cond + [(eq? state 'eof) + (try (posix-close status-r) (catch (e) #f)) + (let* ([st (decode-status-record acc)] + [ok? (and (not (car timed-out?)) + (status-accepted? accept? st))] + [reason (cond + [(car timed-out?) 'timeout] + [ok? #f] + [else 'pre-exec-refused])]) + (write-control! control-w ok?) + (try (posix-close control-w) (catch (e) #f)) + (values st ok? reason))] + [else + (when (and timeout-ms + (not (car timed-out?)) + (> (- (now-ms) start) timeout-ms)) + (set-car! timed-out? #t) + (write-control! control-w #f) + (kill-pgid! pgid SIGTERM) + (sleep-ms 100) + (kill-pgid! pgid SIGKILL)) + (sleep-ms 5) + (loop)]))))) + ;; ---------- Kill ---------- (def (kill-pgid! pgid sig) @@ -349,10 +477,14 @@ [cap-err-bytes (launch-spec-stderr-cap-bytes spec)] [timeout-ms (launch-spec-timeout-ms spec)] [pre (launch-spec-child-pre-exec spec)] + [status-proc (launch-spec-child-status-proc spec)] + [status-accept? (launch-spec-child-status-accept? spec)] [cwd (launch-spec-cwd spec)] ;; Pipes for capture (parent reads, child writes) [out-pipe (and cap-out? (call-with-values posix-pipe list))] [err-pipe (and cap-err? (call-with-values posix-pipe list))] + [status-pipe (and status-proc (call-with-values posix-pipe list))] + [control-pipe (and status-proc (call-with-values posix-pipe list))] [start (now-ms)] [pid (posix-fork)]) (cond @@ -371,10 +503,21 @@ (posix-close (car err-pipe)) (posix-dup2 (cadr err-pipe) 2) (posix-close (cadr err-pipe))) + (when status-pipe + (posix-close (car status-pipe))) ;; close parent read end + (when control-pipe + (posix-close (cadr control-pipe))) ;; close parent write end ;; cwd (when cwd (try (posix-chdir cwd) (catch (e) #f))) ;; Hook for limit-policy-install! and other in-child setup - (when pre (try (pre) (catch (e) #f))) + (cond + [status-proc + (run-child-status-handshake + pre status-proc + (cadr status-pipe) + (car control-pipe))] + [else + (when pre (try (pre) (catch (e) #f)))]) ;; Build argv + envp (let-values ([(argv _argv-cstrs) (alloc-string-array cmd)]) (cond @@ -397,11 +540,25 @@ ;; Close child-side pipe ends (when out-pipe (posix-close (cadr out-pipe))) (when err-pipe (posix-close (cadr err-pipe))) + (when status-pipe (posix-close (cadr status-pipe))) + (when control-pipe (posix-close (car control-pipe))) (when out-pipe (set-nonblock! (car out-pipe))) (when err-pipe (set-nonblock! (car err-pipe))) + (when status-pipe (set-nonblock! (car status-pipe))) (let ([out-acc (and out-pipe (new-byte-accum))] [err-acc (and err-pipe (new-byte-accum))] + [child-status (list #f)] [killed-reason (list #f)]) + (when status-pipe + (let-values ([(st accepted? reason) + (parent-status-handshake + (car status-pipe) + (cadr control-pipe) + status-accept? + timeout-ms start pid pgid)]) + (set-car! child-status st) + (when reason + (set-car! killed-reason reason)))) (let loop ([out-state (if out-pipe 'open 'closed)] [err-state (if err-pipe 'open 'closed)]) ;; Try to reap (non-blocking until we kill; blocking after). @@ -421,7 +578,8 @@ (finalize-result resolved cmd env pid pgid start status out-acc err-acc out-pipe err-pipe - (car killed-reason))] + (car killed-reason) + (car child-status))] [else ;; Drain available pipe data (let ([ns (if (and out-pipe (eq? out-state 'open)) @@ -458,7 +616,8 @@ (loop ns es))])))))]))) (def (finalize-result resolved cmd env pid pgid start status - out-acc err-acc out-pipe err-pipe killed-reason) + out-acc err-acc out-pipe err-pipe + killed-reason child-status) (when out-pipe (try (posix-close (car out-pipe)) (catch (e) #f))) (when err-pipe (try (posix-close (car err-pipe)) (catch (e) #f))) (let* ([elapsed (- (now-ms) start)] @@ -473,6 +632,7 @@ (bytevector-length ebytes) obytes ebytes - killed-reason))) + killed-reason + child-status))) ) ;; end library --- a/tests/test-limits-primitives.ss +++ b/tests/test-limits-primitives.ss @@ -40,6 +40,14 @@ [(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 (child-status-value st) + (alist-ref/default st 'value #f)) + (define-syntax test (syntax-rules () [(_ name expr expected) @@ -125,6 +133,40 @@ (process-result-status r) (lambda (st) (and (number? st) (= st 137))))) +;; Child setup status is parent-visible before exec. The accept hook can +;; refuse the launch, in which case the target program never runs. +(let ([r (supervise-run + (launch-spec + 'command: '("/bin/echo" "status-ok") + 'capture-stdout?: #t + 'child-status-proc: (lambda () '((ready . installed))) + 'child-status-accept?: + (lambda (st) + (equal? (child-status-value st) + '((ready . installed))))))]) + (test "supervise child status accepted" + (process-result-status r) + 0) + (test "supervise child status value reported" + (child-status-value (process-result-child-status r)) + '((ready . installed)))) + +(let ([r (supervise-run + (launch-spec + 'command: '("/bin/sh" "-c" "printf should-not-run") + 'capture-stdout?: #t + 'child-status-proc: (lambda () '((ready . failed))) + 'child-status-accept?: (lambda (st) #f)))]) + (test "supervise child status refusal exits 126" + (process-result-status r) + 126) + (test "supervise child status refusal reason" + (process-result-killed-reason r) + 'pre-exec-refused) + (test "supervise child status refusal suppresses exec" + (process-result-stdout-bytes r) + 0)) + ;; ===== exec-id ===== (printf "[exec-id]~%") @@ -248,6 +290,60 @@ (sandbox-result-status r) (lambda (s) (and (number? s) (= s 0))))) +(let ([lp (limit-policy)]) + (limit-policy-set! lp 'nofile 256) + (let ([r (sandbox-launch + (sandbox-policy) + 'command: '("/bin/echo" "limits-ok") + 'require: '(limits) + 'limit-policy: lp + 'fail-closed?: #t)]) + (test "sandbox require limits launches when installed" + (sandbox-result-launched? r) + #t) + (test "sandbox actual limit report only includes requested nofile" + (map car (sandbox-result-limit-report r)) + '(nofile)) + (test "sandbox actual nofile limit installed" + (alist-ref/default (sandbox-result-limit-report r) 'nofile #f) + 'installed) + (test-pred "sandbox dynamic report has backend and fs status" + (sandbox-result-report r) + (lambda (rep) + (and (assq 'backend rep) + (assq 'fs rep)))))) + +(let ([r (sandbox-launch + (sandbox-policy) + 'command: '("/bin/echo" "no-limits") + 'require: '(limits) + 'fail-closed?: #t)]) + (test "sandbox require limits refuses without limit policy" + (sandbox-result-launched? r) + #f) + (test "sandbox require limits refused axes" + (sandbox-result-refused-axes r) + '(limits))) + +(let ([r (sandbox-launch + (sandbox-policy) + 'command: '("/bin/sh" "-c" "printf should-not-run") + 'capture-stdout?: #t + 'child-pre-exec: (lambda () (error 'test "pre failed")) + 'fail-closed?: #f)]) + (test "sandbox pre-exec failure refuses target launch" + (sandbox-result-launched? r) + #f) + (test "sandbox pre-exec failure status" + (sandbox-result-status r) + 126) + (test "sandbox pre-exec failure refused axis" + (sandbox-result-refused-axes r) + '(pre-exec)) + (test "sandbox pre-exec failure suppresses exec output" + (process-result-stdout-bytes (sandbox-result-process r)) + 0)) + ;; A required axis that isn't installed must refuse to launch the child. (let ([r (guard (exn [#t (cons 'error (if (message-condition? exn)