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-imap.scm < prev    next >
Text File  |  2001-07-08  |  72KB  |  2,087 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: imail-imap.scm,v 1.182 2001/07/08 05:25:29 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: IMAP back end
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;;; URL
  27.  
  28. (define-class <imap-url> (<url>))
  29. (define-url-protocol "imap" <imap-url>)
  30.  
  31. ;; User name to connect as.
  32. (define-generic imap-url-user-id (url))
  33.  
  34. ;; Name or IP address of host to connect to.
  35. (define-generic imap-url-host (url))
  36.  
  37. ;; Port number to connect to.
  38. (define-generic imap-url-port (url))
  39.  
  40. ;; Name of mailbox to access.
  41. (define-generic imap-url-mailbox (url))
  42.  
  43. (define-class <imap-folder-url> (<imap-url> <folder-url>)
  44.   (user-id accessor imap-url-user-id)
  45.   (host accessor imap-url-host)
  46.   (port accessor imap-url-port)
  47.   (mailbox accessor imap-url-mailbox)
  48.   (list-time define standard initial-value #f)
  49.   (exists? define standard)
  50.   (selectable? define standard)
  51.   (corresponding-container define standard))
  52.  
  53. (define-class <imap-container-url> (<imap-url> <container-url>)
  54.   (corresponding-folder define accessor))
  55.  
  56. (let ((reflect-1
  57.        (lambda (generic)
  58.      (define-method generic ((url <container-url>))
  59.        (generic (imap-container-url-corresponding-folder url))))))
  60.   (reflect-1 imap-url-user-id)
  61.   (reflect-1 imap-url-host)
  62.   (reflect-1 imap-url-port)
  63.   (reflect-1 url-exists?))
  64.  
  65. (define-method imap-url-mailbox ((url <container-url>))
  66.   (let ((mailbox
  67.      (imap-url-mailbox (imap-container-url-corresponding-folder url))))
  68.     (if mailbox
  69.     (string-append mailbox "/")
  70.     "")))
  71.  
  72. (define make-imap-url
  73.   (let ((make-folder
  74.      (let ((constructor
  75.         (instance-constructor <imap-folder-url>
  76.                       '(USER-ID HOST PORT MAILBOX))))
  77.        (lambda (user-id host port mailbox)
  78.          (intern-url (constructor user-id host port mailbox)
  79.              imap-container-url))))
  80.     (make-container
  81.      (let ((constructor
  82.         (instance-constructor <imap-container-url>
  83.                       '(CORRESPONDING-FOLDER))))
  84.        (lambda (folder)
  85.          (intern-url (constructor folder) imap-container-url)))))
  86.     (lambda (user-id host port mailbox)
  87.       (let ((host (string-downcase host))
  88.         (mailbox (canonicalize-imap-mailbox mailbox)))
  89.     (if (string-suffix? "/" mailbox)
  90.         (make-container
  91.          (make-folder user-id host port
  92.               (string-head mailbox
  93.                        (fix:- (string-length mailbox) 1))))
  94.         (let ((folder (make-folder user-id host port mailbox)))
  95.           (if (string-null? mailbox)
  96.           (make-container folder)
  97.           folder)))))))
  98.  
  99. (define (imap-url-new-mailbox url mailbox)
  100.   (make-imap-url (imap-url-user-id url)
  101.          (imap-url-host url)
  102.          (imap-url-port url)
  103.          mailbox))
  104.  
  105. (define-method url-body ((url <imap-url>))
  106.   (make-imap-url-string url (imap-url-mailbox url)))
  107.  
  108. (define (make-imap-url-string url mailbox)
  109.   (string-append "//"
  110.          (let ((user-id (imap-url-user-id url)))
  111.            (if (string=? user-id (current-user-name))
  112.                ""
  113.                (string-append (url:encode-string user-id) "@")))
  114.          (string-downcase (imap-url-host url))
  115.          (let ((port (imap-url-port url)))
  116.            (if (= port 143)
  117.                ""
  118.                (string-append ":" (number->string port))))
  119.          (if mailbox
  120.              (string-append
  121.               "/"
  122.               (url:encode-string (canonicalize-imap-mailbox mailbox)))
  123.              "")))
  124.  
  125. (define (canonicalize-imap-mailbox mailbox)
  126.   (cond ((string-ci=? "inbox" mailbox) "inbox")
  127.     ((and (string-prefix-ci? "inbox/" mailbox)
  128.           (not (string-prefix? "inbox/" mailbox)))
  129.      (let ((mailbox (string-copy mailbox)))
  130.        (substring-downcase! mailbox 0 5)
  131.        mailbox))
  132.     (else mailbox)))
  133.  
  134. (define (compatible-imap-urls? url1 url2)
  135.   ;; Can URL1 and URL2 both be accessed from the same IMAP session?
  136.   ;; E.g. can the IMAP COPY command work between them?
  137.   (and (string=? (imap-url-user-id url1) (imap-url-user-id url2))
  138.        (string=? (imap-url-host url1) (imap-url-host url2))
  139.        (= (imap-url-port url1) (imap-url-port url2))))
  140.  
  141. (define-method url-exists? ((url <imap-folder-url>))
  142.   (guarantee-imap-url-list-info url)
  143.   (imap-folder-url-exists? url))
  144.  
  145. (define-method folder-url-is-selectable? ((url <imap-folder-url>))
  146.   (guarantee-imap-url-list-info url)
  147.   (imap-folder-url-selectable? url))
  148.  
  149. (define-method url-corresponding-container ((url <imap-folder-url>))
  150.   (guarantee-imap-url-list-info url)
  151.   (imap-folder-url-corresponding-container url))
  152.  
  153. (define (guarantee-imap-url-list-info url)
  154.   (let ((t (get-universal-time))
  155.     (list-time (imap-folder-url-list-time url)))
  156.     (if (or (not list-time)
  157.         (> t (+ list-time imap-list-info-duration)))
  158.     (if (null? (run-list-command url (imap-url-server-mailbox url)))
  159.         (begin
  160.           (set-imap-folder-url-list-time! url t)
  161.           (set-imap-folder-url-exists?! url #f)
  162.           (set-imap-folder-url-selectable?! url #f)
  163.           (set-imap-folder-url-corresponding-container! url #f))))))
  164.  
  165. (define (flush-imap-url-list-info url)
  166.   (set-imap-folder-url-list-time!
  167.    (if (imap-container-url? url)
  168.        (imap-container-url-corresponding-folder url)
  169.        url)
  170.    #f))
  171.  
  172. ;; Number of seconds for which LIST command info is assumed valid.
  173. ;; Info is automatically invalidated at times that IMAIL knows to do
  174. ;; so.  But other IMAP clients can invalidate this information without
  175. ;; notifying IMAIL, so we must periodically refresh the info from the
  176. ;; server.  (The protocol really ought to be fixed to provide
  177. ;; asynchronous updates to this information.)
  178. (define imap-list-info-duration 60)
  179.  
  180. (define-method url-base-name ((url <imap-folder-url>))
  181.   (let ((mailbox (or (imap-url-mailbox url) "")))
  182.     (let ((index (imap-mailbox-container-slash mailbox)))
  183.       (if index
  184.       (string-tail mailbox (fix:+ index 1))
  185.       mailbox))))
  186.  
  187. (define-method url-pass-phrase-key ((url <imap-url>))
  188.   (make-url-string (url-protocol url) (make-imap-url-string url #f)))
  189.  
  190. (define-method parse-url-body (string (default-url <imap-url>))
  191.   (call-with-values (lambda () (parse-imap-url-body string default-url))
  192.     (lambda (user-id host port mailbox)
  193.       (if user-id
  194.       (make-imap-url user-id host port mailbox)
  195.       (error:bad-range-argument string 'PARSE-URL-BODY)))))
  196.  
  197. (define parse-imap-url-body
  198.   (let ((parser
  199.      (let ((//server
  200.         (sequence-parser (noise-parser (string-matcher "//"))
  201.                  (imap:server-parser #f)))
  202.            (/mbox
  203.         (sequence-parser (noise-parser (string-matcher "/"))
  204.                  (optional-parser imap:parse:enc-mailbox))))
  205.        (alternatives-parser
  206.         (sequence-parser //server (optional-parser /mbox))
  207.         /mbox
  208.         imap:parse:enc-mailbox))))
  209.     (lambda (string default-url)
  210.       (let ((pv (parse-string parser string)))
  211.     (if pv
  212.         (values (or (parser-token pv 'USER-ID)
  213.             (imap-url-user-id default-url))
  214.             (or (parser-token pv 'HOST)
  215.             (imap-url-host default-url))
  216.             (cond ((parser-token pv 'PORT) => string->number)
  217.               ((parser-token pv 'HOST) 143)
  218.               (else (imap-url-port default-url)))
  219.             (or (parser-token pv 'MAILBOX)
  220.             (imap-url-mailbox default-url)))
  221.         (values #f #f #f #f))))))
  222.  
  223. ;;;; Container heirarchy
  224.  
  225. (define (imap-container-url url)
  226.   (imap-url-new-mailbox url
  227.             (or (imap-url-container-mailbox url)
  228.                 "")))
  229.  
  230. (define-method container-url-for-prompt ((url <imap-url>))
  231.   (imap-url-new-mailbox url
  232.             (or (imap-url-container-mailbox url)
  233.                 (get-personal-namespace url)
  234.                 "")))
  235.  
  236. (define-method url-content-name ((url <imap-url>))
  237.   (let* ((mailbox (or (imap-url-mailbox url) ""))
  238.      (index (imap-mailbox-container-slash mailbox)))
  239.     (if index
  240.     (string-tail mailbox (fix:+ index 1))
  241.     mailbox)))
  242.  
  243. (define-method make-content-url ((url <imap-container-url>) name)
  244.   (imap-url-new-mailbox url (string-append (imap-url-mailbox url) name)))
  245.  
  246. (define (imap-url-container-mailbox url)
  247.   (let ((mailbox (imap-url-mailbox url)))
  248.     (and mailbox
  249.      (let ((index (imap-mailbox-container-slash mailbox)))
  250.        (and index
  251.         (string-head mailbox (fix:+ index 1)))))))
  252.  
  253. (define (imap-mailbox-container-slash mailbox)
  254.   (substring-find-previous-char mailbox
  255.                 0
  256.                 (let ((n (string-length mailbox)))
  257.                   (if (string-suffix? "/" mailbox)
  258.                       (fix:- n 1)
  259.                       n))
  260.                 #\/))
  261.  
  262. (define (get-personal-namespace url)
  263.   (let ((response
  264.      (let ((connection
  265.         (search-imap-connections
  266.          (lambda (connection)
  267.            (and (compatible-imap-urls? (imap-connection-url connection)
  268.                            url)
  269.             (not (eq? (imap-connection-namespace connection)
  270.                   'UNKNOWN))
  271.             0)))))
  272.        (and connection
  273.         (imap-connection-namespace connection)))))
  274.     (and response
  275.      (let ((namespace (imap:response:namespace-personal response)))
  276.        (and (pair? namespace)
  277.         (car namespace)
  278.         (let ((prefix (imap:decode-mailbox-name (caar namespace)))
  279.               (delimiter (cadar namespace)))
  280.           (if delimiter
  281.               (if (string-ci=? "inbox/" prefix)
  282.               "inbox/"
  283.               (string-replace prefix (string-ref delimiter 0) #\/))
  284.               prefix)))))))
  285.  
  286. (define-method container-url-contents ((url <imap-container-url>))
  287.   (%imap-mailbox-completions (imap-url-mailbox url) url))
  288.  
  289. ;;;; Completion
  290.  
  291. (define-method %url-complete-string
  292.     ((string <string>) (default-url <imap-url>)
  293.                if-unique if-not-unique if-not-found)
  294.   (call-with-values (lambda () (imap-completion-args string default-url))
  295.     (lambda (mailbox url)
  296.       (if mailbox
  297.       (let ((convert
  298.          (lambda (mailbox) (make-imap-url-string url mailbox))))
  299.         (complete-imap-mailbox mailbox url
  300.           (lambda (mailbox)
  301.         (if-unique (convert mailbox)))
  302.           (lambda (prefix get-mailboxes)
  303.         (if-not-unique (convert prefix)
  304.                    (lambda () (map convert (get-mailboxes)))))
  305.           if-not-found))
  306.       (if-not-found)))))
  307.  
  308. (define-method %url-string-completions
  309.     ((string <string>) (default-url <imap-url>))
  310.   (call-with-values (lambda () (imap-completion-args string default-url))
  311.     (lambda (mailbox url)
  312.       (if mailbox
  313.       (map (lambda (mailbox) (make-imap-url-string url mailbox))
  314.            (imap-mailbox-completions mailbox url))
  315.       '()))))
  316.  
  317. (define (imap-completion-args string default-url)
  318.   (if (string-null? string)
  319.       (values string default-url)
  320.       (call-with-values (lambda () (parse-imap-url-body string default-url))
  321.     (lambda (user-id host port mailbox)
  322.       (if user-id
  323.           (values mailbox (make-imap-url user-id host port "inbox"))
  324.           (values #f #f))))))
  325.  
  326. (define (complete-imap-mailbox mailbox url
  327.                    if-unique if-not-unique if-not-found)
  328.   (if (string-null? mailbox)
  329.       (if-not-unique mailbox
  330.              (lambda () (imap-mailbox-completions mailbox url)))
  331.       (let ((responses (imap-mailbox-completions mailbox url)))
  332.     (cond ((not (pair? responses)) (if-not-found))
  333.           ((pair? (cdr responses))
  334.            (if-not-unique (string-greatest-common-prefix responses)
  335.                   (lambda () responses)))
  336.           (else (if-unique (car responses)))))))
  337.  
  338. (define (imap-mailbox-completions prefix url)
  339.   (map imap-url-mailbox (%imap-mailbox-completions prefix url)))
  340.  
  341. (define (%imap-mailbox-completions prefix url)
  342.   (let loop
  343.       ((urls
  344.     (run-list-command
  345.      url
  346.      (string-append (imap-mailbox/url->server url prefix) "%")))
  347.        (results '()))
  348.     (if (pair? urls)
  349.     (loop (cdr urls)
  350.           (cond ((imap-folder-url-selectable? (car urls))
  351.              (cons (car urls) results))
  352.             ((imap-folder-url-corresponding-container (car urls))
  353.              => (lambda (url) (cons url results)))
  354.             (else results)))
  355.     (reverse! results))))
  356.  
  357. (define (run-list-command url mailbox)
  358.   (let ((t (get-universal-time)))
  359.     (map (lambda (response)
  360.        (let ((mailbox
  361.           (let ((delimiter (imap:response:list-delimiter response))
  362.             (mailbox
  363.              (imap:decode-mailbox-name
  364.               (imap:response:list-mailbox response))))
  365.             (if delimiter
  366.             (string-replace mailbox (string-ref delimiter 0) #\/)
  367.             mailbox)))
  368.          (flags (imap:response:list-flags response)))
  369.          (let ((url (imap-url-new-mailbox url mailbox)))
  370.            (set-imap-folder-url-list-time! url t)
  371.            (set-imap-folder-url-exists?! url #t)
  372.            (set-imap-folder-url-selectable?! url
  373.                          (not (memq '\NOSELECT flags)))
  374.            (set-imap-folder-url-corresponding-container!
  375.         url
  376.         (and (not (memq '\NOINFERIORS flags))
  377.              (imap-url-new-mailbox url (string-append mailbox "/"))))
  378.            url)))
  379.      (with-open-imap-connection url
  380.        (lambda (connection)
  381.          (imap:command:list connection "" mailbox))))))
  382.  
  383. ;;;; URL->server delimiter conversion
  384.  
  385. (define (imap-url-server-mailbox url)
  386.   (imap-mailbox/url->server
  387.    url
  388.    (let ((mailbox (imap-url-mailbox url)))
  389.      (cond ((not mailbox) "")
  390.        ((string-suffix? "/" mailbox)
  391.         (string-head mailbox (fix:- (string-length mailbox) 1)))
  392.        (else mailbox)))))
  393.  
  394. (define (imap-mailbox/url->server url mailbox)
  395.   (let ((delimiter (imap-mailbox-delimiter url mailbox)))
  396.     (if (and delimiter (not (char=? delimiter #\/)))
  397.     (string-replace mailbox #\/ delimiter)
  398.     mailbox)))
  399.  
  400. (define (imap-mailbox-delimiter url mailbox)
  401.   (let* ((slash (string-find-next-char mailbox #\/))
  402.      (root (if slash (string-head mailbox slash) mailbox)))
  403.     (let ((delimiter (hash-table/get imap-delimiters-table root 'UNKNOWN)))
  404.       (if (eq? delimiter 'UNKNOWN)
  405.       (let ((delimiter
  406.          (imap:response:list-delimiter
  407.           (with-open-imap-connection url
  408.             (lambda (connection)
  409.               (imap:command:get-delimiter connection root))))))
  410.         (let ((delimiter
  411.            (and delimiter
  412.             (string-ref delimiter 0))))
  413.           (hash-table/put! imap-delimiters-table root delimiter)
  414.           delimiter))
  415.       delimiter))))
  416.  
  417. (define imap-delimiters-table
  418.   (make-equal-hash-table))
  419.  
  420. ;;;; Server connection
  421.  
  422. (define-class <imap-connection> ()
  423.   ;; The URL of the mailbox this connection has selected, if any.  If
  424.   ;; it doesn't have a mailbox selected, the URL will have a null
  425.   ;; string for its mailbox component.
  426.   (url             define accessor)
  427.   ;; If a folder has claimed this connection, it is stored here.
  428.   (folder          define standard initial-value #f)
  429.   (port            define standard initial-value #f)
  430.   (greeting        define standard initial-value #f)
  431.   (capabilities    define standard initial-value '())
  432.   (namespace       define standard initial-value 'UNKNOWN)
  433.   (sequence-number define standard initial-value 0)
  434.   (response-queue  define accessor initializer (lambda () (cons '() '())))
  435.   (reference-count define standard initial-value 0))
  436.  
  437. (define-method write-instance ((connection <imap-connection>) port)
  438.   (write-instance-helper 'IMAP-CONNECTION connection port
  439.     (lambda ()
  440.       (write-char #\space port)
  441.       (write (url-body (imap-connection-url connection)) port))))
  442.  
  443. (define (reset-imap-connection connection)
  444.   (without-interrupts
  445.    (lambda ()
  446.      (set-imap-connection-url! connection #f)
  447.      (set-imap-connection-greeting! connection #f)
  448.      (set-imap-connection-capabilities! connection '())
  449.      (set-imap-connection-sequence-number! connection 0)
  450.      (let ((queue (imap-connection-response-queue connection)))
  451.        (set-car! queue '())
  452.        (set-cdr! queue '())))))
  453.  
  454. (define set-imap-connection-url!
  455.   (let ((modifier (slot-modifier <imap-connection> 'URL)))
  456.     (lambda (connection url)
  457.       (modifier
  458.        connection
  459.        (or url (imap-url-new-mailbox (imap-connection-url connection) ""))))))
  460.  
  461. (define (next-imap-command-tag connection)
  462.   (let ((n (imap-connection-sequence-number connection)))
  463.     (set-imap-connection-sequence-number! connection (+ n 1))
  464.     (nonnegative-integer->base26-string n 3)))
  465.  
  466. (define (nonnegative-integer->base26-string n min-length)
  467.   (let ((s
  468.      (make-string (max (ceiling->exact (/ (log (+ n 1)) (log 26)))
  469.                min-length)
  470.               #\A)))
  471.     (let loop ((n n) (i (fix:- (string-length s) 1)))
  472.       (let ((q.r (integer-divide n 26)))
  473.     (string-set! s i (string-ref "ABCDEFGHIJKLMNOPQRSTUVWXYZ" (cdr q.r)))
  474.     (if (not (= (car q.r) 0))
  475.         (loop (car q.r) (fix:- i 1)))))
  476.     s))
  477.  
  478. (define (base26-string->nonnegative-integer s)
  479.   (let ((end (string-length s)))
  480.     (let loop ((start 0) (n 0))
  481.       (if (fix:< start end)
  482.       (let ((digit (- (vector-8b-ref s start) (char->integer #\A))))
  483.         (if (not (<= 0 digit 25))
  484.         (error:bad-range-argument s
  485.                       'BASE26-STRING->NONNEGATIVE-INTEGER))
  486.         (loop (fix:+ start 1) (+ (* n 26) digit)))
  487.       n))))
  488.  
  489. (define (increment-connection-reference-count! connection)
  490.   (set-imap-connection-reference-count!
  491.    connection
  492.    (+ (imap-connection-reference-count connection) 1)))
  493.  
  494. (define (decrement-connection-reference-count! connection)
  495.   (set-imap-connection-reference-count!
  496.    connection
  497.    (- (imap-connection-reference-count connection) 1)))
  498.  
  499. (define (enqueue-imap-response connection response)
  500.   (let ((queue (imap-connection-response-queue connection)))
  501.     (let ((next (cons response '())))
  502.       (without-interrupts
  503.        (lambda ()
  504.      (if (pair? (cdr queue))
  505.          (set-cdr! (cdr queue) next)
  506.          (set-car! queue next))
  507.      (set-cdr! queue next))))))
  508.  
  509. (define (dequeue-imap-responses connection)
  510.   (let ((queue (imap-connection-response-queue connection)))
  511.     (without-interrupts
  512.      (lambda ()
  513.        (let ((responses (car queue)))
  514.      (set-car! queue '())
  515.      (set-cdr! queue '())
  516.      responses)))))
  517.  
  518. (define (get-folder-imap-connection url)
  519.   (or (search-imap-connections
  520.        (lambda (connection)
  521.      (if (eq? (imap-connection-url connection) url)
  522.          2
  523.          (and (compatible-imap-urls? (imap-connection-url connection) url)
  524.           (not (imap-connection-folder connection))
  525.           (if (test-imap-connection-open connection) 1 0)))))
  526.       (make-imap-connection url)))
  527.  
  528. (define (get-compatible-imap-connection url)
  529.   (or (search-imap-connections
  530.        (lambda (connection)
  531.      (and (compatible-imap-urls? (imap-connection-url connection) url)
  532.           (if (test-imap-connection-open connection) 1 0))))
  533.       (make-imap-connection url)))
  534.  
  535. (define (search-imap-connections assessor)
  536.   (let loop ((connections memoized-imap-connections) (prev #f) (winner #f))
  537.     (if (weak-pair? connections)
  538.     (let ((connection (weak-car connections)))
  539.       (if connection
  540.           (loop (weak-cdr connections)
  541.             connections
  542.             (let ((value (assessor connection)))
  543.               (if (and value
  544.                    (or (not winner)
  545.                    (> value (cdr winner))))
  546.               (cons connection value)
  547.               winner)))
  548.           (let ((next (weak-cdr connections)))
  549.         (if prev
  550.             (weak-set-cdr! prev next)
  551.             (set! memoized-imap-connections next))
  552.         (loop next prev winner))))
  553.     (and winner (car winner)))))
  554.  
  555. (define make-imap-connection
  556.   (let ((constructor (instance-constructor <imap-connection> '(URL))))
  557.     (lambda (url)
  558.       (let ((connection (constructor (imap-url-new-mailbox url ""))))
  559.     (without-interrupts
  560.      (lambda ()
  561.        (set! memoized-imap-connections
  562.          (weak-cons connection memoized-imap-connections))))
  563.     connection))))
  564.  
  565. (define memoized-imap-connections '())
  566.  
  567. (define (guarantee-imap-connection-open connection)
  568.   (stop-pending-connection-closure connection)
  569.   (if (test-imap-connection-open connection)
  570.       #f
  571.       (let ((url (imap-connection-url connection)))
  572.     (let ((port
  573.            (open-tcp-stream-socket (imap-url-host url)
  574.                        (or (imap-url-port url) "imap2")
  575.                        #f
  576.                        "\n")))
  577.       (let ((response
  578.          (imap:catch-no-response #f
  579.            (lambda ()
  580.              (let ((finished? #f))
  581.                (dynamic-wind
  582.             (lambda () unspecific)
  583.             (lambda ()
  584.               (reset-imap-connection connection)
  585.               (set-imap-connection-port! connection port)
  586.               (set-imap-connection-greeting!
  587.                connection
  588.                (let ((response (imap:read-server-response-1 port)))
  589.                  (if (imap:response:ok? response)
  590.                  (imap:response:response-text-string response)
  591.                  response)))
  592.               (imap:command:capability connection)
  593.               (if (not (memq 'IMAP4REV1
  594.                      (imap-connection-capabilities
  595.                       connection)))
  596.                   (error "Server doesn't support IMAP4rev1:" url))
  597.               (let ((response
  598.                  (imail-ui:call-with-pass-phrase url
  599.                    (lambda (pass-phrase)
  600.                      (imap:command:login connection
  601.                              (imap-url-user-id url)
  602.                              pass-phrase)))))
  603.                 (set! finished? #t)
  604.                 response))
  605.             (lambda ()
  606.               (if (not finished?)
  607.                   (close-imap-connection connection)))))))))
  608.         (if (imap:response:no? response)
  609.         (begin
  610.           (imail-ui:delete-stored-pass-phrase url)
  611.           (error "Unable to log in:"
  612.              (imap:response:response-text-string response))))))
  613.     (if (eq? (imap-connection-namespace connection) 'UNKNOWN)
  614.         (set-imap-connection-namespace!
  615.          connection
  616.          (and (memq 'NAMESPACE (imap-connection-capabilities connection))
  617.           (imap:command:namespace connection))))
  618.     #t)))
  619.  
  620. (define (with-open-imap-connection url receiver)
  621.   (let ((connection (get-compatible-imap-connection url)))
  622.     (dynamic-wind (lambda ()
  623.             (increment-connection-reference-count! connection))
  624.           (lambda ()
  625.             (guarantee-imap-connection-open connection)
  626.             (let ((v (receiver connection)))
  627.               (maybe-close-imap-connection connection 1 #f)
  628.               v))
  629.           (lambda ()
  630.             (decrement-connection-reference-count! connection)))))
  631.  
  632. (define (test-imap-connection-open connection)
  633.   (let ((port (imap-connection-port connection)))
  634.     (and port
  635.      (let ((lose
  636.         (lambda ()
  637.           (process-queued-responses connection #f)
  638.           (close-imap-connection connection)
  639.           #f)))
  640.        (let loop ()
  641.          (cond ((not (char-ready? port))
  642.             (process-queued-responses connection #f)
  643.             #t)
  644.            ((eof-object? (peek-char port))
  645.             (lose))
  646.            (else
  647.             (let ((response
  648.                (ignore-errors
  649.                 (lambda ()
  650.                   (imap:read-server-response-1 port)))))
  651.               (if (or (condition? response)
  652.                   (begin
  653.                 (enqueue-imap-response connection response)
  654.                 (imap:response:bye? response)))
  655.               (lose)
  656.               (loop))))))))))
  657.  
  658. (define (close-imap-connection-cleanly connection)
  659.   (if (test-imap-connection-open connection)
  660.       (imap:command:logout connection))
  661.   (close-imap-connection connection))
  662.  
  663. (define (close-imap-connection connection)
  664.   (let ((port
  665.      (without-interrupts
  666.       (lambda ()
  667.         (let ((port (imap-connection-port connection)))
  668.           (set-imap-connection-port! connection #f)
  669.           port)))))
  670.     (if port
  671.     (close-port port)))
  672.   (reset-imap-connection connection))
  673.  
  674. (define (maybe-close-imap-connection connection min-count no-defer?)
  675.   (if (= (imap-connection-reference-count connection) min-count)
  676.       (if (or no-defer?
  677.           (search-imap-connections
  678.            (let ((url (imap-connection-url connection)))
  679.          (lambda (connection*)
  680.            (and (not (eq? connection* connection))
  681.             (compatible-imap-urls?
  682.              (imap-connection-url connection*)
  683.              url)
  684.             0)))))
  685.       (close-imap-connection-cleanly connection)
  686.       (defer-closing-of-connection connection))))
  687.  
  688. (define (defer-closing-of-connection connection)
  689.   (without-interrupts
  690.    (lambda ()
  691.      (let ((entry (assq connection connections-awaiting-closure))
  692.        (t (+ (get-universal-time) connection-closure-delay)))
  693.        (if entry
  694.        (set-cdr! entry t)
  695.        (set! connections-awaiting-closure
  696.          (cons (cons connection t)
  697.                connections-awaiting-closure))))
  698.      (if (not connection-closure-thread-registration)
  699.      (begin
  700.        (set! connection-closure-thread-registration
  701.          (start-standard-polling-thread
  702.           connection-closure-thread-interval
  703.           connection-closure-output-processor))
  704.        unspecific)))))
  705.  
  706. (define (connection-closure-output-processor)
  707.   (for-each close-imap-connection-cleanly
  708.         (without-interrupts
  709.          (lambda ()
  710.            (let ((t (get-universal-time)))
  711.          (let loop
  712.              ((this connections-awaiting-closure)
  713.               (prev #f)
  714.               (connections '()))
  715.            (if (pair? this)
  716.                (let ((next (cdr this)))
  717.              (if (>= t (cdar this))
  718.                  (begin
  719.                    (if prev
  720.                    (set-cdr! prev next)
  721.                    (set! connections-awaiting-closure next))
  722.                    (loop next prev (cons (caar this) connections)))
  723.                  (loop next this connections)))
  724.                (begin
  725.              (%maybe-stop-connection-closure-thread)
  726.              connections)))))))
  727.   #f)
  728.  
  729. (define (stop-pending-connection-closure connection)
  730.   (without-interrupts
  731.    (lambda ()
  732.      (set! connections-awaiting-closure
  733.        (del-assq! connection connections-awaiting-closure))
  734.      (%maybe-stop-connection-closure-thread))))
  735.  
  736. (define (%maybe-stop-connection-closure-thread)
  737.   ;; Interrupts are assumed off here.
  738.   (if (and (null? connections-awaiting-closure)
  739.        connection-closure-thread-registration)
  740.       (begin
  741.     (stop-standard-polling-thread connection-closure-thread-registration)
  742.     (set! connection-closure-thread-registration #f)
  743.     unspecific)))
  744.  
  745. (define connections-awaiting-closure '())
  746. (define connection-closure-delay 60)    ;seconds
  747. (define connection-closure-thread-interval (* 10 1000))    ;milliseconds
  748. (define connection-closure-thread-registration #f)
  749.  
  750. ;;;; Folder and container datatypes
  751.  
  752. (define-class <imap-folder> (<folder>)
  753.   (connection define standard
  754.           initial-value #f)
  755.   (read-only? define standard)
  756.   (allowed-flags define standard)
  757.   (permanent-flags define standard)
  758.   (permanent-keywords? define standard)
  759.   (uidnext define standard)
  760.   (uidvalidity define standard)
  761.   (unseen define standard)
  762.   (messages-synchronized? define standard)
  763.   (length accessor folder-length
  764.       define modifier
  765.       initial-value 0)
  766.   (messages define standard
  767.         initial-value '#()))
  768.  
  769. (define-class (<imap-container> (constructor (locator))) (<container>)
  770.   (connection define standard
  771.           initial-value #f))
  772.  
  773. (define make-imap-folder
  774.   (let ((constructor (instance-constructor <imap-folder> '(LOCATOR))))
  775.     (lambda (url)
  776.       (let ((folder (constructor url)))
  777.     (reset-imap-folder! folder)
  778.     folder))))
  779.  
  780. (define (reset-imap-folder! folder)
  781.   (without-interrupts
  782.    (lambda ()
  783.      (detach-all-messages! folder)
  784.      (set-imap-folder-read-only?! folder #f)
  785.      (set-imap-folder-allowed-flags! folder '())
  786.      (set-imap-folder-permanent-flags! folder '())
  787.      (set-imap-folder-permanent-keywords?! folder #f)
  788.      (set-imap-folder-uidnext! folder #f)
  789.      (set-imap-folder-uidvalidity! folder #f)
  790.      (set-imap-folder-unseen! folder #f)
  791.      (set-imap-folder-messages-synchronized?! folder #f)
  792.      (set-imap-folder-length! folder 0)
  793.      (set-imap-folder-messages! folder (initial-messages)))))
  794.  
  795. (define (guarantee-imap-folder-connection folder)
  796.   (without-interrupts
  797.    (lambda ()
  798.      (or (imap-folder-connection folder)
  799.      (let ((connection
  800.         (get-folder-imap-connection (resource-locator folder))))
  801.        (set-imap-connection-folder! connection folder)
  802.        (increment-connection-reference-count! connection)
  803.        (set-imap-folder-connection! folder connection)
  804.        connection)))))
  805.  
  806. (define (guarantee-imap-folder-open folder)
  807.   (let ((connection (guarantee-imap-folder-connection folder))
  808.     (url (resource-locator folder)))
  809.     (if (or (guarantee-imap-connection-open connection)
  810.         (not (eq? (imap-connection-url connection) url)))
  811.     (begin
  812.       (set-imap-folder-messages-synchronized?! folder #f)
  813.       (let ((selected? #f))
  814.         (dynamic-wind
  815.          (lambda ()
  816.            (set-imap-connection-url! connection url))
  817.          (lambda ()
  818.            (imap:command:select connection (imap-url-server-mailbox url))
  819.            (set! selected? #t)
  820.            unspecific)
  821.          (lambda ()
  822.            (if (not selected?)
  823.            (set-imap-connection-url! connection #f)))))
  824.       (object-modified! folder 'STATUS)))
  825.     connection))
  826.  
  827. (define (new-imap-folder-uidvalidity! folder uidvalidity)
  828.   (without-interrupts
  829.    (lambda ()
  830.      (detach-all-messages! folder)
  831.      (fill-messages-vector! folder 0)
  832.      (if (imap-folder-uidvalidity folder)
  833.      (set-imap-folder-unseen! folder #f))
  834.      (set-imap-folder-uidvalidity! folder uidvalidity)))
  835.   (read-message-headers! folder 0))
  836.  
  837. (define (detach-all-messages! folder)
  838.   (let ((v (imap-folder-messages folder))
  839.     (n (folder-length folder)))
  840.     (do ((i 0 (fix:+ i 1)))
  841.     ((fix:= i n))
  842.       (detach-message! (vector-ref v i)))))
  843.  
  844. (define (fill-messages-vector! folder start)
  845.   (let ((v (imap-folder-messages folder))
  846.     (n (folder-length folder)))
  847.     (do ((index start (fix:+ index 1)))
  848.     ((fix:= index n))
  849.       (vector-set! v index (make-imap-message folder index)))))
  850.  
  851. (define (read-message-headers! folder start)
  852.   (if (and (imap-folder-uidvalidity folder)
  853.        (> (folder-length folder) start))
  854.       ((imail-ui:message-wrapper "Reading message UIDs")
  855.        (lambda ()
  856.      (imap:command:fetch-range (imap-folder-connection folder)
  857.                    start #f '(UID FLAGS))))))
  858.  
  859. (define (remove-imap-folder-message folder index)
  860.   (without-interrupts
  861.    (lambda ()
  862.      (let ((v (imap-folder-messages folder))
  863.        (n (fix:- (folder-length folder) 1)))
  864.        (detach-message! (vector-ref v index))
  865.        (do ((i index (fix:+ i 1)))
  866.        ((fix:= i n))
  867.      (let ((m (vector-ref v (fix:+ i 1))))
  868.        (set-message-index! m i)
  869.        (vector-set! v i m)))
  870.        (vector-set! v n #f)
  871.        (set-imap-folder-length! folder n)
  872.        (set-imap-folder-unseen! folder #f)
  873.        (let ((new-length (compute-messages-length v n)))
  874.      (if new-length
  875.          (set-imap-folder-messages! folder
  876.                     (vector-head v new-length))))
  877.        (object-modified! folder 'EXPUNGE index)))))
  878.  
  879. (define (initial-messages)
  880.   (make-vector 64 #f))
  881.  
  882. (define (compute-messages-length v count)
  883.   (let ((old-length (vector-length v))
  884.     (min-length 64))
  885.     (if (> count old-length)
  886.     (let loop ((n (* old-length 2)))
  887.       (if (<= count n)
  888.           n
  889.           (loop (* n 2))))
  890.     (and (> old-length min-length)
  891.          (<= count (quotient old-length 2))
  892.          (let loop ((n (quotient old-length 2)))
  893.            (let ((n/2 (quotient n 2)))
  894.          (if (or (> count n/2) (= n min-length))
  895.              n
  896.              (loop n/2))))))))
  897.  
  898. ;;; UPDATE-IMAP-FOLDER-LENGTH! needs explanation.  There are two basic
  899. ;;; cases.
  900.  
  901. ;;; In the first case, our folder is synchronized with the server,
  902. ;;; meaning that our folder has the same length and UIDs as the
  903. ;;; server's mailbox.  In that case, length changes can only be
  904. ;;; increases, and we know that no deletions occur except those
  905. ;;; reflected by EXPUNGE responses (both constraints required by the
  906. ;;; IMAP specification).
  907.  
  908. ;;; In the second case, we have lost synchrony with the server,
  909. ;;; usually because the connection was closed and then reopened.  Here
  910. ;;; we must resynchronize, matching up messages by UID.  Our strategy
  911. ;;; is to detach all of the existing messages, create a new message
  912. ;;; set with empty messages, read in the UIDs for the new messages,
  913. ;;; then match up the old messages with the new.  Any old message that
  914. ;;; matches a new one replaces it in the folder, thus preserving
  915. ;;; message pointers where possible.
  916.  
  917. ;;; The reason for this complexity in the second case is that we can't
  918. ;;; be guaranteed that we will complete reading the UIDs for the new
  919. ;;; messages, either due to error or the user aborting the read.  So
  920. ;;; we must have everything in a consistent (if nonoptimal) state
  921. ;;; while reading.  If the read finishes, we can do the match/replace
  922. ;;; operation atomically.
  923.  
  924. (define (update-imap-folder-length! folder count)
  925.   (with-interrupt-mask interrupt-mask/gc-ok
  926.     (lambda (interrupt-mask)
  927.       (if (or (imap-folder-messages-synchronized? folder)
  928.           (= 0 (folder-length folder)))
  929.       (let ((v (imap-folder-messages folder))
  930.         (n (folder-length folder)))
  931.         (cond ((> count n)
  932.            (let ((new-length (compute-messages-length v count)))
  933.              (if new-length
  934.              (set-imap-folder-messages!
  935.               folder
  936.               (vector-grow v new-length #f))))
  937.            (set-imap-folder-length! folder count)
  938.            (fill-messages-vector! folder n)
  939.            (set-imap-folder-messages-synchronized?! folder #t)
  940.            (with-interrupt-mask interrupt-mask
  941.              (lambda (interrupt-mask)
  942.                interrupt-mask
  943.                (read-message-headers! folder n)))
  944.            (object-modified! folder 'INCREASE-LENGTH n count))
  945.           ((= count n)
  946.            (set-imap-folder-messages-synchronized?! folder #t))
  947.           (else
  948.            (error "EXISTS response decreased folder length:"
  949.               folder))))
  950.       (begin
  951.         (detach-all-messages! folder)
  952.         (let ((v (imap-folder-messages folder))
  953.           (n (folder-length folder)))
  954.           (set-imap-folder-length! folder count)
  955.           (set-imap-folder-messages!
  956.            folder
  957.            (make-vector (or (compute-messages-length v count)
  958.                 (vector-length v))
  959.                 #f))
  960.           (fill-messages-vector! folder 0)
  961.           (set-imap-folder-messages-synchronized?! folder #t)
  962.           (if (> count 0)
  963.           (with-interrupt-mask interrupt-mask
  964.             (lambda (interrupt-mask)
  965.               interrupt-mask
  966.               ((imail-ui:message-wrapper "Reading message UIDs")
  967.                (lambda ()
  968.              (imap:command:fetch-range
  969.               (imap-folder-connection folder)
  970.               0 #f '(UID)))))))
  971.           (let ((v* (imap-folder-messages folder))
  972.             (n* (folder-length folder)))
  973.         (let loop ((i 0) (i* 0))
  974.           (if (and (fix:< i n) (fix:< i* n*))
  975.               (let ((m (vector-ref v i))
  976.                 (m* (vector-ref v* i*)))
  977.             (if (= (imap-message-uid m) (imap-message-uid m*))
  978.                 (begin
  979.                   ;; Flags might have been updated while
  980.                   ;; reading the UIDs.
  981.                   (if (%message-flags-initialized? m*)
  982.                   (%set-message-flags! m (message-flags m*)))
  983.                   (detach-message! m*)
  984.                   (attach-message! m folder i*)
  985.                   (vector-set! v* i* m)
  986.                   (loop (fix:+ i 1) (fix:+ i* 1)))
  987.                 (begin
  988.                   (if (> (imap-message-uid m)
  989.                      (imap-message-uid m*))
  990.                   (error "Message inserted into folder:" m*))
  991.                   (loop (fix:+ i 1) i*)))))))
  992.           (object-modified! folder 'SET-LENGTH n count)))))))
  993.  
  994. ;;;; Message datatype
  995.  
  996. (define-class (<imap-message> (constructor (folder index))) (<message>)
  997.   (uid)
  998.   (length)
  999.   (envelope)
  1000.   (bodystructure)
  1001.   (body-parts define standard initial-value '()))
  1002.  
  1003. (define-generic imap-message-uid (message))
  1004. (define-generic imap-message-length (message))
  1005. (define-generic imap-message-envelope (message))
  1006. (define-generic imap-message-bodystructure (message))
  1007.  
  1008. (define-method set-message-flags! ((message <imap-message>) flags)
  1009.   (with-imap-message-open message
  1010.     (lambda (connection)
  1011.       (imap:command:uid-store-flags
  1012.        connection
  1013.        (imap-message-uid message)
  1014.        (map imail-flag->imap-flag
  1015.         (let ((flags (flags-delete "recent" flags))
  1016.           (folder (message-folder message)))
  1017.           (if (imap-folder-permanent-keywords? folder)
  1018.           flags
  1019.           (list-transform-positive flags
  1020.             (let ((allowed-flags (imap-folder-allowed-flags folder)))
  1021.               (lambda (flag)
  1022.             (flags-member? flag allowed-flags)))))))))))
  1023.  
  1024. (define (imap-flag->imail-flag flag)
  1025.   (let ((entry (assq flag standard-imap-flags)))
  1026.     (if entry
  1027.     (cdr entry)
  1028.     (symbol->string flag))))
  1029.  
  1030. (define (imail-flag->imap-flag flag)
  1031.   (let ((entry
  1032.      (list-search-positive standard-imap-flags
  1033.        (lambda (entry)
  1034.          (string-ci=? flag (cdr entry))))))
  1035.     (if entry
  1036.     (car entry)
  1037.     (intern flag))))
  1038.  
  1039. (define standard-imap-flags
  1040.   (map (lambda (s)
  1041.      (cons s (string-tail (symbol->string s) 1)))
  1042.        '(\SEEN \ANSWERED \FLAGGED \DELETED \DRAFT \RECENT)))
  1043.  
  1044. (define-method message-internal-time ((message <imap-message>))
  1045.   (with-imap-message-open message
  1046.     (lambda (connection)
  1047.       (imap:response:fetch-attribute
  1048.        (imap:command:uid-fetch connection
  1049.                    (imap-message-uid message)
  1050.                    '(INTERNALDATE))
  1051.        'INTERNALDATE))))
  1052.  
  1053. (define-method message-length ((message <imap-message>))
  1054.   (with-imap-message-open message
  1055.     (lambda (connection)
  1056.       connection
  1057.       (imap-message-length message))))
  1058.  
  1059. (define (with-imap-message-open message receiver)
  1060.   (let ((folder (message-folder message)))
  1061.     (if folder
  1062.     (receiver (guarantee-imap-folder-open folder)))))
  1063.  
  1064. ;;; These reflectors are needed to guarantee that we read the
  1065. ;;; appropriate information from the server.  Some message slots are
  1066. ;;; filled in by READ-MESSAGE-HEADERS!, but it's possible for
  1067. ;;; READ-MESSAGE-HEADERS! to be interrupted, leaving unfilled slots.
  1068.  
  1069. (let ((accessor (slot-accessor <imap-message> 'UID))
  1070.       (initpred (slot-initpred <imap-message> 'UID)))
  1071.   (define-method imap-message-uid ((message <imap-message>))
  1072.     (if (not (initpred message))
  1073.     (with-imap-message-open message
  1074.       (lambda (connection)
  1075.         (let ((index (message-index message)))
  1076.           (let ((suffix
  1077.              (string-append " UID for message "
  1078.                     (number->string (+ index 1)))))
  1079.         ((imail-ui:message-wrapper "Reading" suffix)
  1080.          (lambda ()
  1081.            (imap:command:fetch connection index '(UID))
  1082.            (if (not (initpred message))
  1083.                (begin
  1084.              ;; Still don't have the goods.  Send a NOOP, in
  1085.              ;; case the server is holding it back because it
  1086.              ;; also needs to send an EXPUNGE.
  1087.              (imap:command:noop connection)
  1088.              (if (not (initpred message))
  1089.                  (error
  1090.                   (string-append "Unable to obtain"
  1091.                          suffix))))))))))))
  1092.     (accessor message)))
  1093.  
  1094. (define (guarantee-slot-initialized message initpred noun keywords)
  1095.   (if (not (initpred message))
  1096.       (with-imap-message-open message
  1097.     (lambda (connection)
  1098.       (let ((uid (imap-message-uid message)))
  1099.         (let ((suffix
  1100.            (string-append
  1101.             " " noun " for message "
  1102.             (number->string (+ (message-index message) 1)))))
  1103.           ((imail-ui:message-wrapper "Reading" suffix)
  1104.            (lambda ()
  1105.          (imap:read-literal-progress-hook imail-ui:progress-meter
  1106.            (lambda ()
  1107.              (imap:command:uid-fetch connection uid keywords)
  1108.              (if (not (initpred message))
  1109.              (error
  1110.               (string-append "Unable to obtain" suffix)))))))))))))
  1111.  
  1112. (let ((reflector
  1113.        (lambda (generic-procedure slot-name guarantee)
  1114.      (let ((initpred (slot-initpred <imap-message> slot-name)))
  1115.        (define-method generic-procedure ((message <imap-message>))
  1116.          (guarantee message initpred)
  1117.          (call-next-method message))))))
  1118.   (reflector message-header-fields 'HEADER-FIELDS
  1119.     (lambda (message initpred)
  1120.       (guarantee-slot-initialized message initpred "header" '(RFC822.HEADER))))
  1121.   (reflector message-flags 'FLAGS
  1122.     (lambda (message initpred)
  1123.       (guarantee-slot-initialized message initpred "flags" '(FLAGS)))))
  1124.  
  1125. (let ((reflector
  1126.        (lambda (generic-procedure slot-name guarantee)
  1127.      (let ((accessor (slot-accessor <imap-message> slot-name))
  1128.            (initpred (slot-initpred <imap-message> slot-name)))
  1129.        (define-method generic-procedure ((message <imap-message>))
  1130.          (guarantee message initpred)
  1131.          (accessor message))))))
  1132.   (reflector imap-message-length 'LENGTH
  1133.     (lambda (message initpred)
  1134.       (guarantee-slot-initialized message initpred "length" '(RFC822.SIZE))))
  1135.   (reflector imap-message-envelope 'ENVELOPE
  1136.     (lambda (message initpred)
  1137.       (guarantee-slot-initialized message initpred "envelope" '(ENVELOPE))))
  1138.   (reflector imap-message-bodystructure 'BODYSTRUCTURE
  1139.     (lambda (message initpred)
  1140.       (guarantee-slot-initialized message initpred "MIME structure"
  1141.                   '(BODYSTRUCTURE)))))
  1142.  
  1143. (define-method preload-folder-outlines ((folder <imap-folder>))
  1144.   (let* ((connection (guarantee-imap-folder-open folder))
  1145.      (messages
  1146.       (messages-satisfying folder
  1147.         (lambda (message)
  1148.           (not (and (imap-message-header-fields-initialized? message)
  1149.             (imap-message-length-initialized? message)))))))
  1150.     (if (pair? messages)
  1151.     ((imail-ui:message-wrapper "Reading message headers")
  1152.      (lambda ()
  1153.        (imap:command:fetch-set connection
  1154.                    (message-list->set messages)
  1155.                    '(RFC822.HEADER RFC822.SIZE)))))))
  1156.     
  1157.  
  1158. (define imap-message-header-fields-initialized?
  1159.   (slot-initpred <imap-message> 'HEADER-FIELDS))
  1160.  
  1161. (define imap-message-length-initialized?
  1162.   (slot-initpred <imap-message> 'LENGTH))
  1163.  
  1164. (define (messages-satisfying folder predicate)
  1165.   (let ((n (folder-length folder)))
  1166.     (let loop ((i 0) (messages '()))
  1167.       (if (< i n)
  1168.       (loop (+ i 1)
  1169.         (let ((message (get-message folder i)))
  1170.           (if (predicate message)
  1171.               (cons message messages)
  1172.               messages)))
  1173.       (reverse! messages)))))
  1174.  
  1175. (define (message-list->set messages)
  1176.   (let loop ((indexes (map message-index messages)) (groups '()))
  1177.     (if (pair? indexes)
  1178.     (let ((start (car indexes)))
  1179.       (let parse-group ((this start) (rest (cdr indexes)))
  1180.         (if (and (pair? rest) (= (car rest) (+ this 1)))
  1181.         (parse-group (car rest) (cdr rest))
  1182.         (loop rest
  1183.               (cons (if (= start this)
  1184.                 (number->string (+ start 1))
  1185.                 (string-append (number->string (+ start 1))
  1186.                            ":"
  1187.                            (number->string (+ this 1))))
  1188.                 groups)))))
  1189.     (decorated-string-append "" "," "" (reverse! groups)))))
  1190.  
  1191. ;;;; MIME support
  1192.  
  1193. (define-method mime-message-body-structure ((message <imap-message>))
  1194.   (imap-message-bodystructure message))
  1195.  
  1196. (define-method write-message-body ((message <imap-message>) port)
  1197.   (write-mime-message-body-part
  1198.    message '(TEXT) (imap-message-length message) port))
  1199.  
  1200. (define-method write-mime-message-body-part
  1201.     ((message <imap-message>) selector cache? port)
  1202.   (let ((section
  1203.      (map (lambda (x)
  1204.         (if (exact-nonnegative-integer? x)
  1205.             (+ x 1)
  1206.             x))
  1207.           selector)))
  1208.     (let ((entry
  1209.        (list-search-positive (imap-message-body-parts message)
  1210.          (lambda (entry)
  1211.            (equal? (car entry) section)))))
  1212.       (cond (entry
  1213.          (write-string (cdr entry) port))
  1214.         ((and cache?
  1215.           (let ((limit (imail-ui:body-cache-limit message)))
  1216.             (and limit
  1217.              (if (and (exact-nonnegative-integer? cache?)
  1218.                   (exact-nonnegative-integer? limit))
  1219.                  (< cache? limit)
  1220.                  #t))))
  1221.          (let ((part (%imap-message-body-part message section)))
  1222.            (set-imap-message-body-parts!
  1223.         message
  1224.         (cons (cons section part)
  1225.               (imap-message-body-parts message)))
  1226.            (write-string part port)))
  1227.         (else
  1228.          (imap:bind-fetch-body-part-port port
  1229.            (lambda ()
  1230.          (%imap-message-body-part message section))))))))
  1231.  
  1232. (define (%imap-message-body-part message section)
  1233.   (imap:response:fetch-body-part
  1234.    (let ((suffix 
  1235.       (string-append " body"
  1236.              (if (equal? section '(TEXT)) "" " part")
  1237.              " for message "
  1238.              (number->string (+ (message-index message) 1)))))
  1239.      ((imail-ui:message-wrapper "Reading" suffix)
  1240.       (lambda ()
  1241.     (imap:read-literal-progress-hook imail-ui:progress-meter
  1242.       (lambda ()
  1243.         (with-imap-message-open message
  1244.           (lambda (connection)
  1245.         (imap:command:uid-fetch
  1246.          connection
  1247.          (imap-message-uid message)
  1248.          `(',(string-append "body["
  1249.                     (decorated-string-append
  1250.                      "" "." ""
  1251.                      (map (lambda (x)
  1252.                         (if (exact-nonnegative-integer? x)
  1253.                         (number->string x)
  1254.                         (symbol->string x)))
  1255.                       section))
  1256.                     "]"))))))))))
  1257.    section
  1258.    #f))
  1259.  
  1260. (define (parse-mime-body body)
  1261.   (cond ((not (and (pair? body) (list? body))) (parse-mime-body:lose body))
  1262.     ((string? (car body)) (parse-mime-body:one-part body))
  1263.     ((pair? (car body)) (parse-mime-body:multi-part body))
  1264.     (else (parse-mime-body:lose body))))
  1265.  
  1266. (define (parse-mime-body:one-part body)
  1267.   (let ((n (length body)))
  1268.     (cond ((string-ci=? "text" (car body))
  1269.        (if (not (fix:>= n 8))
  1270.            (parse-mime-body:lose body))
  1271.        (apply make-mime-body-text
  1272.           (intern (list-ref body 1))
  1273.           (parse-mime-parameters (list-ref body 2))
  1274.           (list-ref body 3)
  1275.           (list-ref body 4)
  1276.           (intern (list-ref body 5))
  1277.           (list-ref body 6)
  1278.           (list-ref body 7)
  1279.           (parse-mime-body:extensions (list-tail body 8))))
  1280.       ((and (string-ci=? "message" (car body))
  1281.         (string-ci=? "rfc822" (cadr body)))
  1282.        (if (not (fix:>= n 10))
  1283.            (parse-mime-body:lose body))
  1284.        (let* ((enclosed (parse-mime-body (list-ref body 8)))
  1285.           (enclosure
  1286.            (apply make-mime-body-message
  1287.               (parse-mime-parameters (list-ref body 2))
  1288.               (list-ref body 3)
  1289.               (list-ref body 4)
  1290.               (intern (list-ref body 5))
  1291.               (list-ref body 6)
  1292.               (parse-mime-envelope (list-ref body 7))
  1293.               enclosed
  1294.               (list-ref body 9)
  1295.               (parse-mime-body:extensions (list-tail body 10)))))
  1296.          (set-mime-body-enclosure! enclosed enclosure)
  1297.          enclosure))
  1298.       (else
  1299.        (if (not (fix:>= n 7))
  1300.            (parse-mime-body:lose body))
  1301.        (apply make-mime-body-basic
  1302.           (intern (list-ref body 0))
  1303.           (intern (list-ref body 1))
  1304.           (parse-mime-parameters (list-ref body 2))
  1305.           (list-ref body 3)
  1306.           (list-ref body 4)
  1307.           (intern (list-ref body 5))
  1308.           (list-ref body 6)
  1309.           (parse-mime-body:extensions (list-tail body 7)))))))
  1310.  
  1311. (define (parse-mime-body:multi-part body)
  1312.   (let loop ((tail body) (index 0))
  1313.     (if (not (pair? tail))
  1314.     (parse-mime-body:lose body))
  1315.     (if (string? (car tail))
  1316.     (let ((enclosed (map parse-mime-body (sublist body 0 index)))
  1317.           (extensions (parse-mime-body:extensions (cdr tail))))
  1318.       (let ((enclosure
  1319.          (make-mime-body-multipart (intern (car tail))
  1320.                        (parse-mime-parameters
  1321.                         (car extensions))
  1322.                        enclosed
  1323.                        (cadr extensions)
  1324.                        (caddr extensions))))
  1325.         (for-each (lambda (enclosed)
  1326.             (set-mime-body-enclosure! enclosed enclosure))
  1327.               enclosed)
  1328.         enclosure))
  1329.     (loop (cdr tail) (fix:+ index 1)))))
  1330.  
  1331. (define (parse-mime-body:extensions tail)
  1332.   (if (pair? tail)
  1333.       (if (pair? (cdr tail))
  1334.       (let ((disposition (parse-mime-disposition (cadr tail))))
  1335.         (if (pair? (cddr tail))
  1336.         (list (car tail) disposition (caddr tail))
  1337.         (list (car tail) disposition #f)))
  1338.       (list (car tail) #f #f))
  1339.       (list #f #f #f)))
  1340.  
  1341. (define (parse-mime-body:lose body)
  1342.   (error "Unrecognized MIME bodystructure:" body))
  1343.  
  1344. (define (parse-mime-parameters parameters)
  1345.   (let ((lose (lambda () (error "Malformed MIME parameters:" parameters))))
  1346.     (let loop ((parameters parameters) (alist '()))
  1347.       (if (pair? parameters)
  1348.       (if (pair? (cdr parameters))
  1349.           (loop (cddr parameters)
  1350.             (cons (cons (intern (car parameters)) (cadr parameters))
  1351.               alist))
  1352.           (lose))
  1353.       (if (null? parameters)
  1354.           (reverse! alist)
  1355.           (lose))))))
  1356.  
  1357. (define (parse-mime-disposition disposition)
  1358.   (and disposition
  1359.        (begin
  1360.      (if (not (and (pair? disposition)
  1361.                (string? (car disposition))
  1362.                (pair? (cdr disposition))
  1363.                (null? (cddr disposition))))
  1364.          (error "Malformed MIME disposition:" disposition))
  1365.      (cons (intern (car disposition))
  1366.            (parse-mime-parameters (cadr disposition))))))
  1367.  
  1368. (define (parse-mime-envelope envelope)
  1369.   (make-mime-envelope (list-ref envelope 0)
  1370.               (list-ref envelope 1)
  1371.               (parse-mime-addr-list (list-ref envelope 2))
  1372.               (parse-mime-addr-list (list-ref envelope 3))
  1373.               (parse-mime-addr-list (list-ref envelope 4))
  1374.               (parse-mime-addr-list (list-ref envelope 5))
  1375.               (parse-mime-addr-list (list-ref envelope 6))
  1376.               (parse-mime-addr-list (list-ref envelope 7))
  1377.               (list-ref envelope 8)
  1378.               (list-ref envelope 9)))
  1379.  
  1380. (define (parse-mime-addr-list addr-list)
  1381.   (if addr-list
  1382.       (let ((lose
  1383.          (lambda () (error "Malformed MIME address list:" addr-list))))
  1384.     (define (loop addr-list open-groups result)
  1385.       (cond ((pair? addr-list)
  1386.          (let ((a (car addr-list)))
  1387.            (cond ((not (and (list? a) (fix:= 4 (length a))))
  1388.               (lose))
  1389.              ((and (or (not (car a)) (string? (car a)))
  1390.                    (or (not (cadr a)) (string? (cadr a)))
  1391.                    (string? (caddr a))
  1392.                    (string? (cadddr a)))
  1393.               (loop (cdr addr-list)
  1394.                 open-groups
  1395.                 (cons (make-mime-address (car a)
  1396.                              (cadr a)
  1397.                              (caddr a)
  1398.                              (cadddr a))
  1399.                       result)))
  1400.              ((and (not (car a))
  1401.                    (not (cadr a))
  1402.                    (string? (caddr a))
  1403.                    (not (cadddr a)))
  1404.               (loop (cdr addr-list)
  1405.                 (cons (cons (caddr a) result)
  1406.                       open-groups)
  1407.                 '()))
  1408.              ((and (not (car a))
  1409.                    (not (cadr a))
  1410.                    (not (caddr a))
  1411.                    (not (cadddr a))
  1412.                    (pair? open-groups))
  1413.               (loop (cdr addr-list)
  1414.                 (cdr open-groups)
  1415.                 (cons (cons (caar open-groups)
  1416.                         (reverse! result))
  1417.                       (cdar open-groups))))
  1418.              (else (lose)))))
  1419.         ((and (null? addr-list) (null? open-groups)) (reverse! result))
  1420.         (else (lose))))
  1421.     (loop addr-list '() '()))
  1422.       '()))
  1423.  
  1424. ;;;; Server operations
  1425.  
  1426. (define-method %create-resource ((url <imap-url>))
  1427.   (let ((resource
  1428.      (with-open-imap-connection url
  1429.        (lambda (connection)
  1430.          (imap:command:create connection (imap-url-server-mailbox url))))))
  1431.     (flush-imap-url-list-info url)
  1432.     resource))
  1433.  
  1434. (define-method %delete-resource ((url <imap-url>))
  1435.   (with-open-imap-connection url
  1436.     (lambda (connection)
  1437.       (imap:command:delete connection (imap-url-server-mailbox url))))
  1438.   (flush-imap-url-list-info url))
  1439.  
  1440. (define-method %rename-resource ((url <imap-url>) (new-url <imap-url>))
  1441.   (if (compatible-imap-urls? url new-url)
  1442.       (with-open-imap-connection url
  1443.     (lambda (connection)
  1444.       (imap:command:rename connection
  1445.                    (imap-url-server-mailbox url)
  1446.                    (imap-url-server-mailbox new-url))))
  1447.       (error "Unable to perform rename between different IMAP accounts:"
  1448.          url new-url))
  1449.   (flush-imap-url-list-info url)
  1450.   (flush-imap-url-list-info new-url))
  1451.  
  1452. (define-method %append-message ((message <message>) (url <imap-folder-url>))
  1453.   (let ((folder (message-folder message))
  1454.     (maybe-create
  1455.      (lambda (connection thunk)
  1456.        (if (imap:catch-no-response
  1457.         (lambda (response)
  1458.           (let ((code (imap:response:response-text-code response)))
  1459.             (and code
  1460.              (imap:response-code:trycreate? code))))
  1461.         (lambda ()
  1462.           (thunk)
  1463.           #f))
  1464.            (begin
  1465.          (imap:command:create connection (imap-url-server-mailbox url))
  1466.          (thunk)
  1467.          #t)))))
  1468.     (if (let ((url* (resource-locator folder)))
  1469.       (and (imap-url? url*)
  1470.            (compatible-imap-urls? url url*)))
  1471.     (let ((connection (guarantee-imap-folder-open folder)))
  1472.       (maybe-create connection
  1473.         (lambda ()
  1474.           (imap:command:uid-copy connection
  1475.                      (imap-message-uid message)
  1476.                      (imap-url-server-mailbox url)))))
  1477.     (with-open-imap-connection url
  1478.       (lambda (connection)
  1479.         (maybe-create connection
  1480.           (lambda ()
  1481.         (imap:command:append connection
  1482.                      (imap-url-server-mailbox url)
  1483.                      (map imail-flag->imap-flag
  1484.                       (flags-delete
  1485.                        "recent"
  1486.                        (message-flags message)))
  1487.                      (message-internal-time message)
  1488.                      (message->string message)))))))))
  1489.  
  1490. (define-method with-open-connection ((url <imap-url>) thunk)
  1491.   (with-open-imap-connection url
  1492.     (lambda (connection)
  1493.       connection
  1494.       (thunk))))
  1495.  
  1496. ;;;; Folder operations
  1497.  
  1498. (define-method open-resource ((url <imap-folder-url>))
  1499.   (let ((folder (maybe-make-resource url make-imap-folder)))
  1500.     (guarantee-imap-folder-open folder)
  1501.     folder))
  1502.  
  1503. (define-method close-resource ((folder <imap-folder>) no-defer?)
  1504.   (close-imap-folder folder no-defer?))
  1505.  
  1506. (define (close-imap-folder folder no-defer?)
  1507.   (let ((connection
  1508.      (without-interrupts
  1509.       (lambda ()
  1510.         (let ((connection (imap-folder-connection folder)))
  1511.           (if connection
  1512.           (begin
  1513.             (set-imap-folder-connection! folder #f)
  1514.             (set-imap-connection-folder! connection #f)
  1515.             (decrement-connection-reference-count! connection)))
  1516.           connection)))))
  1517.     (if connection
  1518.     (begin
  1519.       (maybe-close-imap-connection connection 0 no-defer?)
  1520.       (object-modified! folder 'STATUS)))))
  1521.  
  1522. (define-method %get-message ((folder <imap-folder>) index)
  1523.   (vector-ref (imap-folder-messages folder) index))
  1524.  
  1525. (define-method first-unseen-message-index ((folder <imap-folder>))
  1526.   (or (imap-folder-unseen folder) 0))
  1527.  
  1528. (define-method expunge-deleted-messages ((folder <imap-folder>))
  1529.   (imap:command:expunge (guarantee-imap-folder-open folder)))
  1530.  
  1531. (define-method search-folder ((folder <imap-folder>) criteria)
  1532.   (map (lambda (index) (- index 1))
  1533.        (imap:response:search-indices
  1534.     (let ((connection (guarantee-imap-folder-open folder)))
  1535.       (cond ((string? criteria)
  1536.          (imap:command:search connection 'TEXT criteria))
  1537.         (else
  1538.          (error:wrong-type-argument criteria
  1539.                         "search criteria"
  1540.                         'SEARCH-FOLDER)))))))
  1541.  
  1542. (define-method folder-sync-status ((folder <imap-folder>))
  1543.   ;; Changes are always written through.
  1544.   folder
  1545.   'SYNCHRONIZED)
  1546.  
  1547. (define-method save-resource ((folder <imap-folder>))
  1548.   ;; Changes are always written through.
  1549.   folder
  1550.   #f)
  1551.  
  1552. (define-method discard-folder-cache ((folder <imap-folder>))
  1553.   (close-resource folder #f)
  1554.   (reset-imap-folder! folder))
  1555.  
  1556. (define-method probe-folder ((folder <imap-folder>))
  1557.   (imap:command:noop (guarantee-imap-folder-open folder)))
  1558.  
  1559. (define-method folder-connection-status ((folder <imap-folder>))
  1560.   (if (let ((connection (imap-folder-connection folder)))
  1561.     (and connection
  1562.          (test-imap-connection-open connection)))
  1563.       'ONLINE
  1564.       'OFFLINE))
  1565.  
  1566. (define-method disconnect-folder ((folder <imap-folder>))
  1567.   (close-resource folder #t))
  1568.  
  1569. (define-method folder-supports-mime? ((folder <imap-folder>))
  1570.   folder
  1571.   #t)
  1572.  
  1573. ;;;; Container operations
  1574.  
  1575. (define-method open-resource ((url <imap-container-url>))
  1576.   (let ((container (maybe-make-resource url make-imap-container)))
  1577.     (guarantee-imap-connection-open
  1578.      (without-interrupts
  1579.       (lambda ()
  1580.     (or (imap-container-connection container)
  1581.         (let ((connection (get-compatible-imap-connection url)))
  1582.           (set-imap-container-connection! container connection)
  1583.           (increment-connection-reference-count! connection)
  1584.           connection)))))
  1585.     (object-modified! container 'STATUS)
  1586.     container))
  1587.  
  1588. (define-method close-resource ((container <imap-container>) no-defer?)
  1589.   (let ((connection
  1590.      (without-interrupts
  1591.       (lambda ()
  1592.         (let ((connection (imap-container-connection container)))
  1593.           (if connection
  1594.           (begin
  1595.             (set-imap-container-connection! container #f)
  1596.             (decrement-connection-reference-count! connection)))
  1597.           connection)))))
  1598.     (if connection
  1599.     (begin
  1600.       (maybe-close-imap-connection connection 0 no-defer?)
  1601.       (object-modified! container 'STATUS)))))
  1602.  
  1603. (define-method save-resource ((container <imap-container>))
  1604.   container
  1605.   #f)
  1606.  
  1607. ;;;; IMAP command invocation
  1608.  
  1609. (define (imap:command:capability connection)
  1610.   (imap:command:no-response connection 'CAPABILITY))
  1611.  
  1612. (define (imap:command:namespace connection)
  1613.   (imap:command:single-response imap:response:namespace? connection
  1614.                 'NAMESPACE))
  1615.  
  1616. (define (imap:command:login connection user-id pass-phrase)
  1617.   ((imail-ui:message-wrapper "Logging in as " user-id)
  1618.    (lambda ()
  1619.      (imap:command:no-response connection 'LOGIN user-id pass-phrase))))
  1620.  
  1621. (define (imap:command:select connection mailbox)
  1622.   ((imail-ui:message-wrapper "Selecting mailbox")
  1623.    (lambda ()
  1624.      (imap:command:no-response connection 'SELECT
  1625.                    (imap:encode-mailbox-name mailbox)))))
  1626.  
  1627. (define (imap:command:status connection mailbox items)
  1628.   (imap:command:single-response imap:response:status? connection 'STATUS
  1629.                 (imap:encode-mailbox-name mailbox)
  1630.                 items))
  1631.  
  1632. (define (imap:command:fetch connection index items)
  1633.   (imap:command:fetch-response connection 'FETCH (list (+ index 1) items)))
  1634.  
  1635. (define (imap:command:uid-fetch connection uid items)
  1636.   (imap:command:fetch-response connection 'UID (list 'FETCH uid items)))
  1637.  
  1638. (define (imap:command:fetch-response connection command arguments)
  1639.   (let ((responses (apply imap:command connection command arguments)))
  1640.     (if (and (pair? (cdr responses))
  1641.          (for-all? (cdr responses) imap:response:fetch?))
  1642.     (if (null? (cddr responses))
  1643.         (cadr responses)
  1644.         ;; Some servers, notably UW IMAP, sometimes return
  1645.         ;; multiple FETCH responses.  This can happen even if only
  1646.         ;; one item is fetched.  Since the caller expects a single
  1647.         ;; response, synthesize one from the available responses.
  1648.         (cons* (caadr responses)
  1649.            (cadadr responses)
  1650.            (append-map cddr (cdr responses))))
  1651.     (error "Malformed response from IMAP server:" responses))))
  1652.  
  1653. (define (imap:command:fetch-range connection start end items)
  1654.   (imap:command:fetch-set connection
  1655.               (string-append (number->string (+ start 1))
  1656.                      ":"
  1657.                      (if end (number->string end) "*"))
  1658.               items))
  1659.  
  1660. (define (imap:command:fetch-set connection set items)
  1661.   (imap:command:multiple-response imap:response:fetch? connection
  1662.                   'FETCH `',set items))
  1663.  
  1664. (define (imap:command:uid-store-flags connection uid flags)
  1665.   (imap:command:no-response connection 'UID 'STORE uid 'FLAGS flags))
  1666.  
  1667. (define (imap:command:expunge connection)
  1668.   ((imail-ui:message-wrapper "Expunging messages")
  1669.    (lambda ()
  1670.      (imap:command:no-response connection 'EXPUNGE))))
  1671.  
  1672. (define (imap:command:noop connection)
  1673.   (imap:command:no-response connection 'NOOP))
  1674.  
  1675. (define (imap:command:logout connection)
  1676.   (imap:command:no-response connection 'LOGOUT))
  1677.  
  1678. (define (imap:command:create connection mailbox)
  1679.   (imap:command:no-response connection 'CREATE
  1680.                 (imap:encode-mailbox-name mailbox)))
  1681.  
  1682. (define (imap:command:delete connection mailbox)
  1683.   (imap:command:no-response connection 'DELETE
  1684.                 (imap:encode-mailbox-name mailbox)))
  1685.  
  1686. (define (imap:command:rename connection from to)
  1687.   (imap:command:no-response connection 'RENAME
  1688.                 (imap:encode-mailbox-name from)
  1689.                 (imap:encode-mailbox-name to)))
  1690.  
  1691. (define (imap:command:uid-copy connection uid mailbox)
  1692.   (imap:command:no-response connection 'UID 'COPY
  1693.                 uid (imap:encode-mailbox-name mailbox)))
  1694.  
  1695. (define (imap:command:append connection mailbox flags time text)
  1696.   (imap:command:no-response connection 'APPEND
  1697.                 (imap:encode-mailbox-name mailbox)
  1698.                 (and (pair? flags) flags)
  1699.                 (and time (imap:universal-time->date-time time))
  1700.                 (cons 'LITERAL text)))
  1701.  
  1702. (define (imap:command:search connection . key-plist)
  1703.   (apply imap:command:single-response imap:response:search? connection
  1704.      'SEARCH key-plist))
  1705.  
  1706. (define (imap:command:list connection reference pattern)
  1707.   (imap:command:multiple-response imap:response:list? connection 'LIST
  1708.                   (imap:encode-mailbox-name reference)
  1709.                   (imap:encode-mailbox-name pattern)))
  1710.  
  1711. (define (imap:command:get-delimiter connection reference)
  1712.   (imap:command:single-response imap:response:list? connection 'LIST
  1713.                 (imap:encode-mailbox-name reference)
  1714.                 (imap:encode-mailbox-name "")))
  1715.  
  1716. (define (imap:command:no-response connection command . arguments)
  1717.   (let ((responses (apply imap:command connection command arguments)))
  1718.     (if (not (null? (cdr responses)))
  1719.     (error "Malformed response from IMAP server:" responses))
  1720.     (car responses)))
  1721.  
  1722. (define (imap:command:single-response predicate connection command . arguments)
  1723.   (let ((responses (apply imap:command connection command arguments)))
  1724.     (if (and (pair? (cdr responses))
  1725.          (predicate (cadr responses))
  1726.          (null? (cddr responses)))
  1727.     (cadr responses)
  1728.     (error "Malformed response from IMAP server:" responses))))
  1729.  
  1730. (define (imap:command:multiple-response predicate
  1731.                     connection command . arguments)
  1732.   (let ((responses (apply imap:command connection command arguments)))
  1733.     (if (for-all? (cdr responses) predicate)
  1734.     (cdr responses)
  1735.     (error "Malformed response from IMAP server:" responses))))
  1736.  
  1737. (define condition-type:imap-server-error
  1738.   (make-condition-type 'IMAP-SERVER-ERROR condition-type:error '(RESPONSE)
  1739.     (lambda (condition port)
  1740.       (let ((response (imap:server-error:response condition)))
  1741.     (write-string "Server signalled a command error: " port)
  1742.     (write-string (imap:response:response-text-string response) port)
  1743.     (let ((code (imap:response:response-text-code response)))
  1744.       (if code
  1745.           (begin
  1746.         (write-char #\space port)
  1747.         (write code port))))))))
  1748.  
  1749. (define imap:server-error
  1750.   (condition-signaller condition-type:imap-server-error
  1751.                '(RESPONSE)
  1752.                standard-error-handler))
  1753.  
  1754. (define imap:server-error:response
  1755.   (condition-accessor condition-type:imap-server-error 'RESPONSE))
  1756.  
  1757. (define (imap:command connection command . arguments)
  1758.   (bind-condition-handler '()
  1759.       (lambda (condition)
  1760.     (if (not (eq? (condition/type condition)
  1761.               condition-type:imap-server-error))
  1762.         (begin
  1763.           (close-imap-connection connection)
  1764.           (if (broken-pipe? condition)
  1765.           (error
  1766.            "Connection to IMAP server broken; please try again.")))))
  1767.     (lambda ()
  1768.       (imap:wait-for-tagged-response
  1769.        connection
  1770.        (imap:send-command connection command arguments)
  1771.        (if (eq? command 'UID)
  1772.        (car arguments)
  1773.        command)))))
  1774.  
  1775. (define (start-imap-trace pathname)
  1776.   (stop-imap-trace)
  1777.   (set! imap-trace-port (open-output-file pathname))
  1778.   unspecific)
  1779.  
  1780. (define (stop-imap-trace)
  1781.   (if imap-trace-port
  1782.       (begin
  1783.     (close-port imap-trace-port)
  1784.     (set! imap-trace-port #f)
  1785.     unspecific)))
  1786.  
  1787. (define imap-trace-port #f)
  1788.  
  1789. (define (imap:send-command connection command arguments)
  1790.   (let ((tag (next-imap-command-tag connection))
  1791.     (port (imap-connection-port connection)))
  1792.     (if imap-trace-port
  1793.     (begin
  1794.       (write-line (cons* 'SEND tag command
  1795.                  (if (eq? command 'LOGIN)
  1796.                  (cons* (car arguments)
  1797.                     "password"
  1798.                     (cddr arguments))
  1799.                  arguments))
  1800.               imap-trace-port)
  1801.       (flush-output imap-trace-port)))
  1802.     (imap-transcript-write-string tag port)
  1803.     (imap-transcript-write-char #\space port)
  1804.     (imap-transcript-write command port)
  1805.     (for-each (lambda (argument)
  1806.         (if argument
  1807.             (begin
  1808.               (imap-transcript-write-char #\space port)
  1809.               (imap:send-command-argument connection tag argument))))
  1810.           arguments)
  1811.     (imap-transcript-write-char #\return port)
  1812.     (imap-transcript-write-char #\linefeed port)
  1813.     (imap-transcript-flush-output port)
  1814.     tag))
  1815.  
  1816. (define (imap:send-command-argument connection tag argument)
  1817.   (let ((port (imap-connection-port connection)))
  1818.     (let loop ((argument argument))
  1819.       (cond ((or (symbol? argument)
  1820.          (exact-nonnegative-integer? argument))
  1821.          (imap-transcript-write argument port))
  1822.         ((and (pair? argument)
  1823.           (eq? (car argument) 'QUOTE)
  1824.           (pair? (cdr argument))
  1825.           (string? (cadr argument))
  1826.           (null? (cddr argument)))
  1827.          (imap-transcript-write-string (cadr argument) port))
  1828.         ((and (pair? argument)
  1829.           (eq? (car argument) 'LITERAL)
  1830.           (string? (cdr argument)))
  1831.          (imap:write-literal-string connection tag (cdr argument)))
  1832.         ((string? argument)
  1833.          (if (imap:string-may-be-quoted? argument)
  1834.          (imap:write-quoted-string argument port)
  1835.          (imap:write-literal-string connection tag argument)))
  1836.         ((list? argument)
  1837.          (imap-transcript-write-char #\( port)
  1838.          (if (pair? argument)
  1839.          (begin
  1840.            (loop (car argument))
  1841.            (for-each (lambda (object)
  1842.                    (imap-transcript-write-char #\space port)
  1843.                    (loop object))
  1844.                  (cdr argument))))
  1845.          (imap-transcript-write-char #\) port))
  1846.         (else (error "Illegal IMAP syntax:" argument))))))
  1847.  
  1848. (define (imap:write-literal-string connection tag string)
  1849.   (let ((port (imap-connection-port connection)))
  1850.     (imap:write-literal-string-header string port)
  1851.     (imap-transcript-flush-output port)
  1852.     (let loop ()
  1853.       (let ((response (imap:read-server-response-1 port)))
  1854.     (cond ((imap:response:continue? response)
  1855.            (imap:write-literal-string-body string port))
  1856.           ((and (imap:response:tag response)
  1857.             (string-ci=? tag (imap:response:tag response)))
  1858.            (imap:server-error response))
  1859.           (else
  1860.            (enqueue-imap-response connection response)
  1861.            (loop)))))))
  1862.  
  1863. (define (imap:wait-for-tagged-response connection tag command)
  1864.   (let ((port (imap-connection-port connection)))
  1865.     (let loop ()
  1866.       (let ((response (imap:read-server-response-1 port)))
  1867.     (let ((tag* (imap:response:tag response)))
  1868.       (if tag*
  1869.           (let ((responses (process-queued-responses connection command)))
  1870.         (if (string-ci=? tag tag*)
  1871.             (if (imap:response:ok? response)
  1872.             (cons response responses)
  1873.             (imap:server-error response))
  1874.             (if (< (base26-string->nonnegative-integer tag*)
  1875.                (base26-string->nonnegative-integer tag))
  1876.             ;; If this is an old tag, ignore it and move on.
  1877.             (loop)
  1878.             (error "Out-of-sequence tag:" tag* tag))))
  1879.           (begin
  1880.         (enqueue-imap-response connection response)
  1881.         (loop))))))))
  1882.  
  1883. (define (imap:read-server-response-1 port)
  1884.   (let ((response (imap:read-server-response port)))
  1885.     (if imap-trace-port
  1886.     (begin
  1887.       (write-line (list 'RECEIVE response) imap-trace-port)
  1888.       (flush-output imap-trace-port)))
  1889.     response))
  1890.  
  1891. (define (imap:catch-no-response predicate thunk)
  1892.   (call-with-current-continuation
  1893.    (lambda (k)
  1894.      (bind-condition-handler
  1895.      (list condition-type:imap-server-error)
  1896.      (lambda (condition)
  1897.        (let ((response (imap:server-error:response condition)))
  1898.          (if (and (imap:response:no? response)
  1899.               (or (not predicate) (predicate response)))
  1900.          (k response))))
  1901.        thunk))))
  1902.  
  1903. (define (process-queued-responses connection command)
  1904.   (with-modification-events-deferred
  1905.     (lambda ()
  1906.       (let loop ((responses (dequeue-imap-responses connection)))
  1907.     (if (pair? responses)
  1908.         (if (process-response connection command (car responses))
  1909.         (cons (car responses) (loop (cdr responses)))
  1910.         (loop (cdr responses)))
  1911.         '())))))
  1912.  
  1913. (define (process-response connection command response)
  1914.   (cond ((imap:response:status-response? response)
  1915.      (let ((code (imap:response:response-text-code response))
  1916.            (text (imap:response:response-text-string response)))
  1917.        (if code
  1918.            (process-response-text connection command code text))
  1919.        (if (and (imap:response:bye? response)
  1920.             (not (memq command '(LOGOUT #F))))
  1921.            (begin
  1922.          (close-imap-connection connection)
  1923.          (error "Server shut down connection:" text)))
  1924.        (if (or (imap:response:no? response)
  1925.            (imap:response:bad? response))
  1926.            (imail-ui:present-user-alert
  1927.         (lambda (port)
  1928.           (write-string "Notice from IMAP server:" port)
  1929.           (newline port)
  1930.           (display text port)
  1931.           (newline port)))))
  1932.      (imap:response:preauth? response))
  1933.     ((imap:response:exists? response)
  1934.      (with-imap-connection-folder connection
  1935.        (lambda (folder)
  1936.          (update-imap-folder-length!
  1937.           folder
  1938.           (imap:response:exists-count response))))
  1939.      #f)
  1940.     ((imap:response:expunge? response)
  1941.      (with-imap-connection-folder connection
  1942.        (lambda (folder)
  1943.          (remove-imap-folder-message
  1944.           folder
  1945.           (- (imap:response:expunge-index response) 1))))
  1946.      #f)
  1947.     ((imap:response:flags? response)
  1948.      (with-imap-connection-folder connection
  1949.        (lambda (folder)
  1950.          (set-imap-folder-allowed-flags!
  1951.           folder
  1952.           (map imap-flag->imail-flag (imap:response:flags response)))))
  1953.      #f)
  1954.     ((imap:response:recent? response)
  1955.      #f)
  1956.     ((imap:response:capability? response)
  1957.      (set-imap-connection-capabilities!
  1958.       connection
  1959.       (imap:response:capabilities response))
  1960.      #f)
  1961.     ((imap:response:namespace? response)
  1962.      #t)
  1963.     ((imap:response:list? response)
  1964.      (eq? command 'LIST))
  1965.     ((imap:response:lsub? response)
  1966.      (eq? command 'LSUB))
  1967.     ((imap:response:search? response)
  1968.      (eq? command 'SEARCH))
  1969.     ((imap:response:status? response)
  1970.      (eq? command 'STATUS))
  1971.     ((imap:response:fetch? response)
  1972.      (with-imap-connection-folder connection
  1973.        (lambda (folder)
  1974.          (process-fetch-attributes
  1975.           (get-message folder
  1976.                (- (imap:response:fetch-index response) 1))
  1977.           response)))
  1978.      (eq? command 'FETCH))
  1979.     (else
  1980.      (error "Illegal server response:" response))))
  1981.  
  1982. (define (process-response-text connection command code text)
  1983.   command
  1984.   (cond ((imap:response-code:alert? code)
  1985.      (imail-ui:present-user-alert
  1986.       (lambda (port)
  1987.         (write-string "Alert from IMAP server:" port)
  1988.         (newline port)
  1989.         (display text port)
  1990.         (newline port))))
  1991.     ((imap:response-code:permanentflags? code)
  1992.      (with-imap-connection-folder connection
  1993.        (lambda (folder)
  1994.          (let ((pflags (imap:response-code:permanentflags code)))
  1995.            (set-imap-folder-permanent-keywords?!
  1996.         folder
  1997.         (if (memq '\* pflags) #t #f))
  1998.            (set-imap-folder-permanent-flags!
  1999.         folder
  2000.         (map imap-flag->imail-flag (delq '\* pflags)))))))
  2001.     ((imap:response-code:read-only? code)
  2002.      (with-imap-connection-folder connection
  2003.        (lambda (folder)
  2004.          (set-imap-folder-read-only?! folder #t))))
  2005.     ((imap:response-code:read-write? code)
  2006.      (with-imap-connection-folder connection
  2007.        (lambda (folder)
  2008.          (set-imap-folder-read-only?! folder #f))))
  2009.     ((imap:response-code:uidnext? code)
  2010.      (with-imap-connection-folder connection
  2011.        (lambda (folder)
  2012.          (set-imap-folder-uidnext! folder
  2013.                        (imap:response-code:uidnext code)))))
  2014.     ((imap:response-code:uidvalidity? code)
  2015.      (with-imap-connection-folder connection
  2016.        (lambda (folder)
  2017.          (let ((uidvalidity (imap:response-code:uidvalidity code)))
  2018.            (if (not (eqv? uidvalidity (imap-folder-uidvalidity folder)))
  2019.            (new-imap-folder-uidvalidity! folder uidvalidity))))))
  2020.     ((imap:response-code:unseen? code)
  2021.      (with-imap-connection-folder connection
  2022.        (lambda (folder)
  2023.          (set-imap-folder-unseen!
  2024.           folder
  2025.           (- (imap:response-code:unseen code) 1)))))
  2026.     #|
  2027.     ((or (imap:response-code:badcharset? code)
  2028.          (imap:response-code:newname? code)
  2029.          (imap:response-code:parse? code)
  2030.          (imap:response-code:trycreate? code))
  2031.      unspecific)
  2032.     |#
  2033.     ))
  2034.  
  2035. (define (process-fetch-attributes message response)
  2036.   (for-each
  2037.    (lambda (keyword)
  2038.      (process-fetch-attribute message
  2039.                   keyword
  2040.                   (imap:response:fetch-attribute response
  2041.                                  keyword)))
  2042.    (imap:response:fetch-attribute-keywords response)))
  2043.  
  2044. (define (process-fetch-attribute message keyword datum)
  2045.   (case keyword
  2046.     ((BODYSTRUCTURE)
  2047.      (%set-imap-message-bodystructure! message (parse-mime-body datum))
  2048.      #t)
  2049.     ((ENVELOPE)
  2050.      (%set-imap-message-envelope! message datum)
  2051.      #t)
  2052.     ((FLAGS)
  2053.      (%set-message-flags! message (map imap-flag->imail-flag datum))
  2054.      #t)
  2055.     ((RFC822.HEADER)
  2056.      (%set-message-header-fields! message (string->header-fields datum))
  2057.      #t)
  2058.     ((RFC822.SIZE)
  2059.      (%set-imap-message-length! message datum)
  2060.      #t)
  2061.     ((UID)
  2062.      (%set-imap-message-uid! message datum)
  2063.      #t)
  2064.     (else #f)))
  2065.  
  2066. (define (with-imap-connection-folder connection receiver)
  2067.   (let ((folder (imap-connection-folder connection)))
  2068.     (if folder
  2069.     (receiver folder))))
  2070.  
  2071. (define %set-message-header-fields!
  2072.   (slot-modifier <imap-message> 'HEADER-FIELDS))
  2073.  
  2074. (define %message-flags-initialized?
  2075.   (slot-initpred <imap-message> 'FLAGS))
  2076.  
  2077. (define %set-imap-message-uid!
  2078.   (slot-modifier <imap-message> 'UID))
  2079.  
  2080. (define %set-imap-message-length!
  2081.   (slot-modifier <imap-message> 'LENGTH))
  2082.  
  2083. (define %set-imap-message-envelope!
  2084.   (slot-modifier <imap-message> 'ENVELOPE))
  2085.  
  2086. (define %set-imap-message-bodystructure!
  2087.   (slot-modifier <imap-message> 'BODYSTRUCTURE))