Harden sandbox/limits/audit primitives
ober
b0bc4b571056c8030a0af1df6f2fd34d608872ab
--- a/docs/limits-followup.md +++ b/docs/limits-followup.md @@ -47,6 +47,23 @@ states: Static "this OS should support X" reporting is not enough. Callers need to know what actually happened for the specific child launch. +## Fail-Closed: Canonical Definition + +Every section below uses "fail closed" with the same meaning. Define it once +here so we do not redefine it per axis: + +> A launch fails closed when any axis listed in the caller's `require:` set +> is not fully installed before the child exec()s the target. Partial install +> is failure. Degraded is failure. Unavailable is failure. A warning is not +> 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. + ## 1. Unified Sandbox API File: `lib/std/os/limits/sandbox.ss` @@ -93,6 +110,15 @@ Required next work: 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: - readable path allowed @@ -202,6 +228,13 @@ Remaining work: but should be documented or replaced with streaming hashing. - Higher-level consumers need to compare identities, not just render them. Add helpers such as `exec-id-same-file?` or `exec-id-matches?`. +- **TOCTOU disclaimer required.** Between `exec-id-resolve` and the child's + `exec()` call, the resolved file can be replaced (e.g., symlink swap, + package update, mount change). The hash and dev/inode capture are + *advisory evidence of identity at resolve time* — not an enforcement + primitive. Document this in the module header; callers that need an + enforcement guarantee should open the file before exec and `fexecve` it, + not re-resolve by path. ## 5. Filesystem Access Tracing --- a/lib/std/net/allow-proxy.ss +++ b/lib/std/net/allow-proxy.ss @@ -50,7 +50,14 @@ allow-proxy-logger allow-proxy-stats - allow-proxy-host-allowed?) + allow-proxy-host-allowed? + allow-proxy-host-denial-reason + + make-allow-proxy-policy + allow-proxy-event + host-is-ipv4-literal? + host-is-ipv6-literal? + host-is-localnet?) (import (chezscheme) (only (jerboa core) def defstruct try catch finally) @@ -64,7 +71,15 @@ (host port allowlist logger server-mutex server thread running? - stats)) + stats + ;; Security policy fields. Defaults are deny-by-default for the + ;; classes of targets a sandbox-aware proxy must never trust: + ;; allow-ip-literals? — pass raw IPv4/IPv6 literal hosts straight + ;; through. Default #f: deny. + ;; allow-localnet? — pass loopback/link-local/RFC1918/multicast + ;; targets. Default #f: deny. + allow-ip-literals? + allow-localnet?)) ;; stats: alist with counters (def allow-proxy? allow-proxy-rec?) @@ -80,7 +95,8 @@ [else (allow-proxy-rec-port p)]))) (def (allow-proxy . opts) - (let ([host "127.0.0.1"] [port 0] [allow '()] [logger #f]) + (let ([host "127.0.0.1"] [port 0] [allow '()] [logger #f] + [allow-ipl? #f] [allow-localnet? #f]) (let lp ([xs opts]) (cond [(null? xs) #t] @@ -88,10 +104,12 @@ (error 'allow-proxy "odd number of options at" (car xs))] [else (case (car xs) - [(host:) (set! host (cadr xs))] - [(port:) (set! port (cadr xs))] - [(allow:) (set! allow (cadr xs))] - [(logger:) (set! logger (cadr xs))] + [(host:) (set! host (cadr xs))] + [(port:) (set! port (cadr xs))] + [(allow:) (set! allow (cadr xs))] + [(logger:) (set! logger (cadr xs))] + [(allow-ip-literals?:)(set! allow-ipl? (and (cadr xs) #t))] + [(allow-localnet?:) (set! allow-localnet? (and (cadr xs) #t))] [else (error 'allow-proxy "unknown option" (car xs))]) (lp (cddr xs))])) (make-allow-proxy-rec @@ -101,19 +119,182 @@ (list (cons 'accepted 0) (cons 'allowed 0) (cons 'denied 0) - (cons 'errors 0))))) + (cons 'errors 0)) + allow-ipl? allow-localnet?))) + + ;; Convenience: build a policy stub usable purely for offline checks + ;; against allow-proxy-host-allowed?. No server is started; tests and + ;; callers that only want allowlist semantics use this. + (def (make-allow-proxy-policy patterns . opts) + (apply allow-proxy + 'host: "127.0.0.1" + 'port: 0 + 'allow: patterns + opts)) + + ;; ---------- IP-literal and localnet detection ---------- + + (def (host-is-ipv4-literal? host) + ;; True iff HOST is a valid IPv4 dotted-quad literal. Does not + ;; resolve DNS; matches the textual form only. + (and (string? host) + (parse-ipv4 host) + #t)) + + (def (parse-ipv4 host) + ;; Returns a 4-list of octets or #f. No leading zeros normalisation; + ;; "01.02.03.04" is accepted for safety (octal-looking forms still + ;; resolve to the same address class via inet_aton, so we should + ;; deny them too). + (let* ([n (string-length host)]) + (let lp ([i 0] [oct '()] [acc -1]) + (cond + [(>= i n) + (and (>= acc 0) (<= acc 255) + (let ([all (reverse (cons acc oct))]) + (and (= 4 (length all)) + all)))] + [(char=? (string-ref host i) #\.) + (and (>= acc 0) (<= acc 255) + (lp (+ i 1) (cons acc oct) -1))] + [else + (let ([c (string-ref host i)]) + (and (char<=? #\0 c #\9) + (let ([d (- (char->integer c) (char->integer #\0))]) + (lp (+ i 1) oct + (if (< acc 0) d (+ (* acc 10) d))))))])))) + + (def (host-is-ipv6-literal? host) + ;; Conservative match: contains a colon and either starts with '[' + ;; (bracketed form) or contains at least one ':' segment plus only + ;; hex/colon/dot characters. This rejects "example.com" cleanly and + ;; accepts "::1", "fe80::1", "2001:db8::1", "[::1]". + (and (string? host) + (> (string-length host) 1) + (let* ([s (if (and (char=? (string-ref host 0) #\[) + (let ([n (string-length host)]) + (char=? (string-ref host (- n 1)) #\]))) + (substring host 1 (- (string-length host) 1)) + host)]) + (and (let lp ([i 0] [colon? #f] [non-hex? #f]) + (cond + [(>= i (string-length s)) (and colon? (not non-hex?))] + [else + (let ([c (string-ref s i)]) + (cond + [(char=? c #\:) (lp (+ i 1) #t non-hex?)] + [(or (char<=? #\0 c #\9) + (char<=? #\a c #\f) + (char<=? #\A c #\F) + (char=? c #\.)) ;; IPv4-mapped tail + (lp (+ i 1) colon? non-hex?)] + [else (lp (+ i 1) colon? #t)]))])))))) + + (def (host-is-localnet? host) + ;; Returns a symbol describing the localnet category, or #f. + ;; Categories: 'loopback4 'loopback6 'link-local4 'link-local6 + ;; 'rfc1918-10 'rfc1918-172 'rfc1918-192 'cgnat 'multicast4 'multicast6 + ;; 'unspecified + (cond + [(host-is-ipv4-literal? host) + (let* ([oct (parse-ipv4 host)] + [a (car oct)] [b (cadr oct)]) + (cond + [(= a 127) 'loopback4] + [(= a 10) 'rfc1918-10] + [(and (= a 172) (>= b 16) (<= b 31)) 'rfc1918-172] + [(and (= a 192) (= b 168)) 'rfc1918-192] + [(and (= a 169) (= b 254)) 'link-local4] + [(and (= a 100) (>= b 64) (<= b 127)) 'cgnat] + [(and (>= a 224) (<= a 239)) 'multicast4] + [(= a 0) 'unspecified] + [else #f]))] + [(host-is-ipv6-literal? host) + (let* ([s host] + [s (if (and (> (string-length s) 1) + (char=? (string-ref s 0) #\[)) + (substring s 1 (- (string-length s) 1)) + s)] + [lower (string-downcase s)]) + (cond + [(or (string=? lower "::1") (string=? lower "0:0:0:0:0:0:0:1")) + 'loopback6] + [(or (string=? lower "::") (string=? lower "0:0:0:0:0:0:0:0")) + 'unspecified] + [(or (and (>= (string-length lower) 4) + (string=? (substring lower 0 4) "fe80")) ; link-local + (and (>= (string-length lower) 3) + (string=? (substring lower 0 3) "ff0"))) ; multicast + (cond + [(and (>= (string-length lower) 4) + (string=? (substring lower 0 4) "fe80")) 'link-local6] + [else 'multicast6])] + [(or (and (>= (string-length lower) 2) + (string=? (substring lower 0 2) "fc")) + (and (>= (string-length lower) 2) + (string=? (substring lower 0 2) "fd"))) + 'rfc1918-6] ;; fc00::/7 unique-local + [else #f]))] + [(string=? host "localhost") 'loopback4] + [else #f])) ;; ---------- Allowlist matching ---------- (def (allow-proxy-host-allowed? p host port) - ;; HOST is a string, PORT is an integer. Walk the allowlist and - ;; return the first pattern that matches. - (let ([target (string-append host ":" (number->string port))]) - (let lp ([xs (allow-proxy-rec-allowlist p)]) + ;; HOST is a string, PORT is an integer. Two stages: + ;; 1. Reject IP literals and localnet targets unless the policy + ;; explicitly opts in. This is a hard gate that overrides any + ;; wildcard ("*:443") in the allowlist. + ;; 2. Match against the host:port glob allowlist. + ;; Returns the matching pattern string on allow, #f on deny. + (cond + [(allow-proxy-host-denial-reason p host port) #f] + [else + (let ([target (string-append host ":" (number->string port))]) + (let lp ([xs (allow-proxy-rec-allowlist p)]) + (cond + [(null? xs) #f] + [(target-matches? target (car xs)) (car xs)] + [else (lp (cdr xs))])))])) + + (def (allow-proxy-host-denial-reason p host port) + ;; Returns a symbol describing why HOST is unconditionally denied, or + ;; #f if it passes the gate. Callers (proxy and audit log) use this + ;; to emit a structured deny reason instead of a generic "no match". + (let ([ipl? (or (host-is-ipv4-literal? host) + (host-is-ipv6-literal? host))] + [ln (host-is-localnet? host)]) + (cond + [(and ipl? (not (allow-proxy-rec-allow-ip-literals? p))) + 'ip-literal] + [(and ln (not (allow-proxy-rec-allow-localnet? p))) + (or ln 'localnet)] + [else #f]))) + + ;; ---------- Structured event constructor ---------- + + (def (allow-proxy-event kind . opts) + ;; Returns an alist suitable for the logger callback and audit + ;; integration. Kinds: 'allow 'deny 'connect-failed 'dns-failed + ;; 'malformed. Recognised options: host: port: reason: pattern: + ;; bytes-in: bytes-out: error:. + (let ([acc (list (cons 'kind kind))]) + (let lp ([xs opts]) (cond - [(null? xs) #f] - [(target-matches? target (car xs)) (car xs)] - [else (lp (cdr xs))])))) + [(null? xs) (reverse acc)] + [(null? (cdr xs)) (reverse acc)] + [else + (let ([k (car xs)] [v (cadr xs)]) + (case k + [(host:) (set! acc (cons (cons 'host v) acc))] + [(port:) (set! acc (cons (cons 'port v) acc))] + [(reason:) (set! acc (cons (cons 'reason v) acc))] + [(pattern:) (set! acc (cons (cons 'pattern v) acc))] + [(bytes-in:) (set! acc (cons (cons 'bytes-in v) acc))] + [(bytes-out:) (set! acc (cons (cons 'bytes-out v) acc))] + [(error:) (set! acc (cons (cons 'error v) acc))] + [else #f])) + (lp (cddr xs))])))) (def (target-matches? target pat) ;; Split TARGET and PAT on ':' and match host part and port part @@ -258,8 +439,11 @@ (bump! p 'denied) (close-pair in out)] [(not (allow-proxy-host-allowed? p host port)) - (write-status out 403 "host not in allowlist") - (log! p `(deny (host . ,host) (port . ,port))) + (let ([reason (or (allow-proxy-host-denial-reason p host port) + 'not-in-allowlist)]) + (write-status out 403 "host not in allowlist") + (log! p (allow-proxy-event 'deny + 'host: host 'port: port 'reason: reason))) (bump! p 'denied) (close-pair in out)] [else --- a/lib/std/os/exec-id.ss +++ b/lib/std/os/exec-id.ss @@ -40,7 +40,8 @@ exec-id-resolve exec-id-realpath-of exec-id-search-path - exec-id-current-path) + exec-id-current-path + exec-id-same-file?) (import (chezscheme) (only (jerboa core) def defstruct try catch finally) @@ -193,8 +194,7 @@ (def (exec-id-resolve* name path-string hash?) (let ([found (exec-id-search-path name path-string)]) (cond - [(not found) - (make-exec-id name #f #f #f #f #f #f #f)] + [(not found) #f] [else (let* ([rp (or (realpath* found) found)]) (let-values ([(d i) (stat-pair rp)]) @@ -203,4 +203,23 @@ (not (string=? found rp)) #t)))]))) + ;; ---------- exec-id-same-file? ---------- + ;; Two exec-ids refer to the same on-disk file iff their (dev, ino) + ;; pairs match. Realpath equality is a softer fallback when stat + ;; data is unavailable (synthetic exec-ids, future filesystems with + ;; no inode concept, etc.). This is advisory only — the underlying + ;; file can be replaced between resolution and use; see the TOCTOU + ;; note in docs/limits-followup.md. + (def (exec-id-same-file? a b) + (and (exec-id? a) (exec-id? b) + (exec-id-exists? a) (exec-id-exists? b) + (cond + [(and (exec-id-dev a) (exec-id-ino a) + (exec-id-dev b) (exec-id-ino b)) + (and (= (exec-id-dev a) (exec-id-dev b)) + (= (exec-id-ino a) (exec-id-ino b)))] + [(and (exec-id-realpath a) (exec-id-realpath b)) + (string=? (exec-id-realpath a) (exec-id-realpath b))] + [else #f]))) + ) ;; end library --- a/lib/std/os/limits.ss +++ b/lib/std/os/limits.ss @@ -45,6 +45,7 @@ limit-policy-get limit-policy-pairs limit-policy-install! + limit-policy-plan limit-policy-explain limits-capabilities) @@ -179,6 +180,41 @@ [(out-bytes) 'parent] [else 'unavailable])) + (def (limit-policy-plan pol) + ;; Returns a per-launch plan describing the *predicted* status of + ;; each requested limit, without actually applying any setrlimit. + ;; Status values: + ;; 'attempt-installed — will call setrlimit on this kind + ;; 'attempt-degraded — setrlimit accepted but enforcement is partial + ;; (e.g. RLIMIT_NPROC is user-wide on Linux) + ;; 'parent — parent-side bookkeeping (time-ms, out-bytes) + ;; 'unavailable — no backend on this OS for this kind + ;; + ;; This is the *planned* shape; the actual installed result lives + ;; behind a fork and is only directly observable if the caller wires + ;; up a child->parent status pipe. Until that exists, this plan is + ;; the most honest report we can produce from the parent side. + (map (lambda (kv) + (let ([kind (car kv)] [val (cdr kv)]) + (cons kind (limit-plan-status kind val)))) + (limit-policy-entries pol))) + + (def (limit-plan-status kind val) + (case kind + [(mem) + (cond [(platform-macos?) 'unavailable] + [else 'attempt-installed])] + [(cpu-sec) 'attempt-installed] + [(nofile) 'attempt-installed] + [(fsize) 'attempt-installed] + [(core) 'attempt-installed] + [(pids) + (cond [(platform-linux?) 'attempt-degraded] + [else 'attempt-installed])] + [(time-ms) 'parent] + [(out-bytes) 'parent] + [else 'unavailable])) + (def (set-rlim name code val) (try (begin --- a/lib/std/os/limits/sandbox.ss +++ b/lib/std/os/limits/sandbox.ss @@ -68,7 +68,11 @@ sandbox-result-process sandbox-result-report sandbox-result-backend - sandbox-result-limit-report) + sandbox-result-limit-report + sandbox-result-launched? + sandbox-result-status + sandbox-result-signal + sandbox-result-refused-axes) (import (chezscheme) (only (jerboa core) def defstruct try catch finally) @@ -78,6 +82,7 @@ limit-policy? limit-policy limit-policy-install! + limit-policy-plan limits-capabilities) (only (std os supervise) launch-spec @@ -95,16 +100,15 @@ supervise-run process-result? process-result-status + process-result-signal process-result-pid)) ;; ---------- Policy record ---------- (defstruct sandbox-policy-rec (entries)) - (def (sandbox-policy) - (make-sandbox-policy-rec - ;; Neutral default: deny everything denyable, allow nothing extra. - ;; The caller opts in to read/write/exec/network. + (def *sandbox-policy-defaults* + ;; Neutral default: deny everything denyable, allow nothing extra. '((read-paths . ()) (write-paths . ()) (exec-paths . ()) @@ -112,7 +116,37 @@ (net-allow . ()) (syscalls . safe) (ptrace? . #f) - (no-new-privs? . #t)))) + (no-new-privs? . #t))) + + (def *sandbox-policy-keys* + '(read-paths: write-paths: exec-paths: + net: net-allow: syscalls: ptrace?: no-new-privs?:)) + + (def (sandbox-policy . args) + ;; Accepts keyword args (e.g. `'net: 'deny`) to override individual + ;; axes from the neutral default. + (let ([pol (make-sandbox-policy-rec + (map (lambda (kv) (cons (car kv) (cdr kv))) + *sandbox-policy-defaults*))]) + (let lp ([xs args]) + (cond + [(null? xs) pol] + [(null? (cdr xs)) + (error 'sandbox-policy "dangling keyword" (car xs))] + [(memq (car xs) *sandbox-policy-keys*) + (let ([k (sandbox-policy-keyword->field (car xs))]) + (sandbox-policy-set! pol k (cadr xs)) + (lp (cddr xs)))] + [else + (error 'sandbox-policy "unknown keyword" (car xs))])))) + + (def (sandbox-policy-keyword->field kw) + (let ([s (symbol->string kw)]) + (string->symbol + (if (and (> (string-length s) 0) + (char=? (string-ref s (- (string-length s) 1)) #\:)) + (substring s 0 (- (string-length s) 1)) + s)))) ;; Re-export under the spec name `make-sandbox-policy` so callers can ;; use either the factory `(sandbox-policy)` (no args, neutral) or the @@ -451,7 +485,8 @@ ;; ---------- Result record ---------- - (defstruct sandbox-result-rec (process report backend limit-report)) + (defstruct sandbox-result-rec + (process report backend limit-report launched? refused-axes)) (def make-sandbox-result make-sandbox-result-rec) (def sandbox-result? sandbox-result-rec?) @@ -459,72 +494,152 @@ (def sandbox-result-report sandbox-result-rec-report) (def sandbox-result-backend sandbox-result-rec-backend) (def sandbox-result-limit-report sandbox-result-rec-limit-report) + (def sandbox-result-launched? sandbox-result-rec-launched?) + (def sandbox-result-refused-axes sandbox-result-rec-refused-axes) + + (def (sandbox-result-status r) + ;; Returns the wait-status of the child process, or #f when the + ;; sandbox refused to launch. + (let ([p (sandbox-result-process r)]) + (and p (process-result-status p)))) + + (def (sandbox-result-signal r) + (let ([p (sandbox-result-process r)]) + (and p (process-result-signal p)))) ;; ---------- Launch ---------- + (def *sandbox-launch-keys* + '(command: env: cwd: capture-stdout?: capture-stderr?: + stdout-cap-bytes: stderr-cap-bytes: timeout-ms: + child-pre-exec: search-path?: + require: fail-closed?: limit-policy:)) + + (def (collect-launch-args xs) + (let lp ([rest xs] [acc '()]) + (cond + [(null? rest) (reverse acc)] + [(null? (cdr rest)) + (error 'sandbox-launch "dangling keyword" (car rest))] + [(memq (car rest) *sandbox-launch-keys*) + (lp (cddr rest) (cons (cons (car rest) (cadr rest)) acc))] + [else + (error 'sandbox-launch "unknown keyword" (car rest))]))) + + (def (launch-arg args key default) + (cond + [(assq key args) => cdr] + [else default])) + + (def (axis-installed? capabilities axis) + ;; AXIS is a symbol like 'fs, 'exec, 'net, 'syscalls, 'ptrace. + ;; A required axis is considered satisfied only when it is + ;; explicitly reported as 'installed by the current backend. + (let ([cell (assq axis capabilities)]) + (and cell (eq? (cdr cell) 'installed)))) + + (def (missing-required-axes capabilities required) + (let lp ([xs required] [out '()]) + (cond + [(null? xs) (reverse out)] + [(axis-installed? capabilities (car xs)) + (lp (cdr xs) out)] + [else (lp (cdr xs) (cons (car xs) out))]))) + (def sandbox-launch - ;; Public entry: combine a launch-spec, sandbox-policy, and an - ;; optional limit-policy. The child runs sandbox-prepare-child! - ;; followed by limit-policy-install! in the pre-exec slot. + ;; Two call shapes: ;; - ;; The launch-spec's `child-pre-exec` (if any) runs FIRST, so the - ;; caller can do their own setup (chdir, drop privileges) before - ;; the sandbox slams shut. + ;; 1. (sandbox-launch spec pol [limit-pol]) + ;; Backwards-compatible launch-spec form. ;; - ;; We can't mutate the launch-spec record (no setters exported), - ;; so we rebuild it via the keyword builder with the combined - ;; pre-exec installed. + ;; 2. (sandbox-launch pol 'command: CMD 'require: AXES + ;; 'fail-closed?: BOOL ...) + ;; Keyword form: builds the launch-spec internally and enforces + ;; per-axis requirements before forking the child. + ;; + ;; The child runs sandbox-prepare-child! followed by + ;; limit-policy-install! in the pre-exec slot. The caller's own + ;; `child-pre-exec` (if any) runs FIRST so the caller can do setup + ;; before the sandbox slams shut. (case-lambda [(spec pol) - (sandbox-launch spec pol #f)] + (sandbox-launch-spec spec pol #f)] [(spec pol limit-pol) - (let* ([user-pre (launch-spec-child-pre-exec spec)] - [combined - (lambda () - (when user-pre (user-pre)) - ;; Effects only — return values can't cross the fork. - (sandbox-prepare-child! pol) - (when limit-pol - (limit-policy-install! limit-pol)))] - ;; On macOS with path policy, wrap command in sandbox-exec - ;; so the SBPL is applied before the target binary loads. - [orig-cmd (launch-spec-command spec)] - [final-cmd (cond - [(platform-macos?) (macos-wrap-command pol orig-cmd)] - [else orig-cmd])] - ;; If we wrapped, force absolute-path mode (don't PATH-search - ;; for /usr/bin/sandbox-exec — it's already absolute). - [search? (and (eq? final-cmd orig-cmd) - (launch-spec-search-path? spec))] - [spec* - (launch-spec - 'command: final-cmd - 'env: (launch-spec-env spec) - 'cwd: (launch-spec-cwd spec) - 'capture-stdout?: (launch-spec-capture-stdout? spec) - 'capture-stderr?: (launch-spec-capture-stderr? spec) - '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 - 'search-path?: search?)] - ;; Static reports — describe what the policy will TRY to - ;; do, derived from sandbox-capabilities on the parent side. - ;; Per-call success/failure can be inferred from process - ;; status + the static capability report. - [report (sandbox-capabilities)] - [lim-report - (and limit-pol - (let ([cell (assq 'limits report)]) - (and cell - (map (lambda (kv) (cons (car kv) 'attempted)) - (cdr cell)))))]) - (let ([proc (supervise-run spec*)]) - (make-sandbox-result-rec - proc - report - (sandbox-backend) - lim-report)))])) + (cond + [(launch-spec? spec) + (sandbox-launch-spec spec pol limit-pol)] + [else (error 'sandbox-launch + "expected launch-spec or keyword form")])] + [(pol . args) + (cond + [(sandbox-policy? pol) + (sandbox-launch-kw pol (collect-launch-args args))] + [(launch-spec? pol) + (error 'sandbox-launch "missing policy argument")] + [else + (error 'sandbox-launch "first argument must be sandbox-policy")])])) + + (def (sandbox-launch-kw pol args) + (let* ([command (launch-arg args 'command: #f)] + [require-axes (launch-arg args 'require: '())] + [fail-closed? (launch-arg args 'fail-closed?: #t)] + [limit-pol (launch-arg args 'limit-policy: #f)] + [capabilities (sandbox-capabilities)] + [missing (missing-required-axes capabilities require-axes)]) + (unless command + (error 'sandbox-launch "missing 'command:")) + (cond + [(and fail-closed? (not (null? missing))) + ;; 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)] + [else + (let* ([spec (launch-spec + 'command: command + 'env: (launch-arg args 'env: '()) + 'cwd: (launch-arg args 'cwd: #f) + 'capture-stdout?: (launch-arg args 'capture-stdout?: #f) + 'capture-stderr?: (launch-arg args 'capture-stderr?: #f) + 'stdout-cap-bytes: (launch-arg args 'stdout-cap-bytes: #f) + 'stderr-cap-bytes: (launch-arg args 'stderr-cap-bytes: #f) + '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))]))) + + (def (sandbox-launch-spec spec pol limit-pol) + (let* ([user-pre (launch-spec-child-pre-exec spec)] + [combined + (lambda () + (when user-pre (user-pre)) + (sandbox-prepare-child! pol) + (when 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))] + [spec* + (launch-spec + 'command: final-cmd + 'env: (launch-spec-env spec) + 'cwd: (launch-spec-cwd spec) + 'capture-stdout?: (launch-spec-capture-stdout? spec) + 'capture-stderr?: (launch-spec-capture-stderr? spec) + '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 + '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 '())))) ;; ---------- Explain ---------- --- a/lib/std/os/posix.ss +++ b/lib/std/os/posix.ss @@ -218,18 +218,26 @@ (def (WSTOPSIG s) (bitwise-arithmetic-shift-right (bitwise-and s #xff00) 8)) ;; ========== Open Flags ========== - ;; Values differ between Linux and FreeBSD + ;; Values differ between Linux, FreeBSD, and macOS (Darwin). + ;; macOS shares the BSD heritage for most flag bits but has its own + ;; O_NOCTTY and O_CLOEXEC values. (def *freebsd?* (memq (machine-type) '(a6fb ta6fb i3fb ti3fb arm64fb))) + (def *macos?* (memq (machine-type) '(a6osx ta6osx i3osx ti3osx arm64osx tarm64osx))) + (def *bsd-like?* (or *freebsd?* *macos?*)) (def O_RDONLY #x0) (def O_WRONLY #x1) (def O_RDWR #x2) - (def O_CREAT (if *freebsd?* #x200 #x40)) - (def O_EXCL (if *freebsd?* #x800 #x80)) - (def O_NOCTTY (if *freebsd?* #x8000 #x100)) - (def O_TRUNC (if *freebsd?* #x400 #x200)) - (def O_APPEND (if *freebsd?* #x8 #x400)) - (def O_NONBLOCK (if *freebsd?* #x4 #x800)) - (def O_CLOEXEC (if *freebsd?* #x100000 #x80000)) + (def O_CREAT (if *bsd-like?* #x200 #x40)) + (def O_EXCL (if *bsd-like?* #x800 #x80)) + (def O_NOCTTY (cond [*macos?* #x20000] + [*freebsd?* #x8000] + [else #x100])) + (def O_TRUNC (if *bsd-like?* #x400 #x200)) + (def O_APPEND (if *bsd-like?* #x8 #x400)) + (def O_NONBLOCK (if *bsd-like?* #x4 #x800)) + (def O_CLOEXEC (cond [*macos?* #x1000000] + [*freebsd?* #x100000] + [else #x80000])) ;; ========== Seek Constants ========== (def SEEK_SET 0) @@ -360,7 +368,10 @@ ;; F_GETFL = 3, F_SETFL = 4 (def c-fcntl2 (foreign-procedure "fcntl" (int int) int)) - (def c-fcntl3 (foreign-procedure "fcntl" (int int int) int)) + ;; fcntl is varargs; the third int is in the variadic part. On + ;; arm64 macOS the ABI uses different registers for varargs vs fixed + ;; args, so we must declare this explicitly or the kernel sees junk. + (def c-fcntl3 (foreign-procedure (__varargs_after 2) "fcntl" (int int int) int)) (def (posix-fcntl-getfl fd) (check-posix 'fcntl (c-fcntl2 fd 3))) --- a/lib/std/os/supervise.ss +++ b/lib/std/os/supervise.ss @@ -276,20 +276,18 @@ (def (read-available fd cap-bytes accum) ;; Drain everything currently in the pipe (without blocking past - ;; EAGAIN); returns 'eof or 'open. Cap is enforced by the caller - ;; via byte-accum-size after the loop. + ;; EAGAIN); returns 'eof, 'open, or 'over-cap. An EAGAIN/EWOULDBLOCK + ;; from posix-read raises a condition that we catch and treat as 'open. + ;; A 0-byte read with no exception is a real EOF. (let ([buf (make-bytevector 4096)]) (let lp ([state 'open]) - (let ([rc - (try (posix-read fd buf 4096) - (catch (e) - ;; EAGAIN/EWOULDBLOCK looks the same as "read - ;; would block" here; treat any read error as - ;; "no more data right now". - 0))]) + (let-values ([(rc err?) + (try (values (posix-read fd buf 4096) #f) + (catch (e) (values -1 #t)))]) (cond - [(< rc 0) 'open] - [(= rc 0) 'eof] + [err? 'open] ;; EAGAIN, EINTR, etc. + [(< rc 0) 'open] + [(= rc 0) 'eof] [else (byte-accum-push! accum buf rc) (cond @@ -297,6 +295,18 @@ 'over-cap] [else (lp 'open)])]))))) + (def (drain-to-eof fd cap-bytes accum) + ;; Blocking-ish drain used after the child has been reaped or killed. + ;; We loop reading until EOF or over-cap; we are non-blocking so + ;; EAGAIN appears as 'open and we just retry after a tiny sleep. + (let lp ([tries 0]) + (let ([s (read-available fd cap-bytes accum)]) + (cond + [(eq? s 'eof) 'eof] + [(eq? s 'over-cap) 'over-cap] + [(>= tries 50) 'open] ;; ~500ms backstop; pipe is genuinely idle + [else (sleep-ms 10) (lp (+ tries 1))])))) + (def (set-nonblock! fd) (let ([fl (posix-fcntl-getfl fd)]) (posix-fcntl-setfl fd (bitwise-ior fl O_NONBLOCK)))) @@ -304,11 +314,16 @@ ;; ---------- Kill ---------- (def (kill-pgid! pgid sig) - ;; kill(2) with -pid sends to whole process group. Best-effort: - ;; ESRCH = group already gone, fine. - (try - (posix-kill (- pgid) sig) - (catch (e) #f))) + ;; The pgid value passed here is always the direct child pid (we set + ;; pgid := pid in the parent). macOS in --script mode rejects + ;; kill(-pgid, sig) with EPERM in some pipe/session configurations, + ;; but kill(pid, sig) on our own child always works. We kill the + ;; bare pid first (reliable) and then attempt -pgid as a best-effort + ;; subtree sweep. Both errors are swallowed. + (let ([bare-ok? (try (begin (posix-kill pgid sig) #t) + (catch (e) #f))]) + (try (posix-kill (- pgid) sig) (catch (e) #f)) + bare-ok?)) (def (supervise-kill r . sig) (let ([s (if (pair? sig) (car sig) SIGTERM)] @@ -389,17 +404,20 @@ [killed-reason (list #f)]) (let loop ([out-state (if out-pipe 'open 'closed)] [err-state (if err-pipe 'open 'closed)]) - ;; Try to reap + ;; Try to reap (non-blocking until we kill; blocking after). (let-values ([(rc status) - (try (posix-waitpid pid WNOHANG) + (try (posix-waitpid + pid + (if (car killed-reason) 0 WNOHANG)) (catch (e) (values -1 0)))]) (cond [(> rc 0) - ;; Final drain + ;; Child reaped. Drain any remaining buffered bytes + ;; until EOF before reporting bytes-out totals. (when (and out-pipe (eq? out-state 'open)) - (read-available (car out-pipe) cap-out-bytes out-acc)) + (drain-to-eof (car out-pipe) cap-out-bytes out-acc)) (when (and err-pipe (eq? err-state 'open)) - (read-available (car err-pipe) cap-err-bytes err-acc)) + (drain-to-eof (car err-pipe) cap-err-bytes err-acc)) (finalize-result resolved cmd env pid pgid start status out-acc err-acc out-pipe err-pipe @@ -412,7 +430,9 @@ [es (if (and err-pipe (eq? err-state 'open)) (read-available (car err-pipe) cap-err-bytes err-acc) err-state)]) - ;; Cap checks + ;; Cap checks: mark + send SIGKILL immediately; the + ;; next loop turn will reap blockingly because + ;; killed-reason is now set. (when (and cap-out-bytes out-acc (>= (byte-accum-size out-acc) cap-out-bytes) (not (car killed-reason))) @@ -423,15 +443,18 @@ (not (car killed-reason))) (set-car! killed-reason 'stderr-cap) (kill-pgid! pgid SIGKILL)) - ;; Timeout check + ;; Timeout check: send SIGTERM, schedule SIGKILL + ;; escalation; the next iteration will switch + ;; waitpid to blocking via the killed-reason guard. (when (and timeout-ms (> (- (now-ms) start) timeout-ms) (not (car killed-reason))) (set-car! killed-reason 'timeout) (kill-pgid! pgid SIGTERM) - (sleep-ms 250) + ;; Best-effort escalation: brief grace then SIGKILL. + (sleep-ms 100) (kill-pgid! pgid SIGKILL)) - (sleep-ms 10) + (sleep-ms 5) (loop ns es))])))))]))) (def (finalize-result resolved cmd env pid pgid start status @@ -444,7 +467,7 @@ [obytes (if out-acc (byte-accum->bytevector out-acc) (make-bytevector 0))] [ebytes (if err-acc (byte-accum->bytevector err-acc) (make-bytevector 0))]) (make-process-result-rec - (or exit-code (and sig (- 128 sig))) + (or exit-code (and sig (+ 128 sig))) sig pid pgid (cons resolved (cdr cmd)) env elapsed (bytevector-length obytes) (bytevector-length ebytes) --- a/lib/std/os/temp-home.ss +++ b/lib/std/os/temp-home.ss @@ -40,7 +40,9 @@ call-with-temp-home temp-home-cache-dir - temp-home-env-overrides) + temp-home-env-overrides + temp-home-policy-grants + temp-home-apply-policy!) (import (chezscheme) (only (jerboa core) def defstruct try catch finally) @@ -247,4 +249,48 @@ (cons "NPM_CONFIG_CACHE" npm))) pairs)))) + ;; ---------- Sandbox-policy integration ---------- + ;; + ;; Without this, callers had to remember to list HOME, scratch, and + ;; every named cache directory in their read-paths/write-paths grants + ;; — easy to miss one and end up with a sandbox that breaks for + ;; non-obvious reasons. These helpers return the paths in a shape + ;; that can be spliced into a sandbox-policy or applied with a + ;; setter callback. + + (def (temp-home-policy-grants h) + ;; Returns alist: + ;; ((read-paths . (...)) + ;; (write-paths . (...)) + ;; (env . (...))) + ;; + ;; read-paths: empty by default — the temp-home holds nothing the + ;; sandboxed process needs to read besides what it writes itself. + ;; If copy-config copied files into ~/HOME, those are inside the + ;; home subtree and are covered by the write grant. + ;; + ;; write-paths: the fake HOME and the scratch dir, plus every + ;; named cache directory. These are the only places the child + ;; should be allowed to mutate. + (let* ([home (temp-home-home h)] + [scratch (temp-home-scratch h)] + [caches (map cdr (temp-home-caches h))] + [write-paths (cons home (cons scratch caches))]) + `((read-paths . ()) + (write-paths . ,write-paths) + (env . ,(temp-home-env-overrides h))))) + + (def (temp-home-apply-policy! h policy-setter) + ;; Calls POLICY-SETTER with each (key . value) pair from the grants + ;; alist. Designed to interoperate with sandbox-policy-set! without + ;; this module having to import (std os limits sandbox). + ;; + ;; Example: + ;; (temp-home-apply-policy! h + ;; (lambda (k v) (sandbox-policy-set! pol k v))) + (let ([grants (temp-home-policy-grants h)]) + (for-each + (lambda (kv) (policy-setter (car kv) (cdr kv))) + grants))) + ) ;; end library --- a/lib/std/os/tracefs.ss +++ b/lib/std/os/tracefs.ss @@ -33,7 +33,9 @@ (export tracefs-supported? tracefs-mode + tracefs-capabilities tracefs-strace-cmd + tracefs-wrap-command tracefs-parse-strace tracefs-parse-strace-file tracefs-events-by-path @@ -83,6 +85,41 @@ [(platform-bsd?) 'unavailable] [else 'unavailable])) + (def (tracefs-capabilities) + ;; Structured capability report so callers can decide between + ;; "trace if possible, run bare otherwise" and "trace or refuse". + ;; + ;; backend symbol — currently 'strace or 'none + ;; status 'installed when fully usable, 'unavailable otherwise + ;; events alist of (event-class . supported?) + ;; caveats list of human-readable caveat strings; the parser is + ;; a subset of full strace output and does not normalize + ;; cwd/fd state, so callers should not treat parsed + ;; events as a complete syscall log. + (let* ([mode (tracefs-mode)] + [installed? (eq? mode 'strace)] + [backend (case mode [(strace) 'strace] [else 'none])]) + `((backend . ,backend) + (status . ,(if installed? 'installed 'unavailable)) + (platform . ,(platform-name))