From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 18 May 2000 22:11:16 +0000 (+0000)
Subject: Implement commands to create and delete folders.  Put in special hack
X-Git-Tag: 20090517-FFI~3811
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ae91989a75d54fc12d900b63f0d46d644c92ae89;p=mit-scheme.git

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 81c489dec..3686c2561 100644
--- 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))))
 
 (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))))
-
+
 (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)))
 
 (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 dcb3c3ee4..425460356 100644
--- 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))))
 
 ;;;; Sending mail
 
diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index ea4bfc591..968dce547 100644
--- 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.