Security hardening: Argon2id, TOCTOU-safe paths, message HMAC, sandbox limits, taint checks, aarch64 seccomp
ober
160d6543620a1960c1934307c1e9f60d8d8a6798
--- a/jerboa-native-rs/Cargo.toml +++ b/jerboa-native-rs/Cargo.toml @@ -9,6 +9,7 @@ crate-type = ["cdylib", "staticlib"] [dependencies] ring = "0.17" scrypt = "0.11" +argon2 = "0.5" flate2 = "1" regex = "1" libc = "0.2" --- a/jerboa-native-rs/src/crypto.rs +++ b/jerboa-native-rs/src/crypto.rs @@ -1,5 +1,6 @@ #[allow(deprecated)] use ring::{digest, hmac, rand, aead, constant_time, pbkdf2}; +use argon2::{Argon2, Algorithm, Version, Params}; use crate::panic::{ffi_wrap, set_last_error}; use std::num::NonZeroU32; @@ -445,3 +446,83 @@ pub extern "C" fn jerboa_pbkdf2_verify( } }) } + +// --- Argon2id --- + +/// Derive a key using Argon2id. +/// m_cost: memory in KiB (e.g., 65536 = 64 MB) +/// t_cost: time cost (iterations, e.g., 3) +/// p_cost: parallelism (e.g., 4) +/// output_len: desired hash length (e.g., 32) +#[no_mangle] +pub extern "C" fn jerboa_argon2id_hash( + password: *const u8, password_len: usize, + salt: *const u8, salt_len: usize, + m_cost: u32, t_cost: u32, p_cost: u32, + output: *mut u8, output_len: usize, +) -> i32 { + ffi_wrap(|| { + if password.is_null() || salt.is_null() || output.is_null() { return -1; } + if salt_len < 8 { + set_last_error("salt must be at least 8 bytes".to_string()); + return -1; + } + if output_len == 0 { return -1; } + + let pw = unsafe { std::slice::from_raw_parts(password, password_len) }; + let s = unsafe { std::slice::from_raw_parts(salt, salt_len) }; + let out = unsafe { std::slice::from_raw_parts_mut(output, output_len) }; + + let params = match Params::new(m_cost, t_cost, p_cost, Some(output_len)) { + Ok(p) => p, + Err(e) => { + set_last_error(format!("invalid argon2id parameters: {}", e)); + return -1; + } + }; + + let argon2 = Argon2::new(Algorithm::Argon2id, Version::V0x13, params); + match argon2.hash_password_into(pw, s, out) { + Ok(()) => 0, + Err(e) => { + set_last_error(format!("argon2id hash failed: {}", e)); + -1 + } + } + }) +} + +/// Verify a password against an Argon2id hash. +/// Returns 1 if matches, 0 if not, -1 on error. +#[no_mangle] +pub extern "C" fn jerboa_argon2id_verify( + password: *const u8, password_len: usize, + salt: *const u8, salt_len: usize, + m_cost: u32, t_cost: u32, p_cost: u32, + expected: *const u8, expected_len: usize, +) -> i32 { + ffi_wrap(|| { + if password.is_null() || salt.is_null() || expected.is_null() { return -1; } + if salt_len < 8 || expected_len == 0 { return -1; } + + let pw = unsafe { std::slice::from_raw_parts(password, password_len) }; + let s = unsafe { std::slice::from_raw_parts(salt, salt_len) }; + let exp = unsafe { std::slice::from_raw_parts(expected, expected_len) }; + + let params = match Params::new(m_cost, t_cost, p_cost, Some(expected_len)) { + Ok(p) => p, + Err(_) => return -1, + }; + + let argon2 = Argon2::new(Algorithm::Argon2id, Version::V0x13, params); + let mut computed = vec![0u8; expected_len]; + match argon2.hash_password_into(pw, s, &mut computed) { + Ok(()) => { + // Constant-time comparison + #[allow(deprecated)] + if constant_time::verify_slices_are_equal(&computed, exp).is_ok() { 1 } else { 0 } + } + Err(_) => -1, + } + }) +} --- a/lib/std/actor/transport.sls +++ b/lib/std/actor/transport.sls @@ -144,9 +144,10 @@ (string-length node-id))))] [else (loop (fx- i 1))]))) - ;; -------- 7C: HMAC-SHA256 Authentication -------- + ;; -------- 7C: HMAC-SHA256 Authentication + Per-Message Integrity -------- (define NONCE_SIZE 32) ;; 256-bit nonces + (define HMAC_SIZE 32) ;; HMAC-SHA256 output size ;; Compute HMAC-SHA256(cookie, nonce1 || nonce2 || node-id) (define (auth-hmac cookie nonce1 nonce2 node-id) @@ -157,9 +158,54 @@ (bytevector-copy! id-bv 0 data (* 2 NONCE_SIZE) (bytevector-length id-bv)) (native-hmac-sha256 (string->utf8 cookie) data))) + ;; Derive a session key from the shared cookie and both nonces. + ;; Uses HMAC-SHA256(cookie, "session" || client-nonce || server-nonce) as KDF. + (define (derive-session-key cookie client-nonce server-nonce) + (let* ([label (string->utf8 "jerboa-session-key-v1")] + [data (make-bytevector (+ (bytevector-length label) NONCE_SIZE NONCE_SIZE))]) + (bytevector-copy! label 0 data 0 (bytevector-length label)) + (bytevector-copy! client-nonce 0 data (bytevector-length label) NONCE_SIZE) + (bytevector-copy! server-nonce 0 data (+ (bytevector-length label) NONCE_SIZE) NONCE_SIZE) + (native-hmac-sha256 (string->utf8 cookie) data))) + + ;; Write an HMAC-authenticated framed message. + ;; Wire format: [4-byte length][N-byte fasl body][32-byte HMAC] + ;; The HMAC covers: length bytes || fasl body (everything before the HMAC). + (define (write-authenticated-message fd session-key msg) + (let* ([frame (message->bytes msg)] + [hmac (native-hmac-sha256 session-key frame)] + [total (make-bytevector (+ (bytevector-length frame) HMAC_SIZE))]) + (bytevector-copy! frame 0 total 0 (bytevector-length frame)) + (bytevector-copy! hmac 0 total (bytevector-length frame) HMAC_SIZE) + (tcp-write fd total))) + + ;; Read and verify an HMAC-authenticated framed message. + ;; Returns the deserialized message, or raises error on HMAC failure. + (define (read-authenticated-message fd session-key) + (let ([header (make-bytevector 4 0)]) + (read-exact-into-buf fd header 0 4) + (let ([n (fx+ (fx+ (fx+ (fxsll (bytevector-u8-ref header 0) 24) + (fxsll (bytevector-u8-ref header 1) 16)) + (fxsll (bytevector-u8-ref header 2) 8)) + (bytevector-u8-ref header 3))]) + ;; Read body + HMAC + (let ([body (make-bytevector n 0)] + [received-hmac (make-bytevector HMAC_SIZE 0)]) + (read-exact-into-buf fd body 0 n) + (read-exact-into-buf fd received-hmac 0 HMAC_SIZE) + ;; Reconstruct the frame (header || body) for HMAC verification + (let* ([frame (make-bytevector (+ 4 n))]) + (bytevector-copy! header 0 frame 0 4) + (bytevector-copy! body 0 frame 4 n) + (let ([expected-hmac (native-hmac-sha256 session-key frame)]) + (unless (native-crypto-memcmp received-hmac expected-hmac) + (error 'read-authenticated-message + "message HMAC verification failed — possible tampering"))) + (fasl-read (open-bytevector-input-port body))))))) + ;; -------- 7D: Connection pool -------- - ;; *connections*: node-id → #(fd write-mutex) + ;; *connections*: node-id → #(fd write-mutex session-key) (define *connections* (make-hashtable string-hash string=?)) (define *conn-mutex* (make-mutex)) @@ -181,7 +227,8 @@ (hashtable-delete! *connections* node-id)))) ;; Open a new TCP connection and complete HMAC-SHA256 challenge-response. - ;; Returns #(fd write-mutex). + ;; Returns #(fd write-mutex session-key). + ;; After handshake, derives a session key for per-message HMAC integrity. (define (open-connection! node-id) (let-values ([(host port) (node-id->host+port node-id)]) (let ([fd (tcp-connect host port)] @@ -214,11 +261,15 @@ (unless (native-crypto-memcmp server-proof expected) (tcp-close fd) (error 'open-connection! "server auth failed — possible MITM" node-id)) - (vector fd write-mutex))))))))) + ;; Derive session key for per-message HMAC integrity + (let ([session-key (derive-session-key (*node-cookie*) + client-nonce server-nonce)]) + (vector fd write-mutex session-key)))))))))) ;; -------- 7E: Remote send -------- ;; Send msg to a remote actor. Called via set-remote-send-handler!. + ;; All post-handshake messages are HMAC-authenticated with the session key. (define (transport-remote-send! actor msg) (let ([node-id (actor-ref-node actor)] [actor-id (actor-ref-id actor)]) @@ -226,10 +277,12 @@ (drop-connection! node-id) (raise exn)]) (let ([conn (get-connection! node-id)]) - (let ([fd (vector-ref conn 0)] - [write-mutex (vector-ref conn 1)]) + (let ([fd (vector-ref conn 0)] + [write-mutex (vector-ref conn 1)] + [session-key (vector-ref conn 2)]) (with-mutex write-mutex - (write-framed-message fd (list 'send actor-id msg)))))))) + (write-authenticated-message fd session-key + (list 'send actor-id msg)))))))) ;; -------- 7F: Server -------- @@ -246,6 +299,7 @@ (loop))))))) ;; Handle one incoming connection: HMAC-SHA256 challenge-response then dispatch. + ;; After authentication, all messages are verified with per-message HMAC. (define (handle-client! fd) (guard (exn [#t (guard (e [#t (void)]) (tcp-close fd))]) @@ -281,12 +335,15 @@ (let ([our-proof (auth-hmac (*node-cookie*) server-nonce client-nonce (current-node-id))]) (write-framed-message fd (list 'ok our-proof)) - (let loop () - (let ([msg (guard (exn [#t 'eof]) - (read-framed-message fd))]) - (unless (eq? msg 'eof) - (dispatch-remote-message! msg) - (loop)))) + ;; Derive session key for per-message integrity + (let ([session-key (derive-session-key (*node-cookie*) + client-nonce server-nonce)]) + (let loop () + (let ([msg (guard (exn [#t 'eof]) + (read-authenticated-message fd session-key))]) + (unless (eq? msg 'eof) + (dispatch-remote-message! msg) + (loop))))) (tcp-close fd))))))))))) ;; Dispatch an inbound message to a local actor. --- a/lib/std/crypto/native-rust.sls +++ b/lib/std/crypto/native-rust.sls @@ -22,6 +22,8 @@ rust-scrypt ;; PBKDF2 rust-pbkdf2-derive rust-pbkdf2-verify + ;; Argon2id + rust-argon2id-hash rust-argon2id-verify ;; Error rust-last-error) @@ -268,4 +270,40 @@ expected (bytevector-length expected))]) (= rc 1)))) + ;; --- Argon2id --- + + (define c-jerboa-argon2id-hash + (foreign-procedure "jerboa_argon2id_hash" + (u8* size_t u8* size_t unsigned-32 unsigned-32 unsigned-32 u8* size_t) int)) + + ;; Derive key using Argon2id. + ;; m-cost: memory in KiB (e.g. 65536 = 64 MB) + ;; t-cost: time cost (iterations, e.g. 3) + ;; p-cost: parallelism (e.g. 4) + ;; OWASP 2023 recommended minimum: m=19456 (19 MiB), t=2, p=1 + (define (rust-argon2id-hash password salt output-len m-cost t-cost p-cost) + (let ([out (make-bytevector output-len)] + [pw (if (string? password) (string->utf8 password) password)] + [s (if (string? salt) (string->utf8 salt) salt)]) + (let ([rc (c-jerboa-argon2id-hash pw (bytevector-length pw) + s (bytevector-length s) + m-cost t-cost p-cost + out output-len)]) + (when (< rc 0) (error 'rust-argon2id-hash "hash failed" (rust-last-error))) + out))) + + (define c-jerboa-argon2id-verify + (foreign-procedure "jerboa_argon2id_verify" + (u8* size_t u8* size_t unsigned-32 unsigned-32 unsigned-32 u8* size_t) int)) + + ;; Verify password against Argon2id hash. Returns #t if match, #f otherwise. + (define (rust-argon2id-verify password salt expected m-cost t-cost p-cost) + (let ([pw (if (string? password) (string->utf8 password) password)] + [s (if (string? salt) (string->utf8 salt) salt)]) + (let ([rc (c-jerboa-argon2id-verify pw (bytevector-length pw) + s (bytevector-length s) + m-cost t-cost p-cost + expected (bytevector-length expected))]) + (= rc 1)))) + ) ;; end library --- a/lib/std/crypto/password.sls +++ b/lib/std/crypto/password.sls @@ -1,16 +1,21 @@ #!chezscheme -;;; (std crypto password) — Password hashing via PBKDF2 +;;; (std crypto password) — Password hashing via Argon2id and PBKDF2 ;;; -;;; Uses PKCS5_PBKDF2_HMAC from libcrypto for password hashing. -;;; PBKDF2-HMAC-SHA256 with configurable iterations and salt. -;;; Argon2id would be preferred but requires libargon2 — PBKDF2 is -;;; universally available via OpenSSL. +;;; Preferred: Argon2id via Rust native library (memory-hard, GPU-resistant). +;;; Fallback: PBKDF2-HMAC-SHA256 via OpenSSL (universally available). +;;; +;;; password-hash defaults to Argon2id when libjerboa_native.so is available, +;;; falls back to PBKDF2 otherwise. password-verify auto-detects the algorithm +;;; from the hash string prefix ($argon2id$ or $pbkdf2-sha256$). (library (std crypto password) (export password-hash password-verify - make-password-salt) + make-password-salt + password-hash-argon2id + password-verify-argon2id + argon2id-available?) (import (chezscheme) (std crypto random) @@ -32,6 +37,36 @@ (foreign-procedure "EVP_sha256" () uptr) (lambda () 0))) + ;; ========== Argon2id Support (via Rust native library) ========== + + ;; Try to load libjerboa_native.so for Argon2id + (define *argon2id-loaded* + (or (guard (e [#t #f]) (load-shared-object "libjerboa_native.so") #t) + (guard (e [#t #f]) (load-shared-object "lib/libjerboa_native.so") #t) + #f)) + + (define c-jerboa-argon2id-hash + (if *argon2id-loaded* + (guard (e [#t #f]) + (foreign-procedure "jerboa_argon2id_hash" + (u8* size_t u8* size_t unsigned-32 unsigned-32 unsigned-32 u8* size_t) int)) + #f)) + + (define c-jerboa-argon2id-verify + (if *argon2id-loaded* + (guard (e [#t #f]) + (foreign-procedure "jerboa_argon2id_verify" + (u8* size_t u8* size_t unsigned-32 unsigned-32 unsigned-32 u8* size_t) int)) + #f)) + + (define (argon2id-available?) + (and c-jerboa-argon2id-hash c-jerboa-argon2id-verify #t)) + + ;; OWASP 2023 recommended Argon2id parameters + (define default-argon2id-m-cost 19456) ;; 19 MiB + (define default-argon2id-t-cost 2) ;; 2 iterations + (define default-argon2id-p-cost 1) ;; 1 thread + ;; ========== Public API ========== (define default-iterations 600000) ;; OWASP 2023 recommendation for PBKDF2-SHA256 @@ -42,10 +77,77 @@ ;; Generate a random salt for password hashing. (random-bytes default-salt-len)) + (define (password-hash-argon2id password . opts) + ;; Hash a password with Argon2id. + ;; Returns a string: "$argon2id$m=M,t=T,p=P$salt-hex$hash-hex" + (unless (argon2id-available?) + (error 'password-hash-argon2id "argon2id not available — libjerboa_native.so not loaded")) + (let* ([pass-bv (if (string? password) (string->utf8 password) password)] + [m-cost (kwarg 'memory: opts default-argon2id-m-cost)] + [t-cost (kwarg 'time: opts default-argon2id-t-cost)] + [p-cost (kwarg 'parallelism: opts default-argon2id-p-cost)] + [salt (kwarg 'salt: opts (make-password-salt))] + [out (make-bytevector default-key-len)]) + (let ([rc (c-jerboa-argon2id-hash pass-bv (bytevector-length pass-bv) + salt (bytevector-length salt) + m-cost t-cost p-cost + out default-key-len)]) + (when (< rc 0) + (error 'password-hash-argon2id "argon2id hash failed")) + (string-append "$argon2id$" + "m=" (number->string m-cost) + ",t=" (number->string t-cost) + ",p=" (number->string p-cost) "$" + (bytevector->hex salt) "$" + (bytevector->hex out))))) + + (define (password-verify-argon2id password hash-string) + ;; Verify a password against an Argon2id hash string. + (unless (argon2id-available?) + (error 'password-verify-argon2id "argon2id not available")) + (let ([parts (string-split-dollar hash-string)]) + (unless (and (>= (length parts) 5) + (string=? (cadr parts) "argon2id")) + (error 'password-verify-argon2id "invalid hash format" hash-string)) + (let* ([params-str (caddr parts)] + [m-cost (parse-argon2-param params-str "m=")] + [t-cost (parse-argon2-param params-str "t=")] + [p-cost (parse-argon2-param params-str "p=")] + [salt (hex->bytevector (cadddr parts))] + [expected (hex->bytevector (list-ref parts 4))] + [pass-bv (if (string? password) (string->utf8 password) password)]) + (let ([rc (c-jerboa-argon2id-verify pass-bv (bytevector-length pass-bv) + salt (bytevector-length salt) + m-cost t-cost p-cost + expected (bytevector-length expected))]) + (= rc 1))))) + + (define (parse-argon2-param str prefix) + ;; Extract numeric value after prefix from "m=19456,t=2,p=1" + (let* ([plen (string-length prefix)] + [slen (string-length str)]) + (let loop ([i 0]) + (cond + [(> (+ i plen) slen) + (error 'parse-argon2-param "parameter not found" prefix str)] + [(string=? (substring str i (+ i plen)) prefix) + (let num-loop ([j (+ i plen)] [acc '()]) + (if (or (>= j slen) + (char=? (string-ref str j) #\,)) + (string->number (list->string (reverse acc))) + (num-loop (+ j 1) (cons (string-ref str j) acc))))] + [else (loop (+ i 1))])))) + (define (password-hash password . opts) + ;; Hash a password. Prefers Argon2id when available, falls back to PBKDF2. + ;; Returns a string with algorithm prefix for auto-detection on verify. + (if (argon2id-available?) + (apply password-hash-argon2id password opts) + (password-hash-pbkdf2 password opts))) + + (define (password-hash-pbkdf2 password opts) ;; Hash a password with PBKDF2-HMAC-SHA256. ;; Returns a string: "$pbkdf2-sha256$iterations$salt-hex$hash-hex" - ;; opts: iterations: N (default 600000), salt: bytevector (let* ([pass-bv (if (string? password) (string->utf8 password) password)] [iterations (kwarg 'iterations: opts default-iterations)] [salt (kwarg 'salt: opts (make-password-salt))] @@ -59,7 +161,6 @@ out)]) (when (not (= r 1)) (error 'password-hash "PKCS5_PBKDF2_HMAC failed")) - ;; Format: $pbkdf2-sha256$iterations$salt$hash (string-append "$pbkdf2-sha256$" (number->string iterations) "$" (bytevector->hex salt) "$" @@ -67,27 +168,34 @@ (define (password-verify password hash-string) ;; Verify a password against a hash string. - ;; Uses timing-safe comparison to prevent timing attacks. + ;; Auto-detects algorithm from prefix ($argon2id$ or $pbkdf2-sha256$). (let ([parts (string-split-dollar hash-string)]) - (unless (and (= (length parts) 5) - (string=? (cadr parts) "pbkdf2-sha256")) - (error 'password-verify "invalid hash format" hash-string)) - (let* ([iterations (string->number (caddr parts))] - [salt (hex->bytevector (cadddr parts))] - [expected-hash (list-ref parts 4)] - [pass-bv (if (string? password) (string->utf8 password) password)] - [out (make-bytevector default-key-len)] - [r (c-PKCS5_PBKDF2_HMAC - pass-bv (bytevector-length pass-bv) - salt (bytevector-length salt) - iterations - (c-EVP_sha256) - default-key-len - out)]) - (when (not (= r 1)) - (error 'password-verify "PKCS5_PBKDF2_HMAC failed")) - ;; Timing-safe comparison - (timing-safe-string=? (bytevector->hex out) expected-hash)))) + (cond + [(and (>= (length parts) 5) + (string=? (cadr parts) "argon2id")) + (password-verify-argon2id password hash-string)] + [(and (= (length parts) 5) + (string=? (cadr parts) "pbkdf2-sha256")) + (password-verify-pbkdf2 password parts)] + [else + (error 'password-verify "unknown hash format" hash-string)]))) + + (define (password-verify-pbkdf2 password parts) + (let* ([iterations (string->number (caddr parts))] + [salt (hex->bytevector (cadddr parts))] + [expected-hash (list-ref parts 4)] + [pass-bv (if (string? password) (string->utf8 password) password)] + [out (make-bytevector default-key-len)] + [r (c-PKCS5_PBKDF2_HMAC + pass-bv (bytevector-length pass-bv) + salt (bytevector-length salt) + iterations + (c-EVP_sha256) + default-key-len + out)]) + (when (not (= r 1)) + (error 'password-verify "PKCS5_PBKDF2_HMAC failed")) + (timing-safe-string=? (bytevector->hex out) expected-hash))) ;; ========== Helpers ========== --- a/lib/std/safe.sls +++ b/lib/std/safe.sls @@ -66,7 +66,8 @@ (import (chezscheme) (std error conditions) - (std resource)) + (std resource) + (only (std security taint) tainted? check-untainted!)) ;; ========================================================================= ;; Mode control @@ -288,8 +289,9 @@ (raw-sqlite-close db)) (define (safe-sqlite-exec db sql) - ;; Pre: db is fixnum handle, sql is string + ;; Pre: db is fixnum handle, sql is string, not tainted ;; Post: returns 0 on success + (check-untainted! sql 'sqlite-exec) (check-fixnum! 'safe-sqlite-exec db) (check-string! 'safe-sqlite-exec sql) (check-sql-safety! 'safe-sqlite-exec sql) @@ -310,6 +312,7 @@ ;; Pre: db is fixnum handle, sql is string, params is list (check-fixnum! 'safe-sqlite-execute db) (check-string! 'safe-sqlite-execute sql) + (check-untainted! 'safe-sqlite-execute sql) (check-sql-safety! 'safe-sqlite-execute sql) (ensure-sqlite! 'safe-sqlite-execute) (apply raw-sqlite-execute db sql params)) @@ -319,6 +322,7 @@ ;; Post: returns a list of alists (check-fixnum! 'safe-sqlite-query db) (check-string! 'safe-sqlite-query sql) + (check-untainted! 'safe-sqlite-query sql) (check-sql-safety! 'safe-sqlite-query sql) (ensure-sqlite! 'safe-sqlite-query) (let ([result (apply raw-sqlite-query db sql params)]) @@ -332,6 +336,7 @@ (define (safe-sqlite-prepare db sql) (check-fixnum! 'safe-sqlite-prepare db) (check-string! 'safe-sqlite-prepare sql) + (check-untainted! 'safe-sqlite-prepare sql) (check-sql-safety! 'safe-sqlite-prepare sql) (ensure-sqlite! 'safe-sqlite-prepare) (let ([stmt (raw-sqlite-prepare db sql)]) @@ -483,6 +488,7 @@ ;; ========================================================================= (define (safe-open-input-file path) + (check-untainted! path 'open-input-file) (check-string! 'safe-open-input-file path) (unless (file-exists? path) (raise (condition @@ -492,6 +498,7 @@ (open-input-file path)) (define (safe-open-output-file path) + (check-untainted! path 'open-output-file) (check-string! 'safe-open-output-file path) ;; Check parent directory exists (let ([dir (path-parent path)]) @@ -505,6 +512,7 @@ (open-output-file path)) (define (safe-call-with-input-file path proc) + (check-untainted! path 'call-with-input-file) (check-string! 'safe-call-with-input-file path) (unless (file-exists? path) (raise (condition @@ -514,6 +522,7 @@ (call-with-input-file path proc)) (define (safe-call-with-output-file path proc) + (check-untainted! path 'call-with-output-file) (check-string! 'safe-call-with-output-file path) (call-with-output-file path proc)) --- a/lib/std/security/capability.sls +++ b/lib/std/security/capability.sls @@ -93,34 +93,107 @@ (define (fs-allowed-path? cap path) ;; Check if path is under one of the allowed paths. - ;; HARDENED: Requires directory boundary — /tmp/safe does NOT match /tmp/safety. - ;; The allowed path must be either an exact match or followed by '/'. + ;; HARDENED: Uses fd-based verification to eliminate TOCTOU races. + ;; Opens the path with O_NOFOLLOW|O_PATH (or falls back to realpath+fstat), + ;; then reads the canonical path from /proc/self/fd or F_GETPATH to verify + ;; the actual filesystem location — not what the name pointed to at check time. (and (eq? (capability-type cap) 'filesystem) (let ([allowed (cdr (assq 'paths (capability-permissions cap)))] - [canonical (canonicalize-path path)]) - (exists (lambda (p) - (or (string=? p canonical) ;; exact match - (string=? p "/") ;; root allows everything - (and (string-prefix? p canonical) - ;; Must be at a directory boundary - (let ([plen (string-length p)]) - (or (char=? (string-ref canonical plen) #\/) - (char=? (string-ref p (- plen 1)) #\/)))))) - allowed)))) - - ;; FFI binding for realpath(3) — resolves symlinks and . / .. + [canonical (resolve-path-safe path)]) + (and canonical + (exists (lambda (p) + (or (string=? p canonical) ;; exact match + (string=? p "/") ;; root allows everything + (and (string-prefix? p canonical) + ;; Must be at a directory boundary + (let ([plen (string-length p)]) + (or (char=? (string-ref canonical plen) #\/) + (char=? (string-ref p (- plen 1)) #\/)))))) + allowed))))) + + ;; ========== TOCTOU-Safe Path Resolution ========== + ;; + ;; Strategy: Open the path (or its parent) with O_PATH|O_NOFOLLOW to get an + ;; fd that refers to the actual inode, then resolve the fd back to a path via + ;; /proc/self/fd/N (Linux), F_GETPATH (macOS), or fallback to realpath(3). + ;; This closes the race window because the fd pins the inode. + + ;; FFI bindings + (define c-open + (guard (exn [#t #f]) + (foreign-procedure "open" (string int int) int))) + + (define c-close-fd + (guard (exn [#t #f]) + (foreign-procedure "close" (int) int))) + + (define c-readlink + (guard (exn [#t #f]) + (foreign-procedure "readlink" (string u8* size_t) ssize_t))) + (define c-realpath (guard (exn [#t #f]) (let ([f (foreign-procedure "realpath" (string void*) string)]) (lambda (path) (f path 0))))) - (define (canonicalize-path path) - ;; HARDENED: Uses realpath(3) to resolve symlinks when available. - ;; Falls back to string-based canonicalization if FFI fails. + ;; Platform-specific flags + ;; O_PATH (Linux) = 0x200000, O_NOFOLLOW = 0x20000 (Linux), 0x0100 (FreeBSD/macOS) + (define O_NOFOLLOW + (case (machine-type) + [(a6le ta6le arm64le) #x20000] ;; Linux + [(a6fb ta6fb) #x0100] ;; FreeBSD + [(a6osx ta6osx) #x0100] ;; macOS + [else #x0100])) ;; conservative default + + (define O_PATH + (case (machine-type) + [(a6le ta6le arm64le) #x200000] ;; Linux-only + [else 0])) ;; not available on BSD/macOS + + (define O_RDONLY 0) + + (define (resolve-path-safe path) + ;; TOCTOU-safe path resolution. + ;; 1. Open path with O_PATH|O_NOFOLLOW (or O_RDONLY|O_NOFOLLOW) + ;; 2. Read canonical path from /proc/self/fd/N + ;; 3. Close fd + ;; Falls back to realpath(3) if fd-based resolution is unavailable. + (if (and c-open c-close-fd) + (let ([flags (bitwise-ior (if (> O_PATH 0) O_PATH O_RDONLY) O_NOFOLLOW)]) + (let ([fd (guard (exn [#t -1]) + (c-open path flags 0))]) + (if (< fd 0) + ;; O_NOFOLLOW failed (symlink or doesn't exist) — reject or fallback + ;; If the path doesn't exist, realpath will also fail → return #f + (fallback-canonicalize path) + (dynamic-wind + (lambda () (void)) + (lambda () (resolve-fd-path fd path)) + (lambda () (c-close-fd fd)))))) + ;; No open() available — pure fallback + (fallback-canonicalize path))) + + (define (resolve-fd-path fd path) + ;; Read the canonical path of an open fd. + ;; Linux: readlink("/proc/self/fd/N") + ;; Fallback: realpath(3) on original path (less safe but better than nothing) + (or (and c-readlink + (let ([proc-path (string-append "/proc/self/fd/" (number->string fd))] + [buf (make-bytevector 4096)]) + (let ([n (guard (exn [#t -1]) + (c-readlink proc-path buf 4096))]) + (and (> n 0) + (utf8->string (let ([r (make-bytevector n)]) + (bytevector-copy! buf 0 r 0 n) + r)))))) + ;; Fallback: realpath on the original path (fd still pins the inode) + (fallback-canonicalize path))) + + (define (fallback-canonicalize path) + ;; Fallback: realpath(3) or string-based canonicalization. (or (and c-realpath (guard (exn [#t #f]) (c-realpath path))) - ;; Fallback: string-based canonicalization (no symlink resolution) (canonicalize-path/string-only path))) (define (canonicalize-path/string-only path) --- a/lib/std/security/sandbox.sls +++ b/lib/std/security/sandbox.sls @@ -60,6 +60,7 @@ sandbox-config-seatbelt sandbox-config-capsicum sandbox-config-capabilities + sandbox-config-max-output-size ;; Condition type &sandbox-error make-sandbox-error sandbox-error? @@ -141,7 +142,8 @@ (immutable landlock %sandbox-config-landlock) (immutable seatbelt %sandbox-config-seatbelt) (immutable capsicum %sandbox-config-capsicum) - (immutable capabilities %sandbox-config-capabilities))) + (immutable capabilities %sandbox-config-capabilities) + (immutable max-output-size %sandbox-config-max-output-size))) ;; Public accessors (define sandbox-config-timeout %sandbox-config-timeout) @@ -150,11 +152,15 @@ (define sandbox-config-seatbelt %sandbox-config-seatbelt) (define sandbox-config-capsicum %sandbox-config-capsicum) (define sandbox-config-capabilities %sandbox-config-capabilities) + (define sandbox-config-max-output-size %sandbox-config-max-output-size) ;; make-sandbox-config: key-value pairs → sandbox-config record ;; (make-sandbox-config 'timeout 10 'seccomp 'io-only) ;; (make-sandbox-config 'timeout 10 'seatbelt 'no-write) ;; (make-sandbox-config 'timeout 10 'capsicum #t) + ;; Default max output size: 1 MB + (define *sandbox-max-output-size* (make-parameter (* 1 1024 1024))) + (define (make-sandbox-config . args) (let loop ([rest args] [timeout (*sandbox-timeout*)] @@ -162,9 +168,10 @@ [landlock (*sandbox-landlock*)] [seatbelt (*sandbox-seatbelt*)] [capsicum (*sandbox-capsicum*)] - [caps '()]) + [caps '()] + [max-output (*sandbox-max-output-size*)]) (if (null? rest) - (%make-sandbox-config timeout seccomp landlock seatbelt capsicum caps) + (%make-sandbox-config timeout seccomp landlock seatbelt capsicum caps max-output) (begin (when (null? (cdr rest)) (error 'make-sandbox-config "key missing value" (car rest))) @@ -173,20 +180,22 @@ [remaining (cddr rest)]) (cond [(eq? key 'timeout) - (loop remaining val seccomp landlock seatbelt capsicum caps)] + (loop remaining val seccomp landlock seatbelt capsicum caps max-output)] [(eq? key 'seccomp) - (loop remaining timeout val landlock seatbelt capsicum caps)] + (loop remaining timeout val landlock seatbelt capsicum caps max-output)] [(eq? key 'landlock) - (loop remaining timeout seccomp val seatbelt capsicum caps)] + (loop remaining timeout seccomp val seatbelt capsicum caps max-output)] [(eq? key 'seatbelt) - (loop remaining timeout seccomp landlock val capsicum caps)] + (loop remaining timeout seccomp landlock val capsicum caps max-output)] [(eq? key 'capsicum) - (loop remaining timeout seccomp landlock seatbelt val caps)] + (loop remaining timeout seccomp landlock seatbelt val caps max-output)] [(eq? key 'capabilities) - (loop remaining timeout seccomp landlock seatbelt capsicum val)] + (loop remaining timeout seccomp landlock seatbelt capsicum val max-output)] + [(eq? key 'max-output-size) + (loop remaining timeout seccomp landlock seatbelt capsicum caps val)] [else (error 'make-sandbox-config - "unknown key; expected timeout, seccomp, landlock, seatbelt, capsicum, or capabilities" + "unknown key; expected timeout, seccomp, landlock, seatbelt, capsicum, capabilities, or max-output-size" key)])))))) ;; ========== Seccomp filter resolution (Linux) ========== @@ -264,7 +273,8 @@ (%sandbox-config-landlock cfg) seatbelt-profile capsicum-mode - (%sandbox-config-capabilities cfg))))) + (%sandbox-config-capabilities cfg) + (%sandbox-config-max-output-size cfg))))) ;; FFI pipe(2) — creates a pair of connected file descriptors (define c-pipe @@ -370,7 +380,8 @@ ;; ========== Core sandbox implementation ========== (define (run-safe-internal thunk timeout seccomp-filter landlock-rules - seatbelt-profile capsicum-mode capabilities) + seatbelt-profile capsicum-mode capabilities + max-output-size) ;; Communication via pipe: child writes result, parent reads it. ;; HARDENED: Uses pipe(2) instead of temp files to prevent symlink attacks, ;; TOCTOU races, and read-eval injection. @@ -447,7 +458,7 @@ (c-close write-fd) (let-values ([(wpid status) (waitpid pid)]) (let* ([raw-data (guard (exn [#t (make-bytevector 0)]) - (fd-read-all read-fd (* 1 1024 1024)))] ;; 1MB max + (fd-read-all read-fd max-output-size))] [_ (c-close read-fd)] [result-sexp (if (> (bytevector-length raw-data) 0) @@ -510,6 +521,7 @@ (%sandbox-config-landlock cfg) seatbelt-profile capsicum-mode - (%sandbox-config-capabilities cfg))))) + (%sandbox-config-capabilities cfg) + (%sandbox-config-max-output-size cfg))))) ) ;; end library --- a/lib/std/security/seccomp.sls +++ b/lib/std/security/seccomp.sls @@ -57,11 +57,35 @@ (if (= loc 0) 0 (foreign-ref 'int loc 0))))) + ;; ========== Architecture Detection ========== + + ;; Architecture validation constants + ;; AUDIT_ARCH_X86_64 = 0xC000003E (EM_X86_64 | __AUDIT_ARCH_64BIT | __AUDIT_ARCH_LE) + ;; AUDIT_ARCH_AARCH64 = 0xC00000B7 (EM_AARCH64 | __AUDIT_ARCH_64BIT | __AUDIT_ARCH_LE) + (define AUDIT_ARCH_X86_64 #xC000003E) + (define AUDIT_ARCH_AARCH64 #xC00000B7) + + ;; Detect current architecture at load time + (define *current-arch* + (case (machine-type) + [(a6le ta6le) 'x86_64] + [(arm64le) 'aarch64] + [else 'x86_64])) ;; conservative default + + (define (current-audit-arch) + (case *current-arch* + [(x86_64) AUDIT_ARCH_X86_64] + [(aarch64) AUDIT_ARCH_AARCH64] + [else AUDIT_ARCH_X86_64])) + ;; prctl constants (define PR_SET_NO_NEW_PRIVS 38) - ;; seccomp syscall number (x86_64) - (define SYS_seccomp 317) + ;; seccomp syscall number (architecture-dependent) + (define SYS_seccomp + (case *current-arch* + [(aarch64) 277] + [else 317])) ;; x86_64 ;; seccomp operations (define SECCOMP_SET_MODE_FILTER 1) @@ -74,10 +98,6 @@ (define SECCOMP_RET_LOG #x7ffc0000) (define SECCOMP_RET_ALLOW #x7fff0000) - ;; Architecture validation - ;; AUDIT_ARCH_X86_64 = 0xC000003E (EM_X86_64 | __AUDIT_ARCH_64BIT | __AUDIT_ARCH_LE) - (define AUDIT_ARCH_X86_64 #xC000003E) - ;; ========== BPF Constants ========== ;; BPF instruction classes @@ -156,9 +176,9 @@ ;; [0] Load architecture from seccomp_data (list (bpf-stmt (bitwise-ior BPF_LD BPF_W BPF_ABS) SECCOMP_DATA_ARCH)) - ;; [1] Check arch == x86_64; if yes skip 1, if no fall through to kill + ;; [1] Check arch matches current platform; if yes skip 1, if no fall through to kill (list (bpf-jump (bitwise-ior BPF_JMP BPF_JEQ BPF_K) - AUDIT_ARCH_X86_64 + (current-audit-arch) 1 ;; jt: skip 1 instruction (over the kill) 0)) ;; jf: fall through to kill ;; [2] Kill on wrong architecture @@ -183,9 +203,10 @@ (list (bpf-stmt (bitwise-ior BPF_RET BPF_K) SECCOMP_RET_ALLOW)))]) insns)) - ;; ========== Syscall Table ========== + ;; ========== Syscall Tables ========== - (define *syscall-table* + ;; x86_64 syscall numbers (Linux) + (define *syscall-table-x86_64* '((read . 0) (write . 1) (close . 3) (fstat . 5) (mmap . 9) (mprotect . 10) (munmap . 11) (brk . 12) (rt_sigaction . 13) (rt_sigprocmask . 14) (rt_sigreturn . 15) @@ -214,12 +235,51 @@ (rseq . 334) (clone3 . 435) (close_range . 436) (prlimit64 . 302))) + ;; aarch64 (ARM64) syscall numbers (Linux) + ;; ARM64 uses a clean numbering starting from the generic Linux asm-generic/unistd.h. + ;; Many legacy x86_64 syscalls (fork, access, pipe, select, etc.) don't exist on ARM64; + ;; their modern replacements (clone, faccessat, pipe2, pselect6, etc.) are used instead. + (define *syscall-table-aarch64* + '((read . 63) (write . 64) (close . 57) (fstat . 80) + (mmap . 222) (mprotect . 226) (munmap . 215) (brk . 214) + (rt_sigaction . 134) (rt_sigprocmask . 135) (rt_sigreturn . 139) + (ioctl . 29) (access . 439) (pipe . 59) ;; access=faccessat2, pipe=pipe2 + (select . 72) (sched_yield . 124) ;; select=pselect6 + (mremap . 216) (madvise . 233) (nanosleep . 101) + (getpid . 172) (socket . 198) (connect . 203) + (accept . 202) (sendto . 206) (recvfrom . 207) + (bind . 200) (listen . 201) (getsockname . 204) + (setsockopt . 208) (clone . 220) (fork . 220) ;; ARM64: use clone for fork + (execve . 221) (exit . 93) (wait4 . 260) + (kill . 129) (uname . 160) (fcntl . 25) + (ftruncate . 46) (getdents . 61) (getcwd . 17) + (chdir . 49) (rename . 38) (mkdir . 34) ;; rename=renameat, mkdir=mkdirat + (rmdir . 35) (creat . 56) (link . 37) ;; rmdir=unlinkat, link=linkat + (unlink . 35) (readlink . 78) ;; unlink=unlinkat, readlink=readlinkat + (gettimeofday . 169) (getuid . 174) + (getgid . 176) (setuid . 146) (setgid . 144) + (getppid . 173) (setsid . 157) + (sigaltstack . 132) (prctl . 167) (arch_prctl . 167) ;; no arch_prctl on ARM64, map to prctl + (futex . 98) (clock_gettime . 113) + (set_tid_address . 96) (exit_group . 94) + (epoll_create1 . 20) (epoll_ctl . 21) (epoll_wait . 22) ;; epoll_wait=epoll_pwait + (openat . 56) (newfstatat . 79) + (set_robust_list . 99) (getrandom . 278) + (rseq . 293) (clone3 . 435) + (close_range . 436) (prlimit64 . 261))) + + ;; Select table based on detected architecture + (define *syscall-table* + (case *current-arch* + [(aarch64) *syscall-table-aarch64*] + [else *syscall-table-x86_64*])) + (define (syscall-name->number name) (let ([pair (assq name *syscall-table*)]) (if pair (cdr pair) (error 'syscall-name->number - (format "unknown syscall name: ~a" name))))) + (format "unknown syscall name: ~a (arch: ~a)" name *current-arch*))))) ;; ========== Action Constructors ==========