Implement commands to create and delete folders. Put in special hack

to prepend "inbox." to folder names when using Cyrus.

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 81c489dec97bd7492f94e1dfaf075eb000f90852..3686c25614804ba53e44761de114454cfa3a4497 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.55 2000/05/18 19:59:37 cph Exp $
+;;; $Id: imail-imap.scm,v 1.56 2000/05/18 22:11:14 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -103,6 +103,8 @@
              initial-value #f)
   (port define standard
        initial-value #f)
+  (greeting define standard
+           initial-value #f)
   (sequence-number define standard
                   initial-value 0)
   (response-queue define accessor
@@ -200,7 +202,12 @@
            (user-id (imap-connection-user-id connection)))
        (let ((port
               (open-tcp-stream-socket host (or ip-port "imap2") #f "\n")))
-         (read-line port)      ;discard server announcement
+         (set-imap-connection-greeting!
+          connection
+          (let ((response (imap:read-server-response port)))
+            (if (imap:response:ok? response)
+                (imap:response:response-text-string response)
+                response)))
          (set-imap-connection-port! connection port)
          (reset-imap-connection connection)
          (if (not (memq 'IMAP4REV1 (imap:command:capability connection)))
@@ -227,6 +234,12 @@
 
 (define (imap-connection-open? connection)
   (imap-connection-port connection))
+
+(define (imap-connection-server-type connection)
+  (let ((greeting (imap-connection-greeting connection)))
+    (cond ((not (string? greeting)) #f)
+         ((string-search-forward " Cyrus " greeting) 'CYRUS)
+         (else #f))))
 \f
 (define (call-with-memoized-passphrase connection receiver)
   (let ((passphrase (imap-connection-passphrase connection)))
@@ -587,7 +600,7 @@
                       (imap-url-mailbox url)))
 
 (define-method %delete-folder ((url <imap-url>))
-  (imap:command:create (get-imap-connection url)
+  (imap:command:delete (get-imap-connection url)
                       (imap-url-mailbox url)))
 
 (define-method %rename-folder ((url <imap-url>) (new-url <imap-url>))
@@ -743,26 +756,31 @@
   ((imail-message-wrapper "Expunging messages")
    (lambda ()
      (imap:command:no-response connection 'EXPUNGE))))
-
+\f
 (define (imap:command:noop connection)
   (imap:command:no-response connection 'NOOP))
 
 (define (imap:command:create connection mailbox)
-  (imap:command:no-response connection 'CREATE mailbox))
+  (imap:command:no-response connection 'CREATE
+                           (adjust-mailbox-name connection mailbox)))
 
 (define (imap:command:delete connection mailbox)
-  (imap:command:no-response connection 'DELETE mailbox))
+  (imap:command:no-response connection 'DELETE
+                           (adjust-mailbox-name connection mailbox)))
 
 (define (imap:command:rename connection from to)
-  (imap:command:no-response connection 'RENAME from to))
+  (imap:command:no-response connection 'RENAME
+                           (adjust-mailbox-name connection from)
+                           (adjust-mailbox-name connection to)))
 
 (define (imap:command:copy connection index mailbox)
-  (imap:command:no-response connection 'COPY (+ index 1) mailbox))
+  (imap:command:no-response connection 'COPY (+ index 1)
+                           (adjust-mailbox-name connection mailbox)))
 
 (define (imap:command:append connection mailbox flags time text)
   (imap:command:no-response connection
                            'APPEND
-                           mailbox
+                           (adjust-mailbox-name connection mailbox)
                            (and (pair? flags) flags)
                            (imap:universal-time->date-time time)
                            (cons 'LITERAL text)))
@@ -770,12 +788,22 @@
 (define (imap:command:search connection . key-plist)
   (apply imap:command:single-response imap:response:search?
         connection 'SEARCH key-plist))
+
+(define (adjust-mailbox-name connection mailbox)
+  (case (imap-connection-server-type connection)
+    ((CYRUS)
+     (if (or (string-ci=? "inbox" mailbox)
+            (string-prefix-ci? "inbox." mailbox)
+            (string-prefix-ci? "user." mailbox))
+        mailbox
+        (string-append "inbox." mailbox)))
+    (else mailbox)))
 \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))))
+       (imap:server-error response))))
 
 (define (imap:command:no-response-1 connection command . arguments)
   (let ((responses (apply imap:command connection command arguments)))
@@ -791,7 +819,7 @@
                 (null? (cddr responses)))
            (cadr responses)
            (error "Malformed response from IMAP server:" responses))
-       (error "Server signalled a command error:" (car responses)))))
+       (imap:server-error (car responses)))))
 
 (define (imap:command:multiple-response predicate
                                        connection command . arguments)
@@ -800,7 +828,16 @@
        (if (for-all? (cdr responses) predicate)
            (cdr responses)
            (error "Malformed response from IMAP server:" responses))
-       (error "Server signalled a command error:" (car responses)))))
+       (imap:server-error (car responses)))))
+
+(define (imap:server-error response)
+  (let ((msg
+        (string-append "Server signalled a command error: "
+                       (imap:response:response-text-string response)))
+       (code (imap:response:response-text-code response)))
+    (if code
+       (error msg code)
+       (error msg))))
 
 (define (imap:command connection command . arguments)
   (bind-condition-handler (list condition-type:system-call-error)

diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index dcb3c3ee4cc958230009cf471e1bfd8afc063aac..4254603562892c0ad0cfda898b7521582e2c95e8 100644 (file)
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-top.scm,v 1.64 2000/05/18 19:53:27 cph Exp $
+;;; $Id: imail-top.scm,v 1.65 2000/05/18 22:11:15 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -219,6 +219,8 @@ DEL Scroll to previous screen of this message.
 \\[imail-forward]      Forward this message to another user.
 \\[imail-continue]     Continue composing outgoing message started before.
 
+\\[imail-create-folder]        Create a new folder.
+\\[imail-delete-folder]        Delete an existing folder.
 \\[imail-output]       Output this message to a specified folder (append it).
 \\[imail-input]        Append messages from a specified folder.
 
@@ -285,6 +287,8 @@ DEL Scroll to previous screen of this message.
 (define-key 'imail #\m-s       'imail-search)
 (define-key 'imail #\o         'imail-output)
 (define-key 'imail #\i         'imail-input)
+(define-key 'imail #\+         'imail-create-folder)
+(define-key 'imail #\-         'imail-delete-folder)
 (define-key 'imail #\q         'imail-quit)
 (define-key 'imail #\?         'describe-mode)
 
@@ -738,7 +742,7 @@ Completion is performed over known flags when reading."
   "sInput from folder"
   (lambda (url-string)
     (let ((folder (selected-folder)))
-      (let ((folder* (open-folder url-string))
+      (let ((folder* (open-folder (imail-parse-partial-url url-string)))
            (url (folder-url folder)))
        (let ((n (folder-length folder*)))
          (do ((index 0 (+ index 1)))
@@ -754,10 +758,23 @@ Completion is performed over known flags when reading."
   "sOutput to folder"
   (lambda (url-string)
     (let ((message (selected-message)))
-      (append-message message url-string)
+      (append-message message (imail-parse-partial-url url-string))
       (message-filed message)
       (if (ref-variable imail-delete-after-output)
          ((ref-command imail-delete-forward) #f)))))
+
+(define-command imail-create-folder
+  "Create a new folder with the specified name.
+An error if signalled if the folder already exists."
+  "sCreate folder"
+  (lambda (url-string)
+    (create-folder (imail-parse-partial-url url-string))))
+
+(define-command imail-delete-folder
+  "Delete a specified folder."
+  "sDelete folder"
+  (lambda (url-string)
+    (delete-folder (imail-parse-partial-url url-string))))
 \f
 ;;;; Sending mail
 

diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index ea4bfc5916145a6f83a503642154f1e8d3206715..968dce5477c9cf23c317b1c3292a9e70e6a86792 100644 (file)
--- a/v7/src/imail/todo.txt
+++ b/v7/src/imail/todo.txt
@@ -1,5 +1,5 @@
 IMAIL To-Do List
-$Id: todo.txt,v 1.21 2000/05/18 19:53:30 cph Exp $
+$Id: todo.txt,v 1.22 2000/05/18 22:11:16 cph Exp $
 
 Bug fixes
 ---------
@@ -41,7 +41,8 @@ Design changes
 New features
 ------------
 
-* Add commands to create, delete, and rename folders.
+* Add command to rename folders.  Add command to append all of the
+  messages from one folder to another.
 
 * Implement URL completion.