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