cgit.sxemacs.org Git - gnus/blob - lisp/nnimap.el

   1 ;;; nnimap.el --- IMAP interface for Gnus
   2
   3 ;; Copyright (C) 2010 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-and-compile
  30   (require 'nnheader))
  31
  32 (eval-when-compile
  33   (require 'cl))
  34
  35 (require 'nnheader)
  36 (require 'gnus-util)
  37 (require 'gnus)
  38 (require 'nnoo)
  39 (require 'netrc)
  40 (require 'utf7)
  41 (require 'parse-time)
  42
  43 (autoload 'auth-source-forget-user-or-password "auth-source")
  44 (autoload 'auth-source-user-or-password "auth-source")
  45
  46 (nnoo-declare nnimap)
  47
  48 (defvoo nnimap-address nil
  49   "The address of the IMAP server.")
  50
  51 (defvoo nnimap-server-port nil
  52   "The IMAP port used.
  53 If nnimap-stream is `ssl', this will default to `imaps'.  If not,
  54 it will default to `imap'.")
  55
  56 (defvoo nnimap-stream 'ssl
  57   "How nnimap will talk to the IMAP server.
  58 Values are `ssl', `network', `starttls' or `shell'.")
  59
  60 (defvoo nnimap-shell-program (if (boundp 'imap-shell-program)
  61                                  (if (listp imap-shell-program)
  62                                      (car imap-shell-program)
  63                                    imap-shell-program)
  64                                "ssh %s imapd"))
  65
  66 (defvoo nnimap-inbox nil
  67   "The mail box where incoming mail arrives and should be split out of.")
  68
  69 (defvoo nnimap-split-methods nil
  70   "How mail is split.
  71 Uses the same syntax as nnmail-split-methods")
  72
  73 (defvoo nnimap-authenticator nil
  74   "How nnimap authenticate itself to the server.
  75 Possible choices are nil (use default methods) or `anonymous'.")
  76
  77 (defvoo nnimap-expunge t
  78   "If non-nil, expunge articles after deleting them.
  79 This is always done if the server supports UID EXPUNGE, but it's
  80 not done by default on servers that doesn't support that command.")
  81
  82 (defvoo nnimap-streaming t
  83   "If non-nil, try to use streaming commands with IMAP servers.
  84 Switching this off will make nnimap slower, but it helps with
  85 some servers.")
  86
  87 (defvoo nnimap-connection-alist nil)
  88
  89 (defvoo nnimap-current-infos nil)
  90
  91 (defvoo nnimap-fetch-partial-articles nil
  92   "If non-nil, Gnus will fetch partial articles.
  93 If t, nnimap will fetch only the first part.  If a string, it
  94 will fetch all parts that have types that match that string.  A
  95 likely value would be \"text/\" to automatically fetch all
  96 textual parts.")
  97
  98 (defvar nnimap-process nil)
  99
 100 (defvar nnimap-status-string "")
 101
 102 (defvar nnimap-split-download-body-default nil
 103   "Internal variable with default value for `nnimap-split-download-body'.")
 104
 105 (defvar nnimap-keepalive-timer nil)
 106 (defvar nnimap-process-buffers nil)
 107
 108 (defstruct nnimap
 109   group process commands capabilities select-result newlinep server
 110   last-command-time greeting)
 111
 112 (defvar nnimap-object nil)
 113
 114 (defvar nnimap-mark-alist
 115   '((read "\\Seen" %Seen)
 116     (tick "\\Flagged" %Flagged)
 117     (reply "\\Answered" %Answered)
 118     (expire "gnus-expire")
 119     (dormant "gnus-dormant")
 120     (score "gnus-score")
 121     (save "gnus-save")
 122     (download "gnus-download")
 123     (forward "gnus-forward")))
 124
 125 (defun nnimap-buffer ()
 126   (nnimap-find-process-buffer nntp-server-buffer))
 127
 128 (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old)
 129   (with-current-buffer nntp-server-buffer
 130     (erase-buffer)
 131     (when (nnimap-possibly-change-group group server)
 132       (with-current-buffer (nnimap-buffer)
 133         (erase-buffer)
 134         (nnimap-wait-for-response
 135          (nnimap-send-command
 136           "UID FETCH %s %s"
 137           (nnimap-article-ranges (gnus-compress-sequence articles))
 138           (format "(UID RFC822.SIZE BODYSTRUCTURE %s)"
 139                   (format
 140                    (if (nnimap-ver4-p)
 141                        "BODY.PEEK[HEADER.FIELDS %s]"
 142                      "RFC822.HEADER.LINES %s")
 143                    (append '(Subject From Date Message-Id
 144                                      References In-Reply-To Xref)
 145                            nnmail-extra-headers))))
 146          t)
 147         (nnimap-transform-headers))
 148       (insert-buffer-substring
 149        (nnimap-find-process-buffer (current-buffer))))
 150     'headers))
 151
 152 (defun nnimap-transform-headers ()
 153   (goto-char (point-min))
 154   (let (article bytes lines size string)
 155     (block nil
 156       (while (not (eobp))
 157         (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
 158           (delete-region (point) (progn (forward-line 1) (point)))
 159           (when (eobp)
 160             (return)))
 161         (setq article (match-string 1))
 162         ;; Unfold quoted {number} strings.
 163         (while (re-search-forward "[^]] {\\([0-9]+\\)}\r\n"
 164                                   (1+ (line-end-position)) t)
 165           (setq size (string-to-number (match-string 1)))
 166           (delete-region (+ (match-beginning 0) 2) (point))
 167           (setq string (delete-region (point) (+ (point) size)))
 168           (insert (format "%S" string)))
 169         (setq bytes (nnimap-get-length)
 170               lines nil)
 171         (beginning-of-line)
 172         (setq size
 173               (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)"
 174                                       (line-end-position)
 175                                       t)
 176                    (match-string 1)))
 177         (beginning-of-line)
 178         (when (search-forward "BODYSTRUCTURE" (line-end-position) t)
 179           (let ((structure (ignore-errors
 180                              (read (current-buffer)))))
 181             (while (and (consp structure)
 182                         (not (stringp (car structure))))
 183               (setq structure (car structure)))
 184             (setq lines (nth 7 structure))))
 185         (delete-region (line-beginning-position) (line-end-position))
 186         (insert (format "211 %s Article retrieved." article))
 187         (forward-line 1)
 188         (when size
 189           (insert (format "Chars: %s\n" size)))
 190         (when lines
 191           (insert (format "Lines: %s\n" lines)))
 192         (re-search-forward "^\r$")
 193         (delete-region (line-beginning-position) (line-end-position))
 194         (insert ".")
 195         (forward-line 1)))))
 196
 197 (defun nnimap-get-length ()
 198   (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t)
 199        (string-to-number (match-string 1))))
 200
 201 (defun nnimap-article-ranges (ranges)
 202   (let (result)
 203     (cond
 204      ((numberp ranges)
 205       (number-to-string ranges))
 206      ((numberp (cdr ranges))
 207       (format "%d:%d" (car ranges) (cdr ranges)))
 208      (t
 209       (dolist (elem ranges)
 210         (push
 211          (if (consp elem)
 212              (format "%d:%d" (car elem) (cdr elem))
 213            (number-to-string elem))
 214          result))
 215       (mapconcat #'identity (nreverse result) ",")))))
 216
 217 (deffoo nnimap-open-server (server &optional defs)
 218   (if (nnimap-server-opened server)
 219       t
 220     (unless (assq 'nnimap-address defs)
 221       (setq defs (append defs (list (list 'nnimap-address server)))))
 222     (nnoo-change-server 'nnimap server defs)
 223     (or (nnimap-find-connection nntp-server-buffer)
 224         (nnimap-open-connection nntp-server-buffer))))
 225
 226 (defun nnimap-make-process-buffer (buffer)
 227   (with-current-buffer
 228       (generate-new-buffer (format "*nnimap %s %s %s*"
 229                                    nnimap-address nnimap-server-port
 230                                    (gnus-buffer-exists-p buffer)))
 231     (mm-disable-multibyte)
 232     (buffer-disable-undo)
 233     (gnus-add-buffer)
 234     (set (make-local-variable 'after-change-functions) nil)
 235     (set (make-local-variable 'nnimap-object)
 236          (make-nnimap :server (nnoo-current-server 'nnimap)))
 237     (push (list buffer (current-buffer)) nnimap-connection-alist)
 238     (push (current-buffer) nnimap-process-buffers)
 239     (current-buffer)))
 240
 241 (defun nnimap-open-shell-stream (name buffer host port)
 242   (let ((process-connection-type nil))
 243     (start-process name buffer shell-file-name
 244                    shell-command-switch
 245                    (format-spec
 246                     nnimap-shell-program
 247                     (format-spec-make
 248                      ?s host
 249                      ?p port)))))
 250
 251 (defun nnimap-credentials (address ports &optional inhibit-create)
 252   (let (port credentials)
 253     ;; Request the credentials from all ports, but only query on the
 254     ;; last port if all the previous ones have failed.
 255     (while (and (null credentials)
 256                 (setq port (pop ports)))
 257       (setq credentials
 258             (auth-source-user-or-password
 259              '("login" "password") address port nil
 260              (if inhibit-create
 261                  nil
 262                (null ports)))))
 263     credentials))
 264
 265 (defun nnimap-keepalive ()
 266   (let ((now (current-time)))
 267     (dolist (buffer nnimap-process-buffers)
 268       (when (buffer-name buffer)
 269         (with-current-buffer buffer
 270           (when (and nnimap-object
 271                      (nnimap-last-command-time nnimap-object)
 272                      (> (time-to-seconds
 273                          (time-subtract
 274                           now
 275                           (nnimap-last-command-time nnimap-object)))
 276                         ;; More than five minutes since the last command.
 277                         (* 5 60)))
 278             (nnimap-send-command "NOOP")))))))
 279
 280 (defun nnimap-open-connection (buffer)
 281   (unless nnimap-keepalive-timer
 282     (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15)
 283                                               'nnimap-keepalive)))
 284   (block nil
 285     (with-current-buffer (nnimap-make-process-buffer buffer)
 286       (let* ((coding-system-for-read 'binary)
 287              (coding-system-for-write 'binary)
 288              (port nil)
 289              (ports
 290               (cond
 291                ((eq nnimap-stream 'network)
 292                 (open-network-stream
 293                  "*nnimap*" (current-buffer) nnimap-address
 294                  (setq port
 295                        (or nnimap-server-port
 296                            (if (netrc-find-service-number "imap")
 297                                "imap"
 298                              "143"))))
 299                 '("143" "imap"))
 300                ((eq nnimap-stream 'shell)
 301                 (nnimap-open-shell-stream
 302                  "*nnimap*" (current-buffer) nnimap-address
 303                  (setq port (or nnimap-server-port "imap")))
 304                 '("imap"))
 305                ((eq nnimap-stream 'starttls)
 306                 (starttls-open-stream
 307                  "*nnimap*" (current-buffer) nnimap-address
 308                  (setq port (or nnimap-server-port "imap")))
 309                 '("imap"))
 310                ((eq nnimap-stream 'ssl)
 311                 (open-tls-stream
 312                  "*nnimap*" (current-buffer) nnimap-address
 313                  (setq port
 314                        (or nnimap-server-port
 315                            (if (netrc-find-service-number "imaps")
 316                                "imaps"
 317                              "993"))))
 318                 '("143" "993" "imap" "imaps"))))
 319              connection-result login-result credentials)
 320         (setf (nnimap-process nnimap-object)
 321               (get-buffer-process (current-buffer)))
 322         (if (not (and (nnimap-process nnimap-object)
 323                       (memq (process-status (nnimap-process nnimap-object))
 324                             '(open run))))
 325             (nnheader-report 'nnimap "Unable to contact %s:%s via %s"
 326                              nnimap-address port nnimap-stream)
 327           (gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil)
 328           (if (not (setq connection-result (nnimap-wait-for-connection)))
 329               (nnheader-report 'nnimap
 330                                "%s" (buffer-substring
 331                                      (point) (line-end-position)))
 332             ;; Store the greeting (for debugging purposes).
 333             (setf (nnimap-greeting nnimap-object)
 334                   (buffer-substring (line-beginning-position)
 335                                     (line-end-position)))
 336             ;; Store the capabilities.
 337             (setf (nnimap-capabilities nnimap-object)
 338                   (mapcar
 339                    #'upcase
 340                    (nnimap-find-parameter
 341                     "CAPABILITY" (cdr (nnimap-command "CAPABILITY")))))
 342             (when (eq nnimap-stream 'starttls)
 343               (nnimap-command "STARTTLS")
 344               (starttls-negotiate (nnimap-process nnimap-object)))
 345             (when nnimap-server-port
 346               (push (format "%s" nnimap-server-port) ports))
 347             (unless (equal connection-result "PREAUTH")
 348               (if (not (setq credentials
 349                              (if (eq nnimap-authenticator 'anonymous)
 350                                  (list "anonymous"
 351                                        (message-make-address))
 352                                (or
 353                                 ;; First look for the credentials based
 354                                 ;; on the virtual server name.
 355                                 (nnimap-credentials
 356                                  (nnoo-current-server 'nnimap) ports t)
 357                                 ;; Then look them up based on the
 358                                 ;; physical address.
 359                                 (nnimap-credentials nnimap-address ports)))))
 360                   (setq nnimap-object nil)
 361                 (setq login-result (nnimap-command "LOGIN %S %S"
 362                                                    (car credentials)
 363                                                    (cadr credentials)))
 364                 (unless (car login-result)
 365                   ;; If the login failed, then forget the credentials
 366                   ;; that are now possibly cached.
 367                   (dolist (host (list (nnoo-current-server 'nnimap)
 368                                       nnimap-address))
 369                     (dolist (port ports)
 370                       (dolist (element '("login" "password"))
 371                         (auth-source-forget-user-or-password
 372                          element host port))))
 373                   (delete-process (nnimap-process nnimap-object))
 374                   (setq nnimap-object nil))))
 375             (when nnimap-object
 376               (when (member "QRESYNC" (nnimap-capabilities nnimap-object))
 377                 (nnimap-command "ENABLE QRESYNC"))
 378               t)))))))
 379
 380 (defun nnimap-find-parameter (parameter elems)
 381   (let (result)
 382     (dolist (elem elems)
 383       (cond
 384        ((equal (car elem) parameter)
 385         (setq result (cdr elem)))
 386        ((and (equal (car elem) "OK")
 387              (consp (cadr elem))
 388              (equal (caadr elem) parameter))
 389         (setq result (cdr (cadr elem))))))
 390     result))
 391
 392 (deffoo nnimap-close-server (&optional server)
 393   t)
 394
 395 (deffoo nnimap-request-close ()
 396   t)
 397
 398 (deffoo nnimap-server-opened (&optional server)
 399   (and (nnoo-current-server-p 'nnimap server)
 400        nntp-server-buffer
 401        (gnus-buffer-live-p nntp-server-buffer)
 402        (nnimap-find-connection nntp-server-buffer)))
 403
 404 (deffoo nnimap-status-message (&optional server)
 405   nnimap-status-string)
 406
 407 (deffoo nnimap-request-article (article &optional group server to-buffer)
 408   (with-current-buffer nntp-server-buffer
 409     (let ((result (nnimap-possibly-change-group group server))
 410           parts structure)
 411       (when (stringp article)
 412         (setq article (nnimap-find-article-by-message-id group article)))
 413       (when (and result
 414                  article)
 415         (erase-buffer)
 416         (with-current-buffer (nnimap-buffer)
 417           (erase-buffer)
 418           (when nnimap-fetch-partial-articles
 419             (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article)
 420             (goto-char (point-min))
 421             (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t)
 422               (setq structure (ignore-errors (read (current-buffer)))
 423                     parts (nnimap-find-wanted-parts structure))))
 424           (when (if parts
 425                     (nnimap-get-partial-article article parts structure)
 426                   (nnimap-get-whole-article article))
 427             (let ((buffer (current-buffer)))
 428               (with-current-buffer (or to-buffer nntp-server-buffer)
 429                 (erase-buffer)
 430                 (insert-buffer-substring buffer)
 431                 (nnheader-ms-strip-cr)
 432                 (cons group article)))))))))
 433
 434 (defun nnimap-get-whole-article (article)
 435   (let ((result
 436          (nnimap-command
 437           (if (nnimap-ver4-p)
 438               "UID FETCH %d BODY.PEEK[]"
 439             "UID FETCH %d RFC822.PEEK")
 440           article)))
 441     ;; Check that we really got an article.
 442     (goto-char (point-min))
 443     (unless (re-search-forward "\\* [0-9]+ FETCH" nil t)
 444       (setq result nil))
 445     (when result
 446       ;; Remove any data that may have arrived before the FETCH data.
 447       (beginning-of-line)
 448       (unless (bobp)
 449         (delete-region (point-min) (point)))
 450       (let ((bytes (nnimap-get-length)))
 451         (delete-region (line-beginning-position)
 452                        (progn (forward-line 1) (point)))
 453         (goto-char (+ (point) bytes))
 454         (delete-region (point) (point-max)))
 455       t)))
 456
 457 (defun nnimap-ver4-p ()
 458   (member "IMAP4REV1" (nnimap-capabilities nnimap-object)))
 459
 460 (defun nnimap-get-partial-article (article parts structure)
 461   (let ((result
 462          (nnimap-command
 463           "UID FETCH %d (%s %s)"
 464           article
 465           (if (nnimap-ver4-p)
 466               "BODY.PEEK[HEADER]"
 467             "RFC822.HEADER")
 468           (if (nnimap-ver4-p)
 469               (mapconcat (lambda (part)
 470                            (format "BODY.PEEK[%s]" part))
 471                          parts " ")
 472             (mapconcat (lambda (part)
 473                          (format "RFC822.PEEK[%s]" part))
 474                        parts " ")))))
 475     (when result
 476       (nnimap-convert-partial-article structure))))
 477
 478 (defun nnimap-convert-partial-article (structure)
 479   ;; First just skip past the headers.
 480   (goto-char (point-min))
 481   (let ((bytes (nnimap-get-length))
 482         id parts)
 483     ;; Delete "FETCH" line.
 484     (delete-region (line-beginning-position)
 485                    (progn (forward-line 1) (point)))
 486     (goto-char (+ (point) bytes))
 487     ;; Collect all the body parts.
 488     (while (looking-at ".*BODY\\[\\([.0-9]+\\)\\]")
 489       (setq id (match-string 1)
 490             bytes (nnimap-get-length))
 491       (beginning-of-line)
 492       (delete-region (point) (progn (forward-line 1) (point)))
 493       (push (list id (buffer-substring (point) (+ (point) bytes)))
 494             parts)
 495       (delete-region (point) (+ (point) bytes)))
 496     ;; Delete trailing junk.
 497     (delete-region (point) (point-max))
 498     ;; Now insert all the parts again where they fit in the structure.
 499     (nnimap-insert-partial-structure structure parts)
 500     t))
 501
 502 (defun nnimap-insert-partial-structure (structure parts &optional subp)
 503   (let (type boundary)
 504     (let ((bstruc structure))
 505       (while (consp (car bstruc))
 506         (pop bstruc))
 507       (setq type (car bstruc))
 508       (setq bstruc (car (cdr bstruc)))
 509       (when (and (stringp (car bstruc))
 510                  (string= (downcase (car bstruc)) "boundary"))
 511         (setq boundary (cadr bstruc))))
 512     (when subp
 513       (insert (format "Content-type: multipart/%s; boundary=%S\n\n"
 514                       (downcase type) boundary)))
 515     (while (not (stringp (car structure)))
 516       (insert "\n--" boundary "\n")
 517       (if (consp (caar structure))
 518           (nnimap-insert-partial-structure (pop structure) parts t)
 519         (let ((bit (pop structure)))
 520           (insert (format  "Content-type: %s/%s"
 521                            (downcase (nth 0 bit))
 522                            (downcase (nth 1 bit))))
 523           (if (member "CHARSET" (nth 2 bit))
 524               (insert (format
 525                        "; charset=%S\n" (cadr (member "CHARSET" (nth 2 bit)))))
 526             (insert "\n"))
 527           (insert (format "Content-transfer-encoding: %s\n"
 528                           (nth 5 bit)))
 529           (insert "\n")
 530           (when (assoc (nth 9 bit) parts)
 531             (insert (cadr (assoc (nth 9 bit) parts)))))))
 532     (insert "\n--" boundary "--\n")))
 533
 534 (defun nnimap-find-wanted-parts (structure)
 535   (message-flatten-list (nnimap-find-wanted-parts-1 structure "")))
 536
 537 (defun nnimap-find-wanted-parts-1 (structure prefix)
 538   (let ((num 1)
 539         parts)
 540     (while (consp (car structure))
 541       (let ((sub (pop structure)))
 542         (if (consp (car sub))
 543             (push (nnimap-find-wanted-parts-1
 544                    sub (if (string= prefix "")
 545                            (number-to-string num)
 546                          (format "%s.%s" prefix num)))
 547                   parts)
 548           (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub)))
 549                 (id (if (string= prefix "")
 550                         (number-to-string num)
 551                       (format "%s.%s" prefix num))))
 552             (setcar (nthcdr 9 sub) id)
 553             (when (if (eq nnimap-fetch-partial-articles t)
 554                       (equal id "1")
 555                     (string-match nnimap-fetch-partial-articles type))
 556               (push id parts))))
 557         (incf num)))
 558     (nreverse parts)))
 559
 560 (deffoo nnimap-request-group (group &optional server dont-check info)
 561   (let ((result (nnimap-possibly-change-group group server))
 562         articles active marks high low)
 563     (with-current-buffer nntp-server-buffer
 564       (when result
 565         (if (and dont-check
 566                  (setq active (nth 2 (assoc group nnimap-current-infos))))
 567             (insert (format "211 %d %d %d %S\n"
 568                             (- (cdr active) (car active))
 569                             (car active)
 570                             (cdr active)
 571                             group))
 572           (with-current-buffer (nnimap-buffer)
 573             (erase-buffer)
 574             (let ((group-sequence
 575                    (nnimap-send-command "SELECT %S" (utf7-encode group t)))
 576                   (flag-sequence
 577                    (nnimap-send-command "UID FETCH 1:* FLAGS")))
 578               (nnimap-wait-for-response flag-sequence)
 579               (setq marks
 580                     (nnimap-flags-to-marks
 581                      (nnimap-parse-flags
 582                       (list (list group-sequence flag-sequence 1 group)))))
 583               (when info
 584                 (nnimap-update-infos marks (list info)))
 585               (goto-char (point-max))
 586               (let ((uidnext (nth 5 (car marks))))
 587                 (setq high (if uidnext
 588                                (1- uidnext)
 589                              (nth 3 (car marks)))
 590                       low (or (nth 4 (car marks)) uidnext)))))
 591           (erase-buffer)
 592           (insert
 593            (format
 594             "211 %d %d %d %S\n" (1+ (- high low)) low high group)))
 595         t))))
 596
 597 (deffoo nnimap-request-create-group (group &optional server args)
 598   (when (nnimap-possibly-change-group nil server)
 599     (with-current-buffer (nnimap-buffer)
 600       (car (nnimap-command "CREATE %S" (utf7-encode group t))))))
 601
 602 (deffoo nnimap-request-delete-group (group &optional force server)
 603   (when (nnimap-possibly-change-group nil server)
 604     (with-current-buffer (nnimap-buffer)
 605       (car (nnimap-command "DELETE %S" (utf7-encode group t))))))
 606
 607 (deffoo nnimap-request-expunge-group (group &optional server)
 608   (when (nnimap-possibly-change-group group server)
 609     (with-current-buffer (nnimap-buffer)
 610       (car (nnimap-command "EXPUNGE")))))
 611
 612 (defun nnimap-get-flags (spec)
 613   (let ((articles nil)
 614         elems)
 615     (with-current-buffer (nnimap-buffer)
 616       (erase-buffer)
 617       (nnimap-wait-for-response (nnimap-send-command
 618                                  "UID FETCH %s FLAGS" spec))
 619       (goto-char (point-min))
 620       (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" nil t)
 621         (setq elems (nnimap-parse-line (match-string 1)))
 622         (push (cons (string-to-number (cadr (member "UID" elems)))
 623                     (cadr (member "FLAGS" elems)))
 624               articles)))
 625     (nreverse articles)))
 626
 627 (deffoo nnimap-close-group (group &optional server)
 628   t)
 629
 630 (deffoo nnimap-request-move-article (article group server accept-form
 631                                              &optional last internal-move-group)
 632   (with-temp-buffer
 633     (when (nnimap-request-article article group server (current-buffer))
 634       ;; If the move is internal (on the same server), just do it the easy
 635       ;; way.
 636       (let ((message-id (message-field-value "message-id")))
 637         (if internal-move-group
 638             (let ((result
 639                    (with-current-buffer (nnimap-buffer)
 640                      (nnimap-command "UID COPY %d %S"
 641                                      article
 642                                      (utf7-encode internal-move-group t)))))
 643               (when (car result)
 644                 (nnimap-delete-article article)
 645                 (cons internal-move-group
 646                       (nnimap-find-article-by-message-id
 647                        internal-move-group message-id))))
 648           ;; Move the article to a different method.
 649           (let ((result (eval accept-form)))
 650             (when result
 651               (nnimap-delete-article article)
 652               result)))))))
 653
 654 (deffoo nnimap-request-expire-articles (articles group &optional server force)
 655   (cond
 656    ((null articles)
 657     nil)
 658    ((not (nnimap-possibly-change-group group server))
 659     articles)
 660    ((and force
 661          (eq nnmail-expiry-target 'delete))
 662     (unless (nnimap-delete-article (gnus-compress-sequence articles))
 663       (message "Article marked for deletion, but not expunged."))
 664     nil)
 665    (t
 666     (let ((deletable-articles
 667            (if (or force
 668                    (eq nnmail-expiry-wait 'immediate))
 669                articles
 670              (gnus-sorted-intersection
 671               articles
 672               (nnimap-find-expired-articles group)))))
 673       (if (null deletable-articles)
 674           articles
 675         (if (eq nnmail-expiry-target 'delete)
 676             (nnimap-delete-article (gnus-compress-sequence deletable-articles))
 677           (setq deletable-articles
 678                 (nnimap-process-expiry-targets
 679                  deletable-articles group server)))
 680         ;; Return the articles we didn't delete.
 681         (gnus-sorted-complement articles deletable-articles))))))
 682
 683 (defun nnimap-process-expiry-targets (articles group server)
 684   (let ((deleted-articles nil))
 685     (dolist (article articles)
 686       (let ((target nnmail-expiry-target))
 687         (with-temp-buffer
 688           (when (nnimap-request-article article group server (current-buffer))
 689             (message "Expiring article %s:%d" group article)
 690             (when (functionp target)
 691               (setq target (funcall target group)))
 692             (when (and target
 693                        (not (eq target 'delete)))
 694               (if (or (gnus-request-group target t)
 695                       (gnus-request-create-group target))
 696                   (nnmail-expiry-target-group target group)
 697                 (setq target nil)))
 698             (when target
 699               (push article deleted-articles))))))
 700     ;; Change back to the current group again.
 701     (nnimap-possibly-change-group group server)
 702     (setq deleted-articles (nreverse deleted-articles))
 703     (nnimap-delete-article (gnus-compress-sequence deleted-articles))
 704     deleted-articles))
 705
 706 (defun nnimap-find-expired-articles (group)
 707   (let ((cutoff (nnmail-expired-article-p group nil nil)))
 708     (with-current-buffer (nnimap-buffer)
 709       (let ((result
 710              (nnimap-command
 711               "UID SEARCH SENTBEFORE %s"
 712               (format-time-string
 713                (format "%%d-%s-%%Y"
 714                        (upcase
 715                         (car (rassoc (nth 4 (decode-time cutoff))
 716                                      parse-time-months))))
 717                cutoff))))
 718         (and (car result)
 719              (delete 0 (mapcar #'string-to-number
 720                                (cdr (assoc "SEARCH" (cdr result))))))))))
 721
 722
 723 (defun nnimap-find-article-by-message-id (group message-id)
 724   (when (nnimap-possibly-change-group group nil)
 725     (with-current-buffer (nnimap-buffer)
 726       (let ((result
 727              (nnimap-command "UID SEARCH HEADER Message-Id %S" message-id))
 728             article)
 729         (when (car result)
 730           ;; Select the last instance of the message in the group.
 731           (and (setq article
 732                      (car (last (assoc "SEARCH" (cdr result)))))
 733                (string-to-number article)))))))
 734
 735 (defun nnimap-delete-article (articles)
 736   (with-current-buffer (nnimap-buffer)
 737     (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)"
 738                     (nnimap-article-ranges articles))
 739     (cond
 740      ((member "UIDPLUS" (nnimap-capabilities nnimap-object))
 741       (nnimap-command "UID EXPUNGE %s"
 742                       (nnimap-article-ranges articles))
 743       t)
 744      (nnimap-expunge
 745       (nnimap-command "EXPUNGE")
 746       t)
 747      (t (gnus-message 7 (concat "nnimap: nnimap-expunge is not set and the "
 748                                 "server doesn't support UIDPLUS, so we won't "
 749                                 "delete this article now"))))))
 750
 751 (deffoo nnimap-request-scan (&optional group server)
 752   (when (and (nnimap-possibly-change-group nil server)
 753              nnimap-inbox
 754              nnimap-split-methods)
 755     (message "nnimap %s splitting mail..." server)
 756     (nnimap-split-incoming-mail)))
 757
 758 (defun nnimap-marks-to-flags (marks)
 759   (let (flags flag)
 760     (dolist (mark marks)
 761       (when (setq flag (cadr (assq mark nnimap-mark-alist)))
 762         (push flag flags)))
 763     flags))
 764
 765 (deffoo nnimap-request-set-mark (group actions &optional server)
 766   (when (nnimap-possibly-change-group group server)
 767     (let (sequence)
 768       (with-current-buffer (nnimap-buffer)
 769         (erase-buffer)
 770         ;; Just send all the STORE commands without waiting for
 771         ;; response.  If they're successful, they're successful.
 772         (dolist (action actions)
 773           (destructuring-bind (range action marks) action
 774             (let ((flags (nnimap-marks-to-flags marks)))
 775               (when flags
 776                 (setq sequence (nnimap-send-command
 777                                 "UID STORE %s %sFLAGS.SILENT (%s)"
 778                                 (nnimap-article-ranges range)
 779                                 (if (eq action 'del)
 780                                     "-"
 781                                   "+")
 782                                 (mapconcat #'identity flags " ")))))))
 783         ;; Wait for the last command to complete to avoid later
 784         ;; syncronisation problems with the stream.
 785         (when sequence
 786           (nnimap-wait-for-response sequence))))))
 787
 788 (deffoo nnimap-request-accept-article (group &optional server last)
 789   (when (nnimap-possibly-change-group nil server)
 790     (nnmail-check-syntax)
 791     (nnimap-add-cr)
 792     (let ((message (buffer-string))
 793           (message-id (message-field-value "message-id"))
 794           sequence)
 795       (with-current-buffer (nnimap-buffer)
 796         (setq sequence (nnimap-send-command
 797                         "APPEND %S {%d}" (utf7-encode group t)
 798                         (length message)))
 799         (process-send-string (get-buffer-process (current-buffer)) message)
 800         (process-send-string (get-buffer-process (current-buffer))
 801                              (if (nnimap-newlinep nnimap-object)
 802                                  "\n"
 803                                "\r\n"))
 804         (let ((result (nnimap-get-response sequence)))
 805           (if (not (car result))
 806               (progn
 807                 (message "%s" (nnheader-get-report-string 'nnimap))
 808                 nil)
 809             (cons group
 810                   (nnimap-find-article-by-message-id group message-id))))))))
 811
 812 (defun nnimap-add-cr ()
 813   (goto-char (point-min))
 814   (while (re-search-forward "\r?\n" nil t)
 815     (replace-match "\r\n" t t)))
 816
 817 (defun nnimap-get-groups ()
 818   (let ((result (nnimap-command "LIST \"\" \"*\""))
 819         groups)
 820     (when (car result)
 821       (dolist (line (cdr result))
 822         (when (and (equal (car line) "LIST")
 823                    (not (and (caadr line)
 824                              (string-match "noselect" (caadr line)))))
 825           (push (car (last line)) groups)))
 826       (nreverse groups))))
 827
 828 (deffoo nnimap-request-list (&optional server)
 829   (nnimap-possibly-change-group nil server)
 830   (with-current-buffer nntp-server-buffer
 831     (erase-buffer)
 832     (let ((groups
 833            (with-current-buffer (nnimap-buffer)
 834              (nnimap-get-groups)))
 835           sequences responses)
 836       (when groups
 837         (with-current-buffer (nnimap-buffer)
 838           (setf (nnimap-group nnimap-object) nil)
 839           (dolist (group groups)
 840             (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t))
 841                         group)
 842                   sequences))
 843           (nnimap-wait-for-response (caar sequences))
 844           (setq responses
 845                 (nnimap-get-responses (mapcar #'car sequences))))
 846         (dolist (response responses)
 847           (let* ((sequence (car response))
 848                  (response (cadr response))
 849                  (group (cadr (assoc sequence sequences))))
 850             (when (and group
 851                        (equal (caar response) "OK"))
 852               (let ((uidnext (nnimap-find-parameter "UIDNEXT" response))
 853                     highest exists)
 854                 (dolist (elem response)
 855                   (when (equal (cadr elem) "EXISTS")
 856                     (setq exists (string-to-number (car elem)))))
 857                 (when uidnext
 858                   (setq highest (1- (string-to-number (car uidnext)))))
 859                 (cond
 860                  ((null highest)
 861                   (insert (format "%S 0 1 y\n" (utf7-decode group t))))
 862                  ((zerop exists)
 863                   ;; Empty group.
 864                   (insert (format "%S %d %d y\n"
 865                                   (utf7-decode group t) highest (1+ highest))))
 866                  (t
 867                   ;; Return the widest possible range.
 868                   (insert (format "%S %d 1 y\n" (utf7-decode group t)
 869                                   (or highest exists)))))))))
 870         t))))
 871
 872 (deffoo nnimap-retrieve-group-data-early (server infos)
 873   (when (nnimap-possibly-change-group nil server)
 874     (with-current-buffer (nnimap-buffer)
 875       ;; QRESYNC handling isn't implemented.
 876       (let ((qresyncp (member "notQRESYNC" (nnimap-capabilities nnimap-object)))
 877             marks groups sequences)
 878         ;; Go through the infos and gather the data needed to know
 879         ;; what and how to request the data.
 880         (dolist (info infos)
 881           (setq marks (gnus-info-marks info))
 882           (push (list (gnus-group-real-name (gnus-info-group info))
 883                       (cdr (assq 'active marks))
 884                       (cdr (assq 'uid marks)))
 885                 groups))
 886         ;; Then request the data.
 887         (erase-buffer)
 888         (setf (nnimap-group nnimap-object) nil)
 889         (dolist (elem groups)
 890           (if (and qresyncp
 891                    (nth 2 elem))
 892               (push
 893                (list 'qresync
 894                      (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))"
 895                                           (car elem)
 896                                           (car (nth 2 elem))
 897                                           (cdr (nth 2 elem)))
 898                      nil
 899                      (car elem))
 900                sequences)
 901             (let ((start
 902                    (if (nth 1 elem)
 903                        ;; Fetch the last 100 flags.
 904                        (max 1 (- (cdr (nth 1 elem)) 100))
 905                      1)))
 906               (push (list (nnimap-send-command "EXAMINE %S" (car elem))
 907                           (nnimap-send-command "UID FETCH %d:* FLAGS" start)
 908                           start
 909                           (car elem))
 910                     sequences)))
 911           ;; Some servers apparently can't have many outstanding
 912           ;; commands, so throttle them.
 913           (when (and (not nnimap-streaming)
 914                      (car sequences))
 915             (nnimap-wait-for-response (caar sequences))))
 916         sequences))))
 917
 918 (deffoo nnimap-finish-retrieve-group-infos (server infos sequences)
 919   (when (and sequences
 920              (nnimap-possibly-change-group nil server))
 921     (with-current-buffer (nnimap-buffer)
 922       ;; Wait for the final data to trickle in.
 923       (when (nnimap-wait-for-response (cadar sequences))
 924         ;; Now we should have all the data we need, no matter whether
 925         ;; we're QRESYNCING, fetching all the flags from scratch, or
 926         ;; just fetching the last 100 flags per group.
 927         (nnimap-update-infos (nnimap-flags-to-marks
 928                               (nnimap-parse-flags
 929                                (nreverse sequences)))
 930                              infos)
 931         ;; Finally, just return something resembling an active file in
 932         ;; the nntp buffer, so that the agent can save the info, too.
 933         (with-current-buffer nntp-server-buffer
 934           (erase-buffer)
 935           (dolist (info infos)
 936             (let* ((group (gnus-info-group info))
 937                    (active (gnus-active group)))
 938               (when active
 939                 (insert (format "%S %d %d y\n"
 940                                 (gnus-group-real-name group)
 941                                 (cdr active)
 942                                 (car active)))))))))))
 943
 944 (defun nnimap-update-infos (flags infos)
 945   (dolist (info infos)
 946     (let ((group (gnus-group-real-name (gnus-info-group info))))
 947       (nnimap-update-info info (cdr (assoc group flags))))))
 948
 949 (defun nnimap-update-info (info marks)
 950   (when marks
 951     (destructuring-bind (existing flags high low uidnext start-article
 952                                   permanent-flags) marks
 953       (let ((group (gnus-info-group info))
 954             (completep (and start-article
 955                             (= start-article 1))))
 956         (when uidnext
 957           (setq high (1- uidnext)))
 958         ;; First set the active ranges based on high/low.
 959         (if (or completep
 960                 (not (gnus-active group)))
 961             (gnus-set-active group
 962                              (cond
 963                               ((and low high)
 964                                (cons low high))
 965                               (uidnext
 966                                ;; No articles in this group.
 967                                (cons uidnext (1- uidnext)))
 968                               (start-article
 969                                (cons start-article (1- start-article)))
 970                               (t
 971                                ;; No articles and no uidnext.
 972                                nil)))
 973           (gnus-set-active
 974            group
 975            (cons (car (gnus-active group))
 976                  (or high (1- uidnext)))))
 977         (when (and (not high)
 978                    uidnext)
 979           (setq high (1- uidnext)))
 980         ;; Then update the list of read articles.
 981         (let* ((unread
 982                 (gnus-compress-sequence
 983                  (gnus-set-difference
 984                   (gnus-set-difference
 985                    existing
 986                    (cdr (assoc '%Seen flags)))
 987                   (cdr (assoc '%Flagged flags)))))
 988                (read (gnus-range-difference
 989                       (cons start-article high) unread)))
 990           (when (> start-article 1)
 991             (setq read
 992                   (gnus-range-nconcat
 993                    (if (> start-article 1)
 994                        (gnus-sorted-range-intersection
 995                         (cons 1 (1- start-article))
 996                         (gnus-info-read info))
 997                      (gnus-info-read info))
 998                    read)))
 999           (gnus-info-set-read info read)
1000           ;; Update the marks.
1001           (setq marks (gnus-info-marks info))
1002           ;; Note the active level for the next run-through.
1003           (let ((active (assq 'active marks)))
1004             (if active
1005                 (setcdr active (gnus-active group))
1006               (push (cons 'active (gnus-active group)) marks)))
1007           (dolist (type (cdr nnimap-mark-alist))
1008             (let ((old-marks (assoc (car type) marks))
1009                   (new-marks
1010                    (gnus-compress-sequence
1011                     (cdr (or (assoc (caddr type) flags)     ; %Flagged
1012                              (assoc (intern (cadr type) obarray) flags)
1013                              (assoc (cadr type) flags)))))) ; "\Flagged"
1014               (setq marks (delq old-marks marks))
1015               (pop old-marks)
1016               (when (and old-marks
1017                          (> start-article 1))
1018                 (setq old-marks (gnus-range-difference
1019                                  old-marks
1020                                  (cons start-article high)))
1021                 (setq new-marks (gnus-range-nconcat old-marks new-marks)))
1022               (when new-marks
1023                 (push (cons (car type) new-marks) marks)))
1024             (gnus-info-set-marks info marks t)
1025             (nnimap-store-info info (gnus-active group))))))))
1026
1027 (defun nnimap-store-info (info active)
1028   (let* ((group (gnus-group-real-name (gnus-info-group info)))
1029          (entry (assoc group nnimap-current-infos)))
1030     (if entry
1031         (setcdr entry (list info active))
1032       (push (list group info active) nnimap-current-infos))))
1033
1034 (defun nnimap-flags-to-marks (groups)
1035   (let (data group totalp uidnext articles start-article mark permanent-flags)
1036     (dolist (elem groups)
1037       (setq group (car elem)
1038             uidnext (nth 1 elem)
1039             start-article (nth 2 elem)
1040             permanent-flags (nth 3 elem)
1041             articles (nthcdr 4 elem))
1042       (let ((high (caar articles))
1043             marks low existing)
1044         (dolist (article articles)
1045           (setq low (car article))
1046           (push (car article) existing)
1047           (dolist (flag (cdr article))
1048             (setq mark (assoc flag marks))
1049             (if (not mark)
1050                 (push (list flag (car article)) marks)
1051               (setcdr mark (cons (car article) (cdr mark))))))
1052         (push (list group existing marks high low uidnext start-article
1053                     permanent-flags)
1054               data)))
1055     data))
1056
1057 (defun nnimap-parse-flags (sequences)
1058   (goto-char (point-min))
1059   ;; Change \Delete etc to %Delete, so that the reader can read it.
1060   (subst-char-in-region (point-min) (point-max)
1061                         ?\\ ?% t)
1062   (let (start end articles groups uidnext elems permanent-flags)
1063     (dolist (elem sequences)
1064       (destructuring-bind (group-sequence flag-sequence totalp group) elem
1065         (setq start (point))
1066         ;; The EXAMINE was successful.
1067         (when (and (search-forward (format "\n%d OK " group-sequence) nil t)
1068                    (progn
1069                      (forward-line 1)
1070                      (setq end (point))
1071                      (goto-char start)
1072                      (setq permanent-flags
1073                            (and (search-forward "PERMANENTFLAGS "
1074                                                  (or end (point-min)) t)
1075                                 (read (current-buffer))))
1076                      (goto-char start)
1077                      (setq uidnext
1078                            (and (search-forward "UIDNEXT "
1079                                                  (or end (point-min)) t)
1080                                 (read (current-buffer))))
1081                      (goto-char end)
1082                      (forward-line -1))
1083                    ;; The UID FETCH FLAGS was successful.
1084                    (search-forward (format "\n%d OK " flag-sequence) nil t))
1085           (setq start (point))
1086           (goto-char end)
1087           (while (search-forward " FETCH " start t)
1088             (setq elems (read (current-buffer)))
1089             (push (cons (cadr (memq 'UID elems))
1090                         (cadr (memq 'FLAGS elems)))
1091                   articles))
1092           (push (nconc (list group uidnext totalp permanent-flags) articles)
1093                 groups)
1094           (setq articles nil))))
1095     groups))
1096
1097 (defun nnimap-find-process-buffer (buffer)
1098   (cadr (assoc buffer nnimap-connection-alist)))
1099
1100 (deffoo nnimap-request-post (&optional server)
1101   (setq nnimap-status-string "Read-only server")
1102   nil)
1103
1104 (defun nnimap-possibly-change-group (group server)
1105   (let ((open-result t))
1106     (when (and server
1107                (not (nnimap-server-opened server)))
1108       (setq open-result (nnimap-open-server server)))
1109     (cond
1110      ((not open-result)
1111       nil)
1112      ((not group)
1113       t)
1114      (t
1115       (with-current-buffer (nnimap-buffer)
1116         (if (equal group (nnimap-group nnimap-object))
1117             t
1118           (let ((result (nnimap-command "SELECT %S" (utf7-encode group t))))
1119             (when (car result)
1120               (setf (nnimap-group nnimap-object) group
1121                     (nnimap-select-result nnimap-object) result)
1122               result))))))))
1123
1124 (defun nnimap-find-connection (buffer)
1125   "Find the connection delivering to BUFFER."
1126   (let ((entry (assoc buffer nnimap-connection-alist)))
1127     (when entry
1128       (if (and (buffer-name (cadr entry))
1129                (get-buffer-process (cadr entry))
1130                (memq (process-status (get-buffer-process (cadr entry)))
1131                      '(open run)))
1132           (get-buffer-process (cadr entry))
1133         (setq nnimap-connection-alist (delq entry nnimap-connection-alist))
1134         nil))))
1135
1136 (defvar nnimap-sequence 0)
1137
1138 (defun nnimap-send-command (&rest args)
1139   (process-send-string
1140    (get-buffer-process (current-buffer))
1141    (nnimap-log-command
1142     (format "%d %s%s\n"
1143             (incf nnimap-sequence)
1144             (apply #'format args)
1145             (if (nnimap-newlinep nnimap-object)
1146                 ""
1147               "\r"))))
1148   nnimap-sequence)
1149
1150 (defun nnimap-log-command (command)
1151   (with-current-buffer (get-buffer-create "*imap log*")
1152     (goto-char (point-max))
1153     (insert (format-time-string "%H:%M:%S") " " command))
1154   command)
1155
1156 (defun nnimap-command (&rest args)
1157   (erase-buffer)
1158   (setf (nnimap-last-command-time nnimap-object) (current-time))
1159   (let* ((sequence (apply #'nnimap-send-command args))
1160          (response (nnimap-get-response sequence)))
1161     (if (equal (caar response) "OK")
1162         (cons t response)
1163       (nnheader-report 'nnimap "%s"
1164                        (mapconcat (lambda (a)
1165                                     (format "%s" a))
1166                                   (car response) " "))
1167       nil)))
1168
1169 (defun nnimap-get-response (sequence)
1170   (nnimap-wait-for-response sequence)
1171   (nnimap-parse-response))
1172
1173 (defun nnimap-wait-for-connection ()
1174   (let ((process (get-buffer-process (current-buffer))))
1175     (goto-char (point-min))
1176     (while (and (memq (process-status process)
1177                       '(open run))
1178                 (not (re-search-forward "^\\* .*\n" nil t)))
1179       (nnheader-accept-process-output process)
1180       (goto-char (point-min)))
1181     (forward-line -1)
1182     (and (looking-at "\\* \\([A-Z0-9]+\\)")
1183          (match-string 1))))
1184
1185 (defun nnimap-wait-for-response (sequence &optional messagep)
1186   (let ((process (get-buffer-process (current-buffer)))
1187         openp)
1188     (goto-char (point-max))
1189     (while (and (setq openp (memq (process-status process)
1190                                   '(open run)))
1191                 (not (re-search-backward
1192                       (format "^%d .*\n" sequence)
1193                       (if nnimap-streaming
1194                           (max (point-min) (- (point) 500))
1195                         (point-min))
1196                       t)))
1197       (when messagep
1198         (message "Read %dKB" (/ (buffer-size) 1000)))
1199       (nnheader-accept-process-output process)
1200       (goto-char (point-max)))
1201     openp))
1202
1203 (defun nnimap-parse-response ()
1204   (let ((lines (split-string (nnimap-last-response-string) "\r\n" t))
1205         result)
1206     (dolist (line lines)
1207       (push (cdr (nnimap-parse-line line)) result))
1208     ;; Return the OK/error code first, and then all the "continuation
1209     ;; lines" afterwards.
1210     (cons (pop result)
1211           (nreverse result))))
1212
1213 ;; Parse an IMAP response line lightly.  They look like
1214 ;; "* OK [UIDVALIDITY 1164213559] UIDs valid", typically, so parse
1215 ;; the lines into a list of strings and lists of string.
1216 (defun nnimap-parse-line (line)
1217   (let (char result)
1218     (with-temp-buffer
1219       (insert line)
1220       (goto-char (point-min))
1221       (while (not (eobp))
1222         (if (eql (setq char (following-char)) ? )
1223             (forward-char 1)
1224           (push
1225            (cond
1226             ((eql char ?\[)
1227              (split-string (buffer-substring
1228                             (1+ (point))
1229                             (1- (search-forward "]" (line-end-position) 'move)))))
1230             ((eql char ?\()
1231              (split-string (buffer-substring
1232                             (1+ (point))
1233                             (1- (search-forward ")" (line-end-position) 'move)))))
1234             ((eql char ?\")
1235              (forward-char 1)
1236              (buffer-substring
1237               (point)
1238               (1- (or (search-forward "\"" (line-end-position) 'move)
1239                       (point)))))
1240             (t
1241              (buffer-substring (point) (if (search-forward " " nil t)
1242                                            (1- (point))
1243                                          (goto-char (point-max))))))
1244            result)))
1245       (nreverse result))))
1246
1247 (defun nnimap-last-response-string ()
1248   (save-excursion
1249     (forward-line 1)
1250     (let ((end (point)))
1251       (forward-line -1)
1252       (when (not (bobp))
1253         (forward-line -1)
1254         (while (and (not (bobp))
1255                     (eql (following-char) ?*))
1256           (forward-line -1))
1257         (unless (eql (following-char) ?*)
1258           (forward-line 1)))
1259       (buffer-substring (point) end))))
1260
1261 (defun nnimap-get-responses (sequences)
1262   (let (responses)
1263     (dolist (sequence sequences)
1264       (goto-char (point-min))
1265       (when (re-search-forward (format "^%d " sequence) nil t)
1266         (push (list sequence (nnimap-parse-response))
1267               responses)))
1268     responses))
1269
1270 (defvar nnimap-incoming-split-list nil)
1271
1272 (defun nnimap-fetch-inbox (articles)
1273   (erase-buffer)
1274   (nnimap-wait-for-response
1275    (nnimap-send-command
1276     "UID FETCH %s %s"
1277     (nnimap-article-ranges articles)
1278     (format "(UID %s%s)"
1279             (format
1280              (if (nnimap-ver4-p)
1281                  "BODY.PEEK[HEADER] BODY.PEEK"
1282                "RFC822.PEEK"))
1283             (if nnimap-split-download-body-default
1284                 "[]"
1285               "[1]")))
1286    t))
1287
1288 (defun nnimap-split-incoming-mail ()
1289   (with-current-buffer (nnimap-buffer)
1290     (let ((nnimap-incoming-split-list nil)
1291           (nnmail-split-methods nnimap-split-methods)
1292           (nnmail-inhibit-default-split-group t)
1293           (groups (nnimap-get-groups))
1294           new-articles)
1295       (erase-buffer)
1296       (nnimap-command "SELECT %S" nnimap-inbox)
1297       (setq new-articles (nnimap-new-articles (nnimap-get-flags "1:*")))
1298       (when new-articles
1299         (nnimap-fetch-inbox new-articles)
1300         (nnimap-transform-split-mail)
1301         (nnheader-ms-strip-cr)
1302         (nnmail-cache-open)
1303         (nnmail-split-incoming (current-buffer)
1304                                #'nnimap-save-mail-spec
1305                                nil nil
1306                                #'nnimap-dummy-active-number
1307                                #'nnimap-save-mail-spec)
1308         (when nnimap-incoming-split-list
1309           (let ((specs (nnimap-make-split-specs nnimap-incoming-split-list))
1310                 sequences junk-articles)
1311             ;; Create any groups that doesn't already exist on the
1312             ;; server first.
1313             (dolist (spec specs)
1314               (when (and (not (member (car spec) groups))
1315                          (not (eq (car spec) 'junk)))
1316                 (nnimap-command "CREATE %S" (utf7-encode (car spec) t))))
1317             ;; Then copy over all the messages.
1318             (erase-buffer)
1319             (dolist (spec specs)
1320               (let ((group (car spec))
1321                     (ranges (cdr spec)))
1322                 (if (eq group 'junk)
1323                     (setq junk-articles ranges)
1324                   (push (list (nnimap-send-command
1325                                "UID COPY %s %S"
1326                                (nnimap-article-ranges ranges)
1327                                (utf7-encode group t))
1328                               ranges)
1329                         sequences))))
1330             ;; Wait for the last COPY response...
1331             (when sequences
1332               (nnimap-wait-for-response (caar sequences))
1333               ;; And then mark the successful copy actions as deleted,
1334               ;; and possibly expunge them.
1335               (nnimap-mark-and-expunge-incoming
1336                (nnimap-parse-copied-articles sequences)))
1337             (nnimap-mark-and-expunge-incoming junk-articles)))))))
1338
1339 (defun nnimap-mark-and-expunge-incoming (range)
1340   (when range
1341     (setq range (nnimap-article-ranges range))
1342     (erase-buffer)
1343     (let ((sequence
1344            (nnimap-send-command
1345             "UID STORE %s +FLAGS.SILENT (\\Deleted)" range)))
1346       (cond
1347        ;; If the server supports it, we now delete the message we have
1348        ;; just copied over.
1349        ((member "UIDPLUS" (nnimap-capabilities nnimap-object))
1350         (setq sequence (nnimap-send-command "UID EXPUNGE %s" range)))
1351        ;; If it doesn't support UID EXPUNGE, then we only expunge if the
1352        ;; user has configured it.
1353        (nnimap-expunge
1354         (setq sequence (nnimap-send-command "EXPUNGE"))))
1355       (nnimap-wait-for-response sequence))))
1356
1357 (defun nnimap-parse-copied-articles (sequences)
1358   (let (sequence copied range)
1359     (goto-char (point-min))
1360     (while (re-search-forward "^\\([0-9]+\\) OK " nil t)
1361       (setq sequence (string-to-number (match-string 1)))
1362       (when (setq range (cadr (assq sequence sequences)))
1363         (push (gnus-uncompress-range range) copied)))
1364     (gnus-compress-sequence (sort (apply #'nconc copied) #'<))))
1365
1366 (defun nnimap-new-articles (flags)
1367   (let (new)
1368     (dolist (elem flags)
1369       (when (or (null (cdr elem))
1370                 (and (not (memq '%Deleted (cdr elem)))
1371                      (not (memq '%Seen (cdr elem)))))
1372         (push (car elem) new)))
1373     (gnus-compress-sequence (nreverse new))))
1374
1375 (defun nnimap-make-split-specs (list)
1376   (let ((specs nil)
1377         entry)
1378     (dolist (elem list)
1379       (destructuring-bind (article spec) elem
1380         (dolist (group (delete nil (mapcar #'car spec)))
1381           (unless (setq entry (assoc group specs))
1382             (push (setq entry (list group)) specs))
1383           (setcdr entry (cons article (cdr entry))))))
1384     (dolist (entry specs)
1385       (setcdr entry (gnus-compress-sequence (sort (cdr entry) #'<))))
1386     specs))
1387
1388 (defun nnimap-transform-split-mail ()
1389   (goto-char (point-min))
1390   (let (article bytes)
1391     (block nil
1392       (while (not (eobp))
1393         (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
1394           (delete-region (point) (progn (forward-line 1) (point)))
1395           (when (eobp)
1396             (return)))
1397         (setq article (match-string 1)
1398               bytes (nnimap-get-length))
1399         (delete-region (line-beginning-position) (line-end-position))
1400         ;; Insert MMDF separator, and a way to remember what this
1401         ;; article UID is.
1402         (insert (format "\^A\^A\^A\^A\n\nX-nnimap-article: %s" article))
1403         (forward-char (1+ bytes))
1404         (setq bytes (nnimap-get-length))
1405         (delete-region (line-beginning-position) (line-end-position))
1406         (forward-char (1+ bytes))
1407         (delete-region (line-beginning-position) (line-end-position))))))
1408
1409 (defun nnimap-dummy-active-number (group &optional server)
1410   1)
1411
1412 (defun nnimap-save-mail-spec (group-art &optional server full-nov)
1413   (let (article)
1414     (goto-char (point-min))
1415     (if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t))
1416         (error "Invalid nnimap mail")
1417       (setq article (string-to-number (match-string 1))))
1418     (push (list article
1419                 (if (eq group-art 'junk)
1420                     (list (cons 'junk 1))
1421                   group-art))
1422           nnimap-incoming-split-list)))
1423
1424 (provide 'nnimap)
1425
1426 ;;; nnimap.el ends here