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