From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 29 Jun 2000 22:02:34 +0000 (+0000)
Subject: Revise representation of header-field objects, so that RFC-822 quoting
X-Git-Tag: 20090517-FFI~3424
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=224dc02f914fdcee52da5dc8bf94a491134729e0;p=mit-scheme.git

Revise representation of header-field objects, so that RFC-822 quoting
mechanism isn't part of the representation.  Value string of a header
is now arbitrary text, and there is an explicit mechanism for
converting the header value to RFC-822 format, by prepending tabs onto
continuation lines.

Additionally, there should no longer be any possibility of a low-level
error being generating when parsing header fields of incoming messages.
---

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 30f28ff70..d38cbd2b4 100644
--- a/v7/src/imail/imail-core.scm
+++ b/v7/src/imail/imail-core.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-core.scm,v 1.110 2000/06/24 01:37:54 cph Exp $
+;;; $Id: imail-core.scm,v 1.111 2000/06/29 22:01:48 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -660,31 +660,16 @@
   (let ((constructor (record-constructor header-field-rtd)))
     (lambda (name value)
       (guarantee-header-field-name name 'MAKE-HEADER-FIELD)
-      (guarantee-header-field-value value 'MAKE-HEADER-FIELD)
       (constructor name value))))
 
 (define (guarantee-header-field-name object procedure)
   (if (not (header-field-name? object))
       (error:wrong-type-argument object "header-field name" procedure)))
 
-(define (guarantee-header-field-value object procedure)
-  (if (not (header-field-value? object))
-      (error:wrong-type-argument object "header-field value" procedure)))
-
 (define (header-field-name? object)
   (and (string? object)
        (rfc822:header-field-name? object 0 (string-length object))))
 
-(define (header-field-value? object)
-  (and (string? object)
-       (let ((end (string-length object)))
-	 (let loop ((index 0))
-	   (let ((nl (substring-find-next-char object index end #\newline)))
-	     (or (not nl)
-		 (and (fix:< (fix:+ nl 1) end)
-		      (char-lwsp? (string-ref object (fix:+ nl 1)))
-		      (loop (fix:+ nl 2)))))))))
-
 (define (copy-header-field header)
   (record-copy header))
 
@@ -693,11 +678,62 @@
 	((message? object) (message-header-fields object))
 	((string? object) (string->header-fields object))
 	(else (error:wrong-type-argument object "header fields" #f))))
+
+(define (encode-header-fields headers receiver)
+  (for-each (lambda (header) (encode-header-field header receiver)) headers)
+  (receiver "\n" 0 1))
+
+(define (encode-header-field header receiver)
+  (let ((name (header-field-name header)))
+    (receiver name 0 (string-length name)))
+  (receiver ": " 0 2)
+  (encode-header-field-value (header-field-value header) receiver)
+  (receiver "\n" 0 1))
+
+(define (encode-header-field-value value receiver)
+  (let ((end (string-length value)))
+    (let loop ((start 0))
+      (let ((index (substring-find-next-char value start end #\newline)))
+	(if index
+	    (let ((index (fix:+ index 1)))
+	      (receiver value start index)
+	      (receiver "\t" 0 1)
+	      (loop index))
+	    (receiver value start end))))))
 
 (define (header-field-length header)
-  (+ (string-length (header-field-name header))
-     (string-length (header-field-value header))
-     2))
+  (let ((value (header-field-value header)))
+    (+ (string-length (header-field-name header))
+       (string-length value)
+       (string-n-newlines value)
+       3)))
+
+(define (write-header-fields headers port)
+  (encode-header-fields headers
+    (lambda (string start end)
+      (write-substring string start end port))))
+
+(define (write-header-field header port)
+  (encode-header-field header
+    (lambda (string start end)
+      (write-substring string start end port))))
+
+(define (header-fields->string headers)
+  (with-string-output-port
+    (lambda (port)
+      (write-header-fields headers port))))
+
+(define (header-field->string header)
+  (with-string-output-port
+    (lambda (port)
+      (write-header-field header port))))
+
+(define (header-field-value->string value)
+  (with-string-output-port
+    (lambda (port)
+      (encode-header-field-value value
+	(lambda (string start end)
+	  (write-substring string start end port))))))
 
 (define (get-first-header-field headers name error?)
   (let loop ((headers (->header-fields headers)))
@@ -727,66 +763,54 @@
 (define (get-first-header-field-value headers name error?)
   (let ((header (get-first-header-field headers name error?)))
     (and header
-	 (string-trim (header-field-value header)))))
+	 (header-field-value header))))
 
 (define (get-last-header-field-value headers name error?)
   (let ((header (get-last-header-field headers name error?)))
     (and header
-	 (string-trim (header-field-value header)))))
+	 (header-field-value header))))
 
 (define (get-all-header-field-values headers name)
-  (map (lambda (header)
-	 (string-trim (header-field-value header)))
-       (get-all-header-fields headers name)))
+  (map header-field-value (get-all-header-fields headers name)))
 
-(define (header-field->lines header)
-  (let ((lines (string->lines (header-field-value header))))
-    (cons (string-append (header-field-name header) ":" (car lines))
-	  (cdr lines))))
-
-(define (lines->header-field lines)
-  (let ((colon
-	 (and (pair? lines)
-	      (string-find-next-char (car lines) #\:))))
-    (if (not colon)
-	(error "Malformed header-field lines:" lines))
-    (make-header-field (string-head (car lines) colon)
-		       (apply string-append
-			      (string-tail (car lines) (fix:+ colon 1))
-			      (map (lambda (line)
-				     (string-append "\n" line))
-				   (cdr lines))))))
-
-(define (header-fields->lines headers)
-  (append-map! header-field->lines headers))
+(define (string->header-fields string)
+  (lines->header-fields (string->lines string)))
 
 (define (lines->header-fields lines)
-  (let loop ((lines lines) (headers '()))
-    (if (and (pair? lines)
-	     (not (string-null? (car lines))))
-	(let collect-group ((lines (cdr lines)) (group (list (car lines))))
-	  (if (or (not (pair? lines))
-		  (string-null? (car lines))
-		  (header-field-initial-line? (car lines)))
-	      (loop lines
-		    (cons (lines->header-field (reverse! group)) headers))
-	      (collect-group (cdr lines) (cons (car lines) group))))
-	(reverse! headers))))
+  (let find-initial ((lines lines) (headers '()))
+    (cond ((or (not (pair? lines))
+	       (string-null? (car lines)))
+	   (reverse! headers))
+	  ((header-field-initial-line? (car lines))
+	   (let collect-group ((lines (cdr lines)) (group (list (car lines))))
+	     (if (or (not (pair? lines))
+		     (string-null? (car lines))
+		     (header-field-initial-line? (car lines)))
+		 (find-initial
+		  lines
+		  (cons
+		   (let ((lines (reverse! group)))
+		     (let ((colon
+			    (and (pair? lines)
+				 (string-find-next-char (car lines) #\:))))
+		       (if (not colon)
+			   (error "Malformed header-field lines:" lines))
+		       (make-header-field
+			(string-head (car lines) colon)
+			(decorated-string-append
+			 "" "\n" ""
+			 (map string-trim
+			      (cons (string-tail (car lines) (fix:+ colon 1))
+				    (cdr lines)))))))
+		   headers))
+		 (collect-group (cdr lines) (cons (car lines) group)))))
+	  (else
+	   (find-initial (cdr lines) headers)))))
 
 (define (header-field-initial-line? line)
   (let ((colon (string-find-next-char line #\:)))
     (and colon
 	 (rfc822:header-field-name? line 0 colon))))
-
-(define (header-field-continuation-line? line)
-  (and (not (string-null? line))
-       (char-lwsp? (string-ref line 0))))
-
-(define (string->header-fields string)
-  (lines->header-fields (string->lines string)))
-
-(define (header-fields->string headers)
-  (lines->string (header-fields->lines headers)))
 
 ;;;; MIME structure
 
diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index 7920a9c57..15dc4bb90 100644
--- a/v7/src/imail/imail-rmail.scm
+++ b/v7/src/imail/imail-rmail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-rmail.scm,v 1.44 2000/06/23 19:29:05 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.45 2000/06/29 22:01:50 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -70,15 +70,14 @@
   (make-rmail-folder-header-fields (folder-flags folder)))
 
 (define (make-rmail-folder-header-fields flags)
-  (list (make-header-field "Version" " 5")
+  (list (make-header-field "Version" "5")
 	(make-header-field "Labels"
 			   (decorated-string-append
 			    "" "," ""
 			    (flags->rmail-labels flags)))
-	(make-header-field "Note" "   This is the header of an rmail file.")
-	(make-header-field "Note" "   If you are seeing it in rmail,")
-	(make-header-field "Note"
-			   "    it means the file has no messages in it.")))
+	(make-header-field "Note" "This is the header of an rmail file.")
+	(make-header-field "Note" "If you are seeing it in rmail,")
+	(make-header-field "Note" "it means the file has no messages in it.")))
 
 ;;;; Message
 
@@ -242,9 +241,7 @@
 	       (time (message-internal-time message)))
 	   (if time
 	       (cons (make-header-field "X-IMAIL-INTERNAL-TIME"
-					(string-append
-					 " "
-					 (universal-time->string time)))
+					(universal-time->string time))
 		     headers)
 	       headers)))
 	(displayed-headers (rmail-message-displayed-header-fields message)))
diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index e1d7bddf7..09bc99030 100644
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-top.scm,v 1.201 2000/06/29 17:54:49 cph Exp $
+;;; $Id: imail-top.scm,v 1.202 2000/06/29 22:01:51 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -1218,10 +1218,7 @@ ADDRESSES is a string consisting of several addresses separated by commas."
 
 (define (header-field->mail-header header)
   (list (header-field-name header)
-	(let ((v (header-field-value header)))
-	  (if (string-prefix? " " v)
-	      (string-tail v 1)
-	      v))))
+	(header-field-value->string (header-field-value header))))
 
 (define (with-buffer-point-preserved buffer thunk)
   (let ((point (mark-right-inserting-copy (buffer-point buffer))))
@@ -1993,20 +1990,16 @@ Negative argument means search in reverse."
 	       (write-message-body message port)))))))
 
 (define (insert-header-fields headers raw? mark)
-  (for-each (lambda (header)
-	      (insert-string (header-field-name header) mark)
-	      (insert-char #\: mark)
-	      (insert-string (header-field-value header) mark)
-	      (insert-newline mark))
-	    (let ((headers (->header-fields headers)))
-	      (if raw?
-		  headers
-		  (maybe-reformat-headers
-		   headers
-		   (or (and (message? headers)
-			    (imail-message->buffer headers #f))
-		       mark)))))
-  (insert-newline mark))
+  (encode-header-fields (let ((headers (->header-fields headers)))
+			  (if raw?
+			      headers
+			      (maybe-reformat-headers
+			       headers
+			       (or (and (message? headers)
+					(imail-message->buffer headers #f))
+				   mark))))
+			(lambda (string start end)
+			  (insert-substring string start end mark))))
 
 (define (maybe-reformat-headers headers buffer)
   (let ((headers
diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm
index 40dd3ed4d..f88d35b46 100644
--- a/v7/src/imail/imail-util.scm
+++ b/v7/src/imail/imail-util.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-util.scm,v 1.28 2000/06/19 02:01:54 cph Exp $
+;;; $Id: imail-util.scm,v 1.29 2000/06/29 22:01:52 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -174,22 +174,6 @@
   (decorated-string-append "" ""
 			   (if (default-object? line-ending) "\n" line-ending)
 			   lines))
-
-(define (write-header-fields headers port)
-  (for-each (lambda (header)
-	      (write-header-field header port))
-	    headers))
-
-(define (write-header-field header port)
-  (%write-header-field (header-field-name header)
-		       (header-field-value header)
-		       port))
-
-(define (%write-header-field name value port)
-  (write-string name port)
-  (write-char #\: port)
-  (write-string value port)
-  (newline port))
 
 (define (read-lines port)
   (source->list (lambda () (read-line port))))
@@ -272,6 +256,16 @@
 	    (if (< index* index)
 		(loop (cdr strings) string* index*)
 		(loop (cdr strings) string index)))))))
+
+(define (string-n-newlines string)
+  (substring-n-newlines string 0 (string-length string)))
+
+(define (substring-n-newlines string start end)
+  (let loop ((start start) (n 0))
+    (let ((index (substring-find-next-char string start end #\newline)))
+      (if index
+	  (loop (fix:+ index 1) (fix:+ n 1))
+	  n))))
 
 ;;;; Broken-pipe handler
 
diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index 26d39cf93..5469563dd 100644
--- a/v7/src/imail/todo.txt
+++ b/v7/src/imail/todo.txt
@@ -1,12 +1,9 @@
 IMAIL To-Do List
-$Id: todo.txt,v 1.101 2000/06/29 17:51:01 cph Exp $
+$Id: todo.txt,v 1.102 2000/06/29 22:02:34 cph Exp $
 
 Bug fixes
 ---------
 
-* Must be able to handle malformed headers in incoming mail.
-  Generating a low-level error in this situation is unacceptable.
-
 * RMAIL file reader must recognize when the tail of the file contains
   umail messages.
 
@@ -72,20 +69,6 @@ Design changes
   Use this same mechanism to read MIME attachments directly into
   files.
 
-* Header parser should strip leading and trailing whitespace in the
-  header value.  It can also strip whitespace at the ends of lines.
-  Strictly speaking, this isn't correct, but I don't know of any
-  situation in which it would cause problems.
-
-  More generally, the internal representation of a header field should
-  permit arbitrary value strings.  The conversion to RFC 822 form
-  should be done during I/O rather than being a required feature of
-  the representation.  This is safe to do for many headers, which are
-  defined to have arbitrary whitespace.
-
-  Parsing errors must be detected during input; erroneous headers can
-  probably be discarded, depending on the error.
-
 * Move pathname-completion code into the runtime system.
 
 * Repackage the code so that each file now in the core is in a