X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fimap.el;h=c8772de4d5400860bb63b3ccc2c7c09b4d8c8e60;hb=06a928c722b3e4b4a5dec9afa240f6b4a9362bd9;hp=74e581c4abdab995b2a2bd47d280aa04466d0119;hpb=0b7e7d43f23f86f6dfb63547d4eb56a094fd2f1a;p=gnus diff --git a/lisp/imap.el b/lisp/imap.el index 74e581c4a..c8772de4d 100644 --- a/lisp/imap.el +++ b/lisp/imap.el @@ -1,6 +1,7 @@ ;;; imap.el --- imap library -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005, 2006 Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; Keywords: mail @@ -19,8 +20,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -69,17 +70,17 @@ ;; imap-message-append, imap-envelope-from ;; imap-body-lines ;; -;; It is my hope that theese commands should be pretty self +;; It is my hope that these commands should be pretty self ;; explanatory for someone that know IMAP. All functions have ;; additional documentation on how to invoke them. ;; -;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP -;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342 +;; imap.el support RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1), implemented +;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342 ;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS, ;; LOGINDISABLED) (with use of external library starttls.el and -;; program starttls) and the GSSAPI / kerberos V4 sections of RFC1731 -;; (with use of external program `imtest'). It also take advantage -;; the UNSELECT extension in Cyrus IMAPD. +;; program starttls), and the GSSAPI / kerberos V4 sections of RFC1731 +;; (with use of external program `imtest'), RFC2971 (ID). It also +;; take advantage the UNSELECT extension in Cyrus IMAPD. ;; ;; Without the work of John McClary Prevost and Jim Radford this library ;; would not have seen the light of day. Many thanks. @@ -125,6 +126,7 @@ ;; o Don't use `read' at all (important places already fixed) ;; o Accept list of articles instead of message set string in most ;; imap-message-* functions. +;; o Send strings as literal if they contain, e.g., ". ;; ;; Revision history: ;; @@ -138,29 +140,19 @@ (eval-when-compile (require 'cl)) (eval-and-compile - (autoload 'base64-decode-string "base64") - (autoload 'base64-encode-string "base64") (autoload 'starttls-open-stream "starttls") (autoload 'starttls-negotiate "starttls") + (autoload 'sasl-find-mechanism "sasl") (autoload 'digest-md5-parse-digest-challenge "digest-md5") (autoload 'digest-md5-digest-response "digest-md5") (autoload 'digest-md5-digest-uri "digest-md5") (autoload 'digest-md5-challenge "digest-md5") (autoload 'rfc2104-hash "rfc2104") - (autoload 'md5 "md5") (autoload 'utf7-encode "utf7") (autoload 'utf7-decode "utf7") (autoload 'format-spec "format-spec") (autoload 'format-spec-make "format-spec") - (autoload 'open-tls-stream "tls") - ;; Avoid use gnus-point-at-eol so we're independent of Gnus. These - ;; days we have point-at-eol anyhow. - (if (fboundp 'point-at-eol) - (defalias 'imap-point-at-eol 'point-at-eol) - (defun imap-point-at-eol () - (save-excursion - (end-of-line) - (point))))) + (autoload 'open-tls-stream "tls")) ;; User variables. @@ -180,8 +172,7 @@ the list is tried until a successful connection is made." :type '(repeat string)) (defcustom imap-gssapi-program (list - (concat "gsasl --client --connect %s:%p " - "--imap --application-data " + (concat "gsasl %s %p " "--mechanism GSSAPI " "--authentication-id %l") "imtest -m gssapi -u %l -p %p %s") @@ -220,7 +211,14 @@ until a successful connection is made." :type '(repeat string)) (defcustom imap-process-connection-type nil - "*Value for `process-connection-type' to use for Kerberos4 and GSSAPI." + "*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL. +The `process-connection-type' variable control type of device +used to communicate with subprocesses. Values are nil to use a +pipe, or t or `pty' to use a pty. The value has no effect if the +system has no ptys or if all ptys are busy: then a pipe is used +in any case. The value takes effect when a IMAP server is +opened, changing it after that has no effect." + :version "22.1" :group 'imap :type 'boolean) @@ -233,12 +231,20 @@ encoded mailboxes which doesn't translate into ISO-8859-1." :type 'boolean) (defcustom imap-log nil - "If non-nil, a imap session trace is placed in *imap-log* buffer." + "If non-nil, a imap session trace is placed in *imap-log* buffer. +Note that username, passwords and other privacy sensitive +information (such as e-mail) may be stored in the *imap-log* +buffer. It is not written to disk, however. Do not enable this +variable unless you are comfortable with that." :group 'imap :type 'boolean) (defcustom imap-debug nil - "If non-nil, random debug spews are placed in *imap-debug* buffer." + "If non-nil, random debug spews are placed in *imap-debug* buffer. +Note that username, passwords and other privacy sensitive +information (such as e-mail) may be stored in the *imap-debug* +buffer. It is not written to disk, however. Do not enable this +variable unless you are comfortable with that." :group 'imap :type 'boolean) @@ -262,6 +268,11 @@ Shorter values mean quicker response, but is more CPU intensive." :type 'number :group 'imap) +(defcustom imap-store-password nil + "If non-nil, store session password without promting." + :group 'imap + :type 'boolean) + ;; Various variables. (defvar imap-fetch-data-hook nil @@ -290,6 +301,7 @@ stream.") kerberos4 digest-md5 cram-md5 + ;;sasl login anonymous) "Priority of authenticators to consider when authenticating to server.") @@ -297,6 +309,7 @@ stream.") (defvar imap-authenticator-alist '((gssapi imap-gssapi-auth-p imap-gssapi-auth) (kerberos4 imap-kerberos4-auth-p imap-kerberos4-auth) + (sasl imap-sasl-auth-p imap-sasl-auth) (cram-md5 imap-cram-md5-p imap-cram-md5-auth) (login imap-login-p imap-login-auth) (anonymous imap-anonymous-p imap-anonymous-auth) @@ -312,7 +325,7 @@ for doing the actual authentication.") (defvar imap-error nil "Error codes from the last command.") -;; Internal constants. Change theese and die. +;; Internal constants. Change these and die. (defconst imap-default-port 143) (defconst imap-default-ssl-port 993) @@ -332,6 +345,7 @@ for doing the actual authentication.") imap-current-target-mailbox imap-message-data imap-capability + imap-id imap-namespace imap-state imap-reached-tag @@ -387,6 +401,10 @@ and `examine'.") (defvar imap-capability nil "Capability for server.") +(defvar imap-id nil + "Identity of server. +See RFC 2971.") + (defvar imap-namespace nil "Namespace for current server.") @@ -498,6 +516,13 @@ sure of changing the value of `foo'." (while (and (memq (process-status process) '(open run)) (set-buffer buffer) ;; XXX "blue moon" nntp.el bug (goto-char (point-min)) + ;; Athena IMTEST can output SSL verify errors + (or (while (looking-at "^verify error:num=") + (forward-line)) + t) + (or (while (looking-at "^TLS connection established") + (forward-line)) + t) ;; cyrus 1.6.x (13? < x <= 22) queries capabilities (or (while (looking-at "^C:") (forward-line)) @@ -563,6 +588,13 @@ sure of changing the value of `foo'." (while (and (memq (process-status process) '(open run)) (set-buffer buffer) ;; XXX "blue moon" nntp.el bug (goto-char (point-min)) + ;; Athena IMTEST can output SSL verify errors + (or (while (looking-at "^verify error:num=") + (forward-line)) + t) + (or (while (looking-at "^TLS connection established") + (forward-line)) + t) ;; cyrus 1.6.x (13? < x <= 22) queries capabilities (or (while (looking-at "^C:") (forward-line)) @@ -571,6 +603,10 @@ sure of changing the value of `foo'." (or (not (looking-at "S: ")) (forward-char 3) t) + ;; GNU SASL may print 'Trying ...' first. + (or (not (looking-at "Trying ")) + (forward-line) + t) (not (and (imap-parse-greeting) ;; success in imtest 1.6: (re-search-forward @@ -612,7 +648,11 @@ sure of changing the value of `foo'." (let* ((port (or port imap-default-ssl-port)) (coding-system-for-read imap-coding-system-for-read) (coding-system-for-write imap-coding-system-for-write) - (process-connection-type nil) + (process-connection-type imap-process-connection-type) + (set-process-query-on-exit-flag + (if (fboundp 'set-process-query-on-exit-flag) + 'set-process-query-on-exit-flag + 'process-kill-without-query)) process) (when (progn (setq process (start-process @@ -622,7 +662,7 @@ sure of changing the value of `foo'." (format-spec-make ?s server ?p (number-to-string port))))) - (process-kill-without-query process) + (funcall set-process-query-on-exit-flag process nil) process) (with-current-buffer buffer (goto-char (point-min)) @@ -752,36 +792,36 @@ sure of changing the value of `foo'." (coding-system-for-read imap-coding-system-for-read) (coding-system-for-write imap-coding-system-for-write) (process (starttls-open-stream name buffer server port)) - done) + done tls-info) (message "imap: Connecting with STARTTLS...") (when process (while (and (memq (process-status process) '(open run)) (set-buffer buffer) ;; XXX "blue moon" nntp.el bug - (goto-char (point-min)) + (goto-char (point-max)) + (forward-line -1) (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) + (imap-send-command "STARTTLS") + (while (and (memq (process-status process) '(open run)) + (set-buffer buffer) ;; XXX "blue moon" nntp.el bug + (goto-char (point-max)) + (forward-line -1) + (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t))) + (accept-process-output process 1) + (sit-for 1)) (and imap-log (with-current-buffer (get-buffer-create imap-log-buffer) (buffer-disable-undo) (goto-char (point-max)) (insert-buffer-substring buffer))) - (let ((imap-process process)) - (unwind-protect - (progn - (set-process-filter imap-process 'imap-arrival-filter) - (when (and (eq imap-stream 'starttls) - (imap-ok-p (imap-send-command-wait "STARTTLS"))) - (starttls-negotiate imap-process))) - (set-process-filter imap-process nil))) - (when (memq (process-status process) '(open run)) + (when (and (setq tls-info (starttls-negotiate process)) + (memq (process-status process) '(open run))) (setq done process))) - (if done - (progn - (message "imap: Connecting with STARTTLS...done") - done) - (message "imap: Connecting with STARTTLS...failed") - nil))) + (if (stringp tls-info) + (message "imap: STARTTLS info: %s" tls-info)) + (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed")) + done)) ;; Server functions; authenticator stuff: @@ -812,11 +852,13 @@ Returns t if login was successful, nil otherwise." (progn (setq ret t imap-username user) - (if (and (not imap-password) - (y-or-n-p "Store password for this session? ")) - (setq imap-password passwd))) + (when (and (not imap-password) + (or imap-store-password + (y-or-n-p "Store password for this session? "))) + (setq imap-password passwd))) (message "Login failed...") (setq passwd nil) + (setq imap-password nil) (sit-for 1)))) ;; (quit (with-current-buffer buffer ;; (setq user nil @@ -827,8 +869,7 @@ Returns t if login was successful, nil otherwise." ret))) (defun imap-gssapi-auth-p (buffer) - (and (imap-capability 'AUTH=GSSAPI buffer) - (eq imap-stream 'gssapi))) + (eq imap-stream 'gssapi)) (defun imap-gssapi-auth (buffer) (message "imap: Authenticating using GSSAPI...%s" @@ -871,14 +912,27 @@ Returns t if login was successful, nil otherwise." (and (not (imap-capability 'LOGINDISABLED buffer)) (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer)))) +(defun imap-quote-specials (string) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "[\\\"]" nil t) + (forward-char -1) + (insert "\\") + (forward-char 1)) + (buffer-string))) + (defun imap-login-auth (buffer) "Login to server using the LOGIN command." (message "imap: Plaintext authentication...") (imap-interactive-login buffer (lambda (user passwd) (imap-ok-p (imap-send-command-wait - (concat "LOGIN \"" user "\" \"" - passwd "\"")))))) + (concat "LOGIN \"" + (imap-quote-specials user) + "\" \"" + (imap-quote-specials passwd) + "\"")))))) (defun imap-anonymous-p (buffer) t) @@ -890,6 +944,66 @@ Returns t if login was successful, nil otherwise." (concat "LOGIN anonymous \"" (concat (user-login-name) "@" (system-name)) "\""))))) +;;; Compiler directives. + +(defvar imap-sasl-client) +(defvar imap-sasl-step) + +(defun imap-sasl-make-mechanisms (buffer) + (let ((mecs '())) + (mapc (lambda (sym) + (let ((name (symbol-name sym))) + (if (and (> (length name) 5) + (string-equal "AUTH=" (substring name 0 5 ))) + (setq mecs (cons (substring name 5) mecs))))) + (imap-capability nil buffer)) + mecs)) + +(defun imap-sasl-auth-p (buffer) + (and (condition-case () + (require 'sasl) + (error nil)) + (sasl-find-mechanism (imap-sasl-make-mechanisms buffer)))) + +(defun imap-sasl-auth (buffer) + "Login to server using the SASL method." + (message "imap: Authenticating using SASL...") + (with-current-buffer buffer + (make-local-variable 'imap-username) + (make-local-variable 'imap-sasl-client) + (make-local-variable 'imap-sasl-step) + (let ((mechanism (sasl-find-mechanism (imap-sasl-make-mechanisms buffer))) + logged user) + (while (not logged) + (setq user (or imap-username + (read-from-minibuffer + (concat "IMAP username for " imap-server " using SASL " + (sasl-mechanism-name mechanism) ": ") + (or user imap-default-user)))) + (when user + (setq imap-sasl-client (sasl-make-client mechanism user "imap2" imap-server) + imap-sasl-step (sasl-next-step imap-sasl-client nil)) + (let ((tag (imap-send-command + (if (sasl-step-data imap-sasl-step) + (format "AUTHENTICATE %s %s" + (sasl-mechanism-name mechanism) + (sasl-step-data imap-sasl-step)) + (format "AUTHENTICATE %s" (sasl-mechanism-name mechanism))) + buffer))) + (while (eq (imap-wait-for-tag tag) 'INCOMPLETE) + (sasl-step-set-data imap-sasl-step (base64-decode-string imap-continuation)) + (setq imap-continuation nil + imap-sasl-step (sasl-next-step imap-sasl-client imap-sasl-step)) + (imap-send-command-1 (if (sasl-step-data imap-sasl-step) + (base64-encode-string (sasl-step-data imap-sasl-step) t) + ""))) + (if (imap-ok-p (imap-wait-for-tag tag)) + (setq imap-username user + logged t) + (message "Login failed...") + (sit-for 1))))) + logged))) + (defun imap-digest-md5-p (buffer) (and (imap-capability 'AUTH=DIGEST-MD5 buffer) (condition-case () @@ -1001,8 +1115,11 @@ necessary. If nil, the buffer name is generated." stream)) ;; We're done, kill the first connection (imap-close buffer) - (kill-buffer buffer) - (rename-buffer buffer) + (let ((name (if (stringp buffer) + buffer + (buffer-name buffer)))) + (kill-buffer buffer) + (rename-buffer name)) (message "imap: Reconnecting with stream `%s'...done" stream) (setq imap-stream stream) @@ -1037,7 +1154,7 @@ password is remembered in the buffer." (with-current-buffer (or buffer (current-buffer)) (if (not (eq imap-state 'nonauth)) (or (eq imap-state 'auth) - (eq imap-state 'select) + (eq imap-state 'selected) (eq imap-state 'examine)) (make-local-variable 'imap-username) (make-local-variable 'imap-password) @@ -1094,6 +1211,26 @@ If BUFFER is nil, the current buffer is assumed." (memq (intern (upcase (symbol-name identifier))) imap-capability) imap-capability))) +(defun imap-id (&optional list-of-values buffer) + "Identify client to server in BUFFER, and return server identity. +LIST-OF-VALUES is nil, or a plist with identifier and value +strings to send to the server to identify the client. + +Return a list of identifiers which server in BUFFER support, or +nil if it doesn't support ID or returns no information. + +If BUFFER is nil, the current buffer is assumed." + (with-current-buffer (or buffer (current-buffer)) + (when (and (imap-capability 'ID) + (imap-ok-p (imap-send-command-wait + (if (null list-of-values) + "ID NIL" + (concat "ID (" (mapconcat (lambda (el) + (concat "\"" el "\"")) + list-of-values + " ") ")"))))) + imap-id))) + (defun imap-namespace (&optional buffer) "Return a namespace hierarchy at server in BUFFER. If BUFFER is nil, the current buffer is assumed." @@ -1340,10 +1477,11 @@ returned, if ITEMS is a symbol only its value is returned." (imap-send-command-wait (list "STATUS \"" (imap-utf7-encode mailbox) "\" " - (format "%s" - (if (listp items) - items - (list items)))))) + (upcase + (format "%s" + (if (listp items) + items + (list items))))))) (if (listp items) (mapcar (lambda (item) (imap-mailbox-get item mailbox)) @@ -1434,7 +1572,7 @@ or 'unseen. The IMAP command tag is returned." (defun imap-fetch (uids props &optional receive nouidfetch buffer) "Fetch properties PROPS from message set UIDS from server in BUFFER. UIDS can be a string, number or a list of numbers. If RECEIVE -is non-nil return theese properties." +is non-nil return these properties." (with-current-buffer (or buffer (current-buffer)) (when (imap-ok-p (imap-send-command-wait (format "%sFETCH %s %s" (if nouidfetch "" "UID ") @@ -1789,7 +1927,7 @@ Return nil if no complete line has arrived." "IMAP process filter." ;; Sometimes, we are called even though the process has died. ;; Better abstain from doing stuff in that case. - (when (process-buffer proc) + (when (buffer-name (process-buffer proc)) (with-current-buffer (process-buffer proc) (goto-char (point-max)) (insert string) @@ -1962,7 +2100,9 @@ Return nil if no complete line has arrived." (when (eq (char-after) ?\)) (imap-forward) (nreverse addresses))) - (assert (imap-parse-nil) t "In imap-parse-address-list"))) + ;; With assert, the code might not be eval'd. + ;; (assert (imap-parse-nil) t "In imap-parse-address-list") + (imap-parse-nil))) ;; mailbox = "INBOX" / astring ;; ; INBOX is case-insensitive. All case variants of @@ -2056,6 +2196,8 @@ Return nil if no complete line has arrived." (read (concat "(" (upcase (buffer-substring (point) (point-max))) ")")))) + (ID (setq imap-id (read (buffer-substring (point) + (point-max))))) (ACL (imap-parse-acl)) (t (case (prog1 (read (current-buffer)) (imap-forward)) @@ -2403,16 +2545,16 @@ Return nil if no complete line has arrived." (defun imap-parse-flag-list () (let (flag-list start) - (assert (eq (char-after) ?\() t "In imap-parse-flag-list") + (assert (eq (char-after) ?\() nil "In imap-parse-flag-list") (while (and (not (eq (char-after) ?\))) (setq start (progn (imap-forward) ;; next line for Courier IMAP bug. (skip-chars-forward " ") (point))) - (> (skip-chars-forward "^ )" (imap-point-at-eol)) 0)) + (> (skip-chars-forward "^ )" (point-at-eol)) 0)) (push (buffer-substring start (point)) flag-list)) - (assert (eq (char-after) ?\)) t "In imap-parse-flag-list") + (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list") (imap-forward) (nreverse flag-list))) @@ -2497,7 +2639,7 @@ Return nil if no complete line has arrived." (while (eq (char-after) ?\ ) (imap-forward) (push (imap-parse-body-extension) b-e)) - (assert (eq (char-after) ?\)) t "In imap-parse-body-extension") + (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension") (imap-forward) (nreverse b-e)) (or (imap-parse-number) @@ -2525,7 +2667,9 @@ Return nil if no complete line has arrived." (imap-forward) (push (imap-parse-string-list) dsp) (imap-forward)) - (assert (imap-parse-nil) t "In imap-parse-body-ext")) + ;; With assert, the code might not be eval'd. + ;; (assert (imap-parse-nil) t "In imap-parse-body-ext") + (imap-parse-nil)) (push (nreverse dsp) ext)) (when (eq (char-after) ?\ ) ;; body-fld-lang (imap-forward) @@ -2621,7 +2765,7 @@ Return nil if no complete line has arrived." (push (and (imap-parse-nil) nil) body)) (setq body (append (imap-parse-body-ext) body))) ;; body-ext-... - (assert (eq (char-after) ?\)) t "In imap-parse-body") + (assert (eq (char-after) ?\)) nil "In imap-parse-body") (imap-forward) (nreverse body)) @@ -2681,7 +2825,7 @@ Return nil if no complete line has arrived." (push (imap-parse-nstring) body) ;; body-fld-md5 (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part.. - (assert (eq (char-after) ?\)) t "In imap-parse-body 2") + (assert (eq (char-after) ?\)) nil "In imap-parse-body 2") (imap-forward) (nreverse body))))) @@ -2784,4 +2928,5 @@ Return nil if no complete line has arrived." (provide 'imap) +;;; arch-tag: 27369ed6-33e4-482f-96f1-8bb906ba70f7 ;;; imap.el ends here