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