From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 1 Jun 2000 05:10:16 +0000 (+0000)
Subject: Add generic interface to access MIME BODYSTRUCTURE information.
X-Git-Tag: 20090517-FFI~3651
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=45f1a3bf94ed43566bf90e8a0fd2e2117c597da4;p=mit-scheme.git

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 ea967abc9..0cb0cbf62 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.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))
 
 ;;;; 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)))
+
+;;;; 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 6b47999d5..4b33b5027 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.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 c5138b5ed..bf88bd760 100644
--- 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)))))
 
+;;;; 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))
+
+(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))))))
+
 ;;;; 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)
 
 ;;;; IMAP command invocation