Add generic interface to access MIME BODYSTRUCTURE information.

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index ea967abc96c201f34ce7de3967aa71a5a19afa7b..0cb0cbf62b7c7c1244698d46011dcc6674d0749c 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.91 2000/05/23 20:19:01 cph Exp $
+;;; $Id: imail-core.scm,v 1.92 2000/06/01 05:10:09 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -388,6 +388,11 @@
 ;; automatically reconnect as needed.
 
 (define-generic disconnect-folder (folder))
+
+;; -------------------------------------------------------------------
+;; Return #T if FOLDER supports MIME parsing.
+
+(define-generic folder-supports-mime? (folder))
 \f
 ;;;; Message type
 
@@ -798,4 +803,82 @@
   (lines->header-fields (string->lines string)))
 
 (define (header-fields->string headers)
-  (lines->string (header-fields->lines headers)))
\ No newline at end of file
+  (lines->string (header-fields->lines headers)))
+\f
+;;;; MIME structure
+
+(define-generic message-mime-body-structure (message))
+
+(define-class <mime-body> ()
+  (parameters define accessor)
+  (disposition define accessor)
+  (language define accessor))
+
+(define-generic mime-body-type (body))
+(define-generic mime-body-subtype (body))
+
+(define-class <mime-body-one-part> (<mime-body>)
+  (id define accessor)
+  (description define accessor)
+  (encoding define accessor)
+  (n-octets define accessor)
+  (md5 define accessor))
+
+(define-class (<mime-body-message>
+              (constructor (parameters id description encoding n-octets
+                                       envelope body n-lines
+                                       md5 disposition language)))
+    (<mime-body-one-part>)
+  (envelope define accessor)           ;<mime-envelope> instance
+  (body define accessor)               ;<mime-body> instance
+  (n-lines define accessor))
+
+(define-method mime-body-type ((body <mime-body-message>)) body 'MESSAGE)
+(define-method mime-body-subtype ((body <mime-body-message>)) body 'RFC822)
+
+(define-class (<mime-body-text>
+              (constructor (subtype parameters id description encoding
+                                    n-octets n-lines
+                                    md5 disposition language)))
+    (<mime-body-one-part>)
+  (subtype accessor mime-body-subtype)
+  (n-lines define accessor))
+
+(define-method mime-body-type ((body <mime-body-text>)) body 'TEXT)
+
+(define-class (<mime-body-basic>
+              (constructor (type subtype parameters id description encoding
+                                 n-octets md5 disposition language)))
+    (<mime-body-one-part>)
+  (type accessor mime-body-type)
+  (subtype accessor mime-body-subtype))
+
+(define-class (<mime-body-multipart>
+              (constructor (subtype parameters parts disposition language)))
+    (<mime-body>)
+  (subtype accessor mime-body-subtype)
+  (parts define accessor))
+
+(define-method mime-body-type ((body <mime-body-multipart>)) body 'MULTIPART)
+
+(define-class (<mime-envelope>
+              (constructor (date subject from sender reply-to to cc bcc
+                                 in-reply-to message-id)))
+    ()
+  (date define accessor)
+  (subject define accessor)
+  (from define accessor)
+  (sender define accessor)
+  (reply-to define accessor)
+  (to define accessor)
+  (cc define accessor)
+  (bcc define accessor)
+  (in-reply-to define accessor)
+  (message-id define accessor))
+
+(define-class (<mime-address> (constructor (name source-route mailbox host)))
+    ()
+  (name define accessor)
+  (source-route define accessor)
+  (mailbox define accessor)
+  (host define accessor))
\ No newline at end of file

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index 6b47999d535246dd18fe5e33233c8da0db972d90..4b33b5027fb078590f44969e1dade839c74bffb6 100644 (file)
--- 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.40 2000/05/23 20:19:02 cph Exp $
+;;; $Id: imail-file.scm,v 1.41 2000/06/01 05:10:14 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -265,4 +265,8 @@
 
 (define-method disconnect-folder ((folder <file-folder>))
   folder
-  unspecific)
\ No newline at end of file
+  unspecific)
+
+(define-method folder-supports-mime? ((folder <file-folder>))
+  folder
+  #f)
\ No newline at end of file

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index c5138b5ed25145d595c520ce2c0d989385da0178..bf88bd76063641f23f27187ce9a9e45e100218a4 100644 (file)
--- a/v7/src/imail/imail-imap.scm
+++ b/v7/src/imail/imail-imap.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-imap.scm,v 1.95 2000/05/30 20:53:51 cph Exp $
+;;; $Id: imail-imap.scm,v 1.96 2000/06/01 05:10:16 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -772,6 +772,165 @@
               (guarantee-slot-initialized message initpred "bodystructure"
                                           '(BODYSTRUCTURE)))))
 \f
+;;;; MIME support
+
+(define-method message-mime-body-structure ((message <imap-message>))
+  (parse-mime-body (imap-message-bodystructure message)))
+
+(define (parse-mime-body body)
+  (cond ((not (and (pair? body) (list? body))) (parse-mime-body:lose body))
+       ((string? (car body)) (parse-mime-body:one-part body))
+       ((pair? (car body)) (parse-mime-body:multi-part body))
+       (else (parse-mime-body:lose body))))
+
+(define (parse-mime-body:one-part body)
+  (let ((n (length body)))
+    (cond ((string-ci=? "text" (car body))
+          (if (not (fix:>= n 8))
+              (parse-mime-body:lose body))
+          (apply make-mime-body-text
+                 (intern (list-ref body 1))
+                 (parse-mime-parameters (list-ref body 2))
+                 (list-ref body 3)
+                 (list-ref body 4)
+                 (intern (list-ref body 5))
+                 (list-ref body 6)
+                 (list-ref body 7)
+                 (parse-mime-body:extensions (list-tail body 8))))
+         ((and (string-ci=? "message" (car body))
+               (string-ci=? "rfc822" (cadr body)))
+          (if (not (fix:>= n 10))
+              (parse-mime-body:lose body))
+          (apply make-mime-body-message
+                 (parse-mime-parameters (list-ref body 2))
+                 (list-ref body 3)
+                 (list-ref body 4)
+                 (intern (list-ref body 5))
+                 (list-ref body 6)
+                 (parse-mime-envelope (list-ref body 7))
+                 (parse-mime-body (list-ref body 8))
+                 (list-ref body 9)
+                 (parse-mime-body:extensions (list-tail body 10))))
+         (else
+          (if (not (fix:>= n 7))
+              (parse-mime-body:lose body))
+          (apply make-mime-body-basic
+                 (intern (list-ref body 0))
+                 (intern (list-ref body 1))
+                 (parse-mime-parameters (list-ref body 2))
+                 (list-ref body 3)
+                 (list-ref body 4)
+                 (intern (list-ref body 5))
+                 (list-ref body 6)
+                 (parse-mime-body:extensions (list-tail body 7)))))))
+
+(define (parse-mime-body:multi-part body)
+  (let loop ((tail body) (index 0))
+    (if (not (pair? tail))
+       (parse-mime-body:lose body))
+    (if (string? (car tail))
+       (let ((extensions (parse-mime-body:extensions (cdr tail))))
+         (make-mime-body-multipart (intern (car tail))
+                                   (parse-mime-parameters (car extensions))
+                                   (list->vector
+                                    (map parse-mime-body
+                                         (sublist body 0 index)))
+                                   (cadr extensions)
+                                   (caddr extensions)))
+       (loop (cdr tail) (fix:+ index 1)))))
+
+(define (parse-mime-body:extensions tail)
+  (if (pair? tail)
+      (if (pair? (cdr tail))
+         (if (pair? (cddr tail))
+             (list (car tail) (cadr tail) (caddr tail))
+             (list (car tail) (cadr tail) #f))
+         (list (car tail) #f #f))
+      (list #f #f #f)))
+
+(define (parse-mime-body:lose body)
+  (error "Unrecognized MIME bodystructure:" body))
+\f
+(define (parse-mime-envelope envelope)
+  (make-mime-envelope (list-ref envelope 0)
+                     (list-ref envelope 1)
+                     (parse-mime-addr-list (list-ref envelope 2))
+                     (parse-mime-addr-list (list-ref envelope 3))
+                     (parse-mime-addr-list (list-ref envelope 4))
+                     (parse-mime-addr-list (list-ref envelope 5))
+                     (parse-mime-addr-list (list-ref envelope 6))
+                     (parse-mime-addr-list (list-ref envelope 7))
+                     (list-ref envelope 8)
+                     (list-ref envelope 9)))
+
+(define (parse-mime-addr-list addr-list)
+  (if addr-list
+      (let ((lose
+            (lambda () (error "Malformed MIME address list:" addr-list))))
+       (define (loop addr-list open-groups result)
+         (cond ((pair? addr-list)
+                (let ((a (car addr-list)))
+                  (cond ((not (and (list? a) (fix:= 4 (length a))))
+                         (lose))
+                        ((and (or (not (car a)) (string? (car a)))
+                              (or (not (cadr a)) (string? (cadr a)))
+                              (string? (caddr a))
+                              (string? (cadddr a)))
+                         (loop (cdr addr-list)
+                               open-groups
+                               (cons (make-mime-address (car a)
+                                                        (cadr a)
+                                                        (caddr a)
+                                                        (cadddr a))
+                                     result)))
+                        ((and (not (car a))
+                              (not (cadr a))
+                              (string? (caddr a))
+                              (not (cadddr a)))
+                         (loop (cdr addr-list)
+                               (cons (cons (caddr a) result)
+                                     open-groups)
+                               '()))
+                        ((and (not (car a))
+                              (not (cadr a))
+                              (not (caddr a))
+                              (not (cadddr a))
+                              (pair? open-groups))
+                         (loop (cdr addr-list)
+                               (cdr open-groups)
+                               (cons (cons (caar open-groups)
+                                           (reverse! result))
+                                     (cdar open-groups))))
+                        (else (lose)))))
+               ((and (null? addr-list) (null? open-groups)) (reverse! result))
+               (else (lose))))
+       (loop addr-list '() '()))
+      '()))
+
+(define (parse-mime-parameters parameters)
+  (let ((lose (lambda () (error "Malformed MIME parameters:" parameters))))
+    (let loop ((parameters parameters) (alist '()))
+      (if (pair? parameters)
+         (if (pair? (cdr parameters))
+             (loop (cddr parameters)
+                   (cons (cons (intern (car parameters)) (cadr parameters))
+                         alist))
+             (lose))
+         (if (null? parameters)
+             (reverse! alist)
+             (lose))))))
+
+(define (parse-mime-disposition disposition)
+  (and disposition
+       (begin
+        (if (not (and (pair? disposition)
+                      (string? (car disposition))
+                      (pair? (cdr disposition))
+                      (null? (cddr disposition))))
+            (error "Malformed MIME disposition:" disposition))
+        (cons (intern (car disposition))
+              (parse-mime-parameters (cadr disposition))))))
+\f
 ;;;; Server operations
 
 (define-method %create-folder ((url <imap-url>))
@@ -912,6 +1071,10 @@
 
 (define-method disconnect-folder ((folder <imap-folder>))
   (close-folder folder))
+
+(define-method folder-supports-mime? ((folder <imap-folder>))
+  folder
+  #t)
 \f
 ;;;; IMAP command invocation