Implement all of the IMAP server operations except for

AVAILABLE-FOLDER-NAMES.

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 644d4657c10b4b24e40e837049996cfb5feee581..3d5c78ff03291e75f11c1c53956fea33232902cd 100644 (file)
--- a/v7/src/imail/imail-imap.scm
+++ b/v7/src/imail/imail-imap.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-imap.scm,v 1.39 2000/05/16 02:16:42 cph Exp $
+;;; $Id: imail-imap.scm,v 1.40 2000/05/16 03:13:29 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -518,16 +518,37 @@
 ;;;; Server operations
 
 (define-method %create-folder ((url <imap-url>))
-  ???)
+  (imap:command:create (get-imap-connection url)
+                      (imap-url-mailbox url)))
 
 (define-method %delete-folder ((url <imap-url>))
-  ???)
+  (imap:command:create (get-imap-connection url)
+                      (imap-url-mailbox url)))
 
 (define-method %rename-folder ((url <imap-url>) (new-url <imap-url>))
-  ???)
+  (if (compatible-imap-urls? url new-url)
+      (imap:command:create (get-imap-connection url)
+                          (imap-url-mailbox url)
+                          (imap-url-mailbox new-url))
+      (error "Unable to perform rename between different IMAP accounts:"
+            url new-url)))
 
 (define-method %append-message ((message <message>) (url <imap-url>))
-  ???)
+  (if (let ((url* (folder-url (message-folder message))))
+       (and (imap-url? url*)
+            (compatible-imap-urls? url url*)))
+      (imap:command:copy (imap-message-connection message)
+                        (message-index message)
+                        (imap-url-mailbox url))
+      (imap:command:append
+       (get-imap-connection url)
+       (imap-url-mailbox url)
+       (message-flags message)
+       (message-internal-time message)
+       (string-append
+       (header-fields->string (message-header-fields message))
+       "\n"
+       (message-body message)))))
 
 (define-method available-folder-names ((url <imap-url>))
   ???)
@@ -607,13 +628,13 @@
 (define (imap:command:login connection user-id passphrase)
   ((imail-message-wrapper "Logging in as " user-id)
    (lambda ()
-     (imap:command:no-response connection 'LOGIN user-id passphrase))))
+     (imap:command:no-response-1 connection 'LOGIN user-id passphrase))))
 
 (define (imap:command:select connection mailbox)
   ((imail-message-wrapper "Select mailbox " mailbox)
    (lambda ()
      (imap:response:ok?
-      (imap:command:no-response connection 'SELECT mailbox)))))
+      (imap:command:no-response-1 connection 'SELECT mailbox)))))
 
 (define (imap:command:fetch connection index items)
   (imap:command:single-response imap:response:fetch?
@@ -647,8 +668,34 @@
 
 (define (imap:command:noop connection)
   (imap:command:no-response connection 'NOOP))
+
+(define (imap:command:create connection mailbox)
+  (imap:command:no-response connection 'CREATE mailbox))
+
+(define (imap:command:delete connection mailbox)
+  (imap:command:no-response connection 'DELETE mailbox))
+
+(define (imap:command:rename connection from to)
+  (imap:command:no-response connection 'RENAME from to))
+
+(define (imap:command:copy connection index mailbox)
+  (imap:command:no-response connection 'COPY (+ index 1) mailbox))
+
+(define (imap:command:append connection mailbox flags time text)
+  (imap:command:no-response connection
+                           'APPEND
+                           mailbox
+                           (and (pair? flags) flags)
+                           (imap:universal-time->date-time time)
+                           (cons 'LITERAL text)))
 \f
 (define (imap:command:no-response connection command . arguments)
+  (let ((response
+        (apply imap:command:no-response-1 connection command . arguments)))
+    (if (not (imap:response:ok? response))
+       (error "Server signalled a command error:" response))))
+
+(define (imap:command:no-response-1 connection command . arguments)
   (let ((responses (apply imap:command connection command arguments)))
     (if (not (null? (cdr responses)))
        (error "Malformed response from IMAP server:" responses))
@@ -727,8 +774,10 @@
     (write-char #\space port)
     (write command port)
     (for-each (lambda (argument)
-               (write-char #\space port)
-               (imap:send-command-argument connection tag argument))
+               (if argument
+                   (begin
+                     (write-char #\space port)
+                     (imap:send-command-argument connection tag argument))))
              arguments)
     (write-char #\return port)
     (write-char #\linefeed port)
@@ -745,6 +794,10 @@
                  (eq? (car argument) 'ATOM)
                  (string? (cdr argument)))
             (write-string (cdr argument) port))
+           ((and (pair? argument)
+                 (eq? (car argument) 'LITERAL)
+                 (string? (cdr argument)))
+            (imap:write-literal-string connection tag (cdr argument)))
            ((string? argument)
             (if (imap:string-may-be-quoted? argument)
                 (imap:write-quoted-string argument port)

diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index f030780a3669a4c6f604a12ff0080be7764f2dc6..55c590b68484be8306e8f0696a2f731861affaa2 100644 (file)
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.31 2000/05/16 01:46:30 cph Exp $
+;;; $Id: imail.pkg,v 1.32 2000/05/16 03:13:41 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -139,6 +139,7 @@
          imap:quoted-special?
          imap:server-parser
          imap:string-may-be-quoted?
+         imap:universal-time->date-time
          imap:write-literal-string-body
          imap:write-literal-string-header
          imap:write-quoted-string))

diff --git a/v7/src/imail/imap-syntax.scm b/v7/src/imail/imap-syntax.scm
index f16d85ea4ab38cb4d3b86fab4367b28c8afc8a93..b435c03650fbf4482f1168e47e4cf9350f34d051 100644 (file)
--- a/v7/src/imail/imap-syntax.scm
+++ b/v7/src/imail/imap-syntax.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imap-syntax.scm,v 1.7 2000/05/16 01:46:42 cph Exp $
+;;; $Id: imap-syntax.scm,v 1.8 2000/05/16 03:13:43 cph Exp $
 ;;;
 ;;; Copyright (c) 2000 Massachusetts Institute of Technology
 ;;;
@@ -598,4 +598,25 @@
   (imap:write-literal-substring-body string 0 (string-length string) port))
 
 (define (imap:write-literal-substring-body string start end port)
-  (write-substring string start end port))
\ No newline at end of file
+  (write-substring string start end port))
+
+(define (imap:universal-time->date-time time)
+  (imap:decoded-time->date-time (universal-time->global-decoded-time time)))
+
+(define (imap:decoded-time->date-time dt)
+  (let ((2digit
+        (lambda (n)
+          (string-pad-left (number->string n) 2 #\0))))
+    (string-append (string-pad-left (number->string (decoded-time/day dt)) 2)
+                  "-"
+                  (month/short-string (decoded-time/month dt))
+                  "-"
+                  (number->string (decoded-time/year dt))
+                  " "
+                  (2digit (decoded-time/hour dt))
+                  ":"
+                  (2digit (decoded-time/minute dt))
+                  ":"
+                  (2digit (decoded-time/second dt))
+                  " "
+                  (time-zone->string (decoded-time/zone dt)))))
\ No newline at end of file