From 45f1a3bf94ed43566bf90e8a0fd2e2117c597da4 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 1 Jun 2000 05:10:16 +0000 Subject: [PATCH] Add generic interface to access MIME BODYSTRUCTURE information. --- v7/src/imail/imail-core.scm | 87 ++++++++++++++++++- v7/src/imail/imail-file.scm | 8 +- v7/src/imail/imail-imap.scm | 165 +++++++++++++++++++++++++++++++++++- 3 files changed, 255 insertions(+), 5 deletions(-) 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 () + (parameters define accessor) + (disposition define accessor) + (language define accessor)) + +(define-generic mime-body-type (body)) +(define-generic mime-body-subtype (body)) + +(define-class () + (id define accessor) + (description define accessor) + (encoding define accessor) + (n-octets define accessor) + (md5 define accessor)) + +(define-class ( + (constructor (parameters id description encoding n-octets + envelope body n-lines + md5 disposition language))) + () + (envelope define accessor) ; instance + (body define accessor) ; instance + (n-lines define accessor)) + +(define-method mime-body-type ((body )) body 'MESSAGE) +(define-method mime-body-subtype ((body )) body 'RFC822) + +(define-class ( + (constructor (subtype parameters id description encoding + n-octets n-lines + md5 disposition language))) + () + (subtype accessor mime-body-subtype) + (n-lines define accessor)) + +(define-method mime-body-type ((body )) body 'TEXT) + +(define-class ( + (constructor (type subtype parameters id description encoding + n-octets md5 disposition language))) + () + (type accessor mime-body-type) + (subtype accessor mime-body-subtype)) + +(define-class ( + (constructor (subtype parameters parts disposition language))) + () + (subtype accessor mime-body-subtype) + (parts define accessor)) + +(define-method mime-body-type ((body )) body 'MULTIPART) + +(define-class ( + (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 ( (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 )) folder - unspecific) \ No newline at end of file + unspecific) + +(define-method folder-supports-mime? ((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 )) + (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 )) @@ -912,6 +1071,10 @@ (define-method disconnect-folder ((folder )) (close-folder folder)) + +(define-method folder-supports-mime? ((folder )) + folder + #t) ;;;; IMAP command invocation -- 2.25.1