Re: Chunked Encoding

[Ian Price]

Hello guilers,

Here is a more complete patch. I've also attached a patch to export
declare-opaque-header!, which I've occasionally found to be useful.

-- 
Ian Price

"Programming is like pinball. The reward for doing it well is
the opportunity to do it again" - from "The Wizardy Compiled"

>From 56a51160a3cba02a4a10375a73106359a1c4a722 Mon Sep 17 00:00:00 2001
From: Ian Price <address@hidden>
Date: Tue, 8 May 2012 00:06:01 +0100
Subject: [PATCH 1/2] Add HTTP Chunked Encoding support to web modules.

* doc/ref/web.texi(Transfer Codings): New subsection for transfer codings.
* module/web/http.scm(make-chunked-input-port,
  make-chunked-output-port): New procedures.
* module/web/response.scm (read-response-body): Handle chunked responses.
* test-suite/tests/web-response.test: Add test.
* test-suite/tests/web-http.test: Add tests.
---
 doc/ref/web.texi                   |   60 +++++++++++++++++++++
 module/web/http.scm                |  104 +++++++++++++++++++++++++++++++++++-
 module/web/response.scm            |   18 ++++---
 test-suite/tests/web-http.test     |   20 +++++++
 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 8bb99e2..e38aee2 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 Coding::             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
 
address@hidden Transfer Codings
address@hidden 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.
+
address@hidden {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.
address@hidden deffn
+
address@hidden
+(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)
address@hidden "First line"
+(read-line s)
address@hidden "Second line"
address@hidden example
+
address@hidden {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.
address@hidden deffn
+
address@hidden
+(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*)))
address@hidden "b\r\nfirst chunk\r\nc\r\nsecond chunk\r\n0\r\n"
address@hidden example
 
 @node Requests
 @subsection HTTP Requests
diff --git a/module/web/http.scm b/module/web/http.scm
index d579c52..9232b28 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 07e1245..6eba69d 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 7984565..97f5559 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 a21a702..ddd55a7 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."))))))
-- 
1.7.7.6

>From e47ef2722d90998256e226b2e2ec2bcec68b07b5 Mon Sep 17 00:00:00 2001
From: Ian Price <address@hidden>
Date: Tue, 8 May 2012 00:18:59 +0100
Subject: [PATCH 2/2] Document and export `declare-opaque-header!'

* module/web/http.scm (declare-opaque-header!): Add docstring. New export.
* doc/ref/web.texi (HTTP): Add documentation.
---
 doc/ref/web.texi    |    5 +++++
 module/web/http.scm |    3 +++
 2 files changed, 8 insertions(+), 0 deletions(-)

diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index e38aee2..7f86748 100644
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@@ -398,6 +398,11 @@ HTTP stack like this:
     (display (inet-ntoa ip) port)))
 @end example
 
address@hidden {Scheme Procedure} declare-opaque-header! name
+A specialised version of @code{declare-header!} for the case in which
+you want a header's value to be returned/written ``as-is''.
address@hidden deffn
+
 @deffn {Scheme Procedure} valid-header? sym val
 Return a true value iff @var{val} is a valid Scheme value for the header
 with name @var{sym}.
diff --git a/module/web/http.scm b/module/web/http.scm
index 9232b28..cc5dd5a 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -42,6 +42,7 @@
             header->string
 
             declare-header!
+            declare-opaque-header!
             known-header?
             header-parser
             header-validator
@@ -1145,6 +1146,8 @@ phrase\"."
 ;; emacs: (put 'declare-header! 'scheme-indent-function 1)
 ;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1)
 (define (declare-opaque-header! name)
+  "Declares a given header as \"opaque\", meaning that its value is not
+treated specially, and is just returned as a plain string."
   (declare-header! name
     parse-opaque-string validate-opaque-string write-opaque-string))
 
-- 
1.7.7.6