From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 21 Sep 2008 23:20:00 +0000 (+0000)
Subject: Generate error when MAKE-HTTP-HEADER called with incorrect parsed
X-Git-Tag: 20090517-FFI~131
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b63175c23b54fa910c72f1b682492925bcd2469c;p=mit-scheme.git

Generate error when MAKE-HTTP-HEADER called with incorrect parsed
value.  Fix various small thinkos in header parsing.
---

diff --git a/v7/src/runtime/http-syntax.scm b/v7/src/runtime/http-syntax.scm
index 933f2213d..35a37f1a6 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.4 2008/09/21 22:20:14 cph Exp $
+$Id: http-syntax.scm,v 1.5 2008/09/21 23:20:00 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -121,7 +121,7 @@ USA.
 	    (begin
 	      (guarantee-http-text value 'MAKE-HTTP-HEADER)
 	      (%make-header name value
-			    (%call-parser (hvdefn-parser defn) value))))
+			    (%call-parser (hvdefn-parser defn) value #t))))
 	(begin
 	  (guarantee-http-text value 'MAKE-HTTP-HEADER)
 	  (%make-header name value (%unparsed-value))))))
@@ -247,15 +247,17 @@ USA.
 			value
 			(let ((defn (header-value-defn name)))
 			  (if defn
-			      (%call-parser (hvdefn-parser defn) value)
+			      (%call-parser (hvdefn-parser defn) value #f)
 			      (%unparsed-value)))))))))
 
-(define (%call-parser parser value)
+(define (%call-parser parser value error?)
   (parser value
 	  (lambda (parsed-value)
 	    parsed-value)
 	  (lambda ()
-	    (warn "Ill-formed HTTP header value:" value)
+	    (if error?
+		(error "Ill-formed HTTP header value:" value)
+		(warn "Ill-formed HTTP header value:" value))
 	    (%unparsed-value))))
 
 (define (%unparsed-value)
@@ -303,9 +305,6 @@ USA.
 (define lp:token
   (list-parser (map intern lp:token-string)))
 
-(define lp:token-cs
-  (list-parser (map string->symbol lp:token-string)))
-
 (define lp:token-string
   (list-parser (map token-token->string (match-if token-token?))))
 
@@ -316,9 +315,6 @@ USA.
   (and (pair? object)
        (token*? object)))
 
-(define lp:token-cs*
-  (lp:comma-list 0 lp:token-cs))
-
 (define (token*? object)
   (list-of-type? object http-token?))
 
@@ -1037,16 +1033,19 @@ USA.
 		     (or (hostport? received-by)
 			 (http-token? received-by)))))
   (lambda (value port)
-    (let ((received-protocol (car value)))
-      (if (car received-protocol)
-	  (begin
-	    (write-http-token (car received-protocol) port)
-	    (write-char #\/ port)))
-      (write-http-token (cdr received-protocol) port))
-    (let ((received-by (cdr value)))
-      (if (hostport? received-by)
-	  (write-hostport received-by port)
-	  (write-http-token received-by port)))))
+    (write-comma-list (lambda (elt port)
+			(let ((received-protocol (car elt)))
+			  (if (car received-protocol)
+			      (begin
+				(write-http-token (car received-protocol) port)
+				(write-char #\/ port)))
+			  (write-http-token (cdr received-protocol) port))
+			(let ((received-by (cdr elt)))
+			  (if (hostport? received-by)
+			      (write-hostport received-by port)
+			      (write-http-token received-by port))))
+		      value
+		      port)))
 
 (define-header "Warning"
   (tokenized-parser
@@ -1081,21 +1080,25 @@ USA.
 			(or (not dt)
 			    (decoded-time? dt)))))
   (lambda (value port)
-    (receive (code agent text date) (vector->values value)
-      (write-string (string-pad-left (number->string code) 3 #\0) port)
-      (write-char #\space port)
-      (if (hostport? agent)
-	  (write-hostport agent port)
-	  (write-http-token agent port))
-      (write-char #\space port)
-      (write-quoted-string text port)
-      (if date
-	  (begin
-	    (write-char #\space port)
-	    (write-quoted-string (call-with-output-string
-				   (lambda (port)
-				     (write-http-date date port)))
-				 port))))))
+    (write-comma-list
+     (lambda (elt port)
+       (receive (code agent text date) (vector->values value)
+	 (write-string (string-pad-left (number->string code) 3 #\0) port)
+	 (write-char #\space port)
+	 (if (hostport? agent)
+	     (write-hostport agent port)
+	     (write-http-token agent port))
+	 (write-char #\space port)
+	 (write-quoted-string text port)
+	 (if date
+	     (begin
+	       (write-char #\space port)
+	       (write-quoted-string (call-with-output-string
+				      (lambda (port)
+					(write-http-date date port)))
+				    port)))))
+     value
+     port)))
 
 ;;;; Request headers
 
@@ -1346,8 +1349,11 @@ USA.
 		   http-token?
 		   accept-params?))
   (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 "User-Agent"
   (tokenized-parser lp:product/comment-list)
@@ -1362,8 +1368,7 @@ USA.
     (alt (encapsulate (lambda (none) none '())
 	   (qualify (token= 'NONE) lp:token))
 	 lp:token+)))
-  (lambda (value)
-    (list+-of-type? value http-token?))
+  token*?
   (lambda (value port)
     (if (null? value)
 	(write-http-token 'NONE port)
@@ -1432,7 +1437,11 @@ USA.
 ;;;; Entity headers
 
 (define-header "Allow"
-  (tokenized-parser lp:token-cs*)
+  (tokenized-parser
+   (lp:comma-list 0
+     (list-parser
+      (map string->symbol
+	   lp:token-string))))
   token*?
   write-token*)