X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnimap.el;h=33c6cd3aa39c35604455fd00384fd17fe090479f;hb=5beb390633ce1e32cdf319c6ba19926244bbfdf2;hp=1899b0ef030e2b7c4214a160b7c605bf39cb7b65;hpb=3286715e509f8ca70efd674d59f6c58e16fdf95a;p=gnus diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 1899b0ef0..33c6cd3aa 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -1,6 +1,6 @@ ;;; nnimap.el --- IMAP interface for Gnus -;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2010-2012 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Simon Josefsson @@ -31,7 +31,11 @@ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-and-compile - (require 'nnheader)) + (require 'nnheader) + ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for + ;; `make-network-stream'. + (unless (fboundp 'open-protocol-stream) + (require 'proto-stream))) (eval-when-compile (require 'cl)) @@ -45,25 +49,30 @@ (require 'tls) (require 'parse-time) (require 'nnmail) -(require 'proto-stream) -(autoload 'auth-source-forget-user-or-password "auth-source") -(autoload 'auth-source-user-or-password "auth-source") +(autoload 'auth-source-forget+ "auth-source") +(autoload 'auth-source-search "auth-source") (nnoo-declare nnimap) (defvoo nnimap-address nil "The address of the IMAP server.") +(defvoo nnimap-user nil + "Username to use for authentication to the IMAP server.") + (defvoo nnimap-server-port nil "The IMAP port used. If nnimap-stream is `ssl', this will default to `imaps'. If not, it will default to `imap'.") (defvoo nnimap-stream 'undecided - "How nnimap will talk to the IMAP server. -Values are `ssl', `network', `starttls' or `shell'. -The default is to try `ssl' first, and then `network'.") + "How nnimap talks to the IMAP server. +The value should be either `undecided', `ssl' or `tls', +`network', `starttls', `plain', or `shell'. + +If the value is `undecided', nnimap tries `ssl' first, then falls +back on `network'.") (defvoo nnimap-shell-program (if (boundp 'imap-shell-program) (if (listp imap-shell-program) @@ -72,14 +81,15 @@ The default is to try `ssl' first, and then `network'.") "ssh %s imapd")) (defvoo nnimap-inbox nil - "The mail box where incoming mail arrives and should be split out of.") + "The mail box where incoming mail arrives and should be split out of. +For example, \"INBOX\".") (defvoo nnimap-split-methods nil "How mail is split. -Uses the same syntax as nnmail-split-methods") +Uses the same syntax as `nnmail-split-methods'.") (defvoo nnimap-split-fancy nil - "Uses the same syntax as nnmail-split-fancy.") + "Uses the same syntax as `nnmail-split-fancy'.") (defvoo nnimap-unsplittable-articles '(%Deleted %Seen) "Articles with the flags in the list will not be considered when splitting.") @@ -124,7 +134,7 @@ textual parts.") (defstruct nnimap group process commands capabilities select-result newlinep server - last-command-time greeting examined) + last-command-time greeting examined stream-type initial-resync) (defvar nnimap-object nil) @@ -142,6 +152,8 @@ textual parts.") (defvar nnimap-quirks '(("QRESYNC" "Zimbra" "QRESYNC "))) +(defvar nnimap-inhibit-logging nil) + (defun nnimap-buffer () (nnimap-find-process-buffer nntp-server-buffer)) @@ -156,6 +168,8 @@ textual parts.") nnmail-extra-headers)))) (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old) + (when group + (setq group (nnimap-decode-gnus-group group))) (with-current-buffer nntp-server-buffer (erase-buffer) (when (nnimap-possibly-change-group group server) @@ -175,25 +189,35 @@ textual parts.") (defun nnimap-transform-headers () (goto-char (point-min)) - (let (article bytes lines size string) + (let (article lines size string) (block nil (while (not (eobp)) - (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)")) + (while (not (looking-at "\\* [0-9]+ FETCH")) (delete-region (point) (progn (forward-line 1) (point))) (when (eobp) (return))) - (setq article (match-string 1)) + (goto-char (match-end 0)) ;; Unfold quoted {number} strings. - (while (re-search-forward "[^]][ (]{\\([0-9]+\\)}\r?\n" - (1+ (line-end-position)) t) + (while (re-search-forward + "[^]][ (]{\\([0-9]+\\)}\r?\n" + (save-excursion + ;; Start of the header section. + (or (re-search-forward "] {[0-9]+}\r?\n" nil t) + ;; Start of the next FETCH. + (re-search-forward "\\* [0-9]+ FETCH" nil t) + (point-max))) + t) (setq size (string-to-number (match-string 1))) (delete-region (+ (match-beginning 0) 2) (point)) (setq string (buffer-substring (point) (+ (point) size))) (delete-region (point) (+ (point) size)) - (insert (format "%S" string))) - (setq bytes (nnimap-get-length) - lines nil) + (insert (format "%S" (mm-subst-char-in-string ?\n ?\s string)))) (beginning-of-line) + (setq article + (and (re-search-forward "UID \\([0-9]+\\)" (line-end-position) + t) + (match-string 1))) + (setq lines nil) (setq size (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)" (line-end-position) @@ -204,9 +228,14 @@ textual parts.") (let ((structure (ignore-errors (read (current-buffer))))) (while (and (consp structure) - (not (stringp (car structure)))) + (not (atom (car structure)))) (setq structure (car structure))) - (setq lines (nth 7 structure)))) + (setq lines (if (and + (stringp (car structure)) + (equal (upcase (nth 0 structure)) "MESSAGE") + (equal (upcase (nth 1 structure)) "RFC822")) + (nth 9 structure) + (nth 7 structure))))) (delete-region (line-beginning-position) (line-end-position)) (insert (format "211 %s Article retrieved." article)) (forward-line 1) @@ -250,18 +279,20 @@ textual parts.") result)) (mapconcat #'identity (nreverse result) ","))))) -(deffoo nnimap-open-server (server &optional defs) +(deffoo nnimap-open-server (server &optional defs no-reconnect) (if (nnimap-server-opened server) t (unless (assq 'nnimap-address defs) (setq defs (append defs (list (list 'nnimap-address server))))) (nnoo-change-server 'nnimap server defs) - (or (nnimap-find-connection nntp-server-buffer) - (nnimap-open-connection nntp-server-buffer)))) + (if no-reconnect + (nnimap-find-connection nntp-server-buffer) + (or (nnimap-find-connection nntp-server-buffer) + (nnimap-open-connection nntp-server-buffer))))) (defun nnimap-make-process-buffer (buffer) (with-current-buffer - (generate-new-buffer (format "*nnimap %s %s %s*" + (generate-new-buffer (format " *nnimap %s %s %s*" nnimap-address nnimap-server-port (gnus-buffer-exists-p buffer))) (mm-disable-multibyte) @@ -269,24 +300,30 @@ textual parts.") (gnus-add-buffer) (set (make-local-variable 'after-change-functions) nil) (set (make-local-variable 'nnimap-object) - (make-nnimap :server (nnoo-current-server 'nnimap))) + (make-nnimap :server (nnoo-current-server 'nnimap) + :initial-resync 0)) (push (list buffer (current-buffer)) nnimap-connection-alist) (push (current-buffer) nnimap-process-buffers) (current-buffer))) -(defun nnimap-credentials (address ports &optional inhibit-create) - (let (port credentials) - ;; Request the credentials from all ports, but only query on the - ;; last port if all the previous ones have failed. - (while (and (null credentials) - (setq port (pop ports))) - (setq credentials - (auth-source-user-or-password - '("login" "password") address port nil - (if inhibit-create - nil - (null ports))))) - credentials)) +(defun nnimap-credentials (address ports user) + (let* ((auth-source-creation-prompts + '((user . "IMAP user at %h: ") + (secret . "IMAP password for %u@%h: "))) + (found (nth 0 (auth-source-search :max 1 + :host address + :port ports + :user user + :require '(:user :secret) + :create t)))) + (if found + (list (plist-get found :user) + (let ((secret (plist-get found :secret))) + (if (functionp secret) + (funcall secret) + secret)) + (plist-get found :save-function)) + nil))) (defun nnimap-keepalive () (let ((now (current-time))) @@ -321,6 +358,11 @@ textual parts.") nil stream))) +(defun nnimap-map-port (port) + (if (equal port "imaps") + "993" + port)) + (defun nnimap-open-connection-1 (buffer) (unless nnimap-keepalive-timer (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15) @@ -328,14 +370,12 @@ textual parts.") (with-current-buffer (nnimap-make-process-buffer buffer) (let* ((coding-system-for-read 'binary) (coding-system-for-write 'binary) - (port nil) (ports (cond - ((or (eq nnimap-stream 'network) - (eq nnimap-stream 'starttls)) + ((memq nnimap-stream '(network plain starttls)) (nnheader-message 7 "Opening connection to %s..." nnimap-address) - '("143" "imap")) + '("imap" "143")) ((eq nnimap-stream 'shell) (nnheader-message 7 "Opening connection to %s via shell..." nnimap-address) @@ -343,29 +383,47 @@ textual parts.") ((memq nnimap-stream '(ssl tls)) (nnheader-message 7 "Opening connection to %s via tls..." nnimap-address) - '("143" "993" "imap" "imaps")) + '("imaps" "imap" "993" "143")) (t (error "Unknown stream type: %s" nnimap-stream)))) - (proto-stream-always-use-starttls t) login-result credentials) (when nnimap-server-port - (setq ports (append ports (list nnimap-server-port)))) - (destructuring-bind (stream greeting capabilities) - (open-protocol-stream - "*nnimap*" (current-buffer) nnimap-address (car (last ports)) - :type nnimap-stream - :shell-command nnimap-shell-program - :capability-command "1 CAPABILITY\r\n" - :success " OK " - :starttls-function - (lambda (capabilities) - (when (gnus-string-match-p "STARTTLS" capabilities) - "1 STARTTLS\r\n"))) + (push nnimap-server-port ports)) + (let* ((stream-list + (open-protocol-stream + "*nnimap*" (current-buffer) nnimap-address + (nnimap-map-port (car ports)) + :type nnimap-stream + :return-list t + :shell-command nnimap-shell-program + :capability-command "1 CAPABILITY\r\n" + :end-of-command "\r\n" + :success " OK " + :starttls-function + (lambda (capabilities) + (when (gnus-string-match-p "STARTTLS" capabilities) + "1 STARTTLS\r\n")))) + (stream (car stream-list)) + (props (cdr stream-list)) + (greeting (plist-get props :greeting)) + (capabilities (plist-get props :capabilities)) + (stream-type (plist-get props :type))) + (when (and stream (not (memq (process-status stream) '(open run)))) + (setq stream nil)) + + (when (and (fboundp 'set-network-process-option) ;; Not in XEmacs. + (fboundp 'process-type) ;; Emacs 22 doesn't provide it. + (eq (process-type stream) 'network)) + ;; Use TCP-keepalive so that connections that pass through a NAT + ;; router don't hang when left idle. + (set-network-process-option stream :keepalive t)) + (setf (nnimap-process nnimap-object) stream) + (setf (nnimap-stream-type nnimap-object) stream-type) (if (not stream) (progn (nnheader-report 'nnimap "Unable to contact %s:%s via %s" - nnimap-address port nnimap-stream) + nnimap-address (car ports) nnimap-stream) 'no-connect) (gnus-set-process-query-on-exit-flag stream nil) (if (not (gnus-string-match-p "[*.] \\(OK\\|PREAUTH\\)" greeting)) @@ -380,36 +438,38 @@ textual parts.") (if (eq nnimap-authenticator 'anonymous) (list "anonymous" (message-make-address)) - (or - ;; First look for the credentials based - ;; on the virtual server name. - (nnimap-credentials - (nnoo-current-server 'nnimap) ports t) - ;; Then look them up based on the - ;; physical address. - (nnimap-credentials nnimap-address ports))))) + ;; Look for the credentials based on + ;; the virtual server name and the address + (nnimap-credentials + (gnus-delete-duplicates + (list + nnimap-address + (nnoo-current-server 'nnimap))) + ports + nnimap-user)))) (setq nnimap-object nil) - (setq login-result - (if (and (nnimap-capability "AUTH=PLAIN") - (nnimap-capability "LOGINDISABLED")) - (nnimap-command - "AUTHENTICATE PLAIN %s" - (base64-encode-string - (format "\000%s\000%s" - (nnimap-quote-specials (car credentials)) - (nnimap-quote-specials (cadr credentials))))) - (nnimap-command "LOGIN %S %S" - (car credentials) - (cadr credentials)))) - (unless (car login-result) + (let ((nnimap-inhibit-logging t)) + (setq login-result + (nnimap-login (car credentials) (cadr credentials)))) + (if (car login-result) + (progn + ;; Save the credentials if a save function exists + ;; (such a function will only be passed if a new + ;; token was created). + (when (functionp (nth 2 credentials)) + (funcall (nth 2 credentials))) + ;; See if CAPABILITY is set as part of login + ;; response. + (dolist (response (cddr login-result)) + (when (string= "CAPABILITY" (upcase (car response))) + (setf (nnimap-capabilities nnimap-object) + (mapcar #'upcase (cdr response)))))) ;; If the login failed, then forget the credentials ;; that are now possibly cached. (dolist (host (list (nnoo-current-server 'nnimap) nnimap-address)) (dolist (port ports) - (dolist (element '("login" "password")) - (auth-source-forget-user-or-password - element host port)))) + (auth-source-forget+ :host host :port port))) (delete-process (nnimap-process nnimap-object)) (setq nnimap-object nil)))) (when nnimap-object @@ -417,6 +477,39 @@ textual parts.") (nnimap-command "ENABLE QRESYNC")) (nnimap-process nnimap-object)))))))) +(autoload 'rfc2104-hash "rfc2104") + +(defun nnimap-login (user password) + (cond + ;; Prefer plain LOGIN if it's enabled (since it requires fewer + ;; round trips than CRAM-MD5, and it's less likely to be buggy), + ;; and we're using an encrypted connection. + ((and (not (nnimap-capability "LOGINDISABLED")) + (eq (nnimap-stream-type nnimap-object) 'tls)) + (nnimap-command "LOGIN %S %S" user password)) + ((nnimap-capability "AUTH=CRAM-MD5") + (erase-buffer) + (let ((sequence (nnimap-send-command "AUTHENTICATE CRAM-MD5")) + (challenge (nnimap-wait-for-line "^\\+\\(.*\\)\n"))) + (process-send-string + (get-buffer-process (current-buffer)) + (concat + (base64-encode-string + (concat user " " + (rfc2104-hash 'md5 64 16 password + (base64-decode-string challenge)))) + "\r\n")) + (nnimap-wait-for-response sequence))) + ((not (nnimap-capability "LOGINDISABLED")) + (nnimap-command "LOGIN %S %S" user password)) + ((nnimap-capability "AUTH=PLAIN") + (nnimap-command + "AUTHENTICATE PLAIN %s" + (base64-encode-string + (format "\000%s\000%s" + (nnimap-quote-specials user) + (nnimap-quote-specials password))))))) + (defun nnimap-quote-specials (string) (with-temp-buffer (insert string) @@ -459,6 +552,8 @@ textual parts.") nnimap-status-string) (deffoo nnimap-request-article (article &optional group server to-buffer) + (when group + (setq group (nnimap-decode-gnus-group group))) (with-current-buffer nntp-server-buffer (let ((result (nnimap-possibly-change-group group server)) parts structure) @@ -485,25 +580,28 @@ textual parts.") (nnimap-get-whole-article article)) (let ((buffer (current-buffer))) (with-current-buffer (or to-buffer nntp-server-buffer) - (erase-buffer) - (insert-buffer-substring buffer) - (nnheader-ms-strip-cr) - (cons group article))))))))) + (nnheader-insert-buffer-substring buffer) + (nnheader-ms-strip-cr))) + (cons group article))))))) (deffoo nnimap-request-head (article &optional group server to-buffer) + (when group + (setq group (nnimap-decode-gnus-group group))) (when (nnimap-possibly-change-group group server) (with-current-buffer (nnimap-buffer) (when (stringp article) (setq article (nnimap-find-article-by-message-id group article))) - (nnimap-get-whole-article - article (format "UID FETCH %%d %s" - (nnimap-header-parameters))) - (let ((buffer (current-buffer))) - (with-current-buffer (or to-buffer nntp-server-buffer) - (erase-buffer) - (insert-buffer-substring buffer) - (nnheader-ms-strip-cr) - (cons group article)))))) + (if (null article) + nil + (nnimap-get-whole-article + article (format "UID FETCH %%d %s" + (nnimap-header-parameters))) + (let ((buffer (current-buffer))) + (with-current-buffer (or to-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring buffer) + (nnheader-ms-strip-cr) + (cons group article))))))) (defun nnimap-get-whole-article (article &optional command) (let ((result @@ -565,7 +663,7 @@ textual parts.") ;; Collect all the body parts. (while (looking-at ".*BODY\\[\\([.0-9]+\\)\\]") (setq id (match-string 1) - bytes (nnimap-get-length)) + bytes (or (nnimap-get-length) 0)) (beginning-of-line) (delete-region (point) (progn (forward-line 1) (point))) (push (list id (buffer-substring (point) (+ (point) bytes))) @@ -595,12 +693,13 @@ textual parts.") (if (consp (caar structure)) (nnimap-insert-partial-structure (pop structure) parts t) (let ((bit (pop structure))) - (insert (format "Content-type: %s/%s" - (downcase (nth 0 bit)) - (downcase (nth 1 bit)))) - (if (member "CHARSET" (nth 2 bit)) + (insert (format "Content-type: %s/%s" + (downcase (nth 0 bit)) + (downcase (nth 1 bit)))) + (if (member-ignore-case "CHARSET" (nth 2 bit)) (insert (format - "; charset=%S\n" (cadr (member "CHARSET" (nth 2 bit))))) + "; charset=%S\n" + (cadr (member-ignore-case "CHARSET" (nth 2 bit))))) (insert "\n")) (insert (format "Content-transfer-encoding: %s\n" (nth 5 bit))) @@ -635,7 +734,11 @@ textual parts.") (incf num))) (nreverse parts))) +(defun nnimap-decode-gnus-group (group) + (decode-coding-string group 'utf-8)) + (deffoo nnimap-request-group (group &optional server dont-check info) + (setq group (nnimap-decode-gnus-group group)) (let ((result (nnimap-possibly-change-group ;; Don't SELECT the group if we're going to select it ;; later, anyway. @@ -685,16 +788,19 @@ textual parts.") t)))) (deffoo nnimap-request-create-group (group &optional server args) + (setq group (nnimap-decode-gnus-group group)) (when (nnimap-possibly-change-group nil server) (with-current-buffer (nnimap-buffer) (car (nnimap-command "CREATE %S" (utf7-encode group t)))))) (deffoo nnimap-request-delete-group (group &optional force server) + (setq group (nnimap-decode-gnus-group group)) (when (nnimap-possibly-change-group nil server) (with-current-buffer (nnimap-buffer) (car (nnimap-command "DELETE %S" (utf7-encode group t)))))) (deffoo nnimap-request-rename-group (group new-name &optional server) + (setq group (nnimap-decode-gnus-group group)) (when (nnimap-possibly-change-group nil server) (with-current-buffer (nnimap-buffer) (nnimap-unselect-group) @@ -709,6 +815,7 @@ textual parts.") (nnimap-command "EXAMINE DOES.NOT.EXIST")) (deffoo nnimap-request-expunge-group (group &optional server) + (setq group (nnimap-decode-gnus-group group)) (when (nnimap-possibly-change-group group server) (with-current-buffer (nnimap-buffer) (car (nnimap-command "EXPUNGE"))))) @@ -736,6 +843,7 @@ textual parts.") (deffoo nnimap-request-move-article (article group server accept-form &optional last internal-move-group) + (setq group (nnimap-decode-gnus-group group)) (with-temp-buffer (mm-disable-multibyte) (when (funcall (if internal-move-group @@ -760,10 +868,12 @@ textual parts.") ;; Move the article to a different method. (let ((result (eval accept-form))) (when result + (nnimap-possibly-change-group group server) (nnimap-delete-article article) result))))))) (deffoo nnimap-request-expire-articles (articles group &optional server force) + (setq group (nnimap-decode-gnus-group group)) (cond ((null articles) nil) @@ -819,15 +929,18 @@ textual parts.") (with-temp-buffer (mm-disable-multibyte) (when (nnimap-request-article article group server (current-buffer)) - (nnheader-message 7 "Expiring article %s:%d" group article) (when (functionp target) (setq target (funcall target group))) - (when (and target - (not (eq target 'delete))) - (if (or (gnus-request-group target t) - (gnus-request-create-group target)) - (nnmail-expiry-target-group target group) - (setq target nil))) + (if (and target + (not (eq target 'delete))) + (if (or (gnus-request-group target t) + (gnus-request-create-group target)) + (progn + (nnmail-expiry-target-group target group) + (nnheader-message 7 "Expiring article %s:%d to %s" + group article target)) + (setq target nil)) + (nnheader-message 7 "Expiring article %s:%d" group article)) (when target (push article deleted-articles)))))))) ;; Change back to the current group again. @@ -868,7 +981,7 @@ textual parts.") (car (setq result (nnimap-parse-response)))) ;; Select the last instance of the message in the group. (and (setq article - (car (last (assoc "SEARCH" (cdr result))))) + (car (last (cdr (assoc "SEARCH" (cdr result)))))) (string-to-number article)))))) (defun nnimap-delete-article (articles) @@ -888,11 +1001,14 @@ textual parts.") "delete this article now")))))) (deffoo nnimap-request-scan (&optional group server) + (when group + (setq group (nnimap-decode-gnus-group group))) (when (and (nnimap-possibly-change-group nil server) nnimap-inbox nnimap-split-methods) (nnheader-message 7 "nnimap %s splitting mail..." server) - (nnimap-split-incoming-mail))) + (nnimap-split-incoming-mail) + (nnheader-message 7 "nnimap %s splitting mail...done" server))) (defun nnimap-marks-to-flags (marks) (let (flags flag) @@ -902,6 +1018,7 @@ textual parts.") flags)) (deffoo nnimap-request-update-group-status (group status &optional server) + (setq group (nnimap-decode-gnus-group group)) (when (nnimap-possibly-change-group nil server) (let ((command (assoc status @@ -912,6 +1029,7 @@ textual parts.") (nnimap-command "%s %S" (cadr command) (utf7-encode group t))))))) (deffoo nnimap-request-set-mark (group actions &optional server) + (setq group (nnimap-decode-gnus-group group)) (when (nnimap-possibly-change-group group server) (let (sequence) (with-current-buffer (nnimap-buffer) @@ -931,11 +1049,12 @@ textual parts.") ((eq action 'set) "")) (mapconcat #'identity flags " "))))))) ;; Wait for the last command to complete to avoid later - ;; syncronisation problems with the stream. + ;; synchronization problems with the stream. (when sequence (nnimap-wait-for-response sequence)))))) (deffoo nnimap-request-accept-article (group &optional server last) + (setq group (nnimap-decode-gnus-group group)) (when (nnimap-possibly-change-group nil server) (nnmail-check-syntax) (let ((message-id (message-field-value "message-id")) @@ -943,30 +1062,60 @@ textual parts.") (nnimap-add-cr) (setq message (buffer-substring-no-properties (point-min) (point-max))) (with-current-buffer (nnimap-buffer) - ;; If we have this group open read-only, then unselect it - ;; before appending to it. - (when (equal (nnimap-examined nnimap-object) group) - (nnimap-unselect-group)) - (erase-buffer) - (setq sequence (nnimap-send-command - "APPEND %S {%d}" (utf7-encode group t) - (length message))) - (unless nnimap-streaming - (nnimap-wait-for-connection "^[+]")) - (process-send-string (get-buffer-process (current-buffer)) message) - (process-send-string (get-buffer-process (current-buffer)) - (if (nnimap-newlinep nnimap-object) - "\n" - "\r\n")) - (let ((result (nnimap-get-response sequence))) - (if (not (car result)) - (progn - (nnheader-message 7 "%s" (nnheader-get-report-string 'nnimap)) - nil) - (cons group - (or (nnimap-find-uid-response "APPENDUID" (car result)) - (nnimap-find-article-by-message-id - group message-id))))))))) + (when (setq message (or (nnimap-process-quirk "OK Gimap " 'append message) + message)) + ;; If we have this group open read-only, then unselect it + ;; before appending to it. + (when (equal (nnimap-examined nnimap-object) group) + (nnimap-unselect-group)) + (erase-buffer) + (setq sequence (nnimap-send-command + "APPEND %S {%d}" (utf7-encode group t) + (length message))) + (unless nnimap-streaming + (nnimap-wait-for-connection "^[+]")) + (process-send-string (get-buffer-process (current-buffer)) message) + (process-send-string (get-buffer-process (current-buffer)) + (if (nnimap-newlinep nnimap-object) + "\n" + "\r\n")) + (let ((result (nnimap-get-response sequence))) + (if (not (nnimap-ok-p result)) + (progn + (nnheader-report 'nnimap "%s" result) + nil) + (cons group + (or (nnimap-find-uid-response "APPENDUID" (car result)) + (nnimap-find-article-by-message-id + group message-id)))))))))) + +(defun nnimap-process-quirk (greeting-match type data) + (when (and (nnimap-greeting nnimap-object) + (string-match greeting-match (nnimap-greeting nnimap-object)) + (eq type 'append) + (string-match "\000" data)) + (let ((choice (gnus-multiple-choice + "Message contains NUL characters. Delete, continue, abort? " + '((?d "Delete NUL characters") + (?c "Try to APPEND the message as is") + (?a "Abort"))))) + (cond + ((eq choice ?a) + (nnheader-report 'nnimap "Aborted APPEND due to NUL characters")) + ((eq choice ?c) + data) + (t + (with-temp-buffer + (insert data) + (goto-char (point-min)) + (while (search-forward "\000" nil t) + (replace-match "" t t)) + (buffer-string))))))) + +(defun nnimap-ok-p (value) + (and (consp value) + (consp (car value)) + (equal (caar value) "OK"))) (defun nnimap-find-uid-response (name list) (let ((result (car (last (nnimap-find-response-element name list))))) @@ -982,6 +1131,7 @@ textual parts.") result)) (deffoo nnimap-request-replace-article (article group buffer) + (setq group (nnimap-decode-gnus-group group)) (let (group-art) (when (and (nnimap-possibly-change-group group nil) ;; Put the article into the group. @@ -1012,87 +1162,96 @@ textual parts.") (separator (read (current-buffer))) (group (read (current-buffer)))) (unless (member '%NoSelect flags) - (push (if (stringp group) - group - (format "%s" group)) + (push (utf7-decode (if (stringp group) + group + (format "%s" group)) t) groups)))) (nreverse groups))) (deffoo nnimap-request-list (&optional server) - (nnimap-possibly-change-group nil server) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (let ((groups - (with-current-buffer (nnimap-buffer) - (nnimap-get-groups))) - sequences responses) - (when groups - (with-current-buffer (nnimap-buffer) - (setf (nnimap-group nnimap-object) nil) - (dolist (group groups) - (setf (nnimap-examined nnimap-object) group) - (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t)) - group) - sequences)) - (nnimap-wait-for-response (caar sequences)) - (setq responses - (nnimap-get-responses (mapcar #'car sequences)))) - (dolist (response responses) - (let* ((sequence (car response)) - (response (cadr response)) - (group (cadr (assoc sequence sequences)))) - (when (and group - (equal (caar response) "OK")) - (let ((uidnext (nnimap-find-parameter "UIDNEXT" response)) - highest exists) - (dolist (elem response) - (when (equal (cadr elem) "EXISTS") - (setq exists (string-to-number (car elem))))) - (when uidnext - (setq highest (1- (string-to-number (car uidnext))))) - (cond - ((null highest) - (insert (format "%S 0 1 y\n" (utf7-decode group t)))) - ((zerop exists) - ;; Empty group. - (insert (format "%S %d %d y\n" - (utf7-decode group t) highest (1+ highest)))) - (t - ;; Return the widest possible range. - (insert (format "%S %d 1 y\n" (utf7-decode group t) - (or highest exists))))))))) - t)))) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (let ((groups + (with-current-buffer (nnimap-buffer) + (nnimap-get-groups))) + sequences responses) + (when groups + (with-current-buffer (nnimap-buffer) + (setf (nnimap-group nnimap-object) nil) + (dolist (group groups) + (setf (nnimap-examined nnimap-object) group) + (push (list (nnimap-send-command "EXAMINE %S" + (utf7-encode group t)) + group) + sequences)) + (nnimap-wait-for-response (caar sequences)) + (setq responses + (nnimap-get-responses (mapcar #'car sequences)))) + (dolist (response responses) + (let* ((sequence (car response)) + (response (cadr response)) + (group (cadr (assoc sequence sequences))) + (egroup (encode-coding-string group 'utf-8))) + (when (and group + (equal (caar response) "OK")) + (let ((uidnext (nnimap-find-parameter "UIDNEXT" response)) + highest exists) + (dolist (elem response) + (when (equal (cadr elem) "EXISTS") + (setq exists (string-to-number (car elem))))) + (when uidnext + (setq highest (1- (string-to-number (car uidnext))))) + (cond + ((null highest) + (insert (format "%S 0 1 y\n" egroup))) + ((zerop exists) + ;; Empty group. + (insert (format "%S %d %d y\n" egroup + highest (1+ highest)))) + (t + ;; Return the widest possible range. + (insert (format "%S %d 1 y\n" egroup + (or highest exists))))))))) + t))))) (deffoo nnimap-request-newgroups (date &optional server) - (nnimap-possibly-change-group nil server) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (dolist (group (with-current-buffer (nnimap-buffer) - (nnimap-get-groups))) - (unless (assoc group nnimap-current-infos) - ;; Insert dummy numbers here -- they don't matter. - (insert (format "%S 0 1 y\n" group)))) - t)) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (dolist (group (with-current-buffer (nnimap-buffer) + (nnimap-get-groups))) + (unless (assoc group nnimap-current-infos) + ;; Insert dummy numbers here -- they don't matter. + (insert (format "%S 0 1 y\n" (encode-coding-string group 'utf-8))))) + t))) (deffoo nnimap-retrieve-group-data-early (server infos) - (when (nnimap-possibly-change-group nil server) + (when (and (nnimap-possibly-change-group nil server) + infos) (with-current-buffer (nnimap-buffer) (erase-buffer) (setf (nnimap-group nnimap-object) nil) + (setf (nnimap-initial-resync nnimap-object) 0) (let ((qresyncp (nnimap-capability "QRESYNC")) - params groups sequences active uidvalidity modseq group) + params groups sequences active uidvalidity modseq group + unexist) ;; Go through the infos and gather the data needed to know ;; what and how to request the data. (dolist (info infos) (setq params (gnus-info-params info) - group (gnus-group-real-name (gnus-info-group info)) + group (nnimap-decode-gnus-group + (gnus-group-real-name (gnus-info-group info))) active (cdr (assq 'active params)) + unexist (assq 'unexist (gnus-info-marks info)) uidvalidity (cdr (assq 'uidvalidity params)) modseq (cdr (assq 'modseq params))) (setf (nnimap-examined nnimap-object) group) (if (and qresyncp uidvalidity - modseq) + active + modseq + unexist) (push (list (nnimap-send-command "EXAMINE %S (%s (%s %s))" (utf7-encode group t) @@ -1101,12 +1260,7 @@ textual parts.") 'qresync nil group 'qresync) sequences) - (let ((start - (if (and active uidvalidity) - ;; Fetch the last 100 flags. - (max 1 (- (cdr active) 100)) - 1)) - (command + (let ((command (if uidvalidity "EXAMINE" ;; If we don't have a UIDVALIDITY, then this is @@ -1114,7 +1268,13 @@ textual parts.") ;; have to do a SELECT (which is slower than an ;; examine), but will tell us whether the group ;; is read-only or not. - "SELECT"))) + "SELECT")) + start) + (if (and active uidvalidity unexist) + ;; Fetch the last 100 flags. + (setq start (max 1 (- (cdr active) 100))) + (incf (nnimap-initial-resync nnimap-object)) + (setq start 1)) (push (list (nnimap-send-command "%s %S" command (utf7-encode group t)) (nnimap-send-command "UID FETCH %d:* FLAGS" start) @@ -1133,7 +1293,11 @@ textual parts.") (deffoo nnimap-finish-retrieve-group-infos (server infos sequences) (when (and sequences - (nnimap-possibly-change-group nil server)) + (nnimap-possibly-change-group nil server t) + ;; Check that the process is still alive. + (get-buffer-process (nnimap-buffer)) + (memq (process-status (get-buffer-process (nnimap-buffer))) + '(open run))) (with-current-buffer (nnimap-buffer) ;; Wait for the final data to trickle in. (when (nnimap-wait-for-response (if (eq (cadar sequences) 'qresync) @@ -1156,13 +1320,15 @@ textual parts.") (active (gnus-active group))) (when active (insert (format "%S %d %d y\n" - (gnus-group-real-name group) + (decode-coding-string + (gnus-group-real-name group) 'utf-8) (cdr active) (car active))))))))))) (defun nnimap-update-infos (flags infos) (dolist (info infos) - (let* ((group (gnus-group-real-name (gnus-info-group info))) + (let* ((group (nnimap-decode-gnus-group + (gnus-group-real-name (gnus-info-group info)))) (marks (cdr (assoc group flags)))) (when marks (nnimap-update-info info marks))))) @@ -1186,7 +1352,8 @@ textual parts.") (cdr (assq 'uidvalidity (gnus-info-params info))))) (and old-uidvalidity (not (equal old-uidvalidity uidvalidity)) - (> start-article 1))) + (or (not start-article) + (> start-article 1)))) (gnus-group-remove-parameter info 'uidvalidity) (gnus-group-remove-parameter info 'modseq)) ;; We have the data needed to update. @@ -1218,10 +1385,9 @@ textual parts.") (t ;; No articles and no uidnext. nil))) - (gnus-set-active - group - (cons (car active) - (or high (1- uidnext))))) + (gnus-set-active group + (cons (car active) + (or high (1- uidnext))))) ;; See whether this is a read-only group. (unless (eq permanent-flags 'not-scanned) (gnus-group-set-parameter @@ -1284,7 +1450,29 @@ textual parts.") (setq new-marks (gnus-range-nconcat old-marks new-marks))) (when new-marks (push (cons (car type) new-marks) marks))))) + ;; Keep track of non-existing articles. + (let* ((old-unexists (assq 'unexist marks)) + (unexists + (if completep + (gnus-range-difference + (gnus-active group) + (gnus-compress-sequence existing)) + (gnus-add-to-range + (cdr old-unexists) + (gnus-list-range-difference + existing (gnus-active group)))))) + (if old-unexists + (setcdr old-unexists unexists) + (push (cons 'unexist unexists) marks))) (gnus-info-set-marks info marks t)))) + ;; Tell Gnus whether there are any \Recent messages in any of + ;; the groups. + (let ((recent (cdr (assoc '%Recent flags)))) + (when (and active + recent + (> (car (last recent)) (cdr active))) + (push (list (cons (gnus-group-real-name group) 0)) + nnmail-split-history))) ;; Note the active level for the next run-through. (gnus-group-set-parameter info 'active (gnus-active group)) (gnus-group-set-parameter info 'uidvalidity uidvalidity) @@ -1319,6 +1507,14 @@ textual parts.") (gnus-sorted-complement existing new-marks)))) (when ticks (push (cons (car type) ticks) marks))) + (gnus-info-set-marks info marks t)) + ;; Add vanished to the list of unexisting articles. + (when vanished + (let* ((old-unexists (assq 'unexist marks)) + (unexists (gnus-range-add (cdr old-unexists) vanished))) + (if old-unexists + (setcdr old-unexists unexists) + (push (cons 'unexist unexists) marks))) (gnus-info-set-marks info marks t)))) (defun nnimap-imap-ranges-to-gnus-ranges (irange) @@ -1371,9 +1567,15 @@ textual parts.") (defun nnimap-parse-flags (sequences) (goto-char (point-min)) - ;; Change \Delete etc to %Delete, so that the reader can read it. + ;; Change \Delete etc to %Delete, so that the Emacs Lisp reader can + ;; read it. (subst-char-in-region (point-min) (point-max) ?\\ ?% t) + ;; Remove any MODSEQ entries in the buffer, because they may contain + ;; numbers that are too large for 32-bit Emacsen. + (while (re-search-forward " MODSEQ ([0-9]+)" nil t) + (replace-match "" t t)) + (goto-char (point-min)) (let (start end articles groups uidnext elems permanent-flags uidvalidity vanished highestmodseq) (dolist (elem sequences) @@ -1408,14 +1610,14 @@ textual parts.") (goto-char start) (setq vanished (and (eq flag-sequence 'qresync) - (re-search-forward "^\\* VANISHED .* \\([0-9:,]+\\)" + (re-search-forward "^\\* VANISHED .*? \\([0-9:,]+\\)" (or end (point-min)) t) (match-string 1))) (goto-char start) (setq highestmodseq - (and (search-forward "HIGHESTMODSEQ " + (and (re-search-forward "HIGHESTMODSEQ \\([0-9]+\\)" (or end (point-min)) t) - (read (current-buffer)))) + (match-string 1))) (goto-char end) (forward-line -1)) ;; The UID FETCH FLAGS was successful. @@ -1428,15 +1630,18 @@ textual parts.") (setq start (point)) (goto-char end)) (while (re-search-forward "^\\* [0-9]+ FETCH " start t) - (setq elems (read (current-buffer))) - (push (cons (cadr (memq 'UID elems)) - (cadr (memq 'FLAGS elems))) - articles)) + (let ((p (point))) + (setq elems (read (current-buffer))) + (push (cons (cadr (memq 'UID elems)) + (cadr (memq 'FLAGS elems))) + articles))) (push (nconc (list group uidnext totalp permanent-flags uidvalidity vanished highestmodseq) articles) groups) - (goto-char end) + (if (eq flag-sequence 'qresync) + (goto-char end) + (setq end (point))) (setq articles nil)))) groups)) @@ -1447,31 +1652,32 @@ textual parts.") (setq nnimap-status-string "Read-only server") nil) -(deffoo nnimap-request-thread (header) - (let* ((id (mail-header-id header)) - (refs (split-string - (or (mail-header-references header) - ""))) - (cmd (let ((value - (format - "(OR HEADER REFERENCES %s HEADER Message-Id %s)" - id id))) - (dolist (refid refs value) - (setq value (format - "(OR (OR HEADER Message-Id %s HEADER REFERENCES %s) %s)" - refid refid value))))) - (result (with-current-buffer (nnimap-buffer) - (nnimap-command "UID SEARCH %s" cmd)))) - (gnus-fetch-headers - (and (car result) (delete 0 (mapcar #'string-to-number - (cdr (assoc "SEARCH" (cdr result)))))) - nil t))) - -(defun nnimap-possibly-change-group (group server) +(declare-function gnus-fetch-headers "gnus-sum" + (articles &optional limit force-new dependencies)) + +(autoload 'nnir-search-thread "nnir") + +(deffoo nnimap-request-thread (header &optional group server) + (when group + (setq group (nnimap-decode-gnus-group group))) + (if gnus-refer-thread-use-nnir + (nnir-search-thread header) + (when (nnimap-possibly-change-group group server) + (let* ((cmd (nnimap-make-thread-query header)) + (result (with-current-buffer (nnimap-buffer) + (nnimap-command "UID SEARCH %s" cmd)))) + (when result + (gnus-fetch-headers + (and (car result) + (delete 0 (mapcar #'string-to-number + (cdr (assoc "SEARCH" (cdr result)))))) + nil t)))))) + +(defun nnimap-possibly-change-group (group server &optional no-reconnect) (let ((open-result t)) (when (and server (not (nnimap-server-opened server))) - (setq open-result (nnimap-open-server server))) + (setq open-result (nnimap-open-server server nil no-reconnect))) (cond ((not open-result) nil) @@ -1502,6 +1708,7 @@ textual parts.") (defvar nnimap-sequence 0) (defun nnimap-send-command (&rest args) + (setf (nnimap-last-command-time nnimap-object) (current-time)) (process-send-string (get-buffer-process (current-buffer)) (nnimap-log-command @@ -1517,15 +1724,22 @@ textual parts.") (nnimap-wait-for-response nnimap-sequence)) nnimap-sequence) +(defvar nnimap-record-commands nil + "If non-nil, log commands to the \"*imap log*\" buffer.") + (defun nnimap-log-command (command) - (with-current-buffer (get-buffer-create "*imap log*") - (goto-char (point-max)) - (insert (format-time-string "%H:%M:%S") " " command)) + (when nnimap-record-commands + (with-current-buffer (get-buffer-create "*imap log*") + (goto-char (point-max)) + (insert (format-time-string "%H:%M:%S") + " [" nnimap-address "] " + (if nnimap-inhibit-logging + "(inhibited)\n" + command)))) command) (defun nnimap-command (&rest args) (erase-buffer) - (setf (nnimap-last-command-time nnimap-object) (current-time)) (let* ((sequence (apply #'nnimap-send-command args)) (response (nnimap-get-response sequence))) (if (equal (caar response) "OK") @@ -1541,8 +1755,9 @@ textual parts.") (nnimap-parse-response)) (defun nnimap-wait-for-connection (&optional regexp) - (unless regexp - (setq regexp "^[*.] .*\n")) + (nnimap-wait-for-line (or regexp "^[*.] .*\n") "[*.] \\([A-Z0-9]+\\)")) + +(defun nnimap-wait-for-line (regexp &optional response-regexp) (let ((process (get-buffer-process (current-buffer)))) (goto-char (point-min)) (while (and (memq (process-status process) @@ -1551,7 +1766,7 @@ textual parts.") (nnheader-accept-process-output process) (goto-char (point-min))) (forward-line -1) - (and (looking-at "[*.] \\([A-Z0-9]+\\)") + (and (looking-at (or response-regexp regexp)) (match-string 1)))) (defun nnimap-wait-for-response (sequence &optional messagep) @@ -1562,23 +1777,32 @@ textual parts.") (goto-char (point-max)) (while (and (setq openp (memq (process-status process) '(open run))) - (not (re-search-backward - (format "^%d .*\n" sequence) - (if nnimap-streaming - (max (point-min) - (min - (- (point) 500) - (save-excursion - (forward-line -3) - (point)))) - (point-min)) - t))) + (progn + ;; Skip past any "*" lines that the server has + ;; output. + (while (and (not (bobp)) + (progn + (forward-line -1) + (looking-at "\\*")))) + (not (looking-at (format "%d .*\n" sequence))))) (when messagep - (nnheader-message 7 "nnimap read %dk" (/ (buffer-size) 1000))) + (nnheader-message-maybe + 7 "nnimap read %dk from %s%s" (/ (buffer-size) 1000) + nnimap-address + (if (not (zerop (nnimap-initial-resync nnimap-object))) + (format " (initial sync of %d group%s; please wait)" + (nnimap-initial-resync nnimap-object) + (if (= (nnimap-initial-resync nnimap-object) 1) + "" + "s")) + ""))) (nnheader-accept-process-output process) (goto-char (point-max))) + (setf (nnimap-initial-resync nnimap-object) 0) openp) (quit + (when debug-on-quit + (debug "Quit")) ;; The user hit C-g while we were waiting: kill the process, in case ;; it's a gnutls-cli process that's stuck (tends to happen a lot behind ;; NAT routers). @@ -1670,19 +1894,28 @@ textual parts.") (format "(UID %s%s)" (format (if (nnimap-ver4-p) - "BODY.PEEK[HEADER] BODY.PEEK" + "BODY.PEEK" "RFC822.PEEK")) - (if nnimap-split-download-body-default - "[]" - "[1]"))) + (cond + (nnimap-split-download-body-default + "[]") + ((nnimap-ver4-p) + "[HEADER]") + (t + "[1]")))) t)) (defun nnimap-split-incoming-mail () (with-current-buffer (nnimap-buffer) (let ((nnimap-incoming-split-list nil) - (nnmail-split-methods (if (eq nnimap-split-methods 'default) - nnmail-split-methods - nnimap-split-methods)) + (nnmail-split-methods + (cond + ((eq nnimap-split-methods 'default) + nnmail-split-methods) + (nnimap-split-methods + nnimap-split-methods) + (nnimap-split-fancy + 'nnmail-split-fancy))) (nnmail-split-fancy (or nnimap-split-fancy nnmail-split-fancy)) (nnmail-inhibit-default-split-group t) @@ -1754,7 +1987,7 @@ textual parts.") (defun nnimap-parse-copied-articles (sequences) (let (sequence copied range) (goto-char (point-min)) - (while (re-search-forward "^\\([0-9]+\\) OK " nil t) + (while (re-search-forward "^\\([0-9]+\\) OK\\b" nil t) (setq sequence (string-to-number (match-string 1))) (when (setq range (cadr (assq sequence sequences))) (push (gnus-uncompress-range range) copied))) @@ -1786,7 +2019,7 @@ textual parts.") (let (article bytes) (block nil (while (not (eobp)) - (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)")) + (while (not (looking-at "\\* [0-9]+ FETCH.+UID \\([0-9]+\\)")) (delete-region (point) (progn (forward-line 1) (point))) (when (eobp) (return))) @@ -1819,6 +2052,21 @@ textual parts.") group-art)) nnimap-incoming-split-list))) +(defun nnimap-make-thread-query (header) + (let* ((id (mail-header-id header)) + (refs (split-string + (or (mail-header-references header) + ""))) + (value + (format + "(OR HEADER REFERENCES %S HEADER Message-Id %S)" + id id))) + (dolist (refid refs value) + (setq value (format + "(OR (OR HEADER Message-Id %S HEADER REFERENCES %S) %s)" + refid refid value))))) + + (provide 'nnimap) ;;; nnimap.el ends here