From a14caf532dad030b94d4246d90af96901c876ba4 Mon Sep 17 00:00:00 2001 From: "Taylor R. Campbell" Date: Sat, 10 Dec 2005 06:45:32 +0000 Subject: [PATCH] Initial checkin of new general MIME parser for IMAIL. All folders by default now support MIME. Still missing: - message media type - RFC2047 =?x?y?z= header field parsing - Content-Language parsing - coherent error handling - efficiency of performance --- v7/src/imail/compile.scm | 5 +- v7/src/imail/ed-ffi.scm | 7 +- v7/src/imail/imail-core.scm | 242 ++++++++++++++++- v7/src/imail/imail-file.scm | 10 +- v7/src/imail/imail-mime.scm | 521 ++++++++++++++++++++++++++++++++++++ v7/src/imail/imail-top.scm | 17 +- v7/src/imail/imail-util.scm | 17 +- v7/src/imail/imail.pkg | 19 +- 8 files changed, 803 insertions(+), 35 deletions(-) create mode 100644 v7/src/imail/imail-mime.scm diff --git a/v7/src/imail/compile.scm b/v7/src/imail/compile.scm index 3f5bc5a44..4a004fd17 100644 --- a/v7/src/imail/compile.scm +++ b/v7/src/imail/compile.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: compile.scm,v 1.21 2005/01/11 03:13:23 cph Exp $ +$Id: compile.scm,v 1.22 2005/12/10 06:45:32 riastradh Exp $ Copyright 2000,2001,2003,2005 Massachusetts Institute of Technology @@ -18,7 +18,7 @@ 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, +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02111-1301, USA. |# @@ -36,6 +36,7 @@ USA. "imail-core" "imail-file" "imail-imap" + "imail-mime" "imail-rmail" "imail-summary" "imail-top" diff --git a/v7/src/imail/ed-ffi.scm b/v7/src/imail/ed-ffi.scm index 0caad6805..671a42e6f 100644 --- a/v7/src/imail/ed-ffi.scm +++ b/v7/src/imail/ed-ffi.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: ed-ffi.scm,v 1.22 2003/02/14 18:28:14 cph Exp $ +$Id: ed-ffi.scm,v 1.23 2005/12/10 06:45:32 riastradh Exp $ -Copyright 2000,2001,2003 Massachusetts Institute of Technology +Copyright 2000,2001,2003,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -18,7 +18,7 @@ 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, +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02111-1301, USA. |# @@ -30,6 +30,7 @@ USA. ("imail-core" (edwin imail)) ("imail-file" (edwin imail file-folder)) ("imail-imap" (edwin imail imap-folder)) + ("imail-mime" (edwin imail mime)) ("imail-rmail" (edwin imail file-folder rmail-folder)) ("imail-summary" (edwin imail front-end summary)) ("imail-top" (edwin imail front-end)) diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 35d24e71e..bec3e345b 100644 --- a/v7/src/imail/imail-core.scm +++ b/v7/src/imail/imail-core.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: imail-core.scm,v 1.151 2003/03/08 02:40:14 cph Exp $ +$Id: imail-core.scm,v 1.152 2005/12/10 06:45:32 riastradh Exp $ -Copyright 1999,2000,2001,2003 Massachusetts Institute of Technology +Copyright 1999,2000,2001,2003,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -18,7 +18,7 @@ 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, +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02111-1301, USA. |# @@ -616,6 +616,13 @@ USA. (define-generic message-internal-time (message)) (define-generic message-length (message)) +(define-generic message-body (message)) +(define-method message-body ((message )) + (let ((string (call-with-output-string + (lambda (output-port) + (write-message-body message output-port))))) + (values string 0 (string-length string)))) + (define (message-index message) (let ((index (%message-index message)) (folder (message-folder message))) @@ -1006,6 +1013,28 @@ USA. (define (get-all-header-field-values headers name) (map header-field-value (get-all-header-fields headers name))) + +(define (parse-first-named-header headers name default parser) + (cond ((get-first-header-field-value headers name #f) + => (header-parser parser name default)) + (else default))) + +(define (parse-last-named-header headers name default parser) + (cond ((get-last-header-field-value headers name #f) + => (header-parser parser name default)) + (else default))) + +(define (parse-all-named-headers headers name default parser) + (map (header-parser parser name default) + (get-all-header-field-values headers name))) + +(define-integrable (header-parser parser name default) + (lambda (value) + (or (parser value) + (begin + (warn (string-append "Malformed " name " field value:") + value) + default)))) (define (string->header-fields string) (lines->header-fields (string->lines string))) @@ -1154,4 +1183,209 @@ USA. (name define accessor) (source-route define accessor) (mailbox define accessor) - (host define accessor)) \ No newline at end of file + (host define accessor)) + +;;;; MIME Encoding Registry + +;;; This should probably be moved to the runtime's MIME codec package. + +(define mime-encodings '()) + +(define-structure (mime-encoding + (conc-name mime-encoding/) + (print-procedure + (standard-unparser-method 'MIME-ENCODING + (lambda (encoding output-port) + (write-char #\space output-port) + (write (mime-encoding/name encoding) + output-port)))) + (constructor %make-mime-encoding)) + (name #f read-only #t) + (identity? #f read-only #t) + (encoder-initializer #f read-only #t) + (encoder-finalizer #f read-only #t) + (encoder-updater #f read-only #t) + (decoder-initializer #f read-only #t) + (decoder-finalizer #f read-only #t) + (decoder-updater #f read-only #t) + (decoding-port-maker #f read-only #t) + (caller-with-decoding-port #f read-only #t)) + +(define (make-mime-identity-encoding name) + (%make-mime-encoding + name #t + + identity-mime-encoding:initialize + output-port/flush-output + output-port/write-string + + identity-mime-encoding:initialize + output-port/flush-output + output-port/write-string + + identity-mime-encoding:initialize + (lambda (port text? generator) + text? + (generator port)))) + +(define (identity-mime-encoding:initialize port text?) + text? + (guarantee-output-port port 'IDENTITY-MIME-ENCODING:INITIALIZE) + port) + +(define (make-mime-encoding name + encode:initialize encode:finalize encode:update + decode:initialize decode:finalize decode:update + make-port call-with-port) + (%make-mime-encoding + name #f + encode:initialize encode:finalize encode:update + decode:initialize decode:finalize decode:update + make-port call-with-port)) + +(define (define-mime-encoding name + encode:initialize encode:finalize encode:update + decode:initialize decode:finalize decode:update + make-port call-with-port) + (let ((encoding + (make-mime-encoding name + encode:initialize encode:finalize encode:update + decode:initialize decode:finalize decode:update + make-port call-with-port))) + (cond ((find-tail (lambda (encoding) + (eq? (mime-encoding/name encoding) + name)) + mime-encodings) + => (lambda (tail) + (warn "Replacing MIME encoding:" (car tail)) + (set-car! tail encoding))) + (else + (set! mime-encodings (cons encoding mime-encodings)))))) + +(define (define-identity-mime-encoding name) + (let ((encoding (make-mime-identity-encoding name))) + (cond ((find-tail (lambda (encoding) + (eq? (mime-encoding/name encoding) + name)) + mime-encodings) + => (lambda (tail) + (cond ((not (mime-encoding/identity? (car tail))) + (warn "Replacing MIME encoding with identity:" + (car tail)) + (set-car! tail encoding))))) + (else + (set! mime-encodings (cons encoding mime-encodings)))))) + +(define (find-tail predicate list) + (let loop ((l list)) + (cond ((pair? l) + (if (predicate (car l)) + (car l) + (loop (cdr l)))) + ((null? l) + #f) + (else + (error:wrong-type-argument list "proper list" + 'FIND-TAIL))))) + +(define (named-mime-encoding name #!optional error?) + (or (find-matching-item mime-encodings + (lambda (encoding) + (eq? (mime-encoding/name encoding) + name))) + (and error? (error "No such named MIME encoding known:" name)))) + +(define (mime-encoder encoding) + (select-mime-encoding encoding + (lambda () + (values identity-mime-encoding:initialize + output-port/write-substring + flush-output)) + (lambda (encoding) + (let ((initializer (mime-encoding/encoder-initializer encoding)) + (finalizer (mime-encoding/encoder-finalizer encoding)) + (updater (mime-encoding/encoder-updater encoding))) + (if (and initializer finalizer updater) + (values initializer finalizer updater) + (error "MIME encoding encoder unimplemented:" + encoding)))))) + +(define (mime-decoder encoding) + (select-mime-encoding encoding + (lambda () + (values identity-mime-encoding:initialize + output-port/write-substring + flush-output)) + (lambda (encoding) + (let ((initializer (mime-encoding/decoder-initializer encoding)) + (finalizer (mime-encoding/decoder-finalizer encoding)) + (updater (mime-encoding/decoder-updater encoding))) + (if (and initializer finalizer updater) + (values initializer finalizer updater) + (error "MIME encoding decoder unimplemented:" + encoding)))))) + +(define (make-mime-decoding-output-port encoding port text?) + (select-mime-encoding* encoding mime-encoding/decoding-port-maker + (lambda () port) + (lambda (make-decoding-port) + (make-decoding-port port text?)))) + +(define (call-with-mime-decoding-output-port encoding port text? + generator) + (select-mime-encoding* encoding + mime-encoding/caller-with-decoding-port + (lambda () (generator port)) + (lambda (call-with-decoding-port) + (call-with-decoding-port port text? generator)))) + +(define (select-mime-encoding encoding lose win) + (cond ((mime-encoding? encoding) + (win encoding)) + ((named-mime-encoding encoding) + => win) + (else + (warn "Unknown MIME encoding:" encoding) + (lose)))) + +(define (select-mime-encoding* encoding selector lose win) + (select-mime-encoding encoding + lose + (lambda (encoding) (win (selector encoding))))) + +(define-identity-mime-encoding '7BIT) +(define-identity-mime-encoding '8BIT) +(define-identity-mime-encoding 'BINARY) + +(define-mime-encoding 'QUOTED-PRINTABLE + encode-quoted-printable:initialize + encode-quoted-printable:finalize + encode-quoted-printable:update + decode-quoted-printable:initialize + decode-quoted-printable:finalize + decode-quoted-printable:update + make-decode-quoted-printable-port + call-with-decode-quoted-printable-output-port) + +(define-mime-encoding 'BASE64 + encode-base64:initialize + encode-base64:finalize + encode-base64:update + decode-base64:initialize + decode-base64:finalize + decode-base64:update + make-decode-base64-port + call-with-decode-base64-output-port) + +(define-mime-encoding 'BINHEX40 + #f #f #f ;No BinHex encoder. + decode-binhex40:initialize + decode-binhex40:finalize + decode-binhex40:update + make-decode-binhex40-port + call-with-decode-binhex40-output-port) + +;;; Edwin Variables: +;;; Eval: (scheme-indent-method 'SELECT-MIME-ENCODING 1) +;;; Eval: (scheme-indent-method 'SELECT-MIME-ENCODING* 2) +;;; End: diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm index 4e568c878..5a117c874 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.85 2005/11/27 06:40:53 riastradh Exp $ +$Id: imail-file.scm,v 1.86 2005/12/10 06:45:32 riastradh Exp $ Copyright 1999,2000,2001,2002,2003,2005 Massachusetts Institute of Technology @@ -18,7 +18,7 @@ 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, +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02111-1301, USA. |# @@ -461,9 +461,9 @@ USA. folder unspecific) -(define-method folder-supports-mime? ((folder )) - folder - #f) +; (define-method folder-supports-mime? ((folder )) +; folder +; #f) (define-method preload-folder-outlines ((folder )) folder diff --git a/v7/src/imail/imail-mime.scm b/v7/src/imail/imail-mime.scm new file mode 100644 index 000000000..ce52f66ea --- /dev/null +++ b/v7/src/imail/imail-mime.scm @@ -0,0 +1,521 @@ +#| -*-Scheme-*- + +$Id $ + +Copyright 2005 Taylor Campbell + +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., 51 Franklin St, Fifth Floor, Boston, MA 02111-1301, +USA. + +|# + +;;;; IMAIL mail reader: MIME parser + +(declare (usual-integrations)) + +(define-method folder-supports-mime? ((folder )) + folder + #t) + +(define-method mime-message-body-structure ((message )) + (or (get-property message 'MIME-MESSAGE-BODY-STRUCTURE #f) + (cond ((mime:get-version-header message) + => (lambda (version-string) + (if (mime:version-1.0? version-string) + (let ((body-structure + (mime:parse-body-structure message))) + (store-property! message + 'MIME-MESSAGE-BODY-STRUCTURE + body-structure) + body-structure) + (error "MIME version not 1.0:" + version-string + message)))) + (else #f)))) + +(define (mime:parse-body-structure message) + (let ((content-type + (parse-first-named-header message "Content-Type" + mime:default-content-type + mime:parse-content-type)) + (encoding + (parse-first-named-header message "Content-Transfer-Encoding" + mime:default-encoding + mime:parse-encoding))) + (let ((type (car content-type)) + (subtype (cadr content-type)) + (parameters (cddr content-type))) + ;; Bizarre code organization here. I can't think of a better + ;; way to structure this code. + ((or (and-let* ((encoding + (named-mime-encoding (or encoding '7BIT) + #f)) + (top-level (assq type mime:media-parsers)) + (parser (cond ((assq subtype (cddr top-level)) + => cdr) + ((cadr top-level)) + (else #f)))) + (lambda () + (parser message type subtype parameters encoding))) + (lambda () + (mime:basic-media-parser message type subtype parameters + #f))))))) + +(define-method write-mime-message-body-part + ((message ) selector cache? port) + cache? + (let loop ((sel selector) + (part (mime-message-body-structure message))) + (let ((item (car sel)) + (sel (cdr sel))) + (cond ((exact-nonnegative-integer? item) + (if (mime-body-multipart? part) + (let ((subpart + (list-ref (mime-body-multipart-parts part) + item))) + (if (null? sel) + (begin + (if (message? subpart) + (begin + (write-header-fields + (message-header-fields subpart) + port) + (newline port))) + (write-message-body subpart port)) + (loop sel subpart))) + (error "Selecting part of non-multipart:" part sel))) + ((null? sel) + (case item + ((TEXT) + (write-message-body part port)) + ((HEADER) + (write-header-fields part port)) + (else + (error "Invalid message MIME body selector tail:" + sel + message)))) + (else + (error "Invalid message MIME body selector:" + selector + message)))))) + +;;;; MIME-Version Header Field + +(define (mime:get-version-header message) + (get-first-header-field-value (message-header-fields message) + "MIME-Version" + ;; No error if not found. + #f)) + +(define (mime:version-1.0? string) + (let ((tokens (mime:string->non-ignored-tokens string))) + (let loop ((in tokens) + (out '())) + (if (pair? in) + (let ((token (car in)) + (in (cdr in))) + (cond ((string? token) + (loop in (cons token out))) + ((char? token) + (loop in (cons (string token) out))) + (else #f))) + (string=? (apply string-append (reverse! out)) + "1.0"))))) + +(define mime:media-parsers '()) + +;++ What about top-level media types whose subtypes are mandated to +;++ have common syntax? + +(define (define-mime-media-parser type subtype parser) + (cond ((assq type mime:media-parsers) + => (lambda (top-level) + (if subtype + (let ((subtype-parsers (cddr top-level))) + (cond ((assq subtype subtype-parsers) + => (lambda (sub-level) + (warn "Replacing MIME parser:" + (symbol type '/ subtype) + (cdr sub-level) + (error-irritant/noise " with") + parser) + (set-cdr! top-level parser))) + (else + (set-cdr! (cdr top-level) + (cons (cons subtype parser) + subtype-parsers))))) + (begin + (if (cadr top-level) + (warn "Replacing default MIME parser:" + type + (cadr top-level) + (error-irritant/noise " with") + parser)) + (set-car! (cdr top-level) parser))))) + (else + (set! mime:media-parsers + (cons (cons type + (if subtype + (list #f (cons subtype parser)) + (list parser))) + mime:media-parsers))))) + +(define-class () + (string define accessor) + (start define accessor) + (end define accessor)) + +(define-method message-body ((message )) + (values (message-part-string message) + (message-part-start message) + (message-part-end message))) + +(define-method write-message-body ((message ) port) + (write-substring (message-part-string message) + (message-part-start message) + (message-part-end message) + port)) + +(define-class ( + (constructor make-mime-body-basic-part + (string + start end + type subtype parameters + id description + encoding + n-octets + md5 + disposition language))) + ( )) + +;;; This is the default media parser, equivalent to a Content-Type of +;;; APPLICATION/OCTET-STREAM. + +(define mime:basic-media-parser + (lambda (message type subtype parameters encoding) + (receive (string start end) (message-body message) + (make-mime-body-basic-part + string start end + type subtype parameters + (mime:get-content-id message) + (mime:get-content-description message) + encoding + (message-length message) + (ignore-errors (lambda () (md5-substring string start end)) + (lambda (condition) condition #f)) + (mime:get-content-disposition message) + (mime:get-content-language message))))) + +;;; This is unnecessary, but it's nice to make things explicit. + +(define-mime-media-parser 'APPLICATION 'OCTET-STREAM + mime:basic-media-parser) + +(define-class ( + (constructor make-mime-body-text-part + (string + start end + subtype parameters + id description + encoding + n-octets n-lines + md5 + disposition language))) + ( )) + +(define-mime-media-parser 'TEXT #f + (lambda (message type subtype parameters encoding) + type ;ignore + (receive (string start end) (message-body message) + (receive (octets lines) (count-octets&lines string start end) + (make-mime-body-text-part + string start end + subtype parameters + (mime:get-content-id message) + (mime:get-content-description message) + (mime-encoding/name encoding) + octets lines + (ignore-errors (lambda () (md5-substring string start end)) + (lambda (condition) condition #f)) + (mime:get-content-disposition message) + (mime:get-content-language message)))))) + +(define (count-octets&lines string start end) + (let loop ((i start) (octets 0) (lines 0)) + (if (fix:= i end) + (values octets lines) + (loop (fix:+ i 1) + (fix:+ octets 1) + (if (char=? (string-ref string i) #\newline) + (fix:+ lines 1) + lines))))) + +;;;; Multipart Media + +(define-mime-media-parser 'MULTIPART #f + (lambda (message type subtype parameters encoding) + type ;ignore + (mime:parse-multipart message subtype parameters encoding))) + +(define-mime-media-parser 'MULTIPART 'DIGEST + (lambda (message type subtype parameters encoding) + type ;ignore + (fluid-let ((mime:default-content-type '(MESSAGE RFC822))) + (mime:parse-multipart message subtype parameters encoding)))) + +(define (mime:parse-multipart message subtype parameters encoding) + (let* ((parts (mime:parse-multipart-subparts message parameters + encoding)) + (enclosure (make-mime-body-multipart + subtype parameters + parts + (mime:get-content-disposition message) + (mime:get-content-language message)))) + (for-each (lambda (part) + (set-mime-body-enclosure! part enclosure)) + parts) + enclosure)) + +(define (mime:parse-multipart-subparts message parameters encoding) + (let ((boundary (mime:get-boundary parameters message))) + (let ((do-it (lambda (body start end) + (mime:parse-parts + body + (mime:multipart-message-parts body start end + boundary))))) + (if (mime-encoding/identity? message) + (call-with-values (lambda () (message-body message)) + do-it) + (let ((body + (call-with-output-string + (lambda (output-port) + (call-with-mime-decoding-output-port + encoding output-port #t + (lambda (output-port) + (write-message-body message output-port))))))) + (do-it body 0 (string-length body))))))) + +(define (mime:get-boundary parameters message) + (cond ((assq 'BOUNDARY parameters) + => (lambda (probe) + (string-append "--" (cdr probe)))) + (else + (error "MIME multipart message has no boundary:" + message)))) + +(define (mime:multipart-message-parts string start end boundary) + (let ((boundary-length (string-length boundary))) + + (define (loop part-start search-start parts) + (cond ((substring-search-forward boundary string + search-start end) + => (lambda (boundary-start) + (let ((boundary-end + (+ boundary-start boundary-length))) + (if (or (zero? boundary-start) + (char=? (string-ref string + (- boundary-start 1)) + #\newline)) + (continue part-start + (if (zero? boundary-start) + 0 + (- boundary-start 1)) + boundary-end + parts) + (loop part-start boundary-end parts))))) + (else (lose parts)))) + + (define (continue part-start part-end boundary-end parts) + (cond ((and (>= end (+ boundary-end 2)) + (char=? #\- (string-ref string boundary-end)) + (char=? #\- (string-ref string (+ boundary-end 1)))) + (win (cons (cons part-start part-end) parts))) + ((skip-lwsp-until-newline string boundary-end end) + => (lambda (next-line-start) + (loop next-line-start + next-line-start + (cons (cons part-start part-end) parts)))) + (else + (loop part-start boundary-end parts)))) + + (define (win parts) + (cdr (reverse! parts))) + + (define (lose parts) + (cdr (reverse! parts))) + + (loop start start '()))) + +;;;;; MIME Part Messages + +(define-class ( + (constructor make-message-part-message + (header-fields string start end))) + ;** Do not rearrange this! The MESSAGE-BODY method on + ;** must be more given precedence over that on + ;** ! + ( )) + +(define (mime:parse-part string header-start header-end body-end) + (mime:parse-body-structure + (make-message-part-message (lines->header-fields + (substring->lines string header-start + header-end)) + string + (+ header-end 1) + body-end))) + +(define (mime:parse-parts body parts) + (map (lambda (part) + (mime:parse-body-structure + (let ((start (car part)) + (end (cdr part))) + (cond ((substring-search-forward "\n\n" body start end) + => (lambda (header-end) + (make-message-part-message + (lines->header-fields + (substring->lines body start + ;; Add trailing newline. + (+ header-end 1))) + body + ;; Skip the two newlines. + (+ header-end 2) + end))) + (else + ;; Grossly assume that this means there are no + ;; headers. + (make-message-part-message '() body start end)))))) + parts)) + +;;;; Content-Type Header Fields + +(define mime:default-content-type '(TEXT PLAIN (CHARSET . "us-ascii"))) + +(define (mime:parse-content-type string) + (let ((tokens (mime:string->non-ignored-tokens string))) + (if (pair? tokens) + (let ((type (car tokens)) + (tokens (cdr tokens))) + (if (and (string? type) + (pair? tokens)) + (let ((slash (car tokens)) + (tokens (cdr tokens))) + (if (and (eqv? slash #\/) + (pair? tokens)) + (let ((subtype (car tokens)) + (tokens (cdr tokens))) + (if (string? subtype) + (cons* (intern type) + (intern subtype) + (mime:parse-parameters + tokens + "Content-Type")) + #f)) + #f)) + #f)) + #f))) + +;;;; Other Content-... Fields + +(define mime:default-encoding '7BIT) + +(define (mime:parse-encoding encoding) + (let ((tokens (mime:string->non-ignored-tokens encoding))) + (if (and (pair? tokens) + (string? (car tokens)) + (null? (cdr tokens))) + (intern (car tokens)) + #f))) + +(define (mime:get-content-id message) + (parse-first-named-header message "Content-ID" #f rfc822:parse-msg-id)) + +(define (mime:get-content-description message) + (parse-first-named-header message "Content-Description" #f + mime:parse-encoded-header-value)) + +(define (mime:parse-encoded-header-value value) + ;++ implement + value) + +(define (mime:get-content-disposition message) + (parse-first-named-header message "Content-Disposition" #f + mime:parse-disposition)) + +(define (mime:parse-disposition disposition) + (let ((tokens (mime:string->non-ignored-tokens disposition))) + (if (pair? tokens) + (let ((type (car tokens)) + (tokens (cdr tokens))) + (if (string? type) + (cons (intern type) + (mime:parse-parameters tokens + "Content-Disposition")) + #f)) + #f))) + +(define (mime:get-content-language message) + ;++ implement + #f) + +;;;; Extended RFC 822 Tokenizer + +(define mime:special-chars + (char-set #\( #\) #\< #\> #\@ + #\, #\; #\: #\\ #\" + #\/ #\[ #\] #\? #\=)) + +;;; STRING->TOKENS includes whitespace & parenthesis comments; +;;; STRING->NON-IGNORED-TOKENS omits them. + +(define mime:string->tokens + (rfc822:string-tokenizer mime:special-chars #t)) + +(define mime:string->non-ignored-tokens + (rfc822:string-tokenizer mime:special-chars #f)) + +;;; Too bad the parser language works only on strings; it would be +;;; nice to be able to use it for general tokens, like RFC822 tokens. + +(define (mime:parse-parameters tokens header-name) + (let ((lose (lambda (tokens) + (warn (string-append "Malformed " header-name + " parameter tokens:") + tokens) + '()))) + (let recur ((tokens tokens)) + (if (pair? tokens) + (let ((lose (lambda () (lose tokens)))) + (let ((semi (car tokens)) + (tokens (cdr tokens))) + (if (and (eqv? semi #\;) + (pair? tokens)) + (let ((attribute (car tokens)) + (tokens (cdr tokens))) + (if (pair? tokens) + (let ((equals (car tokens)) + (tokens (cdr tokens))) + (if (and (eqv? equals #\=) + (pair? tokens)) + (cons (cons (intern attribute) + (rfc822:unquote-string + (car tokens))) + (recur (cdr tokens))) + (lose))) + (lose))) + (lose)))) + '())))) diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index d9c01a1aa..351d0a2af 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.292 2005/09/13 14:19:26 cph Exp $ +$Id: imail-top.scm,v 1.293 2005/12/10 06:45:32 riastradh Exp $ Copyright 1999,2000,2001,2002,2003,2004 Massachusetts Institute of Technology Copyright 2005 Massachusetts Institute of Technology @@ -19,7 +19,7 @@ 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, +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02111-1301, USA. |# @@ -2702,19 +2702,6 @@ Negative argument means search in reverse." (body #f read-only #t) (selector #f read-only #t) (context #f read-only #t)) - -(define (call-with-mime-decoding-output-port encoding port text? generator) - (case encoding - ((QUOTED-PRINTABLE) - (call-with-decode-quoted-printable-output-port port text? generator)) - ((BASE64) - (call-with-decode-base64-output-port port text? generator)) - ((BINHEX40) - (call-with-decode-binhex40-output-port port text? generator)) - ((X-UUENCODE) - (call-with-decode-uue-output-port port text? generator)) - (else - (generator port)))) ;;;; Automatic wrap/fill diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm index d8406083a..1904a480f 100644 --- a/v7/src/imail/imail-util.scm +++ b/v7/src/imail/imail-util.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: imail-util.scm,v 1.45 2005/11/27 06:35:24 riastradh Exp $ +$Id: imail-util.scm,v 1.46 2005/12/10 06:45:32 riastradh Exp $ -Copyright 2000,2001,2003,2004 Massachusetts Institute of Technology +Copyright 2000,2001,2003,2004,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -18,7 +18,7 @@ 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, +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02111-1301, USA. |# @@ -138,6 +138,17 @@ USA. (loop (fix:- end 1)) end))) +(define (skip-lwsp-until-newline string start end) + (let loop ((index start)) + (cond ((= index end) + #f) + ((char-lwsp? (string-ref string index)) + (loop (+ index 1))) + ((char=? (string-ref string index) #\newline) + (+ index 1)) + (else + #f)))) + (define (quote-lines lines) (map (lambda (line) (string-append "\t" line)) diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg index 4e5fd240f..1f2d3a7c0 100644 --- a/v7/src/imail/imail.pkg +++ b/v7/src/imail/imail.pkg @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: imail.pkg,v 1.100 2003/02/14 18:28:14 cph Exp $ +$Id: imail.pkg,v 1.101 2005/12/10 06:45:32 riastradh Exp $ -Copyright 2000-2001 Massachusetts Institute of Technology +Copyright 2000,2001,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -18,7 +18,7 @@ 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, +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02111-1301, USA. |# @@ -35,6 +35,19 @@ USA. "imail-core") (parent (edwin))) +(define-package (edwin imail mime) + (files "imail-mime") + (parent (edwin imail)) + (export (edwin imail) + define-mime-media-parser + mime:basic-media-parser + mime:parse-multipart + mime:default-content-type + + message-part-string + message-part-start + message-part-end)) + (define-package (edwin imail file-folder) (files "imail-file") (parent (edwin imail)) -- 2.25.1