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