Add jsh sandbox/limits/audit module set
ober
e2762bd30c1f311f2888996d392d3d241fa9e1c3
new file mode 100644 --- /dev/null +++ b/lib/std/net/allow-proxy.ss @@ -0,0 +1,381 @@ +#!chezscheme +;;; (std net allow-proxy) — Local HTTP CONNECT proxy with host allowlist +;;; +;;; Spins up a tiny HTTP/1.1 proxy on 127.0.0.1:N that accepts only the +;;; CONNECT method. Every CONNECT target is matched against an +;;; allowlist of host:port glob patterns; allowed targets are tunneled, +;;; denied targets get a 403 and the connection is closed. +;;; +;;; This is the bridge for sandboxed children that need network access +;;; to a small known set of hosts. Stock Seatbelt/Landlock have no way +;;; to allowlist by hostname — both deny network unconditionally. The +;;; child runs with all outbound network denied EXCEPT to 127.0.0.1:N, +;;; and uses this proxy via HTTP_PROXY / HTTPS_PROXY env vars. Most +;;; HTTP and HTTPS clients honor those (curl, wget, requests, fetch, +;;; reqwest). +;;; +;;; Allowlist patterns: +;;; +;;; "example.com:443" exact match +;;; "*.example.com:443" subdomain wildcard (single label) +;;; "**.example.com:443" any subdomain depth +;;; "example.com:*" any port +;;; +;;; Usage: +;;; +;;; (def p (allow-proxy 'host: "127.0.0.1" 'port: 0 +;;; 'allow: '("api.example.com:443" +;;; "*.googleapis.com:443") +;;; 'logger: (lambda (ev) (display ev) (newline)))) +;;; (allow-proxy-start! p) +;;; ;; ... use (allow-proxy-port p) for HTTP_PROXY env var +;;; (allow-proxy-stop! p) +;;; +;;; Threading: each accepted connection runs in its own Chez thread. +;;; Tunnel halves are two threads (client→origin and origin→client). +;;; +;;; Limits: this is not a hardened production proxy. It handles only +;;; CONNECT, no transparent HTTP, no caching, no TLS termination, no +;;; auth. Goal is sandbox-friendly egress with an auditable allow-list. + +(library (std net allow-proxy) + (export + allow-proxy? + allow-proxy + allow-proxy-start! + allow-proxy-stop! + allow-proxy-port + allow-proxy-host + allow-proxy-allowlist + allow-proxy-logger + allow-proxy-stats + + allow-proxy-host-allowed?) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch finally) + (only (std net tcp) + tcp-listen tcp-accept tcp-close tcp-connect + tcp-server-port)) + + ;; ---------- Record ---------- + + (defstruct allow-proxy-rec + (host port allowlist logger + server-mutex + server thread running? + stats)) + ;; stats: alist with counters + + (def allow-proxy? allow-proxy-rec?) + (def allow-proxy-host allow-proxy-rec-host) + (def allow-proxy-allowlist allow-proxy-rec-allowlist) + (def allow-proxy-logger allow-proxy-rec-logger) + (def allow-proxy-stats allow-proxy-rec-stats) + + (def (allow-proxy-port p) + (let ([srv (allow-proxy-rec-server p)]) + (cond + [srv (tcp-server-port srv)] + [else (allow-proxy-rec-port p)]))) + + (def (allow-proxy . opts) + (let ([host "127.0.0.1"] [port 0] [allow '()] [logger #f]) + (let lp ([xs opts]) + (cond + [(null? xs) #t] + [(null? (cdr xs)) + (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))] + [else (error 'allow-proxy "unknown option" (car xs))]) + (lp (cddr xs))])) + (make-allow-proxy-rec + host port allow logger + (make-mutex) + #f #f #f + (list (cons 'accepted 0) + (cons 'allowed 0) + (cons 'denied 0) + (cons 'errors 0))))) + + ;; ---------- 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)]) + (cond + [(null? xs) #f] + [(target-matches? target (car xs)) (car xs)] + [else (lp (cdr xs))])))) + + (def (target-matches? target pat) + ;; Split TARGET and PAT on ':' and match host part and port part + ;; independently. Host part supports '*' (one label) and '**' (any). + (let-values ([(thost tport) (split-host-port target)] + [(phost pport) (split-host-port pat)]) + (and (port-matches? tport pport) + (host-matches? thost phost)))) + + (def (split-host-port s) + (let lp ([i (- (string-length s) 1)]) + (cond + [(< i 0) (values s "")] + [(char=? (string-ref s i) #\:) + (values (substring s 0 i) + (substring s (+ i 1) (string-length s)))] + [else (lp (- i 1))]))) + + (def (port-matches? tp pp) + (cond + [(string=? pp "*") #t] + [(string=? pp "") #t] + [else (string=? tp pp)])) + + (def (host-matches? host pat) + (cond + [(string=? pat "*") #t] + [(string=? pat host) #t] + [(prefix? "**." pat) + ;; **.example.com matches any-suffix + (let ([suffix (substring pat 3 (string-length pat))]) + (or (string=? host suffix) + (and (> (string-length host) (+ 1 (string-length suffix))) + (string=? (substring host + (- (string-length host) + (+ 1 (string-length suffix))) + (string-length host)) + (string-append "." suffix)))))] + [(prefix? "*." pat) + ;; *.example.com matches exactly one extra label + (let ([suffix (substring pat 2 (string-length pat))]) + (and (> (string-length host) (+ 1 (string-length suffix))) + (string=? (substring host + (- (string-length host) + (+ 1 (string-length suffix))) + (string-length host)) + (string-append "." suffix)) + ;; ensure exactly one label before the suffix + (not (label-contains-dot? host suffix))))] + [else #f])) + + (def (label-contains-dot? host suffix) + ;; HOST is "a.b.c", SUFFIX is "c" → label is "a.b" → contains dot. + ;; Returns #t when the prefix label before SUFFIX contains a dot, + ;; which means *.suffix would NOT match. + (let ([pre-len (- (string-length host) (+ 1 (string-length suffix)))]) + (let lp ([i 0]) + (cond + [(>= i pre-len) #f] + [(char=? (string-ref host i) #\.) #t] + [else (lp (+ i 1))])))) + + (def (prefix? p s) + (and (>= (string-length s) (string-length p)) + (string=? (substring s 0 (string-length p)) p))) + + ;; ---------- Logging / stats ---------- + + (def (bump! p key) + (with-mutex (allow-proxy-rec-server-mutex p) + (let ([cell (assq key (allow-proxy-rec-stats p))]) + (when cell (set-cdr! cell (+ 1 (cdr cell))))))) + + (def (log! p ev) + (let ([logger (allow-proxy-rec-logger p)]) + (when logger + (try (logger ev) (catch (e) #f))))) + + ;; ---------- Server ---------- + + (def (allow-proxy-start! p) + (with-mutex (allow-proxy-rec-server-mutex p) + (cond + [(allow-proxy-rec-server p) #f] ;; already running + [else + (let ([srv (tcp-listen (allow-proxy-rec-host p) + (allow-proxy-rec-port p))]) + (allow-proxy-rec-server-set! p srv) + (allow-proxy-rec-running?-set! p #t) + (let ([t (fork-thread (lambda () (accept-loop p srv)))]) + (allow-proxy-rec-thread-set! p t)) + #t)]))) + + (def (allow-proxy-stop! p) + (with-mutex (allow-proxy-rec-server-mutex p) + (allow-proxy-rec-running?-set! p #f) + (let ([srv (allow-proxy-rec-server p)]) + (when srv (try (tcp-close srv) (catch (e) #f))) + (allow-proxy-rec-server-set! p #f) + (allow-proxy-rec-thread-set! p #f)))) + + (def (accept-loop p srv) + (let lp () + (when (allow-proxy-rec-running? p) + (let ([accepted + (try + (let-values ([(in out) (tcp-accept srv)]) + (cons in out)) + (catch (e) #f))]) + (cond + [accepted + (bump! p 'accepted) + (fork-thread + (lambda () + (handle-conn p (car accepted) (cdr accepted))))] + [else + ;; tcp-accept may return on shutdown, or this is the EAGAIN + ;; path; sleep briefly and retry while running. + (when (allow-proxy-rec-running? p) + (sleep (make-time 'time-duration 10000000 0)))]) ;; 10ms + (lp))))) + + ;; ---------- Per-connection handler ---------- + + (def (handle-conn p in out) + ;; Parse a CONNECT line, check allowlist, then tunnel. + (let ([line (try (read-line-textual in) + (catch (e) #f))]) + (cond + [(not line) + (log! p `(error (kind . malformed))) + (bump! p 'errors) + (close-pair in out)] + [else + ;; Drain headers up to blank line. + (try (drain-headers in) (catch (e) #f)) + (let-values ([(method host port) (parse-connect line)]) + (cond + [(not (equal? method "CONNECT")) + (write-status out 405 "method not allowed") + (log! p `(deny (reason . not-connect) (line . ,line))) + (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))) + (bump! p 'denied) + (close-pair in out)] + [else + (tunnel p in out host port)]))]))) + + (def (close-pair in out) + (try (close-port in) (catch (e) #f)) + (try (close-port out) (catch (e) #f))) + + (def (read-line-textual port) + ;; Read until CRLF or LF. Returns string without terminator. + (let ([acc (open-output-string)]) + (let lp () + (let ([c (get-char port)]) + (cond + [(eof-object? c) + (let ([s (get-output-string acc)]) + (if (= 0 (string-length s)) #f s))] + [(char=? c #\newline) (get-output-string acc)] + [(char=? c #\return) + (let ([n (get-char port)]) + (unless (or (eof-object? n) (char=? n #\newline)) + (write-char n acc)) + (get-output-string acc))] + [else + (write-char c acc) + (lp)]))))) + + (def (drain-headers in) + (let lp () + (let ([line (read-line-textual in)]) + (cond + [(not line) #f] + [(= 0 (string-length line)) #t] + [else (lp)])))) + + (def (parse-connect line) + ;; "CONNECT host:port HTTP/1.1" + (let-values ([(method rest) (split-on-space line)]) + (let-values ([(target _ver) (split-on-space rest)]) + (let-values ([(host port-str) (split-host-port target)]) + (values method host + (or (string->number port-str) 0)))))) + + (def (split-on-space s) + (let ([n (string-length s)]) + (let lp ([i 0]) + (cond + [(>= i n) (values s "")] + [(char=? (string-ref s i) #\space) + (values (substring s 0 i) + (substring s (+ i 1) n))] + [else (lp (+ i 1))])))) + + (def (write-status out code msg) + (display "HTTP/1.1 " out) + (display code out) + (display " " out) + (display msg out) + (display "\r\n\r\n" out) + (flush-output-port out)) + + ;; ---------- Tunnel ---------- + + (def (tunnel p client-in client-out host port) + (log! p `(connect (host . ,host) (port . ,port))) + (bump! p 'allowed) + (let ([conn (try (call-with-values + (lambda () (tcp-connect host port)) + cons) + (catch (e) #f))]) + (cond + [(not conn) + (write-status client-out 502 "upstream connect failed") + (close-pair client-in client-out)] + [else + (let ([origin-in (car conn)] [origin-out (cdr conn)]) + (write-status client-out 200 "Connection established") + ;; Two shuttle threads, each copies one direction. + (let ([t1 (fork-thread + (lambda () (copy-loop client-in origin-out)))] + [t2 (fork-thread + (lambda () (copy-loop origin-in client-out)))]) + ;; Wait for either direction to close (no thread-join in + ;; Chez; poll with a brief sleep). Once one side closes, + ;; we tear down both. + (let wait () + (cond + [(or (and (proxy-port-eof? client-in) + (proxy-port-eof? origin-in))) + #f] + [else + (sleep (make-time 'time-duration 50000000 0)) + (wait)])) + (close-pair client-in client-out) + (close-pair origin-in origin-out)))]))) + + (def (proxy-port-eof? p) + (try (port-eof? p) (catch (e) #t))) + + (def (copy-loop in out) + (let ([buf (make-bytevector 4096)]) + (let lp () + (let ([n (try (get-bytevector-some! in buf 0 4096) + (catch (e) (eof-object)))]) + (cond + [(eof-object? n) + (try (close-port out) (catch (e) #f))] + [(<= n 0) + (try (close-port out) (catch (e) #f))] + [else + (try + (begin + (put-bytevector out buf 0 n) + (flush-output-port out) + (lp)) + (catch (e) (try (close-port out) (catch (e) #f))))]))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/os/exec-id.ss @@ -0,0 +1,206 @@ +#!chezscheme +;;; (std os exec-id) — Executable identity resolution +;;; +;;; Resolves a command name (or absolute path) through an explicit PATH, +;;; canonicalizes via realpath(3), captures the underlying device/inode, +;;; and optionally hashes the file. Lets higher-level policy flag a +;;; binary by resolved identity rather than by name alone — important +;;; for shadowed `node`, `npm`, etc. +;;; +;;; Usage: +;;; (exec-id-resolve "node") +;;; => #f if not found, else an exec-id record +;;; +;;; (exec-id-resolve "node" path: "/usr/bin:/usr/local/bin" hash?: #t) +;;; +;;; Record: +;;; argv0 original requested name (or absolute path) +;;; path first existing executable on PATH (absolute) +;;; realpath canonicalized path (symlinks resolved) +;;; dev device number from stat +;;; ino inode number from stat +;;; sha256 lowercase hex digest, or #f if not computed +;;; symlink? #t when path differs from realpath +;;; exists? #t when an entry was found at all + +(library (std os exec-id) + (export + exec-id? + make-exec-id + exec-id-argv0 + exec-id-path + exec-id-realpath + exec-id-dev + exec-id-ino + exec-id-sha256 + exec-id-symlink? + exec-id-exists? + exec-id->alist + + exec-id-resolve + exec-id-realpath-of + exec-id-search-path + exec-id-current-path) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch finally) + (only (std os posix) posix-stat stat-dev stat-ino free-stat + posix-access X_OK F_OK) + (only (std crypto sha256-pure) sha256-hex)) + + ;; ---------- FFI ---------- + ;; realpath(3): canonicalize a path; returns NULL on error. + ;; We pass our own buffer (PATH_MAX=4096) so the result is owned by us. + (def c-realpath + (foreign-procedure "realpath" (string u8*) void*)) + + (def PATH_MAX 4096) + + (def (realpath* path) + (let ([buf (make-bytevector PATH_MAX 0)]) + (let ([rc (c-realpath path buf)]) + (if (= rc 0) + #f + (let loop ([i 0] [acc '()]) + (if (or (= i PATH_MAX) + (= (bytevector-u8-ref buf i) 0)) + (list->string (reverse acc)) + (loop (+ i 1) + (cons (integer->char (bytevector-u8-ref buf i)) + acc)))))))) + + ;; ---------- Record ---------- + + (defstruct exec-id + (argv0 path realpath dev ino sha256 symlink? exists?)) + + (def (exec-id->alist x) + `((argv0 . ,(exec-id-argv0 x)) + (path . ,(exec-id-path x)) + (realpath . ,(exec-id-realpath x)) + (dev . ,(exec-id-dev x)) + (ino . ,(exec-id-ino x)) + (sha256 . ,(exec-id-sha256 x)) + (symlink? . ,(exec-id-symlink? x)) + (exists? . ,(exec-id-exists? x)))) + + ;; ---------- PATH search ---------- + + (def (string-index-char s ch start) + (let ([n (string-length s)]) + (let lp ([i start]) + (cond + [(>= i n) #f] + [(char=? (string-ref s i) ch) i] + [else (lp (+ i 1))])))) + + (def (split-path-string s) + ;; Split on ':' — empty components mean "current directory" per POSIX, + ;; but we deliberately drop them since callers running policy-controlled + ;; launches should not pick up CWD silently. + (if (or (not s) (string=? s "")) + '() + (let lp ([start 0] [acc '()]) + (let ([j (string-index-char s #\: start)]) + (if j + (let ([part (substring s start j)]) + (lp (+ j 1) + (if (string=? part "") acc (cons part acc)))) + (let ([part (substring s start (string-length s))]) + (reverse (if (string=? part "") acc (cons part acc))))))))) + + (def (exec-id-current-path) + ;; Default PATH used when caller passes no override. + (or (getenv "PATH") "")) + + (def (abs-path? p) + (and (> (string-length p) 0) + (char=? (string-ref p 0) #\/))) + + (def (join-dir-name dir name) + (let ([n (string-length dir)]) + (cond + [(= n 0) name] + [(char=? (string-ref dir (- n 1)) #\/) + (string-append dir name)] + [else (string-append dir "/" name)]))) + + (def (executable? path) + ;; posix-access returns #t when the mode is granted. + (try (and (posix-access path X_OK) #t) + (catch (e) #f))) + + (def (exec-id-search-path name path-string) + ;; Returns the absolute path to the first executable named NAME found + ;; on PATH-STRING, or #f. If NAME is itself absolute or contains '/', + ;; PATH is ignored (matches POSIX `execvp` semantics). + (cond + [(or (abs-path? name) + (string-index-char name #\/ 0)) + (and (executable? name) name)] + [else + (let lp ([dirs (split-path-string path-string)]) + (cond + [(null? dirs) #f] + [else + (let ([cand (join-dir-name (car dirs) name)]) + (if (executable? cand) + cand + (lp (cdr dirs))))]))])) + + ;; ---------- Hashing ---------- + + (def (read-whole-file path) + (let* ([port (open-file-input-port path)] + [bv (get-bytevector-all port)]) + (close-port port) + (if (eof-object? bv) (make-bytevector 0) bv))) + + (def (hash-file path) + (try (sha256-hex (read-whole-file path)) + (catch (e) #f))) + + ;; ---------- Stat helpers ---------- + + (def (stat-pair path) + ;; Returns (values dev ino) or (values #f #f) on failure. + (try (let ([buf (posix-stat path)]) + (let ([d (stat-dev buf)] + [i (stat-ino buf)]) + (free-stat buf) + (values d i))) + (catch (e) (values #f #f)))) + + (def (exec-id-realpath-of path) + (or (realpath* path) path)) + + ;; ---------- Public entry ---------- + + (def exec-id-resolve + (case-lambda + [(name) (exec-id-resolve* name (exec-id-current-path) #f)] + [(name . opts) + (let lp ([opts opts] [path (exec-id-current-path)] [hash? #f]) + (cond + [(null? opts) (exec-id-resolve* name path hash?)] + [(eq? (car opts) 'path:) + (lp (cddr opts) (cadr opts) hash?)] + [(eq? (car opts) 'hash?:) + (lp (cddr opts) path (and (cadr opts) #t))] + [else + (error 'exec-id-resolve "unknown option" (car opts))]))])) + + (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)] + [else + (let* ([rp (or (realpath* found) found)]) + (let-values ([(d i) (stat-pair rp)]) + (make-exec-id name found rp d i + (and hash? (hash-file rp)) + (not (string=? found rp)) + #t)))]))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/os/limits.ss @@ -0,0 +1,219 @@ +#!chezscheme +;;; (std os limits) — Portable resource limits +;;; +;;; Policy + installer for the resource limits a supervising parent +;;; wants applied to a child. Two enforcement paths: +;;; +;;; 1. In-process setrlimit (POSIX). Use it AFTER fork in the child +;;; so the parent stays unrestricted. Affects only the calling +;;; process; child subprocesses inherit but can lower further. +;;; +;;; 2. Parent-side counters: wall-clock timeout and stdout/stderr byte +;;; caps are not setrlimit-shaped. They are recorded here for the +;;; supervisor module (std os supervise) to honour. +;;; +;;; Linux cgroup v2 enforcement is the right answer for tree-wide memory +;;; / pid / cpu containment, but it requires permissions or a delegated +;;; controller and is therefore exposed only via the capability report. +;;; Callers who detect cgroup support can set up their own slice. +;;; +;;; Limit kinds (symbols): +;;; +;;; mem memory bytes (RLIMIT_AS) +;;; cpu-sec CPU seconds (RLIMIT_CPU) +;;; time-ms wall-clock ms (parent-side timeout) +;;; pids process count (RLIMIT_NPROC; user-wide on some kernels) +;;; nofile open file descriptors (RLIMIT_NOFILE) +;;; fsize file size cap (RLIMIT_FSIZE) +;;; out-bytes stdout+stderr cap (parent-side counter) +;;; core core dump size (RLIMIT_CORE) +;;; +;;; Returned installation results: +;;; +;;; 'installed — applied via setrlimit +;;; 'parent — recorded for parent-side enforcement (time-ms, out-bytes) +;;; 'degraded — kernel accepted a softer limit than requested +;;; 'failed — setrlimit returned an error +;;; 'unavailable — no backend for this limit on this OS + +(library (std os limits) + (export + limit-policy? + make-limit-policy + limit-policy + limit-policy-set! + limit-policy-get + limit-policy-pairs + limit-policy-install! + limit-policy-explain + + limits-capabilities) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch finally) + (only (std os posix) posix-setrlimit posix-getrlimit) + (only (std os platform) platform-linux? platform-macos? + platform-bsd? platform-name)) + + ;; (std os posix) only encodes Linux RLIMIT_* numbers; macOS/FreeBSD + ;; use a different layout (NOFILE/NPROC swap, AS is RSS-aliased on + ;; macOS and lives at 10 on FreeBSD). We carry our own platform-aware + ;; table here so callers actually limit what they asked for. + (def *rl-cpu* 0) + (def *rl-fsize* 1) + (def *rl-data* 2) + (def *rl-core* 4) + (def *rl-nproc* (cond [(platform-linux?) 6] [else 7])) + (def *rl-nofile* (cond [(platform-linux?) 7] [else 8])) + (def *rl-as* + (cond + [(platform-linux?) 9] + [(member (platform-name) '("freebsd")) 10] + [(platform-macos?) 5] ;; aliased to RSS; soft cap only + [else 9])) + + (defstruct limit-policy (entries)) + ;; entries: alist (kind . value) + + (def (limit-policy) + (make-limit-policy '())) + + ;; ---------- Mutators ---------- + + (def (limit-policy-set! pol kind value) + (unless (memq kind '(mem cpu-sec time-ms pids nofile fsize out-bytes core)) + (error 'limit-policy-set! "unknown limit kind" kind)) + (let lp ([xs (limit-policy-entries pol)] [acc '()] [hit #f]) + (cond + [(null? xs) + (limit-policy-entries-set! + pol + (if hit + (reverse acc) + (reverse (cons (cons kind value) acc))))] + [(eq? (car (car xs)) kind) + (lp (cdr xs) (cons (cons kind value) acc) #t)] + [else + (lp (cdr xs) (cons (car xs) acc) hit)]))) + + (def (limit-policy-get pol kind) + (cond + [(assq kind (limit-policy-entries pol)) => cdr] + [else #f])) + + (def (limit-policy-pairs pol) + (limit-policy-entries pol)) + + ;; ---------- Capability report ---------- + + (def (limits-capabilities) + ;; Returns alist (kind . status) describing what we can enforce on + ;; the current platform. + (let ([cgroup-status + (cond + [(and (platform-linux?) + (file-exists? "/sys/fs/cgroup/cgroup.controllers")) + 'available-cgroup-v2] + [(platform-linux?) 'available-cgroup-v1-or-disabled] + [else 'unavailable])] + ;; macOS rejects setrlimit on every memory-shaped limit + ;; (RLIMIT_AS/RSS/DATA all return EINVAL). Surface that as + ;; 'degraded so callers don't trust mem enforcement on Darwin. + [mem-status (cond + [(platform-macos?) 'degraded] + [(platform-linux?) 'installed] + [else 'installed])]) + `((mem . ,mem-status) + (cpu-sec . installed) + (time-ms . parent) + (pids . ,(if (platform-linux?) 'degraded 'installed)) + (nofile . installed) + (fsize . installed) + (out-bytes . parent) + (core . installed) + (cgroup . ,cgroup-status) + (platform . ,(platform-name))))) + + ;; ---------- Installer ---------- + + (def (limit-policy-install! pol) + ;; Walk entries, applying each. Returns alist of (kind . result). + (let lp ([xs (limit-policy-entries pol)] [out '()]) + (cond + [(null? xs) (reverse out)] + [else + (let* ([kind (car (car xs))] + [val (cdr (car xs))] + [res (install-one kind val)]) + (lp (cdr xs) (cons (cons kind res) out)))]))) + + (def (mem-rlimit-code) + ;; RLIMIT_AS on Linux/FreeBSD limits the address space cleanly. + ;; macOS aliases AS to RSS and ignores the hard cap; RLIMIT_DATA is + ;; the next closest, but Chez has already mapped its arena, so + ;; lowering DATA on the parent fails. We pick AS where it works + ;; and DATA on macOS — callers should apply this in a forked child + ;; before the heap is sized. + (cond + [(platform-macos?) *rl-data*] + [else *rl-as*])) + + (def (install-one kind val) + (case kind + [(mem) + (cond + [(platform-macos?) + ;; setrlimit-for-memory is a no-op on Darwin; don't pretend. + 'unavailable] + [else (set-rlim 'mem (mem-rlimit-code) val)])] + [(cpu-sec) (set-rlim 'cpu-sec *rl-cpu* val)] + [(nofile) (set-rlim 'nofile *rl-nofile* val)] + [(fsize) (set-rlim 'fsize *rl-fsize* val)] + [(core) (set-rlim 'core *rl-core* val)] + [(pids) + ;; RLIMIT_NPROC is user-wide on many kernels; still useful as a + ;; soft ceiling but record as 'degraded so callers know. + (let ([r (set-rlim 'pids *rl-nproc* val)]) + (if (eq? r 'installed) 'degraded r))] + [(time-ms) 'parent] + [(out-bytes) 'parent] + [else 'unavailable])) + + (def (set-rlim name code val) + (try + (begin + (posix-setrlimit code val val) + ;; Read it back: kernel may clamp the hard limit, in which case + ;; we are 'degraded but still installed. Cheap to verify. + (let-values ([(soft hard) (posix-getrlimit code)]) + (cond + [(= soft val) 'installed] + [(< soft val) 'degraded] + [else 'installed]))) + (catch (e) 'failed))) + + ;; ---------- Explain ---------- + + (def (limit-policy-explain pol) + (let ([port (open-output-string)]) + (display "limit policy:" port) (newline port) + (for-each + (lambda (kv) + (display " " port) + (display (car kv) port) + (display " = " port) + (display (cdr kv) port) + (newline port)) + (limit-policy-entries pol)) + (display "capabilities:" port) (newline port) + (for-each + (lambda (kv) + (display " " port) + (display (car kv) port) + (display " : " port) + (display (cdr kv) port) + (newline port)) + (limits-capabilities)) + (get-output-string port))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/os/limits/sandbox.ss @@ -0,0 +1,553 @@ +#!chezscheme +;;; (std os limits sandbox) — Unified sandbox policy + launcher +;;; +;;; Wraps the platform-specific sandbox backends in (std os sandbox) +;;; and the resource-limit installer in (std os limits) behind a single +;;; policy record. Designed to be the one entry point that callers like +;;; jsh use to build a sandboxed `exec` plan without having to know +;;; whether they are on Linux, macOS, FreeBSD, or OpenBSD. +;;; +;;; The policy is a passive declaration of what the caller wants. The +;;; sandbox layer picks the strongest available backend on the current +;;; OS and reports back, per-axis, whether the request was fully honored, +;;; partially honored, or unavailable. Callers who care about the +;;; distinction read `sandbox-capabilities` (static, OS-level) or the +;;; per-axis report inside the launch result (dynamic, per-launch). +;;; +;;; Policy axes: +;;; +;;; read-paths list of read-only paths +;;; write-paths list of read/write paths +;;; exec-paths list of execute paths +;;; net 'allow | 'deny | 'local-only | 'allowlist +;;; net-allow list of host:port for 'allowlist +;;; syscalls 'unrestricted | 'safe | 'minimal (Linux seccomp hint) +;;; ptrace? whether the child may be ptraced (defaults #f) +;;; no-new-privs? whether to set PR_SET_NO_NEW_PRIVS (Linux only) +;;; +;;; Backend mapping: +;;; +;;; Linux → Landlock (paths) + seccomp (syscalls) + rlimit +;;; macOS → Seatbelt SBPL (paths+net via SBPL) + rlimit +;;; — note: net allowlist beyond local-only is not expressible +;;; in stock SBPL; degrade to 'deny outbound and let the +;;; caller pair with (std net allow-proxy) +;;; FreeBSD → Capsicum (paths via pre-open fds) + rlimit +;;; OpenBSD → pledge + unveil (paths and syscall classes) + rlimit +;;; other → rlimit only; everything else 'unavailable +;;; +;;; Result of `sandbox-launch`: +;;; +;;; process-result from supervise, plus a sandbox-report alist: +;;; ((fs . installed|degraded|unavailable) +;;; (exec . installed|degraded|unavailable) +;;; (net . installed|degraded|unavailable) +;;; (syscalls . installed|degraded|unavailable) +;;; (limits . (kind . status) ...) +;;; (backend . landlock|seatbelt|capsicum|pledge|none)) + +(library (std os limits sandbox) + (export + sandbox-policy? + make-sandbox-policy + sandbox-policy + sandbox-policy-set! + sandbox-policy-get + sandbox-policy-pairs + + sandbox-capabilities + sandbox-backend + sandbox-policy-explain + + sandbox-launch + sandbox-prepare-child! + sandbox-policy-sbpl ;; debug: render policy as SBPL string (macOS only) + + sandbox-result? + make-sandbox-result + sandbox-result-process + sandbox-result-report + sandbox-result-backend + sandbox-result-limit-report) + + (import (chezscheme) + (only (jerboa core) def defstruct try catch finally) + (only (std os platform) platform-linux? platform-macos? + platform-bsd? platform-name) + (only (std os limits) + limit-policy? + limit-policy + limit-policy-install! + limits-capabilities) + (only (std os supervise) + launch-spec + launch-spec? + launch-spec-command + launch-spec-env + launch-spec-cwd + launch-spec-capture-stdout? + launch-spec-capture-stderr? + launch-spec-stdout-cap-bytes + launch-spec-stderr-cap-bytes + launch-spec-timeout-ms + launch-spec-child-pre-exec + launch-spec-search-path? + supervise-run + process-result? + process-result-status + 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. + '((read-paths . ()) + (write-paths . ()) + (exec-paths . ()) + (net . deny) + (net-allow . ()) + (syscalls . safe) + (ptrace? . #f) + (no-new-privs? . #t)))) + + ;; Re-export under the spec name `make-sandbox-policy` so callers can + ;; use either the factory `(sandbox-policy)` (no args, neutral) or the + ;; constructor `(make-sandbox-policy 'entries)`. + (def make-sandbox-policy make-sandbox-policy-rec) + (def sandbox-policy? sandbox-policy-rec?) + + (def (sandbox-policy-set! pol key val) + (let lp ([xs (sandbox-policy-rec-entries pol)] [acc '()] [hit #f]) + (cond + [(null? xs) + (sandbox-policy-rec-entries-set! + pol + (if hit (reverse acc) + (reverse (cons (cons key val) acc))))] + [(eq? (car (car xs)) key) + (lp (cdr xs) (cons (cons key val) acc) #t)] + [else + (lp (cdr xs) (cons (car xs) acc) hit)]))) + + (def (sandbox-policy-get pol key) + (cond + [(assq key (sandbox-policy-rec-entries pol)) => cdr] + [else #f])) + + (def (sandbox-policy-pairs pol) + (sandbox-policy-rec-entries pol)) + + ;; ---------- Backend detection ---------- + + (def (sandbox-backend) + ;; Pick the strongest backend available for the current OS. + ;; This is a static report — does not actually try to apply anything. + (cond + [(and (platform-linux?) + (file-exists? "/sys/kernel/security/landlock")) + 'landlock] + [(platform-linux?) 'landlock] ;; assume present; fail at launch + [(platform-macos?) 'seatbelt] + [(and (platform-bsd?) + (member (platform-name) '("freebsd"))) 'capsicum] + [(and (platform-bsd?) + (member (platform-name) '("openbsd"))) 'pledge] + [else 'none])) + + ;; ---------- Capability report ---------- + + (def (sandbox-capabilities) + ;; Static, OS-level report describing per-axis support. Status: + ;; installed — fully enforceable by this backend + ;; degraded — partially enforceable / known caveats + ;; unavailable — no backend on this OS + (let ([be (sandbox-backend)]) + (case be + [(landlock) + `((backend . landlock) + (fs . installed) + (exec . installed) + (net . degraded) ;; needs seccomp + cgroup for full + (syscalls . installed) ;; via seccomp + (ptrace . installed) + (limits . ,(limits-capabilities)))] + [(seatbelt) + `((backend . seatbelt) + (fs . installed) + (exec . degraded) ;; SBPL exec rules coarser than Landlock + (net . degraded) ;; allowlist needs external proxy + (syscalls . unavailable) ;; no per-call filtering on macOS + (ptrace . installed) + (limits . ,(limits-capabilities)))]