home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / imail / imail-core.scm < prev    next >
Text File  |  2001-06-11  |  38KB  |  1,078 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: imail-core.scm,v 1.144 2001/06/12 00:47:19 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; License, or (at your option) any later version.
  11. ;;;
  12. ;;; This program is distributed in the hope that it will be useful,
  13. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;;; General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with this program; if not, write to the Free Software
  19. ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20. ;;; 02111-1307, USA.
  21.  
  22. ;;;; IMAIL mail reader: core definitions
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;;; Properties
  27.  
  28. (define-class <property-mixin> ()
  29.   (alist define (accessor modifier)
  30.      accessor object-properties
  31.      modifier set-object-properties!
  32.      initial-value '()))
  33.  
  34. (define (get-property object key default)
  35.   (let ((entry (assq key (object-properties object))))
  36.     (if entry
  37.     (cdr entry)
  38.     default)))
  39.  
  40. (define (store-property! object key datum)
  41.   (let ((alist (object-properties object)))
  42.     (let ((entry (assq key alist)))
  43.       (if entry
  44.       (set-cdr! entry datum)
  45.       (set-object-properties! object (cons (cons key datum) alist))))))
  46.  
  47. (define (remove-property! object key)
  48.   (set-object-properties! object (del-assq! key (object-properties object))))
  49.  
  50. ;;;; Modification events
  51.  
  52. (define-class <modification-event-mixin> ()
  53.   (modification-count define (accessor modifier)
  54.               accessor object-modification-count
  55.               modifier set-object-modification-count!
  56.               initial-value 0)
  57.   (modification-event define accessor
  58.               accessor object-modification-event
  59.               initializer make-event-distributor))
  60.  
  61. (define (receive-modification-events object procedure)
  62.   (add-event-receiver! (object-modification-event object) procedure))
  63.  
  64. (define (ignore-modification-events object procedure)
  65.   (remove-event-receiver! (object-modification-event object) procedure))
  66.  
  67. (define (object-modified! object type . arguments)
  68.   (without-interrupts
  69.    (lambda ()
  70.      (set-object-modification-count!
  71.       object
  72.       (+ (object-modification-count object) 1))))
  73.   (apply signal-modification-event object type arguments))
  74.  
  75. (define (signal-modification-event object type . arguments)
  76.   (if *deferred-modification-events*
  77.       (set-cdr! *deferred-modification-events*
  78.         (cons (cons* object type arguments)
  79.               (cdr *deferred-modification-events*)))
  80.       (begin
  81.     (if imap-trace-port
  82.         (begin
  83.           (write-line (cons* 'OBJECT-EVENT object type arguments)
  84.               imap-trace-port)
  85.           (flush-output imap-trace-port)))
  86.     (event-distributor/invoke! (object-modification-event object)
  87.                    object
  88.                    type
  89.                    arguments))))
  90.  
  91. (define (with-modification-events-deferred thunk)
  92.   (let ((events (list 'EVENTS)))
  93.     (let ((v
  94.        (fluid-let ((*deferred-modification-events* events))
  95.          (thunk))))
  96.       (for-each (lambda (event) (apply signal-modification-event event))
  97.         (reverse! (cdr events)))
  98.       v)))
  99.  
  100. (define *deferred-modification-events* #f)
  101.  
  102. ;;;; URL type
  103.  
  104. (define-class <url> (<property-mixin>)
  105.   (container initial-value 'UNKNOWN))
  106.  
  107. (define-class <folder-url> (<url>))
  108. (define-class <container-url> (<url>))
  109.  
  110. (define (guarantee-url url procedure)
  111.   (if (not (url? url))
  112.       (error:wrong-type-argument url "IMAIL URL" procedure)))
  113.  
  114. ;; Return the canonical name of URL's protocol as a string.
  115. (define-generic url-protocol (url))
  116.  
  117. ;; Return the body of URL as a string.
  118. (define-generic url-body (url))
  119.  
  120. (define (make-url-string protocol body)
  121.   (string-append protocol ":" body))
  122.  
  123. (define (url->string url)
  124.   (make-url-string (url-protocol url) (url-body url)))
  125.  
  126. (define-method write-instance ((url <url>) port)
  127.   (write-instance-helper 'URL url port
  128.     (lambda ()
  129.       (write-char #\space port)
  130.       (write (url->string url) port))))
  131.  
  132. ;; Return #T iff URL represents an existing folder.
  133. (define-generic url-exists? (url))
  134.  
  135. ;; Return #T iff FOLDER-URL both exists and can be opened.
  136. (define-generic folder-url-is-selectable? (folder-url))
  137.  
  138. ;; If URL can potentially contain other resources, return a container
  139. ;; URL for the same resource.  Otherwise return #F.  The result is
  140. ;; undefined if the URL doesn't represent an existing folder.
  141. (define-generic url-corresponding-container (url))
  142. (define-method url-corresponding-container ((url <container-url>)) url)
  143.  
  144. ;; Return a locator for the container of URL.  E.g. the container URL
  145. ;; of "imap://localhost/inbox/foo" is "imap://localhost/inbox/".
  146. (define-generic container-url (url))
  147. (add-method container-url (slot-accessor-method <url> 'CONTAINER))
  148.  
  149. ;; Like CONTAINER-URL except that the returned container URL is
  150. ;; allowed to be different from the true container URL when this
  151. ;; results in a better prompt.
  152. ;;
  153. ;; For example, when URL is "imap://localhost/inbox" and the IMAP
  154. ;; server is Cyrus, this will return "imap://localhost/inbox/".
  155. (define-generic container-url-for-prompt (url))
  156.  
  157. ;; Return the content name of a URL.  The content name of a URL is the
  158. ;; suffix of the URL that uniquely identifies the resource with
  159. ;; respect to its container.
  160. ;;
  161. ;; Here are some examples:
  162. ;;
  163. ;; URL                    content name
  164. ;; ---------------------------        ------------
  165. ;; imap://localhost/inbox/foo        foo
  166. ;; imap://localhost/inbox/foo/        foo/
  167. ;; file:/usr/home/cph/foo.mail        foo.mail
  168. (define-generic url-content-name (url))
  169.  
  170. ;; Return a URL that refers to the content NAME of the container
  171. ;; referred to by CONTAINER-URL.
  172. (define-generic make-content-url (container-url name))
  173.  
  174. ;; Return the base name of FOLDER-URL.  This is the content name of
  175. ;; FOLDER-URL, but presented in a type-independent way.  For example,
  176. ;; if the content name of a file URL is "foo.mail", the base name is
  177. ;; just "foo".
  178. (define-generic url-base-name (folder-url))
  179.  
  180. ;; Return a string that uniquely identifies the server and account for
  181. ;; URL.  E.g. for IMAP this could be the URL string without the
  182. ;; mailbox information.  This string will be included in the
  183. ;; pass-phrase prompt, and also used as a key for memoization.
  184. (define-generic url-pass-phrase-key (url))
  185.  
  186. ;; Convert STRING to a URL.  GET-DEFAULT-URL is a procedure of one
  187. ;; argument that returns a URL that is used to fill in defaults if
  188. ;; STRING is a specification for a partial URL.  GET-DEFAULT-URL is
  189. ;; called with #F as its first argument to return a default URL to be
  190. ;; used if STRING doesn't explicitly specify a protocol.  Otherwise,
  191. ;; it is called with a protocol name as its first argument to return a
  192. ;; protocol-specific default.
  193. (define (parse-url-string string get-default-url)
  194.   (let ((colon (string-find-next-char string #\:)))
  195.     (if colon
  196.     (parse-url-body (string-tail string (fix:+ colon 1))
  197.             (get-default-url (string-head string colon)))
  198.     (parse-url-body string (get-default-url #f)))))
  199.  
  200. ;; Protocol-specific parsing.  Dispatch on the class of DEFAULT-URL.
  201. ;; Each method is responsible for calling INTERN-URL on the result of
  202. ;; the parse, and returning the interned URL.  Illegal syntax in
  203. ;; STRING must cause an error to be signalled.
  204. (define-generic parse-url-body (string default-url))
  205.  
  206. (define intern-url
  207.   (let ((modifier (slot-modifier <url> 'CONTAINER)))
  208.     (lambda (url compute-container)
  209.       (let ((string (url->string url)))
  210.     (or (hash-table/get interned-urls string #f)
  211.         (begin
  212.           (let ((finished? #f))
  213.         (dynamic-wind
  214.          (lambda ()
  215.            (hash-table/put! interned-urls string url))
  216.          (lambda ()
  217.            (modifier url (compute-container url))
  218.            (set! finished? #t)
  219.            unspecific)
  220.          (lambda ()
  221.            (if (not finished?)
  222.                (hash-table/remove! interned-urls string)))))
  223.           url))))))
  224.  
  225. (define interned-urls
  226.   (make-string-hash-table))
  227.  
  228. (define (define-url-protocol name class)
  229.   (define-method url-protocol ((url class)) url name)
  230.   (hash-table/put! url-protocols (string-downcase name) class))
  231.  
  232. (define (url-protocol-name? name)
  233.   (hash-table/get url-protocols (string-downcase name) #f))
  234.  
  235. (define url-protocols
  236.   (make-string-hash-table))
  237.  
  238. (define (url-presentation-name url)
  239.   (let ((name (url-content-name url)))
  240.     (if (string-suffix? "/" name)
  241.     (string-head name (fix:- (string-length name) 1))
  242.     name)))
  243.  
  244. ;; Do completion on URL-STRING, which is a partially-specified URL.
  245. ;; Tail-recursively calls one of the three procedure arguments, as
  246. ;; follows.  If URL-STRING has a unique completion, IF-UNIQUE is
  247. ;; called with that completion.  If URL-STRING has more than one
  248. ;; completion, IF-NOT-UNIQUE is called with two arguments: the first
  249. ;; argument is a prefix string that all of the completions share, and
  250. ;; the second argument is a thunk that returns a list of the
  251. ;; completions.  If URL-STRING has no completions, IF-NOT-FOUND is
  252. ;; called with no arguments.
  253.  
  254. ;; See PARSE-URL-STRING for a description of GET-DEFAULT-URL.
  255.  
  256. (define (url-complete-string string get-default-url
  257.                  if-unique if-not-unique if-not-found)
  258.   (call-with-values (lambda () (url-completion-args string get-default-url))
  259.     (lambda (body default-url prepend)
  260.       (if default-url
  261.       (%url-complete-string body default-url
  262.         (lambda (body)
  263.           (if-unique (prepend body)))
  264.         (lambda (prefix get-completions)
  265.           (if-not-unique (prepend prefix)
  266.                  (lambda () (map prepend (get-completions)))))
  267.         if-not-found)
  268.       (if-not-found)))))
  269.  
  270. (define-generic %url-complete-string
  271.     (string default-url if-unique if-not-unique if-not-found))
  272.  
  273. ;; Return a list of the completions for STRING.
  274. ;; See PARSE-URL-STRING for a description of GET-DEFAULT-URL.
  275.  
  276. (define (url-string-completions string get-default-url)
  277.   (call-with-values (lambda () (url-completion-args string get-default-url))
  278.     (lambda (body default-url prepend)
  279.       (map prepend
  280.        (if default-url
  281.            (%url-string-completions body default-url)
  282.            '())))))
  283.  
  284. (define-generic %url-string-completions (string default-url))
  285.  
  286. (define (url-completion-args string get-default-url)
  287.   (let ((colon (string-find-next-char string #\:))
  288.     (make-prepend
  289.      (lambda (protocol)
  290.        (lambda (body)
  291.          (make-url-string protocol body)))))
  292.     (if colon
  293.     (let ((protocol (string-head string colon)))
  294.       (values (string-tail string (fix:+ colon 1))
  295.           (and (url-protocol-name? protocol)
  296.                (get-default-url protocol))
  297.           (make-prepend protocol)))
  298.     (let ((url (get-default-url #f)))
  299.       (values string url (make-prepend (url-protocol url)))))))
  300.  
  301. ;;;; Server operations
  302.  
  303. ;; -------------------------------------------------------------------
  304. ;; Create a new resource named URL.  Signal an error if the resource
  305. ;; already exists or can't be created.
  306.  
  307. (define (create-resource url)
  308.   (let ((folder (%create-resource url)))
  309.     (container-modified! url 'CREATE-RESOURCE)
  310.     folder))
  311.  
  312. (define-generic %create-resource (url))
  313.  
  314. ;; -------------------------------------------------------------------
  315. ;; Delete the resource named URL.  Signal an error if the resource
  316. ;; doesn't exist or if it can't be deleted.
  317.  
  318. (define (delete-resource url)
  319.   (%delete-resource url)
  320.   (unmemoize-resource url)
  321.   (container-modified! url 'DELETE-RESOURCE))
  322.  
  323. (define-generic %delete-resource (url))
  324.  
  325. ;; -------------------------------------------------------------------
  326. ;; Rename the resource named URL to NEW-URL.  Signal an error if the
  327. ;; resource doesn't exist, if NEW-URL already refers to a resource, or if
  328. ;; the rename can't be performed for some reason.  This operation does
  329. ;; NOT do format conversion, or move a resource from one place to
  330. ;; another.  It only allows changing the name of an existing resource.
  331.  
  332. (define (rename-resource url new-url)
  333.   (%rename-resource url new-url)
  334.   (unmemoize-resource url)
  335.   (container-modified! url 'DELETE-RESOURCE)
  336.   (container-modified! new-url 'CREATE-RESOURCE))
  337.  
  338. (define-generic %rename-resource (url new-url))
  339.  
  340. ;; -------------------------------------------------------------------
  341. ;; Insert a copy of MESSAGE in the folder referenced by URL at the end
  342. ;; of the existing messages.  Unspecified result.
  343.  
  344. (define (append-message message url)
  345.   (if (%append-message message url)
  346.       (container-modified! url 'CREATE-RESOURCE)))
  347.  
  348. (define-generic %append-message (message url))
  349.  
  350. ;; -------------------------------------------------------------------
  351. ;; Keep a connection open to the server referenced by URL for the
  352. ;; dynamic extent of THUNK.
  353.  
  354. (define-generic with-open-connection (url thunk))
  355.  
  356. (define (container-modified! url type . arguments)
  357.   (let ((container (get-memoized-resource (container-url url))))
  358.     (if container
  359.     (apply object-modified! container type url arguments))))
  360.  
  361. ;; -------------------------------------------------------------------
  362. ;; Return a list of URLs referring to the contents of CONTAINER-URL.
  363. ;; The result can contain both folder and container URLs.
  364. ;; The result is not sorted.
  365.  
  366. (define-generic container-url-contents (container-url))
  367.  
  368. ;;;; Resources
  369.  
  370. (define-class <resource> (<property-mixin> <modification-event-mixin>)
  371.   (locator define accessor))
  372.  
  373. (define-method write-instance ((r <resource>) port)
  374.   (write-instance-helper (resource-type-name r) r port
  375.     (lambda ()
  376.       (write-char #\space port)
  377.       (write (url-content-name (resource-locator r)) port))))
  378.  
  379. (define-generic resource-type-name (resource))
  380. (define-method resource-type-name ((r <resource>)) r 'RESOURCE)
  381.  
  382. (define-method url-protocol ((resource <resource>))
  383.   (url-protocol (resource-locator resource)))
  384.  
  385. (define-method url-body ((resource <resource>))
  386.   (url-body (resource-locator resource)))
  387.  
  388. (define-method container-url ((resource <resource>))
  389.   (container-url (resource-locator resource)))
  390.  
  391. (define-method container-url-for-prompt ((resource <resource>))
  392.   (container-url-for-prompt (resource-locator resource)))
  393.  
  394. (define-method url-content-name ((resource <resource>))
  395.   (url-content-name (resource-locator resource)))
  396.  
  397. (define-method url-base-name ((resource <resource>))
  398.   (url-base-name (resource-locator resource)))
  399.  
  400. (define-class <folder> (<resource>))
  401. (define-class <container> (<resource>))
  402.  
  403. (define-method resource-type-name ((r <folder>)) r 'FOLDER)
  404. (define-method resource-type-name ((r <container>)) r 'CONTAINER)
  405.  
  406. (define-method %append-message (message (folder <folder>))
  407.   (%append-message message (resource-locator folder)))
  408.  
  409. (define-method make-content-url ((container <container>) name)
  410.   (make-content-url (resource-locator container) name))
  411.  
  412. (define-method container-url-contents ((container <container>))
  413.   (container-url-contents (resource-locator container)))
  414.  
  415. (define (guarantee-folder folder procedure)
  416.   (if (not (folder? folder))
  417.       (error:wrong-type-argument folder "IMAIL folder" procedure)))
  418.  
  419. (define (guarantee-container container procedure)
  420.   (if (not (container? container))
  421.       (error:wrong-type-argument container "IMAIL container" procedure)))
  422.  
  423. (define (maybe-make-resource url constructor)
  424.   (or (get-memoized-resource url)
  425.       (memoize-resource (constructor url))))
  426.  
  427. (define (get-memoized-resource url #!optional error?)
  428.   (or (let ((resource (hash-table/get memoized-resources url #f)))
  429.     (and resource
  430.          (let ((resource (weak-car resource)))
  431.            ;; Delete memoization _only_ if URL-EXISTS?
  432.            ;; unambiguously states non-existence.  An error is
  433.            ;; often transitory.
  434.            (if (and resource (ignore-errors (lambda () (url-exists? url))))
  435.            resource
  436.            (begin
  437.              (hash-table/remove! memoized-resources url)
  438.              #f)))))
  439.       (and (if (default-object? error?) #f error?)
  440.        (error "URL has no associated resource:" url))))
  441.  
  442. (define (memoize-resource resource)
  443.   (hash-table/put! memoized-resources
  444.            (resource-locator resource)
  445.            (weak-cons resource
  446.                   (lambda (resource)
  447.                 (close-resource resource #t))))
  448.   resource)
  449.  
  450. (define (unmemoize-resource url)
  451.   (let ((r.c (hash-table/get memoized-resources url #f)))
  452.     (if r.c
  453.     (let ((resource (weak-car r.c)))
  454.       (if resource
  455.           (begin
  456.         (let ((close (weak-cdr r.c)))
  457.           (if close
  458.               (close resource)))
  459.         (hash-table/remove! memoized-resources url)))))))
  460.  
  461. (define (%unmemoize-resource url)
  462.   (hash-table/remove! memoized-resources url))
  463.  
  464. (define memoized-resources
  465.   (make-eq-hash-table))
  466.  
  467. ;;;; Folder operations
  468.  
  469. ;; -------------------------------------------------------------------
  470. ;; Open the resource named URL.
  471.  
  472. (define-generic open-resource (url))
  473.  
  474. (define (with-open-resource url procedure)
  475.   (let ((resource #f))
  476.     (dynamic-wind (lambda ()
  477.             (set! resource (open-resource url))
  478.             unspecific)
  479.           (lambda () (procedure resource))
  480.           (lambda ()
  481.             (let ((r resource))
  482.               (if r
  483.               (begin
  484.                 (set! resource #f)
  485.                 (close-resource r #f))))))))
  486.  
  487. ;; -------------------------------------------------------------------
  488. ;; Close RESOURCE, freeing up connections, memory, etc.  Subsequent
  489. ;; use of the resource must work, but may incur a significant time or
  490. ;; space penalty.  NO-DEFER? means that the resource must be closed
  491. ;; immediately, and not deferred.
  492.  
  493. (define-generic close-resource (resource no-defer?))
  494.  
  495. ;; -------------------------------------------------------------------
  496. ;; Return the number of messages in FOLDER.
  497.  
  498. (define-generic folder-length (folder))
  499.  
  500. ;; -------------------------------------------------------------------
  501. ;; Get the INDEX'th message in FOLDER and return it.  Signal an
  502. ;; error for invalid INDEX.
  503.  
  504. (define (get-message folder index)
  505.   (guarantee-index index 'GET-MESSAGE)
  506.   (if (not (< index (folder-length folder)))
  507.       (error:bad-range-argument index 'GET-MESSAGE))
  508.   (%get-message folder index))
  509.  
  510. (define-generic %get-message (folder index))
  511.  
  512. ;; -------------------------------------------------------------------
  513. ;; Remove all messages in FOLDER that are marked for deletion.
  514. ;; Unspecified result.
  515.  
  516. (define-generic expunge-deleted-messages (folder))
  517.  
  518. ;; -------------------------------------------------------------------
  519. ;; Search FOLDER for messages matching CRITERIA.  At present, CRITERIA
  520. ;; may be a string.  Returns a list of messages.
  521.  
  522. (define-generic search-folder (folder criteria))
  523.  
  524. ;; -------------------------------------------------------------------
  525. ;; Compare FOLDER's cache with the persistent folder and return a
  526. ;; symbol indicating whether they are synchronized, as follows:
  527. ;; SYNCHRONIZED CACHE-MODIFIED PERSISTENT-MODIFIED BOTH-MODIFIED
  528. ;; PERSISTENT-DELETED UNSYNCHRONIZED
  529.  
  530. (define-generic folder-sync-status (folder))
  531.  
  532. ;; -------------------------------------------------------------------
  533. ;; Save any cached changes made to RESOURCE.  Returns a boolean
  534. ;; indicating whether anything was saved.
  535.  
  536. (define-generic save-resource (resource))
  537.  
  538. ;; -------------------------------------------------------------------
  539. ;; Discard cached contents of FOLDER.  Subsequent use of FOLDER will
  540. ;; reload contents from the persistent folder.
  541.  
  542. (define-generic discard-folder-cache (folder))
  543.  
  544. ;; -------------------------------------------------------------------
  545. ;; Probe FOLDER's server for changes.  Useful as a check for new mail.
  546.  
  547. (define-generic probe-folder (folder))
  548.  
  549. ;; -------------------------------------------------------------------
  550. ;; Return a symbol representing FOLDER's connection status.  The
  551. ;; returned value is one of the following symbols:
  552. ;; ONLINE    Open connection to the server.
  553. ;; OFFLINE    No connection to the server.
  554. ;; NO-SERVER    Folder is not server-based.
  555.  
  556. (define-generic folder-connection-status (folder))
  557.  
  558. ;; -------------------------------------------------------------------
  559. ;; Disconnect FOLDER from its associated server.  The folder will
  560. ;; automatically reconnect as needed.
  561.  
  562. (define-generic disconnect-folder (folder))
  563.  
  564. ;; -------------------------------------------------------------------
  565. ;; Return #T if FOLDER supports MIME parsing.
  566.  
  567. (define-generic folder-supports-mime? (folder))
  568.  
  569. ;; -------------------------------------------------------------------
  570. ;; Preload outline information about each message in the folder.
  571. ;; Normally used prior to generating a folder summary, to accelerate
  572. ;; the downloading of this information from the server.  This
  573. ;; operation need not be implemented, as it is just a performance
  574. ;; enhancement.
  575.  
  576. (define-generic preload-folder-outlines (folder))
  577.  
  578. ;;;; Message type
  579.  
  580. (define-class <message> (<property-mixin>)
  581.   (header-fields define accessor)
  582.   (flags define accessor)
  583.   (folder define standard
  584.       initial-value #f)
  585.   (index define standard
  586.      initial-value #f))
  587.  
  588. (define-method write-instance ((message <message>) port)
  589.   (write-instance-helper 'MESSAGE message port 
  590.     (lambda ()
  591.       (write-char #\space port)
  592.       (write (message-folder message) port)
  593.       (write-char #\space port)
  594.       (write (message-index message) port))))
  595.  
  596. (define (guarantee-message message procedure)
  597.   (if (not (message? message))
  598.       (error:wrong-type-argument message "IMAIL message" procedure)))
  599.  
  600. (define-generic write-message-body (message port))
  601. (define-generic set-message-flags! (message flags))
  602. (define-generic message-internal-time (message))
  603. (define-generic message-length (message))
  604.  
  605. (define %set-message-flags!
  606.   (let ((modifier (slot-modifier <message> 'FLAGS)))
  607.     (lambda (message flags)
  608.       (modifier message flags)
  609.       (let ((folder (message-folder message)))
  610.     (if folder
  611.         (object-modified! folder 'FLAGS message))))))
  612.  
  613. (define (message-attached? message #!optional folder)
  614.   (let ((folder (if (default-object? folder) #f folder)))
  615.     (if folder
  616.     (eq? folder (message-folder message))
  617.     (message-folder message))))
  618.  
  619. (define (message-detached? message)
  620.   (not (message-folder message)))
  621.  
  622. (define (attach-message! message folder index)
  623.   (guarantee-folder folder 'ATTACH-MESSAGE!)
  624.   (without-interrupts
  625.    (lambda ()
  626.      (set-message-folder! message folder)
  627.      (set-message-index! message index))))
  628.  
  629. (define (detach-message! message)
  630.   (set-message-folder! message #f))
  631.  
  632. (define (message->string message)
  633.   (with-string-output-port
  634.     (lambda (port)
  635.       (write-header-fields (message-header-fields message) port)
  636.       (write-message-body message port))))
  637.  
  638. (define (message-time message)
  639.   (let ((date (get-first-header-field-value message "date" #f)))
  640.     (and date
  641.      (parse-header-field-date date))))
  642.  
  643. ;;;; Message Navigation
  644.  
  645. (define (first-unseen-message folder)
  646.   (let ((end (folder-length folder)))
  647.     (let loop ((start (first-unseen-message-index folder)))
  648.       (and (< start end)
  649.        (let ((message (get-message folder start)))
  650.          (if (message-seen? message)
  651.          (loop (+ start 1))
  652.          message))))))
  653.  
  654. (define-generic first-unseen-message-index (folder))
  655.  
  656. (define (first-message folder)
  657.   (and (> (folder-length folder) 0)
  658.        (get-message folder 0)))
  659.  
  660. (define (last-message folder)
  661.   (let ((n (folder-length folder)))
  662.     (and (> n 0)
  663.      (get-message folder (- n 1)))))
  664.  
  665. (define (previous-message message #!optional predicate)
  666.   (let ((predicate
  667.      (if (or (default-object? predicate) (not predicate))
  668.          (lambda (message) message #t)
  669.          predicate))
  670.     (folder (message-folder message)))
  671.     (let loop ((index (message-index message)))
  672.       (and (> index 0)
  673.        (let ((index (- index 1)))
  674.          (let ((message (get-message folder index)))
  675.            (if (predicate message)
  676.            message
  677.            (loop index))))))))
  678.  
  679. (define (next-message message #!optional predicate)
  680.   (let ((predicate
  681.      (if (or (default-object? predicate) (not predicate))
  682.          (lambda (message) message #t)
  683.          predicate))
  684.     (folder (message-folder message)))
  685.     (let ((n (folder-length folder)))
  686.       (let loop ((index (message-index message)))
  687.     (let ((index (+ index 1)))
  688.       (and (< index n)
  689.            (let ((message (get-message folder index)))
  690.          (if (predicate message)
  691.              message
  692.              (loop index)))))))))
  693.  
  694. ;;;; Message flags
  695.  
  696. ;;; Flags are markers that can be attached to messages.  They indicate
  697. ;;; state about the message, such as whether it has been deleted,
  698. ;;; seen, etc.  A flag is represented by a string.
  699.  
  700. (define (message-flagged? message flag)
  701.   (guarantee-message-flag flag 'MESSAGE-FLAGGED?)
  702.   (flags-member? flag (message-flags message)))
  703.  
  704. (define (set-message-flag message flag)
  705.   (guarantee-message-flag flag 'SET-MESSAGE-FLAG)
  706.   (without-interrupts
  707.    (lambda ()
  708.      (let ((flags (message-flags message)))
  709.        (if (not (flags-member? flag flags))
  710.        (set-message-flags! message (cons flag flags)))))))
  711.  
  712. (define (clear-message-flag message flag)
  713.   (guarantee-message-flag flag 'SET-MESSAGE-FLAG)
  714.   (without-interrupts
  715.    (lambda ()
  716.      (let ((flags (message-flags message)))
  717.        (if (flags-member? flag flags)
  718.        (set-message-flags! message (flags-delete! flag flags)))))))
  719.  
  720. (define (folder-flags folder)
  721.   (let ((n (folder-length folder)))
  722.     (do ((index 0 (+ index 1))
  723.      (flags '() (append (message-flags (get-message folder index)) flags)))
  724.     ((= index n) (remove-duplicates flags string-ci=?)))))
  725.  
  726. (define flags-member? (member-procedure string-ci=?))
  727. (define flags-add (add-member-procedure string-ci=?))
  728. (define flags-delete (delete-member-procedure list-deletor string-ci=?))
  729. (define flags-delete! (delete-member-procedure list-deletor! string-ci=?))
  730.  
  731. (define (message-flag? object)
  732.   (header-field-name? object))
  733.  
  734. (define (guarantee-message-flag object procedure)
  735.   (if (not (message-flag? object))
  736.       (error:wrong-type-argument object "message flag" procedure)))
  737.  
  738. (define standard-message-flags
  739.   '("answered" "deleted" "filed" "forwarded" "resent" "seen"))
  740.  
  741. (define (message-flags->header-field flags)
  742.   (make-header-field message-flags:name
  743.              (decorated-string-append "" " " "" flags)))
  744.  
  745. (define (header-field->message-flags header)
  746.   (and (string-ci=? message-flags:name (header-field-name header))
  747.        ;; Extra pair needed to distinguish #F from ().
  748.        (cons #f
  749.          (burst-string (header-field-value header)
  750.                char-set:whitespace
  751.                #t))))
  752.  
  753. (define message-flags:name "X-IMAIL-FLAGS")
  754.  
  755. (define (parse-imail-header-fields headers)
  756.   (let loop ((headers headers) (headers* '()) (flags '()))
  757.     (cond ((not (pair? headers))
  758.        (values (reverse! headers*)
  759.            (remove-duplicates! (reverse! flags) string-ci=?)))
  760.       ((header-field->message-flags (car headers))
  761.        => (lambda (flags*)
  762.         (loop (cdr headers)
  763.               headers*
  764.               (append! (reverse! (cdr flags*)) flags))))
  765.       (else
  766.        (loop (cdr headers)
  767.          (cons (car headers) headers*)
  768.          flags)))))
  769.  
  770. (define (message-deleted? msg) (message-flagged? msg "deleted"))
  771. (define (message-undeleted? msg) (not (message-flagged? msg "deleted")))
  772. (define (delete-message msg) (set-message-flag msg "deleted"))
  773. (define (undelete-message msg) (clear-message-flag msg "deleted"))
  774.  
  775. (define (message-answered? msg) (message-flagged? msg "answered"))
  776. (define (message-unanswered? msg) (not (message-flagged? msg "answered")))
  777. (define (message-answered msg) (set-message-flag msg "answered"))
  778. (define (message-not-answered msg) (clear-message-flag msg "answered"))
  779.  
  780. (define (message-seen? msg) (message-flagged? msg "seen"))
  781. (define (message-unseen? msg) (not (message-flagged? msg "seen")))
  782. (define (message-seen msg) (set-message-flag msg "seen"))
  783. (define (message-not-seen msg) (clear-message-flag msg "seen"))
  784.  
  785. (define (message-filed? msg) (message-flagged? msg "filed"))
  786. (define (message-unfiled? msg) (not (message-flagged? msg "filed")))
  787. (define (message-filed msg) (set-message-flag msg "filed"))
  788. (define (message-not-filed msg) (clear-message-flag msg "filed"))
  789.  
  790. (define (message-forwarded? msg) (message-flagged? msg "forwarded"))
  791. (define (message-not-forwarded? msg) (not (message-flagged? msg "forwarded")))
  792. (define (message-forwarded msg) (set-message-flag msg "forwarded"))
  793. (define (message-not-forwarded msg) (clear-message-flag msg "forwarded"))
  794.  
  795. (define (message-resent? msg) (message-flagged? msg "resent"))
  796. (define (message-not-resent? msg) (not (message-flagged? msg "resent")))
  797. (define (message-resent msg) (set-message-flag msg "resent"))
  798. (define (message-not-resent msg) (clear-message-flag msg "resent"))
  799.  
  800. ;;;; Header fields
  801.  
  802. (define-structure (header-field
  803.            (type-descriptor header-field-rtd)
  804.            (safe-accessors #t)
  805.            (constructor #f)
  806.            (print-procedure
  807.             (standard-unparser-method 'HEADER-FIELD
  808.               (lambda (header port)
  809.             (write-char #\space port)
  810.             (write (header-field-name header) port)))))
  811.   (name #f read-only #t)
  812.   (value #f read-only #t))
  813.  
  814. (define make-header-field
  815.   (let ((constructor (record-constructor header-field-rtd)))
  816.     (lambda (name value)
  817.       (guarantee-header-field-name name 'MAKE-HEADER-FIELD)
  818.       (constructor name value))))
  819.  
  820. (define (guarantee-header-field-name object procedure)
  821.   (if (not (header-field-name? object))
  822.       (error:wrong-type-argument object "header-field name" procedure)))
  823.  
  824. (define (header-field-name? object)
  825.   (and (string? object)
  826.        (rfc822:header-field-name? object 0 (string-length object))))
  827.  
  828. (define (copy-header-field header)
  829.   (record-copy header))
  830.  
  831. (define (->header-fields object)
  832.   (cond ((or (pair? object) (null? object)) object)
  833.     ((message? object) (message-header-fields object))
  834.     ((string? object) (string->header-fields object))
  835.     (else (error:wrong-type-argument object "header fields" #f))))
  836.  
  837. (define (encode-header-fields headers receiver)
  838.   (for-each (lambda (header) (encode-header-field header receiver)) headers)
  839.   (receiver "\n" 0 1))
  840.  
  841. (define (encode-header-field header receiver)
  842.   (let ((name (header-field-name header)))
  843.     (receiver name 0 (string-length name)))
  844.   (receiver ": " 0 2)
  845.   (encode-header-field-value (header-field-value header) receiver)
  846.   (receiver "\n" 0 1))
  847.  
  848. (define (encode-header-field-value value receiver)
  849.   (let ((end (string-length value)))
  850.     (let loop ((start 0))
  851.       (let ((index (substring-find-next-char value start end #\newline)))
  852.     (if index
  853.         (let ((index (fix:+ index 1)))
  854.           (receiver value start index)
  855.           (receiver "\t" 0 1)
  856.           (loop index))
  857.         (receiver value start end))))))
  858.  
  859. (define (header-field-length header)
  860.   (let ((value (header-field-value header)))
  861.     (+ (string-length (header-field-name header))
  862.        (string-length value)
  863.        (string-n-newlines value)
  864.        3)))
  865.  
  866. (define (write-header-fields headers port)
  867.   (encode-header-fields headers
  868.     (lambda (string start end)
  869.       (write-substring string start end port))))
  870.  
  871. (define (write-header-field header port)
  872.   (encode-header-field header
  873.     (lambda (string start end)
  874.       (write-substring string start end port))))
  875.  
  876. (define (header-fields->string headers)
  877.   (with-string-output-port
  878.     (lambda (port)
  879.       (write-header-fields headers port))))
  880.  
  881. (define (header-field->string header)
  882.   (with-string-output-port
  883.     (lambda (port)
  884.       (write-header-field header port))))
  885.  
  886. (define (header-field-value->string value)
  887.   (with-string-output-port
  888.     (lambda (port)
  889.       (encode-header-field-value value
  890.     (lambda (string start end)
  891.       (write-substring string start end port))))))
  892.  
  893. (define (get-first-header-field headers name error?)
  894.   (let loop ((headers (->header-fields headers)))
  895.     (cond ((pair? headers)
  896.        (if (string-ci=? name (header-field-name (car headers)))
  897.            (car headers)
  898.            (loop (cdr headers))))
  899.       (error? (error:bad-range-argument name 'GET-FIRST-HEADER-FIELD))
  900.       (else #f))))
  901.  
  902. (define (get-last-header-field headers name error?)
  903.   (let loop ((headers (->header-fields headers)) (winner #f))
  904.     (cond ((pair? headers)
  905.        (loop (cdr headers)
  906.          (if (string-ci=? name (header-field-name (car headers)))
  907.              (car headers)
  908.              winner)))
  909.       ((and (not winner) error?)
  910.        (error:bad-range-argument name 'GET-LAST-HEADER-FIELD))
  911.       (else winner))))
  912.  
  913. (define (get-all-header-fields headers name)
  914.   (list-transform-positive (->header-fields headers)
  915.     (lambda (header)
  916.       (string-ci=? name (header-field-name header)))))
  917.  
  918. (define (get-first-header-field-value headers name error?)
  919.   (let ((header (get-first-header-field headers name error?)))
  920.     (and header
  921.      (header-field-value header))))
  922.  
  923. (define (get-last-header-field-value headers name error?)
  924.   (let ((header (get-last-header-field headers name error?)))
  925.     (and header
  926.      (header-field-value header))))
  927.  
  928. (define (get-all-header-field-values headers name)
  929.   (map header-field-value (get-all-header-fields headers name)))
  930.  
  931. (define (string->header-fields string)
  932.   (lines->header-fields (string->lines string)))
  933.  
  934. (define (lines->header-fields lines)
  935.   (let find-initial ((lines lines) (headers '()))
  936.     (cond ((or (not (pair? lines))
  937.            (string-null? (car lines)))
  938.        (reverse! headers))
  939.       ((header-field-initial-line? (car lines))
  940.        (let collect-group ((lines (cdr lines)) (group (list (car lines))))
  941.          (if (or (not (pair? lines))
  942.              (string-null? (car lines))
  943.              (header-field-initial-line? (car lines)))
  944.          (find-initial
  945.           lines
  946.           (cons
  947.            (let ((lines (reverse! group)))
  948.              (let ((colon
  949.                 (and (pair? lines)
  950.                  (string-find-next-char (car lines) #\:))))
  951.                (if (not colon)
  952.                (error "Malformed header-field lines:" lines))
  953.                (make-header-field
  954.             (string-head (car lines) colon)
  955.             (decorated-string-append
  956.              "" "\n" ""
  957.              (map string-trim
  958.                   (cons (string-tail (car lines) (fix:+ colon 1))
  959.                     (cdr lines)))))))
  960.            headers))
  961.          (collect-group (cdr lines) (cons (car lines) group)))))
  962.       (else
  963.        (find-initial (cdr lines) headers)))))
  964.  
  965. (define (header-field-initial-line? line)
  966.   (let ((colon (string-find-next-char line #\:)))
  967.     (and colon
  968.      (rfc822:header-field-name? line 0 colon))))
  969.  
  970. ;;;; MIME structure
  971.  
  972. (define-generic mime-message-body-structure (message))
  973. (define-generic write-mime-message-body-part (message selector cache? port))
  974.  
  975. (define-class <mime-body> (<property-mixin>)
  976.   (parameters define accessor)
  977.   (disposition define accessor)
  978.   (language define accessor)
  979.   (enclosure define standard initial-value #f))
  980.  
  981. (define-generic mime-body-type (body))
  982. (define-generic mime-body-subtype (body))
  983.  
  984. (define (mime-body-type-string body)
  985.   (string-append (symbol->string (mime-body-type body))
  986.          "/"
  987.          (symbol->string (mime-body-subtype body))))
  988.  
  989. (define (mime-body-parameter body key default)
  990.   (let ((entry (assq key (mime-body-parameters body))))
  991.     (if entry
  992.     (cdr entry)
  993.     default)))
  994.  
  995. (define (mime-body-disposition-filename body)
  996.   (let ((disposition (mime-body-disposition body)))
  997.     (and disposition
  998.      (let ((entry (assq 'FILENAME (cdr disposition))))
  999.        (and entry
  1000.         (cdr entry))))))
  1001.  
  1002. (define-method write-instance ((body <mime-body>) port)
  1003.   (write-instance-helper 'MIME-BODY body port 
  1004.     (lambda ()
  1005.       (write-char #\space port)
  1006.       (write-string (mime-body-type-string body) port))))
  1007.  
  1008. (define (mime-body-enclosed? b1 b2)
  1009.   (or (eq? b1 b2)
  1010.       (let ((enclosure (mime-body-enclosure b1)))
  1011.     (and enclosure
  1012.          (mime-body-enclosed? enclosure b2)))))
  1013.  
  1014. (define-class <mime-body-one-part> (<mime-body>)
  1015.   (id define accessor)
  1016.   (description define accessor)
  1017.   (encoding define accessor)
  1018.   (n-octets define accessor)
  1019.   (md5 define accessor))
  1020.  
  1021. (define-class (<mime-body-message>
  1022.            (constructor (parameters id description encoding n-octets
  1023.                     envelope body n-lines
  1024.                     md5 disposition language)))
  1025.     (<mime-body-one-part>)
  1026.   (envelope define accessor)        ;<mime-envelope> instance
  1027.   (body define accessor)        ;<mime-body> instance
  1028.   (n-lines define accessor))
  1029.  
  1030. (define-method mime-body-type ((body <mime-body-message>)) body 'MESSAGE)
  1031. (define-method mime-body-subtype ((body <mime-body-message>)) body 'RFC822)
  1032.  
  1033. (define-class (<mime-body-text>
  1034.            (constructor (subtype parameters id description encoding
  1035.                      n-octets n-lines
  1036.                      md5 disposition language)))
  1037.     (<mime-body-one-part>)
  1038.   (subtype accessor mime-body-subtype)
  1039.   (n-lines define accessor))
  1040.  
  1041. (define-method mime-body-type ((body <mime-body-text>)) body 'TEXT)
  1042.  
  1043. (define-class (<mime-body-basic>
  1044.            (constructor (type subtype parameters id description encoding
  1045.                   n-octets md5 disposition language)))
  1046.     (<mime-body-one-part>)
  1047.   (type accessor mime-body-type)
  1048.   (subtype accessor mime-body-subtype))
  1049.  
  1050. (define-class (<mime-body-multipart>
  1051.            (constructor (subtype parameters parts disposition language)))
  1052.     (<mime-body>)
  1053.   (subtype accessor mime-body-subtype)
  1054.   (parts define accessor))
  1055.  
  1056. (define-method mime-body-type ((body <mime-body-multipart>)) body 'MULTIPART)
  1057.  
  1058. (define-class (<mime-envelope>
  1059.            (constructor (date subject from sender reply-to to cc bcc
  1060.                   in-reply-to message-id)))
  1061.     ()
  1062.   (date define accessor)
  1063.   (subject define accessor)
  1064.   (from define accessor)
  1065.   (sender define accessor)
  1066.   (reply-to define accessor)
  1067.   (to define accessor)
  1068.   (cc define accessor)
  1069.   (bcc define accessor)
  1070.   (in-reply-to define accessor)
  1071.   (message-id define accessor))
  1072.  
  1073. (define-class (<mime-address> (constructor (name source-route mailbox host)))
  1074.     ()
  1075.   (name define accessor)
  1076.   (source-route define accessor)
  1077.   (mailbox define accessor)
  1078.   (host define accessor))