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