Re: Chunked Encoding

[Ian Price]

I've attached the patch. It's not ready for inclusion yet, as it needs
more tests, and documentation, but this is the rough idea of what it
will be like. It doesn't close the wrapped port, but I think a keyword
argument might be the right approach.

Thoughts on this, and the patch in general are welcome

I'd just like to make a note that, instead of modifying the client, I
modified read-response-body directly. This feels like probably the right
thing to do.

-- 
Ian Price

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

>From cf7835882a586bcb3d9077563acbb1aecf09cf97 Mon Sep 17 00:00:00 2001
From: Ian Price <address@hidden>
Date: Sun, 6 May 2012 17:40:09 +0100
Subject: [PATCH] transfer encoding draft

---
 module/web/request.scm             |   32 +++++++++++++-
 module/web/response.scm            |   82 ++++++++++++++++++++++++++++++++---
 test-suite/tests/web-request.test  |   13 ++++++
 test-suite/tests/web-response.test |   27 ++++++++++++
 4 files changed, 146 insertions(+), 8 deletions(-)

diff --git a/module/web/request.scm b/module/web/request.scm
index 40d4a66..90ca326 100644
--- a/module/web/request.scm
+++ b/module/web/request.scm
@@ -26,6 +26,7 @@
   #:use-module (srfi srfi-9)
   #:use-module (web uri)
   #:use-module (web http)
+  #:use-module (ice-9 q)
   #:export (request?
             request-method
             request-uri
@@ -89,7 +90,9 @@
             request-user-agent
 
             ;; Misc
-            request-absolute-uri))
+            request-absolute-uri
+
+            make-chunked-output-port))
 
 
 ;;; {Character Encodings, Strings, and Bytevectors}
@@ -313,3 +316,30 @@ request @var{r}."
                      #:path (uri-path uri)
                      #:query (uri-query uri)
                      #:fragment (uri-fragment uri))))))
+
+;; Chunked Requests
+(define (make-chunked-output-port port)
+  (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)
+    (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)
+    ;;(flush) ;; prints the final zero chunk
+    ;;(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..9d04064 100644
--- a/module/web/response.scm
+++ b/module/web/response.scm
@@ -40,6 +40,8 @@
             read-response-body
             write-response-body
 
+            make-chunked-input-port
+
             ;; General headers
             ;;
             response-cache-control
@@ -227,13 +229,16 @@ 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))))
+        (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
@@ -291,3 +296,66 @@ response @var{r}."
 (define-response-accessor server #f)
 (define-response-accessor vary '())
 (define-response-accessor www-authenticate #f)
+
+
+;; 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)
+  (define (next-chunk)
+    (read-chunk port))
+  (define finished? #f)
+  (define (close)
+    #f
+    ;(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 num-read))
+             (loop (- to-read buffer-size)
+                   (+ num-read buffer-size)))
+            (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 ;; get-position
+   #f ;; set-position!
+   close))
diff --git a/test-suite/tests/web-request.test 
b/test-suite/tests/web-request.test
index 8cf1c2e..9c64d61 100644
--- a/test-suite/tests/web-request.test
+++ b/test-suite/tests/web-request.test
@@ -83,3 +83,16 @@ Accept-Language: en-gb, en;q=0.9\r
 
     (pass-if "by accessor"
       (equal? (request-accept-encoding r) '((1000 . "gzip"))))))
+
+(with-test-prefix "chunked encoding"
+  (pass-if
+      (equal? (call-with-output-string
+               (lambda (out-raw)
+                 (let ((out-chunked (make-chunked-output-port out-raw)))
+                   (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..d621e87 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,17 @@ 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.")))))
+  (let* ((r (build-response #:port (open-input-string "0\r\n") #:headers 
'((transfer-encoding (chunked)))))
+         (b (read-response-body r))) ;; should be eof or #vu8()???
+    (pass-if (eof-object? b))))
-- 
1.7.7.6