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