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 30f28ff709b569db1b1549eef85e4584bbd829b0..d38cbd2b438b9faee24994d5f4e451d10eda634d 100644 (file)
--- 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))))
+\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))))))
 \f
 (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)))
 \f
-(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)))
 \f
 ;;;; MIME structure
 

diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index 7920a9c57399ff174d928d827b39b8644b9e5a67..15dc4bb90d217932e45862051a0abd256dfcf2ab 100644 (file)
--- 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 e1d7bddf756cdd38d7de9a8ceab988d8f1fefb49..09bc99030eb2b38abcb1da8f0696020eb84a01f8 100644 (file)
--- 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 40dd3ed4d1052ca93b8a4a0556151b3657f5ecad..f88d35b46876eedac0589f61a69b21e4f62f60cd 100644 (file)
--- 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))
 \f
 (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))))
 \f
 ;;;; Broken-pipe handler
 

diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index 26d39cf9343c5f20c4fe75b75d334486b2b52bf4..5469563ddf2008f55ada57e74b7a11591e1d2d50 100644 (file)
--- 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