build: remove tracked generated .sls files and ignore them
ober
0cddc000e5bca7aedac4dfc1fa972f9027d71eb5
--- a/.gitignore +++ b/.gitignore @@ -15,3 +15,4 @@ fuzz/corpus/*/* # Release evidence generated by make release-evidence /dist/ +**/*.sls deleted file mode 100644 --- a/lib/jerboa-https.sls +++ /dev/null @@ -1,1109 +0,0 @@ -#!chezscheme -;;; Generated by jerbuild — DO NOT EDIT -;;; Source: src/jerboa-https.ss - -(library (jerboa-https) - (export http-get http-post http-put http-delete http-head - http-client-config request-status request-text - request-content request-headers request-header request-close - parse-url flatten-request-headers build-query-string - url-encode) - (import - (except (chezscheme) make-hash-table hash-table? sort sort! - printf fprintf format path-extension path-absolute? - with-input-from-string with-output-to-string iota \x31;+ - \x31;- partition make-date make-time meta atom?) - (except (jerboa prelude) string-join string-trim string-contains - string-index string-prefix? tcp-write-string tcp-write - tcp-read tcp-close tcp-accept tcp-listen tcp-connect) - (jerboa-ssl)) - (def (string-prefix? prefix str) - (let ([plen (string-length prefix)] - [slen (string-length str)]) - (and (>= slen plen) - (string=? prefix (substring str 0 plen))))) - (def (string-index str ch) - (let ([len (string-length str)]) - (let loop ([i 0]) - (cond - [(= i len) #f] - [(char=? (string-ref str i) ch) i] - [else (loop (+ i 1))])))) - (def (string-contains str needle) - (let ([hlen (string-length str)] - [nlen (string-length needle)]) - (let loop ([i 0]) - (cond - [(> (+ i nlen) hlen) #f] - [(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)]) - (let loop ([i 0]) - (if (and (< i len) (char-whitespace? (string-ref str i))) - (loop (+ i 1)) - (substring str i len))))) - (def (string-trim str) - (let* ([len (string-length str)] - [start (let loop ([i 0]) - (if (and (< i len) - (char-whitespace? (string-ref str i))) - (loop (+ i 1)) - i))] - [end (let loop ([i len]) - (if (and (> i start) - (char-whitespace? (string-ref str (- i 1)))) - (loop (- i 1)) - i))]) - (substring str start end))) - (def (string-join strs sep) - (if (null? strs) - "" - (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)) - result)) - (def (bytevector-concat-list bvs) - (if (null? bvs) - (make-bytevector 0) - (let* ([total (fold-left + 0 (map bytevector-length bvs))] - [result (make-bytevector total)]) - (let loop ([bvs bvs] [offset 0]) - (if (null? bvs) - result - (let ([bv (car bvs)]) - (bytevector-copy! bv 0 result offset - (bytevector-length bv)) - (loop - (cdr bvs) - (+ offset (bytevector-length bv))))))))) - (define request-body-write-chunk-size 8388608) - (define request-write-timeout-seconds 300) - (def *response-policy* - (vector 8192 8192 65536 100 67108864 8388608 83886080 30 300 - 8)) - (def (response-policy-ref i) - (vector-ref *response-policy* i)) - (def (positive-exact-integer? value) - (and (integer? value) (exact? value) (> value 0))) - (def (set-response-policy! who index value) - (unless (positive-exact-integer? value) - (error who - "policy value must be a positive exact integer" - value)) - (vector-set! *response-policy* index value)) - (def (http-client-config . args) - (if (null? args) - (list (cons 'max-status-line (response-policy-ref 0)) - (cons 'max-header-line (response-policy-ref 1)) - (cons 'max-header-bytes (response-policy-ref 2)) - (cons 'max-headers (response-policy-ref 3)) - (cons 'max-body (response-policy-ref 4)) - (cons 'max-chunk (response-policy-ref 5)) - (cons 'max-chunked-wire (response-policy-ref 6)) - (cons 'idle-timeout (response-policy-ref 7)) - (cons 'total-timeout (response-policy-ref 8)) - (cons 'max-interim-responses (response-policy-ref 9))) - (let loop ([rest args]) - (cond - [(null? rest) (void)] - [(null? (cdr rest)) - (error 'http-client-config - "missing value for option" - (car rest))] - [else - (let ([key (car rest)] [value (cadr rest)]) - (cond - [(eq? key 'max-status-line:) - (set-response-policy! 'http-client-config 0 value)] - [(eq? key 'max-header-line:) - (set-response-policy! 'http-client-config 1 value)] - [(eq? key 'max-header-bytes:) - (set-response-policy! 'http-client-config 2 value)] - [(eq? key 'max-headers:) - (set-response-policy! 'http-client-config 3 value)] - [(eq? key 'max-body:) - (set-response-policy! 'http-client-config 4 value)] - [(eq? key 'max-chunk:) - (set-response-policy! 'http-client-config 5 value)] - [(eq? key 'max-chunked-wire:) - (set-response-policy! 'http-client-config 6 value)] - [(eq? key 'idle-timeout:) - (set-response-policy! 'http-client-config 7 value)] - [(eq? key 'total-timeout:) - (set-response-policy! 'http-client-config 8 value)] - [(eq? key 'max-interim-responses:) - (set-response-policy! 'http-client-config 9 value)] - [else - (error 'http-client-config "unknown option" key)]) - (loop (cddr rest)))])))) - (def (ssl-write-bytevector-chunked conn bv) - (let ([len (bytevector-length bv)]) - (let loop ([offset 0]) - (when (< offset len) - (let ([end (min len - (+ offset request-body-write-chunk-size))]) - (ssl-write conn (subbytevector bv offset end)) - (loop end)))))) - (def (find-crlfcrlf bv len start) - (let loop ([i start]) - (if (> (+ i 3) len) - #f - (if (and (= (bytevector-u8-ref bv i) 13) - (= (bytevector-u8-ref bv (+ i 1)) 10) - (= (bytevector-u8-ref bv (+ i 2)) 13) - (= (bytevector-u8-ref bv (+ i 3)) 10)) - i - (loop (+ i 1)))))) - (def (read-bv-line bv start len) - (let loop ([i start]) - (cond - [(>= (+ i 1) len) - (values (utf8->string (subbytevector bv start len)) len)] - [(and (= (bytevector-u8-ref bv i) 13) - (= (bytevector-u8-ref bv (+ i 1)) 10)) - (values (utf8->string (subbytevector bv start i)) (+ i 2))] - [else (loop (+ i 1))]))) - (def hex-chars "0123456789ABCDEF") - (def (url-encode 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)) - (and (fx>= b 97) (fx<= b 122)) - (and (fx>= b 48) (fx<= b 57)) - (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 15)) out)])) - (loop (+ i 1) len))) - (get-output-string out))) - (def (string-index-from str ch start) - (let ([len (string-length str)]) - (let loop ([i start]) - (cond - [(= i len) #f] - [(char=? (string-ref str i) ch) i] - [else (loop (+ i 1))])))) - (def (first-authority-delimiter str) - (let ([slash (string-index str #\/)] - [query (string-index str #\?)] - [fragment (string-index str #\#)]) - (fold-left - (lambda (best candidate) - (cond - [(not candidate) best] - [(not best) candidate] - [else (min best candidate)])) - #f - (list slash query fragment)))) - (def (parse-port who text) - (let ([port (bounded-unsigned-integer text 10 65535)]) - (unless (and port (> port 0)) - (error who "invalid URL port" text)) - port)) - (def (parse-authority authority default-port) - (when (= (string-length authority) 0) - (error 'parse-url "URL host is empty")) - (when (string-index authority #\@) - (error 'parse-url "userinfo is not supported in URLs")) - (if (char=? (string-ref authority 0) #\[) - (let ([close (string-index authority #\])]) - (unless close - (error 'parse-url "unterminated IPv6 host" authority)) - (let ([host (substring authority 1 close)] - [suffix (substring - authority - (+ close 1) - (string-length authority))]) - (when (= (string-length host) 0) - (error 'parse-url "URL host is empty")) - (cond - [(string=? suffix "") (values host default-port)] - [(and (> (string-length suffix) 1) - (char=? (string-ref suffix 0) #\:)) - (values - host - (parse-port - 'parse-url - (substring suffix 1 (string-length suffix))))] - [else - (error 'parse-url - "invalid text after IPv6 host" - suffix)]))) - (let ([colon (string-index authority #\:)]) - (if colon - (begin - (when (string-index-from authority #\: (+ colon 1)) - (error 'parse-url - "IPv6 hosts must use brackets" - authority)) - (let ([host (substring authority 0 colon)]) - (when (= (string-length host) 0) - (error 'parse-url "URL host is empty")) - (values - host - (parse-port - 'parse-url - (substring - authority - (+ colon 1) - (string-length authority)))))) - (values authority default-port))))) - (def (parse-url url) - (unless (string? url) - (error 'parse-url "URL must be a string" url)) - (let* ([https? (string-prefix? "https://" url)] - [http? (string-prefix? "http://" url)] - [_ (unless (or https? http?) - (error 'parse-url "unsupported URL scheme" url))] - [after-scheme (substring - url - (if https? 8 7) - (string-length url))] - [delimiter (first-authority-delimiter after-scheme)] - [authority (if delimiter - (substring after-scheme 0 delimiter) - after-scheme)] - [tail (if delimiter - (substring - after-scheme - delimiter - (string-length after-scheme)) - "")]) - (when (string-index tail #\#) - (error 'parse-url - "URL fragments are not sent in HTTP requests" - url)) - (let ([path (cond - [(string=? tail "") "/"] - [(char=? (string-ref tail 0) #\?) - (string-append "/" tail)] - [else tail])]) - (let-values ([(host port) - (parse-authority authority (if https? 443 80))]) - (validate-host! 'parse-url host) - (validate-request-target! 'parse-url path) - (values host port path))))) - (def (flatten-request-headers hdrs) - (if (or (not hdrs) (null? hdrs)) - '() - (begin - (unless (list? hdrs) - (error 'flatten-request-headers - "headers must be a proper list" - hdrs)) - (let loop ([items hdrs] [result '()]) - (cond - [(null? items) (reverse result)] - [(and (symbol? (car items)) (eq? (car items) '::)) - (loop (cdr items) result)] - [(pair? (car items)) - (let ([item (car items)]) - (if (and (pair? item) - (string? (car item)) - (pair? (cdr item)) - (eq? (cadr item) '::) - (pair? (cddr item)) - (null? (cdddr item))) - (loop - (cdr items) - (cons (cons (car item) (caddr item)) result)) - (if (string? (car item)) - (error 'flatten-request-headers - "malformed name :: value entry" - item) - (loop - (cdr items) - (fold-left - (lambda (acc x) (cons x acc)) - result - (flatten-request-headers item))))))] - [else - (error 'flatten-request-headers - "invalid header list entry" - (car items))]))))) - (def (build-query-string params) - (if (or (not params) (null? params)) - "" - (let ([pairs (flatten-request-headers params)]) - (string-join - (map (lambda (p) - (string-append - (url-encode (car p)) - "=" - (url-encode (cdr p)))) - pairs) - "&")))) - (def (header-assoc name headers) - (let ([name-lower (string-downcase name)]) - (let loop ([h headers]) - (cond - [(null? h) #f] - [(string=? name-lower (string-downcase (caar h))) (car h)] - [else (loop (cdr h))])))) - (def (header-count name headers) - (let ([name-lower (string-downcase name)]) - (let loop ([rest headers] [count 0]) - (cond - [(null? rest) count] - [(and (pair? (car rest)) - (string? (caar rest)) - (string=? name-lower (string-downcase (caar rest)))) - (loop (cdr rest) (+ count 1))] - [else (loop (cdr rest) count)])))) - (def (http-token-char? c) - (let ([n (char->integer c)]) - (or (and (>= n 48) (<= n 57)) - (and (>= n 65) (<= n 90)) - (and (>= n 97) (<= n 122)) - (memv - c - '(#\! #\# #\$ #\% #\& #\' #\* #\+ #\- #\. #\^ #\_ #\` #\| - #\~))))) - (def (valid-http-token? value) - (and (string? value) - (> (string-length value) 0) - (let loop ([i 0]) - (or (= i (string-length value)) - (and (http-token-char? (string-ref value i)) - (loop (+ i 1))))))) - (def (valid-header-value? value) - (and (string? value) - (let loop ([i 0]) - (if (= i (string-length value)) - #t - (let ([n (char->integer (string-ref value i))]) - (and (>= n 32) (not (= n 127)) (loop (+ i 1)))))))) - (def (valid-host-field? value) - (and (valid-header-value? value) - (> (string-length value) 0) - (let loop ([i 0]) - (or (= i (string-length value)) - (and (not (char-whitespace? (string-ref value i))) - (loop (+ i 1))))))) - (def (validate-host! who host) - (unless (valid-host-field? host) - (error who - "host contains whitespace or control characters" - host)) - (when (or (string-index host #\/) - (string-index host #\?) - (string-index host #\#) - (string-index host #\@)) - (error who "host contains an authority delimiter" host))) - (def (validate-request-target! who target) - (unless (and (string? target) - (> (string-length target) 0) - (char=? (string-ref target 0) #\/)) - (error who "request target must be origin-form" target)) - (let loop ([i 0]) - (when (< i (string-length target)) - (let ([c (string-ref target i)]) - (when (or (char-whitespace? c) - (< (char->integer c) 32) - (= (char->integer c) 127) - (char=? c #\#)) - (error who - "request target contains forbidden characters" - target)) - (loop (+ i 1)))))) - (def (bounded-unsigned-integer text radix limit) - (and (string? text) - (> (string-length text) 0) - (let loop ([i 0] [value 0]) - (if (= i (string-length text)) - value - (let* ([c (string-ref text i)] - [n (char->integer c)] - [digit (cond - [(and (>= n 48) (<= n 57)) (- n 48)] - [(and (= radix 16) (>= n 65) (<= n 70)) - (+ 10 (- n 65))] - [(and (= radix 16) (>= n 97) (<= n 102)) - (+ 10 (- n 97))] - [else #f])]) - (and digit - (< digit radix) - (<= digit limit) - (<= value (quotient (- limit digit) radix)) - (loop (+ i 1) (+ (* value radix) digit)))))))) - (def (validate-outbound-headers! headers body-bv) - (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)) - (validate-request-target! 'build-request path) - (validate-host! 'build-request host) - (validate-outbound-headers! headers body-bv) - (let ([out (open-output-string)]) - (put-string out method) - (put-string out " ") - (put-string out path) - (put-string out " HTTP/1.1\r\n") - (unless (header-assoc "Host" headers) - (put-string out "Host: ") - (put-string out host) - (put-string out "\r\n")) - (for-each - (lambda (h) - (put-string out (car h)) - (put-string out ": ") - (put-string out (cdr h)) - (put-string out "\r\n")) - headers) - (when (and body-bv - (not (header-assoc "Content-Length" headers))) - (put-string out "Content-Length: ") - (put-string - out - (number->string (bytevector-length body-bv))) - (put-string out "\r\n")) - (unless (header-assoc "Connection" headers) - (put-string - out - (if keep-alive? - "Connection: keep-alive\r\n" - "Connection: close\r\n"))) - (put-string out "\r\n") - (get-output-string out))) - (def (parse-status-line line) - (let ([space (string-index line #\space)]) - (unless space - (error 'read-response "malformed status line")) - (let* ([version (substring line 0 space)] - [rest (substring line (+ space 1) (string-length line))] - [space2 (string-index rest #\space)] - [code-str (if space2 (substring rest 0 space2) rest)] - [status (bounded-unsigned-integer code-str 10 999)]) - (unless (or (string=? version "HTTP/1.0") - (string=? version "HTTP/1.1")) - (error 'read-response - "unsupported HTTP response version" - version)) - (unless (and (= (string-length code-str) 3) - status - (>= status 100)) - (error 'read-response "invalid HTTP status code" code-str)) - (values version status)))) - (def (trim-http-ows value) - (let* ([len (string-length value)] - [start (let loop ([i 0]) - (if (and (< i len) - (or (char=? (string-ref value i) #\space) - (char=? (string-ref value i) #\tab))) - (loop (+ i 1)) - i))] - [end (let loop ([i len]) - (if (and (> i start) - (or (char=? - (string-ref value (- i 1)) - #\space) - (char=? - (string-ref value (- i 1)) - #\tab))) - (loop (- i 1)) - i))]) - (substring value start end))) - (def (parse-header-line line) - (let ([colon (string-index line #\:)]) - (unless (and colon (> colon 0)) - (error 'read-response "malformed response header")) - (let ([name (substring line 0 colon)] - [value (trim-http-ows - (substring - line - (+ colon 1) - (string-length line)))]) - (unless (valid-http-token? name) - (error 'read-response "invalid response header name" name)) - (unless (valid-header-value? value) - (error 'read-response - "response header contains control characters" - name)) - (cons (string-downcase name) value)))) - (def (header-value headers name) - (let ([pair (assoc name headers)]) (and pair (cdr pair)))) - (def (header-values headers name) - (let ([target (string-downcase name)]) - (let loop ([rest headers] [result '()]) - (cond - [(null? rest) (reverse result)] - [(string=? (caar rest) target) - (loop (cdr rest) (cons (cdar rest) result))] - [else (loop (cdr rest) result)])))) - (def (header-has-token? headers name token) - (let ([target (string-downcase token)]) - (let value-loop ([values (header-values headers name)]) - (and (pair? values) - (or (let token-loop ([tokens (string-split - (car values) - #\,)]) - (and (pair? tokens) - (or (string=? - (string-downcase - (trim-http-ows (car tokens))) - target) - (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* - (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) - (string-append host ":" (number->string port))) - (def (pool-get host port) - (let ([key (pool-key host port)]) - (with-mutex *conn-pool-mutex* - (let ([conns (hashtable-ref *conn-pool* key '())]) - (if (null? conns) - #f - (let ([conn (car conns)]) - (hashtable-set! *conn-pool* key (cdr conns)) - conn)))))) - (def (pool-put host port conn) - (let ([key (pool-key host port)]) - (with-mutex *conn-pool-mutex* - (let ([conns (hashtable-ref *conn-pool* key '())]) - (if (< (length conns) 4) - (hashtable-set! *conn-pool* key (cons conn conns)) - (ssl-close conn)))))) - (def (monotonic-seconds) - (let ([now (current-time 'time-monotonic)]) - (+ (time-second now) - (/ (time-nanosecond now) 1000000000.0)))) - (def (make-response-deadline) - (+ (monotonic-seconds) (response-policy-ref 8))) - (def (make-response-reader conn deadline) - (vector conn (make-bytevector 32768) 0 0 deadline)) - (def (response-reader-conn reader) (vector-ref reader 0)) - (def (response-reader-buffer reader) (vector-ref reader 1)) - (def (response-reader-position reader) - (vector-ref reader 2)) - (def (response-reader-end reader) (vector-ref reader 3)) - (def (response-reader-deadline reader) - (vector-ref reader 4)) - (def (response-reader-position-set! reader value) - (vector-set! reader 2 value)) - (def (response-reader-end-set! reader value) - (vector-set! reader 3 value)) - (def (response-reader-available reader) - (- (response-reader-end reader) - (response-reader-position reader))) - (def (response-reader-fill! reader) - (let ([remaining (- (response-reader-deadline reader) - (monotonic-seconds))]) - (when (<= remaining 0) - (error 'read-response "total response deadline exceeded")) - (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) - (let ([count (ssl-read - (response-reader-conn reader) - buf - (bytevector-length buf))]) - (response-reader-position-set! reader 0) - (response-reader-end-set! reader (max count 0)) - count)))) - (def (response-reader-read-byte reader) - (when (= (response-reader-available reader) 0) - (response-reader-fill! reader)) - (if (= (response-reader-available reader) 0) - #f - (let* ([position (response-reader-position reader)] - [byte (bytevector-u8-ref - (response-reader-buffer reader) - position)]) - (response-reader-position-set! reader (+ position 1)) - byte))) - (def (response-reader-read-line reader limit who) - (let ([line (make-bytevector limit)] - [buf (response-reader-buffer reader)]) - (let loop ([length 0]) - (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]) - (if (= offset length) - result - (begin - (when (= (response-reader-available reader) 0) - (response-reader-fill! reader)) - (when (= (response-reader-available reader) 0) - (error who "truncated response body")) - (let ([take (min (- length offset) - (response-reader-available reader))]) - (bytevector-copy! (response-reader-buffer reader) - (response-reader-position reader) result offset take) - (response-reader-position-set! - reader - (+ (response-reader-position reader) take)) - (loop (+ offset take)))))))) - (def (response-reader-read-some reader limit) - (when (= (response-reader-available reader) 0) - (response-reader-fill! reader)) - (if (= (response-reader-available reader) 0) - #f - (let* ([take (min limit (response-reader-available reader))] - [result (make-bytevector take)]) - (bytevector-copy! (response-reader-buffer reader) - (response-reader-position reader) result 0 take) - (response-reader-position-set! - reader - (+ (response-reader-position reader) take)) - result))) - (def (checked-total who current addition limit) - (when (or (< addition 0) (> addition (- limit current))) - (error who "configured byte limit exceeded" limit)) - (+ current addition)) - (def (read-response-head reader) - (let-values ([(status-line status-wire) - (response-reader-read-line - reader - (response-policy-ref 0) - 'read-response)]) - (when (> status-wire (response-policy-ref 2)) - (error 'read-response - "response headers exceed configured limit")) - (let-values ([(version status) - (parse-status-line status-line)]) - (let loop ([headers '()] [count 0] [total status-wire]) - (let-values ([(line wire) - (response-reader-read-line - reader - (response-policy-ref 1) - 'read-response)]) - (let ([new-total (checked-total - 'read-response - total - wire - (response-policy-ref 2))]) - (cond - [(string=? line "") - (values version status (reverse headers))] - [(>= count (response-policy-ref 3)) - (error 'read-response "too many response headers")] - [else - (loop - (cons (parse-header-line line) headers) - (+ count 1) - new-total)]))))))) - (def (response-framing headers) - (let ([content-lengths (header-values - headers - "content-length")] - [transfer-encodings (header-values - headers - "transfer-encoding")]) - (when (> (length content-lengths) 1) - (error 'read-response "duplicate Content-Length headers")) - (when (> (length transfer-encodings) 1) - (error 'read-response - "duplicate Transfer-Encoding headers")) - (when (and (pair? content-lengths) - (pair? transfer-encodings)) - (error 'read-response - "conflicting Content-Length and Transfer-Encoding")) - (cond - [(pair? transfer-encodings) - (unless (string=? - (string-downcase - (trim-http-ows (car transfer-encodings))) - "chunked") - (error 'read-response - "unsupported Transfer-Encoding" - (car transfer-encodings))) - (values 'chunked #f)] - [(pair? content-lengths) - (let ([length (bounded-unsigned-integer - (car content-lengths) - 10 - (response-policy-ref 4))]) - (unless length - (error 'read-response - "invalid or oversized Content-Length" - (car content-lengths))) - (values 'content-length length))] - [else (values 'close-delimited #f)]))) - (def (parse-chunk-size-line line) - (let* ([semi (string-index line #\;)] - [size-text (if semi (substring line 0 semi) line)]) - (unless (> (string-length size-text) 0) - (error 'read-response "empty chunk size")) - (let ([size (bounded-unsigned-integer - size-text - 16 - (response-policy-ref 5))]) - (unless size - (error 'read-response - "invalid or oversized chunk size" - size-text)) - size))) - (def (consume-response-trailers reader wire-total) - (let loop ([count 0] [wire wire-total]) - (let-values ([(line line-wire) - (response-reader-read-line - reader - (response-policy-ref 1) - 'read-response)]) - (let ([new-wire (checked-total - 'read-response - wire - line-wire - (response-policy-ref 6))]) - (cond - [(string=? line "") new-wire] - [(>= count (response-policy-ref 3)) - (error 'read-response "too many chunk trailers")] - [else - (let ([trailer (parse-header-line line)]) - (when (member - (car trailer) - '("content-length" "transfer-encoding" "host")) - (error 'read-response - "forbidden framing trailer" - (car trailer))) - (loop (+ count 1) new-wire))]))))) - (def (read-chunked-response-body reader) - (let loop ([chunks '()] [decoded 0] [wire 0]) - (let-values ([(size-line size-wire) - (response-reader-read-line - reader - (response-policy-ref 1) - 'read-response)]) - (let* ([wire-after-line (checked-total - 'read-response - wire - size-wire - (response-policy-ref 6))] - [chunk-size (parse-chunk-size-line size-line)]) - (if (= chunk-size 0) - (begin - (consume-response-trailers reader wire-after-line) - (bytevector-concat-list (reverse chunks))) - (let* ([new-decoded (checked-total - 'read-response - decoded - chunk-size - (response-policy-ref 4))] - [wire-after-data (checked-total - 'read-response - wire-after-line - chunk-size - (response-policy-ref 6))] - [chunk (response-reader-read-exact - reader - chunk-size - 'read-response)] - [terminator (response-reader-read-exact - reader - 2 - 'read-response)] - [new-wire (checked-total - 'read-response - wire-after-data - 2 - (response-policy-ref 6))]) - (unless (and (= (bytevector-u8-ref terminator 0) 13) - (= (bytevector-u8-ref terminator 1) 10)) - (error 'read-response "invalid chunk terminator")) - (loop (cons chunk chunks) new-decoded new-wire))))))) - (def (read-close-delimited-body reader) - (let loop ([chunks '()] [total 0]) - (let ([chunk (response-reader-read-some reader 32768)]) - (if (not chunk) - (bytevector-concat-list (reverse chunks)) - (let ([new-total (checked-total - 'read-response - total - (bytevector-length chunk) - (response-policy-ref 4))]) - (loop (cons chunk chunks) new-total)))))) - (def (response-default-keep-alive? version headers) - (and (not (header-has-token? headers "connection" "close")) - (or (string=? version "HTTP/1.1") - (header-has-token? headers "connection" "keep-alive")))) - (def (response-must-not-have-body? method status) - (or (string=? method "HEAD") - (and (>= status 100) (< status 200)) - (= status 204) - (= status 304))) - (def (read-response conn method) - (let ([reader (make-response-reader - conn - (make-response-deadline))]) - (let interim-loop ([interim-count 0]) - (let-values ([(version status headers) - (read-response-head reader)]) - (cond - [(and (>= status 100) (< status 200) (not (= status 101))) - (when (>= interim-count (response-policy-ref 9)) - (error 'read-response "too many interim responses")) - (let-values ([(mode length) (response-framing headers)]) - (when (or (eq? mode 'chunked) - (and (eq? mode 'content-length) (> length 0))) - (error 'read-response - "interim response declared a body"))) - (interim-loop (+ interim-count 1))] - [else - (let-values ([(mode content-length) - (response-framing headers)]) - (let* ([bodyless? (response-must-not-have-body? - method - status)] - [body (cond - [bodyless? (make-bytevector 0)] - [(eq? mode 'chunked) - (read-chunked-response-body reader)] - [(eq? mode 'content-length) - (response-reader-read-exact - reader - content-length - 'read-response)] - [else - (read-close-delimited-body reader)])] - [framing-reusable? (and (not (= status 101)) - (or bodyless? - (eq? mode 'chunked) - (eq? mode - 'content-length)))] - [keep-alive? (and framing-reusable? - (= (response-reader-available - reader) - 0) - (response-default-keep-alive? - version - headers))]) - (values status headers body keep-alive?)))]))))) - (def (make-request-result status headers body-bv) - (vector status headers body-bv)) - (def (request-status req) (vector-ref req 0)) - (def (request-headers req) (vector-ref req 1)) - (def (request-content req) (vector-ref req 2)) - (def (request-text req) - (let ([body (vector-ref req 2)]) - (if (= (bytevector-length body) 0) "" (utf8->string body))))