cgit.sxemacs.org Git - gnus/blob - lisp/nnimap.el

   1 ;;; nnimap.el --- IMAP interface for Gnus
   2
   3 ;; Copyright (C) 2010-2011 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 ;; For Emacs <22.2 and XEmacs.
  30 (eval-and-compile
  31   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  32
  33 (eval-and-compile
  34   (require 'nnheader))
  35
  36 (eval-when-compile
  37   (require 'cl))
  38
  39 (require 'nnheader)
  40 (require 'gnus-util)
  41 (require 'gnus)
  42 (require 'nnoo)
  43 (require 'netrc)
  44 (require 'utf7)
  45 (require 'tls)
  46 (require 'parse-time)
  47 (require 'nnmail)
  48 (require 'proto-stream)
  49
  50 (autoload 'auth-source-forget+ "auth-source")
  51 (autoload 'auth-source-search "auth-source")
  52
  53 (nnoo-declare nnimap)
  54
  55 (defvoo nnimap-address nil
  56   "The address of the IMAP server.")
  57
  58 (defvoo nnimap-server-port nil
  59   "The IMAP port used.
  60 If nnimap-stream is `ssl', this will default to `imaps'.  If not,
  61 it will default to `imap'.")
  62
  63 (defvoo nnimap-stream 'undecided
  64   "How nnimap will talk to the IMAP server.
  65 Values are `ssl', `network', `starttls' or `shell'.
  66 The default is to try `ssl' first, and then `network'.")
  67
  68 (defvoo nnimap-shell-program (if (boundp 'imap-shell-program)
  69                                  (if (listp imap-shell-program)
  70                                      (car imap-shell-program)
  71                                    imap-shell-program)
  72                                "ssh %s imapd"))
  73
  74 (defvoo nnimap-inbox nil
  75   "The mail box where incoming mail arrives and should be split out of.")
  76
  77 (defvoo nnimap-split-methods nil
  78   "How mail is split.
  79 Uses the same syntax as nnmail-split-methods")
  80
  81 (defvoo nnimap-split-fancy nil
  82   "Uses the same syntax as nnmail-split-fancy.")
  83
  84 (defvoo nnimap-unsplittable-articles '(%Deleted %Seen)
  85   "Articles with the flags in the list will not be considered when splitting.")
  86
  87 (make-obsolete-variable 'nnimap-split-rule "see `nnimap-split-methods'"
  88                         "Emacs 24.1")
  89
  90 (defvoo nnimap-authenticator nil
  91   "How nnimap authenticate itself to the server.
  92 Possible choices are nil (use default methods) or `anonymous'.")
  93
  94 (defvoo nnimap-expunge t
  95   "If non-nil, expunge articles after deleting them.
  96 This is always done if the server supports UID EXPUNGE, but it's
  97 not done by default on servers that doesn't support that command.")
  98
  99 (defvoo nnimap-streaming t
 100   "If non-nil, try to use streaming commands with IMAP servers.
 101 Switching this off will make nnimap slower, but it helps with
 102 some servers.")
 103
 104 (defvoo nnimap-connection-alist nil)
 105
 106 (defvoo nnimap-current-infos nil)
 107
 108 (defvoo nnimap-fetch-partial-articles nil
 109   "If non-nil, Gnus will fetch partial articles.
 110 If t, nnimap will fetch only the first part.  If a string, it
 111 will fetch all parts that have types that match that string.  A
 112 likely value would be \"text/\" to automatically fetch all
 113 textual parts.")
 114
 115 (defvar nnimap-process nil)
 116
 117 (defvar nnimap-status-string "")
 118
 119 (defvar nnimap-split-download-body-default nil
 120   "Internal variable with default value for `nnimap-split-download-body'.")
 121
 122 (defvar nnimap-keepalive-timer nil)
 123 (defvar nnimap-process-buffers nil)
 124
 125 (defstruct nnimap
 126   group process commands capabilities select-result newlinep server
 127   last-command-time greeting examined stream-type)
 128
 129 (defvar nnimap-object nil)
 130
 131 (defvar nnimap-mark-alist
 132   '((read "\\Seen" %Seen)
 133     (tick "\\Flagged" %Flagged)
 134     (reply "\\Answered" %Answered)
 135     (expire "gnus-expire")
 136     (dormant "gnus-dormant")
 137     (score "gnus-score")
 138     (save "gnus-save")
 139     (download "gnus-download")
 140     (forward "gnus-forward")))
 141
 142 (defvar nnimap-quirks
 143   '(("QRESYNC" "Zimbra" "QRESYNC ")))
 144
 145 (defun nnimap-buffer ()
 146   (nnimap-find-process-buffer nntp-server-buffer))
 147
 148 (defun nnimap-header-parameters ()
 149   (format "(UID RFC822.SIZE BODYSTRUCTURE %s)"
 150           (format
 151            (if (nnimap-ver4-p)
 152                "BODY.PEEK[HEADER.FIELDS %s]"
 153              "RFC822.HEADER.LINES %s")
 154            (append '(Subject From Date Message-Id
 155                              References In-Reply-To Xref)
 156                    nnmail-extra-headers))))
 157
 158 (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old)
 159   (with-current-buffer nntp-server-buffer
 160     (erase-buffer)
 161     (when (nnimap-possibly-change-group group server)
 162       (with-current-buffer (nnimap-buffer)
 163         (erase-buffer)
 164         (nnimap-wait-for-response
 165          (nnimap-send-command
 166           "UID FETCH %s %s"
 167           (nnimap-article-ranges (gnus-compress-sequence articles))
 168           (nnimap-header-parameters))
 169          t)
 170         (nnimap-transform-headers)
 171         (nnheader-remove-cr-followed-by-lf))
 172       (insert-buffer-substring
 173        (nnimap-find-process-buffer (current-buffer))))
 174     'headers))
 175
 176 (defun nnimap-transform-headers ()
 177   (goto-char (point-min))
 178   (let (article bytes lines size string)
 179     (block nil
 180       (while (not (eobp))
 181         (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
 182           (delete-region (point) (progn (forward-line 1) (point)))
 183           (when (eobp)
 184             (return)))
 185         (setq article (match-string 1))
 186         ;; Unfold quoted {number} strings.
 187         (while (re-search-forward "[^]][ (]{\\([0-9]+\\)}\r?\n"
 188                                   (1+ (line-end-position)) t)
 189           (setq size (string-to-number (match-string 1)))
 190           (delete-region (+ (match-beginning 0) 2) (point))
 191           (setq string (buffer-substring (point) (+ (point) size)))
 192           (delete-region (point) (+ (point) size))
 193           (insert (format "%S" string)))
 194         (setq bytes (nnimap-get-length)
 195               lines nil)
 196         (beginning-of-line)
 197         (setq size
 198               (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)"
 199                                       (line-end-position)
 200                                       t)
 201                    (match-string 1)))
 202         (beginning-of-line)
 203         (when (search-forward "BODYSTRUCTURE" (line-end-position) t)
 204           (let ((structure (ignore-errors
 205                              (read (current-buffer)))))
 206             (while (and (consp structure)
 207                         (not (stringp (car structure))))
 208               (setq structure (car structure)))
 209             (setq lines (nth 7 structure))))
 210         (delete-region (line-beginning-position) (line-end-position))
 211         (insert (format "211 %s Article retrieved." article))
 212         (forward-line 1)
 213         (when size
 214           (insert (format "Chars: %s\n" size)))
 215         (when lines
 216           (insert (format "Lines: %s\n" lines)))
 217         (unless (re-search-forward "^\r$" nil t)
 218           (goto-char (point-max)))
 219         (delete-region (line-beginning-position) (line-end-position))
 220         (insert ".")
 221         (forward-line 1)))))
 222
 223 (defun nnimap-unfold-quoted-lines ()
 224   ;; Unfold quoted {number} strings.
 225   (let (size string)
 226     (while (re-search-forward " {\\([0-9]+\\)}\r?\n" nil t)
 227       (setq size (string-to-number (match-string 1)))
 228       (delete-region (1+ (match-beginning 0)) (point))
 229       (setq string (buffer-substring (point) (+ (point) size)))
 230       (delete-region (point) (+ (point) size))
 231       (insert (format "%S" string)))))
 232
 233 (defun nnimap-get-length ()
 234   (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t)
 235        (string-to-number (match-string 1))))
 236
 237 (defun nnimap-article-ranges (ranges)
 238   (let (result)
 239     (cond
 240      ((numberp ranges)
 241       (number-to-string ranges))
 242      ((numberp (cdr ranges))
 243       (format "%d:%d" (car ranges) (cdr ranges)))
 244      (t
 245       (dolist (elem ranges)
 246         (push
 247          (if (consp elem)
 248              (format "%d:%d" (car elem) (cdr elem))
 249            (number-to-string elem))
 250          result))
 251       (mapconcat #'identity (nreverse result) ",")))))
 252
 253 (deffoo nnimap-open-server (server &optional defs)
 254   (if (nnimap-server-opened server)
 255       t
 256     (unless (assq 'nnimap-address defs)
 257       (setq defs (append defs (list (list 'nnimap-address server)))))
 258     (nnoo-change-server 'nnimap server defs)
 259     (or (nnimap-find-connection nntp-server-buffer)
 260         (nnimap-open-connection nntp-server-buffer))))
 261
 262 (defun nnimap-make-process-buffer (buffer)
 263   (with-current-buffer
 264       (generate-new-buffer (format "*nnimap %s %s %s*"
 265                                    nnimap-address nnimap-server-port
 266                                    (gnus-buffer-exists-p buffer)))
 267     (mm-disable-multibyte)
 268     (buffer-disable-undo)
 269     (gnus-add-buffer)
 270     (set (make-local-variable 'after-change-functions) nil)
 271     (set (make-local-variable 'nnimap-object)
 272          (make-nnimap :server (nnoo-current-server 'nnimap)))
 273     (push (list buffer (current-buffer)) nnimap-connection-alist)
 274     (push (current-buffer) nnimap-process-buffers)
 275     (current-buffer)))
 276
 277 (defun nnimap-credentials (address ports &optional inhibit-create)
 278   (let* ((found (nth 0 (auth-source-search :max 1
 279                                            :host address
 280                                            :port ports
 281                                            :create (if inhibit-create
 282                                                        nil
 283                                                      (null ports)))))
 284          (user (plist-get found :user))
 285          (secret (plist-get found :secret))
 286          (secret (if (functionp secret) (funcall secret) secret)))
 287     (if found
 288         (list user secret)
 289       nil)))
 290
 291 (defun nnimap-keepalive ()
 292   (let ((now (current-time)))
 293     (dolist (buffer nnimap-process-buffers)
 294       (when (buffer-name buffer)
 295         (with-current-buffer buffer
 296           (when (and nnimap-object
 297                      (nnimap-last-command-time nnimap-object)
 298                      (> (gnus-float-time
 299                          (time-subtract
 300                           now
 301                           (nnimap-last-command-time nnimap-object)))
 302                         ;; More than five minutes since the last command.
 303                         (* 5 60)))
 304             (nnimap-send-command "NOOP")))))))
 305
 306 (defun nnimap-open-connection (buffer)
 307   ;; Be backwards-compatible -- the earlier value of nnimap-stream was
 308   ;; `ssl' when nnimap-server-port was nil.  Sort of.
 309   (when (and nnimap-server-port
 310              (eq nnimap-stream 'undecided))
 311     (setq nnimap-stream 'ssl))
 312   (let ((stream
 313          (if (eq nnimap-stream 'undecided)
 314              (loop for type in '(ssl network)
 315                    for stream = (let ((nnimap-stream type))
 316                                   (nnimap-open-connection-1 buffer))
 317                    while (eq stream 'no-connect)
 318                    finally (return stream))
 319            (nnimap-open-connection-1 buffer))))
 320     (if (eq stream 'no-connect)
 321         nil
 322       stream)))
 323
 324 (defun nnimap-open-connection-1 (buffer)
 325   (unless nnimap-keepalive-timer
 326     (setq nnimap-keepalive-timer (run-at-time (* 60 15) (* 60 15)
 327                                               'nnimap-keepalive)))
 328   (with-current-buffer (nnimap-make-process-buffer buffer)
 329     (let* ((coding-system-for-read 'binary)
 330            (coding-system-for-write 'binary)
 331            (port nil)
 332            (ports
 333             (cond
 334              ((or (eq nnimap-stream 'network)
 335                   (eq nnimap-stream 'starttls))
 336               (nnheader-message 7 "Opening connection to %s..."
 337                                 nnimap-address)
 338               '("143" "imap"))
 339              ((eq nnimap-stream 'shell)
 340               (nnheader-message 7 "Opening connection to %s via shell..."
 341                                 nnimap-address)
 342               '("imap"))
 343              ((memq nnimap-stream '(ssl tls))
 344               (nnheader-message 7 "Opening connection to %s via tls..."
 345                                 nnimap-address)
 346               '("143" "993" "imap" "imaps"))
 347              (t
 348               (error "Unknown stream type: %s" nnimap-stream))))
 349            (proto-stream-always-use-starttls t)
 350            login-result credentials)
 351       (when nnimap-server-port
 352         (setq ports (append ports (list nnimap-server-port))))
 353       (destructuring-bind (stream greeting capabilities stream-type)
 354           (open-protocol-stream
 355            "*nnimap*" (current-buffer) nnimap-address (car (last ports))
 356            :type nnimap-stream
 357            :shell-command nnimap-shell-program
 358            :capability-command "1 CAPABILITY\r\n"
 359            :success " OK "
 360            :starttls-function
 361            (lambda (capabilities)
 362              (when (gnus-string-match-p "STARTTLS" capabilities)
 363                "1 STARTTLS\r\n")))
 364         (setf (nnimap-process nnimap-object) stream)
 365         (setf (nnimap-stream-type nnimap-object) stream-type)
 366         (if (not stream)
 367             (progn
 368               (nnheader-report 'nnimap "Unable to contact %s:%s via %s"
 369                                nnimap-address port nnimap-stream)
 370               'no-connect)
 371           (gnus-set-process-query-on-exit-flag stream nil)
 372           (if (not (gnus-string-match-p "[*.] \\(OK\\|PREAUTH\\)" greeting))
 373               (nnheader-report 'nnimap "%s" greeting)
 374             ;; Store the greeting (for debugging purposes).
 375             (setf (nnimap-greeting nnimap-object) greeting)
 376             (setf (nnimap-capabilities nnimap-object)
 377                   (mapcar #'upcase
 378                           (split-string capabilities)))
 379             (unless (gnus-string-match-p "[*.] PREAUTH" greeting)
 380               (if (not (setq credentials
 381                              (if (eq nnimap-authenticator 'anonymous)
 382                                  (list "anonymous"
 383                                        (message-make-address))
 384                                ;; Look for the credentials based on
 385                                ;; the virtual server name and the address
 386                                (nnimap-credentials
 387                                 (list
 388                                  (nnoo-current-server 'nnimap)
 389                                  nnimap-address)
 390                                 ports t))))
 391                   (setq nnimap-object nil)
 392                 (setq login-result
 393                       (nnimap-login (car credentials) (cadr credentials)))
 394                 (unless (car login-result)
 395                   ;; If the login failed, then forget the credentials
 396                   ;; that are now possibly cached.
 397                   (dolist (host (list (nnoo-current-server 'nnimap)
 398                                       nnimap-address))
 399                     (dolist (port ports)
 400                       (auth-source-forget+ :host host :protocol port)))
 401                   (delete-process (nnimap-process nnimap-object))
 402                   (setq nnimap-object nil))))
 403             (when nnimap-object
 404               (when (nnimap-capability "QRESYNC")
 405                 (nnimap-command "ENABLE QRESYNC"))
 406               (nnimap-process nnimap-object))))))))
 407
 408 (autoload 'rfc2104-hash "rfc2104")
 409
 410 (defun nnimap-login (user password)
 411   (cond
 412    ;; Prefer plain LOGIN if it's enabled (since it requires fewer
 413    ;; round trips than CRAM-MD5, and it's less likely to be buggy),
 414    ;; and we're using an encrypted connection.
 415    ((and (not (nnimap-capability "LOGINDISABLED"))
 416          (eq (nnimap-stream-type nnimap-object) 'tls))
 417     (nnimap-command "LOGIN %S %S" user password))
 418    ((nnimap-capability "AUTH=CRAM-MD5")
 419     (erase-buffer)
 420     (let ((sequence (nnimap-send-command "AUTHENTICATE CRAM-MD5"))
 421           (challenge (nnimap-wait-for-line "^\\+\\(.*\\)\n")))
 422       (process-send-string
 423        (get-buffer-process (current-buffer))
 424        (concat
 425         (base64-encode-string
 426          (concat user " "
 427                  (rfc2104-hash 'md5 64 16 password
 428                                (base64-decode-string challenge))))
 429         "\r\n"))
 430       (nnimap-wait-for-response sequence)))
 431    ((not (nnimap-capability "LOGINDISABLED"))
 432     (nnimap-command "LOGIN %S %S" user password))
 433    ((nnimap-capability "AUTH=PLAIN")
 434     (nnimap-command
 435      "AUTHENTICATE PLAIN %s"
 436      (base64-encode-string
 437       (format "\000%s\000%s"
 438               (nnimap-quote-specials user)
 439               (nnimap-quote-specials password)))))))
 440
 441 (defun nnimap-quote-specials (string)
 442   (with-temp-buffer
 443     (insert string)
 444     (goto-char (point-min))
 445     (while (re-search-forward "[\\\"]" nil t)
 446       (forward-char -1)
 447       (insert "\\")
 448       (forward-char 1))
 449     (buffer-string)))
 450
 451 (defun nnimap-find-parameter (parameter elems)
 452   (let (result)
 453     (dolist (elem elems)
 454       (cond
 455        ((equal (car elem) parameter)
 456         (setq result (cdr elem)))
 457        ((and (equal (car elem) "OK")
 458              (consp (cadr elem))
 459              (equal (caadr elem) parameter))
 460         (setq result (cdr (cadr elem))))))
 461     result))
 462
 463 (deffoo nnimap-close-server (&optional server)
 464   (when (nnoo-change-server 'nnimap server nil)
 465     (ignore-errors
 466       (delete-process (get-buffer-process (nnimap-buffer))))
 467     (nnoo-close-server 'nnimap server)
 468     t))
 469
 470 (deffoo nnimap-request-close ()
 471   t)
 472
 473 (deffoo nnimap-server-opened (&optional server)
 474   (and (nnoo-current-server-p 'nnimap server)
 475        nntp-server-buffer
 476        (gnus-buffer-live-p nntp-server-buffer)
 477        (nnimap-find-connection nntp-server-buffer)))
 478
 479 (deffoo nnimap-status-message (&optional server)
 480   nnimap-status-string)
 481
 482 (deffoo nnimap-request-article (article &optional group server to-buffer)
 483   (with-current-buffer nntp-server-buffer
 484     (let ((result (nnimap-possibly-change-group group server))
 485           parts structure)
 486       (when (stringp article)
 487         (setq article (nnimap-find-article-by-message-id group article)))
 488       (when (and result
 489                  article)
 490         (erase-buffer)