prevent collect-safe FFI movable-pointer bugs
ober
2834f9186a84302f1ee7d10dac1bc0021c061e33
--- a/Makefile +++ b/Makefile @@ -61,7 +61,7 @@ JCODE_DEV_NATIVE_ENV = JERBOA_DEV_NATIVE=1 \ JERBOA_NATIVE_LIB="$(JCODE_DEV_NATIVE_LIB)" \ JCODE_TUI_DEV_NATIVE=1 JCODE_TUI_LIB="$(JCODE_DEV_TUI_LIB)" -.PHONY: all help ensure-jerboa-tools build gen run test fuzz test-websearch-worker test-websearch-packaged test-tui-native-loader-security test-binary-startup security audit security-audit verify sbom target-evidence reproducibility-report release-evidence test-providers local-eval clean repl binary install tui-shim run-tui native-rs linux linux-check linux-amd64 linux-arm64 jcode-linux-amd64 jcode-linux-arm64 freebsd freebsd-amd64 jcode-freebsd-amd64 purge-stale android android-clean vendor-deps vendor-provenance-check vendor-clean lint +.PHONY: all help ensure-jerboa-tools build gen run test fuzz test-websearch-worker test-websearch-packaged test-tui-native-loader-security test-binary-startup security audit security-audit verify sbom target-evidence reproducibility-report release-evidence test-providers local-eval clean repl binary install tui-shim run-tui native-rs linux linux-check linux-amd64 linux-arm64 jcode-linux-amd64 jcode-linux-arm64 freebsd freebsd-amd64 jcode-freebsd-amd64 purge-stale android android-clean vendor-deps vendor-provenance-check vendor-clean lint lint-ffi all: help @@ -206,7 +206,11 @@ vendor-provenance-check: vendor-deps $(NATIVE_DIR) vendor-clean: rm -rf vendor -lint: gen +lint: gen lint-ffi + +# Reject GC-unsafe __collect_safe FFI declarations (movable u8*/string args). +lint-ffi: + sh scripts/ffi-collect-safe-check.sh gen: ensure-jerboa-tools vendor-deps purge-stale $(JERBUILD) transpile src lib @@ -245,6 +249,9 @@ test: build test-websearch-worker test-tui-native-loader-security JERBSEARCH_ENGINE_WORKER="$(WEBSEARCH_WORKER)" \ $(JCODE_DEV_NATIVE_ENV) \ $(JEXEC) test/run.ss + JERBSEARCH_ENGINE_WORKER="$(WEBSEARCH_WORKER)" \ + $(JCODE_DEV_NATIVE_ENV) \ + $(JEXEC) test/ffi-gc-stress.ss $(MAKE) test-binary-startup fuzz: build --- a/SECURITY.md +++ b/SECURITY.md @@ -50,6 +50,31 @@ must be cut from a clean checkout after: worker, parser, or reviewed native TLS overlay fails closed. Packaged mode clears external parser/fallback overrides and requires its embedded sandbox. +## FFI Memory Safety Rules + +Every `foreign-procedure` declaration in this repo must satisfy two checks: + +1. **Can it block in the kernel?** Then it must be declared `__collect_safe` + so it does not pin the Chez TC mutex and freeze every other thread. +2. **Does it take Scheme-pointer arguments** (`u8*`, `u16*`, `u32*`, + `string`)? A `__collect_safe` call releases the TC mutex, so the moving + collector can relocate the object while native code is parked in the + syscall; the native side then reads/writes a stale address. This was the + root cause of a production `SEGFAULT ctx=tui.agent-worker` ("invalid + memory reference") during HTTPS streaming. + + Such bindings must take `void*` into scoped `foreign-alloc` memory, + copied in/out and freed with `dynamic-wind` — the audited pattern in + `(std net tls-rustls)` (`call-with-rustls-io-buffer`). Movable Scheme + pointers are only acceptable in non-collect-safe calls that are provably + fast (the collector cannot run while the TC mutex is held). + +Do not redeclare FFI bindings locally when `(std ...)` already exports them +— local copies bypass upstream audits. `make lint-ffi` +(`scripts/ffi-collect-safe-check.sh`) rejects movable-pointer +`__collect_safe` declarations, and `test/ffi-gc-stress.ss` exercises the +collect-safe I/O paths under forced garbage-collection pressure. + ## Release Gates - Required files: `LICENSE`, `SECURITY.md`, `.gitignore`, `README.md`, new file mode 100755 --- /dev/null +++ b/scripts/ffi-collect-safe-check.sh @@ -0,0 +1,69 @@ +#!/bin/sh +# ffi-collect-safe-check.sh -- reject GC-unsafe FFI declarations. +# +# Rule: a foreign-procedure declared __collect_safe must not take movable +# Scheme pointer arguments (u8*, u16*, u32*, string). A collect-safe call +# releases the Chez TC mutex while parked in the kernel, so the moving +# collector can relocate the object and native code then reads/writes a +# stale address -> heap corruption, later "invalid memory reference" +# crashes (observed in production as the tui.agent-worker segfault). +# +# Safe alternatives: void* into a scoped foreign-alloc buffer (see +# call-with-rustls-io-buffer in (std net tls-rustls)), or a non-collect-safe +# binding for provably fast/nonblocking calls. +# +# Scans src/**/*.ss. Exits 1 and prints offenders if any are found. + +set -eu + +repo_root=$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd) + +# Extract every (foreign-procedure ... ) form (paren-balanced, so multi-line +# declarations work) from all sources, tagged with file and start line, and +# print any form that is both __collect_safe and mentions a movable Scheme +# pointer type. +offenders=$( + find "$repo_root/src" -name '*.ss' -type f -print0 | + xargs -0 awk ' + function flush( i, form) { + if (in_form) { + form = buf + if (form ~ /__collect_safe/ && form ~ /(u8\*|u16\*|u32\*|string)/) { + printf "%s:%d: %s\n", file, start_line, form + } + buf = "" + in_form = 0 + } + } + FNR == 1 { flush(); file = FILENAME } + { + line = $0 + if (!in_form && line ~ /\(foreign-procedure/) { + in_form = 1 + start_line = FNR + buf = line + } else if (in_form) { + buf = buf " " line + } + if (in_form) { + n = split(buf, chars, "") + depth = 0 + for (i = 1; i <= n; i++) { + if (chars[i] == "(") depth++ + else if (chars[i] == ")") depth-- + } + if (depth <= 0) flush() + } + } + END { flush() } + ' +) + +if [ -n "$offenders" ]; then + printf 'ERROR: GC-unsafe __collect_safe FFI declarations found:\n%s\n' "$offenders" >&2 + printf '%s\n' "A __collect_safe call must not take movable Scheme pointers (u8*/u16*/u32*/string)." >&2 + printf '%s\n' "Use void* with a scoped foreign-alloc buffer; see (std net tls-rustls)." >&2 + exit 1 +fi + +printf 'ffi-collect-safe-check: OK (no movable-pointer __collect_safe declarations)\n' --- a/src/jcode/provider/http.ss +++ b/src/jcode/provider/http.ss @@ -164,90 +164,13 @@ (when body-str (put-string out body-str)) (get-output-string out))) -;; TC-safe rustls bindings. -;; -;; The std lib's rustls-{read,write,flush,close} are plain foreign-procedure -;; declarations that hold the Chez TC mutex during the call. When any of -;; them block waiting on the kernel (a slow read, a full TCP send buffer, -;; a socket shutdown that races a peer close) no other Scheme thread can -;; run -- so the streaming watchdog in this module never fires and a -;; silent server hangs jcode forever. -;; -;; These bindings declare __collect_safe so the scheduler can switch -;; threads while the C side is parked in a syscall. Same pattern as the -;; termbox poll binding in src/jcode/ui/tui-ffi.ss. -(def c-jcode-tls-read - (foreign-procedure __collect_safe "jerboa_tls_read" - (unsigned-64 void* unsigned-64) int)) -(def c-jcode-tls-write - (foreign-procedure __collect_safe "jerboa_tls_write" - (unsigned-64 void* unsigned-64) int)) -(def jcode-tls-flush - (foreign-procedure __collect_safe "jerboa_tls_flush" - (unsigned-64) int)) -(def jcode-tls-close - (foreign-procedure __collect_safe "jerboa_tls_close" - (unsigned-64) void)) - -;; GC-safety: a __collect_safe call releases the TC mutex, so the moving -;; collector can relocate Scheme objects while the C side is parked in a -;; syscall. Handing rustls a movable bytevector as u8* lets it read or -;; write a stale address after a GC -- this is the "invalid memory -;; reference" segfault that ~/.jcode/crash.log records for the agent -;; worker. The raw bindings above therefore take void* and every call -;; bounces through a scoped foreign buffer (same pattern as -;; call-with-rustls-io-buffer in (std net tls-rustls)). -(def (with-tls-buffer-freed ptr k) - (dynamic-wind void - (lambda () (k ptr)) - (lambda () (foreign-free ptr)))) - -(def (call-with-tls-io-buffer who size k) - (unless (and (integer? size) (exact? size) (>= size 0)) - (error who "invalid TLS foreign buffer size" size)) - (let ((ptr (foreign-alloc (max 1 size)))) - (unless (and ptr (not (= ptr 0))) - (error who "TLS foreign buffer allocation failed" size)) - (with-tls-buffer-freed ptr k))) - -(def (check-tls-bv-args who buf len) - (unless (bytevector? buf) - (error who "expected bytevector" buf)) - (unless (and (integer? len) (exact? len) (>= len 0) - (<= len (bytevector-length buf))) - (error who "TLS length exceeds bytevector capacity" - len (bytevector-length buf)))) - -(def (copy-tls-input! who bv ptr len) - (check-tls-bv-args who bv len) - (do ((i 0 (+ i 1))) - ((>= i len)) - (foreign-set! 'unsigned-8 ptr i (bytevector-u8-ref bv i)))) - -(def (copy-tls-output! who ptr bv len) - (check-tls-bv-args who bv len) - (do ((i 0 (+ i 1))) - ((>= i len)) - (bytevector-u8-set! bv i (foreign-ref 'unsigned-8 ptr i)))) - -;; Bytevector API used by every I/O helper below. Signatures match the -;; old raw u8* bindings; the foreign copy keeps the moving collector -;; from ever handing rustls a stale address across a blocked call. -(def (jcode-tls-read conn buf max-len) - (check-tls-bv-args 'jcode-tls-read buf max-len) - (call-with-tls-io-buffer 'jcode-tls-read max-len - (lambda (tmp) - (let ((n (c-jcode-tls-read conn tmp max-len))) - (when (> n 0) - (copy-tls-output! 'jcode-tls-read tmp buf n)) - n)))) - -(def (jcode-tls-write conn buf len) - (check-tls-bv-args 'jcode-tls-write buf len) - (call-with-tls-io-buffer 'jcode-tls-write len - (lambda (tmp) - (copy-tls-input! 'jcode-tls-write buf tmp len) - (c-jcode-tls-write conn tmp len)))) +;; TLS I/O uses the rustls-{read,write,flush,close} bindings from (std net +;; tls-rustls): they are __collect_safe (so the streaming watchdog below can +;; fire while a read is parked in the kernel) and take void* scoped foreign +;; buffers (so the moving collector can never hand rustls a stale address). +;; Do NOT redeclare these bindings locally -- a previous local copy used +;; u8* movable bytevectors and caused the "invalid memory reference" +;; segfault recorded in ~/.jcode/crash.log for the agent worker. ;; TLS I/O: write full string via rustls (def (tls-write-string conn s) @@ -260,10 +183,10 @@ (bytevector-copy! bv offset c 0 4096) c) (let ((c (make-bytevector remaining))) (bytevector-copy! bv offset c 0 remaining) c))) - (n (jcode-tls-write conn chunk (bytevector-length chunk)))) + (n (rustls-write conn chunk (bytevector-length chunk)))) (when (< n 0) (error 'tls-write-string "TLS write failed")) (loop (+ offset n))))) - (jcode-tls-flush conn))) + (rustls-flush conn))) ;; Build a UTF-8 string from a reverse list of bytes, dropping a trailing ;; CR (carriage return) if present. Shared by the line readers below. @@ -289,7 +212,7 @@ (rev-bytes '()) (got-any #f)) (let loop () - (let ((n (jcode-tls-read conn buf 1))) + (let ((n (rustls-read conn buf 1))) (cond ((<= n 0) (and got-any (bytes->line rev-bytes))) @@ -309,7 +232,7 @@ (let loop ((offset 0)) (if (>= offset n) (utf8->string result) (let* ((want (min 4096 (- n offset))) - (got (jcode-tls-read conn buf want))) + (got (rustls-read conn buf want))) (cond ((<= got 0) (utf8->string (let ((r (make-bytevector offset))) (bytevector-copy! result 0 r 0 offset) r))) @@ -321,7 +244,7 @@ (let ((out (open-output-string)) (buf (make-bytevector 4096))) (let loop () - (let ((n (jcode-tls-read conn buf 4096))) + (let ((n (rustls-read conn buf 4096))) (if (<= n 0) (get-output-string out) (begin (put-string out (utf8->string @@ -488,7 +411,7 @@ (def (close-once!) (unless (vector-ref closed? 0) (vector-set! closed? 0 #t) - (jcode-tls-close conn))) + (rustls-close conn))) (fork-thread (lambda () (guard (e [#t (when (tracing?) @@ -718,7 +641,7 @@ (def (close-once!) (unless (vector-ref closed? 0) (vector-set! closed? 0 #t) - (jcode-tls-close conn))) + (rustls-close conn))) ;; Watchdog: closes the connection if no bytes arrive for ;; timeout-secs seconds. Two correctness traps to remember here: ;; @@ -729,10 +652,10 @@ ;; ;; 2. The Scheme thread the watchdog runs on can only run ;; while the main thread is not holding the Chez TC mutex. - ;; That is why jcode-tls-read above declares __collect_safe - ;; -- without it, a blocked TLS read pins TC and the - ;; watchdog never gets scheduled, so a silent server hangs - ;; jcode forever. + ;; That is why (std net tls-rustls) declares its read/write + ;; bindings __collect_safe -- without it, a blocked TLS + ;; read pins TC and the watchdog never gets scheduled, so + ;; a silent server hangs jcode forever. (fork-thread (lambda () (guard (e [#t (when (tracing?) @@ -897,7 +820,7 @@ (let ((chunks '()) (buf (make-bytevector 4096))) (let loop () - (let ((n (jcode-tls-read conn buf 4096))) + (let ((n (rustls-read conn buf 4096))) (if (<= n 0) (concat-bytevectors (reverse chunks)) (let ((chunk (make-bytevector n))) @@ -1002,7 +925,7 @@ (else (tls-read-all-bytes conn)))) (body (utf8->string body-bv))) (values status body))) - (lambda () (jcode-tls-close conn)))) + (lambda () (rustls-close conn)))) (let-values (((in out) (tcp-connect host port))) (dynamic-wind (lambda () (void)) --- a/src/jcode/provider/provider.ss +++ b/src/jcode/provider/provider.ss @@ -305,90 +305,13 @@ (when body-str (put-string out body-str)) (get-output-string out))) -;; TC-safe rustls bindings. -;; -;; The std lib's rustls-{read,write,flush,close} are plain foreign-procedure -;; declarations that hold the Chez TC mutex during the call. When any of -;; them block waiting on the kernel (a slow read, a full TCP send buffer, -;; a socket shutdown that races a peer close) no other Scheme thread can -;; run -- so the streaming watchdog in this module never fires and a -;; silent server hangs jcode forever. -;; -;; These bindings declare __collect_safe so the scheduler can switch -;; threads while the C side is parked in a syscall. Same pattern as the -;; termbox poll binding in src/jcode/ui/tui-ffi.ss. -(def c-jcode-tls-read - (foreign-procedure __collect_safe "jerboa_tls_read" - (unsigned-64 void* unsigned-64) int)) -(def c-jcode-tls-write - (foreign-procedure __collect_safe "jerboa_tls_write" - (unsigned-64 void* unsigned-64) int)) -(def jcode-tls-flush - (foreign-procedure __collect_safe "jerboa_tls_flush" - (unsigned-64) int)) -(def jcode-tls-close - (foreign-procedure __collect_safe "jerboa_tls_close" - (unsigned-64) void)) - -;; GC-safety: a __collect_safe call releases the TC mutex, so the moving -;; collector can relocate Scheme objects while the C side is parked in a -;; syscall. Handing rustls a movable bytevector as u8* lets it read or -;; write a stale address after a GC -- this is the "invalid memory -;; reference" segfault that ~/.jcode/crash.log records for the agent -;; worker. The raw bindings above therefore take void* and every call -;; bounces through a scoped foreign buffer (same pattern as -;; call-with-rustls-io-buffer in (std net tls-rustls)). -(def (with-tls-buffer-freed ptr k) - (dynamic-wind void - (lambda () (k ptr)) - (lambda () (foreign-free ptr)))) - -(def (call-with-tls-io-buffer who size k) - (unless (and (integer? size) (exact? size) (>= size 0)) - (error who "invalid TLS foreign buffer size" size)) - (let ((ptr (foreign-alloc (max 1 size)))) - (unless (and ptr (not (= ptr 0))) - (error who "TLS foreign buffer allocation failed" size)) - (with-tls-buffer-freed ptr k))) - -(def (check-tls-bv-args who buf len) - (unless (bytevector? buf) - (error who "expected bytevector" buf)) - (unless (and (integer? len) (exact? len) (>= len 0) - (<= len (bytevector-length buf))) - (error who "TLS length exceeds bytevector capacity" - len (bytevector-length buf)))) - -(def (copy-tls-input! who bv ptr len) - (check-tls-bv-args who bv len) - (do ((i 0 (+ i 1))) - ((>= i len)) - (foreign-set! 'unsigned-8 ptr i (bytevector-u8-ref bv i)))) - -(def (copy-tls-output! who ptr bv len) - (check-tls-bv-args who bv len) - (do ((i 0 (+ i 1))) - ((>= i len)) - (bytevector-u8-set! bv i (foreign-ref 'unsigned-8 ptr i)))) - -;; Bytevector API used by every I/O helper below. Signatures match the -;; old raw u8* bindings; the foreign copy keeps the moving collector -;; from ever handing rustls a stale address across a blocked call. -(def (jcode-tls-read conn buf max-len) - (check-tls-bv-args 'jcode-tls-read buf max-len) - (call-with-tls-io-buffer 'jcode-tls-read max-len - (lambda (tmp) - (let ((n (c-jcode-tls-read conn tmp max-len))) - (when (> n 0) - (copy-tls-output! 'jcode-tls-read tmp buf n)) - n)))) - -(def (jcode-tls-write conn buf len) - (check-tls-bv-args 'jcode-tls-write buf len) - (call-with-tls-io-buffer 'jcode-tls-write len - (lambda (tmp) - (copy-tls-input! 'jcode-tls-write buf tmp len) - (c-jcode-tls-write conn tmp len)))) +;; TLS I/O uses the rustls-{read,write,flush,close} bindings from (std net +;; tls-rustls): they are __collect_safe (so the streaming watchdog below can +;; fire while a read is parked in the kernel) and take void* scoped foreign +;; buffers (so the moving collector can never hand rustls a stale address). +;; Do NOT redeclare these bindings locally -- a previous local copy used +;; u8* movable bytevectors and caused the "invalid memory reference" +;; segfault recorded in ~/.jcode/crash.log for the agent worker. ;; TLS I/O: write full string via rustls (def (tls-write-string conn s) @@ -401,10 +324,10 @@ (bytevector-copy! bv offset c 0 4096) c) (let ((c (make-bytevector remaining))) (bytevector-copy! bv offset c 0 remaining) c))) - (n (jcode-tls-write conn chunk (bytevector-length chunk)))) + (n (rustls-write conn chunk (bytevector-length chunk)))) (when (< n 0) (error 'tls-write-string "TLS write failed")) (loop (+ offset n))))) - (jcode-tls-flush conn))) + (rustls-flush conn))) ;; Build a UTF-8 string from a reverse list of bytes, dropping a trailing ;; CR (carriage return) if present. Shared by the line readers below. @@ -430,7 +353,7 @@ (rev-bytes '()) (got-any #f)) (let loop () - (let ((n (jcode-tls-read conn buf 1))) + (let ((n (rustls-read conn buf 1))) (cond ((<= n 0) (and got-any (bytes->line rev-bytes))) @@ -450,7 +373,7 @@ (let loop ((offset 0)) (if (>= offset n) (utf8->string result) (let* ((want (min 4096 (- n offset))) - (got (jcode-tls-read conn buf want))) + (got (rustls-read conn buf want))) (cond ((<= got 0) (utf8->string (let ((r (make-bytevector offset))) (bytevector-copy! result 0 r 0 offset) r))) @@ -462,7 +385,7 @@ (let ((out (open-output-string)) (buf (make-bytevector 4096))) (let loop () - (let ((n (jcode-tls-read conn buf 4096))) + (let ((n (rustls-read conn buf 4096))) (if (<= n 0) (get-output-string out) (begin (put-string out (utf8->string @@ -629,7 +552,7 @@ (def (close-once!) (unless (vector-ref closed? 0) (vector-set! closed? 0 #t) - (jcode-tls-close conn))) + (rustls-close conn))) (fork-thread (lambda () (guard (e [#t (when (tracing?) @@ -861,7 +784,7 @@ (def (close-once!) (unless (vector-ref closed? 0) (vector-set! closed? 0 #t) - (jcode-tls-close conn))) + (rustls-close conn))) ;; Watchdog: closes the connection if no bytes arrive for ;; timeout-secs seconds. Two correctness traps to remember here: ;; @@ -872,10 +795,10 @@ ;; ;; 2. The Scheme thread the watchdog runs on can only run ;; while the main thread is not holding the Chez TC mutex. - ;; That is why jcode-tls-read above declares __collect_safe - ;; -- without it, a blocked TLS read pins TC and the - ;; watchdog never gets scheduled, so a silent server hangs - ;; jcode forever. + ;; That is why (std net tls-rustls) declares its read/write + ;; bindings __collect_safe -- without it, a blocked TLS + ;; read pins TC and the watchdog never gets scheduled, so + ;; a silent server hangs jcode forever. (fork-thread (lambda () (guard (e [#t (when (tracing?) @@ -3275,7 +3198,7 @@ (let ((chunks '()) (buf (make-bytevector 4096))) (let loop () - (let ((n (jcode-tls-read conn buf 4096))) + (let ((n (rustls-read conn buf 4096))) (if (<= n 0) (concat-bytevectors (reverse chunks)) (let ((chunk (make-bytevector n))) @@ -3380,7 +3303,7 @@ (else (tls-read-all-bytes conn)))) (body (utf8->string body-bv))) (values status body))) - (lambda () (jcode-tls-close conn)))) + (lambda () (rustls-close conn)))) (let-values (((in out) (tcp-connect host port))) (dynamic-wind (lambda () (void)) new file mode 100644 --- /dev/null +++ b/test/ffi-gc-stress.ss @@ -0,0 +1,258 @@ +#!/usr/bin/env scheme --script +;;; test/ffi-gc-stress.ss -- GC stress for collect-safe FFI I/O paths. +;;; +;;; A hammer thread forces garbage collections in a tight loop while the +;;; main thread performs blocking __collect_safe FFI I/O: +;;; +;;; 1. secure-write-file-string -> c-write (libc write(2)) +;;; 2. a local rustls loopback -> rustls-read / rustls-write +;;; +;;; With movable u8* buffers this corrupts payload data (or the heap) +;;; within seconds, because the moving collector relocates the bytevector +;;; while native code is parked in the syscall. With the scoped +;;; foreign-buffer pattern it must pass byte-exactly. + +(import (scheme) + (jcode core path-policy) + (std net tls-rustls) + (std misc thread)) + +(define printf-failures 0) + +(define (fail who e) + (set! printf-failures (+ printf-failures 1)) + (printf " FAIL: ~a: ~a\n" who + (if (condition? e) + (call-with-string-output-port + (lambda (p) (display-condition e p))) + e))) + +;;; ---- GC hammer ----------------------------------------------------------- + +(define stop-hammer? #f) + +;;; Chez raises "cannot collect when multiple threads are active" on a +;;; direct (collect) call from a non-main thread, so force collections +;;; the production way: sustained allocation pressure. 64 KiB per +;;; iteration fills generation 0 quickly and triggers frequent moving +;;; collections while the I/O thread is parked in a collect-safe call. +(define hammer-thread + (fork-thread + (lambda () + (let loop () + (unless stop-hammer? + (make-bytevector 65536) + (loop)))))) + +(define (stop-hammer!) + (set! stop-hammer? #t)) + +;;; ---- Part 1: c-write under GC stress ------------------------------------- + +(define stress-file ".ffi-gc-stress.tmp") + +(define (part-c-write) + (guard (e [#t (fail 'c-write e)]) + (let ((content (make-string (* 4 1024 1024) #\g))) + (do ((i 0 (+ i 1))) + ((>= i 5)) + (secure-write-file-string stress-file content) + (let ((actual (secure-read-file-string stress-file))) + (unless (string=? actual content) + (error 'c-write "payload corrupted under GC stress" i)))) + (secure-delete-file! stress-file) + (printf " PASS: c-write byte-exact under GC stress (5 x 4 MiB)\n")))) + +;;; ---- Part 2: rustls loopback under GC stress ------------------------------ + +;;; Raw libc sockets for the loopback listener. Integer/void* arguments +;;; only -- no movable Scheme pointers, so these are GC-safe. accept(2) +;;; can block, so it is declared __collect_safe. +(define c-socket (foreign-procedure "socket" (int int int) int)) +(define c-bind (foreign-procedure "bind" (int void* int) int)) +(define c-listen (foreign-procedure "listen" (int int) int)) +(define c-accept (foreign-procedure __collect_safe "accept" (int void* void*) int)) +(define c-getsockname (foreign-procedure "getsockname" (int void* void*) int)) +(define c-close-fd (foreign-procedure "close" (int) int)) + +(define AF_INET 2) +(define SOCK_STREAM 1) + +(define (make-sockaddr-in-foreign port) + (let ((p (foreign-alloc 16))) + (do ((i 0 (+ i 1))) + ((>= i 16)) + (foreign-set! 'unsigned-8 p i 0)) + (foreign-set! 'unsigned-8 p 0 16) ;; sin_len (BSD) + (foreign-set! 'unsigned-8 p 1 AF_INET) + (foreign-set! 'unsigned-8 p 2 (fxarithmetic-shift-right port 8)) + (foreign-set! 'unsigned-8 p 3 (fxand port #xff)) + (foreign-set! 'unsigned-8 p 4 127) ;; 127.0.0.1 + (foreign-set! 'unsigned-8 p 5 0) + (foreign-set! 'unsigned-8 p 6 0) + (foreign-set! 'unsigned-8 p 7 1) + p)) + +(define (open-loopback-listener) + (let ((fd (c-socket AF_INET SOCK_STREAM 0))) + (when (< fd 0) (error 'tls-loopback "socket(2) failed")) + (let ((addr (make-sockaddr-in-foreign 0))) + (unless (= 0 (c-bind fd addr 16)) + (error 'tls-loopback "bind(2) failed")) + (unless (= 0 (c-listen fd 4)) + (error 'tls-loopback "listen(2) failed")) + (let ((lenp (foreign-alloc 4))) + (foreign-set! 'unsigned-32 lenp 0 16) + (unless (= 0 (c-getsockname fd addr lenp)) + (error 'tls-loopback "getsockname(2) failed")) + (let ((port (fx+ (fxarithmetic-shift-left + (foreign-ref 'unsigned-8 addr 2) 8) + (foreign-ref 'unsigned-8 addr 3)))) + (foreign-free addr) + (foreign-free lenp) + (values fd port)))))) + +(define tls-dir "/tmp/jcode-ffi-gc-stress") +(define cert-pem (string-append tls-dir "/cert.pem")) +(define key-pem (string-append tls-dir "/key.pem")) +(define cert-der (string-append tls-dir "/cert.der")) + +(define (openssl-available?) + (= 0 (system "command -v openssl >/dev/null 2>&1"))) + +(define (generate-self-signed-cert) + (system (string-append "rm -rf " tls-dir " && mkdir -p " tls-dir)) + (unless (= 0 (system (string-append + "openssl req -x509 -newkey rsa:2048" + " -keyout " key-pem " -out " cert-pem + " -days 1 -nodes -subj /CN=localhost" + " >/dev/null 2>&1"))) + (error 'tls-loopback "openssl req failed")) + (unless (= 0 (system (string-append + "openssl x509 -in " cert-pem + " -outform der -out " cert-der))) + (error 'tls-loopback "openssl x509 failed"))) + +(define (cert-pin-sha256) + (let ((p (open-file-input-port cert-der))) + (dynamic-wind void + (lambda () (sha256-bytevector (get-bytevector-all p))) + (lambda () (close-port p))))) + +;;; 1 KiB payload block; absolute-offset content check below relies on the +;;; block size being a multiple of 256. +(define payload-block + (let ((bv (make-bytevector 1024))) + (do ((i 0 (+ i 1))) + ((>= i 1024)) + (bytevector-u8-set! bv i (fxand i #xff))) + bv)) + +(define payload-blocks 512) + +(define server-condition #f) + +(define (start-tls-server listen-fd) + (fork-thread + (lambda () + (guard (e [#t (set! server-condition e)]) + (let ((ctx (rustls-server-ctx-new cert-pem key-pem))) + (let ((client-fd (c-accept listen-fd 0 0))) + (when (< client-fd 0) + (error 'tls-server "accept(2) failed")) + (let ((conn (rustls-accept ctx client-fd))) + (let ((buf (make-bytevector 4096))) + (let ((n (rustls-read conn buf 4096))) + (when (<= n 0) + (error 'tls-server "no client request")))) + ;; Dribble the payload so the client read stays blocked + ;; across many GC windows. + (do ((i 0 (+ i 1))) + ((>= i payload-blocks)) + (let ((n (rustls-write conn payload-block 1024))) + (when (< n 0) + (error 'tls-server "write failed"))) + (thread-sleep! 0.001)) + (rustls-close conn) + (c-close-fd client-fd)) + (rustls-server-ctx-free ctx))))))) + +(define (run-tls-client port pin expected-total) + ;; Read exactly EXPECTED-TOTAL bytes. The server closes with SHUT_RDWR + ;; (jerboa_tls_close) rather than TLS close_notify, so after the payload + ;; rustls reports "unexpected EOF" (-1) instead of a clean 0 -- do not + ;; read past the payload. + (let ((conn (rustls-connect-pinned "localhost" port pin))) + (rustls-set-timeout conn 30000 30000) + (let ((req (string->utf8 "GET / HTTP/1.0\r\n\r\n"))) + (let ((n (rustls-write conn req (bytevector-length req)))) + (when (< n 0) + (error 'tls-client "request write failed")))) + (let ((buf (make-bytevector 65536)) + (chunks '()) + (total 0)) + (let loop () + (when (< total expected-total) + (let ((n (rustls-read conn buf (min 65536 (- expected-total total))))) + (cond + ((> n 0) + (let ((chunk (make-bytevector n))) + (bytevector-copy! buf 0 chunk 0 n) + (set! chunks (cons chunk chunks)) + (set! total (+ total n)) + (loop))) + (else + (error 'tls-client "stream ended before payload complete" + total expected-total n)))))) + (rustls-close conn) + (values (reverse chunks) total)))) + +(define (verify-payload chunks total) + (let ((expected-total (* payload-blocks 1024))) + (unless (= total expected-total) + (error 'tls-client "payload length mismatch" total expected-total)) + (let ((ok? #t) (offset 0)) + (for-each + (lambda (chunk) + (do ((i 0 (+ i 1))) + ((>= i (bytevector-length chunk))) + (unless (= (bytevector-u8-ref chunk i) + (fxand (+ offset i) #xff)) + (set! ok? #f))) + (set! offset (+ offset (bytevector-length chunk)))) + chunks) + (unless ok? + (error 'tls-client "payload corrupted under GC stress"))))) + +(define (part-tls-loopback) + (cond + ((not (openssl-available?)) + (printf " SKIP: rustls loopback (openssl not found)\n")) + (else + (guard (e [#t (fail 'tls-loopback e)]) + (generate-self-signed-cert) + (let-values (((listen-fd port) (open-loopback-listener))) + (let ((pin (cert-pin-sha256)) + (server (start-tls-server listen-fd))) + (let-values (((chunks total) + (run-tls-client port pin (* payload-blocks 1024)))) + (verify-payload chunks total)) + (c-close-fd listen-fd) + (when server-condition + (error 'tls-loopback "server thread failed" server-condition)) + (printf " PASS: rustls loopback byte-exact under GC stress (~a KiB dribbled)\n" + payload-blocks))))))) + +;;; ---- Run ------------------------------------------------------------------ + +(printf "ffi-gc-stress: GC hammer running during collect-safe FFI I/O\n") +(part-c-write) +(part-tls-loopback) +(stop-hammer!) +(system "rm -rf /tmp/jcode-ffi-gc-stress") + +(if (= printf-failures 0) + (printf "ffi-gc-stress: PASS\n") + (begin + (printf "ffi-gc-stress: ~a failure(s)\n" printf-failures) + (exit 1)))