net/allow-proxy: thread-safe CONNECT tunnel
ober
4c9f666495821e9ec0e7415783a9afe1008fd486
--- a/lib/std/net/allow-proxy.ss +++ b/lib/std/net/allow-proxy.ss @@ -463,18 +463,32 @@ [else (let ([origin-in (car conn)] [origin-out (cdr conn)]) (write-status client-out 200 "Connection established") - ;; Two shuttle threads, each copies one direction. - (let ([t1 (fork-thread - (lambda () (copy-loop client-in origin-out)))] - [t2 (fork-thread - (lambda () (copy-loop origin-in client-out)))]) - ;; Wait for either direction to close (no thread-join in - ;; Chez; poll with a brief sleep). Once one side closes, - ;; we tear down both. + ;; Two shuttle threads, each copies one direction. Track + ;; completion with shared flags rather than polling port-eof? + ;; on the live tunnel ports. port-eof? peeks a byte and is + ;; not thread-safe: calling it here while the copy-loop threads + ;; are reading the same ports raced and corrupted the tunneled + ;; byte stream, so TLS handshakes through the proxy failed + ;; ("wrong version number" for curl/openssl, UND_ERR_HEADERS_ + ;; TIMEOUT for Node/undici). Each copy-loop sets its flag when + ;; its direction reaches EOF; tear down once both are done. + (let ([done-mutex (make-mutex)] + [client->origin-done #f] + [origin->client-done #f]) + (fork-thread + (lambda () + (copy-loop client-in origin-out) + (with-mutex done-mutex (set! client->origin-done #t)))) + (fork-thread + (lambda () + (copy-loop origin-in client-out) + (with-mutex done-mutex (set! origin->client-done #t)))) + ;; Wait until both directions have closed (no thread-join in + ;; Chez; poll the flags with a brief sleep). (let wait () (cond - [(or (and (proxy-port-eof? client-in) - (proxy-port-eof? origin-in))) + [(with-mutex done-mutex + (and client->origin-done origin->client-done)) #f] [else (sleep (make-time 'time-duration 50000000 0)) @@ -482,9 +496,6 @@ (close-pair client-in client-out) (close-pair origin-in origin-out)))])))) - (def (proxy-port-eof? p) - (try (port-eof? p) (catch (e) #t))) - (def (copy-loop in out) (let ([buf (make-bytevector 4096)]) (let lp ()