From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 21 Sep 2008 07:35:15 +0000 (+0000)
Subject: Implement "chunked" transfer encoding, required by HTTP 1.1.  Fix bug
X-Git-Tag: 20090517-FFI~134
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6ccebf52d3c2b554a971af59718c10f9f543c946;p=mit-scheme.git

Implement "chunked" transfer encoding, required by HTTP 1.1.  Fix bug
in "transfer-encoding" header parser.  Add new procedure
READ-RFC2822-FOLDED-LINE that reads a line of text, dealing with the
header-field folding from RFC 2822.
---

diff --git a/v7/src/runtime/http-syntax.scm b/v7/src/runtime/http-syntax.scm
index 21bd412cf..e4e03a2e6 100644
--- a/v7/src/runtime/http-syntax.scm
+++ b/v7/src/runtime/http-syntax.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: http-syntax.scm,v 1.2 2008/09/17 06:31:48 cph Exp $
+$Id: http-syntax.scm,v 1.3 2008/09/21 07:35:03 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -220,25 +220,11 @@ USA.
 
 (define (read-http-headers port)
   (let loop ((headers '()))
-    (let ((string (%read-http-header port)))
+    (let ((string (read-rfc2822-folded-line port)))
       (if string
 	  (loop (cons (parse-header string) headers))
 	  (reverse! headers)))))
 
-(define (%read-http-header port)
-  (let ((line (read-line port)))
-    (if (eof-object? line)
-	(error "Premature EOF reading header."))
-    (if (string-null? line)
-	#f
-	(let loop ((lines (list (string-trim-right line))))
-	  (cond ((char-wsp? (peek-char port))
-		 (loop (cons (string-trim (read-line port)) lines)))
-		((null? (cdr lines))
-		 (car lines))
-		(else
-		 (decorated-string-append "" " " "" (reverse! lines))))))))
-
 (define parse-header
   (let ((parser
 	 (*parser
@@ -996,17 +982,23 @@ USA.
 
 (define-header "Transfer-Encoding"
   (tokenized-parser
-   (list-parser
-    (encapsulate cons
-      (seq lp:token
-	   lp:parameter*))))
+   (lp:comma-list 1
+     (list-parser
+      (encapsulate cons
+	(seq lp:token
+	     lp:parameter*)))))
   (lambda (value)
-    (pair-of-type? value
-		   http-token?
-		   http-parameters?))
+    (list-of-type? value
+      (lambda (elt)
+	(pair-of-type? elt
+		       http-token?
+		       http-parameters?))))
   (lambda (value port)
-    (write-http-token (car value) port)
-    (write-parameter* (cdr value) port)))
+    (write-comma-list (lambda (elt port)
+			(write-http-token (car elt) port)
+			(write-parameter* (cdr elt) port))
+		      value
+		      port)))
 
 (define-header "Upgrade"
   (tokenized-parser (lp:comma-list 1 lp:product))
@@ -1550,6 +1542,29 @@ USA.
   http-date?
   write-http-date)
 
+;;;; Chunked encoding
+
+(define (parse-http-chunk-leader string)
+  (lp:chunk-leader (string->tokens string)
+		   (lambda (tokens vals lose)
+		     (if (null? tokens)
+			 (structure-parser-values-ref vals 0)
+			 (lose)))
+		   (lambda ()
+		     #f)))
+
+(define lp:chunk-leader
+  (list-parser
+   (encapsulate cons
+     (seq (transform (lambda (s)
+		       (let ((n (string->number s 16 #f)))
+			 (and n
+			      (list n))))
+	    lp:token-string)
+	  (encapsulate list
+	    (* lp:semicolon
+	       lp:parameter%))))))
+
 ;;;; Utilities
 
 (define initialize-package!
diff --git a/v7/src/runtime/httpio.scm b/v7/src/runtime/httpio.scm
index eb7952c75..78a6bcfb3 100644
--- a/v7/src/runtime/httpio.scm
+++ b/v7/src/runtime/httpio.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: httpio.scm,v 14.9 2008/09/17 06:31:50 cph Exp $
+$Id: httpio.scm,v 14.10 2008/09/21 07:35:06 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -212,9 +212,13 @@ USA.
 	(receive (method uri version)
 	    (parse-line parse-request-line line "HTTP request line")
 	  (let ((headers (read-http-headers port)))
-	    (make-http-request method uri version headers
-			       (or (%read-delimited-body headers port)
-				   (%no-read-body))))))))
+	    (let ((b.t
+		   (or (%read-chunked-body headers port)
+		       (%read-delimited-body headers port)
+		       (%no-read-body))))
+	      (make-http-request method uri version
+				 (append! headers (cdr b.t))
+				 (car b.t))))))))
 
 (define (read-http-response request port)
   (%text-mode port)
@@ -224,42 +228,67 @@ USA.
 	(receive (version status reason)
 	    (parse-line parse-response-line line "HTTP response line")
 	  (let ((headers (read-http-headers port)))
-	    (make-http-response version status reason headers
-				(if (or (non-body-status? status)
-					(string=? (http-request-method request)
-						  "HEAD"))
-				    #f
-				    (or (%read-delimited-body headers port)
-					(%read-terminal-body headers port)
-					(%no-read-body)))))))))
+	    (let ((b.t
+		   (if (or (non-body-status? status)
+			   (string=? (http-request-method request) "HEAD"))
+		       (list #f)
+		       (or (%read-chunked-body headers port)
+			   (%read-delimited-body headers port)
+			   (%read-terminal-body headers port)
+			   (%no-read-body)))))
+	      (make-http-response version status reason
+				  (append! headers (cdr b.t))
+				  (car b.t))))))))
+
+(define (%read-chunked-body headers port)
+  (let ((h (http-header 'TRANSFER-ENCODING headers #f)))
+    (and h
+	 (let ((v (http-header-parsed-value h)))
+	   (and (not (default-object? v))
+		(assq 'CHUNKED v)))
+	 (let ((output (open-output-octets))
+	       (buffer (make-vector-8b #x1000)))
+	   (let loop ()
+	     (let ((n (%read-chunk-leader port)))
+	       (if (> n 0)
+		   (begin
+		     (%read-chunk n buffer port output)
+		     (%text-mode port)
+		     (let ((line (read-line port)))
+		       (if (not (string-null? line))
+			   (error "Missing CRLF after chunk data.")))
+		     (loop)))))
+	   (cons (get-output-string! output)
+		 (read-http-headers port))))))
+
+(define (%read-chunk-leader port)
+  (%text-mode port)
+  (let ((line (read-line port)))
+    (if (eof-object? line)
+	(error "Premature EOF in HTTP message body."))
+    (let ((v (parse-http-chunk-leader line)))
+      (if (not v)
+	  (error "Ill-formed chunk in HTTP message body."))
+      (car v))))
 
-(define (%read-all port)
+(define (%read-chunk n buffer port output)
   (%binary-mode port)
-  (call-with-output-octets
-   (lambda (output)
-     (let ((buffer (make-vector-8b #x1000)))
-       (let loop ()
-	 (let ((n (read-string! buffer port)))
-	   (if (> n 0)
-	       (begin
-		 (write-substring buffer 0 n output)
-		 (loop)))))))))
+  (let ((len (vector-8b-length buffer)))
+    (let loop ((n n))
+      (if (> n 0)
+	  (let ((m (read-substring! buffer 0 (min n len) port)))
+	    (if (= m 0)
+		(error "Premature EOF in HTTP message body."))
+	    (write-substring buffer 0 m output)
+	    (loop (- n m)))))))
 
 (define (%read-delimited-body headers port)
   (let ((n (%get-content-length headers)))
     (and n
-	 (begin
-	   (%binary-mode port)
-	   (call-with-output-octets
-	    (lambda (output)
-	      (let ((buffer (make-vector-8b #x1000)))
-		(let loop ((n n))
-		  (if (> n 0)
-		      (let ((m (read-string! buffer port)))
-			(if (= m 0)
-			    (error "Premature EOF in HTTP message body."))
-			(write-substring buffer 0 m output)
-			(loop (- n m))))))))))))
+	 (list
+	  (call-with-output-octets
+	   (lambda (output)
+	     (%read-chunk n (make-vector-8b #x1000) port output)))))))
 
 (define (%read-terminal-body headers port)
   (and (let ((h (http-header 'CONNECTION headers #f)))
@@ -267,7 +296,19 @@ USA.
 	      (let ((v (http-header-parsed-value h)))
 		(and (not (default-object? v))
 		     (memq 'CLOSE v)))))
-       (%read-all port)))
+       (list (%read-all port))))
+
+(define (%read-all port)
+  (%binary-mode port)
+  (call-with-output-octets
+   (lambda (output)
+     (let ((buffer (make-vector-8b #x1000)))
+       (let loop ()
+	 (let ((n (read-string! buffer port)))
+	   (if (> n 0)
+	       (begin
+		 (write-substring buffer 0 n output)
+		 (loop)))))))))
 
 (define (%no-read-body)
   (error "Unable to determine HTTP message body length."))
diff --git a/v7/src/runtime/rfc2822-headers.scm b/v7/src/runtime/rfc2822-headers.scm
index 2d53a48bd..b55d4d5da 100644
--- a/v7/src/runtime/rfc2822-headers.scm
+++ b/v7/src/runtime/rfc2822-headers.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rfc2822-headers.scm,v 14.2 2008/09/15 07:07:51 cph Exp $
+$Id: rfc2822-headers.scm,v 14.3 2008/09/21 07:35:13 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -139,58 +139,65 @@ USA.
 
 (define (read-rfc2822-headers port)
   (let loop ((headers '()))
-    (let ((line (read-line port)))
-      (if (eof-object? line)
-	  (parse-error port "Premature EOF reading header fields."))
-      (let ((end (string-length line)))
-	(cond ((fix:= end 0)
-	       (map (lambda (p)
-		      (make-rfc2822-header (car p) (cdr p)))
-		    (reverse! headers)))
-	      ((char-wsp? (string-ref line 0))
-	       (if (not (pair? headers))
-		   (parse-error port
-				"Unmatched header continuation in request:"
-				line))
-	       (let ((h (car headers)))
-		 (set-cdr! h
-			   (string-append (cdr h)
-					  " "
-					  (trim-wsp line 0 end))))
-	       (loop headers))
-	      (else
-	       (loop
-		(cons (let ((colon (string-find-next-char line #\:)))
-			(if (not colon)
-			    (parse-error port
-					 "Missing colon in header field:"
-					 line))
-			(let ((name (intern (string-head line colon))))
-			  (guarantee-header-name name)
-			  (cons name
-				(trim-wsp line (fix:+ colon 1) end))))
-		      headers))))))))
-
-(define (trim-wsp string start end)
-  (let* ((start*
-	  (let loop ((i start))
-	    (if (and (fix:< i end)
-		     (char-wsp? (string-ref string i)))
-		(loop (fix:+ i 1))
-		i)))
-	 (end*
-	  (let loop ((i end))
-	    (if (and (fix:> i start*)
-		     (char-wsp? (string-ref string (fix:- i 1))))
-		(loop (fix:- i 1))
-		i))))
-    (let ((string
-	   (if (and (fix:= start* 0)
-		    (fix:= end* (string-length string)))
-	       string
-	       (substring string start* end*))))
-      (guarantee-header-value string)
-      string)))
+    (let ((header (read-rfc2822-header port)))
+      (if header
+	  (loop (cons header headers))
+	  (reverse! headers)))))
+
+(define (read-rfc2822-header port)
+  (let ((line (read-rfc2822-folded-line port)))
+    (and line
+	 (let ((colon (string-find-next-char line #\:)))
+	   (if (not colon)
+	       (parse-error port "Missing colon in header field:" line))
+	   (make-rfc2822-header (intern (string-head line colon))
+				(let ((end (string-length line)))
+				  (substring line
+					     (skip-wsp-left line
+							    (fix:+ colon 1)
+							    end)
+					     end)))))))
+
+(define (read-rfc2822-folded-line port)
+  (let ((line (read-line port)))
+    (cond ((string-null? line)
+	   #f)
+	  ((char-wsp? (string-ref line 0))
+	   (parse-error port
+			"Unmatched continuation line:"
+			'READ-RFC2822-FOLDED-LINE))
+	  (else
+	   (call-with-output-string
+	     (lambda (out)
+	       (let loop ((line line))
+		 (let ((end (skip-wsp-right line 0 (string-length line))))
+		   (write-substring line
+				    (skip-wsp-left line 0 end)
+				    end
+				    out))
+		 (if (let ((char (peek-char port)))
+		       (if (eof-object? char)
+			   (parse-error port
+					"Premature EOF:"
+					'READ-RFC2822-FOLDED-LINE))
+		       (char-wsp? char))
+		     (begin
+		       (write-char #\space out)
+		       (loop (read-line port)))))))))))
+
+(define (skip-wsp-left string start end)
+  (let loop ((i start))
+    (if (and (fix:< i end)
+	     (char-wsp? (string-ref string i)))
+	(loop (fix:+ i 1))
+	i)))
+
+(define (skip-wsp-right string start end)
+  (let loop ((i end))
+    (if (and (fix:> i start)
+	     (char-wsp? (string-ref string (fix:- i 1))))
+	(loop (fix:- i 1))
+	i)))
 
 ;;;; Quotation
 
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 43fba2f4c..bec4f4d51 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.683 2008/09/17 06:31:54 cph Exp $
+$Id: runtime.pkg,v 14.684 2008/09/21 07:35:15 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -5181,6 +5181,7 @@ USA.
 	  make-rfc2822-header
 	  parser:rfc2822-quoted-string
 	  quote-rfc2822-text
+	  read-rfc2822-folded-line
 	  read-rfc2822-headers
 	  rfc2822-header-name
 	  rfc2822-header-value
@@ -5230,6 +5231,7 @@ USA.
 	  http-version?
 	  make-http-header
 	  make-http-version
+	  parse-http-chunk-leader
 	  parse-http-status
 	  parse-http-token
 	  parse-http-version