fix: ssl-init race, strict Content-Length parsing, keep-alive idle timeout, remove dead code
ober
bb8b1292d34b31e13b710fe50c24473fce0c2b44
--- a/lib/jerboa-https.sls +++ b/lib/jerboa-https.sls @@ -63,18 +63,6 @@ (if (null? rest) acc (loop (cdr rest) (string-append acc sep (car rest))))))) - (def (string-split-crlf str) - (let ([len (string-length str)]) - (let loop ([start 0] [i 0] [acc '()]) - (cond - [(>= i len) - (reverse - (if (> i start) (cons (substring str start i) acc) acc))] - [(and (char=? (string-ref str i) #\return) - (< (+ i 1) len) - (char=? (string-ref str (+ i 1)) #\newline)) - (loop (+ i 2) (+ i 2) (cons (substring str start i) acc))] - [else (loop start (+ i 1) acc)])))) (def (subbytevector bv start end) (let ([result (make-bytevector (- end start))]) (bytevector-copy! bv start result 0 (- end start)) @@ -603,10 +591,13 @@ (token-loop (cdr tokens))))) (value-loop (cdr values))))))) (def *ssl-initialized* #f) + (def *ssl-init-mutex* (make-mutex 'ssl-init)) (def (ensure-ssl-init!) (unless *ssl-initialized* - (ssl-init!) - (set! *ssl-initialized* #t))) + (with-mutex *ssl-init-mutex* + (unless *ssl-initialized* + (ssl-init!) + (set! *ssl-initialized* #t))))) (def *conn-pool* (make-hashtable string-hash string=?)) (def *conn-pool-mutex* (make-mutex 'conn-pool)) (def (pool-key host port) --- a/lib/jerboa-https/httpd.sls +++ b/lib/jerboa-https/httpd.sls @@ -30,8 +30,8 @@ parse-chunk-size-sandboxed) (jerboa-ssl)) (def *config* - (vector 4 8192 32768 60 120 1048576 128 100 #f 4 #f 10 #f - 8)) + (vector 4 8192 32768 60 120 1048576 128 100 #f 4 #f 10 #f 8 + 30)) (def (cfg-ref i) (vector-ref *config* i)) (def (httpd-config . args) (let loop ([args args]) @@ -69,6 +69,8 @@ [(eq? key 'tls-max-preauth:) (vector-set! *config* 12 val)] [(eq? key 'tls-max-preauth-per-ip:) (vector-set! *config* 13 val)] + [(eq? key 'keep-alive-timeout:) + (vector-set! *config* 14 val)] [else (error 'httpd-config "unknown option" key)]) (loop (cddr args)))))) (def (string-index str ch) @@ -204,14 +206,6 @@ (def *input-pool-mutex* (make-mutex 'httpd-input-pool)) (def *output-pool* '()) (def *output-pool-mutex* (make-mutex 'httpd-output-pool)) - (def (pool-get! pool-var mutex-var size) - (with-mutex mutex-var - (let ([pool (pool-var)]) - (if (null? pool) - (make-bytevector size) - (let ([buf (car pool)]) (pool-var (cdr pool)) buf))))) - (def (pool-put! pool-var mutex-var buf) - (with-mutex mutex-var (pool-var (cons buf (pool-var))))) (define-syntax get-input-buffer (syntax-rules () [(_) @@ -257,17 +251,6 @@ (bytevector-copy! buf pos buf 0 avail) (reader-pos-set! r 0) (reader-end-set! r avail))))) - (def (reader-fill! r) - (reader-compact! r) - (let* ([buf (reader-buf r)] - [end (reader-end r)] - [cap (bytevector-length buf)] - [space (- cap end)]) - (if (<= space 0) - #t - (let ([n (conn-read (reader-conn r) buf end)]) #f)))) - (def *temp-read-buf* #f) - (def *temp-read-mutex* (make-mutex 'temp-read)) (def (reader-fill-from-conn! r) (reader-compact! r) (let* ([buf (reader-buf r)] @@ -454,17 +437,18 @@ [(and te (header-ci=? (cdr te) "chunked")) (read-chunked-request-body reader)] [(and cl (cdr cl)) - (let ([len (string->number (cdr cl))]) - (cond - [(or (not len) (< len 0)) - (error 'read-request-body "invalid content-length")] - [(> len (cfg-ref 5)) - (error 'read-request-body "request body too large")] - [(= len 0) (make-bytevector 0)] - [else - (or (reader-read-bytes reader len) - (error 'read-request-body - "truncated request body"))]))] + (let ([cl-str (cdr cl)]) + (unless (decimal-string? cl-str) + (error 'read-request-body "invalid content-length")) + (let ([len (string->number cl-str)]) + (cond + [(> len (cfg-ref 5)) + (error 'read-request-body "request body too large")] + [(= len 0) (make-bytevector 0)] + [else + (or (reader-read-bytes reader len) + (error 'read-request-body + "truncated request body"))])))] [else #f]))) (def (consume-chunk-trailers reader) (let loop ([count 0]) @@ -851,6 +835,7 @@ (header-ci=? conn-hdr "keep-alive"))))) + (ssl-set-timeout conn (cfg-ref 14) (cfg-ref 4)) (loop)))])))) (lambda () (try (ssl-close conn) (catch (e) (void))) --- a/src/jerboa-https.ss +++ b/src/jerboa-https.ss @@ -77,20 +77,6 @@ acc (loop (cdr rest) (string-append acc sep (car rest))))))) - (def (string-split-crlf str) - (let ([len (string-length str)]) - (let loop ([start 0] [i 0] [acc '()]) - (cond - [(>= i len) - (reverse (if (> i start) - (cons (substring str start i) acc) - acc))] - [(and (char=? (string-ref str i) #\return) - (< (+ i 1) len) - (char=? (string-ref str (+ i 1)) #\newline)) - (loop (+ i 2) (+ i 2) (cons (substring str start i) acc))] - [else (loop start (+ i 1) acc)])))) - ;; ================================================================ ;; Bytevector utilities ;; ================================================================ @@ -626,11 +612,17 @@ ;; ================================================================ (def *ssl-initialized* #f) + (def *ssl-init-mutex* (make-mutex 'ssl-init)) (def (ensure-ssl-init!) + ;; Double-checked locking: the outer test is a lock-free fast path, the + ;; inner test under the mutex closes the check-and-set TOCTOU window so + ;; only one thread ever runs ssl-init!. (unless *ssl-initialized* - (ssl-init!) - (set! *ssl-initialized* #t))) + (with-mutex *ssl-init-mutex* + (unless *ssl-initialized* + (ssl-init!) + (set! *ssl-initialized* #t))))) ;; ================================================================ ;; Connection pool — keep-alive / connection sharing --- a/src/jerboa-https/httpd.ss +++ b/src/jerboa-https/httpd.ss @@ -61,6 +61,7 @@ 10 ;; 11: TLS handshake deadline (seconds) #f ;; 12: global pre-auth cap (#f = workers + queue) 8 ;; 13: per-IP pre-auth cap + 30 ;; 14: keep-alive idle timeout (seconds) )) (def (cfg-ref i) (vector-ref *config* i)) @@ -93,6 +94,7 @@ [(eq? key 'tls-handshake-timeout:) (vector-set! *config* 11 val)] [(eq? key 'tls-max-preauth:) (vector-set! *config* 12 val)] [(eq? key 'tls-max-preauth-per-ip:) (vector-set! *config* 13 val)] + [(eq? key 'keep-alive-timeout:) (vector-set! *config* 14 val)] [else (error 'httpd-config "unknown option" key)]) (loop (cddr args)))))) @@ -233,19 +235,6 @@ (def *output-pool* '()) (def *output-pool-mutex* (make-mutex 'httpd-output-pool)) - (def (pool-get! pool-var mutex-var size) - (with-mutex mutex-var - (let ([pool (pool-var)]) - (if (null? pool) - (make-bytevector size) - (let ([buf (car pool)]) - (pool-var (cdr pool)) - buf))))) - - (def (pool-put! pool-var mutex-var buf) - (with-mutex mutex-var - (pool-var (cons buf (pool-var))))) - ;; Use syntax to capture the mutable variable references (define-syntax get-input-buffer (syntax-rules () @@ -301,31 +290,10 @@ (reader-pos-set! r 0) (reader-end-set! r avail))))) - (def (reader-fill! r) - ;; Compact then read more data from connection. - ;; Returns #t if data was read, #f on EOF/error. - (reader-compact! r) - (let* ([buf (reader-buf r)] - [end (reader-end r)] - [cap (bytevector-length buf)] - [space (- cap end)]) - (if (<= space 0) - #t ;; buffer full, data available - (let ([n (conn-read (reader-conn r) buf end)]) - ;; conn-read takes (conn buf len) but we need offset support. - ;; We'll use a temp buffer and copy. Or better: read into a temp - ;; and copy to the right position. - ;; Actually, conn-read reads into start of buf. We need to read - ;; at offset. Let's use a workaround with a temp buffer. - #f)))) ;; placeholder - ;; Since conn-read reads into the start of the bytevector, we use a temp buf ;; and copy into the main buffer at the right offset. This is the price of ;; not having offset-aware C functions. - (def *temp-read-buf* #f) - (def *temp-read-mutex* (make-mutex 'temp-read)) - (def (reader-fill-from-conn! r) ;; Read more data into the reader buffer. ;; Returns bytes read (0 = EOF, -1 = error). @@ -563,17 +531,20 @@ [(and te (header-ci=? (cdr te) "chunked")) (read-chunked-request-body reader)] [(and cl (cdr cl)) - (let ([len (string->number (cdr cl))]) - (cond - [(or (not len) (< len 0)) - (error 'read-request-body "invalid content-length")] - [(> len (cfg-ref 5)) - (error 'read-request-body "request body too large")] - [(= len 0) - (make-bytevector 0)] - [else - (or (reader-read-bytes reader len) - (error 'read-request-body "truncated request body"))]))] + ;; string->number accepts #x10/#o10/#b10/1e5, so reject anything that + ;; is not a plain decimal digit string before parsing. + (let ([cl-str (cdr cl)]) + (unless (decimal-string? cl-str) + (error 'read-request-body "invalid content-length")) + (let ([len (string->number cl-str)]) + (cond + [(> len (cfg-ref 5)) + (error 'read-request-body "request body too large")] + [(= len 0) + (make-bytevector 0)] + [else + (or (reader-read-bytes reader len) + (error 'read-request-body "truncated request body"))])))] [else #f]))) (def (consume-chunk-trailers reader) @@ -988,6 +959,11 @@ (string=? version "HTTP/1.0") (not (and conn-hdr (header-ci=? conn-hdr "keep-alive"))))) + ;; Bound how long we block waiting for the next request + ;; on a kept-alive connection. If no request arrives + ;; within the idle timeout the read fails, read-request + ;; returns #f, and the loop exits to close the conn. + (ssl-set-timeout conn (cfg-ref 14) (cfg-ref 4)) (loop)))])))) (lambda () (try (ssl-close conn)