From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 15 Sep 2008 05:15:23 +0000 (+0000)
Subject: Split "http-io.scm" to create new file "http-syntax.scm".  I'm
X-Git-Tag: 20090517-FFI~152
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e9d9ff5025ea042dde94ba0687b4fc9170a60abc;p=mit-scheme.git

Split "http-io.scm" to create new file "http-syntax.scm".  I'm
currently working on the latter, so this minimizes the difference
between the trunk and my code.
---

diff --git a/v7/src/runtime/ed-ffi.scm b/v7/src/runtime/ed-ffi.scm
index 74ef16774..b16e68889 100644
--- a/v7/src/runtime/ed-ffi.scm
+++ b/v7/src/runtime/ed-ffi.scm
@@ -1,6 +1,6 @@
 #| -*- Scheme -*-
 
-$Id: ed-ffi.scm,v 1.44 2008/09/07 04:33:12 cph Exp $
+$Id: ed-ffi.scm,v 1.45 2008/09/15 05:15:05 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -83,6 +83,7 @@ USA.
     ("histry"	(runtime history))
     ("html-form-codec" (runtime html-form-codec))
     ("http-client" (runtime http-client))
+    ("http-syntax" (runtime http-syntax))
     ("httpio"	(runtime http-i/o))
     ("illdef"	(runtime illegal-definitions))
     ("infstr"	(runtime compiler-info))
diff --git a/v7/src/runtime/http-client.scm b/v7/src/runtime/http-client.scm
index 7518ec8a8..a7c9bf3ef 100644
--- a/v7/src/runtime/http-client.scm
+++ b/v7/src/runtime/http-client.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: http-client.scm,v 14.6 2008/08/26 04:21:54 cph Exp $
+$Id: http-client.scm,v 14.7 2008/09/15 05:15:08 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -53,45 +53,24 @@ USA.
 					(uri-query uri)
 					(uri-fragment uri))
 			      http-version:1.0
-			      (cons (make-rfc2822-header
-				     'host
-				     (host-string authority))
-				    (if (first-rfc2822-header 'user-agent
-							      headers)
-					headers
-					(cons (make-rfc2822-header
-					       'user-agent
-					       default-user-agent)
-					      headers)))
+			      (add-default-headers headers authority)
 			      body)))
       (write-http-request request port)
       (let ((response (read-http-response request port)))
 	(close-port port)
 	response))))
 
+(define (add-default-headers headers authority)
+  (let ((headers (convert-http-headers headers)))
+    (cons (make-http-header 'HOST (host-string authority))
+	  (if (http-header 'USER-AGENT headers #f)
+	      headers
+	      (cons (make-http-header 'USER-AGENT default-http-user-agent)
+		    headers)))))
+
 (define (host-string authority)
   (let ((host (uri-authority-host authority))
 	(port (uri-authority-port authority)))
     (if port
 	(string-append host ":" (number->string port))
-	host)))
-
-(define default-user-agent)
-
-(define (initialize-package!)
-  (set! default-user-agent
-	(call-with-output-string
-	  (lambda (output)
-	    (write-string "MIT-GNU-Scheme/" output)
-	    (let ((input
-		   (open-input-string
-		    (get-subsystem-version-string "release"))))
-	      (let loop ()
-		(let ((char (read-char input)))
-		  (if (not (eof-object? char))
-		      (begin
-			(if (char-set-member? char-set:http-token char)
-			    (write-char char output)
-			    (write-char #\_ output))
-			(loop)))))))))
-  unspecific)
\ No newline at end of file
+	host)))
\ No newline at end of file
diff --git a/v7/src/runtime/http-syntax.scm b/v7/src/runtime/http-syntax.scm
new file mode 100644
index 000000000..5f87264ea
--- /dev/null
+++ b/v7/src/runtime/http-syntax.scm
@@ -0,0 +1,252 @@
+#| -*-Scheme-*-
+
+$Id: http-syntax.scm,v 1.1 2008/09/15 05:15:12 cph Exp $
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; HTTP syntax
+;;; package: (runtime http-syntax)
+
+(declare (usual-integrations))
+
+;;;; Version
+
+(define (http-version? object)
+  (and (pair? object)
+       (exact-nonnegative-integer? (car object))
+       (exact-nonnegative-integer? (cdr object))))
+
+(define-guarantee http-version "HTTP version")
+
+(define (make-http-version major minor) (cons major minor))
+(define (http-version-major v) (car v))
+(define (http-version-minor v) (cdr v))
+
+(define (http-version=? v1 v2)
+  (and (= (car v1) (car v2))
+       (= (cdr v1) (cdr v2))))
+
+(define (http-version<? v1 v2)
+  (or (< (car v1) (car v2))
+      (and (= (car v1) (car v2))
+	   (< (cdr v1) (cdr v2)))))
+
+(define parse-http-version
+  (*parser
+   (encapsulate* make-http-version
+     (seq "HTTP/"
+	  (map string->number
+	       (match (+ (char-set char-set:numeric))))
+	  "."
+	  (map string->number
+	       (match (+ (char-set char-set:numeric))))))))
+
+(define (write-http-version version port)
+  (write-string "HTTP/" port)
+  (write (car version) port)
+  (write-string "." port)
+  (write (cdr version) port))
+
+;;;; Status
+
+(define (http-status? object)
+  (and (exact-nonnegative-integer? object)
+       (< object 1000)))
+
+(define-guarantee http-status "HTTP status code")
+
+(define (http-status-major status)
+  (modulo status 100))
+
+(define parse-http-status
+  (*parser
+   (map string->number
+	(match (seq (char-set char-set:numeric)
+		    (char-set char-set:numeric)
+		    (char-set char-set:numeric))))))
+
+(define (write-http-status object port)
+  (write-string (string-pad-left (number->string object) 3 #\0) port))
+
+;;;; Header
+
+(define-record-type <http-header>
+    (%make-http-header name value)
+    http-header?
+  (name http-header-name)
+  (value http-header-value))
+
+(define-guarantee http-header "HTTP header field")
+
+(define (make-http-header name value)
+  (guarantee-http-token name 'MAKE-HTTP-HEADER)
+  (guarantee-http-text value 'MAKE-HTTP-HEADER)
+  (%make-http-header name value))
+
+(define (convert-http-headers headers #!optional caller)
+  (guarantee-list headers caller)
+  (map (lambda (header)
+	 (cond ((http-header? header)
+		header)
+	       ((and (pair? header)
+		     (http-token? (car header))
+		     (string? (cdr header)))
+		(make-http-header (car header) (cdr header)))
+	       ((and (pair? header)
+		     (http-token? (car header))
+		     (pair? (cdr header))
+		     (string? (cadr header))
+		     (null? (cddr header)))
+		(make-http-header (car header) (cadr header)))
+	       (else
+		(error:not-http-header header caller))))
+       headers))
+
+(define (guarantee-http-headers object #!optional caller)
+  (guarantee-list-of-type object http-header? "HTTP headers" caller))
+
+(define (http-header name headers error?)
+  (let ((h
+	 (find (lambda (header)
+		 (eq? (http-header-name header) name))
+	       headers)))
+    (if (and (not h) error?)
+	(error:bad-range-argument name 'HTTP-HEADER))
+    h))
+
+(define (read-http-headers port)
+  (map (lambda (h)
+	 (make-http-header (rfc2822-header-name h)
+			   (rfc2822-header-value h)))
+       (read-rfc2822-headers port)))
+
+(define (write-http-headers headers port)
+  (guarantee-http-headers headers 'WRITE-HTTP-HEADERS)
+  (write-rfc2822-headers (map (lambda (h)
+				(make-rfc2822-header (http-header-name h)
+						     (http-header-value h)))
+			      headers)
+			 port))
+
+;;;; Token
+
+(define (http-token? object)
+  (and (interned-symbol? object)
+       (string-is-http-token? (symbol-name object))))
+
+(define-guarantee http-token "HTTP token")
+
+(define (write-http-token token port)
+  (write-string (symbol-name token) port))
+
+(define (string-is-http-token? string)
+  (*match-string match-http-token string))
+
+(define parse-http-token
+  (*parser (map intern (match match-http-token))))
+
+(define match-http-token
+  (*matcher (+ (char-set char-set:http-token))))
+
+;;;; Text
+
+(define (http-text? object)
+  (string? object))
+
+(define-guarantee http-text "HTTP text")
+
+(define (write-text string port)
+  (if (string-is-http-token? string)
+      (write-string string port)
+      (write-quoted-string string port)))
+
+(define (write-quoted-string string port)
+  (write-char #\" port)
+  (%write-with-quotations string char-set:http-qdtext port)
+  (write-char #\" port))
+
+(define (write-comment string port)
+  (write-char #\( port)
+  (%write-with-quotations string char-set:http-ctext port)
+  (write-char #\) port))
+
+(define (%write-with-quotations string unquoted port)
+  (let ((n (string-length string)))
+    (do ((i 0 (fix:+ i 1)))
+	((not (fix:< i n)))
+      (let ((char (string-ref string i)))
+	(if (not (char-set-member? unquoted char))
+	    (write-char #\\ port))
+	(write-char char port)))))
+
+
+(define http-version:1.0)
+(define http-version:1.1)
+
+(define char-set:http-separators)
+(define char-set:http-token)
+(define char-set:http-text)
+(define char-set:http-ctext)
+(define char-set:http-qdtext)
+(define char-set:alpha)
+(define default-http-user-agent)
+
+(define (initialize-package!)
+  (set! http-version:1.0 (make-http-version 1 0))
+  (set! http-version:1.1 (make-http-version 1 1))
+  (set! char-set:http-separators
+	(string->char-set "()<>@,;:\\\"/[]?={} \t"))
+  (set! char-set:http-token
+	(char-set-difference char-set:ascii
+			     (char-set-union char-set:ctls
+					     char-set:http-separators)))
+  (set! char-set:http-text
+	(char-set-invert char-set:ctls))
+  (set! char-set:http-ctext
+	(char-set-difference char-set:http-text
+			     (char-set #\( #\))))
+  (set! char-set:http-qdtext
+	(char-set-difference char-set:http-text
+			     (char-set #\")))
+  (set! char-set:alpha
+	(char-set-union (ascii-range->char-set #x41 #x5B)
+			(ascii-range->char-set #x61 #x7B)))
+  (set! default-http-user-agent
+	(call-with-output-string
+	  (lambda (output)
+	    (write-string "MIT-GNU-Scheme/" output)
+	    (let ((input
+		   (open-input-string
+		    (get-subsystem-version-string "release"))))
+	      (let loop ()
+		(let ((char (read-char input)))
+		  (if (not (eof-object? char))
+		      (begin
+			(write-char (if (char-set-member? char-set:http-token
+							  char)
+					char
+					#\_)
+				    output)
+			(loop)))))))))
+  unspecific)
\ No newline at end of file
diff --git a/v7/src/runtime/httpio.scm b/v7/src/runtime/httpio.scm
index 33842692a..00bfe7401 100644
--- a/v7/src/runtime/httpio.scm
+++ b/v7/src/runtime/httpio.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: httpio.scm,v 14.6 2008/08/27 04:58:09 cph Exp $
+$Id: httpio.scm,v 14.7 2008/09/15 05:15:17 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -72,41 +72,22 @@ USA.
     (%make-http-response version status reason headers body)))
 
 (define (guarantee-headers&body headers body caller)
-  (let ((headers (convert-http-headers headers caller)))
-    (if body
-	(begin
-	  (guarantee-string body caller)
-	  (let ((n (%get-content-length headers))
-		(m (vector-8b-length body)))
-	    (if n
-		(begin
-		  (if (not (= n m))
-		      (error:bad-range-argument body caller))
-		  (values headers body))
-		(values (cons (make-rfc2822-header 'CONTENT-LENGTH
-						   (number->string m))
-			      headers)
-			body))))
-	(values headers ""))))
-
-(define (convert-http-headers headers caller)
-  (guarantee-list headers caller)
-  (map (lambda (header)
-	 (cond ((http-header? header)
-		header)
-	       ((and (pair? header)
-		     (http-token? (car header))
-		     (http-text? (cdr header)))
-		(make-rfc2822-header (car header) (cdr header)))
-	       ((and (pair? header)
-		     (http-token? (car header))
-		     (pair? (cdr header))
-		     (http-text? (cadr header))
-		     (null? (cddr header)))
-		(make-rfc2822-header (car header) (cadr header)))
-	       (else
-		(error:not-http-header header caller))))
-       headers))
+  (guarantee-http-headers headers caller)
+  (if body
+      (begin
+	(guarantee-string body caller)
+	(let ((n (%get-content-length headers))
+	      (m (vector-8b-length body)))
+	  (if n
+	      (begin
+		(if (not (= n m))
+		    (error:bad-range-argument body caller))
+		(values headers body))
+	      (values (cons (make-http-header 'CONTENT-LENGTH
+					      (number->string m))
+			    headers)
+		      body))))
+      (values headers "")))
 
 (define (simple-http-request? object)
   (and (http-request? object)
@@ -144,13 +125,6 @@ USA.
 	((http-response? message) (http-response-body message))
 	(else (error:not-http-message message 'HTTP-MESSAGE-BODY))))
 
-(define (http-token? object)
-  (and (interned-symbol? object)
-       (not (eq? object '||))
-       (string-in-char-set? (symbol-name object) char-set:http-token)))
-
-(define-guarantee http-token "HTTP token")
-
 (define (http-request-uri? object)
   (or (simple-http-request-uri? object)
       (absolute-uri? object)
@@ -168,63 +142,10 @@ USA.
 
 (define-guarantee simple-http-request-uri "simple HTTP URI")
 
-(define (http-version? object)
-  (and (pair? object)
-       (exact-nonnegative-integer? (car object))
-       (exact-nonnegative-integer? (cdr object))))
-
-(define-guarantee http-version "HTTP version")
-
-(define (make-http-version major minor)
-  (guarantee-exact-nonnegative-integer major 'MAKE-HTTP-VERSION)
-  (guarantee-exact-nonnegative-integer minor 'MAKE-HTTP-VERSION)
-  (cons major minor))
-
-(define (http-version-major v)
-  (guarantee-http-version v 'HTTP-VERSION-MAJOR)
-  (car v))
-
-(define (http-version-minor v)
-  (guarantee-http-version v 'HTTP-VERSION-MINOR)
-  (cdr v))
-
-(define (http-version=? v1 v2)
-  (guarantee-http-version v1 'HTTP-VERSION=?)
-  (guarantee-http-version v2 'HTTP-VERSION=?)
-  (and (= (car v1) (car v2))
-       (= (cdr v1) (cdr v2))))
-
-(define (http-version<? v1 v2)
-  (guarantee-http-version v1 'HTTP-VERSION<?)
-  (guarantee-http-version v2 'HTTP-VERSION<?)
-  (if (< (car v1) (car v2))
-      #t
-      (and (= (car v1) (car v2))
-	   (< (cdr v1) (cdr v2)))))
-
-(define (http-status? object)
-  (and (exact-nonnegative-integer? object)
-       (< object 1000)))
-
-(define-guarantee http-status "HTTP status code")
-
-(define (http-header? object)
-  (and (rfc2822-header? object)
-       (http-token? (rfc2822-header-name object))
-       (http-text? (rfc2822-header-value object))))
-
-(define-guarantee http-header "HTTP header field")
-
-(define (http-text? object)
-  (and (string? object)
-       (string-in-char-set? object char-set:http-text)))
-
-(define-guarantee http-text "HTTP text")
-
 ;;;; Output
 
 (define (%text-mode port)
-  (port/set-coding port 'US-ASCII)
+  (port/set-coding port 'ISO-8859-1)
   (port/set-line-ending port 'CRLF))
 
 (define (%binary-mode port)
@@ -233,15 +154,15 @@ USA.
 
 (define (write-http-request request port)
   (%text-mode port)
-  (write-token (http-request-method request) port)
+  (write-http-token (http-request-method request) port)
   (write-string " " port)
   (write-uri (http-request-uri request) port)
   (if (http-request-version request)
       (begin
 	(write-string " " port)
-	(write-version (http-request-version request) port)
+	(write-http-version (http-request-version request) port)
 	(newline port)
-	(write-rfc2822-headers (http-request-headers request) port)
+	(write-http-headers (http-request-headers request) port)
 	(%binary-mode port)
 	(write-string (http-request-body request) port))
       (begin
@@ -252,25 +173,16 @@ USA.
   (if (http-response-version response)
       (begin
 	(%text-mode port)
-	(write-version (http-response-version response) port)
+	(write-http-version (http-response-version response) port)
 	(write-string " " port)
 	(write (http-response-status response) port)
 	(write-string " " port)
 	(write-string (http-response-reason response) port)
 	(newline port)
-	(write-rfc2822-headers (http-response-headers response) port)))
+	(write-http-headers (http-response-headers response) port)))
   (%binary-mode port)
   (write-string (http-response-body response) port)
   (flush-output port))
-
-(define (write-token token port)
-  (write-string (string-upcase (symbol->string token)) port))
-
-(define (write-version version port)
-  (write-string "HTTP/" port)
-  (write (car version) port)
-  (write-string "." port)
-  (write (cdr version) port))
 
 ;;;; Input
 
@@ -292,7 +204,7 @@ USA.
 	line
 	(receive (method uri version)
 	    (parse-line parse-request-line line "HTTP request line")
-	  (let ((headers (read-rfc2822-headers port)))
+	  (let ((headers (read-http-headers port)))
 	    (make-http-request method uri version headers
 			       (or (%read-delimited-body headers port)
 				   (%no-read-body))))))))
@@ -304,7 +216,7 @@ USA.
 	#f
 	(receive (version status reason)
 	    (parse-line parse-response-line line "HTTP response line")
-	  (let ((headers (read-rfc2822-headers port)))
+	  (let ((headers (read-http-headers port)))
 	    (make-http-response version status reason headers
 				(if (or (non-body-status? status)
 					(eq? (http-request-method request)
@@ -314,65 +226,6 @@ USA.
 					(%read-terminal-body headers port)
 					(%no-read-body)))))))))
 
-(define (parse-line parser line description)
-  (let ((v (*parse-string parser line)))
-    (if (not v)
-	(error (string-append "Malformed " description ":") line))
-    (if (fix:= (vector-length v) 1)
-	(vector-ref v 0)
-	(apply values (vector->list v)))))
-
-(define parse-simple-request
-  (*parser
-   (seq "GET"
-	(noise match-wsp)
-	parse-uri-path-absolute)))
-
-(define parse-request-line
-  (*parser
-   (seq (map string->symbol
-	     parse-http-token)
-	(noise match-wsp)
-	(alt (match "*")
-	     parse-absolute-uri
-	     parse-uri-path-absolute
-	     parse-uri-authority)
-	(noise match-wsp)
-	parse-version)))
-
-(define parse-http-token
-  (*parser (match (+ (char-set char-set:http-token)))))
-
-(define parse-response-line
-  (*parser
-   (seq parse-version
-	(noise match-wsp)
-	parse-status-code
-	(noise match-wsp)
-	(match (* (char-set char-set:http-text))))))
-
-(define parse-version
-  (*parser
-   (encapsulate (lambda (v)
-		  (make-http-version (vector-ref v 0)
-				     (vector-ref v 1)))
-     (seq "HTTP/"
-	  (map string->number
-	       (match (+ (char-set char-set:numeric))))
-	  "."
-	  (map string->number
-	       (match (+ (char-set char-set:numeric))))))))
-
-(define parse-status-code
-  (*parser
-   (map string->number
-	(match (seq (char-set char-set:numeric)
-		    (char-set char-set:numeric)
-		    (char-set char-set:numeric))))))
-
-(define match-wsp
-  (*matcher (+ (char-set char-set:wsp))))
-
 (define (%read-all port)
   (%binary-mode port)
   (call-with-output-octets
@@ -401,50 +254,52 @@ USA.
 			(write-substring buffer 0 m output)
 			(loop (- n m))))))))))))
 
-(define (%get-content-length headers)
-  (let ((h (first-rfc2822-header 'CONTENT-LENGTH headers)))
-    (and h
-	 (let ((s (rfc2822-header-value h)))
-	   (let ((n (string->number s)))
-	     (if (not (exact-nonnegative-integer? n))
-		 (error "Malformed content-length value:" s))
-	     n)))))
-
 (define (%read-terminal-body headers port)
-  (and (let ((h (first-rfc2822-header 'CONNECTION headers)))
+  (and (let ((h (http-header 'CONNECTION headers #f)))
 	 (and h
 	      (any (lambda (token)
 		     (string-ci=? token "close"))
-		   (burst-string (rfc2822-header-value h) char-set:wsp #t))))
+		   (burst-string (http-header-value h) char-set:wsp #t))))
        (%read-all port)))
 
 (define (%no-read-body)
   (error "Unable to determine HTTP message body length."))
 
-;;;; Syntax
-
-(define (string-in-char-set? string char-set)
-  (let ((end (string-length string)))
-    (let loop ((i 0))
-      (if (fix:< i end)
-	  (and (char-set-member? char-set (string-ref string i))
-	       (loop (fix:+ i 1)))
-	  #t))))
-
-(define char-set:http-text)
-(define char-set:http-token)
-(define http-version:1.0)
-(define http-version:1.1)
-
-(define (initialize-package!)
-  (set! char-set:http-text
-	(char-set-difference char-set:ascii char-set:ctls))
-  (set! char-set:http-token
-	(char-set-difference char-set:http-text
-			     (string->char-set "()<>@,;:\\\"/[]?={} \t")))
-  (set! http-version:1.0 (make-http-version 1 0))
-  (set! http-version:1.1 (make-http-version 1 1))
-  unspecific)
+;;;; Request and response lines
+
+(define parse-request-line
+  (*parser
+   (seq (map string->symbol
+	     (match (+ (char-set char-set:http-token))))
+	" "
+	(alt (match "*")
+	     parse-absolute-uri
+	     parse-uri-path-absolute
+	     parse-uri-authority)
+	" "
+	parse-http-version)))
+
+(define parse-response-line
+  (*parser
+   (seq parse-http-version
+	" "
+	parse-http-status
+	" "
+	(match (* (char-set char-set:http-text))))))
+
+(define parse-simple-request
+  (*parser
+   (seq (map string->symbol (match "GET"))
+	" "
+	parse-uri-path-absolute)))
+
+(define (parse-line parser line description)
+  (let ((v (*parse-string parser line)))
+    (if (not v)
+	(error (string-append "Malformed " description ":") line))
+    (if (fix:= (vector-length v) 1)
+	(vector-ref v 0)
+	(apply values (vector->list v)))))
 
 ;;;; Status descriptions
 
@@ -509,7 +364,7 @@ USA.
 
 (define (http-message-body-port message)
   (let ((port (open-input-octets (http-message-body message))))
-    (receive (type coding) (http-content-type message)
+    (receive (type coding) (%get-content-type message)
       (cond ((eq? (mime-type/top-level type) 'TEXT)
 	     (port/set-coding port (or coding 'TEXT))
 	     (port/set-line-ending port 'TEXT))
@@ -527,8 +382,8 @@ USA.
 	     (port/set-line-ending port 'BINARY))))
     port))
 
-(define (http-content-type message)
-  (let ((h (first-http-header 'CONTENT-TYPE message)))
+(define (%get-content-type message)
+  (let ((h (http-message-header 'CONTENT-TYPE message #f)))
     (if h
 	(let ((s (rfc2822-header-value h)))
 	  (let ((v (*parse-string parser:http-content-type s)))
@@ -543,28 +398,29 @@ USA.
 	(values (make-mime-type 'APPLICATION 'OCTET-STREAM)
 		#f))))
 
+(define (%get-content-length headers)
+  (let ((h (http-header 'CONTENT-LENGTH headers #f)))
+    (and h
+	 (let ((s (http-header-value h)))
+	   (let ((n (string->number s)))
+	     (if (not (exact-nonnegative-integer? n))
+		 (error "Malformed content-length value:" s))
+	     n)))))
+
 (define parser:http-content-type
   (let ((parse-parameter
 	 (*parser
-	  (encapsulate (lambda (v)
-			 (cons (vector-ref v 0)
-			       (vector-ref v 1)))
-		       (seq ";"
-			    (noise (* (char-set char-set:wsp)))
-			    parser:mime-token
-			    "="
-			    (alt (match matcher:mime-token)
-				 parser:rfc2822-quoted-string))))))
+	  (encapsulate* cons
+	    (seq ";"
+		 (noise (* (char-set char-set:wsp)))
+		 parser:mime-token
+		 "="
+		 (alt (match matcher:mime-token)
+		      parser:rfc2822-quoted-string))))))
     (*parser
      (seq parser:mime-type
 	  (encapsulate vector->list
 		       (* parse-parameter))))))
 
-(define (http-content-length message)
-  (%get-content-length (http-message-headers message)))
-
-(define (first-http-header name message)
-  (first-rfc2822-header name (http-message-headers message)))
-
-(define (all-http-headers name message)
-  (all-rfc2822-headers name (http-message-headers message)))
\ No newline at end of file
+(define (http-message-header name message error?)
+  (http-header name (http-message-headers message) error?))
\ No newline at end of file
diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index 6005b006e..6868d92bb 100644
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.118 2008/08/31 07:28:05 cph Exp $
+$Id: make.scm,v 14.119 2008/09/15 05:15:20 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -518,7 +518,7 @@ USA.
    ((RUNTIME CONTINUATION-PARSER) INITIALIZE-SPECIAL-FRAMES! #f)
    (RUNTIME URI)
    (RUNTIME RFC2822-HEADERS)
-   (RUNTIME HTTP-I/O)
+   (RUNTIME HTTP-SYNTAX)
    (RUNTIME HTTP-CLIENT)
    (RUNTIME HTML-FORM-CODEC)
    (RUNTIME WIN32-REGISTRY)))
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 28e472d52..9a2f8ae77 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.678 2008/09/09 16:28:19 cph Exp $
+$Id: runtime.pkg,v 14.679 2008/09/15 05:15:23 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -5183,45 +5183,75 @@ USA.
 	  write-rfc2822-headers)
   (initialization (initialize-package!)))
 
-(define-package (runtime http-i/o)
-  (files "httpio")
+(define-package (runtime http-syntax)
+  (files "http-syntax")
   (parent (runtime))
   (export ()
-	  all-http-headers
+	  <http-header>
 	  char-set:http-text
 	  char-set:http-token
-	  error:not-http-message
+	  convert-http-headers
+	  default-http-user-agent
 	  error:not-http-header
-	  error:not-http-request
-	  error:not-http-request-uri
-	  error:not-http-response
 	  error:not-http-status
 	  error:not-http-text
 	  error:not-http-token
 	  error:not-http-version
+	  guarantee-http-header
+	  guarantee-http-headers
+	  guarantee-http-status
+	  guarantee-http-text
+	  guarantee-http-token
+	  guarantee-http-version
+	  http-header
+	  http-header-name
+	  http-header-value
+	  http-header?
+	  http-status?
+	  http-text?
+	  http-token?
+	  http-version-major
+	  http-version-minor
+	  http-version:1.0
+	  http-version:1.1
+	  http-version<?
+	  http-version=?
+	  http-version?
+	  make-http-header
+	  make-http-version
+	  parse-http-status
+	  parse-http-token
+	  parse-http-version
+	  read-http-headers
+	  write-http-status
+	  write-http-token
+	  write-http-version
+	  write-http-headers)
+  (initialization (initialize-package!)))
+
+(define-package (runtime http-i/o)
+  (files "httpio")
+  (parent (runtime))
+  (export ()
+	  error:not-http-message
+	  error:not-http-request
+	  error:not-http-request-uri
+	  error:not-http-response
 	  error:not-simple-http-request
 	  error:not-simple-http-request-uri
 	  error:not-simple-http-response
-	  first-http-header
 	  guarantee-http-message
-	  guarantee-http-header
 	  guarantee-http-request
 	  guarantee-http-request-uri
 	  guarantee-http-response
-	  guarantee-http-status
-	  guarantee-http-text
-	  guarantee-http-token
-	  guarantee-http-version
 	  guarantee-simple-http-request
 	  guarantee-simple-http-request-uri
 	  guarantee-simple-http-response
-	  http-content-length
-	  http-content-type
 	  http-message-body
 	  http-message-body-port
+	  http-message-header
 	  http-message-headers
 	  http-message?
-	  http-header?
 	  http-request-body
 	  http-request-headers
 	  http-request-method
@@ -5235,23 +5265,10 @@ USA.
 	  http-response-version
 	  http-response?
 	  http-status-description
-	  http-status?
-	  http-text?
-	  http-token?
-	  http-request-uri?
-	  http-version-major
-	  http-version-minor
-	  http-version:1.0
-	  http-version:1.1
-	  http-version<?
-	  http-version=?
-	  http-version?
 	  make-http-request
 	  make-http-response
-	  make-http-version
 	  make-simple-http-request
 	  make-simple-http-response
-	  parser:http-content-type
 	  read-http-request
 	  read-http-response
 	  read-simple-http-request