provider: declare __collect_safe on jerboa_tls_read so watchdog can fire
ober
9856799c5dd419d7c56049cbc493e45f089bb4ad
--- a/src/jcode/provider/provider.ss +++ b/src/jcode/provider/provider.ss @@ -143,6 +143,20 @@ (when body-str (put-string out body-str)) (get-output-string out))) +;; TC-safe rustls read. +;; +;; The std lib's rustls-read uses a plain foreign-procedure that holds the +;; Chez TC mutex during the call. When the read blocks waiting for bytes, +;; no other Scheme thread can run -- so the streaming watchdog in this +;; module never fires and a silent server hangs jcode forever. +;; +;; This binding declares __collect_safe so the scheduler can switch threads +;; while the C side is parked in recv(). Same pattern as the termbox poll +;; binding in src/jcode/ui/tui-ffi.ss. +(def jcode-tls-read + (foreign-procedure __collect_safe "jerboa_tls_read" + (unsigned-64 u8* unsigned-64) int)) + ;; TLS I/O: write full string via rustls (def (tls-write-string conn s) (let ((bv (string->utf8 s))) @@ -165,7 +179,7 @@ (buf (make-bytevector 1)) (got-any #f)) (let loop () - (let ((n (rustls-read conn buf 1))) + (let ((n (jcode-tls-read conn buf 1))) (cond ((<= n 0) (if got-any (get-output-string out) #f)) @@ -188,7 +202,7 @@ (let loop ((offset 0)) (if (>= offset n) (utf8->string result) (let* ((want (min 4096 (- n offset))) - (got (rustls-read conn buf want))) + (got (jcode-tls-read conn buf want))) (cond ((<= got 0) (utf8->string (let ((r (make-bytevector offset))) (bytevector-copy! result 0 r 0 offset) r))) @@ -200,7 +214,7 @@ (let ((out (open-output-string)) (buf (make-bytevector 4096))) (let loop () - (let ((n (rustls-read conn buf 4096))) + (let ((n (jcode-tls-read conn buf 4096))) (if (<= n 0) (get-output-string out) (begin (put-string out (utf8->string @@ -326,10 +340,20 @@ (unless (vector-ref closed? 0) (vector-set! closed? 0 #t) (rustls-close conn))) - ;; Use thread-sleep!, not (sleep (make-time ...)) -- the prelude - ;; shadows make-time with a date-style constructor, so the latter - ;; raises in `sleep`. Guard the loop so any future regression - ;; can't silently kill the watchdog and let the stream hang. + ;; Watchdog: closes the connection if no bytes arrive for + ;; timeout-secs seconds. Two correctness traps to remember here: + ;; + ;; 1. Sleep with thread-sleep!, not (sleep (make-time ...)). + ;; The prelude shadows make-time with a date-style + ;; constructor; the latter raises in `sleep` and silently + ;; kills the worker. + ;; + ;; 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. (fork-thread (lambda () (guard (e [#t (when (tracing?) @@ -990,7 +1014,7 @@ (let ((chunks '()) (buf (make-bytevector 4096))) (let loop () - (let ((n (rustls-read conn buf 4096))) + (let ((n (jcode-tls-read conn buf 4096))) (if (<= n 0) (concat-bytevectors (reverse chunks)) (let ((chunk (make-bytevector n)))