#| -*-Scheme-*-

$Id: imail-core.scm,v 1.165 2007/03/11 22:38:55 riastradh Exp $

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; IMAIL mail reader: core definitions

(declare (usual-integrations))

;;;; Properties

(define-class <property-mixin> ()
  (alist define (accessor modifier)
	 accessor object-properties
	 modifier set-object-properties!
	 initial-value '()))

(define (get-property object key default)
  (let ((entry (assq key (object-properties object))))
    (if entry
	(cdr entry)
	default)))

(define (store-property! object key datum)
  (let ((alist (object-properties object)))
    (let ((entry (assq key alist)))
      (if entry
	  (set-cdr! entry datum)
	  (set-object-properties! object (cons (cons key datum) alist))))))

(define (remove-property! object key)
  (set-object-properties! object (del-assq! key (object-properties object))))

;;;; Modification events

(define-class <modification-event-mixin> ()
  (modification-count define (accessor modifier)
		      accessor object-modification-count
		      modifier set-object-modification-count!
		      initial-value 0)
  (modification-event define accessor
		      accessor object-modification-event
		      initializer make-event-distributor))

(define (receive-modification-events object procedure)
  (add-event-receiver! (object-modification-event object) procedure))

(define (ignore-modification-events object procedure)
  (remove-event-receiver! (object-modification-event object) procedure))

(define (object-modified! object type . arguments)
  (without-interrupts
   (lambda ()
     (set-object-modification-count!
      object
      (+ (object-modification-count object) 1))))
  (apply signal-modification-event object type arguments))

(define (signal-modification-event object type . arguments)
  (if *deferred-modification-events*
      (set-cdr! *deferred-modification-events*
		(cons (cons* object type arguments)
		      (cdr *deferred-modification-events*)))
      (begin
	(if imap-trace-port
	    (begin
	      (write-line (cons* 'OBJECT-EVENT object type arguments)
			  imap-trace-port)
	      (flush-output imap-trace-port)))
	(event-distributor/invoke! (object-modification-event object)
				   object
				   type
				   arguments))))

(define (with-modification-events-deferred thunk)
  (let ((events (list 'EVENTS)))
    (let ((v
	   (fluid-let ((*deferred-modification-events* events))
	     (thunk))))
      (for-each (lambda (event) (apply signal-modification-event event))
		(reverse! (cdr events)))
      v)))

(define *deferred-modification-events* #f)

;;;; URL type

(define-class <url> (<property-mixin>)
  (container initial-value 'UNKNOWN))

(define-class <folder-url> (<url>))
(define-class <container-url> (<url>))

(define (guarantee-url url procedure)
  (if (not (url? url))
      (error:wrong-type-argument url "IMAIL URL" procedure)))

;; Return the canonical name of URL's protocol as a string.
(define-generic url-protocol (url))

;; Return the body of URL as a string.
(define-generic url-body (url))

(define (make-url-string protocol body)
  (string-append protocol ":" body))

(define (url->string url)
  (make-url-string (url-protocol url) (url-body url)))

(define-method write-instance ((url <url>) port)
  (write-instance-helper 'URL url port
    (lambda ()
      (write-char #\space port)
      (write (url->string url) port))))

;; Return #T iff URL represents an existing folder.
(define-generic url-exists? (url))

;; Return #T iff FOLDER-URL both exists and can be opened.
(define-generic folder-url-is-selectable? (folder-url))

;; If URL can potentially contain other resources, return a container
;; URL for the same resource.  Otherwise return #F.  The result is
;; undefined if the URL doesn't represent an existing folder.
(define-generic url-corresponding-container (url))
(define-method url-corresponding-container ((url <container-url>)) url)

;; Return a locator for the container of URL.  E.g. the container URL
;; of "imap://localhost/inbox/foo" is "imap://localhost/inbox/".
(define-generic container-url (url))
(add-method container-url (slot-accessor-method <url> 'CONTAINER))

;; Like CONTAINER-URL except that the returned container URL is
;; allowed to be different from the true container URL when this
;; results in a better prompt.
;;
;; For example, when URL is "imap://localhost/inbox" and the IMAP
;; server is Cyrus, this will return "imap://localhost/inbox/".
(define-generic container-url-for-prompt (url))

;; Return the content name of a URL.  The content name of a URL is the
;; suffix of the URL that uniquely identifies the resource with
;; respect to its container.
;;
;; Here are some examples:
;;
;; URL					content name
;; ---------------------------		------------
;; imap://localhost/inbox/foo		foo
;; imap://localhost/inbox/foo/		foo/
;; file:/usr/home/cph/foo.mail		foo.mail
(define-generic url-content-name (url))

;; Return a URL that refers to the content NAME of the container
;; referred to by CONTAINER-URL.
(define-generic make-content-url (container-url name))

;; Return the base name of FOLDER-URL.  This is the content name of
;; FOLDER-URL, but presented in a type-independent way.  For example,
;; if the content name of a file URL is "foo.mail", the base name is
;; just "foo".
(define-generic url-base-name (folder-url))

;; Return a string that uniquely identifies the server and account for
;; URL.  E.g. for IMAP this could be the URL string without the
;; mailbox information.  This string will be included in the
;; pass-phrase prompt, and also used as a key for memoization.
(define-generic url-pass-phrase-key (url))

;; Convert STRING to a URL.  GET-DEFAULT-URL is a procedure of one
;; argument that returns a URL that is used to fill in defaults if
;; STRING is a specification for a partial URL.  GET-DEFAULT-URL is
;; called with #F as its first argument to return a default URL to be
;; used if STRING doesn't explicitly specify a protocol.  Otherwise,
;; it is called with a protocol name as its first argument to return a
;; protocol-specific default.
(define (parse-url-string string get-default-url)
  (let ((colon (string-find-next-char string #\:)))
    (if colon
	(parse-url-body (string-tail string (fix:+ colon 1))
			(get-default-url (string-head string colon)))
	(parse-url-body string (get-default-url #f)))))

;; Protocol-specific parsing.  Dispatch on the class of DEFAULT-URL.
;; Each method is responsible for calling INTERN-URL on the result of
;; the parse, and returning the interned URL.  Illegal syntax in
;; STRING must cause an error to be signalled.
(define-generic parse-url-body (string default-url))

(define intern-url
  (let ((modifier (slot-modifier <url> 'CONTAINER)))
    (lambda (url compute-container)
      (let ((string (url->string url)))
	(or (hash-table/get interned-urls string #f)
	    (begin
	      (let ((finished? #f))
		(dynamic-wind
		 (lambda ()
		   (hash-table/put! interned-urls string url))
		 (lambda ()
		   (modifier url (compute-container url))
		   (set! finished? #t)
		   unspecific)
		 (lambda ()
		   (if (not finished?)
		       (hash-table/remove! interned-urls string)))))
	      url))))))

(define interned-urls
  (make-string-hash-table))

(define (define-url-protocol name class)
  (define-method url-protocol ((url class)) url name)
  (hash-table/put! url-protocols (string-downcase name) class))

(define (url-protocol-name? name)
  (hash-table/get url-protocols (string-downcase name) #f))

(define url-protocols
  (make-string-hash-table))

(define (url-presentation-name url)
  (let ((name (url-content-name url)))
    (if (string-suffix? "/" name)
	(string-head name (fix:- (string-length name) 1))
	name)))

;; Do completion on URL-STRING, which is a partially-specified URL.
;; Tail-recursively calls one of the three procedure arguments, as
;; follows.  If URL-STRING has a unique completion, IF-UNIQUE is
;; called with that completion.  If URL-STRING has more than one
;; completion, IF-NOT-UNIQUE is called with two arguments: the first
;; argument is a prefix string that all of the completions share, and
;; the second argument is a thunk that returns a list of the
;; completions.  If URL-STRING has no completions, IF-NOT-FOUND is
;; called with no arguments.

;; See PARSE-URL-STRING for a description of GET-DEFAULT-URL.

(define (url-complete-string string get-default-url
			     if-unique if-not-unique if-not-found)
  (call-with-values (lambda () (url-completion-args string get-default-url))
    (lambda (body default-url prepend)
      (if default-url
	  (%url-complete-string body default-url
	    (lambda (body)
	      (if-unique (prepend body)))
	    (lambda (prefix get-completions)
	      (if-not-unique (prepend prefix)
			     (lambda () (map prepend (get-completions)))))
	    if-not-found)
	  (if-not-found)))))

(define-generic %url-complete-string
    (string default-url if-unique if-not-unique if-not-found))

;; Return a list of the completions for STRING.
;; See PARSE-URL-STRING for a description of GET-DEFAULT-URL.

(define (url-string-completions string get-default-url)
  (call-with-values (lambda () (url-completion-args string get-default-url))
    (lambda (body default-url prepend)
      (map prepend
	   (if default-url
	       (%url-string-completions body default-url)
	       '())))))

(define-generic %url-string-completions (string default-url))

(define (url-completion-args string get-default-url)
  (let ((colon (string-find-next-char string #\:))
	(make-prepend
	 (lambda (protocol)
	   (lambda (body)
	     (make-url-string protocol body)))))
    (if colon
	(let ((protocol (string-head string colon)))
	  (values (string-tail string (fix:+ colon 1))
		  (and (url-protocol-name? protocol)
		       (get-default-url protocol))
		  (make-prepend protocol)))
	(let ((url (get-default-url #f)))
	  (values string url (make-prepend (url-protocol url)))))))

;;;; Server operations

;; -------------------------------------------------------------------
;; Create a new resource named URL.  Signal an error if the resource
;; already exists or can't be created.

(define (create-resource url)
  (let ((folder (%create-resource url)))
    (container-modified! url 'CREATE-RESOURCE)
    folder))

(define-generic %create-resource (url))

;; -------------------------------------------------------------------
;; Delete the resource named URL.  Signal an error if the resource
;; doesn't exist or if it can't be deleted.

(define (delete-resource url)
  (%delete-resource url)
  (unmemoize-resource url)
  (container-modified! url 'DELETE-RESOURCE))

(define-generic %delete-resource (url))

;; -------------------------------------------------------------------
;; Rename the resource named URL to NEW-URL.  Signal an error if the
;; resource doesn't exist, if NEW-URL already refers to a resource, or if
;; the rename can't be performed for some reason.  This operation does
;; NOT do format conversion, or move a resource from one place to
;; another.  It only allows changing the name of an existing resource.

(define (rename-resource url new-url)
  (%rename-resource url new-url)
  (unmemoize-resource url)
  (container-modified! url 'DELETE-RESOURCE)
  (container-modified! new-url 'CREATE-RESOURCE))

(define-generic %rename-resource (url new-url))

;; -------------------------------------------------------------------
;; Insert a copy of MESSAGE in the folder referenced by URL at the end
;; of the existing messages.  Unspecified result.

(define (append-message message url)
  (if (%append-message message url)
      (container-modified! url 'CREATE-RESOURCE)))

(define-generic %append-message (message url))

;; -------------------------------------------------------------------
;; Keep a connection open to the server referenced by URL for the
;; dynamic extent of THUNK.

(define-generic with-open-connection (url thunk))

(define (container-modified! url type . arguments)
  (let ((container (get-memoized-resource (container-url url))))
    (if container
	(apply object-modified! container type url arguments))))

;; -------------------------------------------------------------------
;; Return a list of URLs referring to the contents of CONTAINER-URL.
;; The result can contain both folder and container URLs.
;; The result is not sorted.

(define-generic container-url-contents (container-url))

;;;; Resources

(define-class <resource> (<property-mixin> <modification-event-mixin>)
  (locator define accessor))

(define-method write-instance ((r <resource>) port)
  (write-instance-helper (resource-type-name r) r port
    (lambda ()
      (write-char #\space port)
      (write (url-content-name (resource-locator r)) port))))

(define-generic resource-type-name (resource))
(define-method resource-type-name ((r <resource>)) r 'RESOURCE)

(define-method url-protocol ((resource <resource>))
  (url-protocol (resource-locator resource)))

(define-method url-body ((resource <resource>))
  (url-body (resource-locator resource)))

(define-method container-url ((resource <resource>))
  (container-url (resource-locator resource)))

(define-method container-url-for-prompt ((resource <resource>))
  (container-url-for-prompt (resource-locator resource)))

(define-method url-content-name ((resource <resource>))
  (url-content-name (resource-locator resource)))

(define-method url-base-name ((resource <resource>))
  (url-base-name (resource-locator resource)))

(define-class <folder> (<resource>)
  (order define accessor
	 initial-value #f))

(define set-folder-order!
  (let ((modifier (slot-modifier <folder> 'ORDER)))
    (lambda (folder order)
      (if order (memoize-folder-order order folder))
      (let ((original-order (folder-order folder)))
        (modifier folder order)
        (cond ((and (not original-order) order)
               (receive-modification-events folder update-folder-order))
              ((and original-order (not order))
               (ignore-modification-events folder update-folder-order))))
      (object-modified! folder 'REORDERED))))

(define-class <container> (<resource>))

(define-method resource-type-name ((r <folder>)) r 'FOLDER)
(define-method resource-type-name ((r <container>)) r 'CONTAINER)

(define-method %append-message (message (folder <folder>))
  (%append-message message (resource-locator folder)))

(define-method make-content-url ((container <container>) name)
  (make-content-url (resource-locator container) name))

(define-method container-url-contents ((container <container>))
  (container-url-contents (resource-locator container)))

(define (guarantee-folder folder procedure)
  (if (not (folder? folder))
      (error:wrong-type-argument folder "IMAIL folder" procedure)))

(define (guarantee-container container procedure)
  (if (not (container? container))
      (error:wrong-type-argument container "IMAIL container" procedure)))

(define (maybe-make-resource url constructor)
  (or (get-memoized-resource url)
      (memoize-resource (constructor url))))

(define (get-memoized-resource url #!optional error?)
  (or (let ((resource (hash-table/get memoized-resources url #f)))
	(and resource
	     (let ((resource (weak-car resource)))
	       ;; Delete memoization _only_ if URL-EXISTS?
	       ;; unambiguously states non-existence.  An error is
	       ;; often transitory.
	       (if (and resource (ignore-errors (lambda () (url-exists? url))))
		   resource
		   (begin
		     (hash-table/remove! memoized-resources url)
		     #f)))))
      (and (if (default-object? error?) #f error?)
	   (error "URL has no associated resource:" url))))

(define (memoize-resource resource)
  (hash-table/put! memoized-resources
		   (resource-locator resource)
		   (weak-cons resource
			      (lambda (resource)
				(close-resource resource #t))))
  resource)

(define (unmemoize-resource url)
  (let ((r.c (hash-table/get memoized-resources url #f)))
    (if r.c
	(let ((resource (weak-car r.c)))
	  (if resource
	      (begin
		(let ((close (weak-cdr r.c)))
		  (if close
		      (close resource)))
		(hash-table/remove! memoized-resources url)))))))

(define (%unmemoize-resource url)
  (hash-table/remove! memoized-resources url))

(define memoized-resources
  (make-eq-hash-table))

;;;; Folder operations

;; -------------------------------------------------------------------
;; Open the resource named URL.

(define-generic open-resource (url))

(define (with-open-resource url procedure)
  (let ((resource #f))
    (dynamic-wind (lambda ()
		    (set! resource (open-resource url))
		    unspecific)
		  (lambda () (procedure resource))
		  (lambda ()
		    (let ((r resource))
		      (if r
			  (begin
			    (set! resource #f)
			    (close-resource r #f))))))))

;; -------------------------------------------------------------------
;; Close RESOURCE, freeing up connections, memory, etc.  Subsequent
;; use of the resource must work, but may incur a significant time or
;; space penalty.  NO-DEFER? means that the resource must be closed
;; immediately, and not deferred.

(define-generic close-resource (resource no-defer?))

;; -------------------------------------------------------------------
;; Return the number of messages in FOLDER.

(define-generic folder-length (folder))

;; -------------------------------------------------------------------
;; Get the INDEX'th message in FOLDER and return it.  Signal an
;; error for invalid INDEX.

(define (get-message folder index)
  (guarantee-index index 'GET-MESSAGE)
  (if (not (< index (folder-length folder)))
      (error:bad-range-argument index 'GET-MESSAGE))
  (%get-message folder (map-folder-index folder index)))

(define-generic %get-message (folder index))

;; -------------------------------------------------------------------
;; Remove all messages in FOLDER that are marked for deletion.
;; Unspecified result.

(define-generic expunge-deleted-messages (folder))

;; -------------------------------------------------------------------
;; Search FOLDER for messages matching CRITERIA.  At present, CRITERIA
;; may be a string.  Returns a list of message indices.

(define (search-folder folder criteria)
  (map (lambda (index)
         (unmap-folder-index folder index))
       (%search-folder folder criteria)))

(define-generic %search-folder (folder criteria))

;; -------------------------------------------------------------------
;; Compare FOLDER's cache with the persistent folder and return a
;; symbol indicating whether they are synchronized, as follows:
;; SYNCHRONIZED CACHE-MODIFIED PERSISTENT-MODIFIED BOTH-MODIFIED
;; PERSISTENT-DELETED UNSYNCHRONIZED

(define-generic folder-sync-status (folder))

;; -------------------------------------------------------------------
;; Save any cached changes made to RESOURCE.  Returns a boolean
;; indicating whether anything was saved.

(define-generic save-resource (resource))

;; -------------------------------------------------------------------
;; Discard cached contents of FOLDER.  Subsequent use of FOLDER will
;; reload contents from the persistent folder.

(define-generic discard-folder-cache (folder))

;; -------------------------------------------------------------------
;; Probe FOLDER's server for changes.  Useful as a check for new mail.

(define-generic probe-folder (folder))

;; -------------------------------------------------------------------
;; Return a symbol representing FOLDER's connection status.  The
;; returned value is one of the following symbols:
;; ONLINE	Open connection to the server.
;; OFFLINE	No connection to the server.
;; NO-SERVER	Folder is not server-based.

(define-generic folder-connection-status (folder))

;; -------------------------------------------------------------------
;; Disconnect FOLDER from its associated server.  The folder will
;; automatically reconnect as needed.

(define-generic disconnect-folder (folder))

;; -------------------------------------------------------------------
;; Preload outline information about each message in the folder.
;; Normally used prior to generating a folder summary, to accelerate
;; the downloading of this information from the server.  This
;; operation need not be implemented, as it is just a performance
;; enhancement.

(define-generic preload-folder-outlines (folder))

;;;; Message type

(define-class <message> (<property-mixin>)
  (header-fields define accessor)
  (flags define accessor)
  (folder define standard
	  initial-value #f)
  (index define standard
	 accessor %message-index
	 initial-value #f))

(define-method write-instance ((message <message>) port)
  (write-instance-helper 'MESSAGE message port
    (lambda ()
      (write-char #\space port)
      (write (message-folder message) port)
      (write-char #\space port)
      (write (%message-index message) port))))

(define (guarantee-message message procedure)
  (if (not (message? message))
      (error:wrong-type-argument message "IMAIL message" procedure)))

(define-generic write-message-body (message port))
(define-generic set-message-flags! (message flags))
(define-generic message-internal-time (message))
(define-generic message-length (message))

(define-generic message-body (message))
(define-method message-body ((message <message>))
  (let ((string (call-with-output-string
                  (lambda (output-port)
                    (write-message-body message output-port)))))
    (values string 0 (string-length string))))

(define (message-index message)
  (let ((index (%message-index message))
	(folder (message-folder message)))
    (if folder
	(unmap-folder-index folder index)
	index)))

(define %set-message-flags!
  (let ((modifier (slot-modifier <message> 'FLAGS)))
    (lambda (message flags)
      (modifier message flags)
      (let ((folder (message-folder message)))
	(if folder
	    (object-modified! folder 'FLAGS message))))))

(define (message-attached? message #!optional folder)
  (let ((folder (if (default-object? folder) #f folder)))
    (if folder
	(eq? folder (message-folder message))
	(message-folder message))))

(define (message-detached? message)
  (not (message-folder message)))

(define (attach-message! message folder index)
  (guarantee-folder folder 'ATTACH-MESSAGE!)
  (without-interrupts
   (lambda ()
     (set-message-folder! message folder)
     (set-message-index! message index))))

(define (detach-message! message)
  (set-message-folder! message #f))

(define (message->string message)
  (call-with-output-string
   (lambda (port)
     (write-header-fields (message-header-fields message) port)
     (write-message-body message port))))

(define (message-time message)
  (let ((date (get-first-header-field-value message "date" #f)))
    (and date
	 (parse-header-field-date date))))

;;;; Message Navigation

(define (first-unseen-message folder)
  (let ((end (folder-length folder)))
    (let loop
	((start
	  (if (folder-order folder)
	      0
	      (first-unseen-message-index folder))))
      (and (< start end)
	   (let ((message (get-message folder start)))
	     (if (message-seen? message)
		 (loop (+ start 1))
		 message))))))

(define-generic first-unseen-message-index (folder))

(define (first-message folder)
  (and (> (folder-length folder) 0)
       (get-message folder 0)))

(define (last-message folder)
  (let ((n (folder-length folder)))
    (and (> n 0)
	 (get-message folder (- n 1)))))

(define (previous-message message #!optional predicate)
  (let ((predicate
	 (if (or (default-object? predicate) (not predicate))
	     (lambda (message) message #t)
	     predicate))
	(folder (message-folder message)))
    (let loop ((index (message-index message)))
      (and (> index 0)
	   (let ((index (- index 1)))
	     (let ((message (get-message folder index)))
	       (if (predicate message)
		   message
		   (loop index))))))))

(define (next-message message #!optional predicate)
  (let ((predicate
	 (if (or (default-object? predicate) (not predicate))
	     (lambda (message) message #t)
	     predicate))
	(folder (message-folder message)))
    (let ((n (folder-length folder)))
      (let loop ((index (message-index message)))
	(let ((index (+ index 1)))
	  (and (< index n)
	       (let ((message (get-message folder index)))
		 (if (predicate message)
		     message
		     (loop index)))))))))

;;;; Folder orders

(define-structure (folder-order
		   (type-descriptor <folder-order>)
		   (constructor make-folder-order (predicate selector)))
  (predicate #f read-only #t)
  (selector #f read-only #t)
  (tree #f))

(define (map-folder-index folder index)
  (let ((order (folder-order folder)))
    (if order
	(begin
	  (memoize-folder-order order folder)
          (let ((tree (folder-order-tree order)))
            (if (< index (wt-tree/size tree))
                (%message-index (wt-tree/index-datum tree index))
                index)))
	index)))

(define (unmap-folder-index folder index)
  (let ((order (folder-order folder)))
    (if order
	(begin
	  (memoize-folder-order order folder)
          (or (wt-tree/rank (folder-order-tree order)
                            (cons ((folder-order-selector order)
                                   (%get-message folder index))
                                  index))
              index))
	index)))

(define (make-wt-message-tree key<?)
  (make-wt-tree
   (make-wt-tree-type
    (lambda (a b)
      (or (key<? (car a) (car b))
          (and (not (key<? (car b) (car a)))
               (< (cdr a) (cdr b))))))))

(define (message-order-key message)
  (let ((folder (message-folder message)))
    (if (not folder)
        (error "Message has no ordering key:" message))
    (let ((order (folder-order folder)))
      (if (not order)
          #f
          (cons ((folder-order-selector order) message)
                (%message-index message))))))

(define (memoize-folder-order order folder)
  (let loop ((modification-count (object-modification-count folder)))
    (if (not (folder-order-tree order))
        (begin
          (set-folder-order-tree!
           order
           (build-folder-order-tree order folder))
          (let ((modification-count* (object-modification-count folder)))
            (if (not (= modification-count modification-count*))
                (begin
                  (imail-ui:message "Folder changed; resorting")
                  (loop modification-count*))))))))

(define (build-folder-order-tree order folder)
  (preload-folder-outlines folder)
  ((imail-ui:message-wrapper "Sorting folder")
   (lambda ()
     (let ((length (folder-length folder))
           (selector (folder-order-selector order))
           (tree (make-wt-message-tree (folder-order-predicate order))))
       (do ((index 0 (+ index 1)))
           ((= index length))
         (if (zero? (remainder index 100))
             (imail-ui:progress-meter index #f))
         (let ((message (%get-message folder index)))
           (wt-tree/add! tree
                         (cons (selector message) index)
                         message)))
       tree))))

(define (update-folder-order folder modification-type arguments)
  (without-interrupts
   (lambda ()
     (let ((order (folder-order folder)))
       (if order
           (case modification-type
             ((SET-LENGTH)
              (set-folder-order-tree! order #f))
             ((INCREASE-LENGTH)
              (let ((tree (folder-order-tree order)))
                (if tree
                    (let ((index (car arguments))
                          (count (cadr arguments))
                          (selector (folder-order-selector order)))
                      (do ((index index (+ index 1)))
                          ((= index count))
                        (let ((message (%get-message folder index)))
                          (wt-tree/add! tree
                                        (cons (selector message) index)
                                        message)))))))
             ((EXPUNGE)
              (let ((tree (folder-order-tree order)))
                (if tree
                    (let ((key (cadr arguments)))
                      (wt-tree/delete! tree key)))))))))))

;;;; Message flags

;;; Flags are markers that can be attached to messages.  They indicate
;;; state about the message, such as whether it has been deleted,
;;; seen, etc.  A flag is represented by a string.

(define (message-flagged? message flag)
  (guarantee-message-flag flag 'MESSAGE-FLAGGED?)
  (flags-member? flag (message-flags message)))

(define (set-message-flag message flag)
  (guarantee-message-flag flag 'SET-MESSAGE-FLAG)
  (without-interrupts
   (lambda ()
     (let ((flags (message-flags message)))
       (if (not (flags-member? flag flags))
	   (set-message-flags! message (cons flag flags)))))))

(define (clear-message-flag message flag)
  (guarantee-message-flag flag 'SET-MESSAGE-FLAG)
  (without-interrupts
   (lambda ()
     (let ((flags (message-flags message)))
       (if (flags-member? flag flags)
	   (set-message-flags! message (flags-delete! flag flags)))))))

(define (folder-flags folder)
  (let ((n (folder-length folder)))
    (do ((index 0 (+ index 1))
	 (flags '() (append (message-flags (get-message folder index)) flags)))
	((= index n) (remove-duplicates flags string-ci=?)))))

(define flags-member? (member-procedure string-ci=?))
(define flags-add (add-member-procedure string-ci=?))
(define flags-delete (delete-member-procedure list-deletor string-ci=?))
(define flags-delete! (delete-member-procedure list-deletor! string-ci=?))

(define (message-flag? object)
  (header-field-name? object))

(define (guarantee-message-flag object procedure)
  (if (not (message-flag? object))
      (error:wrong-type-argument object "message flag" procedure)))

(define standard-message-flags
  '("answered" "deleted" "filed" "forwarded" "resent" "seen"))

(define (message-flags->header-field flags)
  (make-header-field message-flags:name
		     (decorated-string-append "" " " "" flags)))

(define (header-field->message-flags header)
  (and (string-ci=? message-flags:name (header-field-name header))
       ;; Extra pair needed to distinguish #F from ().
       (cons #f
	     (burst-string (header-field-value header)
			   char-set:whitespace
			   #t))))

(define message-flags:name "X-IMAIL-FLAGS")

(define (parse-imail-header-fields headers)
  (let loop ((headers headers) (headers* '()) (flags '()))
    (cond ((not (pair? headers))
	   (values (reverse! headers*)
		   (remove-duplicates! (reverse! flags) string-ci=?)))
	  ((header-field->message-flags (car headers))
	   => (lambda (flags*)
		(loop (cdr headers)
		      headers*
		      (append! (reverse! (cdr flags*)) flags))))
	  (else
	   (loop (cdr headers)
		 (cons (car headers) headers*)
		 flags)))))

(define (message-deleted? msg) (message-flagged? msg "deleted"))
(define (message-undeleted? msg) (not (message-flagged? msg "deleted")))
(define (delete-message msg) (set-message-flag msg "deleted"))
(define (undelete-message msg) (clear-message-flag msg "deleted"))

(define (message-answered? msg) (message-flagged? msg "answered"))
(define (message-unanswered? msg) (not (message-flagged? msg "answered")))
(define (message-answered msg) (set-message-flag msg "answered"))
(define (message-not-answered msg) (clear-message-flag msg "answered"))

(define (message-seen? msg) (message-flagged? msg "seen"))
(define (message-unseen? msg) (not (message-flagged? msg "seen")))
(define (message-seen msg) (set-message-flag msg "seen"))
(define (message-not-seen msg) (clear-message-flag msg "seen"))

(define (message-filed? msg) (message-flagged? msg "filed"))
(define (message-unfiled? msg) (not (message-flagged? msg "filed")))
(define (message-filed msg) (set-message-flag msg "filed"))
(define (message-not-filed msg) (clear-message-flag msg "filed"))

(define (message-forwarded? msg) (message-flagged? msg "forwarded"))
(define (message-not-forwarded? msg) (not (message-flagged? msg "forwarded")))
(define (message-forwarded msg) (set-message-flag msg "forwarded"))
(define (message-not-forwarded msg) (clear-message-flag msg "forwarded"))

(define (message-resent? msg) (message-flagged? msg "resent"))
(define (message-not-resent? msg) (not (message-flagged? msg "resent")))
(define (message-resent msg) (set-message-flag msg "resent"))
(define (message-not-resent msg) (clear-message-flag msg "resent"))

;;;; Header fields

(define-structure (header-field
		   (type-descriptor <header-field>)
		   (safe-accessors #t)
		   (constructor #f)
		   (print-procedure
		    (standard-unparser-method 'HEADER-FIELD
		      (lambda (header port)
			(write-char #\space port)
			(write (header-field-name header) port)))))
  (name #f read-only #t)
  (value #f read-only #t))

(define make-header-field
  (let ((constructor (record-constructor <header-field>)))
    (lambda (name value)
      (guarantee-header-field-name name 'MAKE-HEADER-FIELD)
      (constructor name value))))

(define (guarantee-header-field-name object procedure)
  (if (not (header-field-name? object))
      (error:wrong-type-argument object "header-field name" procedure)))

(define (header-field-name? object)
  (and (string? object)
       (rfc822:header-field-name? object 0 (string-length object))))

(define copy-header-field
  copy-record)

(define (->header-fields object)
  (cond ((or (pair? object) (null? object)) object)
	((message? object) (message-header-fields object))
	((string? object) (string->header-fields object))
	(else (error:wrong-type-argument object "header fields" #f))))

(define (encode-header-fields headers receiver)
  (for-each (lambda (header) (encode-header-field header receiver)) headers)
  (receiver "\n" 0 1))

(define (encode-header-field header receiver)
  (let ((name (header-field-name header)))
    (receiver name 0 (string-length name)))
  (receiver ": " 0 2)
  (encode-header-field-value (header-field-value header) receiver)
  (receiver "\n" 0 1))

(define (encode-header-field-value value receiver)
  (let ((end (string-length value)))
    (let loop ((start 0))
      (let ((index (substring-find-next-char value start end #\newline)))
	(if index
	    (let ((index (fix:+ index 1)))
	      (receiver value start index)
	      (receiver "\t" 0 1)
	      (loop index))
	    (receiver value start end))))))

(define (header-field-length header)
  (let ((value (header-field-value header)))
    (+ (string-length (header-field-name header))
       (string-length value)
       (string-n-newlines value)
       3)))

(define (write-header-fields headers port)
  (encode-header-fields headers
    (lambda (string start end)
      (write-substring string start end port))))

(define (write-header-field header port)
  (encode-header-field header
    (lambda (string start end)
      (write-substring string start end port))))

(define (header-fields->string headers)
  (call-with-output-string
   (lambda (port)
     (write-header-fields headers port))))

(define (header-field->string header)
  (call-with-output-string
   (lambda (port)
     (write-header-field header port))))

(define (header-field-value->string value)
  (call-with-output-string
   (lambda (port)
     (encode-header-field-value value
       (lambda (string start end)
	 (write-substring string start end port))))))

(define (get-first-header-field headers name error?)
  (let loop ((headers (->header-fields headers)))
    (cond ((pair? headers)
	   (if (string-ci=? name (header-field-name (car headers)))
	       (car headers)
	       (loop (cdr headers))))
	  (error? (error:bad-range-argument name 'GET-FIRST-HEADER-FIELD))
	  (else #f))))

(define (get-last-header-field headers name error?)
  (let loop ((headers (->header-fields headers)) (winner #f))
    (cond ((pair? headers)
	   (loop (cdr headers)
		 (if (string-ci=? name (header-field-name (car headers)))
		     (car headers)
		     winner)))
	  ((and (not winner) error?)
	   (error:bad-range-argument name 'GET-LAST-HEADER-FIELD))
	  (else winner))))

(define (get-all-header-fields headers name)
  (list-transform-positive (->header-fields headers)
    (lambda (header)
      (string-ci=? name (header-field-name header)))))

(define (get-first-header-field-value headers name error?)
  (let ((header (get-first-header-field headers name error?)))
    (and header
	 (header-field-value header))))

(define (get-last-header-field-value headers name error?)
  (let ((header (get-last-header-field headers name error?)))
    (and header
	 (header-field-value header))))

(define (get-all-header-field-values headers name)
  (map header-field-value (get-all-header-fields headers name)))

(define (parse-first-named-header headers name default parser)
  (cond ((get-first-header-field-value headers name #f)
         => (header-parser parser name default))
        (else default)))

(define (parse-last-named-header headers name default parser)
  (cond ((get-last-header-field-value headers name #f)
         => (header-parser parser name default))
        (else default)))

(define (parse-all-named-headers headers name default parser)
  (map (header-parser parser name default)
       (get-all-header-field-values headers name)))

(define-integrable (header-parser parser name default)
  (lambda (value)
    (or (parser value)
        (begin
          (warn (string-append "Malformed " name " field value:")
                value)
          default))))

(define (string->header-fields string)
  (lines->header-fields (string->lines string)))

(define (lines->header-fields lines)
  (let find-initial ((lines lines) (headers '()))
    (cond ((or (not (pair? lines))
	       (string-null? (car lines)))
	   (reverse! headers))
	  ((header-field-initial-line? (car lines))
	   (let collect-group ((lines (cdr lines)) (group (list (car lines))))
	     (if (or (not (pair? lines))
		     (string-null? (car lines))
		     (header-field-initial-line? (car lines)))
		 (find-initial
		  lines
		  (cons
		   (let ((lines (reverse! group)))
		     (let ((colon
			    (and (pair? lines)
				 (string-find-next-char (car lines) #\:))))
		       (if (not colon)
			   (error "Malformed header-field lines:" lines))
		       (make-header-field
			(string-head (car lines) colon)
			(decorated-string-append
			 "" "\n" ""
			 (map string-trim
			      (cons (string-tail (car lines) (fix:+ colon 1))
				    (cdr lines)))))))
		   headers))
		 (collect-group (cdr lines) (cons (car lines) group)))))
	  (else
	   (find-initial (cdr lines) headers)))))

(define (header-field-initial-line? line)
  (let ((colon (string-find-next-char line #\:)))
    (and colon
	 (rfc822:header-field-name? line 0 colon))))

;;;; MIME structure

(define-generic mime-message-body-structure (message))
(define-generic write-mime-message-body-part (message selector cache? port))

(define-class <mime-body> (<property-mixin>)
  (parameters define accessor)
  (disposition define accessor)
  (language define accessor)
  (enclosure define standard initial-value #f))

(define-generic mime-body-type (body))
(define-generic mime-body-subtype (body))

(define (mime-body-type-string body)
  (string-append (symbol->string (mime-body-type body))
		 "/"
		 (symbol->string (mime-body-subtype body))))

(define (mime-body-parameter body key default)
  (let ((entry (assq key (mime-body-parameters body))))
    (if entry
	(cdr entry)
	default)))

(define (mime-body-disposition-filename body)
  (let ((disposition (mime-body-disposition body)))
    (and disposition
	 (let ((entry (assq 'FILENAME (cdr disposition))))
	   (and entry
		(cdr entry))))))

(define-method write-instance ((body <mime-body>) port)
  (write-instance-helper 'MIME-BODY body port
    (lambda ()
      (write-char #\space port)
      (write-string (mime-body-type-string body) port))))

(define (mime-body-enclosed? b1 b2)
  (or (eq? b1 b2)
      (let ((enclosure (mime-body-enclosure b1)))
	(and enclosure
	     (mime-body-enclosed? enclosure b2)))))

(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))

;;;; MIME Encoding Registry
;;; This should probably be moved to the runtime's MIME codec package.

(define-structure (mime-encoding
                   (conc-name mime-encoding/)
                   (print-procedure
                    (standard-unparser-method 'MIME-ENCODING
                      (lambda (encoding output-port)
                        (write-char #\space output-port)
                        (write (mime-encoding/name encoding) output-port))))
                   (constructor %make-mime-encoding))
  (name                          #f read-only #t)
  (identity?                     #f read-only #t)
  (encoder-initializer           #f read-only #t)
  (encoder-finalizer             #f read-only #t)
  (encoder-updater               #f read-only #t)
  (decoder-initializer           #f read-only #t)
  (decoder-finalizer             #f read-only #t)
  (decoder-updater               #f read-only #t)
  (decoding-port-maker           #f read-only #t)
  (caller-with-decoding-port     #f read-only #t))

(define-guarantee mime-encoding "MIME codec")

(define mime-encodings
  (make-eq-hash-table))

(define (define-mime-encoding name
			      encode:initialize encode:finalize encode:update
			      decode:initialize decode:finalize decode:update
			      make-port call-with-port)
  (hash-table/put!
   mime-encodings
   name
   (%make-mime-encoding name #f
			encode:initialize encode:finalize encode:update
			decode:initialize decode:finalize decode:update
			make-port call-with-port))
  name)

(define (define-identity-mime-encoding name)
  (hash-table/put! mime-encodings
		   name
		   (%make-mime-encoding name #t

					(lambda (port text?) text? port)
					output-port/flush-output
					output-port/write-string

					(lambda (port text?) text? port)
					output-port/flush-output
					output-port/write-string

					(lambda (port text?) text? port)
					(lambda (port text? generator)
					  text?
					  (generator port)))))

(define (named-mime-encoding name)
  (or (hash-table/get mime-encodings name #f)
      (let ((encoding (make-unknown-mime-encoding name)))
	(hash-table/put! mime-encodings name encoding)
	encoding)))

(define (make-unknown-mime-encoding name)
  (let ((lose (lambda args args (error "Unknown MIME encoding name:" name))))
    (%make-mime-encoding name #f
			 lose lose lose
			 lose lose lose
			 lose lose)))

(define (call-with-mime-decoding-output-port encoding port text? generator)
  ((mime-encoding/caller-with-decoding-port
    (if (symbol? encoding)
	(named-mime-encoding encoding)
	(begin
	  (guarantee-mime-encoding encoding
				   'CALL-WITH-MIME-DECODING-OUTPUT-PORT)
	  encoding)))
   port text? generator))

(define-identity-mime-encoding '7BIT)
(define-identity-mime-encoding '8BIT)
(define-identity-mime-encoding 'BINARY)
;; Next two are random values sometimes used by Outlook.
(define-identity-mime-encoding '7-BIT)
(define-identity-mime-encoding '8-BIT)

(define-mime-encoding 'QUOTED-PRINTABLE
  encode-quoted-printable:initialize
  encode-quoted-printable:finalize
  encode-quoted-printable:update
  decode-quoted-printable:initialize
  decode-quoted-printable:finalize
  decode-quoted-printable:update
  make-decode-quoted-printable-port
  call-with-decode-quoted-printable-output-port)

(define-mime-encoding 'BASE64
  encode-base64:initialize
  encode-base64:finalize
  encode-base64:update
  decode-base64:initialize
  decode-base64:finalize
  decode-base64:update
  make-decode-base64-port
  call-with-decode-base64-output-port)

(define-mime-encoding 'BINHEX40
  #f #f #f                              ;No BinHex encoder.
  decode-binhex40:initialize
  decode-binhex40:finalize
  decode-binhex40:update
  make-decode-binhex40-port
  call-with-decode-binhex40-output-port)
