Add 165 functional tests exposing and fixing fake security and broken cache
ober
3bd0a0d04d0427cb199a1dd7ee147e80b974fecd
--- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ CHEZ_EXT_LIBDIRS = $(CHEZ_EXT_DIR)/chez-https/src:$(CHEZ_EXT_DIR)/chez-ssl/src:$ # Shared object paths for FFI-based chez-* libraries CHEZ_EXT_LDPATH = $(CHEZ_EXT_DIR)/chez-ssl:$(CHEZ_EXT_DIR)/chez-zlib:$(CHEZ_EXT_DIR)/chez-pcre2:$(CHEZ_EXT_DIR)/chez-leveldb:$(CHEZ_EXT_DIR)/chez-epoll:$(CHEZ_EXT_DIR)/chez-inotify:$(CHEZ_EXT_DIR)/chez-crypto:$(CHEZ_EXT_DIR)/chez-sqlite:$(CHEZ_EXT_DIR)/chez-postgresql -.PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 clean +.PHONY: test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-functional clean test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded @@ -224,6 +224,11 @@ test-phase6: @echo "--- Phase 6: Making Real Programs Easier to Build ---" @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-phase6.ss +test-functional: + @echo "--- Functional Tests (real I/O, fork, Landlock, signals) ---" + @gcc -shared -fPIC -O2 -o support/libjerboa-landlock.so support/landlock-shim.c 2>/dev/null || true + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-functional.ss + test-all: test test-features test-wrappers clean: --- a/lib/std/build.sls +++ b/lib/std/build.sls @@ -199,21 +199,41 @@ ;; ========== Build Cache ========== (define (build-cache-load cache-file) - ;; Load hash cache from fasl file + ;; Load hash cache from file. + ;; Serialized as an alist because fasl cannot round-trip hashtables + ;; with custom hash/equal functions. ;; Returns hashtable: file-path -> content-hash (guard (e [#t (make-hashtable string-hash string=?)]) (if (file-exists? cache-file) - (call-with-port (open-file-input-port cache-file) - (lambda (port) - (fasl-read port))) + (let ([alist (call-with-port (open-file-input-port cache-file) + (lambda (port) + (fasl-read port)))]) + (if (list? alist) + (let ([ht (make-hashtable string-hash string=?)]) + (for-each + (lambda (pair) + (when (and (pair? pair) (string? (car pair))) + (hashtable-set! ht (car pair) (cdr pair)))) + alist) + ht) + ;; Fallback for old format + (make-hashtable string-hash string=?))) (make-hashtable string-hash string=?)))) (define (build-cache-save cache-file cache) + ;; Save as alist for reliable fasl round-trip. (guard (e [#t (void)]) - (call-with-port (open-file-output-port cache-file - (file-options no-fail)) - (lambda (port) - (fasl-write cache port))))) + (let ([alist (let-values ([(keys vals) (hashtable-entries cache)]) + (let lp ([i 0] [acc '()]) + (if (= i (vector-length keys)) acc + (lp (+ i 1) + (cons (cons (vector-ref keys i) + (vector-ref vals i)) + acc)))))]) + (call-with-port (open-file-output-port cache-file + (file-options no-fail)) + (lambda (port) + (fasl-write alist port)))))) (define (module-changed? file cache) (guard (e [#t #t]) --- a/lib/std/security/restrict.sls +++ b/lib/std/security/restrict.sls @@ -104,28 +104,139 @@ format )) + ;; ========== Dangerous Bindings to Remove ========== + ;; Explicitly block these — they provide FFI, file I/O, code loading, + ;; process execution, and other capabilities that break sandboxing. + + (define dangerous-bindings + '(;; Code loading and evaluation + load load-shared-object load-program load-library + eval eval-when compile compile-file compile-port + compile-library compile-program compile-whole-program + compile-to-port expand include + library-directories library-extensions + source-directories + + ;; FFI — must be blocked to prevent arbitrary C calls + foreign-procedure foreign-callable foreign-sizeof + foreign-alloc foreign-free foreign-ref foreign-set! + foreign-entry? foreign-entry + ftype-sizeof ftype-ref ftype-set! ftype-pointer-address + ftype-pointer-null? ftype-pointer-ftype make-ftype-pointer + define-ftype lock-object unlock-object + load-shared-object + + ;; Process execution + system process + + ;; File I/O + open-file-input-port open-file-output-port + open-file-input/output-port + open-input-file open-output-file + call-with-input-file call-with-output-file + with-input-from-file with-output-to-file + file-exists? delete-file rename-file + directory-list make-directory delete-directory + file-regular? file-directory? file-symbolic-link? + get-mode chmod + + ;; Environment manipulation + putenv getenv + scheme-environment interaction-environment + copy-environment environment environment-symbols + define-top-level-value set-top-level-value! + top-level-value top-level-bound? + + ;; Module system manipulation + import import-only + + ;; Ports to filesystem + current-directory + standard-input-port standard-output-port standard-error-port + console-input-port console-output-port console-error-port + transcript-on transcript-off + + ;; Low-level and unsafe + #%$top-level-value inspect inspect/object + sc-expand syntax->datum datum->syntax + pretty-print trace-define trace-lambda + with-profile-tracker profile-dump-html + + ;; Exit + exit scheme-start + + ;; Thread creation (could be used to escape) + fork-thread make-thread thread-start!)) + ;; ========== Restricted Environment ========== (define (make-restricted-environment . extra-bindings) - ;; Create an environment with only safe bindings. - (let ([restricted (copy-environment (scheme-environment) #t)]) - ;; Import safe bindings from the scheme environment + ;; Create an environment with ONLY safe bindings. + ;; Strategy: copy the scheme-environment (to get syntax/macros), + ;; then rebind all dangerous symbols to error-raising procedures. + (let ([restricted (copy-environment (scheme-environment) #t)] + [safe-set (make-eq-hashtable)]) + ;; Build lookup table of safe bindings + (for-each (lambda (name) (hashtable-set! safe-set name #t)) safe-bindings) + ;; Remove explicitly dangerous bindings + (for-each + (lambda (name) + (guard (e [#t (void)]) + (when (top-level-bound? name restricted) + (define-top-level-value name + (lambda args + (error 'restricted-eval + (format "~a is not available in restricted environment" name))) + restricted)))) + dangerous-bindings) + ;; Also scan all symbols and block anything not in safe-bindings + ;; that looks like a procedure (conservative: block unknown procedures) + (guard (e [#t (void)]) + (for-each + (lambda (sym) + (unless (hashtable-ref safe-set sym #f) + (guard (e2 [#t (void)]) + (when (and (top-level-bound? sym restricted) + (procedure? (top-level-value sym restricted))) + (define-top-level-value sym + (lambda args + (error 'restricted-eval + (format "~a is not available in restricted environment" sym))) + restricted))))) + (environment-symbols restricted))) + ;; Block syntax keywords that can't be caught by procedure scanning + ;; (foreign-procedure, etc. are special forms, not procedures) + (for-each + (lambda (name) + (guard (e [#t (void)]) + (define-top-level-value name + (lambda args + (error 'restricted-eval + (format "~a is not available in restricted environment" name))) + restricted))) + '(foreign-procedure foreign-callable foreign-entry + foreign-entry? ftype-sizeof ftype-ref ftype-set! + define-ftype make-ftype-pointer + load-shared-object + import import-only library + meta-cond eval-when)) + ;; Re-add safe bindings (in case we accidentally blocked any) + (for-each + (lambda (name) + (guard (e [#t (void)]) + (when (top-level-bound? name (scheme-environment)) + (define-top-level-value name + (top-level-value name (scheme-environment)) + restricted)))) + safe-bindings) + ;; Add any extra bindings + (when (pair? extra-bindings) (for-each - (lambda (name) - (guard (e [#t (void)]) ;; skip if not available - (when (top-level-bound? name (scheme-environment)) - (define-top-level-value name - (top-level-value name (scheme-environment)) - restricted)))) - safe-bindings) - ;; Add any extra bindings - (when (pair? extra-bindings) - (for-each - (lambda (binding) - (when (and (pair? binding) (symbol? (car binding))) - (define-top-level-value (car binding) (cdr binding) restricted))) - (car extra-bindings))) - restricted)) + (lambda (binding) + (when (and (pair? binding) (symbol? (car binding))) + (define-top-level-value (car binding) (cdr binding) restricted))) + (car extra-bindings))) + restricted)) ;; ========== Restricted Eval ========== new file mode 100644 --- /dev/null +++ b/tests/test-functional.ss @@ -0,0 +1,908 @@ +#!chezscheme +;;; test-functional.ss — Functional tests that prove jerboa features WORK +;;; +;;; These are NOT unit tests. They exercise real I/O, real fork/exec, +;;; real kernel enforcement (Landlock), real signals, etc. +;;; Negative tests prove that restrictions are actually enforced. + +(import (chezscheme)) + +;; Load Landlock FFI shim (needed for (std os landlock) / (std os sandbox)) +;; In static binaries, symbols are registered via Sforeign_symbol. +;; For dynamic testing, we compile and load the shared library. +(guard (e [#t (void)]) + (load-shared-object "./support/libjerboa-landlock.so")) + +(define pass-count 0) +(define fail-count 0) +(define skip-count 0) + +(define-syntax check + (syntax-rules (=>) + [(_ expr => expected) + (let ([result expr] + [exp expected]) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") + (write 'expr) + (display " => ") + (write result) + (display " expected ") + (write exp) + (newline))))] + [(_ expr) + (if expr + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") + (write 'expr) + (display " => #f") + (newline)))])) + +(define-syntax check-error + (syntax-rules () + [(_ expr) + (guard (e [#t (set! pass-count (+ pass-count 1))]) + expr + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL (expected error): ") + (write 'expr) + (newline)))])) + +(define-syntax skip + (syntax-rules () + [(_ reason) + (begin + (set! skip-count (+ skip-count 1)) + (display "SKIP: ") + (display reason) + (newline))])) + +(define (string-contains haystack needle) + (let ([hlen (string-length haystack)] + [nlen (string-length needle)]) + (let lp ([i 0]) + (cond + [(> (+ i nlen) hlen) #f] + [(string=? (substring haystack i (+ i nlen)) needle) #t] + [else (lp (+ i 1))])))) + +(define test-dir "/tmp/jerboa-functional-test") +(define (test-path name) (string-append test-dir "/" name)) + +;; Clean up from previous runs +(guard (e [#t (void)]) (system (string-append "rm -rf " test-dir))) +(system (string-append "mkdir -p " test-dir)) + +;;; ====================================================================== +;;; Section 1: POSIX FFI — Real I/O Operations +;;; ====================================================================== +(display "\n=== POSIX FFI: Real I/O ===\n") + +(import (std os posix)) + +;; 1a. Write a file with posix-open/posix-write, read it back, verify content +(let ([path (test-path "posix-write-test.txt")] + [content "Hello from posix-write!\n"]) + (let ([fd (posix-open path (bitwise-ior O_WRONLY O_CREAT O_TRUNC) #o644)]) + (let ([bv (string->utf8 content)]) + (posix-write fd bv (bytevector-length bv))) + (posix-close fd)) + ;; Read it back with posix-open/posix-read + (let ([fd (posix-open path O_RDONLY)]) + (let ([buf (make-bytevector 100)]) + (let ([n (posix-read fd buf 100)]) + (check (= n (string-length content))) + (check (string=? (utf8->string (bytevector-copy buf)) content) => #f) + ;; Actually compare just the bytes read + (let ([result-bv (make-bytevector n)]) + (bytevector-copy! buf 0 result-bv 0 n) + (check (string=? (utf8->string result-bv) content)))))) + ;; Verify with stat + (let ([st (posix-stat path)]) + (check (stat-is-regular? st)) + (check (= (stat-size st) (string-length content))) + (free-stat st)) + ;; Cleanup + (posix-unlink path)) + +;; 1b. Pipe round-trip with binary data (high bytes that would be mangled by text I/O) +(let-values ([(rfd wfd) (posix-pipe)]) + (let ([data (bytevector 0 1 127 128 200 255)]) + (posix-write wfd data 6) + (posix-close wfd) + (let ([buf (make-bytevector 6)]) + (let ([n (posix-read rfd buf 6)]) + (check n => 6) + (check (= (bytevector-u8-ref buf 0) 0)) + (check (= (bytevector-u8-ref buf 2) 127)) + (check (= (bytevector-u8-ref buf 3) 128)) + (check (= (bytevector-u8-ref buf 5) 255))))) + (posix-close rfd)) + +;; 1c. dup2 actually redirects fd +(let-values ([(rfd wfd) (posix-pipe)]) + ;; dup wfd to a high fd number + (let ([high-fd (posix-dup wfd)]) + ;; Write through the dup'd fd + (posix-write high-fd (string->utf8 "dup-test") 8) + (posix-close high-fd) + (posix-close wfd) + ;; Read from read end + (let ([buf (make-bytevector 8)]) + (let ([n (posix-read rfd buf 8)]) + (check n => 8) + (let ([result (make-bytevector n)]) + (bytevector-copy! buf 0 result 0 n) + (check (string=? (utf8->string result) "dup-test")))))) + (posix-close rfd)) + +;; 1d. lseek actually repositions (read same data twice) +(let ([path (test-path "lseek-test.txt")]) + (let ([fd (posix-open path (bitwise-ior O_RDWR O_CREAT O_TRUNC) #o644)]) + (posix-write fd (string->utf8 "ABCDEF") 6) + ;; Seek back to start and read again + (posix-lseek fd 0 SEEK_SET) + (let ([buf (make-bytevector 6)]) + (let ([n (posix-read fd buf 6)]) + (check n => 6) + (let ([result (make-bytevector n)]) + (bytevector-copy! buf 0 result 0 n) + (check (string=? (utf8->string result) "ABCDEF"))))) + ;; Seek to middle and read from there + (posix-lseek fd 3 SEEK_SET) + (let ([buf (make-bytevector 3)]) + (let ([n (posix-read fd buf 3)]) + (check n => 3) + (let ([result (make-bytevector n)]) + (bytevector-copy! buf 0 result 0 n) + (check (string=? (utf8->string result) "DEF"))))) + (posix-close fd)) + (posix-unlink path)) + +;; 1e. O_NONBLOCK actually makes read non-blocking (returns -1/EAGAIN on empty pipe) +(let-values ([(rfd wfd) (posix-pipe)]) + (let ([flags (posix-fcntl-getfl rfd)]) + (posix-fcntl-setfl rfd (bitwise-ior flags O_NONBLOCK)) + ;; Try to read from empty pipe — should return -1 or 0 (EAGAIN) + (let ([buf (make-bytevector 10)]) + (guard (e [(posix-error? e) (check #t)] ;; EAGAIN raises posix-error — good + [#t (check #f)]) ;; unexpected error + (let ([n (posix-read rfd buf 10)]) + ;; If it returns without error, n should be -1 or 0 + (check (or (= n -1) (= n 0))))))) + (posix-close rfd) + (posix-close wfd)) + +;; 1f. Negative: open nonexistent file raises posix-error +(guard (e [(posix-error? e) + (check (= (posix-error-errno e) 2)) ;; ENOENT + (check (eq? (posix-error-syscall e) 'open))] + [#t (check #f)]) + (posix-open "/nonexistent/path/does/not/exist" O_RDONLY) + (check #f)) ;; should not reach here + +;; 1g. Negative: write to read-only fd fails +(let ([path (test-path "readonly-test.txt")]) + (let ([fd (posix-open path (bitwise-ior O_WRONLY O_CREAT O_TRUNC) #o644)]) + (posix-write fd (string->utf8 "data") 4) + (posix-close fd)) + (let ([fd (posix-open path O_RDONLY)]) + (guard (e [(posix-error? e) (check #t)] ;; EBADF or similar + [#t (check #f)]) + (posix-write fd (string->utf8 "hack") 4) + (check #f)) ;; should not reach + (posix-close fd)) + (posix-unlink path)) + +;; 1h. setenv/getenv round-trip — verify env actually changes +(let ([var "JERBOA_FUNC_TEST_12345"]) + (posix-setenv var "test-value-xyz" #t) + (check (string=? (getenv var) "test-value-xyz")) + ;; Verify child process inherits it + (let ([exit-code (system (string-append "test \"$" var "\" = \"test-value-xyz\""))]) + (check (= exit-code 0))) + (posix-unsetenv var) + (check (not (getenv var)))) + +;; 1i. fork+exec via system — verify real command execution +(let ([path (test-path "exec-test.txt")]) + (system (string-append "echo 'created by shell' > " path)) + ;; Verify the file actually exists and has content + (check (posix-access path F_OK)) + (let ([fd (posix-open path O_RDONLY)]) + (let ([buf (make-bytevector 100)]) + (let ([n (posix-read fd buf 100)]) + (check (> n 0)) + (let ([result (make-bytevector n)]) + (bytevector-copy! buf 0 result 0 n) + (check (string-contains (utf8->string result) "created by shell")))))) + (posix-unlink path)) + +;;; ====================================================================== +;;; Section 2: FD Manager — Resource Lifecycle +;;; ====================================================================== +(display "\n=== FD Manager: Resource Lifecycle ===\n") + +(import (std os fd)) + +;; 2a. Write through fd-write, read back through fd-read — real data flow +(let-values ([(rfd wfd) (fd-pipe)]) + (fd-write wfd (string->utf8 "functional test data")) + (let ([data (fd-read rfd 20)]) + (check (string=? (utf8->string data) "functional test data"))) + (fd-close! rfd) + (fd-close! wfd)) + +;; 2b. fd-close! actually closes — subsequent operations should fail +(let-values ([(rfd wfd) (fd-pipe)]) + (fd-close! wfd) + (check (not (fd-open? wfd))) + ;; Writing to closed fd should fail + (guard (e [#t (check #t)]) + (fd-write wfd (string->utf8 "should fail")) + (check #f)) ;; should not reach + (fd-close! rfd)) + +;; 2c. with-fds cleanup — verify fds are ACTUALLY closed after scope +(let ([captured-fd #f]) + (let-values ([(rfd wfd) (fd-pipe)]) + (fd-close! wfd) + (with-fds ([r rfd]) + (set! captured-fd r) + (check (fd-open? r))) + ;; After with-fds, the fd should be closed + (check (not (fd-open? captured-fd))))) + +;; 2d. with-fds cleanup on exception — fd closed even on error +(let ([captured-fd #f]) + (guard (e [#t (void)]) + (let-values ([(rfd wfd) (fd-pipe)]) + (fd-close! wfd) + (with-fds ([r rfd]) + (set! captured-fd r) + (error 'test "intentional")))) + (check (not (fd-open? captured-fd)))) + +;; 2e. spawn-process — verify real command execution +(let ([proc (spawn-process '("sh" "-c" "exit 0"))]) + (process-wait proc) + (check (process-exited? proc)) + (check (= (process-exit-code proc) 0))) + +;; 2f. spawn-process — verify exit code propagation +(let ([proc (spawn-process '("sh" "-c" "exit 42"))]) + (process-wait proc) + (check (process-exited? proc)) + (check (= (process-exit-code proc) 42))) + +;; 2g. Negative: spawn nonexistent command +(let ([proc (spawn-process '("/nonexistent/binary/xyz"))]) + (process-wait proc) + (check (not (= (process-exit-code proc) 0)))) + + +;;; ====================================================================== +;;; Section 3: Sandbox — Real Landlock Enforcement +;;; ====================================================================== +(display "\n=== Sandbox: Landlock Enforcement ===\n") + +(import (std os landlock)) +(import (std os sandbox)) + +(let ([available (landlock-available?)]) + (if (not available) + (begin + (skip "Landlock not supported on this kernel") + (skip "Skipping all sandbox enforcement tests")) + (begin + (display " Landlock available, ABI version: ") + (display (landlock-abi-version)) + (newline) + + ;; 3a. sandbox-run with allowed read path — child can read + (let ([path (test-path "sandbox-readable.txt")]) + ;; Create a file first + (let ([fd (posix-open path (bitwise-ior O_WRONLY O_CREAT O_TRUNC) #o644)]) + (posix-write fd (string->utf8 "sandbox test data") 17) + (posix-close fd)) + ;; Run sandboxed child with read access to test-dir + (let ([status (sandbox-run (list test-dir) '() '() + (lambda () + (guard (e [#t (display-condition e (current-error-port)) + ((foreign-procedure "_exit" (int) void) 1)]) + (let ([fd2 (posix-open path O_RDONLY)]) + (let ([buf (make-bytevector 17)]) + (posix-read fd2 buf 17) + (posix-close fd2) + ;; Verify we actually read the right data + (unless (string=? (utf8->string buf) "sandbox test data") + ((foreign-procedure "_exit" (int) void) 2)))))))]) + (check (= status 0))) + (posix-unlink path)) + + ;; 3b. NEGATIVE: sandbox-run WITHOUT allowed path — child CANNOT read + (let ([path (test-path "sandbox-denied.txt")]) + (let ([fd (posix-open path (bitwise-ior O_WRONLY O_CREAT O_TRUNC) #o644)]) + (posix-write fd (string->utf8 "secret") 6) + (posix-close fd)) + ;; Run sandboxed child with NO access to test-dir + ;; The child should get EACCES and exit non-zero + (let ([status (sandbox-run '() '() '() + (lambda () + ;; Try to read the file — should fail with EACCES + (guard (e [#t ((foreign-procedure "_exit" (int) void) 77)]) + (posix-open path O_RDONLY) + ;; If we get here, Landlock didn't block us! + ((foreign-procedure "_exit" (int) void) 0))))]) + ;; Child should have exited 77 (from EACCES guard) + (check (= status 77))) + (posix-unlink path)) + + ;; 3c. NEGATIVE: sandbox-run — child cannot write without write permission + (let ([path (test-path "sandbox-no-write.txt")]) + (let ([status (sandbox-run (list test-dir) '() '() ;; read-only, no write + (lambda () + (guard (e [#t ((foreign-procedure "_exit" (int) void) 88)]) + ;; Try to create a file — should fail + (posix-open path + (bitwise-ior O_WRONLY O_CREAT O_TRUNC) #o644) + ((foreign-procedure "_exit" (int) void) 0))))]) + ;; Child should have exited 88 (write denied) + (check (= status 88)))) + + ;; 3d. sandbox-run with write permission — child CAN write + (let ([path (test-path "sandbox-writable.txt")]) + (let ([status (sandbox-run (list test-dir) (list test-dir) '() + (lambda () + (guard (e [#t ((foreign-procedure "_exit" (int) void) 1)]) + (let ([fd (posix-open path + (bitwise-ior O_WRONLY O_CREAT O_TRUNC) #o644)]) + (posix-write fd (string->utf8 "written!") 8) + (posix-close fd)))))]) + (check (= status 0))) + ;; Verify the file was actually created by the child + (check (posix-access path F_OK)) + (let ([fd (posix-open path O_RDONLY)]) + (let ([buf (make-bytevector 8)]) + (posix-read fd buf 8) + (check (string=? (utf8->string buf) "written!"))) + (posix-close fd)) + (posix-unlink path)) + + ;; 3e. sandbox-run/command — real shell command in sandbox + (let ([status (sandbox-run/command (list "/tmp" test-dir) '() '() + (string-append "ls " test-dir " > /dev/null 2>&1"))]) + (check (= status 0))) + + ;; 3f. NEGATIVE: sandbox-run/command — command blocked by Landlock + ;; The child tries to cat a file under test-dir, but no read path + ;; includes test-dir. The cat should fail with EACCES. + ;; NOTE: sandbox-run/command returns the CHILD exit code, and the + ;; child always exits 0 if (system ...) doesn't crash. But the + ;; system() call itself will return non-zero from cat's failure. + ;; Actually, the child calls (thunk) then (c-exit 0), so exit is + ;; always 0. We test via a direct sandbox-run with explicit exit. + (let ([path (test-path "sandbox-cmd-test.txt")]) + ;; Create the file + (let ([fd (posix-open path (bitwise-ior O_WRONLY O_CREAT O_TRUNC) #o644)]) + (posix-write fd (string->utf8 "secret") 6) + (posix-close fd)) + (let ([status (sandbox-run '() '() '() + (lambda () + ;; Try to run a command that reads from test-dir + (let ([rc (system (string-append "cat " path " > /dev/null 2>&1"))]) + ;; Exit with the command's exit code + ((foreign-procedure "_exit" (int) void) + (if (= rc 0) 0 99)))))]) + ;; cat should have failed (EACCES), child exits 99 + (check (= status 99))) + (posix-unlink path))))) + + +;;; ====================================================================== +;;; Section 4: Raw Byte I/O — Binary Data Integrity +;;; ====================================================================== +(display "\n=== Raw Byte I/O: Binary Integrity ===\n") + +(import (std io raw)) + +;; 4a. Binary round-trip through pipe — verify no byte mangling +(let-values ([(rfd wfd) (posix-pipe)]) + ;; Write every possible byte value + (let ([all-bytes (make-bytevector 256)]) + (let lp ([i 0]) + (when (< i 256) + (bytevector-u8-set! all-bytes i i) + (lp (+ i 1)))) + (fd-write-bytes wfd all-bytes) + (posix-close wfd) + ;; Read back and verify every byte + (let ([result (fd-read-bytes rfd 256)]) + (check (= (bytevector-length result) 256)) + (let lp ([i 0] [ok #t]) + (if (= i 256) + (check ok) + (lp (+ i 1) (and ok (= (bytevector-u8-ref result i) i))))))) + (posix-close rfd)) + +;; 4b. Binary port wrapping — write through port, read through port +(let-values ([(rfd wfd) (posix-pipe)]) + (let ([out (fd->binary-output-port wfd "test-out")] + [in (fd->binary-input-port rfd "test-in")]) + ;; Write mixed binary data + (put-bytevector out (bytevector #xff #x00 #x80 #x7f #xfe #x01)) + (flush-output-port out) + (close-port out) + ;; Read and verify + (let ([bv (get-bytevector-n in 6)]) + (check (= (bytevector-u8-ref bv 0) #xff)) + (check (= (bytevector-u8-ref bv 1) #x00)) + (check (= (bytevector-u8-ref bv 2) #x80)) + (check (= (bytevector-u8-ref bv 3) #x7f)) + (check (= (bytevector-u8-ref bv 4) #xfe)) + (check (= (bytevector-u8-ref bv 5) #x01))) + (close-port in))) + +;; 4c. bytevector-concat edge cases +(check (bytevector-concat '()) => (make-bytevector 0)) +(check (= (bytevector-length (bytevector-concat (list (bytevector 1 2 3)))) 3)) +(let ([result (bytevector-concat (list (bytevector 1) (bytevector) (bytevector 2 3)))]) + (check (= (bytevector-length result) 3)) + (check (= (bytevector-u8-ref result 0) 1)) + (check (= (bytevector-u8-ref result 1) 2)) + (check (= (bytevector-u8-ref result 2) 3))) + +;; 4d. Large binary data — 64KB round-trip +(let-values ([(rfd wfd) (posix-pipe)]) + (let ([size 65536] + [pattern #xAB]) + (let ([big-data (make-bytevector size pattern)]) + (fd-write-bytes wfd big-data) + (posix-close wfd) + ;; Read in chunks + (let lp ([total-read 0] [chunks '()]) + (let ([chunk (fd-read-bytes rfd 8192)]) + (if (or (not chunk) (= (bytevector-length chunk) 0)) + (let ([result (bytevector-concat (reverse chunks))]) + (check (= (bytevector-length result) size)) + ;; Verify pattern + (let vp ([i 0] [ok #t]) + (if (= i size) + (check ok) + (vp (+ i 1) (and ok (= (bytevector-u8-ref result i) pattern)))))) + (lp (+ total-read (bytevector-length chunk)) + (cons chunk chunks))))))) + (posix-close rfd)) + + +;;; ====================================================================== +;;; Section 5: Persistent Map — Structural Sharing & Immutability +;;; ====================================================================== +(display "\n=== Persistent Map: Immutability ===\n") + +(import (std data pmap)) + +;; 5a. Verify old maps are TRULY unchanged after modification +(let* ([m0 pmap-empty] + [m1 (pmap-set m0 "key1" "val1")] + [m2 (pmap-set m1 "key2" "val2")] + [m3 (pmap-set m2 "key1" "updated")]) + ;; m1 should still have original value + (check (string=? (pmap-ref m1 "key1" #f) "val1")) + ;; m1 should NOT have key2 + (check (eq? (pmap-ref m1 "key2" 'missing) 'missing)) + ;; m3 has updated key1 + (check (string=? (pmap-ref m3 "key1" #f) "updated")) + ;; m2 still has original key1 + (check (string=? (pmap-ref m2 "key1" #f) "val1")) + ;; Sizes + (check (= (pmap-size m0) 0)) + (check (= (pmap-size m1) 1)) + (check (= (pmap-size m2) 2)) + (check (= (pmap-size m3) 2))) + +;; 5b. Delete doesn't affect original +(let* ([m1 (alist->pmap '(("a" . 1) ("b" . 2) ("c" . 3)))] + [m2 (pmap-delete m1 "b")]) + (check (= (pmap-size m1) 3)) ;; original unchanged + (check (= (pmap-size m2) 2)) + (check (pmap-contains? m1 "b")) ;; still in original + (check (not (pmap-contains? m2 "b")))) ;; gone in new + +;; 5c. Stress test — 1000 keys, verify all present and correct +(let ([m (let lp ([i 0] [m pmap-empty]) + (if (= i 1000) m + (lp (+ i 1) (pmap-set m (number->string i) (* i i)))))]) + (check (= (pmap-size m) 1000)) + ;; Spot-check values + (check (= (pmap-ref m "0" #f) 0)) + (check (= (pmap-ref m "1" #f) 1)) + (check (= (pmap-ref m "500" #f) 250000)) + (check (= (pmap-ref m "999" #f) 998001)) + ;; Negative + (check (eq? (pmap-ref m "1000" 'nope) 'nope)) + (check (eq? (pmap-ref m "-1" 'nope) 'nope))) + +;; 5d. pmap-merge — overlay wins for duplicates +(let ([base (alist->pmap '(("a" . 1) ("b" . 2) ("c" . 3)))] + [overlay (alist->pmap '(("b" . 99) ("d" . 4)))]) + (let ([merged (pmap-merge base overlay)]) + (check (= (pmap-ref merged "a" #f) 1)) + (check (= (pmap-ref merged "b" #f) 99)) ;; overlay wins + (check (= (pmap-ref merged "c" #f) 3)) + (check (= (pmap-ref merged "d" #f) 4)) + ;; base unchanged + (check (= (pmap-ref base "b" #f) 2)))) + +;; 5e. pmap-cell (mutable wrapper) — snapshot isolation +(let ([cell (make-pmap-cell)]) + (pmap-cell-set! cell "x" 1) + (pmap-cell-set! cell "y" 2) + (let ([snap (pmap-cell-snapshot cell)]) + ;; Modify cell after snapshot + (pmap-cell-set! cell "x" 999) + (pmap-cell-set! cell "z" 3) + ;; Snapshot is frozen + (check (= (pmap-ref snap "x" #f) 1)) + (check (eq? (pmap-ref snap "z" 'gone) 'gone)) + ;; Cell has new values + (check (= (pmap-cell-ref cell "x") 999)) + (check (= (pmap-cell-ref cell "z") 3)))) + + +;;; ====================================================================== +;;; Section 6: Error Recovery — Actual Retry Behavior +;;; ====================================================================== +(display "\n=== Error Recovery: Retry Behavior ===\n") + +(import (std error recovery)) + +;; 6a. with-retry actually retries the right number of times +(let ([call-count 0]) + (guard (e [#t (void)]) + (with-retry + (lambda () + (set! call-count (+ call-count 1)) + (when (< call-count 3) + (error 'test "not yet"))) + 'attempts: 5)) + (check (= call-count 3))) + +;; 6b. with-retry stops after max attempts +(let ([call-count 0]) + (guard (e [#t (void)]) + (with-retry + (lambda () + (set! call-count (+ call-count 1)) + (error 'test "always fails")) + 'attempts: 4)) + (check (= call-count 4))) + +;; 6c. with-retry succeeds on first try — no retries +(let ([call-count 0]) + (let ([result (with-retry + (lambda () + (set! call-count (+ call-count 1)) + 'success) + 'attempts: 3)]) + (check (= call-count 1)) + (check (eq? result 'success)))) + +;; 6d. with-fallback — primary succeeds +(let ([result (with-fallback + (lambda () 'primary) + (lambda (e) 'fallback))]) + (check (eq? result 'primary))) + +;; 6e. with-fallback — primary fails, fallback used +(let ([result (with-fallback + (lambda () (error 'test "fail")) + (lambda (e) 'caught-it))]) + (check (eq? result 'caught-it))) + +;; 6f. with-cleanup — only runs on error +(let ([cleanup-ran #f]) + (with-cleanup + (lambda () 42) + (lambda () (set! cleanup-ran #t))) + (check (not cleanup-ran))) ;; NOT called on success + +(let ([cleanup-ran #f]) + (guard (e [#t (void)]) + (with-cleanup + (lambda () (error 'test "boom")) + (lambda () (set! cleanup-ran #t)))) + (check cleanup-ran)) ;; Called on error + + +;;; ====================================================================== +;;; Section 7: Capability Security — Restricted Eval +;;; ====================================================================== +(display "\n=== Security: Restricted Eval ===\n") + +(import (std security restrict)) + +;; 7a. Safe operations work +(check (restricted-eval '(+ 1 2 3)) => 6) +(check (restricted-eval '(map (lambda (x) (* x x)) '(1 2 3 4))) => '(1 4 9 16)) +(check (restricted-eval '(string-append "hello" " " "world")) => "hello world") +(check (restricted-eval '(length '(a b c d e))) => 5) +(check (restricted-eval '(apply + '(1 2 3 4 5))) => 15) + +;; 7b. NEGATIVE: Dangerous operations are blocked +;; load should be blocked +(guard (e [#t (check #t)]) + (restricted-eval '(load "malicious.ss")) + (begin (set! fail-count (+ fail-count 1)) + (display "FAIL: restricted-eval did NOT block 'load'\n"))) + +;; system should be blocked +(guard (e [#t (check #t)]) + (restricted-eval '(system "echo ESCAPED")) + (begin (set! fail-count (+ fail-count 1)) + (display "FAIL: restricted-eval did NOT block 'system'\n"))) + +;; eval in restricted context should not escape +(guard (e [#t (check #t)]) + (restricted-eval '(eval '(+ 1 2) (scheme-environment))) + (begin (set! fail-count (+ fail-count 1)) + (display "FAIL: restricted-eval did NOT block 'eval'\n"))) + +;; foreign-procedure should be blocked +(guard (e [#t (check #t)]) + (restricted-eval '(foreign-procedure "system" (string) int)) + (begin (set! fail-count (+ fail-count 1)) + (display "FAIL: restricted-eval did NOT block 'foreign-procedure'\n"))) + +;; delete-file should be blocked +(guard (e [#t (check #t)]) + (restricted-eval '(delete-file "/tmp/nonexistent-test-file")) + (begin (set! fail-count (+ fail-count 1)) + (display "FAIL: restricted-eval did NOT block 'delete-file'\n"))) + + +;;; ====================================================================== +;;; Section 8: Platform Abstraction — Real System Info +;;; ====================================================================== +(display "\n=== Platform: System Info ===\n") + +(import (std os platform)) + +;; 8a. Verify we're on Linux (since that's what these tests run on) +(check (string=? (platform-name) "linux")) +(check (platform-linux?)) +(check (not (platform-macos?))) + +;; 8b. CPU count is sane +(let ([cpus (platform-cpu-count)]) + (check (> cpus 0)) + (check (< cpus 10000))) ;; sanity upper bound + +;; 8c. Page size is power of 2 and reasonable +(let ([ps (platform-page-size)]) + (check (> ps 0)) + (check (= 0 (bitwise-and ps (- ps 1)))) ;; power of 2 + (check (>= ps 4096))) + +;; 8d. Temp file path actually produces usable paths +(let ([p (platform-tmpfile-path "test" ".dat")]) + (check (string? p)) + (check (> (string-length p) 0)) + ;; Should be able to create a file at this path + (let ([port (open-file-output-port p)]) + (put-bytevector port (bytevector 1 2 3)) + (close-port port) + (check (file-exists? p)) + (delete-file p))) + + +;;; ====================================================================== +;;; Section 9: Build System — Content Hashing & Topo Sort +;;; ====================================================================== +(display "\n=== Build System ===\n") + +(import (std build)) + +;; 9a. Content hash is deterministic +(let ([h1 (content-hash "hello world")] + [h2 (content-hash "hello world")] + [h3 (content-hash "hello world!")]) + (check (= h1 h2)) + (check (not (= h1 h3)))) + +;; 9b. Topological sort respects dependencies +(let ([dag '(("compile" . ("parse")) + ("parse" . ("lex")) + ("lex" . ()) + ("link" . ("compile")) + ("run" . ("link")))]) + (let ([sorted (topological-sort dag)]) + (check (= (length sorted) 5)) + ;; lex must come before parse, parse before compile, etc. + (let ([pos (lambda (name) + (let lp ([l sorted] [i 0]) + (cond [(null? l) -1] + [(string=? (car l) name) i] + [else (lp (cdr l) (+ i 1))])))]) + (check (< (pos "lex") (pos "parse"))) + (check (< (pos "parse") (pos "compile"))) + (check (< (pos "compile") (pos "link"))) + (check (< (pos "link") (pos "run")))))) + +;; 9c. Build cache persistence — save and reload +(let ([cache-path (test-path "build-cache.fasl")]) + (let ([cache (build-cache-load cache-path)]) + (check (hashtable? cache)) + (hashtable-set! cache "module-a.sls" 12345) + (hashtable-set! cache "module-b.sls" 67890) + (build-cache-save cache-path cache)) + ;; Reload — verify it's a valid hashtable with our data + (guard (e [#t + ;; If fasl round-trip fails, that's a real bug — report it + (set! fail-count (+ fail-count 1)) + (display "FAIL: build-cache round-trip: ") + (when (message-condition? e) (display (condition-message e))) + (newline)]) + (let ([cache2 (build-cache-load cache-path)]) + (check (hashtable? cache2)) + (check (= (hashtable-ref cache2 "module-a.sls" 0) 12345)) + (check (= (hashtable-ref cache2 "module-b.sls" 0) 67890)))) + (guard (e [#t (void)]) (delete-file cache-path))) + + +;;; ====================================================================== +;;; Section 10: Signal Handling — Real Signal Delivery +;;; ====================================================================== +(display "\n=== Signal Handling ===\n") + +(import (std os signal)) +