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

   1 ;;; imap.el --- imap library
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005 Free Software Foundation, Inc.
   5
   6 ;; Author: Simon Josefsson <jas@pdc.kth.se>
   7 ;; Keywords: mail
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; imap.el is a elisp library providing an interface for talking to
  29 ;; IMAP servers.
  30 ;;
  31 ;; imap.el is roughly divided in two parts, one that parses IMAP
  32 ;; responses from the server and storing data into buffer-local
  33 ;; variables, and one for utility functions which send commands to
  34 ;; server, waits for an answer, and return information.  The latter
  35 ;; part is layered on top of the previous.
  36 ;;
  37 ;; The imap.el API consist of the following functions, other functions
  38 ;; in this file should not be called directly and the result of doing
  39 ;; so are at best undefined.
  40 ;;
  41 ;; Global commands:
  42 ;;
  43 ;; imap-open,       imap-opened,    imap-authenticate, imap-close,
  44 ;; imap-capability, imap-namespace, imap-error-text
  45 ;;
  46 ;; Mailbox commands:
  47 ;;
  48 ;; imap-mailbox-get,       imap-mailbox-map,         imap-current-mailbox,
  49 ;; imap-current-mailbox-p, imap-search,              imap-mailbox-select,
  50 ;; imap-mailbox-examine,   imap-mailbox-unselect,    imap-mailbox-expunge
  51 ;; imap-mailbox-close,     imap-mailbox-create,      imap-mailbox-delete
  52 ;; imap-mailbox-rename,    imap-mailbox-lsub,        imap-mailbox-list
  53 ;; imap-mailbox-subscribe, imap-mailbox-unsubscribe, imap-mailbox-status
  54 ;; imap-mailbox-acl-get,   imap-mailbox-acl-set,     imap-mailbox-acl-delete
  55 ;;
  56 ;; Message commands:
  57 ;;
  58 ;; imap-fetch-asynch,                 imap-fetch,
  59 ;; imap-current-message,              imap-list-to-message-set,
  60 ;; imap-message-get,                  imap-message-map
  61 ;; imap-message-envelope-date,        imap-message-envelope-subject,
  62 ;; imap-message-envelope-from,        imap-message-envelope-sender,
  63 ;; imap-message-envelope-reply-to,    imap-message-envelope-to,
  64 ;; imap-message-envelope-cc,          imap-message-envelope-bcc
  65 ;; imap-message-envelope-in-reply-to, imap-message-envelope-message-id
  66 ;; imap-message-body,                 imap-message-flag-permanent-p
  67 ;; imap-message-flags-set,            imap-message-flags-del
  68 ;; imap-message-flags-add,            imap-message-copyuid
  69 ;; imap-message-copy,                 imap-message-appenduid
  70 ;; imap-message-append,               imap-envelope-from
  71 ;; imap-body-lines
  72 ;;
  73 ;; It is my hope that these commands should be pretty self
  74 ;; explanatory for someone that know IMAP.  All functions have
  75 ;; additional documentation on how to invoke them.
  76 ;;
  77 ;; imap.el support RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1), implemented
  78 ;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
  79 ;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,
  80 ;; LOGINDISABLED) (with use of external library starttls.el and
  81 ;; program starttls), and the GSSAPI / kerberos V4 sections of RFC1731
  82 ;; (with use of external program `imtest'), RFC2971 (ID).  It also
  83 ;; take advantage the UNSELECT extension in Cyrus IMAPD.
  84 ;;
  85 ;; Without the work of John McClary Prevost and Jim Radford this library
  86 ;; would not have seen the light of day.  Many thanks.
  87 ;;
  88 ;; This is a transcript of short interactive session for demonstration
  89 ;; purposes.
  90 ;;
  91 ;; (imap-open "my.mail.server")
  92 ;; => " *imap* my.mail.server:0"
  93 ;;
  94 ;; The rest are invoked with current buffer as the buffer returned by
  95 ;; `imap-open'.  It is possible to do all without this, but it would
  96 ;; look ugly here since `buffer' is always the last argument for all
  97 ;; imap.el API functions.
  98 ;;
  99 ;; (imap-authenticate "myusername" "mypassword")
 100 ;; => auth
 101 ;;
 102 ;; (imap-mailbox-lsub "*")
 103 ;; => ("INBOX.sentmail" "INBOX.private" "INBOX.draft" "INBOX.spam")
 104 ;;
 105 ;; (imap-mailbox-list "INBOX.n%")
 106 ;; => ("INBOX.namedroppers" "INBOX.nnimap" "INBOX.ntbugtraq")
 107 ;;
 108 ;; (imap-mailbox-select "INBOX.nnimap")
 109 ;; => "INBOX.nnimap"
 110 ;;
 111 ;; (imap-mailbox-get 'exists)
 112 ;; => 166
 113 ;;
 114 ;; (imap-mailbox-get 'uidvalidity)
 115 ;; => "908992622"
 116 ;;
 117 ;; (imap-search "FLAGGED SINCE 18-DEC-98")
 118 ;; => (235 236)
 119 ;;
 120 ;; (imap-fetch 235 "RFC822.PEEK" 'RFC822)
 121 ;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: <jas@pdc.kth.se>^M\r...."
 122 ;;
 123 ;; Todo:
 124 ;;
 125 ;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow.
 126 ;; o Don't use `read' at all (important places already fixed)
 127 ;; o Accept list of articles instead of message set string in most
 128 ;;   imap-message-* functions.
 129 ;; o Send strings as literal if they contain, e.g., ".
 130 ;;
 131 ;; Revision history:
 132 ;;
 133 ;;  - 19991218 added starttls/digest-md5 patch,
 134 ;;             by Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
 135 ;;             NB! you need SLIM for starttls.el and digest-md5.el
 136 ;;  - 19991023 commited to pgnus
 137 ;;
 138
 139 ;;; Code:
 140
 141 (eval-when-compile (require 'cl))
 142 (eval-and-compile
 143   (autoload 'starttls-open-stream "starttls")
 144   (autoload 'starttls-negotiate "starttls")
 145   (autoload 'sasl-find-mechanism "sasl")
 146   (autoload 'digest-md5-parse-digest-challenge "digest-md5")
 147   (autoload 'digest-md5-digest-response "digest-md5")
 148   (autoload 'digest-md5-digest-uri "digest-md5")
 149   (autoload 'digest-md5-challenge "digest-md5")
 150   (autoload 'rfc2104-hash "rfc2104")
 151   (autoload 'utf7-encode "utf7")
 152   (autoload 'utf7-decode "utf7")
 153   (autoload 'format-spec "format-spec")
 154   (autoload 'format-spec-make "format-spec")
 155   (autoload 'open-tls-stream "tls"))
 156
 157 ;; User variables.
 158
 159 (defgroup imap nil
 160   "Low-level IMAP issues."
 161   :version "21.1"
 162   :group 'mail)
 163
 164 (defcustom imap-kerberos4-program '("imtest -m kerberos_v4 -u %l -p %p %s"
 165                                     "imtest -kp %s %p")
 166   "List of strings containing commands for Kerberos 4 authentication.
 167 %s is replaced with server hostname, %p with port to connect to, and
 168 %l with the value of `imap-default-user'.  The program should accept
 169 IMAP commands on stdin and return responses to stdout.  Each entry in
 170 the list is tried until a successful connection is made."
 171   :group 'imap
 172   :type '(repeat string))
 173
 174 (defcustom imap-gssapi-program (list
 175                                 (concat "gsasl %s %p "
 176                                         "--imap --mechanism GSSAPI "
 177                                         "--authentication-id %l")
 178                                 "imtest -m gssapi -u %l -p %p %s")
 179   "List of strings containing commands for GSSAPI (krb5) authentication.
 180 %s is replaced with server hostname, %p with port to connect to, and
 181 %l with the value of `imap-default-user'.  The program should accept
 182 IMAP commands on stdin and return responses to stdout.  Each entry in
 183 the list is tried until a successful connection is made."
 184   :group 'imap
 185   :type '(repeat string))
 186
 187 (defcustom imap-ssl-program '("openssl s_client -quiet -ssl3 -connect %s:%p"
 188                               "openssl s_client -quiet -ssl2 -connect %s:%p"
 189                               "s_client -quiet -ssl3 -connect %s:%p"
 190                               "s_client -quiet -ssl2 -connect %s:%p")
 191   "A string, or list of strings, containing commands for SSL connections.
 192 Within a string, %s is replaced with the server address and %p with
 193 port number on server.  The program should accept IMAP commands on
 194 stdin and return responses to stdout.  Each entry in the list is tried
 195 until a successful connection is made."
 196   :group 'imap
 197   :type '(choice string
 198                  (repeat string)))
 199
 200 (defcustom imap-shell-program '("ssh %s imapd"
 201                                 "rsh %s imapd"
 202                                 "ssh %g ssh %s imapd"
 203                                 "rsh %g rsh %s imapd")
 204   "A list of strings, containing commands for IMAP connection.
 205 Within a string, %s is replaced with the server address, %p with port
 206 number on server, %g with `imap-shell-host', and %l with
 207 `imap-default-user'.  The program should read IMAP commands from stdin
 208 and write IMAP response to stdout. Each entry in the list is tried
 209 until a successful connection is made."
 210   :group 'imap
 211   :type '(repeat string))
 212
 213 (defcustom imap-process-connection-type nil
 214   "*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL.
 215 The `process-connection-type' variable control type of device
 216 used to communicate with subprocesses.  Values are nil to use a
 217 pipe, or t or `pty' to use a pty.  The value has no effect if the
 218 system has no ptys or if all ptys are busy: then a pipe is used
 219 in any case.  The value takes effect when a IMAP server is
 220 opened, changing it after that has no effect."
 221   :version "22.1"
 222   :group 'imap
 223   :type 'boolean)
 224
 225 (defcustom imap-use-utf7 t
 226   "If non-nil, do utf7 encoding/decoding of mailbox names.
 227 Since the UTF7 decoding currently only decodes into ISO-8859-1
 228 characters, you may disable this decoding if you need to access UTF7
 229 encoded mailboxes which doesn't translate into ISO-8859-1."
 230   :group 'imap
 231   :type 'boolean)
 232
 233 (defcustom imap-log nil
 234   "If non-nil, a imap session trace is placed in *imap-log* buffer.
 235 Note that username, passwords and other privacy sensitive
 236 information (such as e-mail) may be stored in the *imap-log*
 237 buffer.  It is not written to disk, however.  Do not enable this
 238 variable unless you are comfortable with that."
 239   :group 'imap
 240   :type 'boolean)
 241
 242 (defcustom imap-debug nil
 243   "If non-nil, random debug spews are placed in *imap-debug* buffer.
 244 Note that username, passwords and other privacy sensitive
 245 information (such as e-mail) may be stored in the *imap-debug*
 246 buffer.  It is not written to disk, however.  Do not enable this
 247 variable unless you are comfortable with that."
 248   :group 'imap
 249   :type 'boolean)
 250
 251 (defcustom imap-shell-host "gateway"
 252   "Hostname of rlogin proxy."
 253   :group 'imap
 254   :type 'string)
 255
 256 (defcustom imap-default-user (user-login-name)
 257   "Default username to use."
 258   :group 'imap
 259   :type 'string)
 260
 261 (defcustom imap-read-timeout (if (string-match
 262                                   "windows-nt\\|os/2\\|emx\\|cygwin"
 263                                   (symbol-name system-type))
 264                                  1.0
 265                                0.1)
 266   "*How long to wait between checking for the end of output.
 267 Shorter values mean quicker response, but is more CPU intensive."
 268   :type 'number
 269   :group 'imap)
 270
 271 (defcustom imap-store-password nil
 272   "If non-nil, store session password without promting."
 273   :group 'imap
 274   :type 'boolean)
 275
 276 ;; Various variables.
 277
 278 (defvar imap-fetch-data-hook nil
 279   "Hooks called after receiving each FETCH response.")
 280
 281 (defvar imap-streams '(gssapi kerberos4 starttls tls ssl network shell)
 282   "Priority of streams to consider when opening connection to server.")
 283
 284 (defvar imap-stream-alist
 285   '((gssapi    imap-gssapi-stream-p    imap-gssapi-open)
 286     (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
 287     (tls       imap-tls-p              imap-tls-open)
 288     (ssl       imap-ssl-p              imap-ssl-open)
 289     (network   imap-network-p          imap-network-open)
 290     (shell     imap-shell-p            imap-shell-open)
 291     (starttls  imap-starttls-p         imap-starttls-open))
 292   "Definition of network streams.
 293
 294 \(NAME CHECK OPEN)
 295
 296 NAME names the stream, CHECK is a function returning non-nil if the
 297 server support the stream and OPEN is a function for opening the
 298 stream.")
 299
 300 (defvar imap-authenticators '(gssapi
 301                               kerberos4
 302                               digest-md5
 303                               cram-md5
 304                               ;;sasl
 305                               login
 306                               anonymous)
 307   "Priority of authenticators to consider when authenticating to server.")
 308
 309 (defvar imap-authenticator-alist
 310   '((gssapi     imap-gssapi-auth-p    imap-gssapi-auth)
 311     (kerberos4  imap-kerberos4-auth-p imap-kerberos4-auth)
 312     (sasl       imap-sasl-auth-p      imap-sasl-auth)
 313     (cram-md5   imap-cram-md5-p       imap-cram-md5-auth)
 314     (login      imap-login-p          imap-login-auth)
 315     (anonymous  imap-anonymous-p      imap-anonymous-auth)
 316     (digest-md5 imap-digest-md5-p     imap-digest-md5-auth))
 317   "Definition of authenticators.
 318
 319 \(NAME CHECK AUTHENTICATE)
 320
 321 NAME names the authenticator.  CHECK is a function returning non-nil if
 322 the server support the authenticator and AUTHENTICATE is a function
 323 for doing the actual authentication.")
 324
 325 (defvar imap-error nil
 326   "Error codes from the last command.")
 327
 328 ;; Internal constants.  Change these and die.
 329
 330 (defconst imap-default-port 143)
 331 (defconst imap-default-ssl-port 993)
 332 (defconst imap-default-tls-port 993)
 333 (defconst imap-default-stream 'network)
 334 (defconst imap-coding-system-for-read 'binary)
 335 (defconst imap-coding-system-for-write 'binary)
 336 (defconst imap-local-variables '(imap-server
 337                                  imap-port
 338                                  imap-client-eol
 339                                  imap-server-eol
 340                                  imap-auth
 341                                  imap-stream
 342                                  imap-username
 343                                  imap-password
 344                                  imap-current-mailbox
 345                                  imap-current-target-mailbox
 346                                  imap-message-data
 347                                  imap-capability
 348                                  imap-id
 349                                  imap-namespace
 350                                  imap-state
 351                                  imap-reached-tag
 352                                  imap-failed-tags
 353                                  imap-tag
 354                                  imap-process
 355                                  imap-calculate-literal-size-first
 356                                  imap-mailbox-data))
 357 (defconst imap-log-buffer "*imap-log*")
 358 (defconst imap-debug-buffer "*imap-debug*")
 359
 360 ;; Internal variables.
 361
 362 (defvar imap-stream nil)
 363 (defvar imap-auth nil)
 364 (defvar imap-server nil)
 365 (defvar imap-port nil)
 366 (defvar imap-username nil)
 367 (defvar imap-password nil)
 368 (defvar imap-calculate-literal-size-first nil)
 369 (defvar imap-state 'closed
 370   "IMAP state.
 371 Valid states are `closed', `initial', `nonauth', `auth', `selected'
 372 and `examine'.")
 373
 374 (defvar imap-server-eol "\r\n"
 375   "The EOL string sent from the server.")
 376
 377 (defvar imap-client-eol "\r\n"
 378   "The EOL string we send to the server.")
 379
 380 (defvar imap-current-mailbox nil
 381   "Current mailbox name.")
 382
 383 (defvar imap-current-target-mailbox nil
 384   "Current target mailbox for COPY and APPEND commands.")
 385
 386 (defvar imap-mailbox-data nil
 387   "Obarray with mailbox data.")
 388
 389 (defvar imap-mailbox-prime 997
 390   "Length of imap-mailbox-data.")
 391
 392 (defvar imap-current-message nil
 393   "Current message number.")
 394
 395 (defvar imap-message-data nil
 396   "Obarray with message data.")
 397
 398 (defvar imap-message-prime 997
 399   "Length of imap-message-data.")
 400
 401 (defvar imap-capability nil
 402   "Capability for server.")
 403
 404 (defvar imap-id nil
 405   "Identity of server.
 406 See RFC 2971.")
 407
 408 (defvar imap-namespace nil
 409   "Namespace for current server.")
 410
 411 (defvar imap-reached-tag 0
 412   "Lower limit on command tags that have been parsed.")
 413
 414 (defvar imap-failed-tags nil
 415   "Alist of tags that failed.
 416 Each element is a list with four elements; tag (a integer), response
 417 state (a symbol, `OK', `NO' or `BAD'), response code (a string), and
 418 human readable response text (a string).")
 419
 420 (defvar imap-tag 0
 421   "Command tag number.")
 422
 423 (defvar imap-process nil
 424   "Process.")
 425
 426 (defvar imap-continuation nil
 427   "Non-nil indicates that the server emitted a continuation request.
 428 The actual value is really the text on the continuation line.")
 429
 430 (defvar imap-callbacks nil
 431   "List of response tags and callbacks, on the form `(number . function)'.
 432 The function should take two arguments, the first the IMAP tag and the
 433 second the status (OK, NO, BAD etc) of the command.")
 434
 435 \f
 436 ;; Utility functions:
 437
 438 (defun imap-remassoc (key alist)
 439   "Delete by side effect any elements of LIST whose car is `equal' to KEY.
 440 The modified LIST is returned.  If the first member
 441 of LIST has a car that is `equal' to KEY, there is no way to remove it
 442 by side effect; therefore, write `(setq foo (remassoc key foo))' to be
 443 sure of changing the value of `foo'."
 444   (when alist
 445     (if (equal key (caar alist))
 446         (cdr alist)
 447       (setcdr alist (imap-remassoc key (cdr alist)))
 448       alist)))
 449
 450 (defsubst imap-disable-multibyte ()
 451   "Enable multibyte in the current buffer."
 452   (when (fboundp 'set-buffer-multibyte)
 453     (set-buffer-multibyte nil)))
 454
 455 (defsubst imap-utf7-encode (string)
 456   (if imap-use-utf7
 457       (and string
 458            (condition-case ()
 459                (utf7-encode string t)
 460              (error (message
 461                      "imap: Could not UTF7 encode `%s', using it unencoded..."
 462                      string)
 463                     string)))
 464     string))
 465
 466 (defsubst imap-utf7-decode (string)
 467   (if imap-use-utf7
 468       (and string
 469            (condition-case ()
 470                (utf7-decode string t)
 471              (error (message
 472                      "imap: Could not UTF7 decode `%s', using it undecoded..."
 473                      string)
 474                     string)))
 475     string))
 476
 477 (defsubst imap-ok-p (status)
 478   (if (eq status 'OK)
 479       t
 480     (setq imap-error status)
 481     nil))
 482
 483 (defun imap-error-text (&optional buffer)
 484   (with-current-buffer (or buffer (current-buffer))
 485     (nth 3 (car imap-failed-tags))))
 486 <