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 'netrc)
  36
  37 (nnoo-declare nnimap)
  38
  39 (defvoo nnimap-address nil
  40   "The address of the IMAP server.")
  41
  42 (defvoo nnimap-server-port nil
  43   "The IMAP port used.
  44 If nnimap-stream is `ssl', this will default to `imaps'.  If not,
  45 it will default to `imap'.")
  46
  47 (defvoo nnimap-stream 'ssl
  48   "How nnimap will talk to the IMAP server.
  49 Values are `ssl' and `network'.")
  50
  51 (defvoo nnimap-shell-program (if (boundp 'imap-shell-program)
  52                                  (if (listp imap-shell-program)
  53                                      (car imap-shell-program)
  54                                    imap-shell-program)
  55                                "ssh %s imapd"))
  56
  57 (defvoo nnimap-inbox nil
  58   "The mail box where incoming mail arrives and should be split out of.")
  59
  60 (defvoo nnimap-expunge-inbox nil
  61   "If non-nil, expunge the inbox after fetching mail.
  62 This is always done if the server supports UID EXPUNGE, but it's
  63 not done by default on servers that doesn't support that command.")
  64
  65 (defvoo nnimap-connection-alist nil)
  66 (defvar nnimap-process nil)
  67
  68 (defvar nnimap-status-string "")
  69
  70 (defvar nnimap-split-download-body-default nil
  71   "Internal variable with default value for `nnimap-split-download-body'.")
  72
  73 (defstruct nnimap
  74   group process commands capabilities)
  75
  76 (defvar nnimap-object nil)
  77
  78 (defvar nnimap-mark-alist
  79   '((read "\\Seen")
  80     (tick "\\Flagged")
  81     (reply "\\Answered")
  82     (expire "gnus-expire")
  83     (dormant "gnus-dormant")
  84     (score "gnus-score")
  85     (save "gnus-save")
  86     (download "gnus-download")
  87     (forward "gnus-forward")))
  88
  89 (defvar nnimap-split-methods nil)
  90
  91 (defun nnimap-buffer ()
  92   (nnimap-find-process-buffer nntp-server-buffer))
  93
  94 (defmacro nnimap-with-process-buffer (&rest body)
  95   `(with-current-buffer (nnimap-find-process-buffer (current-buffer))
  96      ,@body))
  97
  98 (defun nnimap-retrieve-headers (articles &optional group server fetch-old)
  99   (with-current-buffer nntp-server-buffer
 100     (erase-buffer)
 101     (when (nnimap-possibly-change-group group server)
 102       (with-current-buffer (nnimap-buffer)
 103         (nnimap-send-command "SELECT %S" (utf7-encode group t))
 104         (erase-buffer)
 105         (nnimap-wait-for-response
 106          (nnimap-send-command
 107           "UID FETCH %s %s"
 108           (nnimap-article-ranges (gnus-compress-sequence articles))
 109           (format "(UID RFC822.SIZE BODYSTRUCTURE %s)"
 110                   (format
 111                    (if (member "IMAP4REV1"
 112                                (nnimap-capabilities nnimap-object))
 113                        "BODY.PEEK[HEADER.FIELDS %s]"
 114                      "RFC822.HEADER.LINES %s")
 115                    (append '(Subject From Date Message-Id
 116                                      References In-Reply-To Xref)
 117                            nnmail-extra-headers))))
 118          t)
 119         (nnimap-transform-headers))
 120       (insert-buffer-substring
 121        (nnimap-find-process-buffer (current-buffer))))
 122     t))
 123
 124 (defun nnimap-transform-headers ()
 125   (goto-char (point-min))
 126   (let (article bytes lines)
 127     (block nil
 128       (while (not (eobp))
 129         (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
 130           (delete-region (point) (progn (forward-line 1) (point)))
 131           (when (eobp)
 132             (return)))
 133         (setq article (match-string 1)
 134               bytes (nnimap-get-length)
 135               lines nil)
 136         (beginning-of-line)
 137         (when (search-forward "BODYSTRUCTURE" (line-end-position) t)
 138           (let ((structure (ignore-errors (read (current-buffer)))))
 139             (while (and (consp structure)
 140                         (not (stringp (car structure))))
 141               (setq structure (car structure)))
 142             (setq lines (nth 7 structure))))
 143         (delete-region (line-beginning-position) (line-end-position))
 144         (insert (format "211 %s Article retrieved." article))
 145         (forward-line 1)
 146         (insert (format "Bytes: %d\n" bytes))
 147         (when lines
 148           (insert (format "Lines: %s\n" lines)))
 149         (re-search-forward "^\r$")
 150         (delete-region (line-beginning-position) (line-end-position))
 151         (insert ".")
 152         (forward-line 1)))))
 153
 154 (defun nnimap-get-length ()
 155   (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t)
 156        (string-to-number (match-string 1))))
 157
 158 (defun nnimap-article-ranges (ranges)
 159   (let (result)
 160     (cond
 161      ((numberp ranges)
 162       (number-to-string ranges))
 163      ((numberp (cdr ranges))
 164       (format "%d:%d" (car ranges) (cdr ranges)))
 165      (t
 166       (dolist (elem ranges)
 167         (push
 168          (if (consp elem)
 169              (format "%d:%d" (car elem) (cdr elem))
 170            (number-to-string elem))
 171          result))
 172       (mapconcat #'identity (nreverse result) ",")))))
 173
 174 (defun nnimap-open-server (server &optional defs)
 175   (if (nnimap-server-opened server)
 176       t
 177     (unless (assq 'nnimap-address defs)
 178       (setq defs (append defs (list (list 'nnimap-address server)))))
 179     (nnoo-change-server 'nnimap server defs)
 180     (or (nnimap-find-connection nntp-server-buffer)
 181         (nnimap-open-connection nntp-server-buffer))))
 182
 183 (defun nnimap-make-process-buffer (buffer)
 184   (with-current-buffer
 185       (generate-new-buffer (format "*nnimap %s %s %s*"
 186                                    nnimap-address nnimap-server-port
 187                                    (gnus-buffer-exists-p buffer)))
 188     (mm-disable-multibyte)
 189     (buffer-disable-undo)
 190     (gnus-add-buffer)
 191     (set (make-local-variable 'after-change-functions) nil)
 192     (set (make-local-variable 'nnimap-object) (make-nnimap))
 193     (push (list buffer (current-buffer)) nnimap-connection-alist)
 194     (current-buffer)))
 195
 196 (defun nnimap-open-shell-stream (name buffer host port)
 197   (let ((process (start-process name buffer shell-file-name
 198                                 shell-command-switch
 199                                 (format-spec
 200                                  nnimap-shell-program
 201                                  (format-spec-make
 202                                   ?s host
 203                                   ?p port)))))
 204     process))
 205
 206 (defun nnimap-open-connection (buffer)
 207   (with-current-buffer (nnimap-make-process-buffer buffer)
 208     (let* ((coding-system-for-read 'binary)
 209            (coding-system-for-write 'binary)
 210            (credentials
 211             (cond
 212              ((eq nnimap-stream 'network)
 213               (open-network-stream "*nnimap*" (current-buffer) nnimap-address
 214                                    (or nnimap-server-port
 215                                        (if (netrc-find-service-number "imap")
 216                                            "imap"
 217                                          "143")))
 218               (netrc-credentials nnimap-address "imap"))
 219              ((eq nnimap-stream 'stream)
 220               (nnimap-open-shell-stream
 221                "*nnimap*" (current-buffer) nnimap-address
 222                (or nnimap-server-port "imap"))
 223               (netrc-credentials nnimap-address "imap"))
 224              ((eq nnimap-stream 'ssl)
 225               (open-tls-stream "*nnimap*" (current-buffer) nnimap-address
 226                                (or nnimap-server-port
 227                                    (if (netrc-find-service-number "imaps")
 228                                        "imaps"
 229                                      "993")))
 230               (netrc-credentials nnimap-address "imaps" "imap")))))
 231       (setf (nnimap-process nnimap-object)
 232             (get-buffer-process (current-buffer)))
 233       (unless credentials
 234         (delete-process (nnimap-process nnimap-object))
 235         (error "Can't find user name/password for %s" nnimap-address))
 236       (when (and (nnimap-process nnimap-object)
 237                  (memq (process-status (nnimap-process nnimap-object))
 238                        '(open run)))
 239         (gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil)
 240         (let ((result (nnimap-command "LOGIN %S %S"
 241                                       (car credentials) (cadr credentials))))
 242           (unless (car result)
 243             (delete-process (nnimap-process nnimap-object))
 244             (error "Unable to login to the server: %s"
 245                    (mapconcat #'identity (cadr result) " ")))
 246           (setf (nnimap-capabilities nnimap-object)
 247                 (mapcar
 248                  #'upcase
 249                  (or (nnimap-find-parameter "CAPABILITY" (cdr result))
 250                      (nnimap-find-parameter
 251                       "CAPABILITY" (cdr (nnimap-command "CAPABILITY"))))))
 252           (when (member "QRESYNC" (nnimap-capabilities nnimap-object))
 253             (nnimap-command "ENABLE QRESYNC"))
 254           t)))))
 255
 256 (defun nnimap-find-parameter (parameter elems)
 257   (let (result)
 258     (dolist (elem elems)
 259       (cond
 260        ((equal (car elem) parameter)
 261         (setq result (cdr elem)))
 262        ((and (equal (car elem) "OK")
 263              (consp (cadr elem))
 264              (equal (caadr elem) parameter))
 265         (setq result (cdr (cadr elem))))))
 266     result))
 267
 268 (defun nnimap-close-server (&optional server)
 269   t)
 270
 271 (defun nnimap-request-close ()
 272   t)
 273
 274 (defun nnimap-server-opened (&optional server)
 275   (and (nnoo-current-server-p 'nnimap server)
 276        nntp-server-buffer
 277        (gnus-buffer-live-p nntp-server-buffer)
 278        (nnimap-find-connection nntp-server-buffer)))
 279
 280 (defun nnimap-status-message (&optional server)
 281   nnimap-status-string)
 282
 283 (defun nnimap-request-article (article &optional group server to-buffer)
 284   (with-current-buffer nntp-server-buffer
 285     (let ((result (nnimap-possibly-change-group group server)))
 286       (when (stringp article)
 287         (setq article (nnimap-find-article-by-message-id group article)))
 288       (when (and result
 289                  article)
 290         (erase-buffer)
 291         (nnimap-with-process-buffer
 292          (erase-buffer)
 293          (setq result
 294                (nnimap-command
 295                 (if (member "IMAP4REV1" (nnimap-capabilities nnimap-object))
 296                     "UID FETCH %d BODY.PEEK[]"
 297                   "UID FETCH %d RFC822.PEEK")
 298                 article)))
 299         (let ((buffer (nnimap-find-process-buffer (current-buffer))))
 300           (when (car result)
 301             (with-current-buffer to-buffer
 302               (insert-buffer-substring buffer)
 303               (goto-char (point-min))
 304               (let ((bytes (nnimap-get-length)))
 305                 (delete-region (line-beginning-position)
 306                                (progn (forward-line 1) (point)))
 307                 (goto-char (+ (point) bytes))
 308                 (delete-region (point) (point-max))
 309                 (nnheader-ms-strip-cr))
 310               t)))))))
 311
 312 (defun nnimap-request-group (group &optional server dont-check)
 313   (with-current-buffer nntp-server-buffer
 314     (let ((result (nnimap-possibly-change-group group server))
 315           articles)
 316       (when result
 317         (setq articles (nnimap-get-flags "1:*"))
 318         (erase-buffer)
 319         (insert
 320          (format
 321           "211 %d %d %d %S\n"
 322           (length articles)
 323           (or (caar articles) 0)
 324           (or (caar (last articles)) 0)
 325           group))
 326         t))))
 327
 328 (defun nnimap-get-flags (spec)
 329   (let ((articles nil)
 330         elems)
 331     (with-current-buffer (nnimap-buffer)
 332       (erase-buffer)
 333       (nnimap-wait-for-response (nnimap-send-command
 334                                  "UID FETCH %s FLAGS" spec))
 335       (goto-char (point-min))
 336       (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" nil t)
 337         (setq elems (nnimap-parse-line (match-string 1)))
 338         (push (cons (string-to-number (cadr (member "UID" elems)))
 339                     (cadr (member "FLAGS" elems)))
 340               articles)))
 341     (nreverse articles)))
 342
 343 (defun nnimap-close-group (group &optional server)
 344   t)
 345
 346 (deffoo nnimap-request-move-article (article group server accept-form
 347                                              &optional last internal-move-group)
 348   (when (nnimap-possibly-change-group group server)
 349     ;; If the move is internal (on the same server), just do it the easy
 350     ;; way.
 351     (let ((message-id (message-field-value "message-id")))
 352       (if internal-move-group
 353           (let ((result
 354                  (with-current-buffer (nnimap-buffer)
 355                    (nnimap-command "UID COPY %d %S"
 356                                    article
 357                                    (utf7-encode internal-move-group t)))))
 358             (when (car result)
 359               (nnimap-delete-article article)
 360               (cons internal-move-group
 361                     (nnimap-find-article-by-message-id
 362                      internal-move-group message-id))))
 363         (with-temp-buffer
 364           (let ((result (eval accept-form)))
 365             (when result
 366               (nnimap-delete-article article)
 367               result)))))))
 368
 369 (deffoo nnimap-request-expire-articles (articles group &optional server force)
 370   (cond
 371    ((not (nnimap-possibly-change-group group server))
 372     articles)
 373    (force
 374     (unless (nnimap-delete-article articles)
 375       (message "Article marked for deletion, but not expunged."))
 376     nil)
 377    (t
 378     articles)))
 379
 380 (defun nnimap-find-article-by-message-id (group message-id)
 381   (when (nnimap-possibly-change-group group nil)
 382     (with-current-buffer (nnimap-buffer)
 383       (let ((result
 384              (nnimap-command "UID SEARCH HEADER Message-Id %S" message-id))
 385             article)
 386         (when (car result)
 387           ;; Select the last instance of the message in the group.
 388           (and (setq article
 389                      (car (last (assoc "SEARCH" (cdr result)))))
 390                (string-to-number article)))))))
 391
 392 (defun nnimap-delete-article (articles)
 393   (with-current-buffer (nnimap-buffer)
 394     (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)"
 395                     (nnimap-article-ranges articles))
 396     (when (member "UIDPLUS" (nnimap-capabilities nnimap-object))
 397       (nnimap-send-command "UID EXPUNGE %s"
 398                            (nnimap-article-ranges articles))
 399       t)))
 400
 401 (deffoo nnimap-request-scan (&optional group server)
 402   (when (and (nnimap-possibly-change-group nil server)
 403              (equal group nnimap-inbox)
 404              nnimap-inbox
 405              nnimap-split-methods)
 406     (nnimap-split-incoming-mail)))
 407
 408 (defun nnimap-marks-to-flags (marks)
 409   (let (flags flag)
 410     (dolist (mark marks)
 411       (when (setq flag (cadr (assq mark nnimap-mark-alist)))
 412         (push flag flags)))
 413     flags))
 414
 415 (defun nnimap-request-set-mark (group actions &optional server)
 416   (when (nnimap-possibly-change-group group server)
 417     (let (sequence)
 418       (with-current-buffer (nnimap-find-process-buffer nntp-server-buffer)
 419         ;; Just send all the STORE commands without waiting for
 420         ;; response.  If they're successful, they're successful.
 421         (dolist (action actions)
 422           (destructuring-bind (range action marks) action
 423             (let ((flags (nnimap-marks-to-flags marks)))
 424               (when flags
 425                 (setq sequence (nnimap-send-command
 426                                 "UID STORE %s %sFLAGS.SILENT (%s)"
 427                                 (nnimap-article-ranges range)
 428                                 (if (eq action 'del)
 429                                     "-"
 430                                   "+")
 431                                 (mapconcat #'identity flags " ")))))))
 432         ;; Wait for the last command to complete to avoid later
 433         ;; syncronisation problems with the stream.
 434         (nnimap-wait-for-response sequence)))))
 435
 436 (deffoo nnimap-request-accept-article (group &optional server last)
 437   (when (nnimap-possibly-change-group nil server)
 438     (nnmail-check-syntax)
 439     (let ((message (buffer-string))
 440           (message-id (message-field-value "message-id"))
 441           sequence)
 442       (with-current-buffer nntp-server-buffer
 443         (nnimap-with-process-buffer
 444          (setq sequence (nnimap-send-command
 445                          "APPEND %S {%d}" (utf7-encode group t)
 446                          (length message)))
 447          (process-send-string (get-buffer-process (current-buffer)) message)
 448          (process-send-string (get-buffer-process (current-buffer)) "\r\n")
 449          (let ((result (nnimap-get-response sequence)))
 450            (when result
 451              (cons group
 452                    (nnimap-find-article-by-message-id group message-id)))))))))
 453
 454 (defun nnimap-add-cr ()
 455   (goto-char (point-min))
 456   (while (re-search-forward "\r?\n" nil t)
 457     (replace-match "\r\n" t t)))
 458
 459 (defun nnimap-get-groups ()
 460   (let ((result (nnimap-command "LIST \"\" \"*\""))
 461         groups)
 462     (when (car result)
 463       (dolist (line (cdr result))
 464         (when (and (equal (car line) "LIST")
 465                    (not (and (caadr line)
 466                              (string-match "noselect" (caadr line)))))
 467           (push (car (last line)) groups)))
 468       (nreverse groups))))
 469
 470 (defun nnimap-request-list (&optional server)
 471   (nnimap-possibly-change-group nil server)
 472   (with-current-buffer nntp-server-buffer
 473     (erase-buffer)
 474     (let ((groups
 475            (nnimap-with-process-buffer
 476             (nnimap-get-groups)))
 477           sequences responses)
 478       (when groups
 479         (nnimap-with-process-buffer
 480          (dolist (group groups)
 481            (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t))
 482                        group)
 483                  sequences))
 484          (nnimap-wait-for-response (caar sequences))
 485          (setq responses
 486                (nnimap-get-responses (mapcar #'car sequences))))
 487         (dolist (response responses)
 488           (let* ((sequence (car response))
 489                  (response (cadr response))
 490                  (group (cadr (assoc sequence sequences))))
 491             (when (and group
 492                        (equal (caar response) "OK"))
 493               (let ((uidnext (nnimap-find-parameter "UIDNEXT" response))
 494                     highest exists)
 495                 (dolist (elem response)
 496                   (when (equal (cadr elem) "EXISTS")
 497                     (setq exists (string-to-number (car elem)))))
 498                 (when uidnext
 499                   (setq highest (1- (string-to-number (car uidnext)))))
 500                 (cond
 501                  ((null highest)
 502                   (insert (format "%S 0 1 y\n" (utf7-decode group t))))
 503                  ((zerop exists)
 504                   ;; Empty group.
 505                   (insert (format "%S %d %d y\n"
 506                                   (utf7-decode group t) highest (1+ highest))))
 507                  (t
 508                   ;; Return the widest possible range.
 509                   (insert (format "%S %d 1 y\n" (utf7-decode group t)
 510                                   (or highest exists)))))))))
 511         t))))
 512
 513 (defun nnimap-retrieve-group-data-early (server infos)
 514   (when (nnimap-possibly-change-group nil server)
 515     (with-current-buffer (nnimap-buffer)
 516       ;; QRESYNC handling isn't implemented.
 517       (let ((qresyncp (member "notQRESYNC" (nnimap-capabilities nnimap-object)))
 518             marks groups sequences)
 519         ;; Go through the infos and gather the data needed to know
 520         ;; what and how to request the data.
 521         (dolist (info infos)
 522           (setq marks (gnus-info-marks info))
 523           (push (list (gnus-group-real-name (gnus-info-group info))
 524                       (cdr (assq 'active marks))
 525                       (cdr (assq 'uid marks)))
 526                 groups))
 527         ;; Then request the data.
 528         (erase-buffer)
 529         (dolist (elem groups)
 530           (if (and qresyncp
 531                    (nth 2 elem))
 532               (push
 533                (list 'qresync
 534                      (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))"
 535                                           (car elem)
 536                                           (car (nth 2 elem))
 537                                           (cdr (nth 2 elem)))
 538                      nil
 539                      (car elem))
 540                sequences)
 541             (let ((start
 542                    (if (nth 1 elem)
 543                        ;; Fetch the last 100 flags.
 544                        (max 1 (- (cdr (nth 1 elem)) 100))
 545                      1)))
 546               (push (list (nnimap-send-command "EXAMINE %S" (car elem))
 547                           (nnimap-send-command "UID FETCH %d:* FLAGS" start)
 548                           start
 549                           (car elem))
 550                     sequences))))
 551         sequences))))
 552
 553 (defun nnimap-finish-retrieve-group-infos (server infos sequences)
 554   (when (nnimap-possibly-change-group nil server)
 555     (with-current-buffer (nnimap-buffer)
 556       ;; Wait for the final data to trickle in.
 557       (nnimap-wait-for-response (cadar sequences))
 558       ;; Now we should have all the data we need, no matter whether
 559       ;; we're QRESYNCING, fetching all the flags from scratch, or
 560       ;; just fetching the last 100 flags per group.
 561       (nnimap-update-infos (nnimap-flags-to-marks
 562                             (nnimap-parse-flags
 563                              (nreverse sequences)))
 564                            infos))))
 565
 566 (defun nnimap-update-infos (flags infos)
 567   (dolist (info infos)
 568     (let ((group (gnus-group-real-name (gnus-info-group info))))
 569       (nnimap-update-info info (cdr (assoc group flags))))))
 570
 571 (defun nnimap-update-info (info marks)
 572   (when marks
 573     (destructuring-bind (existing flags high low uidnext start-article) marks
 574       (let ((group (gnus-info-group info))
 575             (completep (and start-article
 576                             (= start-article 1))))
 577         ;; First set the active ranges based on high/low.
 578         (if (or completep
 579                 (not (gnus-active group)))
 580             (gnus-set-active group
 581                              (if high
 582                                  (cons low high)
 583                                ;; No articles in this group.
 584                                (cons (1- uidnext) uidnext)))
 585           (setcdr (gnus-active group) high))
 586         ;; Then update the list of read articles.
 587         (let* ((unread
 588                 (gnus-compress-sequence
 589                  (gnus-set-difference
 590                   (gnus-set-difference
 591                    existing
 592                    (cdr (assoc "\\Seen" flags)))
 593                   (cdr (assoc "\\Flagged" flags)))))
 594                (read (gnus-range-difference
 595                       (cons start-article high) unread)))
 596           (when (> start-article 1)
 597             (setq read
 598                   (gnus-range-nconcat
 599                    (gnus-sorted-range-intersection
 600                     (cons 1 start-article)
 601                     (gnus-info-read info))
 602                    read)))
 603           (gnus-info-set-read info read)
 604           ;; Update the marks.
 605           (setq marks (gnus-info-marks info))
 606           ;; Note the active level for the next run-through.
 607           (let ((active (assq 'active marks)))
 608             (if active
 609                 (setcdr active (gnus-active group))
 610               (push (cons 'active (gnus-active group)) marks)))
 611           (dolist (type (cdr nnimap-mark-alist))
 612             (let ((old-marks (assoc (car type) marks))
 613                   (new-marks (gnus-compress-sequence
 614                               (cdr (assoc (cadr type) flags)))))
 615               (setq marks (delq old-marks marks))
 616               (pop old-marks)
 617               (when (and old-marks
 618                          (> start-article 1))
 619                 (setq old-marks (gnus-range-difference
 620                                  (cons start-article high)
 621                                  old-marks))
 622                 (setq new-marks (gnus-range-nconcat old-marks new-marks)))
 623               (when new-marks
 624                 (push (cons (car type) new-marks) marks)))
 625             (gnus-info-set-marks info marks)))))))
 626
 627 (defun nnimap-flags-to-marks (groups)
 628   (let (data group totalp uidnext articles start-article mark)
 629     (dolist (elem groups)
 630       (setq group (car elem)
 631             uidnext (cadr elem)
 632             start-article (caddr elem)
 633             articles (cdddr elem))
 634       (let ((high (caar articles))
 635             marks low existing)
 636         (dolist (article articles)
 637           (setq low (car article))
 638           (push (car article) existing)
 639           (dolist (flag (cdr article))
 640             (setq mark (assoc flag marks))
 641             (if (not mark)
 642                 (push (list flag (car article)) marks)
 643               (setcdr mark (cons (car article) (cdr mark)))))
 644           (push (list group existing marks high low uidnext start-article)
 645                 data))))
 646     data))
 647
 648 (defun nnimap-parse-flags (sequences)
 649   (goto-char (point-min))
 650   (let (start end articles groups uidnext elems)
 651     (dolist (elem sequences)
 652       (destructuring-bind (group-sequence flag-sequence totalp group) elem
 653         ;; The EXAMINE was successful.
 654         (when (and (search-forward (format "\n%d OK " group-sequence) nil t)
 655                    (progn
 656                      (forward-line 1)
 657                      (setq start (point))
 658                      (if (re-search-backward "UIDNEXT \\([0-9]+\\)"
 659                                                (or end (point-min)) t)
 660                          (setq uidnext (string-to-number (match-string 1)))
 661                        (setq uidnext nil))
 662                      (goto-char start))
 663                    ;; The UID FETCH FLAGS was successful.
 664                    (search-forward (format "\n%d OK " flag-sequence) nil t))
 665           (setq end (point))
 666           (goto-char start)
 667           (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" end t)
 668             (setq elems (nnimap-parse-line (match-string 1)))
 669             (push (cons (string-to-number (cadr (member "UID" elems)))
 670                         (cadr (member "FLAGS" elems)))
 671                   articles))
 672           (push (nconc (list group uidnext totalp) articles) groups)
 673           (setq articles nil))))
 674     groups))
 675
 676 (defun nnimap-find-process-buffer (buffer)
 677   (cadr (assoc buffer nnimap-connection-alist)))
 678
 679 (defun nnimap-request-post (&optional server)
 680   (setq nnimap-status-string "Read-only server")
 681   nil)
 682
 683 (defun nnimap-possibly-change-group (group server)
 684   (when (and server
 685              (not (nnimap-server-opened server)))
 686     (nnimap-open-server server))
 687   (if (not group)
 688       t
 689     (with-current-buffer (nnimap-buffer)
 690       (if (equal group (nnimap-group nnimap-object))
 691           t
 692         (let ((result (nnimap-command "SELECT %S" (utf7-encode group t))))
 693           (when (car result)
 694             (setf (nnimap-group nnimap-object) group)
 695             result))))))
 696
 697 (defun nnimap-find-connection (buffer)
 698   "Find the connection delivering to BUFFER."
 699   (let ((entry (assoc buffer nnimap-connection-alist)))
 700     (when entry
 701       (if (and (buffer-name (cadr entry))
 702                (get-buffer-process (cadr entry))
 703                (memq (process-status (get-buffer-process (cadr entry)))
 704                      '(open run)))
 705           (get-buffer-process (cadr entry))
 706         (setq nnimap-connection-alist (delq entry nnimap-connection-alist))
 707         nil))))
 708
 709 (defvar nnimap-sequence 0)
 710
 711 (defun nnimap-send-command (&rest args)
 712   (process-send-string
 713    (get-buffer-process (current-buffer))
 714    (nnimap-log-command
 715     (format "%d %s\r\n"
 716             (incf nnimap-sequence)
 717             (apply #'format args))))
 718   nnimap-sequence)
 719
 720 (defun nnimap-log-command (command)
 721   (with-current-buffer (get-buffer-create "*imap log*")
 722     (goto-char (point-max))
 723     (insert (format-time-string "%H:%M:%S") " " command))
 724   command)
 725
 726 (defun nnimap-command (&rest args)
 727   (erase-buffer)
 728   (let* ((sequence (apply #'nnimap-send-command args))
 729          (response (nnimap-get-response sequence)))
 730     (if (equal (caar response) "OK")
 731         (cons t response)
 732       (nnheader-report 'nnimap "%s"
 733                        (mapconcat #'identity (car response) " "))
 734       nil)))
 735
 736 (defun nnimap-get-response (sequence)
 737   (nnimap-wait-for-response sequence)
 738   (nnimap-parse-response))
 739
 740 (defun nnimap-wait-for-response (sequence &optional messagep)
 741   (goto-char (point-max))
 742   (while (or (bobp)
 743              (progn
 744                (forward-line -1)
 745                (not (looking-at (format "^%d .*\n" sequence)))))
 746     (when messagep
 747       (message "Read %dKB" (/ (buffer-size) 1000)))
 748     (nnheader-accept-process-output (get-buffer-process (current-buffer)))
 749     (goto-char (point-max))))
 750
 751 (defun nnimap-parse-response ()
 752   (let ((lines (split-string (nnimap-last-response-string) "\r\n" t))
 753         result)
 754     (dolist (line lines)
 755       (push (cdr (nnimap-parse-line line)) result))
 756     ;; Return the OK/error code first, and then all the "continuation
 757     ;; lines" afterwards.
 758     (cons (pop result)
 759           (nreverse result))))
 760
 761 ;; Parse an IMAP response line lightly.  They look like
 762 ;; "* OK [UIDVALIDITY 1164213559] UIDs valid", typically, so parse
 763 ;; the lines into a list of strings and lists of string.
 764 (defun nnimap-parse-line (line)
 765   (let (char result)
 766     (with-temp-buffer
 767       (insert line)
 768       (goto-char (point-min))
 769       (while (not (eobp))
 770         (if (eql (setq char (following-char)) ? )
 771             (forward-char 1)
 772           (push
 773            (cond
 774             ((eql char ?\[)
 775              (split-string (buffer-substring
 776                             (1+ (point)) (1- (search-forward "]")))))
 777             ((eql char ?\()
 778              (split-string (buffer-substring
 779                             (1+ (point)) (1- (search-forward ")")))))
 780             ((eql char ?\")
 781              (forward-char 1)
 782              (buffer-substring (point) (1- (search-forward "\""))))
 783             (t
 784              (buffer-substring (point) (if (search-forward " " nil t)
 785                                            (1- (point))
 786                                          (goto-char (point-max))))))
 787            result)))
 788       (nreverse result))))
 789
 790 (defun nnimap-last-response-string ()
 791   (save-excursion
 792     (forward-line 1)
 793     (let ((end (point)))
 794       (forward-line -1)
 795       (when (not (bobp))
 796         (forward-line -1)
 797         (while (and (not (bobp))
 798                     (eql (following-char) ?*))
 799           (forward-line -1))
 800         (unless (eql (following-char) ?*)
 801           (forward-line 1)))
 802       (buffer-substring (point) end))))
 803
 804 (defun nnimap-get-responses (sequences)
 805   (let (responses)
 806     (dolist (sequence sequences)
 807       (goto-char (point-min))
 808       (when (re-search-forward (format "^%d " sequence) nil t)
 809         (push (list sequence (nnimap-parse-response))
 810               responses)))
 811     responses))
 812
 813 (defvar nnimap-incoming-split-list nil)
 814
 815 (defun nnimap-fetch-inbox (articles)
 816   (erase-buffer)
 817   (nnimap-wait-for-response
 818    (nnimap-send-command
 819     "UID FETCH %s %s"
 820     (nnimap-article-ranges articles)
 821     (format "(UID %s%s)"
 822             (format
 823              (if (member "IMAP4REV1"
 824                          (nnimap-capabilities nnimap-object))
 825                  "BODY.PEEK[HEADER] BODY.PEEK"
 826                "RFC822.PEEK"))
 827             (if nnimap-split-download-body-default
 828                 ""
 829               "[1]")))
 830    t))
 831
 832 (defun nnimap-split-incoming-mail ()
 833   (with-current-buffer (nnimap-buffer)
 834     (let ((nnimap-incoming-split-list nil)
 835           (nnmail-split-methods nnimap-split-methods)
 836           (nnmail-inhibit-default-split-group t)
 837           (groups (nnimap-get-groups))
 838           new-articles)
 839       (erase-buffer)
 840       (nnimap-command "SELECT %S" nnimap-inbox)
 841       (setq new-articles (nnimap-new-articles (nnimap-get-flags "1:*")))
 842       (when new-articles
 843         (nnimap-fetch-inbox new-articles)
 844         (nnimap-transform-split-mail)
 845         (nnheader-ms-strip-cr)
 846         (nnmail-cache-open)
 847         (nnmail-split-incoming (current-buffer)
 848                                #'nnimap-save-mail-spec
 849                                nil nil
 850                                #'nnimap-dummy-active-number)
 851         (when nnimap-incoming-split-list
 852           (let ((specs (nnimap-make-split-specs nnimap-incoming-split-list))
 853                 sequences)
 854             ;; Create any groups that doesn't already exist on the
 855             ;; server first.
 856             (dolist (spec specs)
 857               (unless (member (car spec) groups)
 858                 (nnimap-command "CREATE %S" (utf7-encode (car spec) t))))
 859             ;; Then copy over all the messages.
 860             (erase-buffer)
 861             (dolist (spec specs)
 862               (let ((group (car spec))
 863                     (ranges (cdr spec)))
 864                 (push (list (nnimap-send-command "UID COPY %s %S"
 865                                                  (nnimap-article-ranges ranges)
 866                                                  (utf7-encode group t))
 867                             ranges)
 868                       sequences)))
 869             ;; Wait for the last COPY response...
 870             (when sequences
 871               (nnimap-wait-for-response (caar sequences))
 872               ;; And then mark the successful copy actions as deleted,
 873               ;; and possibly expunge them.
 874               (nnimap-mark-and-expunge-incoming
 875                (nnimap-parse-copied-articles sequences)))))))))
 876
 877 (defun nnimap-mark-and-expunge-incoming (range)
 878   (when range
 879     (setq range (nnimap-article-ranges range))
 880     (nnimap-send-command
 881      "UID STORE %s +FLAGS.SILENT (\\Deleted)" range)
 882     (cond
 883      ;; If the server supports it, we now delete the message we have
 884      ;; just copied over.
 885      ((member "UIDPLUS" (nnimap-capabilities nnimap-object))
 886       (nnimap-send-command "UID EXPUNGE %s" range))
 887      ;; If it doesn't support UID EXPUNGE, then we only expunge if the
 888      ;; user has configured it.
 889      (nnimap-expunge-inbox
 890       (nnimap-send-command "EXPUNGE")))))
 891
 892 (defun nnimap-parse-copied-articles (sequences)
 893   (let (sequence copied range)
 894     (goto-char (point-min))
 895     (while (re-search-forward "^\\([0-9]+\\) OK " nil t)
 896       (setq sequence (string-to-number (match-string 1)))
 897       (when (setq range (cadr (assq sequence sequences)))
 898         (push (gnus-uncompress-range range) copied)))
 899     (gnus-compress-sequence (sort (apply #'nconc copied) #'<))))
 900
 901 (defun nnimap-new-articles (flags)
 902   (let (new)
 903     (dolist (elem flags)
 904       (when (or (null (cdr elem))
 905                 (and (not (member "\\Deleted" (cdr elem)))
 906                      (not (member "\\Seen" (cdr elem)))))
 907         (push (car elem) new)))
 908     (gnus-compress-sequence (nreverse new))))
 909
 910 (defun nnimap-make-split-specs (list)
 911   (let ((specs nil)
 912         entry)
 913     (dolist (elem list)
 914       (destructuring-bind (article spec) elem
 915         (dolist (group (delete nil (mapcar #'car spec)))
 916           (unless (setq entry (assoc group specs))
 917             (push (setq entry (list group)) specs))
 918           (setcdr entry (cons article (cdr entry))))))
 919     (dolist (entry specs)
 920       (setcdr entry (gnus-compress-sequence (sort (cdr entry) #'<))))
 921     specs))
 922
 923 (defun nnimap-transform-split-mail ()
 924   (goto-char (point-min))
 925   (let (article bytes)
 926     (block nil
 927       (while (not (eobp))
 928         (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
 929           (delete-region (point) (progn (forward-line 1) (point)))
 930           (when (eobp)
 931             (return)))
 932         (setq article (match-string 1)
 933               bytes (nnimap-get-length))
 934         (delete-region (line-beginning-position) (line-end-position))
 935         ;; Insert MMDF separator, and a way to remember what this
 936         ;; article UID is.
 937         (insert (format "\^A\^A\^A\^A\n\nX-nnimap-article: %s" article))
 938         (forward-char (1+ bytes))
 939         (setq bytes (nnimap-get-length))
 940         (delete-region (line-beginning-position) (line-end-position))
 941         (forward-char (1+ bytes))
 942         (delete-region (line-beginning-position) (line-end-position))))))
 943
 944 (defun nnimap-dummy-active-number (group &optional server)
 945   1)
 946
 947 (defun nnimap-save-mail-spec (group-art &optional server full-nov)
 948   (let (article)
 949     (goto-char (point-min))
 950     (if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t))
 951         (error "Invalid nnimap mail")
 952       (setq article (string-to-number (match-string 1))))
 953     (push (list article group-art)
 954           nnimap-incoming-split-list)))
 955
 956 (provide 'nnimap)
 957
 958 ;;; nnimap.el ends here