macos: Landlock parity for cage! via Seatbelt SBPL profiles
ober
e754e627b0fbf7ce3fdd728e8d52e1c02db85975
--- a/lib/std/os/sandbox.sls +++ b/lib/std/os/sandbox.sls @@ -116,34 +116,46 @@ (guard (e [#t #f]) (foreign-entry? "sandbox_init")))) - ;; Named profile map - (define (named-profile-string sym) + ;; Named profile map. Apple's legacy `kSBXProfile*` named profiles + ;; were deprecated in macOS 10.7 and no longer load on modern macOS, + ;; so we map symbols to equivalent SBPL strings. + (define (named-profile-sbpl sym) (case sym - [(pure-computation) "kSBXProfilePureComputation"] - [(no-write) "kSBXProfileNoWrite"] - [(no-write-except-temporary) "kSBXProfileNoWriteExceptTemporary"] - [(no-internet) "kSBXProfileNoInternet"] - [(no-network) "kSBXProfileNoNetwork"] + [(pure-computation) + "(version 1)(deny default)(allow mach-lookup)(allow signal)(allow sysctl-read)"] + [(no-write) + "(version 1)(allow default)(deny file-write*)"] + [(no-write-except-temporary) + (string-append + "(version 1)(allow default)(deny file-write*)" + "(allow file-write* (subpath \"/tmp\") (subpath \"/private/tmp\")" + " (subpath \"/var/folders\") (subpath \"/private/var/folders\"))")] + [(no-internet) + "(version 1)(allow default)(deny network-outbound (remote ip))"] + [(no-network) + "(version 1)(allow default)(deny network*)"] [else #f])) (define (apply-seatbelt! profile-spec) ;; Apply a Seatbelt profile. profile-spec is a symbol or SBPL string. + ;; Always uses SBPL (flags = 0) since the legacy named-profile path + ;; is broken on modern macOS. (let ([errptr (foreign-alloc 8)]) (foreign-set! 'void* errptr 0 0) (dynamic-wind (lambda () (void)) (lambda () - (let ([rc (if (string? profile-spec) - ;; Raw SBPL string — flags = 0 - (c-sandbox-init profile-spec 0 errptr) - ;; Named profile — flags = SANDBOX_NAMED - (let ([name (named-profile-string profile-spec)]) - (if name - (c-sandbox-init name SANDBOX_NAMED errptr) - (begin - (display "sandbox: unknown Seatbelt profile\n" - (current-error-port)) - -1))))]) + (let ([rc (cond + [(string? profile-spec) + (c-sandbox-init profile-spec 0 errptr)] + [else + (let ([sbpl (named-profile-sbpl profile-spec)]) + (if sbpl + (c-sandbox-init sbpl 0 errptr) + (begin + (display "sandbox: unknown Seatbelt profile\n" + (current-error-port)) + -1)))])]) (when (< rc 0) (let ([errmsg (foreign-ref 'void* errptr 0)]) (unless (= errmsg 0) --- a/lib/std/security/cage.sls +++ b/lib/std/security/cage.sls @@ -58,6 +58,7 @@ (import (chezscheme) (std security landlock) (std security capsicum) + (std security seatbelt) (std error conditions)) ;; ========== libc ========== @@ -296,6 +297,7 @@ (case *current-platform* [(linux) (cage-linux! cfg)] + [(macos) (cage-macos! cfg)] [(openbsd) (cage-openbsd! cfg)] [(freebsd) (cage-freebsd! cfg)] [else @@ -368,6 +370,75 @@ (void))) + ;; ========== macOS implementation (Seatbelt) ========== + ;; + ;; macOS has no Landlock, but `sandbox_init(3)` (Seatbelt) provides + ;; a similar capability via SBPL profiles. We synthesize a profile + ;; from the cage config, then apply it. Seatbelt is irreversible for + ;; the process lifetime, just like Landlock. + ;; + ;; SBPL is more permissive by default than Landlock (it operates at + ;; the syscall layer, not vfs). We use `(deny default)` and whitelist + ;; only the paths and operations the cage permits. + + ;; macOS-specific system paths (different from Linux — see + ;; seatbelt-macos-system-read-paths / seatbelt-macos-system-execute-paths). + + (define (cage-macos! cfg) + (unless (seatbelt-available?) + (raise (make-cage-error + "cage" + 'platform + "Seatbelt (sandbox_init) not available on this system"))) + + (let* ([root (resolve-path 'cage! (cage-config-root cfg))] + [extra-ro (resolve-paths 'cage! (cage-config-read-only cfg))] + [extra-rw (resolve-paths 'cage! (cage-config-read-write cfg))] + [extra-exec (resolve-paths 'cage! (cage-config-execute cfg))] + [temp (and (cage-config-temp-dir cfg) + (guard (exn [#t #f]) + (resolve-path 'cage! (cage-config-temp-dir cfg))))] + ;; Build system paths + [sys-ro (case (cage-config-system-paths cfg) + [(auto) (existing-paths seatbelt-macos-system-read-paths)] + [(#f) '()] + [else (cage-config-system-paths cfg)])] + [sys-exec (case (cage-config-system-paths cfg) + [(auto) (existing-paths seatbelt-macos-system-execute-paths)] + [(#f) '()] + [else '()])] + [rw-paths (append (list root) + (if temp (list temp) '()) + extra-rw)] + [ro-paths (append sys-ro extra-ro)] + [exec-paths (append sys-exec extra-exec)] + [profile (seatbelt-cage-profile + 'read-write: rw-paths + 'read-only: ro-paths + 'execute: exec-paths + 'network: (and (cage-config-network cfg) #t))]) + + ;; Install — IRREVERSIBLE for process lifetime + (guard (exn + [#t (raise (make-cage-error + "cage" + 'platform + (if (message-condition? exn) + (condition-message exn) + "seatbelt-install-profile! failed")))]) + (seatbelt-install-profile! profile)) + + ;; Record state + (set! *cage-active* #t) + (set! *cage-root-path* root) + (set! *cage-all-paths* + (append + (map (lambda (p) (cons 'read-write p)) rw-paths) + (map (lambda (p) (cons 'read-only p)) ro-paths) + (map (lambda (p) (cons 'execute p)) exec-paths))) + + (void))) + ;; ========== OpenBSD implementation (pledge/unveil) ========== ;; Stub for future implementation — OpenBSD has native unveil(2) ;; which is exactly what cage! wants to be. --- a/lib/std/security/sandbox.sls +++ b/lib/std/security/sandbox.sls @@ -204,9 +204,9 @@ (cond [(eq? spec #f) #f] [(seccomp-filter? spec) spec] - [(eq? spec 'compute-only) (compute-only-filter)] - [(eq? spec 'io-only) (io-only-filter)] - [(eq? spec 'network-server) (network-server-filter)] + [(eq? spec 'compute-only) compute-only-filter] + [(eq? spec 'io-only) io-only-filter] + [(eq? spec 'network-server) network-server-filter] [else (error 'run-safe "invalid seccomp spec; expected #f, 'compute-only, 'io-only, 'network-server, or seccomp-filter" spec)])) --- a/lib/std/security/seatbelt.sls +++ b/lib/std/security/seatbelt.sls @@ -5,12 +5,13 @@ ;;; Profiles restrict filesystem, network, and process operations. ;;; Once applied, restrictions are IRREVERSIBLE for the process lifetime. ;;; -;;; macOS provides built-in named profiles: -;;; kSBXProfilePureComputation — no I/O at all -;;; kSBXProfileNoWrite — read-only filesystem -;;; kSBXProfileNoWriteExceptTemporary — writes only to $TMPDIR -;;; kSBXProfileNoInternet — no outbound network -;;; kSBXProfileNoNetwork — no network at all (including local) +;;; Named profile symbols (mapped to equivalent SBPL since the +;;; legacy kSBXProfile* names were removed in modern macOS): +;;; pure-computation — no I/O at all +;;; no-write — read-only filesystem +;;; no-write-except-temporary — writes only to $TMPDIR / /tmp +;;; no-internet — no outbound IP network +;;; no-network — no network at all (including local) ;;; ;;; Custom profiles use SBPL (Sandbox Profile Language), e.g.: ;;; (version 1)(deny default)(allow file-read* (subpath "/usr/lib")) @@ -41,6 +42,11 @@ seatbelt-no-network-profile seatbelt-no-write-profile + ;; Path-based confinement profile (Landlock-equivalent) + seatbelt-cage-profile + seatbelt-macos-system-read-paths + seatbelt-macos-system-execute-paths + ;; Named profile symbols ;; 'pure-computation, 'no-write, 'no-write-except-temporary, ;; 'no-internet, 'no-network @@ -98,14 +104,39 @@ p)))) ;; ========== Named Profile Map ========== + ;; + ;; Apple's `kSBXProfile*` named profiles were deprecated in macOS 10.7 + ;; and no longer load on modern macOS (sandbox_init returns "profile + ;; not found"). We map the same symbols to equivalent SBPL strings + ;; so the API keeps working across versions. - (define (named-profile-string sym) + (define (named-profile-sbpl sym) (case sym - [(pure-computation) "kSBXProfilePureComputation"] - [(no-write) "kSBXProfileNoWrite"] - [(no-write-except-temporary) "kSBXProfileNoWriteExceptTemporary"] - [(no-internet) "kSBXProfileNoInternet"] - [(no-network) "kSBXProfileNoNetwork"] + [(pure-computation) + ;; Deny everything except basic process operation + "(version 1)(deny default)(allow mach-lookup)(allow signal)(allow sysctl-read)"] + [(no-write) + "(version 1)(allow default)(deny file-write*)"] + [(no-write-except-temporary) + ;; Allow writes only under $TMPDIR / /tmp / /private/tmp / /private/var/folders + (string-append + "(version 1)" + "(allow default)" + "(deny file-write*)" + "(allow file-write* " + "(subpath \"/tmp\") " + "(subpath \"/private/tmp\") " + "(subpath \"/var/folders\") " + "(subpath \"/private/var/folders\")" + (let ([t (getenv "TMPDIR")]) + (if (and (string? t) (positive? (string-length t))) + (format " (subpath ~s)" t) + "")) + ")")] + [(no-internet) + "(version 1)(allow default)(deny network-outbound (remote ip))"] + [(no-network) + "(version 1)(allow default)(deny network*)"] [else (error 'seatbelt-install! "unknown named profile; expected pure-computation, no-write, no-write-except-temporary, no-internet, or no-network" sym)])) @@ -116,25 +147,12 @@ ;; Install a named Seatbelt profile. IRREVERSIBLE. ;; profile-sym: one of 'pure-computation, 'no-write, ;; 'no-write-except-temporary, 'no-internet, 'no-network + ;; + ;; Since the kSBXProfile* names are removed in modern macOS, this + ;; expands the symbol to an equivalent SBPL string and applies that. (unless (macos?) (error 'seatbelt-install! "Seatbelt is only available on macOS")) - (let* ([profile-name (named-profile-string profile-sym)] - [errptr (foreign-alloc 8)]) - (foreign-set! 'void* errptr 0 0) - (dynamic-wind - (lambda () (void)) - (lambda () - (let ([rc (c-sandbox-init profile-name SANDBOX_NAMED errptr)]) - (when (< rc 0) - (let ([errmsg (foreign-ref 'void* errptr 0)]) - (let ([msg (if (= errmsg 0) - "sandbox_init failed (unknown error)" - (let ([s (foreign-ref 'string errmsg 0)]) - (c-sandbox-free-error errmsg) - (format "sandbox_init failed: ~a" s)))]) - (error 'seatbelt-install! msg)))))) - (lambda () - (foreign-free errptr))))) + (seatbelt-install-profile! (named-profile-sbpl profile-sym))) (define (seatbelt-install-profile! sbpl-string) ;; Install a custom SBPL profile string. IRREVERSIBLE. @@ -207,4 +225,188 @@ "(allow signal)" "(allow sysctl-read)")))) + ;; ========== macOS System Paths ========== + ;; + ;; Paths a Chez Scheme process needs to function on macOS: + ;; dyld, system frameworks, TLS roots, DNS, terminal, devices. + ;; macOS symlinks /etc, /tmp, /var to /private/etc, /private/tmp, + ;; /private/var — we list both forms so realpath resolution works + ;; either way. + + (define seatbelt-macos-system-read-paths + '(;; System libraries and frameworks + "/usr/lib" + "/usr/local/lib" + "/usr/share" + "/System/Library" + "/Library/Frameworks" + "/Library/Apple" + ;; dyld shared cache + "/private/var/db/dyld" + ;; TLS certificate roots + "/etc/ssl" + "/private/etc/ssl" + "/private/var/db/mds" + ;; DNS resolution / hosts + "/etc/resolv.conf" + "/etc/hosts" + "/etc/services" + "/private/etc/resolv.conf" + "/private/etc/hosts" + "/private/etc/services" + ;; Terminal + "/usr/share/terminfo" + ;; Timezone / locale + "/etc/localtime" + "/private/etc/localtime" + "/usr/share/zoneinfo" + "/var/db/timezone" + "/private/var/db/timezone" + ;; Devices + "/dev/null" + "/dev/zero" + "/dev/random" + "/dev/urandom" + "/dev/tty" + "/dev/dtracehelper")) + + (define seatbelt-macos-system-execute-paths + '("/usr/bin" + "/bin" + "/usr/local/bin" + "/usr/sbin" + "/sbin" + "/usr/libexec" + ;; Frameworks contain executable Mach-O binaries + "/System/Library" + "/Library/Frameworks" + "/usr/lib")) + + ;; ========== Cage profile builder ========== + ;; + ;; Build an SBPL profile that mimics Landlock-style path confinement: + ;; - Read+write access to a list of paths (e.g. project root, $TMPDIR) + ;; - Read-only access to a list of paths (e.g. system libs, configs) + ;; - Execute access to a list of paths (e.g. /usr/bin) + ;; - Optional network access + ;; + ;; macOS Seatbelt always denies by default in this profile, then + ;; whitelists specific operations. The result is roughly equivalent + ;; to a Landlock ruleset on Linux. + ;; + ;; Operations needed for any usable Chez Scheme process are always + ;; allowed: mach-lookup, signal, sysctl-read, process-fork, + ;; ipc-posix-shm*, file-ioctl (terminal). These are not security- + ;; relevant on macOS — the relevant restrictions are filesystem and + ;; network. + + (define (sbpl-quote-path p) + ;; Quote a path for inclusion in SBPL. format ~s gives "..." with + ;; escaped backslashes/quotes, which matches SBPL string syntax. + (format "~s" p)) + + (define (subpath-form p) + (string-append "(subpath " (sbpl-quote-path p) ")")) + + (define (literal-form p) + (string-append "(literal " (sbpl-quote-path p) ")")) + + (define (path-form p) + ;; A directory becomes (subpath ...), anything else (literal ...). + ;; subpath also matches the directory itself, so it's a strict + ;; superset for directory paths. + (if (guard (e [#t #f]) (file-directory? p)) + (subpath-form p) + (literal-form p))) + + (define (paths->sbpl-forms paths) + (apply string-append + (map (lambda (p) (string-append " " (path-form p))) paths))) + + (define (seatbelt-cage-profile . opts) + ;; Build an SBPL profile from path lists. + ;; + ;; Keywords (any order): + ;; read-write: '("/path" ...) ;; full read+write+create+delete + ;; read-only: '("/path" ...) ;; read access only + ;; execute: '("/path" ...) ;; process-exec from these paths + ;; network: #t | #f ;; allow outbound/inbound network + ;; + ;; Returns an SBPL string suitable for seatbelt-install-profile!. + (let loop ([rest opts] + [rw '()] + [ro '()] + [exec '()] + [network #t]) + (cond + [(null? rest) + (build-cage-sbpl rw ro exec network)] + [(null? (cdr rest)) + (error 'seatbelt-cage-profile "keyword missing value" (car rest))] + [else + (let ([key (cage-key->string (car rest))] + [val (cadr rest)] + [more (cddr rest)]) + (cond + [(string=? key "read-write") + (loop more val ro exec network)] + [(string=? key "read-only") + (loop more rw val exec network)] + [(string=? key "execute") + (loop more rw ro val network)] + [(string=? key "network") + (loop more rw ro exec val)] + [else + (error 'seatbelt-cage-profile + "unknown keyword; expected read-write:, read-only:, execute:, or network:" + (car rest))]))]))) + + (define (cage-key->string sym) + (let ([s (symbol->string sym)]) + (cond + [(and (>= (string-length s) 2) + (char=? (string-ref s 0) #\#) + (char=? (string-ref s 1) #\:)) + (substring s 2 (string-length s))] + [(and (> (string-length s) 0) + (char=? (string-ref s (- (string-length s) 1)) #\:)) + (substring s 0 (- (string-length s) 1))] + [else s]))) + + (define (build-cage-sbpl rw-paths ro-paths exec-paths network?) + ;; Read access covers: all read-only paths AND all read-write paths + ;; (write access without read access is rarely useful, and Chez + ;; needs to read its boot files anyway). + (let* ([all-readable (append ro-paths rw-paths)] + [read-forms (paths->sbpl-forms all-readable)] + [write-forms (paths->sbpl-forms rw-paths)] + [exec-forms (paths->sbpl-forms exec-paths)]) + (string-append + "(version 1)" + "(deny default)" + ;; Always-allowed operations needed for basic process function. + "(allow process-fork)" + "(allow signal (target self))" + "(allow sysctl-read)" + "(allow mach-lookup)" + "(allow ipc-posix-shm*)" + "(allow file-ioctl)" + "(allow file-read-metadata)" + ;; Read access + (if (null? all-readable) + "" + (string-append "(allow file-read*" read-forms ")")) + ;; Write access (read-write paths only) + (if (null? rw-paths) + "" + (string-append "(allow file-write*" write-forms ")")) + ;; Execute access + (if (null? exec-paths) + "" + (string-append "(allow process-exec*" exec-forms ")")) + ;; Network + (if network? + "(allow network*)" + "")))) + ) ;; end library --- a/tests/test-cage.ss +++ b/tests/test-cage.ss @@ -2,12 +2,15 @@ (import (std security cage)) (import (std security landlock)) (import (std security capsicum)) +(import (std security seatbelt)) ;; fork-process and waitpid for subprocess tests (guard (e [#t (void)]) (load-shared-object "libc.so.7")) (guard (e [#t (void)]) (load-shared-object "libc.so.6")) +(guard (e [#t (void)]) + (load-shared-object "libc.dylib")) (define fork-process (guard (e [#t (lambda () (error 'fork "not available"))]) (foreign-procedure "fork" () int))) @@ -231,6 +234,76 @@ (unless (capsicum-available?) (displayln " [skipped — Capsicum not available]")) +;; ---- macOS Seatbelt cage test ---- + +(displayln "--- macOS Seatbelt cage ---") + +(when (seatbelt-available?) + (let ([cage-dir "/tmp/jerboa-cage-test-macos"]) + (when (file-exists? cage-dir) + (system (str "rm -rf " cage-dir))) + (mkdir cage-dir) + (write-file-string (str cage-dir "/hello.txt") "hello from seatbelt cage") + + (let ([pid (fork-process)]) + (cond + ((= pid 0) + (guard (exn + (#t + (display "CHILD ERROR: ") + (display-condition exn) + (newline) + (exit 1))) + + (cage! (make-cage-config + 'root: cage-dir + 'system-paths: 'auto + 'temp-dir: "/tmp" + 'network: #f)) + + (assert! (cage-active?)) + (assert! (string? (cage-root))) + + ;; Read inside cage works + (let ([content (read-file-string (str cage-dir "/hello.txt"))]) + (assert! (string=? content "hello from seatbelt cage"))) + + ;; Write inside cage works + (write-file-string (str cage-dir "/new.txt") "wrote inside") + (assert! (string=? (read-file-string (str cage-dir "/new.txt")) + "wrote inside")) + + ;; Write outside cage is blocked. /Users is outside the cage + ;; (root is in /tmp, system paths are read-only). + (let ([blocked (not #t)]) + (guard (exn (#t (set! blocked #t))) + (write-file-string "/Users/jerboa-cage-escape" "nope")) + (assert! blocked)) + + ;; Reading non-allowed paths is blocked + (let ([blocked (not #t)]) + (guard (exn (#t (set! blocked #t))) + (read-file-string "/etc/master.passwd")) + (assert! blocked)) + + (displayln " child seatbelt cage: ok") + (exit 0))) + + (else + (let-values ([(wpid status) (waitpid pid)]) + (let ([exit-code (bitwise-arithmetic-shift-right + (bitwise-and status #xFF00) 8)]) + (if (= exit-code 0) + (displayln " seatbelt cage! fork test: ok") + (begin + (displayln (str " seatbelt cage! fork test: FAILED (exit " exit-code ")")) + (exit 1)))))))) + + (system (str "rm -rf " cage-dir)))) + +(unless (seatbelt-available?) + (displayln " [skipped — Seatbelt not available]")) + ;; ---- Double-cage prevention ---- (displayln "--- double cage prevention ---") @@ -303,4 +376,37 @@ (unless (capsicum-available?) (displayln " [skipped — Capsicum not available]")) +;; macOS Seatbelt double-cage prevention +(when (seatbelt-available?) + (let ([pid (fork-process)]) + (cond + ((= pid 0) + (guard (exn + (#t (display "CHILD ERROR: ") + (display-condition exn) (newline) + (exit 1))) + (let ([cage-dir "/tmp/jerboa-cage-test2-macos"]) + (when (file-exists? cage-dir) (system (str "rm -rf " cage-dir))) + (mkdir cage-dir) + (cage! (make-cage-config 'root: cage-dir 'temp-dir: "/tmp")) + (let ([got-error (not #t)]) + (try + (cage! (make-cage-config 'root: cage-dir 'temp-dir: "/tmp")) + (catch (e) (set! got-error #t))) + (assert! got-error) + (displayln " macOS double cage blocked: ok") + (exit 0))))) + (else + (let-values ([(wpid status) (waitpid pid)]) + (let ([exit-code (bitwise-arithmetic-shift-right + (bitwise-and status #xFF00) 8)]) + (if (= exit-code 0) + (displayln " macOS double cage test: ok") + (begin + (displayln (str " macOS double cage test: FAILED (exit " exit-code ")")) + (exit 1))))))))) + +(unless (seatbelt-available?) + (displayln " [skipped — Seatbelt not available]")) + (displayln "=== all cage tests passed ===") --- a/tests/test-seatbelt.ss +++ b/tests/test-seatbelt.ss @@ -92,6 +92,77 @@ (string? (seatbelt-no-write-profile)) #t) +;; ========== Cage profile builder ========== + +(printf "~%-- Cage profile builder --~%") + +(define (contains? haystack needle) + (let ([h-len (string-length haystack)] + [n-len (string-length needle)]) + (let loop ([i 0]) + (cond + [(> (+ i n-len) h-len) #f] + [(string=? (substring haystack i (+ i n-len)) needle) #t] + [else (loop (+ i 1))])))) + +(test "seatbelt-cage-profile returns string" + (string? (seatbelt-cage-profile 'read-write: '("/tmp"))) + #t) + +(test "seatbelt-cage-profile starts with (version 1)" + (let ([p (seatbelt-cage-profile 'read-write: '("/tmp"))]) + (and (string? p) + (>= (string-length p) 11) + (string=? (substring p 0 11) "(version 1)"))) + #t) + +(test "seatbelt-cage-profile denies by default" + (contains? (seatbelt-cage-profile 'read-write: '("/tmp")) + "(deny default)") + #t) + +(test "seatbelt-cage-profile includes read-write path" + (contains? (seatbelt-cage-profile 'read-write: '("/tmp")) + "/tmp") + #t) + +(test "seatbelt-cage-profile read-write grants both read and write" + (let ([p (seatbelt-cage-profile 'read-write: '("/tmp"))]) + (and (contains? p "file-read*") + (contains? p "file-write*"))) + #t) + +(test "seatbelt-cage-profile network: #t allows network*" + (contains? (seatbelt-cage-profile 'read-only: '("/usr") 'network: #t) + "(allow network*)") + #t) + +(test "seatbelt-cage-profile network: #f omits network*" + (not (contains? (seatbelt-cage-profile 'read-only: '("/usr") 'network: #f) + "(allow network*)")) + #t) + +(test "seatbelt-cage-profile execute: adds process-exec*" + (contains? (seatbelt-cage-profile + 'read-only: '("/usr/lib") + 'execute: '("/usr/bin")) + "process-exec*") + #t) + +(test "seatbelt-cage-profile rejects unknown keyword" + (guard (exn [#t #t]) + (seatbelt-cage-profile 'bogus: '("/tmp")) + #f) + #t) + +(test "seatbelt-macos-system-read-paths is a list" + (list? seatbelt-macos-system-read-paths) + #t) + +(test "seatbelt-macos-system-execute-paths is a list" + (list? seatbelt-macos-system-execute-paths) + #t) + ;; ========== Error handling for non-macOS ========== (printf "~%-- Error handling --~%")