lisp/gnus/nnimap.el

   1 ;;; nnimap.el --- IMAP interface for Gnus
   2
   3 ;; Copyright (C) 2010-2017 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;         Simon Josefsson <simon@josefsson.org>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; nnimap interfaces Gnus with IMAP servers.
  26
  27 ;;; Code:
  28
  29 (eval-when-compile
  30   (require 'cl))
  31
  32 (require 'nnheader)
  33 (require 'gnus-util)
  34 (require 'gnus)
  35 (require 'nnoo)
  36 (require 'netrc)
  37 (require 'utf7)
  38 (require 'tls)
  39 (require 'parse-time)
  40 (require 'nnmail)
  41
  42 (autoload 'auth-source-forget+ "auth-source")
  43 (autoload 'auth-source-search "auth-source")
  44
  45 (nnoo-declare nnimap)
  46
  47 (defvoo nnimap-address nil
  48   "The address of the IMAP server.")
  49
  50 (defvoo nnimap-user nil
  51   "Username to use for authentication to the IMAP server.")
  52
  53 (defvoo nnimap-server-port nil
  54   "The IMAP port used.
  55 If nnimap-stream is `ssl', this will default to `imaps'.  If not,
  56 it will default to `imap'.")
  57
  58 (defvoo nnimap-stream 'undecided
  59   "How nnimap talks to the IMAP server.
  60 The value should be either `undecided', `ssl' or `tls',
  61 `network', `starttls', `plain', or `shell'.
  62
  63 If the value is `undecided', nnimap tries `ssl' first, then falls
  64 back on `network'.")
  65
  66 (defvoo nnimap-shell-program (if (boundp 'imap-shell-program)
  67                                  (if (listp imap-shell-program)
  68                                      (car imap-shell-program)
  69                                    imap-shell-program)
  70                                "ssh %s imapd")
  71   "What command to execute to connect to an IMAP server.
  72 This will only be used if the connection type is `shell'.  See
  73 the `open-network-stream' documentation for an explanation of
  74 the format.")
  75
  76 (defvoo nnimap-inbox nil
  77   "The mail box where incoming mail arrives and should be split out of.
  78 This can be a string or a list of strings
  79 For example, \"INBOX\" or (\"INBOX\" \"SENT\").")
  80
  81 (defvoo nnimap-split-methods nil
  82   "How mail is split.
  83 Uses the same syntax as `nnmail-split-methods'.")
  84
  85 (defvoo nnimap-split-fancy nil
  86   "Uses the same syntax as `nnmail-split-fancy'.")
  87
  88 (defvoo nnimap-unsplittable-articles '(%Deleted %Seen)
  89   "Articles with the flags in the list will not be considered when splitting.")
  90
  91 (make-obsolete-variable 'nnimap-split-rule "see `nnimap-split-methods'."
  92                         "Emacs 24.1")
  93
  94 (defvoo nnimap-authenticator nil
  95   "How nnimap authenticate itself to the server.
  96 Possible choices are nil (use default methods), `anonymous',
  97 `login', `plain' and `cram-md5'.")
  98
  99 (defvoo nnimap-expunge t
 100   "If non-nil, expunge articles after deleting them.
 101 This is always done if the server supports UID EXPUNGE, but it's
 102 not done by default on servers that doesn't support that command.")
 103
 104 (defvoo nnimap-streaming t
 105   "If non-nil, try to use streaming commands with IMAP servers.
 106 Switching this off will make nnimap slower, but it helps with
 107 some servers.")
 108
 109 (defvoo nnimap-connection-alist nil)
 110
 111 (defvoo nnimap-current-infos nil)
 112
 113 (defun nnimap-decode-gnus-group (group)
 114   (decode-coding-string group 'utf-8))
 115
 116 (defun nnimap-encode-gnus-group (group)
 117   (encode-coding-string group 'utf-8))
 118
 119 (defvoo nnimap-fetch-partial-articles nil
 120   "If non-nil, Gnus will fetch partial articles.
 121 If t, Gnus will fetch only the first part.  If a string, it
 122 will fetch all parts that have types that match that string.  A
 123 likely value would be \"text/\" to automatically fetch all
 124 textual parts.")
 125
 126 (defgroup nnimap nil
 127   "IMAP for Gnus."
 128   :group 'gnus)
 129
 130 (defcustom nnimap-request-articles-find-limit nil
 131   "Limit the number of articles to look for after moving an article."
 132   :type '(choice (const nil) integer)
 133   :version "24.4"
 134   :group 'nnimap)
 135
 136 (defvar nnimap-process nil)
 137
 138 (defvar nnimap-status-string "")
 139
 140 (defvar nnimap-split-download-body-default nil
 141   "Internal variable with default value for `nnimap-split-download-body'.")
 142
 143 (defvar nnimap-keepalive-timer nil)
 144 (defvar nnimap-process-buffers nil)
 145
 146 (defstruct nnimap
 147   group process commands capabilities select-result newlinep server
 148   last-command-time greeting examined stream-type initial-resync)
 149
 150 (defvar nnimap-object nil)
 151
 152 (defvar nnimap-mark-alist
 153   '((read "\\Seen" %Seen)
 154     (tick "\\Flagged" %Flagged)
 155     (reply "\\Answered" %Answered)
 156     (expire "gnus-expire")
 157     (dormant "gnus-dormant")
 158     (score "gnus-score")
 159     (save "gnus-save")
 160     (download "gnus-download")
 161     (forward "gnus-forward")))
 162
 163 (defvar nnimap-quirks
 164   '(("QRESYNC" "Zimbra" "QRESYNC ")
 165     ("MOVE" "Dovecot" nil)))
 166
 167 (defvar nnimap-inhibit-logging nil)
 168
 169 (defun nnimap-buffer ()
 170   (nnimap-find-process-buffer nntp-server-buffer))
 171
 172 (defun nnimap-header-parameters ()
 173   (let (params)
 174     (push "UID" params)
 175     (push "RFC822.SIZE" params)
 176     (when (nnimap-capability "X-GM-EXT-1")
 177       (push "X-GM-LABELS" params))
 178     (push "BODYSTRUCTURE" params)
 179     (push (format
 180            (if (nnimap-ver4-p)
 181                "BODY.PEEK[HEADER.FIELDS %s]"
 182              "RFC822.HEADER.LINES %s")
 183            (append '(Subject From Date Message-Id
 184                              References In-Reply-To Xref)
 185                    nnmail-extra-headers))
 186           params)
 187     (format "%s" (nreverse params))))
 188
 189 (deffoo nnimap-retrieve-headers (articles &optional group server _fetch-old)
 190   (when group
 191     (setq group (nnimap-decode-gnus-group group)))
 192   (with-current-buffer nntp-server-buffer
 193     (erase-buffer)
 194     (when (nnimap-change-group group server)
 195       (with-current-buffer (nnimap-buffer)
 196         (erase-buffer)
 197         (nnimap-wait-for-response
 198          (nnimap-send-command
 199           "UID FETCH %s %s"
 200           (nnimap-article-ranges (gnus-compress-sequence articles))
 201           (nnimap-header-parameters))
 202          t)
 203         (unless (process-live-p (get-buffer-process (current-buffer)))
 204           (error "Server closed connection"))
 205         (nnimap-transform-headers)
 206         (nnheader-remove-cr-followed-by-lf))
 207       (insert-buffer-substring
 208        (nnimap-find-process-buffer (current-buffer))))
 209     'headers))
 210
 211 (defun nnimap-transform-headers ()
 212   (goto-char (point-min))
 213   (let (article lines size string labels)
 214     (block nil
 215       (while (not (eobp))
 216         (while (not (looking-at "\\* [0-9]+ FETCH"))
 217           (delete-region (point) (progn (forward-line 1) (point)))
 218           (when (eobp)
 219             (return)))
 220         (goto-char (match-end 0))
 221         ;; Unfold quoted {number} strings.
 222         (while (re-search-forward
 223                 "[^]][ (]{\\([0-9]+\\)}\r?\n"
 224                 (save-excursion
 225                   ;; Start of the header section.
 226                   (or (re-search-forward "] {[0-9]+}\r?\n" nil t)
 227                       ;; Start of the next FETCH.
 228                       (re-search-forward "\\* [0-9]+ FETCH" nil t)
 229                       (point-max)))
 230                 t)
 231           (setq size (string-to-number (match-string 1)))
 232           (delete-region (+ (match-beginning 0) 2) (point))
 233           (setq string (buffer-substring (point) (+ (point) size)))
 234           (delete-region (point) (+ (point) size))
 235           (insert (format "%S" (subst-char-in-string ?\n ?\s string))))
 236         (beginning-of-line)
 237         (setq article
 238               (and (re-search-forward "UID \\([0-9]+\\)" (line-end-position)
 239                                       t)
 240                    (match-string 1)))
 241         (setq lines nil)
 242         (beginning-of-line)
 243         (setq size
 244               (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)"
 245                                       (line-end-position)
 246                                       t)
 247                    (match-string 1)))
 248         (beginning-of-line)
 249         (when (search-forward "X-GM-LABELS" (line-end-position) t)
 250           (setq labels (ignore-errors (read (current-buffer)))))
 251         (beginning-of-line)
 252         (when (search-forward "BODYSTRUCTURE" (line-end-position) t)
 253           (let ((structure (ignore-errors
 254                              (read (current-buffer)))))
 255             (while (and (consp structure)
 256                         (not (atom (car structure))))
 257               (setq structure (car structure)))
 258             (setq lines (if (and
 259                              (stringp (car structure))
 260                              (equal (upcase (nth 0 structure)) "MESSAGE")
 261                              (equal (upcase (nth 1 structure)) "RFC822"))
 262                             (nth 9 structure)
 263                           (nth 7 structure)))))
 264         (delete-region (line-beginning-position) (line-end-position))
 265         (insert (format "211 %s Article retrieved." article))
 266         (forward-line 1)
 267         (when size
 268           (insert (format "Chars: %s\n" size)))
 269         (when lines
 270           (insert (format "Lines: %s\n" lines)))
 271         (when labels
 272           (insert (format "X-GM-LABELS: %s\n" labels)))
 273         ;; Most servers have a blank line after the headers, but
 274         ;; Davmail doesn't.
 275         (unless (re-search-forward "^\r$\\|^)\r?$" nil t)
 276           (goto-char (point-max)))
 277         (delete-region (line-beginning-position) (line-end-position))
 278         (insert ".")
 279         (forward-line 1)))))
 280
 281 (defun nnimap-unfold-quoted-lines ()
 282   ;; Unfold quoted {number} strings.
 283   (let (size string)
 284     (while (re-search-forward " {\\([0-9]+\\)}\r?\n" nil t)
 285       (setq size (string-to-number (match-string 1)))
 286       (delete-region (1+ (match-beginning 0)) (point))
 287       (setq string (buffer-substring (point) (+ (point) size)))
 288       (delete-region (point) (+ (point) size))
 289       (insert (format "%S" string)))))
 290
 291 (defun nnimap-get-length ()
 292   (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t)
 293        (string-to-number (match-string 1))))
 294
 295 (defun nnimap-article-ranges (ranges)
 296   (let (result)
 297     (cond
 298      ((numberp ranges)
 299       (number-to-string ranges))
 300      ((numberp (cdr ranges))
 301       (format "%d:%d" (car ranges) (cdr ranges)))
 302      (t
 303       (dolist (elem ranges)
 304         (push
 305          (if (consp elem)
 306              (format "%d:%d" (car elem) (cdr elem))
 307            (number-to-string elem))
 308          result))
 309       (mapconcat #'identity (nreverse result) ",")))))
 310
 311 (deffoo nnimap-open-server (server &optional defs no-reconnect)
 312   (if (nnimap-server-opened server)
 313       t
 314     (unless (assq 'nnimap-address defs)
 315       (setq defs (append defs (list (list 'nnimap-address server)))))
 316     (nnoo-change-server 'nnimap server defs)
 317     (if no-reconnect
 318         (nnimap-find-connection nntp-server-buffer)
 319       (or (nnimap-find-connection nntp-server-buffer)
 320           (nnimap-open-connection nntp-server-buffer)))))
 321
 322 (defun nnimap-make-process-buffer (buffer)
 323   (with-current-buffer
 324       (generate-new-buffer (format " *nnimap %s %s %s*"
 325                                    nnimap-address nnimap-server-port
 326                                    (gnus-buffer-exists-p buffer)))
 327     (mm-disable-multibyte)
 328     (buffer-disable-undo)
 329     (gnus-add-buffer)
 330     (set (make-local-variable 'after-change-functions) nil)
 331     (set (make-local-variable 'nnimap-object)
 332          (make-nnimap :server (nnoo-current-server 'nnimap)
 333                       :initial-resync 0))
 334     (push (list buffer (current-buffer)) nnimap-connection-alist)
 335     (push (current-buffer) nnimap-process-buffers)
 336     (current-buffer)))
 337
 338 (defvar auth-source-creation-prompts)
 339
 340 (defun nnimap-credentials (address ports user)
 341   (let* ((auth-source-creation-prompts
 342           '((user  . "IMAP user at %h: ")
 343             (secret . "IMAP password for %u@%h: ")))
 344          (found (nth 0 (auth-source-search :max 1
 345                                            :host address
 346                                            :port ports
 347                                            :user user
 348                                            :require '(:user :secret)
 349                                            :create t))))
 350     (if found
 351         (list (plist-get found :user)
 352               (let ((secret (plist-get found :secret)))
 353                 (if (functionp secret)
 354                     (funcall secret)
 355                   secret))
 356               (plist-get found :save-function))
 357       nil)))
 358
 359 (defun nnimap-keepalive ()
 360   (let ((now (current-time)))
 361     (dolist (buffer nnimap-process-buffers)
 362       (when (buffer-name buffer)
 363         (with-current-buffer buffer
 364           (when (and nnimap-object
 365                      (nnimap-last-command-time nnimap-object)
 366                      (> (float-time
 367                          (time-subtract
 368                           now
 369                           (nnimap-last-command-time nnimap-object)))
 370                         ;; More than five minutes since the last command.
 371                         (* 5 60)))
 372             (ignore-errors              ;E.g. "buffer foo has no process".
 373               (nnimap-send-command "NOOP"))))))))
 374
 375 (defun nnimap-open-connection (buffer)
 376   ;; Be backwards-compatible -- the earlier value of nnimap-stream was
 377   ;; `ssl' when nnimap-server-port was nil.  Sort of.
 378   (when (and nnimap-server-port
 379              (eq nnimap-stream 'undecided))
 380     (setq nnimap-stream 'ssl))
 381   (let ((stream
 382          (if (eq nnimap-stream 'undecided)
 383              (loop for type in '(ssl network)
 384                    for stream = (let ((nnimap-stream type))
 385                                   (nnimap-open-connection-1 buffer))
 386                    while (eq stream 'no-connect)
 387                    finally (return stream))
 388            (nnimap-open-connection-1 buffer))))
 389     (if (eq stream 'no-connect)
 390         nil
 391       stream)))
 392
 393 (defun nnimap-map-port (port)
 394   (if (equal port "imaps")
 395       "993"
 396     port))
 397
 398 (defun nnimap-open-connection-1 (buffer)
 399   (unless nnimap-keepalive-timer
 400     (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15)
 401                                               #'nnimap-keepalive)))
 402   (with-current-buffer (nnimap-make-process-buffer buffer)
 403     (let* ((coding-system-for-read 'binary)
 404            (coding-system-for-write 'binary)
 405            (ports
 406             (cond
 407              ((memq nnimap-stream '(network plain starttls))
 408               (nnheader-message 7 "Opening connection to %s..."
 409                                 nnimap-address)
 410               '("imap" "143"))
 411              ((eq nnimap-stream 'shell)
 412               (nnheader-message 7 "Opening connection to %s via shell..."
 413                                 nnimap-address)
 414               '("imap"))
 415              ((memq nnimap-stream '(ssl tls))
 416               (nnheader-message 7 "Opening connection to %s via tls..."
 417                                 nnimap-address)
 418               '("imaps" "imap" "993" "143"))
 419              (t
 420               (error "Unknown stream type: %s" nnimap-stream))))
 421            login-result credentials)
 422       (when nnimap-server-port
 423         (push nnimap-server-port ports))
 424       (let* ((stream-list
 425               (open-network-stream
 426                "*nnimap*" (current-buffer) nnimap-address
 427                (nnimap-map-port (car ports))
 428                :type nnimap-stream
 429                :warn-unless-encrypted t
 430                :return-list t
 431                :shell-command nnimap-shell-program
 432                :capability-command "1 CAPABILITY\r\n"
 433                :always-query-capabilities t
 434                :end-of-command "\r\n"
 435                :success " OK "
 436                :starttls-function
 437                (lambda (capabilities)
 438                  (when (string-match-p "STARTTLS" capabilities)
 439                    "1 STARTTLS\r\n"))))
 440              (stream (car stream-list))
 441              (props (cdr stream-list))
 442              (greeting (plist-get props :greeting))
 443              (capabilities (plist-get props :capabilities))
 444              (stream-type (plist-get props :type)))
 445         (when (and stream (not (memq (process-status stream) '(open run))))
 446           (setq stream nil))
 447
 448         (when (eq (process-type stream) 'network)
 449           ;; Use TCP-keepalive so that connections that pass through a NAT
 450           ;; router don't hang when left idle.
 451           (set-network-process-option stream :keepalive t))
 452
 453         (setf (nnimap-process nnimap-object) stream)
 454         (setf (nnimap-stream-type nnimap-object) stream-type)
 455         (if (not stream)
 456             (progn
 457               (nnheader-report 'nnimap "Unable to contact %s:%s via %s"
 458                                nnimap-address (car ports) nnimap-stream)
 459               'no-connect)
 460           (set-process-query-on-exit-flag stream nil)
 461           (if (not (string-match-p "[*.] \\(OK\\|PREAUTH\\)" greeting))
 462               (nnheader-report 'nnimap "%s" greeting)
 463             ;; Store the greeting (for debugging purposes).
 464             (setf (nnimap-greeting nnimap-object) greeting)
 465             (setf (nnimap-capabilities nnimap-object)
 466                   (mapcar #'upcase
 467                           (split-string capabilities)))
 468             (unless (string-match-p "[*.] PREAUTH" greeting)
 469               (if (not (setq credentials
 470                              (if (eq nnimap-authenticator 'anonymous)
 471                                  (list "anonymous"
 472                                        (message-make-address))
 473                                ;; Look for the credentials based on
 474                                ;; the virtual server name and the address
 475                                (nnimap-credentials
 476                                 (gnus-delete-duplicates
 477                                  (list
 478                                   (nnoo-current-server 'nnimap)
 479                                   nnimap-address))
 480                                 ports
 481                                 nnimap-user))))
 482                   (setq nnimap-object nil)
 483                 (let ((nnimap-inhibit-logging t))
 484                   (setq login-result
 485                         (nnimap-login (car credentials) (cadr credentials))))
 486                 (if (car login-result)
 487                     (progn
 488                       ;; Save the credentials if a save function exists
 489                       ;; (such a function will only be passed if a new
 490                       ;; token was created).
 491                       (when (functionp (nth 2 credentials))
 492                         (funcall (nth 2 credentials)))
 493                       ;; See if CAPABILITY is set as part of login
 494                       ;; response.
 495                       (dolist (response (cddr (nnimap-command "CAPABILITY")))
 496                         (when (string= "CAPABILITY" (upcase (car response)))
 497                           (setf (nnimap-capabilities nnimap-object)
 498                                 (mapcar #'upcase (cdr response))))))
 499                   ;; If the login failed, then forget the credentials
 500                   ;; that are now possibly cached.
 501                   (dolist (host (list (nnoo-current-server 'nnimap)
 502                                       nnimap-address))
 503                     (dolist (port ports)
 504                       (auth-source-forget+ :host host :port port)))
 505                   (delete-process (nnimap-process nnimap-object))
 506                   (setq nnimap-object nil))))
 507             (when nnimap-object
 508               (when (nnimap-capability "QRESYNC")
 509                 (nnimap-command "ENABLE QRESYNC"))
 510               (nnheader-message 7 "Opening connection to %s...done"
 511                                 nnimap-address)
 512               (nnimap-process nnimap-object))))))))
 513
 514 (autoload 'rfc2104-hash "rfc2104")
 515
 516 (defun nnimap-login (user password)
 517   (cond
 518    ;; Prefer plain LOGIN if it's enabled (since it requires fewer
 519    ;; round trips than CRAM-MD5, and it's less likely to be buggy),
 520    ;; and we're using an encrypted connection.
 521    ((and (not (nnimap-capability "LOGINDISABLED"))
 522          (eq (nnimap-stream-type nnimap-object) 'tls)
 523          (or (null nnimap-authenticator)
 524              (eq nnimap-authenticator 'login)))
 525     (nnimap-command "LOGIN %S %S" user password))
 526    ((and (nnimap-capability "AUTH=CRAM-MD5")
 527          (or (null nnimap-authenticator)
 528              (eq nnimap-authenticator 'cram-md5)))
 529     (erase-buffer)
 530     (let ((sequence (nnimap-send-command "AUTHENTICATE CRAM-MD5"))
 531           (challenge (nnimap-wait-for-line "^\\+\\(.*\\)\n")))
 532       (process-send-string
 533        (get-buffer-process (current-buffer))
 534        (concat
 535         (base64-encode-string
 536          (concat user " "
 537                  (rfc2104-hash 'md5 64 16 password
 538                                (base64-decode-string challenge))))
 539         "\r\n"))
 540       (nnimap-wait-for-response sequence)))
 541    ((and (not (nnimap-capability "LOGINDISABLED"))
 542          (or (null nnimap-authenticator)
 543              (eq nnimap-authenticator 'login)))
 544     (nnimap-command "LOGIN %S %S" user password))
 545    ((and (nnimap-capability "AUTH=PLAIN")
 546          (or (null nnimap-authenticator)
 547              (eq nnimap-authenticator 'plain)))
 548     (nnimap-command
 549      "AUTHENTICATE PLAIN %s"
 550      (base64-encode-string
 551       (format "\000%s\000%s"
 552               (nnimap-quote-specials user)
 553               (nnimap-quote-specials password)))))))
 554
 555 (defun nnimap-quote-specials (string)
 556   (with-temp-buffer
 557     (insert string)
 558     (goto-char (point-min))
 559     (while (re-search-forward "[\\\"]" nil t)
 560       (forward-char -1)
 561       (insert "\\")
 562       (forward-char 1))
 563     (buffer-string)))
 564
 565 (defun nnimap-find-parameter (parameter elems)
 566   (let (result)
 567     (dolist (elem elems)
 568       (cond
 569        ((equal (car elem) parameter)
 570         (setq result (cdr elem)))
 571        ((and (equal (car elem) "OK")
 572              (consp (cadr elem))
 573              (equal (caadr elem) parameter))
 574         (setq result (cdr (cadr elem))))))
 575     result))
 576
 577 (deffoo nnimap-close-server (&optional server)
 578   (when (nnoo-change-server 'nnimap server nil)
 579     (ignore-errors
 580       (delete-process (get-buffer-process (nnimap-buffer))))
 581     (nnoo-close-server 'nnimap server)
 582     t))
 583
 584 (deffoo nnimap-request-close ()
 585   t)
 586
 587 (deffoo nnimap-server-opened (&optional server)
 588   (and (nnoo-current-server-p 'nnimap server)
 589        nntp-server-buffer
 590        (gnus-buffer-live-p nntp-server-buffer)
 591        (nnimap-find-connection nntp-server-buffer)))
 592
 593 (deffoo nnimap-status-message (&optional _server)
 594   nnimap-status-string)
 595
 596 (deffoo nnimap-request-article (article &optional group server to-buffer)
 597   (when group
 598     (setq group (nnimap-decode-gnus-group group)))
 599   (with-current-buffer nntp-server-buffer
 600     (let ((result (nnimap-change-group group server))
 601           parts structure)
 602       (when (stringp article)
 603         (setq article (nnimap-find-article-by-message-id group server article)))
 604       (when (and result
 605                  article)
 606         (erase-buffer)
 607         (with-current-buffer (nnimap-buffer)
 608           (erase-buffer)
 609           (when nnimap-fetch-partial-articles
 610             (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article)
 611             (goto-char (point-min))
 612             (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t)
 613               (setq structure (ignore-errors
 614                                 (let ((start (point)))
 615                                   (forward-sexp 1)
 616                                   (downcase-region start (point))
 617                                   (goto-char start)
 618                                   (read (current-buffer))))
 619                     parts (nnimap-find-wanted-parts structure))))
 620           (when (if parts
 621                     (nnimap-get-partial-article article parts structure)
 622                   (nnimap-get-whole-article article))
 623             (let ((buffer (current-buffer)))
 624               (with-current-buffer (or to-buffer nntp-server-buffer)
 625                 (nnheader-insert-buffer-substring buffer)
 626                 (nnheader-ms-strip-cr)))
 627             (cons group article)))))))
 628
 629 (deffoo nnimap-request-head (article &optional group server to-buffer)
 630   (when group
 631     (setq group (nnimap-decode-gnus-group group)))
 632   (when (nnimap-change-group group server)
 633     (with-current-buffer (nnimap-buffer)
 634       (when (stringp article)
 635         (setq article (nnimap-find-article-by-message-id group server article)))
 636       (if (null article)
 637           nil
 638         (nnimap-get-whole-article
 639          article (format "UID FETCH %%d %s"
 640                          (nnimap-header-parameters)))
 641         (let ((buffer (current-buffer)))
 642           (with-current-buffer (or to-buffer nntp-server-buffer)
 643             (erase-buffer)
 644             (insert-buffer-substring buffer)
 645             (nnheader-ms-strip-cr)
 646             (cons group article)))))))
 647
 648 (deffoo nnimap-request-articles (articles &optional group server)
 649   (when group
 650     (setq group (nnimap-decode-gnus-group group)))
 651   (with-current-buffer nntp-server-buffer
 652     (let ((result (nnimap-change-group group server)))
 653       (when result
 654         (erase-buffer)
 655         (with-current-buffer (nnimap-buffer)
 656           (erase-buffer)
 657           (when (nnimap-command
 658                  (if (nnimap-ver4-p)
 659                      "UID FETCH %s BODY.PEEK[]"
 660                    "UID FETCH %s RFC822.PEEK")
 661                  (nnimap-article-ranges (gnus-compress-sequence articles)))
 662             (let ((buffer (current-buffer)))
 663               (with-current-buffer nntp-server-buffer
 664                 (nnheader-insert-buffer-substring buffer)
 665                 (nnheader-ms-strip-cr)))
 666             t))))))
 667
 668 (defun nnimap-get-whole-article (article &optional command)
 669   (let ((result
 670          (nnimap-command
 671           (or command
 672               (if (nnimap-ver4-p)
 673                   "UID FETCH %d BODY.PEEK[]"
 674                 "UID FETCH %d RFC822.PEEK"))
 675           article)))
 676     ;; Check that we really got an article.
 677     (goto-char (point-min))
 678     (unless (re-search-forward "\\* [0-9]+ FETCH" nil t)
 679       (setq result nil))
 680     (when result
 681       ;; Remove any data that may have arrived before the FETCH data.
 682       (beginning-of-line)
 683       (unless (bobp)
 684         (delete-region (point-min) (point)))
 685       (let ((bytes (nnimap-get-length)))
 686         (delete-region (line-beginning-position)
 687                        (progn (forward-line 1) (point)))
 688         (goto-char (+ (point) bytes))
 689         (delete-region (point) (point-max)))
 690       t)))
 691
 692 (defun nnimap-capability (capability)
 693   (member capability (nnimap-capabilities nnimap-object)))
 694
 695 (defun nnimap-ver4-p ()
 696   (nnimap-capability "IMAP4REV1"))
 697
 698 (defun nnimap-get-partial-article (article parts structure)
 699   (let ((result
 700          (nnimap-command
 701           "UID FETCH %d (%s %s)"
 702           article
 703           (if (nnimap-ver4-p)
 704               "BODY.PEEK[HEADER]"
 705             "RFC822.HEADER")
 706           (if (nnimap-ver4-p)
 707               (mapconcat (lambda (part)
 708                            (format "BODY.PEEK[%s]" part))
 709                          parts " ")
 710             (mapconcat (lambda (part)
 711                          (format "RFC822.PEEK[%s]" part))
 712                        parts " ")))))
 713     (when result
 714       (nnimap-convert-partial-article structure))))
 715
 716 (defun nnimap-convert-partial-article (structure)
 717   ;; First just skip past the headers.
 718   (goto-char (point-min))
 719   (let ((bytes (nnimap-get-length))
 720         id parts)
 721     ;; Delete "FETCH" line.
 722     (delete-region (line-beginning-position)
 723                    (progn (forward-line 1) (point)))
 724     (goto-char (+ (point) bytes))
 725     ;; Collect all the body parts.
 726     (while (looking-at ".*BODY\\[\\([.0-9]+\\)\\]")
 727       (setq id (match-string 1)
 728             bytes (or (nnimap-get-length) 0))
 729       (beginning-of-line)
 730       (delete-region (point) (progn (forward-line 1) (point)))
 731       (push (list id (buffer-substring (point) (+ (point) bytes)))
 732             parts)
 733       (delete-region (point) (+ (point) bytes)))
 734     ;; Delete trailing junk.
 735     (delete-region (point) (point-max))
 736     ;; Now insert all the parts again where they fit in the structure.
 737     (nnimap-insert-partial-structure structure parts)
 738     t))
 739
 740 (defun nnimap-insert-partial-structure (structure parts &optional subp)
 741   (let (type boundary)
 742     (let ((bstruc structure))
 743       (while (consp (car bstruc))
 744         (pop bstruc))
 745       (setq type (car bstruc))
 746       (setq bstruc (car (cdr bstruc)))
 747       (let ((has-boundary (member "boundary" bstruc)))
 748         (when has-boundary
 749           (setq boundary (cadr has-boundary)))))
 750     (when subp
 751       (insert (format "Content-type: multipart/%s; boundary=%S\n\n"
 752                       (downcase type) boundary)))
 753     (while (not (stringp (car structure)))
 754       (insert "\n--" boundary "\n")
 755       (if (consp (caar structure))
 756           (nnimap-insert-partial-structure (pop structure) parts t)
 757         (let ((bit (pop structure)))
 758           (insert (format "Content-type: %s/%s"
 759                           (downcase (nth 0 bit))
 760                           (downcase (nth 1 bit))))
 761           (if (member-ignore-case "CHARSET" (nth 2 bit))
 762               (insert (format
 763                        "; charset=%S\n"
 764                        (cadr (member-ignore-case "CHARSET" (nth 2 bit)))))
 765             (insert "\n"))
 766           (insert (format "Content-transfer-encoding: %s\n"
 767                           (nth 5 bit)))
 768           (insert "\n")
 769           (when (assoc (nth 9 bit) parts)
 770             (insert (cadr (assoc (nth 9 bit) parts)))))))
 771     (insert "\n--" boundary "--\n")))
 772
 773 (defun nnimap-find-wanted-parts (structure)
 774   (message-flatten-list (nnimap-find-wanted-parts-1 structure "")))
 775
 776 (defun nnimap-find-wanted-parts-1 (structure prefix)
 777   (let ((num 1)
 778         parts)
 779     (while (consp (car structure))
 780       (let ((sub (pop structure)))
 781         (if (consp (car sub))
 782             (push (nnimap-find-wanted-parts-1
 783                    sub (if (string= prefix "")
 784                            (number-to-string num)
 785                          (format "%s.%s" prefix num)))
 786                   parts)
 787           (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub)))
 788                 (id (if (string= prefix "")
 789                         (number-to-string num)
 790                       (format "%s.%s" prefix num))))
 791             (setcar (nthcdr 9 sub) id)
 792             (when (if (eq nnimap-fetch-partial-articles t)
 793                       (equal id "1")
 794                     (string-match nnimap-fetch-partial-articles type))
 795               (push id parts))))
 796         (incf num)))
 797     (nreverse parts)))
 798
 799 (deffoo nnimap-request-group (group &optional server dont-check info)
 800   (setq group (nnimap-decode-gnus-group group))
 801   (let ((result (nnimap-change-group
 802                  ;; Don't SELECT the group if we're going to select it
 803                  ;; later, anyway.
 804                  (if (and (not dont-check)
 805                           (assoc group nnimap-current-infos))
 806                      nil
 807                    group)
 808                  server))
 809         (info (when info (list info)))
 810         active)
 811     (with-current-buffer nntp-server-buffer
 812       (when result
 813         (when (or (not dont-check)
 814                   (not (setq active
 815                              (nth 2 (assoc group nnimap-current-infos)))))
 816           (let ((sequences (nnimap-retrieve-group-data-early
 817                             server info)))
 818             (nnimap-finish-retrieve-group-infos server info sequences
 819                                                 t)
 820             (setq active (nth 2 (assoc group nnimap-current-infos)))))
 821         (setq active (or active '(0 . 1)))
 822         (erase-buffer)
 823         (insert (format "211 %d %d %d %S\n"
 824                         (- (cdr active) (car active))
 825                         (car active)
 826                         (cdr active)
 827                         (nnimap-encode-gnus-group group)))
 828         t))))
 829
 830 (deffoo nnimap-request-group-scan (group &optional server info)
 831   (setq group (nnimap-decode-gnus-group group))
 832   (when (nnimap-change-group nil server)
 833     (let (marks high low)
 834       (with-current-buffer (nnimap-buffer)
 835         (erase-buffer)
 836         (let ((group-sequence
 837                (nnimap-send-command "SELECT %S" (utf7-encode group t)))
 838               (flag-sequence
 839                (nnimap-send-command "UID FETCH 1:* FLAGS")))
 840           (setf (nnimap-group nnimap-object) group)
 841           (nnimap-wait-for-response flag-sequence)
 842           (setq marks
 843                 (nnimap-flags-to-marks
 844                  (nnimap-parse-flags
 845                   (list (list group-sequence flag-sequence
 846                               1 group "SELECT")))))
 847           (when (and info
 848                      marks)
 849             (nnimap-update-infos marks (list info))
 850             (nnimap-store-info info (gnus-active (gnus-info-group info))))
 851           (goto-char (point-max))
 852           (let ((uidnext (nth 5 (car marks))))
 853             (setq high (or (if uidnext
 854                                (1- uidnext)
 855                              (nth 3 (car marks)))
 856                            0)
 857                   low (or (nth 4 (car marks)) uidnext 1)))))
 858       (with-current-buffer nntp-server-buffer
 859         (erase-buffer)
 860         (insert
 861          (format
 862           "211 %d %d %d %S\n" (1+ (- high low)) low high
 863           (nnimap-encode-gnus-group group)))
 864         t))))
 865
 866 (deffoo nnimap-request-create-group (group &optional server _args)
 867   (setq group (nnimap-decode-gnus-group group))
 868   (when (nnimap-change-group nil server)
 869     (with-current-buffer (nnimap-buffer)
 870       (car (nnimap-command "CREATE %S" (utf7-encode group t))))))
 871
 872 (deffoo nnimap-request-delete-group (group &optional _force server)
 873   (setq group (nnimap-decode-gnus-group group))
 874   (when (nnimap-change-group nil server)
 875     (with-current-buffer (nnimap-buffer)
 876       (car (nnimap-command "DELETE %S" (utf7-encode group t))))))
 877
 878 (deffoo nnimap-request-rename-group (group new-name &optional server)
 879   (setq group (nnimap-decode-gnus-group group))
 880   (when (nnimap-change-group nil server)
 881     (with-current-buffer (nnimap-buffer)
 882       (nnimap-unselect-group)
 883       (car (nnimap-command "RENAME %S %S"
 884                            (utf7-encode group t) (utf7-encode new-name t))))))
 885
 886 (defun nnimap-unselect-group ()
 887   ;; Make sure we don't have this group open read/write by asking
 888   ;; to examine a mailbox that doesn't exist.  This seems to be
 889   ;; the only way that allows us to reliably go back to unselected
 890   ;; state on Courier.
 891   (nnimap-command "EXAMINE DOES.NOT.EXIST"))
 892
 893 (deffoo nnimap-request-expunge-group (group &optional server)
 894   (setq group (nnimap-decode-gnus-group group))
 895   (when (nnimap-change-group group server)
 896     (with-current-buffer (nnimap-buffer)
 897       (car (nnimap-command "EXPUNGE")))))
 898
 899 (defun nnimap-get-flags (spec)
 900   (let ((articles nil)
 901         elems end)
 902     (with-current-buffer (nnimap-buffer)
 903       (erase-buffer)
 904       (nnimap-wait-for-response (nnimap-send-command
 905                                  "UID FETCH %s FLAGS" spec))
 906       (setq end (point))
 907       (subst-char-in-region (point-min) (point-max)
 908                             ?\\ ?% t)
 909       (goto-char (point-min))
 910       (while (search-forward " FETCH " end t)
 911         (setq elems (read (current-buffer)))
 912         (push (cons (cadr (memq 'UID elems))
 913                     (cadr (memq 'FLAGS elems)))
 914               articles)))
 915     (nreverse articles)))
 916
 917 (deffoo nnimap-close-group (_group &optional _server)
 918   t)
 919
 920 (deffoo nnimap-request-move-article (article group server accept-form
 921                                              &optional _last
 922                                              internal-move-group)
 923   (setq group (nnimap-decode-gnus-group group))
 924   (when internal-move-group
 925     (setq internal-move-group (nnimap-decode-gnus-group internal-move-group)))
 926   (with-temp-buffer
 927     (mm-disable-multibyte)
 928     (when (funcall (if internal-move-group
 929                        'nnimap-request-head
 930                      'nnimap-request-article)
 931                    article group server (current-buffer))
 932       ;; If the move is internal (on the same server), just do it the
 933       ;; easy way.
 934       (let ((message-id (message-field-value "message-id")))
 935         (if internal-move-group
 936             (with-current-buffer (nnimap-buffer)
 937               (let* ((can-move (and (nnimap-capability "MOVE")
 938                                     (equal (nnimap-quirk "MOVE") "MOVE")))
 939                      (command (if can-move
 940                                   "UID MOVE %d %S"
 941                                 "UID COPY %d %S"))
 942                      (result (nnimap-command
 943                               command article
 944                               (utf7-encode internal-move-group t))))
 945                 (when (and (car result) (not can-move))
 946                   (nnimap-delete-article article))
 947                 (cons internal-move-group
 948                       (or (nnimap-find-uid-response "COPYUID" (caddr result))
 949                           (nnimap-find-article-by-message-id
 950                            internal-move-group server message-id
 951                            nnimap-request-articles-find-limit)))))
 952           ;; Move the article to a different method.
 953           (when-let ((result (eval accept-form)))
 954             (nnimap-change-group group server)
 955             (nnimap-delete-article article)
 956             result))))))
 957
 958 (deffoo nnimap-request-expire-articles (articles group &optional server force)
 959   (setq group (nnimap-decode-gnus-group group))
 960   (cond
 961    ((null articles)
 962     nil)
 963    ((not (nnimap-change-group group server))
 964     articles)
 965    ((and force
 966          (eq nnmail-expiry-target 'delete))
 967     (unless (nnimap-delete-article (gnus-compress-sequence articles))
 968       (nnheader-message 7 "Article marked for deletion, but not expunged."))
 969     nil)
 970    (t
 971     (let ((deletable-articles
 972            (if (or force
 973                    (eq nnmail-expiry-wait 'immediate))
 974                articles
 975              (gnus-sorted-intersection
 976               articles
 977               (nnimap-find-expired-articles group)))))
 978       (if (null deletable-articles)
 979           articles
 980         (if (eq nnmail-expiry-target 'delete)
 981             (nnimap-delete-article (gnus-compress-sequence deletable-articles))
 982           (setq deletable-articles
 983                 (nnimap-process-expiry-targets
 984                  deletable-articles group server)))
 985         ;; Return the articles we didn't delete.
 986         (gnus-sorted-complement articles deletable-articles))))))
 987
 988 (defun nnimap-process-expiry-targets (articles group server)
 989   (let ((deleted-articles nil)
 990         (articles-to-delete nil))
 991     (cond
 992      ;; shortcut further processing if we're going to delete the articles
 993      ((eq nnmail-expiry-target 'delete)
 994       (setq articles-to-delete articles)
 995       t)
 996      ;; or just move them to another folder on the same IMAP server
 997      ((and (not (functionp nnmail-expiry-target))
 998            (gnus-server-equal (gnus-group-method nnmail-expiry-target)
 999                               (gnus-server-to-method
1000                                (format "nnimap:%s" server))))
1001       (and (nnimap-change-group group server)
1002            (with-current-buffer (nnimap-buffer)
1003              (nnheader-message 7 "Expiring articles from %s: %s" group articles)
1004              (let ((can-move (and (nnimap-capability "MOVE")
1005                                   (equal (nnimap-quirk "MOVE") "MOVE"))))
1006                (nnimap-command
1007                 (if can-move
1008                     "UID MOVE %s %S"
1009                   "UID COPY %s %S")
1010                 (nnimap-article-ranges (gnus-compress-sequence articles))
1011                 (utf7-encode (gnus-group-real-name nnmail-expiry-target) t))
1012                (set (if can-move 'deleted-articles 'articles-to-delete) articles))))
1013       t)
1014      (t
1015       (dolist (article articles)
1016         (let ((target nnmail-expiry-target))
1017           (with-temp-buffer
1018             (mm-disable-multibyte)
1019             (when (nnimap-request-article article group server (current-buffer))
1020               (when (functionp target)
1021                 (setq target (funcall target group)))
1022               (if (and target
1023                        (not (eq target 'delete)))
1024                   (if (or (gnus-request-group target t)
1025                           (gnus-request-create-group target))
1026                       (progn
1027                         (nnmail-expiry-target-group target group)
1028                         (nnheader-message 7 "Expiring article %s:%d to %s"
1029                                           group article target))
1030                     (setq target nil))
1031                 (nnheader-message 7 "Expiring article %s:%d" group article))
1032               (when target
1033                 (push article articles-to-delete))))))
1034       (setq articles-to-delete (nreverse articles-to-delete))))
1035     ;; Change back to the current group again.
1036     (nnimap-change-group group server)
1037     (when articles-to-delete
1038       (nnimap-delete-article (gnus-compress-sequence articles-to-delete))
1039       (setq deleted-articles articles-to-delete))
1040     deleted-articles))
1041
1042 (defun nnimap-find-expired-articles (group)
1043   (let ((cutoff (nnmail-expired-article-p group nil nil)))
1044     (when cutoff
1045       (with-current-buffer (nnimap-buffer)
1046         (let ((result
1047                (nnimap-command
1048                 "UID SEARCH SENTBEFORE %s"
1049                 (format-time-string
1050                  (format "%%d-%s-%%Y"
1051                          (upcase
1052                           (car (rassoc (nth 4 (decode-time cutoff))
1053                                        parse-time-months))))
1054                  cutoff))))
1055           (and (car result)
1056                (delete 0 (mapcar #'string-to-number
1057                                  (cdr (assoc "SEARCH" (cdr result)))))))))))
1058
1059 (defun nnimap-find-article-by-message-id (group server message-id
1060                                                 &optional limit)
1061   "Search for message with MESSAGE-ID in GROUP from SERVER.
1062 If LIMIT, first try to limit the search to the N last articles."
1063   (with-current-buffer (nnimap-buffer)
1064     (erase-buffer)
1065     (let* ((change-group-result (nnimap-change-group group server nil t))
1066            (number-of-article
1067             (and (listp change-group-result)
1068                  (catch 'found
1069                    (dolist (result (cdr change-group-result))
1070                      (when (equal "EXISTS" (cadr result))
1071                        (throw 'found (car result)))))))
1072            (sequence
1073             (nnimap-send-command
1074              "UID SEARCH%s HEADER Message-Id %S"
1075              (if (and limit number-of-article)
1076                  ;; The -1 is because IMAP message
1077                  ;; numbers are one-based rather than
1078                  ;; zero-based.
1079                  (format " %s:*" (- (string-to-number number-of-article)
1080                                     limit -1))
1081                "")
1082              message-id)))
1083       (when (nnimap-wait-for-response sequence)
1084         (let ((article (car (last (cdr (assoc "SEARCH"
1085                                               (nnimap-parse-response)))))))
1086           (if article
1087               (string-to-number article)
1088             (when (and limit number-of-article)
1089               (nnimap-find-article-by-message-id group server message-id))))))))
1090
1091 (defun nnimap-delete-article (articles)
1092   (with-current-buffer (nnimap-buffer)
1093     (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)"
1094                     (nnimap-article-ranges articles))
1095     (cond
1096      ((nnimap-capability "UIDPLUS")
1097       (nnimap-command "UID EXPUNGE %s"
1098                       (nnimap-article-ranges articles))
1099       t)
1100      (nnimap-expunge
1101       (nnimap-command "EXPUNGE")
1102       t)
1103      (t (gnus-message 7 (concat "nnimap: nnimap-expunge is not set and the "
1104                                 "server doesn't support UIDPLUS, so we won't "
1105                                 "delete this article now"))))))
1106
1107 (deffoo nnimap-request-scan (&optional group server)
1108   (when group
1109     (setq group (nnimap-decode-gnus-group group)))
1110   (when (and (nnimap-change-group nil server)
1111              nnimap-inbox
1112              nnimap-split-methods)
1113     (nnheader-message 7 "nnimap %s splitting mail..." server)
1114     (if (listp nnimap-inbox)
1115        (dolist (nnimap-inbox nnimap-inbox)
1116          (nnimap-split-incoming-mail))
1117       (nnimap-split-incoming-mail))
1118     (nnheader-message 7 "nnimap %s splitting mail...done" server)))
1119
1120 (defun nnimap-marks-to-flags (marks)
1121   (let (flags flag)
1122     (dolist (mark marks)
1123       (when (setq flag (cadr (assq mark nnimap-mark-alist)))
1124         (push flag flags)))
1125     flags))
1126
1127 (deffoo nnimap-request-update-group-status (group status &optional server)
1128   (setq group (nnimap-decode-gnus-group group))
1129   (when (nnimap-change-group nil server)
1130     (let ((command (assoc
1131                     status
1132                     '((subscribe "SUBSCRIBE")
1133                       (unsubscribe "UNSUBSCRIBE")))))
1134       (when command
1135         (with-current-buffer (nnimap-buffer)
1136           (nnimap-command "%s %S" (cadr command) (utf7-encode group t)))))))
1137
1138 (deffoo nnimap-request-set-mark (group actions &optional server)
1139   (setq group (nnimap-decode-gnus-group group))
1140   (when (nnimap-change-group group server)
1141     (let (sequence)
1142       (with-current-buffer (nnimap-buffer)
1143         (erase-buffer)
1144         ;; Just send all the STORE commands without waiting for
1145         ;; response.  If they're successful, they're successful.
1146         (dolist (action actions)
1147           (destructuring-bind (range action marks) action
1148             (let ((flags (nnimap-marks-to-flags marks)))
1149               (when flags
1150                 (setq sequence (nnimap-send-command
1151                                 "UID STORE %s %sFLAGS.SILENT (%s)"
1152                                 (nnimap-article-ranges range)
1153                                 (cond
1154                                  ((eq action 'del) "-")
1155                                  ((eq action 'add) "+")
1156                                  ((eq action 'set) ""))
1157                                 (mapconcat #'identity flags " ")))))))
1158         ;; Wait for the last command to complete to avoid later
1159         ;; synchronization problems with the stream.
1160         (when sequence
1161           (nnimap-wait-for-response sequence))))))
1162
1163 (deffoo nnimap-request-accept-article (group &optional server _last)
1164   (unless group
1165     ;; We're respooling.  Find out where mail splitting would place
1166     ;; this article.
1167     (setq group
1168           (caar
1169            (nnmail-article-group
1170             ;; We don't really care about the article number, because
1171             ;; that's determined by the IMAP server later.  So just
1172             ;; return the group name.
1173             `(lambda (group)
1174                (list (list group)))))))
1175   (setq group (nnimap-decode-gnus-group group))
1176   (when (nnimap-change-group nil server)
1177     (nnmail-check-syntax)
1178     (let ((message-id (message-field-value "message-id"))
1179           sequence message)
1180       (nnimap-add-cr)
1181       (setq message (buffer-substring-no-properties (point-min) (point-max)))
1182       (with-current-buffer (nnimap-buffer)
1183         (when (setq message (or (nnimap-process-quirk "OK Gimap " 'append message)
1184                                 message))
1185           ;; If we have this group open read-only, then unselect it
1186           ;; before appending to it.
1187           (when (equal (nnimap-examined nnimap-object) group)
1188             (nnimap-unselect-group))
1189           (erase-buffer)
1190           (setq sequence (nnimap-send-command
1191                           "APPEND %S {%d}" (utf7-encode group t)
1192                           (length message)))
1193           (unless nnimap-streaming
1194             (nnimap-wait-for-connection "^[+]"))
1195           (process-send-string (get-buffer-process (current-buffer)) message)
1196           (process-send-string (get-buffer-process (current-buffer))
1197                                (if (nnimap-newlinep nnimap-object)
1198                                    "\n"
1199                                  "\r\n"))
1200           (let ((result (nnimap-get-response sequence)))
1201             (if (not (nnimap-ok-p result))
1202                 (progn
1203                   (nnheader-report 'nnimap "%s" result)
1204                   nil)
1205               (cons group
1206                     (or (nnimap-find-uid-response "APPENDUID" (car result))
1207                         (nnimap-find-article-by-message-id
1208                          group server message-id
1209                          nnimap-request-articles-find-limit))))))))))
1210
1211 (defun nnimap-process-quirk (greeting-match type data)
1212   (when (and (nnimap-greeting nnimap-object)
1213              (string-match greeting-match (nnimap-greeting nnimap-object))
1214              (eq type 'append)
1215              (string-match "\000" data))
1216     (let ((choice (gnus-multiple-choice
1217                    "Message contains NUL characters.  Delete, continue, abort? "
1218                    '((?d "Delete NUL characters")
1219                      (?c "Try to APPEND the message as is")
1220                      (?a "Abort")))))
1221       (cond
1222        ((eq choice ?a)
1223         (nnheader-report 'nnimap "Aborted APPEND due to NUL characters"))
1224        ((eq choice ?c)
1225         data)
1226        (t
1227         (with-temp-buffer
1228           (insert data)
1229           (goto-char (point-min))
1230           (while (search-forward "\000" nil t)
1231             (replace-match "" t t))
1232           (buffer-string)))))))
1233
1234 (defun nnimap-ok-p (value)
1235   (and (consp value)
1236        (consp (car value))
1237        (equal (caar value) "OK")))
1238
1239 (defun nnimap-find-uid-response (name list)
1240   (let ((result (car (last (nnimap-find-response-element name list)))))
1241     (and result
1242          (string-to-number result))))
1243
1244 (defun nnimap-find-response-element (name list)
1245   (let (result)
1246     (dolist (elem list)
1247       (when (and (consp elem)
1248                  (equal name (car elem)))
1249         (setq result elem)))
1250     result))
1251
1252 (deffoo nnimap-request-replace-article (article group buffer)
1253   (setq group (nnimap-decode-gnus-group group))
1254   (let (group-art)
1255     (when (and (nnimap-change-group group)
1256                ;; Put the article into the group.
1257                (with-current-buffer buffer
1258                  (setq group-art
1259                        (nnimap-request-accept-article group nil t))))
1260       (nnimap-delete-article (list article))
1261       ;; Return the new article number.
1262       (cdr group-art))))
1263
1264 (defun nnimap-add-cr ()
1265   (goto-char (point-min))
1266   (while (re-search-forward "\r?\n" nil t)
1267     (replace-match "\r\n" t t)))
1268
1269 (defun nnimap-get-groups ()
1270   (erase-buffer)
1271   (let ((sequence (nnimap-send-command "LIST \"\" \"*\""))
1272         groups)
1273     (nnimap-wait-for-response sequence)
1274     (subst-char-in-region (point-min) (point-max)
1275                           ?\\ ?% t)
1276     (goto-char (point-min))
1277     (nnimap-unfold-quoted-lines)
1278     (goto-char (point-min))
1279     (while (search-forward "* LIST " nil t)
1280       (let ((flags (read (current-buffer)))
1281             (_separator (read (current-buffer)))
1282             (group (buffer-substring-no-properties
1283                     (progn (skip-chars-forward " \"")
1284                            (point))
1285                     (progn (end-of-line)
1286                            (skip-chars-backward " \r\"")
1287                            (point)))))
1288         (unless (member '%NoSelect flags)
1289           (push (utf7-decode (if (stringp group)
1290                                  group
1291                                (format "%s" group))
1292                              t)
1293                 groups))))
1294     (nreverse groups)))
1295
1296 (defun nnimap-get-responses (sequences)
1297   (let (responses)
1298     (dolist (sequence sequences)
1299       (goto-char (point-min))
1300       (when (re-search-forward (format "^%d " sequence) nil t)
1301         (push (list sequence (nnimap-parse-response))
1302               responses)))
1303     responses))
1304
1305 (deffoo nnimap-request-list (&optional server)
1306   (when (nnimap-change-group nil server)
1307     (with-current-buffer nntp-server-buffer
1308       (erase-buffer)
1309       (let ((groups
1310              (with-current-buffer (nnimap-buffer)
1311                (nnimap-get-groups)))
1312             sequences responses)
1313         (when groups
1314           (with-current-buffer (nnimap-buffer)
1315             (setf (nnimap-group nnimap-object) nil)
1316             (dolist (group groups)
1317               (setf (nnimap-examined nnimap-object) group)
1318               (push (list (nnimap-send-command "EXAMINE %S"
1319                                                (utf7-encode group t))
1320                           group)
1321                     sequences))
1322             (nnimap-wait-for-response (caar sequences))
1323             (setq responses
1324                   (nnimap-get-responses (mapcar #'car sequences))))
1325           (dolist (response responses)
1326             (let* ((sequence (car response))
1327                    (response (cadr response))
1328                    (group (cadr (assoc sequence sequences)))
1329                    (egroup (nnimap-encode-gnus-group group)))
1330               (when (and group
1331                          (equal (caar response) "OK"))
1332                 (let ((uidnext (nnimap-find-parameter "UIDNEXT" response))
1333                       highest exists)
1334                   (dolist (elem response)
1335                     (when (equal (cadr elem) "EXISTS")
1336                       (setq exists (string-to-number (car elem)))))
1337                   (when uidnext
1338                     (setq highest (1- (string-to-number (car uidnext)))))
1339                   (cond
1340                    ((null highest)
1341                     (insert (format "%S 0 1 y\n" egroup)))
1342                    ((zerop exists)
1343                     ;; Empty group.
1344                     (insert (format "%S %d %d y\n" egroup
1345                                     highest (1+ highest))))
1346                    (t
1347                     ;; Return the widest possible range.
1348                     (insert (format "%S %d 1 y\n" egroup
1349                                     (or highest exists)))))))))
1350           t)))))
1351
1352 (deffoo nnimap-request-newgroups (_date &optional server)
1353   (when (nnimap-change-group nil server)
1354     (with-current-buffer nntp-server-buffer
1355       (erase-buffer)
1356       (dolist (group (with-current-buffer (nnimap-buffer)
1357                        (nnimap-get-groups)))
1358         (unless (assoc group nnimap-current-infos)
1359           ;; Insert dummy numbers here -- they don't matter.
1360           (insert (format "%S 0 1 y\n" (nnimap-encode-gnus-group group)))))
1361       t)))
1362
1363 (deffoo nnimap-retrieve-group-data-early (server infos)
1364   (when (and (nnimap-change-group nil server)
1365              infos)
1366     (with-current-buffer (nnimap-buffer)
1367       (erase-buffer)
1368       (setf (nnimap-group nnimap-object) nil)
1369       (setf (nnimap-initial-resync nnimap-object) 0)
1370       (let ((qresyncp (nnimap-capability "QRESYNC"))
1371             params sequences active uidvalidity modseq group
1372             unexist)
1373         ;; Go through the infos and gather the data needed to know
1374         ;; what and how to request the data.
1375         (dolist (info infos)
1376           (setq params (gnus-info-params info)
1377                 group (nnimap-decode-gnus-group
1378                        (gnus-group-real-name (gnus-info-group info)))
1379                 active (cdr (assq 'active params))
1380                 unexist (assq 'unexist (gnus-info-marks info))
1381                 uidvalidity (cdr (assq 'uidvalidity params))
1382                 modseq (cdr (assq 'modseq params)))
1383           (setf (nnimap-examined nnimap-object) group)
1384           (if (and qresyncp
1385                    uidvalidity
1386                    active
1387                    modseq
1388                    unexist)
1389               (push
1390                (list (nnimap-send-command "EXAMINE %S (%s (%s %s))"
1391                                           (utf7-encode group t)
1392                                           (nnimap-quirk "QRESYNC")
1393                                           uidvalidity modseq)
1394                      'qresync
1395                      nil group 'qresync)
1396                sequences)
1397             (let ((command
1398                    (if uidvalidity
1399                        "EXAMINE"
1400                      ;; If we don't have a UIDVALIDITY, then this is
1401                      ;; the first time we've seen the group, so we
1402                      ;; have to do a SELECT (which is slower than an
1403                      ;; examine), but will tell us whether the group
1404                      ;; is read-only or not.
1405                      "SELECT"))
1406                   start)
1407               (if (and active uidvalidity unexist)
1408                   ;; Fetch the last 100 flags.
1409                   (setq start (max 1 (- (cdr active) 100)))
1410                 (incf (nnimap-initial-resync nnimap-object))
1411                 (setq start 1))
1412               (push (list (nnimap-send-command "%s %S" command
1413                                                (utf7-encode group t))
1414                           (nnimap-send-command "UID FETCH %d:* FLAGS" start)
1415                           start group command)
1416                     sequences))))
1417         sequences))))
1418
1419 (defun nnimap-quirk (command)
1420   (let ((quirk (assoc command nnimap-quirks)))
1421     ;; If this server is of a type that matches a quirk, then return
1422     ;; the "quirked" command instead of the proper one.
1423     (if (or (null quirk)
1424             (not (string-match (nth 1 quirk) (nnimap-greeting nnimap-object))))
1425         command
1426       (nth 2 quirk))))
1427
1428 (deffoo nnimap-finish-retrieve-group-infos (server infos sequences
1429                                                    &optional dont-insert)
1430   (when (and sequences
1431              (nnimap-change-group nil server t)
1432              ;; Check that the process is still alive.
1433              (get-buffer-process (nnimap-buffer))
1434              (memq (process-status (get-buffer-process (nnimap-buffer)))
1435                    '(open run)))
1436     (with-current-buffer (nnimap-buffer)
1437       ;; Wait for the final data to trickle in.
1438       (when (nnimap-wait-for-response (if (eq (cadar sequences) 'qresync)
1439                                           (caar sequences)
1440                                         (cadar sequences))
1441                                       t)
1442         ;; Now we should have most of the data we need, no matter
1443         ;; whether we're QRESYNCING, fetching all the flags from
1444         ;; scratch, or just fetching the last 100 flags per group.
1445         (nnimap-update-infos (nnimap-flags-to-marks
1446                               (nnimap-parse-flags
1447                                (nreverse sequences)))
1448                              infos)
1449         (unless dont-insert
1450           ;; Finally, just return something resembling an active file in
1451           ;; the nntp buffer, so that the agent can save the info, too.
1452           (with-current-buffer nntp-server-buffer
1453             (erase-buffer)
1454             (dolist (info infos)
1455               (let* ((group (gnus-info-group info))
1456                      (active (gnus-active group)))
1457                 (when active
1458                   (insert (format "%S %d %d y\n"
1459                                   (nnimap-encode-gnus-group
1460                                    (nnimap-decode-gnus-group
1461                                     (gnus-group-real-name group)))
1462                                   (cdr active)
1463                                   (car active))))))))))))
1464
1465 (defun nnimap-update-infos (flags infos)
1466   (dolist (info infos)
1467     (let* ((group (nnimap-decode-gnus-group
1468                    (gnus-group-real-name (gnus-info-group info))))
1469            (marks (cdr (assoc group flags))))
1470       (when marks
1471         (nnimap-update-info info marks)))))
1472
1473 (defun nnimap-update-info (info marks)
1474   (destructuring-bind (existing flags high low uidnext start-article
1475                                 permanent-flags uidvalidity
1476                                 vanished highestmodseq) marks
1477     (cond
1478      ;; Ignore groups with no UIDNEXT/marks.  This happens for
1479      ;; completely empty groups.
1480      ((and (not existing)
1481            (not uidnext))
1482       (let ((active (cdr (assq 'active (gnus-info-params info)))))
1483         (when active
1484           (gnus-set-active (gnus-info-group info) active))))
1485      ;; We have a mismatch between the old and new UIDVALIDITY
1486      ;; identifiers, so we have to re-request the group info (the next
1487      ;; time).  This virtually never happens.
1488      ((let ((old-uidvalidity
1489              (cdr (assq 'uidvalidity (gnus-info-params info)))))
1490         (and old-uidvalidity
1491              (not (equal old-uidvalidity uidvalidity))
1492              (or (not start-article)
1493                  (> start-article 1))))
1494       (gnus-group-remove-parameter info 'uidvalidity)
1495       (gnus-group-remove-parameter info 'modseq))
1496      ;; We have the data needed to update.
1497      (t
1498       (let* ((group (gnus-info-group info))
1499              (completep (and start-article
1500                              (= start-article 1)))
1501              (active (or (gnus-active group)
1502                          (cdr (assq 'active (gnus-info-params info))))))
1503         (when uidnext
1504           (setq high (1- uidnext)))
1505         ;; First set the active ranges based on high/low.
1506         (if (or completep
1507                 (not (gnus-active group)))
1508             (gnus-set-active group
1509                              (cond
1510                               (active
1511                                (cons (min (or low (car active))
1512                                           (car active))
1513                                      (max (or high (cdr active))
1514                                           (cdr active))))
1515                               ((and low high)
1516                                (cons low high))
1517                               (uidnext
1518                                ;; No articles in this group.
1519                                (cons uidnext (1- uidnext)))
1520                               (start-article
1521                                (cons start-article (1- start-article)))
1522                               (t
1523                                ;; No articles and no uidnext.
1524                                nil)))
1525           (gnus-set-active group
1526                            (cons (car active)
1527                                  (or high (1- uidnext)))))
1528         ;; See whether this is a read-only group.
1529         (unless (eq permanent-flags 'not-scanned)
1530           (gnus-group-set-parameter
1531            info 'permanent-flags
1532            (and (or (memq '%* permanent-flags)
1533                     (memq '%Seen permanent-flags))
1534                 permanent-flags)))
1535         ;; Update marks and read articles if this isn't a
1536         ;; read-only IMAP group.
1537         (when (setq permanent-flags
1538                     (cdr (assq 'permanent-flags (gnus-info-params info))))
1539           (if (and highestmodseq
1540                    (not start-article))
1541               ;; We've gotten the data by QRESYNCing.
1542               (nnimap-update-qresync-info
1543                info existing (nnimap-imap-ranges-to-gnus-ranges vanished) flags)
1544             ;; Do normal non-QRESYNC flag updates.
1545             ;; Update the list of read articles.
1546             (let* ((unread
1547                     (gnus-compress-sequence
1548                      (gnus-set-difference
1549                       (gnus-set-difference
1550                        existing
1551                        (gnus-sorted-union
1552                         (cdr (assoc '%Seen flags))
1553                         (cdr (assoc '%Deleted flags))))
1554                       (cdr (assoc '%Flagged flags)))))
1555                    (read (gnus-range-difference
1556                           (cons start-article high) unread)))
1557               (when (> start-article 1)
1558                 (setq read
1559                       (gnus-range-nconcat
1560                        (if (> start-article 1)
1561                            (gnus-sorted-range-intersection
1562                             (cons 1 (1- start-article))
1563                             (gnus-info-read info))
1564                          (gnus-info-read info))
1565                        read)))
1566               (when (or (not (listp permanent-flags))
1567                         (memq '%Seen permanent-flags))
1568                 (gnus-info-set-read info read))
1569               ;; Update the marks.
1570               (setq marks (gnus-info-marks info))
1571               (dolist (type (cdr nnimap-mark-alist))
1572                 (when (or (not (listp permanent-flags))
1573                           (memq (car (assoc (caddr type) flags))
1574                                 permanent-flags)
1575                           (memq '%* permanent-flags))
1576                   (let ((old-marks (assoc (car type) marks))
1577                         (new-marks
1578                          (gnus-compress-sequence
1579                           (cdr (or (assoc (caddr type) flags) ; %Flagged
1580                                    (assoc (intern (cadr type) obarray) flags)
1581                                    (assoc (cadr type) flags)))))) ; "\Flagged"
1582                     (setq marks (delq old-marks marks))
1583                     (pop old-marks)
1584                     (when (and old-marks
1585                                (> start-article 1))
1586                       (setq old-marks (gnus-range-difference
1587                                        old-marks
1588                                        (cons start-article high)))
1589                       (setq new-marks (gnus-range-nconcat old-marks new-marks)))
1590                     (when new-marks
1591                       (push (cons (car type) new-marks) marks)))))
1592               ;; Keep track of non-existing articles.
1593               (let* ((old-unexists (assq 'unexist marks))
1594                      (active (gnus-active group))
1595                      (unexists
1596                       (if completep
1597                           (gnus-range-difference
1598                            active
1599                            (gnus-compress-sequence existing))
1600                         (gnus-add-to-range
1601                          (cdr old-unexists)
1602                          (gnus-list-range-difference
1603                           existing (gnus-active group))))))
1604                 (when (> (car active) 1)
1605                   (setq unexists (gnus-range-add
1606                                   (cons 1 (1- (car active)))
1607                                   unexists)))
1608                 (if old-unexists
1609                     (setcdr old-unexists unexists)
1610                   (push (cons 'unexist unexists) marks)))
1611               (gnus-info-set-marks info marks t))))
1612         ;; Tell Gnus whether there are any \Recent messages in any of
1613         ;; the groups.
1614         (let ((recent (cdr (assoc '%Recent flags))))
1615           (when (and active
1616                      recent
1617                      (> (car (last recent)) (cdr active)))
1618             (push (list (cons (gnus-group-real-name group) 0))
1619                   nnmail-split-history)))
1620         ;; Note the active level for the next run-through.
1621         (gnus-group-set-parameter info 'active (gnus-active group))
1622         (gnus-group-set-parameter info 'uidvalidity uidvalidity)
1623         (gnus-group-set-parameter info 'modseq highestmodseq)
1624         (nnimap-store-info info (gnus-active group)))))))
1625
1626 (defun nnimap-update-qresync-info (info existing vanished flags)
1627   ;; Add all the vanished articles to the list of read articles.
1628   (gnus-info-set-read
1629    info
1630    (gnus-add-to-range
1631     (gnus-add-to-range
1632      (gnus-range-add (gnus-info-read info)
1633                      vanished)
1634      (cdr (assq '%Flagged flags)))
1635     (cdr (assq '%Seen flags))))
1636   (let ((marks (gnus-info-marks info)))
1637     (dolist (type (cdr nnimap-mark-alist))
1638       (let ((ticks (assoc (car type) marks))
1639             (new-marks
1640              (cdr (or (assoc (caddr type) flags) ; %Flagged
1641                       (assoc (intern (cadr type) obarray) flags)
1642                       (assoc (cadr type) flags))))) ; "\Flagged"
1643         (setq marks (delq ticks marks))
1644         (pop ticks)
1645         ;; Add the new marks we got.
1646         (setq ticks (gnus-add-to-range ticks new-marks))
1647         ;; Remove the marks from messages that don't have them.
1648         (setq ticks (gnus-remove-from-range
1649                      ticks
1650                      (gnus-compress-sequence
1651                       (gnus-sorted-complement existing new-marks))))
1652         (when ticks
1653           (push (cons (car type) ticks) marks)))
1654       (gnus-info-set-marks info marks t))
1655     ;; Add vanished to the list of unexisting articles.
1656     (when vanished
1657       (let* ((old-unexists (assq 'unexist marks))
1658              (unexists (gnus-range-add (cdr old-unexists) vanished)))
1659         (if old-unexists
1660             (setcdr old-unexists unexists)
1661           (push (cons 'unexist unexists) marks)))
1662       (gnus-info-set-marks info marks t))))
1663
1664 (defun nnimap-imap-ranges-to-gnus-ranges (irange)
1665   (if (zerop (length irange))
1666       nil
1667     (let ((result nil))
1668       (dolist (elem (split-string irange ","))
1669         (push
1670          (if (string-match ":" elem)
1671              (let ((numbers (split-string elem ":")))
1672                (cons (string-to-number (car numbers))
1673                      (string-to-number (cadr numbers))))
1674            (string-to-number elem))
1675          result))
1676       (nreverse result))))
1677
1678 (defun nnimap-store-info (info active)
1679   (let* ((group (nnimap-decode-gnus-group
1680                  (gnus-group-real-name (gnus-info-group info))))
1681          (entry (assoc group nnimap-current-infos)))
1682     (if entry
1683         (setcdr entry (list info active))
1684       (push (list group info active) nnimap-current-infos))))
1685
1686 (defun nnimap-flags-to-marks (groups)
1687   (let (data group uidnext articles start-article mark permanent-flags
1688              uidvalidity vanished highestmodseq)
1689     (dolist (elem groups)
1690       (setq group (car elem)
1691             uidnext (nth 1 elem)
1692             start-article (nth 2 elem)
1693             permanent-flags (nth 3 elem)
1694             uidvalidity (nth 4 elem)
1695             vanished (nth 5 elem)
1696             highestmodseq (nth 6 elem)
1697             articles (nthcdr 7 elem))
1698       (let ((high (caar articles))
1699             marks low existing)
1700         (dolist (article articles)
1701           (setq low (car article))
1702           (push (car article) existing)
1703           (dolist (flag (cdr article))
1704             (setq mark (assoc flag marks))
1705             (if (not mark)
1706                 (push (list flag (car article)) marks)
1707               (setcdr mark (cons (car article) (cdr mark))))))
1708         (push (list group existing marks high low uidnext start-article
1709                     permanent-flags uidvalidity vanished highestmodseq)
1710               data)))
1711     data))
1712
1713 (defun nnimap-parse-flags (sequences)
1714   (goto-char (point-min))
1715   ;; Change \Delete etc to %Delete, so that the Emacs Lisp reader can
1716   ;; read it.
1717   (subst-char-in-region (point-min) (point-max)
1718                         ?\\ ?% t)
1719   ;; Remove any MODSEQ entries in the buffer, because they may contain
1720   ;; numbers that are too large for 32-bit Emacsen.
1721   (while (re-search-forward " MODSEQ ([0-9]+)" nil t)
1722     (replace-match "" t t))
1723   (goto-char (point-min))
1724   (let (start end articles groups uidnext elems permanent-flags
1725               uidvalidity vanished highestmodseq)
1726     (dolist (elem sequences)
1727       (destructuring-bind (group-sequence flag-sequence totalp group command)
1728           elem
1729         (setq start (point))
1730         (when (and
1731                ;; The EXAMINE was successful.
1732                (search-forward (format "\n%d OK " group-sequence) nil t)
1733                (progn
1734                  (forward-line 1)
1735                  (setq end (point))
1736                  (goto-char start)
1737                  (setq permanent-flags
1738                        (if (equal command "SELECT")
1739                            (and (search-forward "PERMANENTFLAGS "
1740                                                 (or end (point-min)) t)
1741                                 (read (current-buffer)))
1742                          'not-scanned))
1743                  (goto-char start)
1744                  (setq uidnext
1745                        (and (search-forward "UIDNEXT "
1746                                             (or end (point-min)) t)
1747                             (read (current-buffer))))
1748                  (goto-char start)
1749                  (setq uidvalidity
1750                        (and (re-search-forward "UIDVALIDITY \\([0-9]+\\)"
1751                                                (or end (point-min)) t)
1752                             ;; Store UIDVALIDITY as a string, as it's
1753                             ;; too big for 32-bit Emacsen, usually.
1754                             (match-string 1)))
1755                  (goto-char start)
1756                  (setq vanished
1757                        (and (eq flag-sequence 'qresync)
1758                             (re-search-forward "^\\* VANISHED .*? \\([0-9:,]+\\)"
1759                                                (or end (point-min)) t)
1760                             (match-string 1)))
1761                  (goto-char start)
1762                  (setq highestmodseq
1763                        (and (re-search-forward "HIGHESTMODSEQ \\([0-9]+\\)"
1764                                             (or end (point-min)) t)
1765                             (match-string 1)))
1766                  (goto-char end)
1767                  (forward-line -1))
1768                ;; The UID FETCH FLAGS was successful.
1769                (or (eq flag-sequence 'qresync)
1770                    (search-forward (format "\n%d OK " flag-sequence) nil t)))
1771           (if (eq flag-sequence 'qresync)
1772               (progn
1773                 (goto-char start)
1774                 (setq start end))
1775             (setq start (point))
1776             (goto-char end))
1777           (while (re-search-forward "^\\* [0-9]+ FETCH " start t)
1778             (progn
1779               (setq elems (read (current-buffer)))
1780               (push (cons (cadr (memq 'UID elems))
1781                           (cadr (memq 'FLAGS elems)))
1782                     articles)))
1783           (push (nconc (list group uidnext totalp permanent-flags uidvalidity
1784                              vanished highestmodseq)
1785                        articles)
1786                 groups)
1787           (if (eq flag-sequence 'qresync)
1788               (goto-char end)
1789             (setq end (point)))
1790           (setq articles nil))))
1791     groups))
1792
1793 (defun nnimap-find-process-buffer (buffer)
1794   (cadr (assoc buffer nnimap-connection-alist)))
1795
1796 (deffoo nnimap-request-post (&optional _server)
1797   (setq nnimap-status-string "Read-only server")
1798   nil)
1799
1800 (defvar gnus-refer-thread-use-nnir) ;; gnus-sum.el
1801 (declare-function gnus-fetch-headers "gnus-sum"
1802                   (articles &optional limit force-new dependencies))
1803
1804 (autoload 'nnir-search-thread "nnir")
1805
1806 (deffoo nnimap-request-thread (header &optional group server)
1807   (when group
1808     (setq group (nnimap-decode-gnus-group group)))
1809   (if gnus-refer-thread-use-nnir
1810       (nnir-search-thread header)
1811     (when (nnimap-change-group group server)
1812       (let* ((cmd (nnimap-make-thread-query header))
1813              (result (with-current-buffer (nnimap-buffer)
1814                        (nnimap-command  "UID SEARCH %s" cmd))))
1815         (when result
1816           (gnus-fetch-headers
1817            (and (car result)
1818                 (delete 0 (mapcar #'string-to-number
1819                                   (cdr (assoc "SEARCH" (cdr result))))))
1820            nil t))))))
1821
1822 (defun nnimap-change-group (group &optional server no-reconnect read-only)
1823   "Change group to GROUP if non-nil.
1824 If SERVER is set, check that server is connected, otherwise retry
1825 to reconnect, unless NO-RECONNECT is set to t.  Return nil if
1826 unsuccessful in connecting.
1827 If GROUP is nil, return t.
1828 If READ-ONLY is set, send EXAMINE rather than SELECT to the server.
1829 Return the server's response to the SELECT or EXAMINE command."
1830   (let ((open-result t))
1831     (when (and server
1832                (not (nnimap-server-opened server)))
1833       (setq open-result (nnimap-open-server server nil no-reconnect)))
1834     (cond
1835      ((not open-result)
1836       nil)
1837      ((not group)
1838       t)
1839      (t
1840       (with-current-buffer (nnimap-buffer)
1841         (let ((result (nnimap-command "%s %S"
1842                                       (if read-only
1843                                           "EXAMINE"
1844                                         "SELECT")
1845                                       (utf7-encode group t))))
1846           (when (car result)
1847             (setf (nnimap-group nnimap-object) group
1848                   (nnimap-select-result nnimap-object) result)
1849             result)))))))
1850
1851 (defun nnimap-find-connection (buffer)
1852   "Find the connection delivering to BUFFER."
1853   (let ((entry (assoc buffer nnimap-connection-alist)))
1854     (when entry
1855       (if (and (buffer-name (cadr entry))
1856                (get-buffer-process (cadr entry))
1857                (memq (process-status (get-buffer-process (cadr entry)))
1858                      '(open run)))
1859           (get-buffer-process (cadr entry))
1860         (setq nnimap-connection-alist (delq entry nnimap-connection-alist))
1861         nil))))
1862
1863 (defvar nnimap-sequence 0)
1864
1865 (defun nnimap-send-command (&rest args)
1866   (setf (nnimap-last-command-time nnimap-object) (current-time))
1867   (process-send-string
1868    (get-buffer-process (current-buffer))
1869    (nnimap-log-command
1870     (format "%d %s%s\n"
1871             (incf nnimap-sequence)
1872             (apply #'format args)
1873             (if (nnimap-newlinep nnimap-object)
1874                 ""
1875               "\r"))))
1876   ;; Some servers apparently can't have many outstanding
1877   ;; commands, so throttle them.
1878   (unless nnimap-streaming
1879     (nnimap-wait-for-response nnimap-sequence))
1880   nnimap-sequence)
1881
1882 (defvar nnimap-record-commands nil
1883   "If non-nil, log commands to the \"*imap log*\" buffer.")
1884
1885 (defun nnimap-log-buffer ()
1886   (let ((name "*imap log*"))
1887     (or (get-buffer name)
1888         (with-current-buffer (get-buffer-create name)
1889           (setq-local window-point-insertion-type t)
1890           (current-buffer)))))
1891
1892 (defun nnimap-log-command (command)
1893   (when nnimap-record-commands
1894     (with-current-buffer (nnimap-log-buffer)
1895       (goto-char (point-max))
1896       (insert (format-time-string "%H:%M:%S")
1897               " [" nnimap-address "] "
1898               (if nnimap-inhibit-logging
1899                   "(inhibited)\n"
1900                 command))))
1901   command)
1902
1903 (defun nnimap-command (&rest args)
1904   (erase-buffer)
1905   (let* ((sequence (apply #'nnimap-send-command args))
1906          (response (nnimap-get-response sequence)))
1907     (if (equal (caar response) "OK")
1908         (cons t response)
1909       (nnheader-report 'nnimap "%s"
1910                        (mapconcat (lambda (a)
1911                                     (format "%s" a))
1912                                   (car response) " "))
1913       nil)))
1914
1915 (defun nnimap-get-response (sequence)
1916   (nnimap-wait-for-response sequence)
1917   (nnimap-parse-response))
1918
1919 (defun nnimap-wait-for-connection (&optional regexp)
1920   (nnimap-wait-for-line (or regexp "^[*.] .*\n") "[*.] \\([A-Z0-9]+\\)"))
1921
1922 (defun nnimap-wait-for-line (regexp &optional response-regexp)
1923   (let ((process (get-buffer-process (current-buffer))))
1924     (goto-char (point-min))
1925     (while (and (memq (process-status process)
1926                       '(open run))
1927                 (not (re-search-forward regexp nil t)))
1928       (nnheader-accept-process-output process)
1929       (goto-char (point-min)))
1930     (forward-line -1)
1931     (and (looking-at (or response-regexp regexp))
1932          (match-string 1))))
1933
1934 (defun nnimap-wait-for-response (sequence &optional messagep)
1935   (let ((process (get-buffer-process (current-buffer)))
1936         openp)
1937     (condition-case nil
1938         (progn
1939           (goto-char (point-max))
1940           (while (and (setq openp (memq (process-status process)
1941                                         '(open run)))
1942                       (progn
1943                         ;; Skip past any "*" lines that the server has
1944                         ;; output.
1945                         (while (and (not (bobp))
1946                                     (progn
1947                                       (forward-line -1)
1948                                       (looking-at "\\*\\|[0-9]+ OK NOOP"))))
1949                         (not (looking-at (format "%d .*\n" sequence)))))
1950             (when messagep
1951               (nnheader-message-maybe
1952                7 "nnimap read %dk from %s%s" (/ (buffer-size) 1000)
1953                nnimap-address
1954                (if (not (zerop (nnimap-initial-resync nnimap-object)))
1955                    (format " (initial sync of %d group%s; please wait)"
1956                            (nnimap-initial-resync nnimap-object)
1957                            (if (= (nnimap-initial-resync nnimap-object) 1)
1958                                ""
1959                              "s"))
1960                  "")))
1961             (nnheader-accept-process-output process)
1962             (goto-char (point-max)))
1963           (setf (nnimap-initial-resync nnimap-object) 0)
1964           openp)
1965       (quit
1966        (when debug-on-quit
1967          (debug "Quit"))
1968        ;; The user hit C-g while we were waiting: kill the process, in case
1969        ;; it's a gnutls-cli process that's stuck (tends to happen a lot behind
1970        ;; NAT routers).
1971        (delete-process process)
1972        nil))))
1973
1974 (defun nnimap-parse-response ()
1975   (let ((lines (split-string (nnimap-last-response-string) "\r\n" t))
1976         result)
1977     (dolist (line lines)
1978       (push (cdr (nnimap-parse-line line)) result))
1979     ;; Return the OK/error code first, and then all the "continuation
1980     ;; lines" afterwards.
1981     (cons (pop result)
1982           (nreverse result))))
1983
1984 ;; Parse an IMAP response line lightly.  They look like
1985 ;; "* OK [UIDVALIDITY 1164213559] UIDs valid", typically, so parse
1986 ;; the lines into a list of strings and lists of string.
1987 (defun nnimap-parse-line (line)
1988   (let (char result)
1989     (with-temp-buffer
1990       (mm-disable-multibyte)
1991       (insert line)
1992       (goto-char (point-min))
1993       (while (not (eobp))
1994         (if (eql (setq char (following-char)) ? )
1995             (forward-char 1)
1996           (push
1997            (cond
1998             ((eql char ?\[)
1999              (split-string
2000               (buffer-substring
2001                (1+ (point))
2002                (if (search-forward "]" (line-end-position) 'move)
2003                    (1- (point))
2004                  (point)))))
2005             ((eql char ?\()
2006              (split-string
2007               (buffer-substring
2008                (1+ (point))
2009                (if (search-forward ")" (line-end-position) 'move)
2010                    (1- (point))
2011                  (point)))))
2012             ((eql char ?\")
2013              (forward-char 1)
2014              (buffer-substring
2015               (point)
2016               (1- (or (search-forward "\"" (line-end-position) 'move)
2017                       (point)))))
2018             (t
2019              (buffer-substring (point) (if (search-forward " " nil t)
2020                                            (1- (point))
2021                                          (goto-char (point-max))))))
2022            result)))
2023       (nreverse result))))
2024
2025 (defun nnimap-last-response-string ()
2026   (save-excursion
2027     (forward-line 1)
2028     (let ((end (point)))
2029       (forward-line -1)
2030       (when (not (bobp))
2031         (forward-line -1)
2032         (while (and (not (bobp))
2033                     (eql (following-char) ?*))
2034           (forward-line -1))
2035         (unless (eql (following-char) ?*)
2036           (forward-line 1)))
2037       (buffer-substring (point) end))))
2038
2039 (defvar nnimap-incoming-split-list nil)
2040
2041 (defun nnimap-fetch-inbox (articles)
2042   (erase-buffer)
2043   (nnimap-wait-for-response
2044    (nnimap-send-command
2045     "UID FETCH %s %s"
2046     (nnimap-article-ranges articles)
2047     (format "(UID %s%s)"
2048             (format
2049              (if (nnimap-ver4-p)
2050                  "BODY.PEEK"
2051                "RFC822.PEEK"))
2052             (cond
2053              (nnimap-split-download-body-default
2054               "[]")
2055              ((nnimap-ver4-p)
2056               "[HEADER]")
2057              (t
2058               "[1]"))))
2059    t))
2060
2061 (defun nnimap-split-incoming-mail ()
2062   (with-current-buffer (nnimap-buffer)
2063     (let ((nnimap-incoming-split-list nil)
2064           (nnmail-split-methods
2065            (cond
2066             ((eq nnimap-split-methods 'default)
2067              nnmail-split-methods)
2068             (nnimap-split-methods
2069              nnimap-split-methods)
2070             (nnimap-split-fancy
2071              'nnmail-split-fancy)))
2072           (nnmail-split-fancy (or nnimap-split-fancy
2073                                   nnmail-split-fancy))
2074           (nnmail-inhibit-default-split-group t)
2075           (groups (nnimap-get-groups))
2076           (can-move (and (nnimap-capability "MOVE")
2077                          (equal (nnimap-quirk "MOVE") "MOVE")))
2078           new-articles)
2079       (erase-buffer)
2080       (nnimap-command "SELECT %S" nnimap-inbox)
2081       (setf (nnimap-group nnimap-object) nnimap-inbox)
2082       (setq new-articles (nnimap-new-articles (nnimap-get-flags "1:*")))
2083       (when new-articles
2084         (nnimap-fetch-inbox new-articles)
2085         (nnimap-transform-split-mail)
2086         (nnheader-ms-strip-cr)
2087         (nnmail-cache-open)
2088         (nnmail-split-incoming (current-buffer)
2089                                #'nnimap-save-mail-spec
2090                                nil nil
2091                                #'nnimap-dummy-active-number
2092                                #'nnimap-save-mail-spec)
2093         (when nnimap-incoming-split-list
2094           (let ((specs (nnimap-make-split-specs nnimap-incoming-split-list))
2095                 sequences junk-articles)
2096             ;; Create any groups that doesn't already exist on the
2097             ;; server first.
2098             (dolist (spec specs)
2099               (when (and (not (member (car spec) groups))
2100                          (not (eq (car spec) 'junk)))
2101                 (nnimap-command "CREATE %S" (utf7-encode (car spec) t))))
2102             ;; Then copy over all the messages.
2103             (erase-buffer)
2104             (dolist (spec specs)
2105               (let ((group (car spec))
2106                     (ranges (cdr spec)))
2107                 (if (eq group 'junk)
2108                     (setq junk-articles ranges)
2109                   ;; Don't copy if the message is already in its
2110                   ;; target group.
2111                   (unless (string= group nnimap-inbox)
2112                     (push (list (nnimap-send-command
2113                                  (if can-move
2114                                      "UID MOVE %s %S"
2115                                    "UID COPY %s %S")
2116                                  (nnimap-article-ranges ranges)
2117                                  (utf7-encode group t))
2118                                 ranges)
2119                           sequences)))))
2120             ;; Wait for the last COPY response...
2121             (when (and (not can-move) sequences)
2122               (nnimap-wait-for-response (caar sequences))
2123               ;; And then mark the successful copy actions as deleted,
2124               ;; and possibly expunge them.
2125               (nnimap-mark-and-expunge-incoming
2126                (nnimap-parse-copied-articles sequences)))
2127             (nnimap-mark-and-expunge-incoming junk-articles)))))))
2128
2129 (defun nnimap-mark-and-expunge-incoming (range)
2130   (when range
2131     (setq range (nnimap-article-ranges range))
2132     (erase-buffer)
2133     (let ((sequence
2134            (nnimap-send-command
2135             "UID STORE %s +FLAGS.SILENT (\\Deleted)" range)))
2136       (cond
2137        ;; If the server supports it, we now delete the message we have
2138        ;; just copied over.
2139        ((nnimap-capability "UIDPLUS")
2140         (setq sequence (nnimap-send-command "UID EXPUNGE %s" range)))
2141        ;; If it doesn't support UID EXPUNGE, then we only expunge if the
2142        ;; user has configured it.
2143        (nnimap-expunge
2144         (setq sequence (nnimap-send-command "EXPUNGE"))))
2145       (nnimap-wait-for-response sequence))))
2146
2147 (defun nnimap-parse-copied-articles (sequences)
2148   (let (sequence copied range)
2149     (goto-char (point-min))
2150     (while (re-search-forward "^\\([0-9]+\\) OK\\b" nil t)
2151       (setq sequence (string-to-number (match-string 1)))
2152       (when (setq range (cadr (assq sequence sequences)))
2153         (push (gnus-uncompress-range range) copied)))
2154     (gnus-compress-sequence (sort (apply #'nconc copied) #'<))))
2155
2156 (defun nnimap-new-articles (flags)
2157   (let (new)
2158     (dolist (elem flags)
2159       (unless (gnus-list-memq-of-list nnimap-unsplittable-articles
2160                                       (cdr elem))
2161         (push (car elem) new)))
2162     (gnus-compress-sequence (nreverse new))))
2163
2164 (defun nnimap-make-split-specs (list)
2165   (let ((specs nil)
2166         entry)
2167     (dolist (elem list)
2168       (destructuring-bind (article spec) elem
2169         (dolist (group (delete nil (mapcar #'car spec)))
2170           (unless (setq entry (assoc group specs))
2171             (push (setq entry (list group)) specs))
2172           (setcdr entry (cons article (cdr entry))))))
2173     (dolist (entry specs)
2174       (setcdr entry (gnus-compress-sequence (sort (cdr entry) #'<))))
2175     specs))
2176
2177 (defun nnimap-transform-split-mail ()
2178   (goto-char (point-min))
2179   (let (article bytes)
2180     (block nil
2181       (while (not (eobp))
2182         (while (not (looking-at "\\* [0-9]+ FETCH.+UID \\([0-9]+\\)"))
2183           (delete-region (point) (progn (forward-line 1) (point)))
2184           (when (eobp)
2185             (return)))
2186         (setq article (match-string 1)
2187               bytes (nnimap-get-length))
2188         (delete-region (line-beginning-position) (line-end-position))
2189         ;; Insert MMDF separator, and a way to remember what this
2190         ;; article UID is.
2191         (insert (format "\^A\^A\^A\^A\n\nX-nnimap-article: %s" article))
2192         (forward-char (1+ bytes))
2193         (setq bytes (nnimap-get-length))
2194         (delete-region (line-beginning-position) (line-end-position))
2195         ;; There's a body; skip past that.
2196         (when bytes
2197           (forward-char (1+ bytes))
2198           (delete-region (line-beginning-position) (line-end-position)))))))
2199
2200 (defun nnimap-dummy-active-number (_group &optional _server)
2201   1)
2202
2203 (defun nnimap-save-mail-spec (group-art &optional _server _full-nov)
2204   (let (article)
2205     (goto-char (point-min))
2206     (if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t))
2207         (error "Invalid nnimap mail")
2208       (setq article (string-to-number (match-string 1))))
2209     (push (list article
2210                 (if (eq group-art 'junk)
2211                     (list (cons 'junk 1))
2212                   group-art))
2213           nnimap-incoming-split-list)))
2214
2215 (defun nnimap-make-thread-query (header)
2216   (let* ((id  (mail-header-id header))
2217          (refs (split-string
2218                 (or (mail-header-references header)
2219                     "")))
2220          (value
2221           (format
2222            "(OR HEADER REFERENCES %S HEADER Message-Id %S)"
2223            id id)))
2224     (dolist (refid refs value)
2225       (setq value (format
2226                    "(OR (OR HEADER Message-Id %S HEADER REFERENCES %S) %s)"
2227                    refid refid value)))))
2228
2229
2230 (provide 'nnimap)
2231
2232 ;;; nnimap.el ends here