perf: O(n^2)/allocation hotspots in HTTP client
ober
8fa36e7f9a75256bffab257da1d47a97bfdd35fb
--- a/lib/jerboa-https.sls +++ b/lib/jerboa-https.sls @@ -35,7 +35,13 @@ (let loop ([i 0]) (cond [(> (+ i nlen) hlen) #f] - [(string=? needle (substring str i (+ i nlen))) i] + [(let match ([j 0]) + (or (= j nlen) + (and (char=? + (string-ref str (+ i j)) + (string-ref needle j)) + (match (+ j 1))))) + i] [else (loop (+ i 1))])))) (def (string-trim-left str) (let ([len (string-length str)]) @@ -59,10 +65,14 @@ (def (string-join strs sep) (if (null? strs) "" - (let loop ([rest (cdr strs)] [acc (car strs)]) - (if (null? rest) - acc - (loop (cdr rest) (string-append acc sep (car rest))))))) + (let ([out (open-output-string)]) + (display (car strs) out) + (let loop ([rest (cdr strs)]) + (unless (null? rest) + (display sep out) + (display (car rest) out) + (loop (cdr rest)))) + (get-output-string out)))) (def (subbytevector bv start end) (let ([result (make-bytevector (- end start))]) (bytevector-copy! bv start result 0 (- end start)) @@ -170,30 +180,24 @@ [else (loop (+ i 1))]))) (def hex-chars "0123456789ABCDEF") (def (url-encode str) - (let ([out (open-output-string)]) - (string-for-each - (lambda (c) - (let ([b (char->integer c)]) + (let ([out (open-output-string)] [bv (string->utf8 str)]) + (let loop ([i 0] [len (bytevector-length bv)]) + (when (< i len) + (let ([b (bytevector-u8-ref bv i)]) (cond [(or (and (fx>= b 65) (fx<= b 90)) (and (fx>= b 97) (fx<= b 122)) (and (fx>= b 48) (fx<= b 57)) - (memv c '(#\- #\_ #\. #\~))) - (write-char c out)] + (fx= b 45) + (fx= b 46) + (fx= b 95) + (fx= b 126)) + (write-char (integer->char b) out)] [else - (let ([bv (string->utf8 (string c))]) - (let loop ([i 0] [len (bytevector-length bv)]) - (when (< i len) - (let ([b (bytevector-u8-ref bv i)]) - (write-char #\% out) - (write-char - (string-ref hex-chars (fxsrl b 4)) - out) - (write-char - (string-ref hex-chars (fxand b 15)) - out) - (loop (+ i 1) len)))))]))) - str) + (write-char #\% out) + (write-char (string-ref hex-chars (fxsrl b 4)) out) + (write-char (string-ref hex-chars (fxand b 15)) out)])) + (loop (+ i 1) len))) (get-output-string out))) (def (string-index-from str ch start) (let ([len (string-length str)]) @@ -332,9 +336,10 @@ item) (loop (cdr items) - (append - (reverse (flatten-request-headers item)) - result)))))] + (fold-left + (lambda (acc x) (cons x acc)) + result + (flatten-request-headers item))))))] [else (error 'flatten-request-headers "invalid header list entry" @@ -445,35 +450,53 @@ (<= value (quotient (- limit digit) radix)) (loop (+ i 1) (+ (* value radix) digit)))))))) (def (validate-outbound-headers! headers body-bv) - (for-each - (lambda (header) - (unless (and (pair? header) - (valid-http-token? (car header)) - (valid-header-value? (cdr header))) - (error 'build-request "invalid HTTP header" header)) - (when (and (string-ci=? (car header) "Host") - (not (valid-host-field? (cdr header)))) - (error 'build-request "invalid Host header" (cdr header)))) - headers) - (when (> (header-count "Host" headers) 1) - (error 'build-request "duplicate Host header")) - (when (> (header-count "Content-Length" headers) 1) - (error 'build-request "duplicate Content-Length header")) - (when (> (header-count "Transfer-Encoding" headers) 0) - (error 'build-request - "Transfer-Encoding is not supported for requests")) - (let ([cl (header-assoc "Content-Length" headers)] - [actual (if body-bv (bytevector-length body-bv) 0)]) - (when cl - (let ([declared (bounded-unsigned-integer - (cdr cl) - 10 - actual)]) - (unless (and declared (= declared actual)) - (error 'build-request - "Content-Length does not match request body" - (cdr cl) - actual)))))) + (let loop ([rest headers] + [host-count 0] + [content-length-count 0] + [transfer-encoding-count 0] + [content-length #f]) + (if (null? rest) + (begin + (when (> host-count 1) + (error 'build-request "duplicate Host header")) + (when (> content-length-count 1) + (error 'build-request "duplicate Content-Length header")) + (when (> transfer-encoding-count 0) + (error 'build-request + "Transfer-Encoding is not supported for requests")) + (let ([actual (if body-bv (bytevector-length body-bv) 0)]) + (when content-length + (let ([declared (bounded-unsigned-integer + (cdr content-length) + 10 + actual)]) + (unless (and declared (= declared actual)) + (error 'build-request + "Content-Length does not match request body" + (cdr content-length) + actual)))))) + (let ([header (car rest)]) + (unless (and (pair? header) + (valid-http-token? (car header)) + (valid-header-value? (cdr header))) + (error 'build-request "invalid HTTP header" header)) + (let ([name (string-downcase (car header))]) + (when (and (string=? name "host") + (not (valid-host-field? (cdr header)))) + (error 'build-request + "invalid Host header" + (cdr header))) + (loop (cdr rest) + (if (string=? name "host") (+ host-count 1) host-count) + (if (string=? name "content-length") + (+ content-length-count 1) + content-length-count) + (if (string=? name "transfer-encoding") + (+ transfer-encoding-count 1) + transfer-encoding-count) + (if (string=? name "content-length") + header + content-length))))))) (def (build-request method path host headers body-bv keep-alive?) (unless (valid-http-token? method) (error 'build-request "invalid HTTP method" method)) @@ -620,7 +643,8 @@ (ssl-close conn)))))) (def (monotonic-seconds) (let ([now (current-time 'time-monotonic)]) - (+ (time-second now) (/ (time-nanosecond now) 1000000000)))) + (+ (time-second now) + (/ (time-nanosecond now) 1000000000.0)))) (def (make-response-deadline) (+ (monotonic-seconds) (response-policy-ref 8))) (def (make-response-reader conn deadline) @@ -644,9 +668,10 @@ (monotonic-seconds))]) (when (<= remaining 0) (error 'read-response "total response deadline exceeded")) - (let ([timeout (max 1 - (min (response-policy-ref 7) - (ceiling remaining)))] + (let ([timeout (inexact->exact + (max 1 + (min (response-policy-ref 7) + (ceiling remaining))))] [buf (response-reader-buffer reader)]) (ssl-set-timeout (response-reader-conn reader) @@ -671,24 +696,37 @@ (response-reader-position-set! reader (+ position 1)) byte))) (def (response-reader-read-line reader limit who) - (let ([line (make-bytevector limit)]) + (let ([line (make-bytevector limit)] + [buf (response-reader-buffer reader)]) (let loop ([length 0]) - (let ([byte (response-reader-read-byte reader)]) - (cond - [(not byte) (error who "truncated line")] - [(= byte 13) - (let ([lf (response-reader-read-byte reader)]) - (unless (and lf (= lf 10)) - (error who "line is not terminated by CRLF")) - (values - (utf8->string (subbytevector line 0 length)) - (+ length 2)))] - [(= byte 10) (error who "bare LF is not permitted")] - [(>= length limit) - (error who "line exceeds configured limit" limit)] - [else - (bytevector-u8-set! line length byte) - (loop (+ length 1))]))))) + (when (= (response-reader-available reader) 0) + (response-reader-fill! reader) + (when (= (response-reader-available reader) 0) + (error who "truncated line"))) + (let ([end (response-reader-end reader)]) + (let scan ([i (response-reader-position reader)] + [length length]) + (cond + [(>= i end) + (response-reader-position-set! reader end) + (loop length)] + [else + (let ([byte (bytevector-u8-ref buf i)]) + (cond + [(= byte 13) + (response-reader-position-set! reader (+ i 1)) + (let ([lf (response-reader-read-byte reader)]) + (unless (and lf (= lf 10)) + (error who "line is not terminated by CRLF")) + (values + (utf8->string (subbytevector line 0 length)) + (+ length 2)))] + [(= byte 10) (error who "bare LF is not permitted")] + [(>= length limit) + (error who "line exceeds configured limit" limit)] + [else + (bytevector-u8-set! line length byte) + (scan (+ i 1) (+ length 1))]))])))))) (def (response-reader-read-exact reader length who) (let ([result (make-bytevector length)]) (let loop ([offset 0]) --- a/src/jerboa-https.ss +++ b/src/jerboa-https.ss @@ -47,7 +47,11 @@ (let loop ([i 0]) (cond [(> (+ i nlen) hlen) #f] - [(string=? needle (substring str i (+ i nlen))) i] + [(let match ([j 0]) + (or (= j nlen) + (and (char=? (string-ref str (+ i j)) (string-ref needle j)) + (match (+ j 1))))) + i] [else (loop (+ i 1))])))) (def (string-trim-left str) @@ -72,10 +76,14 @@ (def (string-join strs sep) (if (null? strs) "" - (let loop ([rest (cdr strs)] [acc (car strs)]) - (if (null? rest) - acc - (loop (cdr rest) (string-append acc sep (car rest))))))) + (let ([out (open-output-string)]) + (display (car strs) out) + (let loop ([rest (cdr strs)]) + (unless (null? rest) + (display sep out) + (display (car rest) out) + (loop (cdr rest)))) + (get-output-string out)))) ;; ================================================================ ;; Bytevector utilities @@ -194,26 +202,25 @@ (def hex-chars "0123456789ABCDEF") (def (url-encode str) - (let ([out (open-output-string)]) - (string-for-each - (lambda (c) - (let ([b (char->integer c)]) - (cond - [(or (and (fx>= b 65) (fx<= b 90)) ; A-Z - (and (fx>= b 97) (fx<= b 122)) ; a-z - (and (fx>= b 48) (fx<= b 57)) ; 0-9 - (memv c '(#\- #\_ #\. #\~))) - (write-char c out)] - [else - (let ([bv (string->utf8 (string c))]) - (let loop ([i 0] [len (bytevector-length bv)]) - (when (< i len) - (let ([b (bytevector-u8-ref bv i)]) - (write-char #\% out) - (write-char (string-ref hex-chars (fxsrl b 4)) out) - (write-char (string-ref hex-chars (fxand b #xf)) out) - (loop (+ i 1) len)))))]))) - str) + (let ([out (open-output-string)] + [bv (string->utf8 str)]) + (let loop ([i 0] [len (bytevector-length bv)]) + (when (< i len) + (let ([b (bytevector-u8-ref bv i)]) + (cond + [(or (and (fx>= b 65) (fx<= b 90)) ; A-Z + (and (fx>= b 97) (fx<= b 122)) ; a-z + (and (fx>= b 48) (fx<= b 57)) ; 0-9 + (fx= b 45) ; - + (fx= b 46) ; . + (fx= b 95) ; _ + (fx= b 126)) ; ~ + (write-char (integer->char b) out)] + [else + (write-char #\% out) + (write-char (string-ref hex-chars (fxsrl b 4)) out) + (write-char (string-ref hex-chars (fxand b #xf)) out)])) + (loop (+ i 1) len))) (get-output-string out))) ;; ================================================================ @@ -343,8 +350,9 @@ "malformed name :: value entry" item) ;; Recurse only into a proper nested list. (loop (cdr items) - (append (reverse (flatten-request-headers item)) - result)))))] + (fold-left (lambda (acc x) (cons x acc)) + result + (flatten-request-headers item))))))] [else (error 'flatten-request-headers "invalid header list entry" (car items))]))))) @@ -465,29 +473,39 @@ (loop (+ i 1) (+ (* value radix) digit)))))))) (def (validate-outbound-headers! headers body-bv) - (for-each - (lambda (header) - (unless (and (pair? header) - (valid-http-token? (car header)) - (valid-header-value? (cdr header))) - (error 'build-request "invalid HTTP header" header)) - (when (and (string-ci=? (car header) "Host") - (not (valid-host-field? (cdr header)))) - (error 'build-request "invalid Host header" (cdr header)))) - headers) - (when (> (header-count "Host" headers) 1) - (error 'build-request "duplicate Host header")) - (when (> (header-count "Content-Length" headers) 1) - (error 'build-request "duplicate Content-Length header")) - (when (> (header-count "Transfer-Encoding" headers) 0) - (error 'build-request "Transfer-Encoding is not supported for requests")) - (let ([cl (header-assoc "Content-Length" headers)] - [actual (if body-bv (bytevector-length body-bv) 0)]) - (when cl - (let ([declared (bounded-unsigned-integer (cdr cl) 10 actual)]) - (unless (and declared (= declared actual)) - (error 'build-request "Content-Length does not match request body" - (cdr cl) actual)))))) + (let loop ([rest headers] + [host-count 0] + [content-length-count 0] + [transfer-encoding-count 0] + [content-length #f]) + (if (null? rest) + (begin + (when (> host-count 1) + (error 'build-request "duplicate Host header")) + (when (> content-length-count 1) + (error 'build-request "duplicate Content-Length header")) + (when (> transfer-encoding-count 0) + (error 'build-request "Transfer-Encoding is not supported for requests")) + (let ([actual (if body-bv (bytevector-length body-bv) 0)]) + (when content-length + (let ([declared (bounded-unsigned-integer (cdr content-length) 10 actual)]) + (unless (and declared (= declared actual)) + (error 'build-request "Content-Length does not match request body" + (cdr content-length) actual)))))) + (let ([header (car rest)]) + (unless (and (pair? header) + (valid-http-token? (car header)) + (valid-header-value? (cdr header))) + (error 'build-request "invalid HTTP header" header)) + (let ([name (string-downcase (car header))]) + (when (and (string=? name "host") + (not (valid-host-field? (cdr header)))) + (error 'build-request "invalid Host header" (cdr header))) + (loop (cdr rest) + (if (string=? name "host") (+ host-count 1) host-count) + (if (string=? name "content-length") (+ content-length-count 1) content-length-count) + (if (string=? name "transfer-encoding") (+ transfer-encoding-count 1) transfer-encoding-count) + (if (string=? name "content-length") header content-length))))))) ;; ================================================================ ;; HTTP request building @@ -664,7 +682,7 @@ (def (monotonic-seconds) (let ([now (current-time 'time-monotonic)]) - (+ (time-second now) (/ (time-nanosecond now) 1000000000)))) + (+ (time-second now) (/ (time-nanosecond now) 1000000000.0)))) (def (make-response-deadline) (+ (monotonic-seconds) (response-policy-ref 8))) @@ -688,7 +706,7 @@ (let ([remaining (- (response-reader-deadline reader) (monotonic-seconds))]) (when (<= remaining 0) (error 'read-response "total response deadline exceeded")) - (let ([timeout (max 1 (min (response-policy-ref 7) (ceiling remaining)))] + (let ([timeout (inexact->exact (max 1 (min (response-policy-ref 7) (ceiling remaining))))] [buf (response-reader-buffer reader)]) (ssl-set-timeout (response-reader-conn reader) timeout request-write-timeout-seconds) @@ -710,25 +728,36 @@ (def (response-reader-read-line reader limit who) ;; Return (values line wire-byte-count), requiring canonical CRLF. - (let ([line (make-bytevector limit)]) + (let ([line (make-bytevector limit)] + [buf (response-reader-buffer reader)]) (let loop ([length 0]) - (let ([byte (response-reader-read-byte reader)]) - (cond - [(not byte) - (error who "truncated line")] - [(= byte 13) - (let ([lf (response-reader-read-byte reader)]) - (unless (and lf (= lf 10)) - (error who "line is not terminated by CRLF")) - (values (utf8->string (subbytevector line 0 length)) - (+ length 2)))] - [(= byte 10) - (error who "bare LF is not permitted")] - [(>= length limit) - (error who "line exceeds configured limit" limit)] - [else - (bytevector-u8-set! line length byte) - (loop (+ length 1))]))))) + (when (= (response-reader-available reader) 0) + (response-reader-fill! reader) + (when (= (response-reader-available reader) 0) + (error who "truncated line"))) + (let ([end (response-reader-end reader)]) + (let scan ([i (response-reader-position reader)] [length length]) + (cond + [(>= i end) + (response-reader-position-set! reader end) + (loop length)] + [else + (let ([byte (bytevector-u8-ref buf i)]) + (cond + [(= byte 13) + (response-reader-position-set! reader (+ i 1)) + (let ([lf (response-reader-read-byte reader)]) + (unless (and lf (= lf 10)) + (error who "line is not terminated by CRLF")) + (values (utf8->string (subbytevector line 0 length)) + (+ length 2)))] + [(= byte 10) + (error who "bare LF is not permitted")] + [(>= length limit) + (error who "line exceeds configured limit" limit)] + [else + (bytevector-u8-set! line length byte) + (scan (+ i 1) (+ length 1))]))])))))) (def (response-reader-read-exact reader length who) (let ([result (make-bytevector length)])