From 7df42c05a44882ec0112da948fb417b91b363256 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 16 May 2000 03:13:43 +0000 Subject: [PATCH] Implement all of the IMAP server operations except for AVAILABLE-FOLDER-NAMES. --- v7/src/imail/imail-imap.scm | 71 +++++++++++++++++++++++++++++++----- v7/src/imail/imail.pkg | 3 +- v7/src/imail/imap-syntax.scm | 25 ++++++++++++- 3 files changed, 87 insertions(+), 12 deletions(-) diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index 644d4657c..3d5c78ff0 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.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:command:create (get-imap-connection url) + (imap-url-mailbox url))) (define-method %delete-folder ((url )) - ???) + (imap:command:create (get-imap-connection url) + (imap-url-mailbox url))) (define-method %rename-folder ((url ) (new-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 ) (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 )) ???) @@ -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))) (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 f030780a3..55c590b68 100644 --- 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 f16d85ea4..b435c0365 100644 --- 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 -- 2.25.1