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