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