Add sandbox denied path policy fields
ober
3670f3573dae449ddd96d11b497fe3c2a1cd2f45
--- a/docs/limits-followup.md +++ b/docs/limits-followup.md @@ -1,7 +1,7 @@ # Limits Follow-Up: Missing Enforcement and Test Work Reviewed: 2026-05-21 -Status updated: 2026-05-22 (path capability resolver phase) +Status updated: 2026-05-22 (sandbox denied path phase) This document is a follow-up to `docs/limits.md` after reviewing the new limits/sandbox/audit module set added around commit `97eea41`. @@ -100,8 +100,8 @@ File: `lib/std/os/limits/sandbox.ss` Implemented: -- `sandbox-policy` record with read, write, exec, net, syscall, ptrace, and - no-new-privs fields. +- `sandbox-policy` record with read, write, exec, deny-read, deny-write, + deny-exec, net, syscall, ptrace, and no-new-privs fields. - `sandbox-capabilities`. - `sandbox-launch` keyword form with `require:` and `fail-closed?:`. - Parent-visible pre-exec status reporting through `(std os supervise)`. @@ -111,11 +111,14 @@ Implemented: 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. +- macOS SBPL generation for path policies, including explicit denied read, + write, and exec subpaths that override broader grants. - `sandbox-command-wrapper-needed?`, `sandbox-command-wrapper-available?`, and `sandbox-wrap-command` expose the reusable command rewrite needed by custom launchers that cannot call `sandbox-launch` directly. -- Linux Landlock hook via `jerboa_landlock_sandbox`. +- Linux Landlock hook via `jerboa_landlock_sandbox`; policies with negative + path exceptions report degraded on backends that cannot enforce those + exceptions. Still incomplete: --- a/docs/limits.md +++ b/docs/limits.md @@ -81,7 +81,10 @@ 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. +report status to the parent through `(std os supervise)` before exec. Policies +also accept `deny-read-paths:`, `deny-write-paths:`, and `deny-exec-paths:`; +macOS Seatbelt renders those as explicit SBPL denies, while backends without +negative path exceptions report degraded so fail-closed callers can refuse. ## 2. Process Supervision --- a/lib/std/os/limits/sandbox.ss +++ b/lib/std/os/limits/sandbox.ss @@ -19,6 +19,9 @@ ;;; read-paths list of read-only paths ;;; write-paths list of read/write paths ;;; exec-paths list of execute paths +;;; deny-read-paths list of read-denied paths overriding broad grants +;;; deny-write-paths list of write-denied paths overriding broad grants +;;; deny-exec-paths list of execute-denied paths overriding broad grants ;;; net 'allow | 'deny | 'local-only | 'allowlist ;;; net-allow list of host:port for 'allowlist ;;; syscalls 'unrestricted | 'safe | 'minimal (Linux seccomp hint) @@ -119,6 +122,9 @@ '((read-paths . ()) (write-paths . ()) (exec-paths . ()) + (deny-read-paths . ()) + (deny-write-paths . ()) + (deny-exec-paths . ()) (net . deny) (net-allow . ()) (syscalls . safe) @@ -127,6 +133,7 @@ (def *sandbox-policy-keys* '(read-paths: write-paths: exec-paths: + deny-read-paths: deny-write-paths: deny-exec-paths: net: net-allow: syscalls: ptrace?: no-new-privs?:)) (def (sandbox-policy . args) @@ -278,6 +285,7 @@ (let* ([read (sandbox-policy-get pol 'read-paths)] [write (sandbox-policy-get pol 'write-paths)] [exec (sandbox-policy-get pol 'exec-paths)] + [has-denies? (sandbox-policy-has-deny-paths? pol)] [fs-status (try (let ([ll-sandbox (foreign-procedure @@ -287,7 +295,7 @@ (pack-paths write) (pack-paths exec))]) (cond - [(= ret 0) 'installed] + [(= ret 0) (if has-denies? 'degraded 'installed)] [(= ret 1) 'unavailable] [else 'failed]))) (catch (e) 'unavailable))]) @@ -310,7 +318,7 @@ [write (sandbox-policy-get pol 'write-paths)] [exec (sandbox-policy-get pol 'exec-paths)] [net (sandbox-policy-get pol 'net)] - [needs-wrap? (or (pair? read) (pair? write) (pair? exec))] + [needs-wrap? (sandbox-policy-has-paths? pol)] [fs-status (cond [needs-wrap? @@ -318,7 +326,14 @@ 'installed ;; handled by sandbox-exec wrap 'unavailable)] [else - (let ([sbpl (build-sbpl read write exec net)]) + (let ([sbpl (build-sbpl read write exec + (sandbox-policy-get pol + 'deny-read-paths) + (sandbox-policy-get pol + 'deny-write-paths) + (sandbox-policy-get pol + 'deny-exec-paths) + net)]) (try (let* ([sb-init (foreign-procedure "sandbox_init" (string unsigned-64 void*) @@ -344,17 +359,26 @@ [write (sandbox-policy-get pol 'write-paths)] [exec (sandbox-policy-get pol 'exec-paths)]) (cond - [(or (pair? read) (pair? write) (pair? exec)) + [(sandbox-policy-has-paths? pol) (let ([sbpl (build-sbpl read write exec + (sandbox-policy-get pol 'deny-read-paths) + (sandbox-policy-get pol 'deny-write-paths) + (sandbox-policy-get pol 'deny-exec-paths) (sandbox-policy-get pol 'net))]) (cons "/usr/bin/sandbox-exec" (cons "-p" (cons sbpl cmd))))] [else cmd]))) + (def (sandbox-policy-has-deny-paths? pol) + (or (pair? (sandbox-policy-get pol 'deny-read-paths)) + (pair? (sandbox-policy-get pol 'deny-write-paths)) + (pair? (sandbox-policy-get pol 'deny-exec-paths)))) + (def (sandbox-policy-has-paths? pol) (or (pair? (sandbox-policy-get pol 'read-paths)) (pair? (sandbox-policy-get pol 'write-paths)) - (pair? (sandbox-policy-get pol 'exec-paths)))) + (pair? (sandbox-policy-get pol 'exec-paths)) + (sandbox-policy-has-deny-paths? pol))) (def (sandbox-command-wrapper-needed? pol) ;; Some backends install policy directly in the child between fork and @@ -410,7 +434,7 @@ ;; ---------- SBPL builder ---------- - (def (build-sbpl read write exec net) + (def (build-sbpl read write exec deny-read deny-write deny-exec net) ;; Two modes: ;; 1. No paths declared → allow-default with selective denies. ;; Deny-default on macOS without an exhaustive read-allow list @@ -419,10 +443,13 @@ ;; plus an allow on the system library paths so the dynamic ;; loader still works. (let ([port (open-output-string)] - [have-paths? (or (pair? read) (pair? write) (pair? exec))]) + [have-allow-paths? (or (pair? read) (pair? write) (pair? exec))] + [have-deny-paths? (or (pair? deny-read) + (pair? deny-write) + (pair? deny-exec))]) (display "(version 1)" port) (cond - [have-paths? + [have-allow-paths? (display "(deny default)" port) (display "(allow process-fork)" port) (display "(allow process-exec)" port) @@ -464,17 +491,36 @@ (display "))" port)) (or write '())) (for-each - (lambda (p) + (lambda (p) (display "(allow process-exec (subpath " port) (display (sbpl-string p) port) (display "))" port)) (or exec '()))] [else (display "(allow default)" port)]) + (when have-deny-paths? + (for-each + (lambda (p) + (display "(deny file-read* (subpath " port) + (display (sbpl-string p) port) + (display "))" port)) + (or deny-read '())) + (for-each + (lambda (p) + (display "(deny file-write* (subpath " port) + (display (sbpl-string p) port) + (display "))" port)) + (or deny-write '())) + (for-each + (lambda (p) + (display "(deny process-exec (subpath " port) + (display (sbpl-string p) port) + (display "))" port)) + (or deny-exec '()))) ;; Network policy applies in both modes. (case net [(allow) - (when have-paths? + (when have-allow-paths? (display "(allow network*)" port))] [(local-only) (display "(deny network*)" port) @@ -491,6 +537,9 @@ (build-sbpl (sandbox-policy-get pol 'read-paths) (sandbox-policy-get pol 'write-paths) (sandbox-policy-get pol 'exec-paths) + (sandbox-policy-get pol 'deny-read-paths) + (sandbox-policy-get pol 'deny-write-paths) + (sandbox-policy-get pol 'deny-exec-paths) (sandbox-policy-get pol 'net))) (def (sbpl-string s) --- a/tests/test-limits-primitives.ss +++ b/tests/test-limits-primitives.ss @@ -49,6 +49,26 @@ [(and (pair? al) (assq key al)) => cdr] [else default])) +(define (path-join a b) + (cond + [(or (zero? (string-length a)) + (char=? (string-ref a (- (string-length a) 1)) #\/)) + (string-append a b)] + [else (string-append a "/" b)])) + +(define (sh-quote s) + (let ([port (open-output-string)]) + (write-char #\' port) + (let ([n (string-length s)]) + (do ([i 0 (+ i 1)]) + ((= i n)) + (let ([ch (string-ref s i)]) + (if (char=? ch #\') + (display "'\\''" port) + (write-char ch port))))) + (write-char #\' port) + (get-output-string port))) + (define (child-status-value st) (alist-ref/default st 'value #f)) @@ -483,6 +503,73 @@ "/usr/bin/sandbox-exec" cmd))) +(let* ([pol (sandbox-policy + 'write-paths: '("/tmp/project") + 'deny-read-paths: '("/tmp/project/secret") + 'deny-write-paths: '("/tmp/project/shims") + 'deny-exec-paths: '("/tmp/project/bin"))] + [sbpl (sandbox-policy-sbpl pol)]) + (test "sandbox policy stores deny-write-paths" + (sandbox-policy-get pol 'deny-write-paths) + '("/tmp/project/shims")) + (test-pred "sandbox SBPL renders deny-read paths" + sbpl + (lambda (s) + (string-contains? + s + "(deny file-read* (subpath \"/tmp/project/secret\"))"))) + (test-pred "sandbox SBPL renders deny-write paths" + sbpl + (lambda (s) + (string-contains? + s + "(deny file-write* (subpath \"/tmp/project/shims\"))"))) + (test-pred "sandbox SBPL renders deny-exec paths" + sbpl + (lambda (s) + (string-contains? + s + "(deny process-exec (subpath \"/tmp/project/bin\"))")))) + +(let ([h (open-temp-home 'cleanup: 'always)]) + (let* ([root (temp-home-scratch h)] + [deny-dir (path-join root "deny")] + [allow-file (path-join root "allowed.txt")] + [deny-file (path-join deny-dir "blocked.txt")]) + (mkdir deny-dir) + (let* ([root* (exec-id-realpath-of root)] + [deny* (exec-id-realpath-of deny-dir)] + [pol (sandbox-policy + 'write-paths: (list root root*) + 'deny-write-paths: (list deny-dir deny*))] + [cmd (list "/bin/sh" "-c" + (string-append "printf ok > " + (sh-quote allow-file) + "; printf no > " + (sh-quote deny-file)))]) + (if (and (platform-macos?) + (sandbox-command-wrapper-needed? pol) + (sandbox-command-wrapper-available? pol)) + (let ([r (sandbox-launch + pol + 'command: cmd + 'cwd: root + 'capture-stderr?: #t + 'require: '(fs) + 'fail-closed?: #t)]) + (test "sandbox deny-write path launches on macOS" + (sandbox-result-launched? r) + #t) + (test-pred "sandbox deny-write permits broader write grant" + allow-file + file-exists?) + (test-pred "sandbox deny-write blocks denied subpath" + deny-file + (lambda (p) (not (file-exists? p))))) + (skip-test "sandbox deny-write live backend" + "requires macOS sandbox-exec")))) + (close-temp-home h 'ok)) + ;; A required axis that isn't installed must refuse to launch the child. (let ([r (guard (exn [#t (cons 'error (if (message-condition? exn)