From ae91989a75d54fc12d900b63f0d46d644c92ae89 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 18 May 2000 22:11:16 +0000 Subject: [PATCH] Implement commands to create and delete folders. Put in special hack to prepend "inbox." to folder names when using Cyrus. --- v7/src/imail/imail-imap.scm | 61 +++++++++++++++++++++++++++++-------- v7/src/imail/imail-top.scm | 23 ++++++++++++-- v7/src/imail/todo.txt | 5 +-- 3 files changed, 72 insertions(+), 17 deletions(-) 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:command:create (get-imap-connection url) + (imap:command:delete (get-imap-connection url) (imap-url-mailbox url))) (define-method %rename-folder ((url ) (new-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. -- 2.25.1