diff options
-rw-r--r-- | doc/ref/web.texi | 60 | ||||
-rw-r--r-- | module/web/http.scm | 104 | ||||
-rw-r--r-- | module/web/response.scm | 18 | ||||
-rw-r--r-- | test-suite/tests/web-http.test | 20 | ||||
-rw-r--r-- | test-suite/tests/web-response.test | 24 |
5 files changed, 218 insertions, 8 deletions
diff --git a/doc/ref/web.texi b/doc/ref/web.texi index a3d92ad8f..d4eec1021 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -37,6 +37,7 @@ back. * URIs:: Universal Resource Identifiers. * HTTP:: The Hyper-Text Transfer Protocol. * HTTP Headers:: How Guile represents specific header values. +* Transfer Codings:: HTTP Transfer Codings. * Requests:: HTTP requests. * Responses:: HTTP responses. * Web Client:: Accessing web resources over HTTP. @@ -1020,6 +1021,65 @@ A list of challenges to a user, indicating the need for authentication. @end example @end deftypevr +@node Transfer Codings +@subsection Transfer Codings + +HTTP 1.1 allows for various transfer codings to be applied to message +bodies. These include various types of compression, and HTTP chunked +encoding. Currently, only chunked encoding is supported by guile. + +Chunked coding is an optional coding that may be applied to message +bodies, to allow messages whose length is not known beforehand to be +returned. Such messages can be split into chunks, terminated by a final +zero length chunk. + +In order to make dealing with encodings more simple, guile provides +procedures to create ports that ``wrap'' existing ports, applying +transformations transparently under the hood. + +@deffn {Scheme Procedure} make-chunked-input-port port [#:keep-alive?=#f] +Returns a new port, that transparently reads and decodes chunk-encoded +data from @var{port}. If no more chunk-encoded data is available, it +returns the end-of-file object. When the port is closed, @var{port} will +also be closed, unless @var{keep-alive?} is true. +@end deffn + +@example +(use-modules (ice-9 rdelim)) + +(define s "5\r\nFirst\r\nA\r\n line\n Sec\r\n8\r\nond line\r\n0\r\n") +(define p (make-chunked-input-port (open-input-string s))) +(read-line s) +@result{} "First line" +(read-line s) +@result{} "Second line" +@end example + +@deffn {Scheme Procedure} make-chunked-output-port port [#:keep-alive?=#f] +Returns a new port, which transparently encodes data as chunk-encoded +before writing it to @var{port}. Whenever a write occurs on this port, +it buffers it, until the port is flushed, at which point it writes a +chunk containing all the data written so far. When the port is closed, +the data remaining is written to @var{port}, as is the terminating zero +chunk. It also causes @var{port} to be closed, unless @var{keep-alive?} +is true. + +Note. Forcing a chunked output port when there is no data is buffered +does not write a zero chunk, as this would cause the data to be +interpreted incorrectly by the client. +@end deffn + +@example +(call-with-output-string + (lambda (out) + (define out* (make-chunked-output-port out #:keep-alive? #t)) + (display "first chunk" out*) + (force-output out*) + (force-output out*) ; note this does not write a zero chunk + (display "second chunk" out*) + (close-port out*))) +@result{} "b\r\nfirst chunk\r\nc\r\nsecond chunk\r\n0\r\n" +@end example @node Requests @subsection HTTP Requests diff --git a/module/web/http.scm b/module/web/http.scm index d579c5267..9232b281e 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -34,6 +34,9 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) #:use-module (ice-9 rdelim) + #:use-module (ice-9 q) + #:use-module (ice-9 binary-ports) + #:use-module (rnrs bytevectors) #:use-module (web uri) #:export (string->header header->string @@ -59,7 +62,10 @@ read-request-line write-request-line read-response-line - write-response-line)) + write-response-line + + make-chunked-input-port + make-chunked-output-port)) ;;; TODO @@ -1799,3 +1805,99 @@ phrase\"." ;; WWW-Authenticate = 1#challenge ;; (declare-challenge-list-header! "WWW-Authenticate") + + +;; Chunked Responses +(define (read-chunk-header port) + (let* ((str (read-line port)) + (extension-start (string-index str (lambda (c) (or (char=? c #\;) + (char=? c #\return))))) + (size (string->number (if extension-start ; unnecessary? + (substring str 0 extension-start) + str) + 16))) + size)) + +(define (read-chunk port) + (let ((size (read-chunk-header port))) + (read-chunk-body port size))) + +(define (read-chunk-body port size) + (let ((bv (get-bytevector-n port size))) + (get-u8 port) ; CR + (get-u8 port) ; LF + bv)) + +(define* (make-chunked-input-port port #:key (keep-alive? #f)) + "Returns a new port which translates HTTP chunked transfer encoded +data from @var{port} into a non-encoded format. Returns eof when it has +read the final chunk from @var{port}. This does not necessarily mean +that there is no more data on @var{port}. When the returned port is +closed it will also close @var{port}, unless the KEEP-ALIVE? is true." + (define (next-chunk) + (read-chunk port)) + (define finished? #f) + (define (close) + (unless keep-alive? + (close-port port))) + (define buffer #vu8()) + (define buffer-size 0) + (define buffer-pointer 0) + (define (read! bv idx to-read) + (define (loop to-read num-read) + (cond ((or finished? (zero? to-read)) + num-read) + ((<= to-read (- buffer-size buffer-pointer)) + (bytevector-copy! buffer buffer-pointer + bv (+ idx num-read) + to-read) + (set! buffer-pointer (+ buffer-pointer to-read)) + (loop 0 (+ num-read to-read))) + (else + (let ((n (- buffer-size buffer-pointer))) + (bytevector-copy! buffer buffer-pointer + bv (+ idx num-read) + n) + (set! buffer (next-chunk)) + (set! buffer-pointer 0) + (set! buffer-size (bytevector-length buffer)) + (set! finished? (= buffer-size 0)) + (loop (- to-read n) + (+ num-read n)))))) + (loop to-read 0)) + (make-custom-binary-input-port "chunked input port" read! #f #f close)) + +(define* (make-chunked-output-port port #:key (keep-alive? #f)) + "Returns a new port which translates non-encoded data into a HTTP +chunked transfer encoded data and writes this to @var{port}. Data +written to this port is buffered until the port is flushed, at which +point it is all sent as one chunk. Take care to close the port when +done, as it will output the remaining data, and encode the final zero +chunk. When the port is closed it will also close @var{port}, unless +KEEP-ALIVE? is true." + (define (q-for-each f q) + (while (not (q-empty? q)) + (f (deq! q)))) + (define queue (make-q)) + (define (put-char c) + (enq! queue c)) + (define (put-string s) + (string-for-each (lambda (c) (enq! queue c)) + s)) + (define (flush) + ;; It is important that we do _not_ write a chunk if the queue is + ;; empty, since it will be treated as the final chunk. + (unless (q-empty? queue) + (let ((len (q-length queue))) + (display (number->string len 16) port) + (display "\r\n" port) + (q-for-each (lambda (elem) (write-char elem port)) + queue) + (display "\r\n" port)))) + (define (close) + (flush) + (display "0\r\n" port) + (force-output port) + (unless keep-alive? + (close-port port))) + (make-soft-port (vector put-char put-string flush #f close) "w")) diff --git a/module/web/response.scm b/module/web/response.scm index 07e124539..6eba69d8d 100644 --- a/module/web/response.scm +++ b/module/web/response.scm @@ -227,13 +227,17 @@ This is true for some response types, like those with code 304." (define (read-response-body r) "Reads the response body from @var{r}, as a bytevector. Returns @code{#f} if there was no response body." - (let ((nbytes (response-content-length r))) - (and nbytes - (let ((bv (get-bytevector-n (response-port r) nbytes))) - (if (= (bytevector-length bv) nbytes) - bv - (bad-response "EOF while reading response body: ~a bytes of ~a" - (bytevector-length bv) nbytes)))))) + (if (member '(chunked) (response-transfer-encoding r)) + (let ((chunk-port (make-chunked-input-port (response-port r) + #:keep-alive? #t))) + (get-bytevector-all chunk-port)) + (let ((nbytes (response-content-length r))) + (and nbytes + (let ((bv (get-bytevector-n (response-port r) nbytes))) + (if (= (bytevector-length bv) nbytes) + bv + (bad-response "EOF while reading response body: ~a bytes of ~a" + (bytevector-length bv) nbytes))))))) (define (write-response-body r bv) "Write @var{bv}, a bytevector, to the port corresponding to the HTTP diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index 79845653e..97f55594a 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -20,6 +20,7 @@ (define-module (test-suite web-http) #:use-module (web uri) #:use-module (web http) + #:use-module (rnrs io ports) #:use-module (ice-9 regex) #:use-module (ice-9 control) #:use-module (srfi srfi-19) @@ -232,3 +233,22 @@ (pass-if-parse vary "foo, bar" '(foo bar)) (pass-if-parse www-authenticate "Basic realm=\"guile\"" '((basic (realm . "guile"))))) + +(with-test-prefix "chunked encoding" + (let* ((s "5\r\nFirst\r\nA\r\n line\n Sec\r\n8\r\nond line\r\n0\r\n") + (p (make-chunked-input-port (open-input-string s)))) + (pass-if (equal? "First line\n Second line" + (get-string-all p))) + (pass-if (port-eof? (make-chunked-input-port (open-input-string "0\r\n"))))) + (pass-if + (equal? (call-with-output-string + (lambda (out-raw) + (let ((out-chunked (make-chunked-output-port out-raw + #:keep-alive? #t))) + (display "First chunk" out-chunked) + (force-output out-chunked) + (display "Second chunk" out-chunked) + (force-output out-chunked) + (display "Third chunk" out-chunked) + (close-port out-chunked)))) + "b\r\nFirst chunk\r\nc\r\nSecond chunk\r\nb\r\nThird chunk\r\n0\r\n"))) diff --git a/test-suite/tests/web-response.test b/test-suite/tests/web-response.test index a21a70207..ddd55a750 100644 --- a/test-suite/tests/web-response.test +++ b/test-suite/tests/web-response.test @@ -40,6 +40,19 @@ Content-Type: text/html; charset=utf-8\r \r abcdefghijklmnopqrstuvwxyz0123456789") +(define example-2 + "HTTP/1.1 200 OK\r +Transfer-Encoding: chunked\r +Content-Type: text/plain +\r +1c\r +Lorem ipsum dolor sit amet, \r +1d\r +consectetur adipisicing elit,\r +43\r + sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.\r +0\r\n") + (define (responses-equal? r1 body1 r2 body2) (and (equal? (response-version r1) (response-version r2)) (equal? (response-code r1) (response-code r2)) @@ -100,3 +113,14 @@ abcdefghijklmnopqrstuvwxyz0123456789") (pass-if "by accessor" (equal? (response-content-encoding r) '(gzip))))) + +(with-test-prefix "example-2" + (let* ((r (read-response (open-input-string example-2))) + (b (read-response-body r))) + (pass-if (equal? '((chunked)) + (response-transfer-encoding r))) + (pass-if (equal? b + (string->utf8 + (string-append + "Lorem ipsum dolor sit amet, consectetur adipisicing elit," + " sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.")))))) |