X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fnnimap.el;h=68bd6307eab378001c9c5e4d43900bbed5ed9bff;hp=37cac75bca18877cbfa8648d8a8741c8879ec6ca;hb=a38f7f0769b418bce7538a763e13444bd1efe8cb;hpb=d9a3e711a59285cefa0bd745464aad6dbd821e05 diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 37cac75bc..68bd6307e 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -37,8 +37,13 @@ (require 'gnus) (require 'nnoo) (require 'netrc) +(require 'utf7) +(require 'tls) (require 'parse-time) +(autoload 'auth-source-forget-user-or-password "auth-source") +(autoload 'auth-source-user-or-password "auth-source") + (nnoo-declare nnimap) (defvoo nnimap-address nil @@ -62,6 +67,16 @@ Values are `ssl', `network', `starttls' or `shell'.") (defvoo nnimap-inbox nil "The mail box where incoming mail arrives and should be split out of.") +(defvoo nnimap-split-methods nil + "How mail is split. +Uses the same syntax as nnmail-split-methods") + +(defvoo nnimap-split-fancy nil + "Uses the same syntax as nnmail-split-fancy.") + +(make-obsolete-variable 'nnimap-split-rule "see `nnimap-split-methods'" + "Emacs 24.1") + (defvoo nnimap-authenticator nil "How nnimap authenticate itself to the server. Possible choices are nil (use default methods) or `anonymous'.") @@ -80,6 +95,13 @@ some servers.") (defvoo nnimap-current-infos nil) +(defvoo nnimap-fetch-partial-articles nil + "If non-nil, Gnus will fetch partial articles. +If t, nnimap will fetch only the first part. If a string, it +will fetch all parts that have types that match that string. A +likely value would be \"text/\" to automatically fetch all +textual parts.") + (defvar nnimap-process nil) (defvar nnimap-status-string "") @@ -92,7 +114,7 @@ some servers.") (defstruct nnimap group process commands capabilities select-result newlinep server - last-command-time) + last-command-time greeting) (defvar nnimap-object nil) @@ -107,8 +129,6 @@ some servers.") (download "gnus-download") (forward "gnus-forward"))) -(defvar nnimap-split-methods nil) - (defun nnimap-buffer () (nnimap-find-process-buffer nntp-server-buffer)) @@ -117,7 +137,6 @@ some servers.") (erase-buffer) (when (nnimap-possibly-change-group group server) (with-current-buffer (nnimap-buffer) - (nnimap-send-command "SELECT %S" (utf7-encode group t)) (erase-buffer) (nnimap-wait-for-response (nnimap-send-command @@ -236,7 +255,7 @@ some servers.") ?s host ?p port))))) -(defun nnimap-credentials (address ports) +(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. @@ -244,7 +263,10 @@ some servers.") (setq port (pop ports))) (setq credentials (auth-source-user-or-password - '("login" "password") address port nil (null ports)))) + '("login" "password") address port nil + (if inhibit-create + nil + (null ports))))) credentials)) (defun nnimap-keepalive () @@ -266,75 +288,143 @@ some servers.") (unless nnimap-keepalive-timer (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15) 'nnimap-keepalive))) - (with-current-buffer (nnimap-make-process-buffer buffer) - (let* ((coding-system-for-read 'binary) - (coding-system-for-write 'binary) - (ports - (cond - ((eq nnimap-stream 'network) - (open-network-stream - "*nnimap*" (current-buffer) nnimap-address - (or nnimap-server-port - (if (netrc-find-service-number "imap") - "imap" - "143"))) - '("143" "imap")) - ((eq nnimap-stream 'shell) - (nnimap-open-shell-stream - "*nnimap*" (current-buffer) nnimap-address - (or nnimap-server-port "imap")) - '("imap")) - ((eq nnimap-stream 'starttls) - (starttls-open-stream - "*nnimap*" (current-buffer) nnimap-address - (or nnimap-server-port "imap")) - '("imap")) - ((eq nnimap-stream 'ssl) - (open-tls-stream - "*nnimap*" (current-buffer) nnimap-address - (or nnimap-server-port - (if (netrc-find-service-number "imaps") - "imaps" - "993"))) - '("143" "993" "imap" "imaps")))) - connection-result login-result credentials) - (setf (nnimap-process nnimap-object) - (get-buffer-process (current-buffer))) - (when (and (nnimap-process nnimap-object) - (memq (process-status (nnimap-process nnimap-object)) - '(open run))) - (gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil) - (when (setq connection-result (nnimap-wait-for-connection)) - (when (eq nnimap-stream 'starttls) - (nnimap-command "STARTTLS") - (starttls-negotiate (nnimap-process nnimap-object))) - (unless (equal connection-result "PREAUTH") - (if (not (setq credentials - (if (eq nnimap-authenticator 'anonymous) - (list "anonymous" - (message-make-address)) - (nnimap-credentials - nnimap-address - (if nnimap-server-port - (cons (format "%s" nnimap-server-port) ports) - ports))))) - (setq nnimap-object nil) - (setq login-result (nnimap-command "LOGIN %S %S" - (car credentials) - (cadr credentials))) - (unless (car login-result) - (delete-process (nnimap-process nnimap-object)) - (setq nnimap-object nil)))) - (when nnimap-object + (block nil + (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) + (and (eq nnimap-stream 'starttls) + (fboundp 'open-gnutls-stream))) + (open-network-stream + "*nnimap*" (current-buffer) nnimap-address + (setq port + (or nnimap-server-port + (if (netrc-find-service-number "imap") + "imap" + "143")))) + '("143" "imap")) + ((eq nnimap-stream 'shell) + (nnimap-open-shell-stream + "*nnimap*" (current-buffer) nnimap-address + (setq port (or nnimap-server-port "imap"))) + '("imap")) + ((eq nnimap-stream 'starttls) + (let ((tls-program (nnimap-extend-tls-programs))) + (open-tls-stream + "*nnimap*" (current-buffer) nnimap-address + (setq port (or nnimap-server-port "imap")) + 'starttls)) + '("imap")) + ((memq nnimap-stream '(ssl tls)) + (funcall (if (fboundp 'open-gnutls-stream) + 'open-gnutls-stream + 'open-tls-stream) + "*nnimap*" (current-buffer) nnimap-address + (setq port + (or nnimap-server-port + (if (netrc-find-service-number "imaps") + "imaps" + "993")))) + '("143" "993" "imap" "imaps")) + (t + (error "Unknown stream type: %s" nnimap-stream)))) + connection-result login-result credentials) + (setf (nnimap-process nnimap-object) + (get-buffer-process (current-buffer))) + (if (not (and (nnimap-process nnimap-object) + (memq (process-status (nnimap-process nnimap-object)) + '(open run)))) + (nnheader-report 'nnimap "Unable to contact %s:%s via %s" + nnimap-address port nnimap-stream) + (gnus-set-process-query-on-exit-flag + (nnimap-process nnimap-object) nil) + (if (not (setq connection-result (nnimap-wait-for-connection))) + (nnheader-report 'nnimap + "%s" (buffer-substring + (point) (line-end-position))) + ;; Store the greeting (for debugging purposes). + (setf (nnimap-greeting nnimap-object) + (buffer-substring (line-beginning-position) + (line-end-position))) + ;; Store the capabilities. (setf (nnimap-capabilities nnimap-object) (mapcar #'upcase - (or (nnimap-find-parameter "CAPABILITY" (cdr login-result)) - (nnimap-find-parameter - "CAPABILITY" (cdr (nnimap-command "CAPABILITY")))))) - (when (member "QRESYNC" (nnimap-capabilities nnimap-object)) - (nnimap-command "ENABLE QRESYNC")) - t)))))) + (nnimap-find-parameter + "CAPABILITY" (cdr (nnimap-command "CAPABILITY"))))) + (when nnimap-server-port + (push (format "%s" nnimap-server-port) ports)) + ;; If this is a STARTTLS-capable server, then sever the + ;; connection and start a STARTTLS connection instead. + (cond + ((and (or (and (eq nnimap-stream 'network) + (member "STARTTLS" + (nnimap-capabilities nnimap-object))) + (eq nnimap-stream 'starttls)) + (fboundp 'open-gnutls-stream)) + (nnimap-command "STARTTLS") + (gnutls-negotiate (nnimap-process nnimap-object) nil)) + ((and (eq nnimap-stream 'network) + (member "STARTTLS" (nnimap-capabilities nnimap-object))) + (let ((nnimap-stream 'starttls)) + (let ((tls-process + (nnimap-open-connection buffer))) + ;; If the STARTTLS connection was successful, we + ;; kill our first non-encrypted connection. If it + ;; wasn't successful, we just use our unencrypted + ;; connection. + (when (memq (process-status tls-process) '(open run)) + (delete-process (nnimap-process nnimap-object)) + (kill-buffer (current-buffer)) + (return tls-process)))))) + (unless (equal connection-result "PREAUTH") + (if (not (setq credentials + (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))))) + (setq nnimap-object nil) + (setq login-result (nnimap-command "LOGIN %S %S" + (car credentials) + (cadr credentials))) + (unless (car login-result) + ;; 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)))) + (delete-process (nnimap-process nnimap-object)) + (setq nnimap-object nil)))) + (when nnimap-object + (when (member "QRESYNC" (nnimap-capabilities nnimap-object)) + (nnimap-command "ENABLE QRESYNC")) + (nnimap-process nnimap-object)))))))) + +(defun nnimap-extend-tls-programs () + (let ((programs tls-program) + result) + (unless (consp programs) + (setq programs (list programs))) + (dolist (program programs) + (when (assoc (car (split-string program)) tls-starttls-switches) + (push (if (not (string-match "%s" program)) + (concat program " " "%s") + program) + result))) + (nreverse result))) (defun nnimap-find-parameter (parameter elems) (let (result) @@ -349,7 +439,10 @@ some servers.") result)) (deffoo nnimap-close-server (&optional server) - t) + (when (nnoo-change-server 'nnimap server nil) + (ignore-errors + (delete-process (get-buffer-process (nnimap-buffer)))) + t)) (deffoo nnimap-request-close () t) @@ -374,14 +467,17 @@ some servers.") (erase-buffer) (with-current-buffer (nnimap-buffer) (erase-buffer) - (when gnus-fetch-partial-articles - (if (eq gnus-fetch-partial-articles t) - (setq parts '(1)) - (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article) - (goto-char (point-min)) - (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t) - (setq structure (ignore-errors (read (current-buffer))) - parts (nnimap-find-wanted-parts structure))))) + (when nnimap-fetch-partial-articles + (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article) + (goto-char (point-min)) + (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t) + (setq structure (ignore-errors + (let ((start (point))) + (forward-sexp 1) + (downcase-region start (point)) + (goto-char (point)) + (read (current-buffer)))) + parts (nnimap-find-wanted-parts structure)))) (when (if parts (nnimap-get-partial-article article parts structure) (nnimap-get-whole-article article)) @@ -401,10 +497,13 @@ some servers.") article))) ;; Check that we really got an article. (goto-char (point-min)) - (unless (looking-at "\\* [0-9]+ FETCH") + (unless (re-search-forward "\\* [0-9]+ FETCH" nil t) (setq result nil)) (when result - (goto-char (point-min)) + ;; Remove any data that may have arrived before the FETCH data. + (beginning-of-line) + (unless (bobp) + (delete-region (point-min) (point))) (let ((bytes (nnimap-get-length))) (delete-region (line-beginning-position) (progn (forward-line 1) (point))) @@ -458,8 +557,15 @@ some servers.") t)) (defun nnimap-insert-partial-structure (structure parts &optional subp) - (let ((type (car (last structure 4))) - (boundary (cadr (member "BOUNDARY" (car (last structure 3)))))) + (let (type boundary) + (let ((bstruc structure)) + (while (consp (car bstruc)) + (pop bstruc)) + (setq type (car bstruc)) + (setq bstruc (car (cdr bstruc))) + (when (and (stringp (car bstruc)) + (string= (downcase (car bstruc)) "boundary")) + (setq boundary (cadr bstruc)))) (when subp (insert (format "Content-type: multipart/%s; boundary=%S\n\n" (downcase type) boundary))) @@ -501,7 +607,9 @@ some servers.") (number-to-string num) (format "%s.%s" prefix num)))) (setcar (nthcdr 9 sub) id) - (when (string-match gnus-fetch-partial-articles type) + (when (if (eq nnimap-fetch-partial-articles t) + (equal id "1") + (string-match nnimap-fetch-partial-articles type)) (push id parts)))) (incf num))) (nreverse parts))) @@ -528,15 +636,18 @@ some servers.") (setq marks (nnimap-flags-to-marks (nnimap-parse-flags - (list (list group-sequence flag-sequence 1 group))))) - (when info + (list (list group-sequence flag-sequence + 1 group "SELECT"))))) + (when (and info + marks) (nnimap-update-infos marks (list info))) (goto-char (point-max)) (let ((uidnext (nth 5 (car marks)))) - (setq high (if uidnext - (1- uidnext) - (nth 3 (car marks))) - low (or (nth 4 (car marks)) uidnext))))) + (setq high (or (if uidnext + (1- uidnext) + (nth 3 (car marks))) + 0) + low (or (nth 4 (car marks)) uidnext 1))))) (erase-buffer) (insert (format @@ -553,6 +664,12 @@ some servers.") (with-current-buffer (nnimap-buffer) (car (nnimap-command "DELETE %S" (utf7-encode group t)))))) +(deffoo nnimap-request-rename-group (group new-name &optional server) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer (nnimap-buffer) + (car (nnimap-command "RENAME %S %S" + (utf7-encode group t) (utf7-encode new-name t)))))) + (deffoo nnimap-request-expunge-group (group &optional server) (when (nnimap-possibly-change-group group server) (with-current-buffer (nnimap-buffer) @@ -560,16 +677,19 @@ some servers.") (defun nnimap-get-flags (spec) (let ((articles nil) - elems) + elems end) (with-current-buffer (nnimap-buffer) (erase-buffer) (nnimap-wait-for-response (nnimap-send-command "UID FETCH %s FLAGS" spec)) + (setq end (point)) + (subst-char-in-region (point-min) (point-max) + ?\\ ?% t) (goto-char (point-min)) - (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" nil t) - (setq elems (nnimap-parse-line (match-string 1))) - (push (cons (string-to-number (cadr (member "UID" elems))) - (cadr (member "FLAGS" elems))) + (while (search-forward " FETCH " end t) + (setq elems (read (current-buffer))) + (push (cons (cadr (memq 'UID elems)) + (cadr (memq 'FLAGS elems))) articles))) (nreverse articles))) @@ -608,7 +728,7 @@ some servers.") articles) ((and force (eq nnmail-expiry-target 'delete)) - (unless (nnimap-delete-article articles) + (unless (nnimap-delete-article (gnus-compress-sequence articles)) (message "Article marked for deletion, but not expunged.")) nil) (t @@ -622,7 +742,7 @@ some servers.") (if (null deletable-articles) articles (if (eq nnmail-expiry-target 'delete) - (nnimap-delete-article deletable-articles) + (nnimap-delete-article (gnus-compress-sequence deletable-articles)) (setq deletable-articles (nnimap-process-expiry-targets deletable-articles group server))) @@ -649,7 +769,7 @@ some servers.") ;; Change back to the current group again. (nnimap-possibly-change-group group server) (setq deleted-articles (nreverse deleted-articles)) - (nnimap-delete-article deleted-articles) + (nnimap-delete-article (gnus-compress-sequence deleted-articles)) deleted-articles)) (defun nnimap-find-expired-articles (group) @@ -670,16 +790,20 @@ some servers.") (defun nnimap-find-article-by-message-id (group message-id) - (when (nnimap-possibly-change-group group nil) - (with-current-buffer (nnimap-buffer) - (let ((result - (nnimap-command "UID SEARCH HEADER Message-Id %S" message-id)) - article) - (when (car result) - ;; Select the last instance of the message in the group. - (and (setq article - (car (last (assoc "SEARCH" (cdr result))))) - (string-to-number article))))))) + (with-current-buffer (nnimap-buffer) + (erase-buffer) + (setf (nnimap-group nnimap-object) nil) + (nnimap-send-command "EXAMINE %S" (utf7-encode group t)) + (let ((sequence + (nnimap-send-command "UID SEARCH HEADER Message-Id %S" message-id)) + article result) + (setq result (nnimap-wait-for-response sequence)) + (when (and result + (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))))) + (string-to-number article)))))) (defun nnimap-delete-article (articles) (with-current-buffer (nnimap-buffer) @@ -715,6 +839,7 @@ some servers.") (when (nnimap-possibly-change-group group server) (let (sequence) (with-current-buffer (nnimap-buffer) + (erase-buffer) ;; Just send all the STORE commands without waiting for ;; response. If they're successful, they're successful. (dolist (action actions) @@ -736,9 +861,10 @@ some servers.") (deffoo nnimap-request-accept-article (group &optional server last) (when (nnimap-possibly-change-group nil server) (nnmail-check-syntax) - (let ((message (buffer-string)) - (message-id (message-field-value "message-id")) - sequence) + (let ((message-id (message-field-value "message-id")) + sequence message) + (nnimap-add-cr) + (setq message (buffer-string)) (with-current-buffer (nnimap-buffer) (setq sequence (nnimap-send-command "APPEND %S {%d}" (utf7-encode group t) @@ -749,7 +875,10 @@ some servers.") "\n" "\r\n")) (let ((result (nnimap-get-response sequence))) - (when result + (if (not (car result)) + (progn + (message "%s" (nnheader-get-report-string 'nnimap)) + nil) (cons group (nnimap-find-article-by-message-id group message-id)))))))) @@ -813,50 +942,67 @@ some servers.") (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)) + (deffoo nnimap-retrieve-group-data-early (server infos) (when (nnimap-possibly-change-group nil server) (with-current-buffer (nnimap-buffer) + (erase-buffer) + (setf (nnimap-group nnimap-object) nil) ;; QRESYNC handling isn't implemented. - (let ((qresyncp (member "notQRESYNC" (nnimap-capabilities nnimap-object))) - marks groups sequences) + (let ((qresyncp (member "QRESYNC" (nnimap-capabilities nnimap-object))) + params groups sequences active uidvalidity modseq group) ;; Go through the infos and gather the data needed to know ;; what and how to request the data. (dolist (info infos) - (setq marks (gnus-info-marks info)) - (push (list (gnus-group-real-name (gnus-info-group info)) - (cdr (assq 'active marks)) - (cdr (assq 'uid marks))) - groups)) - ;; Then request the data. - (erase-buffer) - (setf (nnimap-group nnimap-object) nil) - (dolist (elem groups) + (setq params (gnus-info-params info) + group (gnus-group-real-name (gnus-info-group info)) + active (cdr (assq 'active params)) + uidvalidity (cdr (assq 'uidvalidity params)) + modseq (cdr (assq 'modseq params))) (if (and qresyncp - (nth 2 elem)) + uidvalidity + modseq) (push - (list 'qresync - (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))" - (car elem) - (car (nth 2 elem)) - (cdr (nth 2 elem))) - nil - (car elem)) + (list (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))" + (utf7-encode group t) + uidvalidity modseq) + 'qresync + nil group 'qresync) sequences) (let ((start - (if (nth 1 elem) + (if (and active uidvalidity) ;; Fetch the last 100 flags. - (max 1 (- (cdr (nth 1 elem)) 100)) - 1))) - (push (list (nnimap-send-command "EXAMINE %S" (car elem)) + (max 1 (- (cdr active) 100)) + 1)) + (command + (if uidvalidity + "EXAMINE" + ;; If we don't have a UIDVALIDITY, then this is + ;; the first time we've seen the group, so we + ;; have to do a SELECT (which is slower than an + ;; examine), but will tell us whether the group + ;; is read-only or not. + "SELECT"))) + (push (list (nnimap-send-command "%s %S" command + (utf7-encode group t)) (nnimap-send-command "UID FETCH %d:* FLAGS" start) - start - (car elem)) + start group command) sequences))) ;; Some servers apparently can't have many outstanding ;; commands, so throttle them. (when (and (not nnimap-streaming) (car sequences)) - (nnimap-wait-for-response (car sequences)))) + (nnimap-wait-for-response (caar sequences)))) sequences)))) (deffoo nnimap-finish-retrieve-group-infos (server infos sequences) @@ -864,10 +1010,13 @@ some servers.") (nnimap-possibly-change-group nil server)) (with-current-buffer (nnimap-buffer) ;; Wait for the final data to trickle in. - (when (nnimap-wait-for-response (cadar sequences)) - ;; Now we should have all the data we need, no matter whether - ;; we're QRESYNCING, fetching all the flags from scratch, or - ;; just fetching the last 100 flags per group. + (when (nnimap-wait-for-response (if (eq (cadar sequences) 'qresync) + (caar sequences) + (cadar sequences)) + t) + ;; Now we should have most of the data we need, no matter + ;; whether we're QRESYNCING, fetching all the flags from + ;; scratch, or just fetching the last 100 flags per group. (nnimap-update-infos (nnimap-flags-to-marks (nnimap-parse-flags (nreverse sequences))) @@ -887,16 +1036,40 @@ some servers.") (defun nnimap-update-infos (flags infos) (dolist (info infos) - (let ((group (gnus-group-real-name (gnus-info-group info)))) - (nnimap-update-info info (cdr (assoc group flags)))))) + (let* ((group (gnus-group-real-name (gnus-info-group info))) + (marks (cdr (assoc group flags)))) + (when marks + (nnimap-update-info info marks))))) (defun nnimap-update-info (info marks) - (when marks - (destructuring-bind (existing flags high low uidnext start-article - permanent-flags) marks - (let ((group (gnus-info-group info)) - (completep (and start-article - (= start-article 1)))) + (destructuring-bind (existing flags high low uidnext start-article + permanent-flags uidvalidity + vanished highestmodseq) marks + (cond + ;; Ignore groups with no UIDNEXT/marks. This happens for + ;; completely empty groups. + ((and (not existing) + (not uidnext)) + (let ((active (cdr (assq 'active (gnus-info-params info))))) + (when active + (gnus-set-active (gnus-info-group info) active)))) + ;; We have a mismatch between the old and new UIDVALIDITY + ;; identifiers, so we have to re-request the group info (the next + ;; time). This virtually never happens. + ((let ((old-uidvalidity + (cdr (assq 'uidvalidity (gnus-info-params info))))) + (and old-uidvalidity + (not (equal old-uidvalidity uidvalidity)) + (> start-article 1))) + (gnus-group-remove-parameter info 'uidvalidity) + (gnus-group-remove-parameter info 'modseq)) + ;; We have the data needed to update. + (t + (let* ((group (gnus-info-group info)) + (completep (and start-article + (= start-article 1))) + (active (or (gnus-active group) + (cdr (assq 'active (gnus-info-params info)))))) (when uidnext (setq high (1- uidnext))) ;; First set the active ranges based on high/low. @@ -909,61 +1082,122 @@ some servers.") (uidnext ;; No articles in this group. (cons uidnext (1- uidnext))) + (active + active) (start-article (cons start-article (1- start-article))) (t ;; No articles and no uidnext. nil))) - (setcdr (gnus-active group) (or high (1- uidnext)))) - (when (and (not high) - uidnext) - (setq high (1- uidnext))) - ;; Then update the list of read articles. - (let* ((unread - (gnus-compress-sequence - (gnus-set-difference - (gnus-set-difference - existing - (cdr (assoc '%Seen flags))) - (cdr (assoc '%Flagged flags))))) - (read (gnus-range-difference - (cons start-article high) unread))) - (when (> start-article 1) - (setq read - (gnus-range-nconcat - (if (> start-article 1) - (gnus-sorted-range-intersection - (cons 1 (1- start-article)) - (gnus-info-read info)) - (gnus-info-read info)) - read))) - (gnus-info-set-read info read) - ;; Update the marks. - (setq marks (gnus-info-marks info)) - ;; Note the active level for the next run-through. - (let ((active (assq 'active marks))) - (if active - (setcdr active (gnus-active group)) - (push (cons 'active (gnus-active group)) marks))) - (dolist (type (cdr nnimap-mark-alist)) - (let ((old-marks (assoc (car type) marks)) - (new-marks - (gnus-compress-sequence - (cdr (or (assoc (caddr type) flags) ; %Flagged - (assoc (intern (cadr type) obarray) flags) - (assoc (cadr type) flags)))))) ; "\Flagged" - (setq marks (delq old-marks marks)) - (pop old-marks) - (when (and old-marks - (> start-article 1)) - (setq old-marks (gnus-range-difference - old-marks - (cons start-article high))) - (setq new-marks (gnus-range-nconcat old-marks new-marks))) - (when new-marks - (push (cons (car type) new-marks) marks))) - (gnus-info-set-marks info marks t) - (nnimap-store-info info (gnus-active group)))))))) + (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 + info 'permanent-flags + (if (memq '%* permanent-flags) + t + nil))) + ;; Update marks and read articles if this isn't a + ;; read-only IMAP group. + (when (cdr (assq 'permanent-flags (gnus-info-params info))) + (if (and highestmodseq + (not start-article)) + ;; We've gotten the data by QRESYNCing. + (nnimap-update-qresync-info + info existing (nnimap-imap-ranges-to-gnus-ranges vanished) flags) + ;; Do normal non-QRESYNC flag updates. + ;; Update the list of read articles. + (let* ((unread + (gnus-compress-sequence + (gnus-set-difference + (gnus-set-difference + existing + (cdr (assoc '%Seen flags))) + (cdr (assoc '%Flagged flags))))) + (read (gnus-range-difference + (cons start-article high) unread))) + (when (> start-article 1) + (setq read + (gnus-range-nconcat + (if (> start-article 1) + (gnus-sorted-range-intersection + (cons 1 (1- start-article)) + (gnus-info-read info)) + (gnus-info-read info)) + read))) + (gnus-info-set-read info read) + ;; Update the marks. + (setq marks (gnus-info-marks info)) + (dolist (type (cdr nnimap-mark-alist)) + (let ((old-marks (assoc (car type) marks)) + (new-marks + (gnus-compress-sequence + (cdr (or (assoc (caddr type) flags) ; %Flagged + (assoc (intern (cadr type) obarray) flags) + (assoc (cadr type) flags)))))) ; "\Flagged" + (setq marks (delq old-marks marks)) + (pop old-marks) + (when (and old-marks + (> start-article 1)) + (setq old-marks (gnus-range-difference + old-marks + (cons start-article high))) + (setq new-marks (gnus-range-nconcat old-marks new-marks))) + (when new-marks + (push (cons (car type) new-marks) marks))) + (gnus-info-set-marks info marks t))))) + ;; 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) + (gnus-group-set-parameter info 'modseq highestmodseq) + (nnimap-store-info info (gnus-active group))))))) + +(defun nnimap-update-qresync-info (info existing vanished flags) + ;; Add all the vanished articles to the list of read articles. + (gnus-info-set-read + info + (gnus-add-to-range + (gnus-add-to-range + (gnus-range-add (gnus-info-read info) + vanished) + (cdr (assq '%Flagged flags))) + (cdr (assq '%Seen flags)))) + (let ((marks (gnus-info-marks info))) + (dolist (type (cdr nnimap-mark-alist)) + (let ((ticks (assoc (car type) marks)) + (new-marks + (cdr (or (assoc (caddr type) flags) ; %Flagged + (assoc (intern (cadr type) obarray) flags) + (assoc (cadr type) flags))))) ; "\Flagged" + (setq marks (delq ticks marks)) + (pop ticks) + ;; Add the new marks we got. + (setq ticks (gnus-add-to-range ticks new-marks)) + ;; Remove the marks from messages that don't have them. + (setq ticks (gnus-remove-from-range + ticks + (gnus-compress-sequence + (gnus-sorted-complement existing new-marks)))) + (when ticks + (push (cons (car type) ticks) marks))) + (gnus-info-set-marks info marks t)))) + +(defun nnimap-imap-ranges-to-gnus-ranges (irange) + (if (zerop (length irange)) + nil + (let ((result nil)) + (dolist (elem (split-string irange ",")) + (push + (if (string-match ":" elem) + (let ((numbers (split-string elem ":"))) + (cons (string-to-number (car numbers)) + (string-to-number (cadr numbers)))) + (string-to-number elem)) + result)) + (nreverse result)))) (defun nnimap-store-info (info active) (let* ((group (gnus-group-real-name (gnus-info-group info))) @@ -973,13 +1207,17 @@ some servers.") (push (list group info active) nnimap-current-infos)))) (defun nnimap-flags-to-marks (groups) - (let (data group totalp uidnext articles start-article mark permanent-flags) + (let (data group totalp uidnext articles start-article mark permanent-flags + uidvalidity vanished highestmodseq) (dolist (elem groups) (setq group (car elem) uidnext (nth 1 elem) start-article (nth 2 elem) permanent-flags (nth 3 elem) - articles (nthcdr 4 elem)) + uidvalidity (nth 4 elem) + vanished (nth 5 elem) + highestmodseq (nth 6 elem) + articles (nthcdr 7 elem)) (let ((high (caar articles)) marks low existing) (dolist (article articles) @@ -991,7 +1229,7 @@ some servers.") (push (list flag (car article)) marks) (setcdr mark (cons (car article) (cdr mark)))))) (push (list group existing marks high low uidnext start-article - permanent-flags) + permanent-flags uidvalidity vanished highestmodseq) data))) data)) @@ -1000,38 +1238,69 @@ some servers.") ;; Change \Delete etc to %Delete, so that the reader can read it. (subst-char-in-region (point-min) (point-max) ?\\ ?% t) - (let (start end articles groups uidnext elems permanent-flags) + (let (start end articles groups uidnext elems permanent-flags + uidvalidity vanished highestmodseq) (dolist (elem sequences) - (destructuring-bind (group-sequence flag-sequence totalp group) elem + (destructuring-bind (group-sequence flag-sequence totalp group command) + elem (setq start (point)) - ;; The EXAMINE was successful. - (when (and (search-forward (format "\n%d OK " group-sequence) nil t) - (progn - (forward-line 1) - (setq end (point)) - (goto-char start) - (setq permanent-flags + (when (and + ;; The EXAMINE was successful. + (search-forward (format "\n%d OK " group-sequence) nil t) + (progn + (forward-line 1) + (setq end (point)) + (goto-char start) + (setq permanent-flags + (if (equal command "SELECT") (and (search-forward "PERMANENTFLAGS " - (or end (point-min)) t) - (read (current-buffer)))) - (goto-char start) - (setq uidnext - (and (search-forward "UIDNEXT " - (or end (point-min)) t) - (read (current-buffer)))) - (goto-char end) - (forward-line -1)) - ;; The UID FETCH FLAGS was successful. - (search-forward (format "\n%d OK " flag-sequence) nil t)) - (setq start (point)) - (goto-char end) + (or end (point-min)) t) + (read (current-buffer))) + 'not-scanned)) + (goto-char start) + (setq uidnext + (and (search-forward "UIDNEXT " + (or end (point-min)) t) + (read (current-buffer)))) + (goto-char start) + (setq uidvalidity + (and (re-search-forward "UIDVALIDITY \\([0-9]+\\)" + (or end (point-min)) t) + ;; Store UIDVALIDITY as a string, as it's + ;; too big for 32-bit Emacsen, usually. + (match-string 1))) + (goto-char start) + (setq vanished + (and (eq flag-sequence 'qresync) + (re-search-forward "VANISHED.* \\([0-9:,]+\\)" + (or end (point-min)) t) + (match-string 1))) + (goto-char start) + (setq highestmodseq + (and (search-forward "HIGHESTMODSEQ " + (or end (point-min)) t) + (read (current-buffer)))) + (goto-char end) + (forward-line -1)) + ;; The UID FETCH FLAGS was successful. + (or (eq flag-sequence 'qresync) + (search-forward (format "\n%d OK " flag-sequence) nil t))) + (if (eq flag-sequence 'qresync) + (progn + (goto-char start) + (setq start end)) + (setq start (point)) + (goto-char end)) (while (search-forward " FETCH " start t) (setq elems (read (current-buffer))) (push (cons (cadr (memq 'UID elems)) (cadr (memq 'FLAGS elems))) articles)) - (push (nconc (list group uidnext totalp permanent-flags) articles) + (push (nconc (list group uidnext totalp permanent-flags uidvalidity + vanished highestmodseq) + articles) groups) + (goto-char end) (setq articles nil)))) groups)) @@ -1116,27 +1385,38 @@ some servers.") (goto-char (point-min)) (while (and (memq (process-status process) '(open run)) - (not (re-search-forward "^\\* .*\n" nil t))) + (not (re-search-forward "^[*.] .*\n" nil t))) (nnheader-accept-process-output process) (goto-char (point-min))) (forward-line -1) - (and (looking-at "\\* \\([A-Z0-9]+\\)") + (and (looking-at "[*.] \\([A-Z0-9]+\\)") (match-string 1)))) (defun nnimap-wait-for-response (sequence &optional messagep) (let ((process (get-buffer-process (current-buffer))) openp) - (goto-char (point-max)) - (while (and (setq openp (memq (process-status process) - '(open run))) - (not (re-search-backward (format "^%d .*\n" sequence) - (max (point-min) (- (point) 500)) - t))) - (when messagep - (message "Read %dKB" (/ (buffer-size) 1000))) - (nnheader-accept-process-output process) - (goto-char (point-max))) - openp)) + (condition-case nil + (progn + (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) (- (point) 500)) + (point-min)) + t))) + (when messagep + (message "nnimap read %dk" (/ (buffer-size) 1000))) + (nnheader-accept-process-output process) + (goto-char (point-max))) + openp) + (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). + (delete-process process) + nil)))) (defun nnimap-parse-response () (let ((lines (split-string (nnimap-last-response-string) "\r\n" t)) @@ -1162,14 +1442,21 @@ some servers.") (push (cond ((eql char ?\[) - (split-string (buffer-substring - (1+ (point)) (1- (search-forward "]"))))) + (split-string + (buffer-substring + (1+ (point)) + (1- (search-forward "]" (line-end-position) 'move))))) ((eql char ?\() - (split-string (buffer-substring - (1+ (point)) (1- (search-forward ")"))))) + (split-string + (buffer-substring + (1+ (point)) + (1- (search-forward ")" (line-end-position) 'move))))) ((eql char ?\") (forward-char 1) - (buffer-substring (point) (1- (search-forward "\"")))) + (buffer-substring + (point) + (1- (or (search-forward "\"" (line-end-position) 'move) + (point))))) (t (buffer-substring (point) (if (search-forward " " nil t) (1- (point)) @@ -1221,7 +1508,11 @@ some servers.") (defun nnimap-split-incoming-mail () (with-current-buffer (nnimap-buffer) (let ((nnimap-incoming-split-list nil) - (nnmail-split-methods nnimap-split-methods) + (nnmail-split-methods (if (eq nnimap-split-methods 'default) + nnmail-split-methods + nnimap-split-methods)) + (nnmail-split-fancy (or nnimap-split-fancy + nnmail-split-fancy)) (nnmail-inhibit-default-split-group t) (groups (nnimap-get-groups)) new-articles) @@ -1272,6 +1563,7 @@ some servers.") (defun nnimap-mark-and-expunge-incoming (range) (when range (setq range (nnimap-article-ranges range)) + (erase-buffer) (let ((sequence (nnimap-send-command "UID STORE %s +FLAGS.SILENT (\\Deleted)" range))) @@ -1335,8 +1627,10 @@ some servers.") (forward-char (1+ bytes)) (setq bytes (nnimap-get-length)) (delete-region (line-beginning-position) (line-end-position)) - (forward-char (1+ bytes)) - (delete-region (line-beginning-position) (line-end-position)))))) + ;; There's a body; skip past that. + (when bytes + (forward-char (1+ bytes)) + (delete-region (line-beginning-position) (line-end-position))))))) (defun nnimap-dummy-active-number (group &optional server) 1)