~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

#| -*-Scheme-*-

$Id: imail-rmail.scm,v 1.73 2003/02/14 18:28:14 cph Exp $

Copyright 1999-2002 Massachusetts Institute of Technology

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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,

USA.

|#

;;;; IMAIL mail reader: RMAIL back end

(declare (usual-integrations))

(define-class <rmail-folder-type> (<file-folder-type>))

(define-file-folder-type <rmail-folder-type> "Rmail"

  (lambda (pathname)

    (check-file-prefix pathname "BABYL OPTIONS:")))

;;;; Server

(define-method create-file-folder-file (url (type <rmail-folder-type>))

  type

  (call-with-binary-output-file (pathname-url-pathname url)

    (lambda (port)

      (write-rmail-file-header (make-rmail-folder-header-fields '()) port))))

;;;; Folder

(define-class (<rmail-folder> (constructor (locator))) (<file-folder>)

  (header-fields define standard))

(define-method rmail-folder-header-fields ((folder <folder>))

  (compute-rmail-folder-header-fields folder))

(define (compute-rmail-folder-header-fields folder)

  (make-rmail-folder-header-fields (folder-flags folder)))

(define (make-rmail-folder-header-fields flags)

  (list (make-header-field "Version" "5")

	(make-header-field "Labels"

			   (decorated-string-append

			    "" "," ""

			    (flags->rmail-labels flags)))

	(make-header-field "Note" "This is the header of an rmail file.")

	(make-header-field "Note" "If you are seeing it in rmail,")

	(make-header-field "Note" "it means the file has no messages in it.")))

(define-method %open-file-resource (url (type <rmail-folder-type>))

  type

  (maybe-make-resource url make-rmail-folder))

;;;; Message

(define-class (<rmail-message>

	       (constructor (header-fields body flags

					   displayed-header-fields

					   internal-time)))

    (<file-message>)

  displayed-header-fields

  internal-time)

(define-generic rmail-message-displayed-header-fields (message))

(define-file-external-message-method rmail-message-displayed-header-fields

  <rmail-message>

  'DISPLAYED-HEADER-FIELDS

  string->header-fields)

(define-method rmail-message-displayed-header-fields ((message <message>))

  message

  'UNDEFINED)

(let ((accessor (slot-accessor <rmail-message> 'INTERNAL-TIME)))

  (define-method message-internal-time ((message <rmail-message>))

    (or (accessor message)

	(call-next-method message))))

(define-method make-message-copy ((message <message>) (folder <rmail-folder>))

  folder

  (make-rmail-message (message-header-fields message)

		      (file-message-body message)

		      (list-copy (message-flags message))

		      (rmail-message-displayed-header-fields message)

		      (message-internal-time message)))

;;;; Read RMAIL file

(define-method revert-file-folder ((folder <rmail-folder>))

  (read-file-folder-contents folder

    (lambda (port)

      (set-rmail-folder-header-fields! folder (read-rmail-prolog port))

      (let loop ((line #f) (index 0) (messages '()))

	(if (= 0 (remainder index 100))

	    (imail-ui:progress-meter index #f))

	(call-with-values (lambda () (read-rmail-message folder port line))

	  (lambda (message line)

	    (if message

		(begin

		  (attach-message! message folder index)

		  (loop line (+ index 1) (cons message messages)))

		(list->vector (reverse! messages)))))))))

(define (read-rmail-prolog port)

  (if (not (rmail-prolog-start-line? (read-required-line port)))

      (error "Not an RMAIL file:" port))

  (lines->header-fields (read-lines-to-eom port)))

(define (read-rmail-message folder port read-ahead-line)

  (let ((line (or read-ahead-line (read-line port))))

    (cond ((eof-object? line)

	   (values #f #f))

	  ((rmail-prolog-start-line? line)

	   (discard-to-eom port)

	   (read-rmail-message folder port #f))

	  ((rmail-message-start-line? line)

	   (values (read-rmail-message-1 folder port) #f))

	  ((umail-delimiter? line)

	   (read-umail-message folder line port

	     (lambda (line)

	       (or (rmail-prolog-start-line? line)

		   (rmail-message-start-line? line)

		   (umail-delimiter? line)))))

	  (else

	   (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))))))

(define (read-rmail-attributes-line port)

  (let ((line (read-required-line port)))

    (let ((n (string-length line))

	  (lose

	   (lambda ()

	     (error "Malformed RMAIL message-attributes line:" line))))

      (if (not (and (fix:>= n 3)

		    (char=? (string-ref line 1) #\,)))

	  (lose))

      (values (cond ((char=? (string-ref line 0) #\0) #f)

		    ((char=? (string-ref line 0) #\1) #t)

		    (else (lose)))

	      (let loop ((i 2) (flags '()) (unseen? #f))

		(if (fix:< i n)

		    (if (or (char=? (string-ref line i) #\space)

			    (char=? (string-ref line i) #\,))

			(loop (fix:+ i 1) flags unseen?)

			(let scan-token ((i* (fix:+ i 1)))

			  (if (or (fix:= i* n)

				  (char=? (string-ref line i*) #\space)

				  (char=? (string-ref line i*) #\,))

			      (let ((flag (substring line i i*)))

				(if (string-ci=? flag "unseen")

				    (loop i* flags #t)

				    (loop i* (cons flag flags) unseen?)))

			      (scan-token (fix:+ i* 1)))))

		    (if unseen?

			(reverse! flags)

			(cons "seen" (reverse! flags)))))))))

(define (read-rmail-alternate-headers port)

  (let ((start (xstring-port/position port)))

    (make-file-external-ref

     start

     (let* ((separator rmail-message:headers-separator)

	    (s0 (string-ref separator 0))

	    (sl (string-length separator)))

       (let loop ()

	 (let ((char (read-required-char port)))

	   (cond ((char=? char #\newline)

		  (let ((end (- (xstring-port/position port) 1)))

		    (if (not (string=? separator (read-required-line port)))

			(error "Missing RMAIL headers-separator string:" port))

		    end))

		 ((char=? char s0)

		  (let ((line (read-required-line port)))

		    (if (substring=? line 0 (string-length line)

				     separator 1 sl)

			(- (xstring-port/position port)

			   (+ (string-length line) 1))

			(loop))))

		 (else

		  (skip-to-line-start port)

		  (loop)))))))))

(define (read-rmail-displayed-headers port)

  (let ((start (xstring-port/position port)))

    (skip-past-blank-line port)

    (make-file-external-ref start (- (xstring-port/position port) 1))))

(define (read-rmail-body port)

  (let ((start (xstring-port/position port)))

    (input-port/discard-chars port rmail-message:end-char-set)

    (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)))))))

;;;; Write RMAIL file

(define-method write-file-folder ((folder <rmail-folder>) pathname)

  (call-with-binary-output-file pathname

    (lambda (port)

      (write-rmail-file-header (rmail-folder-header-fields folder) port)

      (for-each-vector-element (file-folder-messages folder)

	(lambda (message)

	  (write-rmail-message message port))))))

(define-method append-message-to-file (message url (type <rmail-folder-type>))

  type

  (call-with-binary-append-file (pathname-url-pathname url)

    (lambda (port)

      (write-rmail-message message port))))

(define (write-rmail-file-header header-fields port)

  (write-string "BABYL OPTIONS: -*- rmail -*-" port)

  (newline port)

  (write-header-fields header-fields port)

  (write-char rmail-message:end-char port))

(define (write-rmail-message message port)

  (write-char rmail-message:start-char port)

  (newline port)

  (let ((headers

	 (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)

	       headers)))

	(displayed-headers (rmail-message-displayed-header-fields message)))

    (let ((formatted? (not (eq? 'UNDEFINED displayed-headers))))

      (write-rmail-attributes-line message formatted? port)

      (if formatted? (write-header-fields headers port))

      (write-string rmail-message:headers-separator port)

      (newline port)

      (write-header-fields (if formatted? displayed-headers headers) port)

      (write-message-body message port)

      (fresh-line port)

      (write-char rmail-message:end-char port))))

(define (write-rmail-attributes-line message formatted? port)

  (write-char (if formatted? #\1 #\0) port)

  (write-char #\, port)

  (call-with-values (lambda () (flags->rmail-markers (message-flags message)))

    (lambda (attributes labels)

      (let ((write-markers

	     (lambda (markers)

	       (for-each (lambda (marker)

			   (write-char #\space port)

			   (write-string marker port)

			   (write-char #\, port))

			 markers))))

	(write-markers attributes)

	(write-char #\, port)

	(write-markers labels))))

  (newline port))

;;;; Attributes and labels

(define (rmail-markers->flags attributes labels)

  (let loop ((strings (append attributes labels)) (flags '()))

    (if (pair? strings)

	(loop (cdr strings) (cons (car strings) flags))

	(reverse!

	 (if (flags-member? "unseen" flags)

	     (flags-delete! "unseen" flags)

	     (cons "seen" flags))))))

(define (flags->rmail-markers flags)

  (let loop

      ((flags

	(if (flags-member? "seen" flags)

	    (flags-delete "seen" flags)

	    (cons "unseen" flags)))

       (attributes '())

       (labels '()))

    (if (pair? flags)

	(if (member (car flags) rmail-attributes)

	    (loop (cdr flags) (cons (car flags) attributes) labels)

	    (loop (cdr flags) attributes (cons (car flags) labels)))

	(values (reverse! attributes) (reverse! labels)))))

(define (flags->rmail-labels flags)

  (call-with-values (lambda () (flags->rmail-markers flags))

    (lambda (attributes labels)

      attributes

      labels)))

;;;; Syntactic Markers

(define (rmail-prolog-start-line? line)

  (string-prefix? "BABYL OPTIONS:" line))

(define (rmail-prolog-end-line? line)

  (string-prefix? "\037" line))

(define (rmail-message-start-line? line)

  (string=? "\f" line))

(define rmail-message:headers-separator

  "*** EOOH ***")

(define rmail-message:start-char

  #\page)

(define rmail-message:end-char

  (integer->char #x1f))

(define rmail-message:end-char-set

  (char-set rmail-message:end-char))

(define rmail-attributes

  '("deleted" "answered" "unseen" "filed" "forwarded" "edited" "resent"))

(define (read-lines-to-eom port)

  (source->list

   (lambda ()

     (if (eqv? rmail-message:end-char (peek-char port))

	 (begin

	   (read-char port)		;discard

	   (make-eof-object port))

	 (read-required-line port)))))

(define (read-to-eom port)

  (let ((string (read-string rmail-message:end-char-set port)))

    (if (or (eof-object? string)

	    (eof-object? (read-char port)))

	(error "EOF while reading RMAIL message body:" port))

    string))

(define (discard-to-eom port)

  (input-port/discard-chars port rmail-message:end-char-set)

  (input-port/discard-char port))