security: harden posix ffi buffers
ober
fc22f61bed10e024efd8230c6f1618bf225dd8e6
--- a/docs/ffi-audit.md +++ b/docs/ffi-audit.md @@ -31,7 +31,7 @@ Latest summary from `tools/ffi-audit-report.ss`: (foreign-callable 7) (pointer-sites 287) (width-sensitive-sites 145) - (blocking-candidates 57) + (blocking-candidates 59) (blocking-without-collect-safe 0) (hazard-site-count 340) (blocking-review-sites 0) @@ -71,7 +71,7 @@ caller reconciliation. The Scheme source inventory now ignores generated `.sls` mirrors and string literals in code generators, so the counts reflect source FFI forms instead of -documentation or emitted-code text. All 47 blocking candidate bindings are now +documentation or emitted-code text. All 59 blocking candidate bindings are now either `__collect_safe` or classified as nonblocking by the scanner; the generated report has 0 `blocking-without-collect-safe` sites. @@ -206,7 +206,12 @@ The Scheme `(std net tls-rustls)` wrapper now uses a shared `dynamic-wind` foreign-buffer helper for rustls reads and writes, bounds foreign-to-Scheme and Scheme-to-foreign byte copies, documents zero-handle checks for Rust TLS handle returns, and carries width/status invariants for timeout, nonblocking, and fd -helpers. +helpers. The Scheme `(std os posix)` wrapper now checks the platform errno +pointer before dereferencing it, ensures fds 0/1/2 are open after `setsid`, +runs collect-safe `read`/`write` through scoped foreign `void*` buffers, copies +`stat`/`fstat`/`lstat` results out of scoped native storage into bytevectors, +and keeps `free-stat` as a compatibility no-op for callers using the exported +stat accessors. `secure_fs.rs` now documents descriptor-relative `openat`/`mkdirat`, fd duplication/ownership transfer, stat buffers, directory stream lifecycle, --- a/docs/kimi3-security-recommmendations.md +++ b/docs/kimi3-security-recommmendations.md @@ -746,7 +746,12 @@ the current inventory and remediation trail now live in [ffi-audit.md](ffi-audit foreign-buffer helper for rustls reads and writes, bounds foreign-to-Scheme and Scheme-to-foreign byte copies, documents zero-handle checks for Rust TLS handle returns, and carries width/status invariants for timeout, nonblocking, - and fd helpers. + and fd helpers. The Scheme `(std os posix)` wrapper now checks the platform + errno pointer before dereferencing it, reopens missing standard fds through + `/dev/null` after `setsid`, routes collect-safe `read`/`write` through + scoped foreign `void*` buffers, validates terminal and stat buffer bounds, + and returns `stat`/`fstat`/`lstat` data as bytevectors copied out of scoped + native storage. `wasm_sm.rs` now compiles under `unsafe_op_in_unsafe_fn` for the SpiderMonkey feature, bounds C ABI buffers, validates host-memory offsets, converts poisoned handle-store locks into normal FFI errors, and documents @@ -763,7 +768,8 @@ the current inventory and remediation trail now live in [ffi-audit.md](ffi-audit shutdown invariants for blocked TLS I/O. The generated report now shows 390 annotated native unsafe sites, 0 remaining unsafe review sites, and 0 Scheme blocking calls missing `__collect_safe`; the clean-tree Scheme FFI inventory - now reports 340 remaining provisional safety-review sites. + now reports 59 blocking candidates, 0 blocking-review sites, and 340 + remaining provisional safety-review sites. Remaining work: finish per-binding Scheme FFI review and targeted scanner rules. --- a/docs/security-reference.md +++ b/docs/security-reference.md @@ -718,7 +718,7 @@ Callers should not treat `allow-degraded?` as successful sandbox installation. ## 7. Parser Hardening -Phases 1-4 are implemented and tested (42 tests in `tests/test-security2-parsers.ss`). Phase 5 (FFI audit) has a reproducible inventory in [ffi-audit.md](ffi-audit.md) via `make ffi-audit-report`; native unsafe review and selected Scheme FFI slices such as Seatbelt, sandbox compatibility, `exec-id`, `regex-native`, the unified regex facade, `compress native-rust`, `crypto native-rust`, `net tls`, and `net tls-rustls` are remediated, while broad Scheme per-binding remediation remains open. +Phases 1-4 are implemented and tested (42 tests in `tests/test-security2-parsers.ss`). Phase 5 (FFI audit) has a reproducible inventory in [ffi-audit.md](ffi-audit.md) via `make ffi-audit-report`; native unsafe review and selected Scheme FFI slices such as Seatbelt, sandbox compatibility, `exec-id`, `regex-native`, the unified regex facade, `compress native-rust`, `crypto native-rust`, `net tls`, `net tls-rustls`, and `std os posix` are remediated, while broad Scheme per-binding remediation remains open. ### Depth limits @@ -1000,7 +1000,7 @@ These are known gaps documented as current limitations, not implementation promi `(std crypto native-rust)` / `(std crypto password)`. The high-level HMAC, AEAD, KDF, and password-hashing compatibility APIs now route through the Rust native crypto boundary. -- **FFI audit (Phase 5 of parser hardening) is in progress.** `make ffi-audit-report` inventories Scheme FFI sites, Rust C ABI exports, pointer/width-sensitive bindings, blocking candidates, and Rust unsafe sites. Native unsafe review and selected Scheme FFI slices, including the regex, compression, crypto, OpenSSL TLS, and rustls TLS wrappers, are remediated; the remaining Scheme per-binding null-return, bounds, ownership, and GC-safety review is tracked in [ffi-audit.md](ffi-audit.md). +- **FFI audit (Phase 5 of parser hardening) is in progress.** `make ffi-audit-report` inventories Scheme FFI sites, Rust C ABI exports, pointer/width-sensitive bindings, blocking candidates, and Rust unsafe sites. Native unsafe review and selected Scheme FFI slices, including the regex, compression, crypto, OpenSSL TLS, rustls TLS, and POSIX wrappers, are remediated; the remaining Scheme per-binding null-return, bounds, ownership, and GC-safety review is tracked in [ffi-audit.md](ffi-audit.md). - **No red team evaluation.** No independent adversarial testing has been performed. - **Secure memory still exposes a raw region escape hatch.** The high-level `secure-bytevector` API is bounds-checked and integrated with --- a/docs/status.md +++ b/docs/status.md @@ -25,7 +25,7 @@ release artifacts are built as Jerboa multicall binaries with `jerboa`, | Area | Current state | Remaining work | |---|---|---| | Kimi security handoff | [kimi3-security-recommmendations.md](kimi3-security-recommmendations.md) is the backlog. Dated evidence and review manifests live under [reviews/](reviews/). | Keep new security evidence in dated review records and summarize the current release state here. | -| FFI audit phase 5 | [ffi-audit.md](ffi-audit.md) records the scanner output, provisional Scheme binding verdicts, and native Rust export inventory. `make native-export-review-check` gates native export decisions. The worker-launch native path in `aproc.rs`/`seccomp.rs`, crypto FFI buffer path in `crypto.rs`, secure-memory region lifecycle in `secure_mem.rs`, secure filesystem capability boundary in `secure_fs.rs`, TLS native ABI in `tls.rs`, Ed25519/X25519 key-agreement buffers, compression buffers, HTTP parse/writev boundary, embed-crypto ABI, integrity ABI, regex-native ABI, process-control ABI, pcap ABI, inotify ABI, epoll/eventfd ABI, antidebug ABI, SOCKS5 server ABI, PostgreSQL native ABI, Landlock native ABI, wasmi sandbox ABI, SpiderMonkey WASM ABI, DuckDB native ABI, X.509 native ABI, SQLite native ABI, the Scheme Seatbelt `sandbox_init` error-buffer paths, the retired `(std os sandbox)` compatibility surface, `(std os exec-id)` realpath/hash helpers, and the Scheme `(std regex-native)`, `(std regex)`, `(std compress native-rust)`, `(std crypto native-rust)`, `(std net tls)`, and `(std net tls-rustls)` out-parameter or foreign-buffer wrappers now have nearby `SAFETY:` comments or equivalent checked FFI/scanner invariants. Generated counts are at 0 unannotated native unsafe sites, 0 Scheme blocking bindings missing `__collect_safe`, and 340 remaining provisional Scheme safety-review sites. | Finish per-binding Scheme FFI review and targeted scanner rules for the remaining provisional verdicts. | +| FFI audit phase 5 | [ffi-audit.md](ffi-audit.md) records the scanner output, provisional Scheme binding verdicts, and native Rust export inventory. `make native-export-review-check` gates native export decisions. The worker-launch native path in `aproc.rs`/`seccomp.rs`, crypto FFI buffer path in `crypto.rs`, secure-memory region lifecycle in `secure_mem.rs`, secure filesystem capability boundary in `secure_fs.rs`, TLS native ABI in `tls.rs`, Ed25519/X25519 key-agreement buffers, compression buffers, HTTP parse/writev boundary, embed-crypto ABI, integrity ABI, regex-native ABI, process-control ABI, pcap ABI, inotify ABI, epoll/eventfd ABI, antidebug ABI, SOCKS5 server ABI, PostgreSQL native ABI, Landlock native ABI, wasmi sandbox ABI, SpiderMonkey WASM ABI, DuckDB native ABI, X.509 native ABI, SQLite native ABI, the Scheme Seatbelt `sandbox_init` error-buffer paths, the retired `(std os sandbox)` compatibility surface, `(std os exec-id)` realpath/hash helpers, and the Scheme `(std regex-native)`, `(std regex)`, `(std compress native-rust)`, `(std crypto native-rust)`, `(std net tls)`, `(std net tls-rustls)`, and `(std os posix)` out-parameter or foreign-buffer wrappers now have nearby `SAFETY:` comments or equivalent checked FFI/scanner invariants. Generated counts are at 0 unannotated native unsafe sites, 0 Scheme blocking bindings missing `__collect_safe`, and 340 remaining provisional Scheme safety-review sites. | Finish per-binding Scheme FFI review and targeted scanner rules for the remaining provisional verdicts. | | Native Rust exports | The native export review now has 190 exported functions: 183 tracked Scheme references and 7 retained standalone C/binary helpers. The previous 35 no-Scheme-reference removal candidates no longer have C ABI export markers. | Re-run `make native-export-review-check` whenever adding or removing native exports. | | Confined worker | `(std security worker)` provides the facade, audit lifecycle, output caps, deadlines, process-group kill, memory rlimit pre-exec setup, Linux syscall/ptrace seccomp pre-exec setup, Linux Landlock filesystem/TCP-connect setup for requested axes, macOS Seatbelt deny-default path/exec/no-network setup for supported axes, standard worker-eval Capsicum entry on FreeBSD, explicit sandbox-axis refusal, egress proxy env wiring, and platform CI smoke for Linux/macOS/FreeBSD sandbox paths. | Keep Linux/macOS/FreeBSD parity tests current; finish arbitrary-command/proxy-aware Capsicum worker paths. | | Fuzzing | `tests/fuzz/corpus/` has 15 checked-in seed inputs, `tests/fuzz/regression/` has 11 crash/rejection regressions, `make fuzz-smoke` runs the deterministic regression gate first, and GitHub CI runs smoke fuzzing normally plus deep fuzzing on scheduled daily runs. | Keep adding minimized corpus and regression inputs for every parser/security bug found. | --- a/lib/std/os/posix.ss +++ b/lib/std/os/posix.ss @@ -18,7 +18,7 @@ posix-getpid posix-getppid posix-setpgid posix-getpgid posix-tcsetpgrp posix-tcgetpgrp - posix-setsid + posix-setsid ; jerboa-security: suppress daemon-missing-fd-hygiene -- posix-setsid calls ensure-standard-fds-open! after successful setsid ;; Wait status decoders WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG @@ -99,7 +99,7 @@ ;; errno is thread-local via __errno_location on Linux / __error on FreeBSD (def c-errno-location - (try (let ((mt (symbol->string (machine-type)))) + (try (let ((mt (symbol->string (machine-type)))) ; jerboa-security: suppress non-constant-time-secret-compare -- machine type suffix checks are platform metadata, not secret material (if (or (memq (machine-type) '(a6fb ta6fb i3fb ti3fb arm64fb)) @@ -107,14 +107,21 @@ (string=? (substring mt (- (string-length mt) 3) (string-length mt)) "osx"))) - (foreign-procedure "__error" () void*) + (foreign-procedure "__error" () void*) ; jerboa-security: suppress ffi-pointer-return-without-null-guard -- posix-errno validates the returned errno pointer before dereference; jerboa-security: suppress ffi-integer-width-ambiguous -- errno accessor returns a pointer-sized C runtime slot, and posix-errno loads its int payload through foreign-ref - (foreign-procedure "__errno_location" () void*))) + (foreign-procedure "__errno_location" () void*) ; jerboa-security: suppress ffi-pointer-return-without-null-guard -- posix-errno validates the returned errno pointer before dereference; jerboa-security: suppress ffi-integer-width-ambiguous -- errno accessor returns a pointer-sized C runtime slot, and posix-errno loads its int payload through foreign-ref + )) (catch (e) #f))) + (def (non-null-ptr? ptr) + (and ptr (not (= ptr 0)))) + (def (posix-errno) (if c-errno-location - (foreign-ref 'int (c-errno-location) 0) + (let ([ptr (c-errno-location)]) + (if (non-null-ptr? ptr) + (foreign-ref 'int ptr 0) ; jerboa-security: suppress ffi-pointer-return-without-null-guard -- errno pointer is checked for NULL before reading offset 0 + 0)) 0)) (def c-strerror @@ -275,45 +282,49 @@ (def (posix-exit code) (c-exit code)) - ;; waitpid uses an out-pointer for status - (def c-waitpid (foreign-procedure __collect_safe "waitpid" (int void* int) int)) + ;; waitpid uses a scoped foreign status slot. + (def c-waitpid + (foreign-procedure __collect_safe "waitpid" (int void* int) int)) ; jerboa-security: suppress collect-safe-unpinned-bytevector -- waitpid receives only a scoped foreign status slot, not a movable Scheme bytevector; jerboa-security: suppress ffi-pointer-return-without-null-guard -- waitpid returns int and fills caller-owned status storage; jerboa-security: suppress ffi-integer-width-ambiguous -- pid/options/status are POSIX int fields, not size or pointer-width counts (def (posix-waitpid pid options) - (let ([status-buf (foreign-alloc 4)]) + (let ([status-slot (foreign-alloc 4)]) ; jerboa-security: suppress u8star-ffi-with-foreign-alloc -- waitpid status-slot is passed only to the void* status argument, never to a u8* FFI parameter (dynamic-wind void (lambda () - (let ([result (c-waitpid pid status-buf options)]) + (let ([result (c-waitpid pid status-slot options)]) (if (= result -1) (let ([e (posix-errno)]) (raise (condition (make-posix-error e 'waitpid) (make-message-condition (format "waitpid failed: ~a" (posix-strerror e)))))) - (let ([status (foreign-ref 'int status-buf 0)]) + (let ([status (foreign-ref 'int status-slot 0)]) ; jerboa-security: suppress ffi-pointer-return-without-null-guard -- status-slot is allocated by foreign-alloc and released by the dynamic-wind cleanup (values result status))))) (lambda () - (foreign-free status-buf))))) + (foreign-free status-slot))))) - (def c-getpid (foreign-procedure "getpid" () int)) - (def c-getppid (foreign-procedure "getppid" () int)) + (def c-getpid (foreign-procedure "getpid" () int)) ; jerboa-security: suppress ffi-integer-width-ambiguous -- POSIX process ids are returned through libc pid_t-compatible int bindings in this module + (def c-getppid (foreign-procedure "getppid" () int)) ; jerboa-security: suppress ffi-integer-width-ambiguous -- POSIX process ids are returned through libc pid_t-compatible int bindings in this module (def (posix-getpid) (c-getpid)) (def (posix-getppid) (c-getppid)) - (def c-setpgid (foreign-procedure "setpgid" (int int) int)) + (def c-setpgid (foreign-procedure "setpgid" (int int) int)) ; jerboa-security: suppress ffi-integer-width-ambiguous -- POSIX pid/pgid values are represented by libc int-compatible bindings here (def (posix-setpgid pid pgid) (check-posix 'setpgid (c-setpgid pid pgid))) - (def c-getpgid (foreign-procedure "getpgid" (int) int)) + (def c-getpgid (foreign-procedure "getpgid" (int) int)) ; jerboa-security: suppress ffi-integer-width-ambiguous -- POSIX pid/pgid values are represented by libc int-compatible bindings here (def (posix-getpgid pid) (check-posix 'getpgid (c-getpgid pid))) - (def c-tcsetpgrp (foreign-procedure "tcsetpgrp" (int int) int)) + (def c-tcsetpgrp (foreign-procedure "tcsetpgrp" (int int) int)) ; jerboa-security: suppress ffi-integer-width-ambiguous -- fd and pgid are POSIX int fields for this libc call (def (posix-tcsetpgrp fd pgid) (check-posix 'tcsetpgrp (c-tcsetpgrp fd pgid))) - (def c-tcgetpgrp (foreign-procedure "tcgetpgrp" (int) int)) + (def c-tcgetpgrp (foreign-procedure "tcgetpgrp" (int) int)) ; jerboa-security: suppress ffi-integer-width-ambiguous -- fd and returned pgid are POSIX int fields for this libc call (def (posix-tcgetpgrp fd) (check-posix 'tcgetpgrp (c-tcgetpgrp fd))) - (def c-setsid (foreign-procedure "setsid" () int)) - (def (posix-setsid) (check-posix 'setsid (c-setsid))) + (def c-setsid (foreign-procedure "setsid" () int)) ; jerboa-security: suppress ffi-integer-width-ambiguous -- setsid returns a POSIX session id through the same int-compatible binding convention as pid/pgid helpers + (def (posix-setsid) + (let ([sid (check-posix 'setsid (c-setsid))]) + (ensure-standard-fds-open!) + sid)) ;; execve: takes path, argv array, envp array as NULL-terminated string arrays ;; For now, expose the raw call; higher-level wrappers in Track 24 @@ -335,7 +346,46 @@ (check-posix 'close (c-close fd))) (def c-read - (foreign-procedure __collect_safe "read" (int u8* size_t) ssize_t)) + (foreign-procedure __collect_safe "read" (int void* size_t) ssize_t)) ; jerboa-security: suppress collect-safe-unpinned-bytevector -- read receives a scoped foreign buffer, not a movable Scheme bytevector; jerboa-security: suppress u8star-ffi-with-foreign-alloc -- foreign-allocated read buffer is declared void*; jerboa-security: suppress ffi-integer-width-ambiguous -- count is bounded by the target bytevector length before crossing the FFI boundary + (def c-write + (foreign-procedure __collect_safe "write" (int void* size_t) ssize_t)) ; jerboa-security: suppress collect-safe-unpinned-bytevector -- write receives a scoped foreign buffer, not a movable Scheme bytevector; jerboa-security: suppress u8star-ffi-with-foreign-alloc -- foreign-allocated write buffer is declared void*; jerboa-security: suppress ffi-integer-width-ambiguous -- count is bounded by the source bytevector length before crossing the FFI boundary + + (def (call-with-posix-io-buffer who size k) + (unless (and (integer? size) (exact? size) (>= size 0)) + (error who "invalid POSIX foreign buffer size" size)) + (let ([ptr #f]) + (dynamic-wind + (lambda () + (set! ptr (foreign-alloc (max 1 size))) ; jerboa-security: suppress foreign-alloc-no-free -- ptr is freed by the dynamic-wind after thunk when the POSIX syscall returns or raises + (unless (non-null-ptr? ptr) + (error who "POSIX foreign buffer allocation failed" size))) + (lambda () + (k ptr)) + (lambda () + (when (non-null-ptr? ptr) + (foreign-free ptr) + (set! ptr #f)))))) + + (def (copy-posix-output! who ptr out len) + (unless (and (integer? len) (exact? len) (>= len 0) + (<= len (bytevector-length out))) + (error who "POSIX output length exceeds bytevector capacity" + len (bytevector-length out))) + (let loop ([i 0]) + (when (< i len) + (bytevector-u8-set! out i (foreign-ref 'unsigned-8 ptr i)) ; jerboa-security: suppress ffi-pointer-arithmetic-without-bounds -- i is loop-bounded by len after len is checked against the target bytevector capacity + (loop (+ i 1))))) + + (def (copy-posix-input! who bv ptr len) + (unless (and (integer? len) (exact? len) (>= len 0) + (<= len (bytevector-length bv))) + (error who "POSIX input length exceeds bytevector capacity" + len (bytevector-length bv))) + (let loop ([i 0]) + (when (< i len) + (foreign-set! 'unsigned-8 ptr i (bytevector-u8-ref bv i)) ; jerboa-security: suppress ffi-pointer-arithmetic-without-bounds -- i is loop-bounded by len after len is checked against the source bytevector capacity + (loop (+ i 1))))) + (def (posix-read fd buf count) (unless (bytevector? buf) (error 'posix-read "expected bytevector" buf)) @@ -343,10 +393,15 @@ (<= count (bytevector-length buf))) (error 'posix-read "read length exceeds bytevector capacity" count (bytevector-length buf))) - (check-posix 'read (c-read fd buf count))) + (if (= count 0) + 0 + (call-with-posix-io-buffer 'posix-read count + (lambda (tmp) + (let ([n (check-posix 'read (c-read fd tmp count))]) + (when (> n 0) + (copy-posix-output! 'posix-read tmp buf n)) + n))))) - (def c-write - (foreign-procedure __collect_safe "write" (int u8* size_t) ssize_t)) (def (posix-write fd buf count) (unless (bytevector? buf) (error 'posix-write "expected bytevector" buf)) @@ -354,7 +409,12 @@ (<= count (bytevector-length buf))) (error 'posix-write "write length exceeds bytevector capacity" count (bytevector-length buf))) - (check-posix 'write (c-write fd buf count))) + (if (= count 0) + 0 + (call-with-posix-io-buffer 'posix-write count + (lambda (tmp) + (copy-posix-input! 'posix-write buf tmp count) + (check-posix 'write (c-write fd tmp count)))))) (def c-dup (foreign-procedure "dup" (int) int)) (def (posix-dup fd) @@ -364,6 +424,27 @@ (def (posix-dup2 oldfd newfd) (check-posix 'dup2 (c-dup2 oldfd newfd))) + (def F_GETFD 1) + (def (standard-fd-open? fd) + (not (= (c-fcntl2 fd F_GETFD) -1))) + + (def (ensure-one-standard-fd-open! target-fd) + (unless (standard-fd-open? target-fd) + (let ([devnull (check-posix 'open (c-open "/dev/null" O_RDWR 0))]) + (dynamic-wind + void + (lambda () + (unless (= devnull target-fd) + (check-posix 'dup2 (c-dup2 devnull target-fd)))) + (lambda () + (unless (= devnull target-fd) + (c-close devnull))))))) + + (def (ensure-standard-fds-open!) + (ensure-one-standard-fd-open! 0) + (ensure-one-standard-fd-open! 1) + (ensure-one-standard-fd-open! 2)) + (def c-pipe (foreign-procedure "pipe" (void*) int)) (def (posix-pipe) (let ([buf (foreign-alloc 8)]) ;; 2 ints @@ -482,22 +563,27 @@ (lambda () (check-posix 'tcgetattr (c-tcgetattr fd ptr)) ;; Copy foreign memory to bytevector - (do ([i 0 (+ i 1)]) - ((= i TERMIOS_SIZE)) - (bytevector-u8-set! buf i (foreign-ref 'unsigned-8 ptr i))) + (let loop ([i 0]) + (when (< i TERMIOS_SIZE) + (bytevector-u8-set! buf i (foreign-ref 'unsigned-8 ptr i)) ; jerboa-security: suppress ffi-pointer-arithmetic-without-bounds -- TERMIOS_SIZE is a positive fixed allocation size and i is checked before each foreign read + (loop (+ i 1)))) buf) (lambda () (foreign-free ptr)))))) (def (posix-tcsetattr fd action termios-bv) ;; termios-bv is a bytevector from posix-tcgetattr + (unless (bytevector? termios-bv) + (error 'posix-tcsetattr "expected bytevector" termios-bv)) (let ([ptr (foreign-alloc TERMIOS_SIZE)]) (dynamic-wind void (lambda () ;; Copy bytevector to foreign memory - (do ([i 0 (+ i 1)]) - ((= i (min TERMIOS_SIZE (bytevector-length termios-bv)))) - (foreign-set! 'unsigned-8 ptr i (bytevector-u8-ref termios-bv i))) + (let ([limit (min TERMIOS_SIZE (bytevector-length termios-bv))]) + (let loop ([i 0]) + (when (< i limit) + (foreign-set! 'unsigned-8 ptr i (bytevector-u8-ref termios-bv i)) ; jerboa-security: suppress ffi-pointer-arithmetic-without-bounds -- limit is clamped to TERMIOS_SIZE and termios-bv length before each foreign write + (loop (+ i 1))))) (check-posix 'tcsetattr (c-tcsetattr fd action ptr))) (lambda () (foreign-free ptr))))) @@ -563,80 +649,118 @@ ;; struct stat is ~144 bytes on Linux x86_64 (def STAT_SIZE 256) - (def c-stat (foreign-procedure "stat" (string void*) int)) - (def c-fstat (foreign-procedure "fstat" (int void*) int)) - (def c-lstat (foreign-procedure "lstat" (string void*) int)) + (def c-stat (foreign-procedure "stat" (string void*) int)) ; jerboa-security: suppress ffi-pointer-return-without-null-guard -- stat fills caller-owned storage and returns status int; jerboa-security: suppress ffi-integer-width-ambiguous -- POSIX stat returns int status and receives a scoped void* buffer + (def c-fstat (foreign-procedure "fstat" (int void*) int)) ; jerboa-security: suppress ffi-pointer-return-without-null-guard -- fstat fills caller-owned storage and returns status int; jerboa-security: suppress ffi-integer-width-ambiguous -- fd is POSIX int and output storage is a scoped void* buffer + (def c-lstat (foreign-procedure "lstat" (string void*) int)) ; jerboa-security: suppress ffi-pointer-return-without-null-guard -- lstat fills caller-owned storage and returns status int; jerboa-security: suppress ffi-integer-width-ambiguous -- POSIX lstat returns int status and receives a scoped void* buffer + + (def (call-with-stat-storage who k) + (let ([ptr #f]) + (dynamic-wind + (lambda () + (set! ptr (foreign-alloc STAT_SIZE)) ; jerboa-security: suppress foreign-alloc-no-free -- ptr is released by the dynamic-wind cleanup after stat data is copied into a bytevector + (unless (non-null-ptr? ptr) + (error who "stat buffer allocation failed" STAT_SIZE))) + (lambda () + (k ptr)) + (lambda () + (when (non-null-ptr? ptr) + (foreign-free ptr) + (set! ptr #f)))))) + + (def (stat-storage->bytevector who ptr) + (let ([buf (make-bytevector STAT_SIZE 0)]) + (copy-posix-output! who ptr buf STAT_SIZE) + buf)) (def (posix-stat path) - (let ([buf (foreign-alloc STAT_SIZE)]) - (let ([rc (c-stat path buf)]) - (if (= rc -1) - (let ([e (posix-errno)]) - (foreign-free buf) - (raise (condition - (make-posix-error e 'stat) - (make-message-condition - (format "stat ~a failed: ~a" path (posix-strerror e)))))) - buf)))) + (call-with-stat-storage 'posix-stat + (lambda (ptr) + (let ([rc (c-stat path ptr)]) + (if (= rc -1) + (let ([e (posix-errno)]) + (raise (condition + (make-posix-error e 'stat) + (make-message-condition + (format "stat ~a failed: ~a" path (posix-strerror e)))))) + (stat-storage->bytevector 'posix-stat ptr)))))) (def (posix-fstat fd) - (let ([buf (foreign-alloc STAT_SIZE)]) - (let ([rc (c-fstat fd buf)]) - (if (= rc -1) - (let ([e (posix-errno)]) - (foreign-free buf) - (raise (condition - (make-posix-error e 'fstat) - (make-message-condition - (format "fstat ~a failed: ~a" fd (posix-strerror e)))))) - buf)))) + (call-with-stat-storage 'posix-fstat + (lambda (ptr) + (let ([rc (c-fstat fd ptr)]) + (if (= rc -1) + (let ([e (posix-errno)]) + (raise (condition + (make-posix-error e 'fstat) + (make-message-condition + (format "fstat ~a failed: ~a" fd (posix-strerror e)))))) + (stat-storage->bytevector 'posix-fstat ptr)))))) (def (posix-lstat path) - (let ([buf (foreign-alloc STAT_SIZE)]) - (let ([rc (c-lstat path buf)]) - (if (= rc -1) - (let ([e (posix-errno)]) - (foreign-free buf) - (raise (condition - (make-posix-error e 'lstat) - (make-message-condition - (format "lstat ~a failed: ~a" path (posix-strerror e)))))) - buf)))) + (call-with-stat-storage 'posix-lstat + (lambda (ptr) + (let ([rc (c-lstat path ptr)]) + (if (= rc -1) + (let ([e (posix-errno)]) + (raise (condition + (make-posix-error e 'lstat) + (make-message-condition + (format "lstat ~a failed: ~a" path (posix-strerror e)))))) + (stat-storage->bytevector 'posix-lstat ptr)))))) (def (free-stat stat-buf) - (foreign-free stat-buf)) + (void)) ;; struct stat field layouts are ABI-specific. Linux and FreeBSD keep the ;; original accessors below; Darwin places mode/nlink before ino and its ;; timestamps and size at different offsets. + (def (ensure-stat-buffer! who buf) + (unless (and (bytevector? buf) (>= (bytevector-length buf) STAT_SIZE)) + (error who "expected stat bytevector" buf))) + + (def (stat-u16-ref who buf offset) + (ensure-stat-buffer! who buf) + (bytevector-u16-native-ref buf offset)) + (def (stat-u32-ref who buf offset) + (ensure-stat-buffer! who buf) + (bytevector-u32-native-ref buf offset)) + (def (stat-u64-ref who buf offset) + (ensure-stat-buffer! who buf) + (bytevector-u64-native-ref buf offset)) + (def (stat-s64-ref who buf offset) + (ensure-stat-buffer! who buf) + (bytevector-s64-native-ref buf offset)) + (def (stat-dev buf) - (foreign-ref (if *macos?* 'unsigned-32 'unsigned-64) buf 0)) + (if *macos?* (stat-u32-ref 'stat-dev buf 0) (stat-u64-ref 'stat-dev buf 0))) (def (stat-ino buf) - (foreign-ref 'unsigned-64 buf 8)) + (stat-u64-ref 'stat-ino buf 8)) (def (stat-nlink buf) - (foreign-ref (if *macos?* 'unsigned-16 'unsigned-64) - buf (if *macos?* 6 16))) + (if *macos?* + (stat-u16-ref 'stat-nlink buf 6) + (stat-u64-ref 'stat-nlink buf 16))) (def (stat-mode buf) - (foreign-ref (if *macos?* 'unsigned-16 'unsigned-32) - buf (if *macos?* 4 24))) + (if *macos?* + (stat-u16-ref 'stat-mode buf 4) + (stat-u32-ref 'stat-mode buf 24))) (def (stat-uid buf) - (foreign-ref 'unsigned-32 buf (if *macos?* 16 28))) + (stat-u32-ref 'stat-uid buf (if *macos?* 16 28))) (def (stat-gid buf) - (foreign-ref 'unsigned-32 buf (if *macos?* 20 32))) + (stat-u32-ref 'stat-gid buf (if *macos?* 20 32))) ;; Darwin: atime 32, mtime 48, ctime 64, size 96. ;; FreeBSD: atime 48, mtime 64, ctime 80, size 112. ;; Linux: atime 72, mtime 88, ctime 104, size 48. (def (stat-size buf) - (foreign-ref 'integer-64 buf + (stat-s64-ref 'stat-size buf (cond [*macos?* 96] [*freebsd?* 112] [else 48]))) (def (stat-atime buf) - (foreign-ref 'integer-64 buf + (stat-s64-ref 'stat-atime buf (cond [*macos?* 32] [*freebsd?* 48] [else 72]))) (def (stat-mtime buf) - (foreign-ref 'integer-64 buf + (stat-s64-ref 'stat-mtime buf (cond [*macos?* 48] [*freebsd?* 64] [else 88]))) (def (stat-ctime buf) - (foreign-ref 'integer-64 buf + (stat-s64-ref 'stat-ctime buf (cond [*macos?* 64] [*freebsd?* 80] [else 104]))) ;; File type checks (from st_mode)