diff --git a/scheme/lib/sunet-utilities.scm b/scheme/lib/sunet-utilities.scm index 4eb882b..ddb6ced 100644 --- a/scheme/lib/sunet-utilities.scm +++ b/scheme/lib/sunet-utilities.scm @@ -126,3 +126,33 @@ (or maybe-length (http-error (status-code bad-request) req "No Content-Length header in request")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Decode chunked entity bodies: "chunked transfer-coding" + + +;;; See RFC 2616, 3.6.1 and 19.4.6 for the composition of chunked entity bodies. +;;; See RFC 2616, 4.4 for precedence of Transfer-encoding header over Content-length header. + + +;;; Is the request's entity body sent in chunked transfer-encoding? +;;; (See RFC 2616, 14.41 and 3.6 for syntax and semantics of Transfer-Encoding header.) + +(define (chunked-transfer-coding? req) + (let ((field-value (get-header (request-headers req) 'transfer-encoding))) + (if (not field-value) + #f + + ; the field value is a list of transfer-codings (3.6), + ; extract the last transfer-coding in the list + (let* ((reversed-field-value (string-reverse field-value)) + (index ; does the list contain more than one element? + (string-contains reversed-field-value " , ")) + (last-transfer-coding + (if index + (string-trim (string-reverse (string-take reversed-field-value index))) + (string-trim field-value)))) + + ; the first token of the (extracted last) transfer-coding must be "chunked" to indicate chunked transfer coding + (string-prefix? "chunked" last-transfer-coding))))) + diff --git a/scheme/packages.scm b/scheme/packages.scm index 92ba8ba..225742f 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -248,7 +248,8 @@ dotdot-check with-lock get-header - get-body-length-from-content-length)) + get-body-length-from-content-length + chunked-transfer-coding?)) (define-interface handle-fatal-error-interface (export with-fatal-error-handler* @@ -585,7 +586,7 @@ (open scheme-with-scsh format-net sigevents - (subset srfi-13 (string-join string-skip string-trim-both)) + (subset srfi-13 (string-join string-skip string-trim-both string-trim string-prefix? string-reverse string-contains string-take)) dns let-opt ; :optional locks