From a3d8993e72c4e39503ad4b5bfef31d55269940b8 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 3 Jul 2008 20:08:15 +0000 Subject: [PATCH] Eliminate problem where RMAIL and IMAIL are both trying to insert internal headers at the beginning of the message, and then assuming their own headers are first. IMAIL now strips out all of its internal headers when a message is read, regardless of their position, and appends new ones to the end of the headers block when the message is written. --- v7/src/imail/imail-core.scm | 62 ++++++++++++++++++++---------------- v7/src/imail/imail-file.scm | 30 ++++++----------- v7/src/imail/imail-rmail.scm | 60 +++++++++++++++------------------- v7/src/imail/imail-umail.scm | 26 +++++++-------- 4 files changed, 81 insertions(+), 97 deletions(-) diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 89b4dba90..bb679ad09 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.170 2008/05/19 00:00:12 riastradh Exp $ +$Id: imail-core.scm,v 1.171 2008/07/03 20:08:07 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -940,33 +940,17 @@ USA. '("answered" "deleted" "filed" "forwarded" "resent" "seen")) (define (message-flags->header-field flags) - (make-header-field message-flags:name - (decorated-string-append "" " " "" flags))) - -(define (header-field->message-flags header) - (and (string-ci=? message-flags:name (header-field-name header)) - ;; Extra pair needed to distinguish #F from (). - (cons #f - (burst-string (header-field-value header) - char-set:whitespace - #t)))) - -(define message-flags:name "X-IMAIL-FLAGS") - -(define (parse-imail-header-fields headers) - (let loop ((headers headers) (headers* '()) (flags '())) - (cond ((not (pair? headers)) - (values (reverse! headers*) - (remove-duplicates! (reverse! flags) string-ci=?))) - ((header-field->message-flags (car headers)) - => (lambda (flags*) - (loop (cdr headers) - headers* - (append! (reverse! (cdr flags*)) flags)))) - (else - (loop (cdr headers) - (cons (car headers) headers*) - flags))))) + (make-internal-header-field "FLAGS" + (decorated-string-append "" " " "" flags))) + +(define (header-fields->message-flags headers) + (delete-duplicates! (map (lambda (header) + (burst-string (header-field-value header) + char-set:whitespace + #t)) + (filter (internal-header-field-predicate "FLAGS") + headers)) + string-ci=?)) (define (message-deleted? msg) (message-flagged? msg "deleted")) (define (message-undeleted? msg) (not (message-flagged? msg "deleted"))) @@ -1189,6 +1173,28 @@ USA. (let ((colon (string-find-next-char line #\:))) (and colon (rfc822:header-field-name? line 0 colon)))) + +(define (internal-header-field? header) + (string-prefix-ci? internal-header-field-prefix (header-field-name header))) + +(define (make-internal-header-field name value) + (make-header-field (string-append internal-header-field-prefix name) + value)) + +(define (internal-header-field-name header) + (string-tail (header-field-name header) + internal-header-field-prefix-length)) + +(define (internal-header-field-predicate name) + (lambda (header) + (and (internal-header-field? header) + (string-ci=? (internal-header-field-name header) name)))) + +(define internal-header-field-prefix + "X-IMAIL-") + +(define internal-header-field-prefix-length + (string-length internal-header-field-prefix)) ;;;; MIME structure diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm index d11f5b773..d021ca3f4 100644 --- a/v7/src/imail/imail-file.scm +++ b/v7/src/imail/imail-file.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: imail-file.scm,v 1.94 2008/02/09 10:29:03 riastradh Exp $ +$Id: imail-file.scm,v 1.95 2008/07/03 20:08:09 cph Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -530,7 +530,8 @@ USA. (define-file-external-message-method message-header-fields 'HEADER-FIELDS - string->header-fields) + (lambda (s) + (remove! internal-header-field? (string->header-fields s)))) (define-generic file-message-body (message)) @@ -599,22 +600,9 @@ USA. (file-time->universal-time t))) (get-universal-time))) -(define (file-folder-strip-internal-headers folder ref) - (call-with-input-xstring (file-folder-xstring folder) - (file-external-ref/start ref) - (lambda (port) - (let loop ((header-lines '())) - (let ((line (read-line port)) - (finish - (lambda (offset) - (values (make-file-external-ref - (- (xstring-port/position port) - offset) - (file-external-ref/end ref)) - (lines->header-fields (reverse! header-lines)))))) - (cond ((eof-object? line) - (finish 0)) - ((re-string-match "X-IMAIL-[^:]+:\\|[ \t]" line) - (loop (cons line header-lines))) - (else - (finish (+ (string-length line) 1))))))))) \ No newline at end of file +(define (file-folder-internal-headers folder ref) + (filter! internal-header-field? + (string->header-fields + (xsubstring (file-folder-xstring folder) + (file-external-ref/start ref) + (file-external-ref/end ref))))) \ No newline at end of file diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index 56c9eabab..c4ce22587 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.77 2008/01/30 20:02:09 cph Exp $ +$Id: imail-rmail.scm,v 1.78 2008/07/03 20:08: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, @@ -143,25 +143,20 @@ USA. (error "Malformed RMAIL file:" port))))) (define (read-rmail-message-1 folder port) - (call-with-values (lambda () (read-rmail-attributes-line port)) - (lambda (formatted? flags) - (let* ((headers (read-rmail-alternate-headers port)) - (displayed-headers (read-rmail-displayed-headers port)) - (body (read-rmail-body port)) - (finish - (lambda (headers displayed-headers) - (call-with-values - (lambda () - (parse-rmail-internal-time-header folder headers)) - (lambda (headers time) - (make-rmail-message headers - body - flags - displayed-headers - time)))))) - (if formatted? - (finish headers displayed-headers) - (finish displayed-headers 'UNDEFINED)))))) + (receive (formatted? flags) (read-rmail-attributes-line port) + (let* ((headers (read-rmail-alternate-headers port)) + (displayed-headers (read-rmail-displayed-headers port)) + (body (read-rmail-body port)) + (finish + (lambda (headers displayed-headers) + (make-rmail-message headers + body + flags + displayed-headers + (rmail-internal-time folder headers))))) + (if formatted? + (finish headers displayed-headers) + (finish displayed-headers 'UNDEFINED))))) (define (read-rmail-attributes-line port) (let ((line (read-required-line port))) @@ -229,17 +224,12 @@ USA. (input-port/discard-char port) (make-file-external-ref start (- (xstring-port/position port) 1)))) -(define (parse-rmail-internal-time-header folder headers) - (call-with-values - (lambda () (file-folder-strip-internal-headers folder headers)) - (lambda (headers internal-headers) - (values headers - (let ((v - (get-first-header-field internal-headers - "X-IMAIL-INTERNAL-TIME" - #f))) - (and v - (parse-header-field-date v))))))) +(define (rmail-internal-time folder ref) + (let ((v + (find (internal-header-field-predicate "INTERNAL-TIME") + (file-folder-internal-headers folder ref)))) + (and v + (parse-header-field-date v)))) ;;;; Write RMAIL file @@ -270,9 +260,11 @@ USA. (let ((headers (message-header-fields message)) (time (message-internal-time message))) (if time - (cons (make-header-field "X-IMAIL-INTERNAL-TIME" - (universal-time->string time)) - headers) + (append headers + (list + (make-internal-header-field + "INTERNAL-TIME" + (universal-time->string time)))) headers))) (displayed-headers (rmail-message-displayed-header-fields message))) (let ((formatted? (not (eq? 'UNDEFINED displayed-headers)))) diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm index 79683ffaf..6c6f7ff00 100644 --- a/v7/src/imail/imail-umail.scm +++ b/v7/src/imail/imail-umail.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: imail-umail.scm,v 1.57 2008/01/30 20:02:10 cph Exp $ +$Id: imail-umail.scm,v 1.58 2008/07/03 20:08: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, @@ -133,15 +133,11 @@ USA. (loop))))))))) (define (read-umail-message-1 folder from-line headers body) - (call-with-values - (lambda () (file-folder-strip-internal-headers folder headers)) - (lambda (headers internal-headers) - (call-with-values - (lambda () - (parse-imail-header-fields internal-headers)) - (lambda (internal-headers flags) - internal-headers - (make-umail-message headers body flags from-line)))))) + (make-umail-message headers + body + (header-fields->message-flags + (file-folder-internal-headers folder headers)) + from-line)) (define (umail-delimiter? line) (re-string-match unix-mail-delimiter line)) @@ -164,10 +160,12 @@ USA. (define (write-umail-message message output-flags? port) (write-string (umail-message-from-line message) port) (newline port) - (if output-flags? - (write-header-field (message-flags->header-field (message-flags message)) - port)) - (write-header-fields (message-header-fields message) port) + (write-header-fields (if output-flags? + (append (message-header-fields message) + (list (message-flags->header-field + (message-flags message)))) + (message-header-fields message)) + port) (for-each (lambda (line) (if (string-prefix-ci? "From " line) (write-string ">" port)) -- 2.25.1