Merge changes made in Gnus trunk.

nnir.el: Batch header retrieval.
proto-stream.el: New library to provide protocol-specific TLS/STARTTLS connections for IMAP, NNTP, SMTP, POP3 and similar protocols.
nnimap.el (nnimap-open-connection): Use it.
proto-stream.el (open-proto-stream): Complete the documentation.
nnimap.el (nnimap-open-connection): Check for "OK" from the greeting.
nntp.el: Use proto-streams for the relevant connections types.
nntp.el (nntp-open-connection): Switch on STARTTLS on supported servers.
proto-stream.el (open-proto-stream): Add a way to specify what the end of a command is.
proto-stream.el (proto-stream-open-tls): Delete output from openssl if we're using tls.el.
proto-stream.el (proto-stream-open-network): If we don't have gnutls-cli or gnutls built in, then don't try to establish a STARTTLS connection.
color.el (color-lab->srgb): Fix function call name.
proto-stream.el: Fix the syntax in the comment.
nntp.el (nntp-open-connection): Fix the STARTTLS command syntax.
proto-stream.el (proto-stream-open-starttls): Actually implement the starttls.el STARTTLS.
proto-stream.el (proto-stream-always-use-starttls): New variable.
proto-stream.el (proto-stream-open-starttls): De-duplicate the starttls code.
proto-stream.el (proto-stream-open-starttls): Folded back into the main function.
proto-stream.el (proto-stream-command): Refactor out.
nnimap.el (nnimap-stream): Change default to `undecided'.
nnimap.el (nnimap-open-connection): If `nnimap-stream' is `undecided', try ssl first, and then network.
nnimap.el (nnimap-open-connection-1): Respect nnimap-server-port.
nnimap.el (nnimap-open-connection): Be more backwards-compatible.
proto-stream.el (open-protocol-stream): Renamed from open-proto-stream.
proto-stream.el (proto-stream-open-network): When doing opportunistic TLS upgrades we don't really care about the identity of the peer.
gnus.texi (Customizing the IMAP Connection): Note the new defaults.
gnus.texi (Direct Functions): Note the STARTTLS upgrade.
proto-stream.el (proto-stream-open-network): Force starttls.el to use gnutls-cli, since that what we've checked for.
proto-stream.el (proto-stream-always-use-starttls): Only default to t if open-gnutls-stream exists.
proto-stream.el (proto-stream-open-network): If STARTTLS failed, then just open a normal connection.
proto-stream.el (proto-stream-open-network): Wait until the greeting before doing STARTTLS.
nnimap.el (nnimap-open-connection-1): Always upgrade to STARTTLS (for backwards compatibility).
nnimap.el (nnimap-open-connection-1): Really respect nnimap-server-port.
nntp.el (nntp-open-connection): Provide a :success condition.
nnimap.el (nnimap-open-connection-1): Ditto.
proto-stream.el (proto-stream-open-network): See what the response to the STARTTLS command is.
proto-stream.el (proto-stream-open-network): Add some comments.
proto-stream.el: Fix example.
proto-stream.el (open-protocol-stream): Actually mention the STARTTLS upgrade.
nnir.el (nnir-get-active): Skip nnir-ignored-newsgroups when searching.
nnir.el (nnir-ignore-newsgroups): Fix default value.
nnir.el (nnir-run-gmane): Use mm-delete-duplicates instead of delete-dups that is not available in XEmacs 21.4.
mm-util.el (mm-delete-duplicates): Add comment.
gnus-sum.el (gnus-summary-delete-article): If delete fails don't change the registry.
nnimap.el (nnimap-open-connection-1): w32 open-network-stream doesn't seem to accept strings-with-numbers as port numbers.
color.el: fix docstring to use English rather than math notation for intervals.
shr.el (shr-find-fill-point): Don't break before apostrophes.
nnir.el (nnir-request-move-article): Bail out if no move support in group.
color.el (color-rgb->hsv): Fix docstring.
nnir.el (nnir-get-active): Improve active list retrieval.
shr.el (shr-find-fill-point): Work better for kinsoku chars and apostrophes.
gnus-gravatar.el (gnus-gravatar-size): Set gnus-gravatar-size to nil.
nnimap.el (nnimap-open-connection-1): Use gnus-string-match-p.
nnimap.el (nnimap-open-connection-1): Fix PREAUTH.
proto-stream.el (open-protocol-stream): All starttls connections are handled by the network handler.
gnus-gravatar.el (gnus-gravatar-insert): Delete unnecessary binding to t of inhibit-read-only since it is inside gnus-with-article-headers.
gnus-gravatar.el (gnus-gravatar-transform-address): Use mail-extract-address-components that supports non-ASCII names rather than mail-header-parse-addresses.
shr.el (shr-find-fill-point): Don't break line between kinsoku-bol characters.
gnus-gravatar.el (gnus-gravatar-insert): Allow LWSP in the middle of names.
nnmaildir.el (nnmaildir-request-set-mark): Add article to add-mark funcall.
gnus-msg.el: Remove nastygram thing.
message.el (message-from-style): Fix comment.
message.el (message-user-organization): Do not use gnus-local-organization.
gnus.el: Remove gnus-local-organization.
rtree.el: New file to handle range trees.
nnir.el, gnus-sum.el: Redo the way nnir handles registry updates.
rtree.el (rtree-extract): Simplify.
gnus-win.el (gnus-configure-windows): Remove Gnus 3.x setting support.
gnus-msg.el: Mark gnus-outgoing-message-group as obsolete.
gnus.texi (Archived Messages): Remove gnus-outgoing-message-group.
gnus-win.el (gnus-configure-frame): Remove old compatibility code.
rtree.el (rtree-memq): Rewrite it as a non-recursive function.
rtree.el (rtree-add, rtree-delq, rtree-length): Implement.
rtree.el (rtree-add): Make code slightly faster.
nnir.el: Allow modified summary-line-format in nnir summary buffers.

1 files changed, 262 insertions, 0 deletions

diff --git a/lisp/gnus/proto-stream.el b/lisp/gnus/proto-stream.el
new file mode 100644
index 00000000000..d402a876456
--- /dev/null
+++ b/lisp/gnus/proto-stream.el
@@ -0,0 +1,262 @@
+;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: network
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; This library is meant to provide the glue between modules that want
+;; to establish a network connection to a server for protocols such as
+;; IMAP, NNTP, SMTP and POP3.
+
+;; The main problem is that there's more than a couple of interfaces
+;; towards doing this.  You have normal, plain connections, which are
+;; no trouble at all, but you also have TLS/SSL connections, and you
+;; have STARTTLS.  Negotiating this for each protocol can be rather
+;; tedious, so this library provides a single entry point, and hides
+;; much of the ugliness.
+
+;; Usage example:
+
+;; (open-protocol-stream
+;;  "*nnimap*" buffer address port
+;;  :type 'network
+;;  :capability-command "1 CAPABILITY\r\n"
+;;  :success " OK "
+;;  :starttls-function
+;;  (lambda (capabilities)
+;;    (if (not (string-match "STARTTLS" capabilities))
+;;        nil
+;;      "1 STARTTLS\r\n")))
+
+;;; Code:
+
+(eval-when-compile
+  (require 'cl))
+(require 'tls)
+(require 'starttls)
+(require 'format-spec)
+
+(defcustom proto-stream-always-use-starttls (fboundp 'open-gnutls-stream)
+  "If non-nil, always try to upgrade network connections with STARTTLS."
+  :version "24.1"
+  :type 'boolean
+  :group 'comm)
+
+(declare-function gnutls-negotiate "gnutls"
+		  (proc type &optional priority-string trustfiles keyfiles))
+
+;;;###autoload
+(defun open-protocol-stream (name buffer host service &rest parameters)
+  "Open a network stream to HOST, upgrading to STARTTLS if possible.
+The first four parameters have the same meaning as in
+`open-network-stream'.  The function returns a list where the
+first element is the stream, the second element is the greeting
+the server replied with after connecting, and the third element
+is a string representing the capabilities of the server (if any).
+
+The PARAMETERS is a keyword list that can have the following
+values:
+
+:type -- either `network', `tls', `shell' or `starttls'.  If
+omitted, the default is `network'.  `network' will be
+opportunistically upgraded to STARTTLS if both the server and
+Emacs supports it.
+
+:end-of-command -- a regexp saying what the end of a command is.
+This defaults to \"\\n\".
+
+:success -- a regexp saying whether the STARTTLS command was
+successful or not.  For instance, for NNTP this is \"^3\".
+
+:capability-command -- a string representing the command used to
+query server for capabilities.  For instance, for IMAP this is
+\"1 CAPABILITY\\r\\n\".
+
+:starttls-function -- a function that takes one parameter, which
+is the response to the capaibility command.  It should return nil
+if it turns out that the server doesn't support STARTTLS, or the
+command to switch on STARTTLS otherwise."
+  (let ((type (or (cadr (memq :type parameters)) 'network)))
+    (cond
+     ((eq type 'starttls)
+      (setq type 'network))
+     ((eq type 'ssl)
+      (setq type 'tls)))
+    (destructuring-bind (stream greeting capabilities)
+	(funcall (intern (format "proto-stream-open-%s" type) obarray)
+		 name buffer host service parameters)
+      (list (and stream
+		 (memq (process-status stream)
+		       '(open run))
+		 stream)
+	    greeting capabilities))))
+
+(defun proto-stream-open-network (name buffer host service parameters)
+  (let* ((start (with-current-buffer buffer (point)))
+	 (stream (open-network-stream name buffer host service))
+	 (capability-command (cadr (memq :capability-command parameters)))
+	 (eoc (proto-stream-eoc parameters))
+	 (type (cadr (memq :type parameters)))
+	 (greeting (proto-stream-get-response stream start eoc))
+	 success)
+    (if (not capability-command)
+	(list stream greeting nil)
+      (let* ((capabilities
+	      (proto-stream-command stream capability-command eoc))
+	     (starttls-command
+	      (funcall (cadr (memq :starttls-function parameters))
+		       capabilities)))
+	(cond
+	  ;; If this server doesn't support STARTTLS, but we have
+	  ;; requested it explicitly, then close the connection and
+	  ;; return nil.
+	 ((or (not starttls-command)
+	      (and (not (eq type 'starttls))
+		   (not proto-stream-always-use-starttls)))
+	  (if (eq type 'starttls)
+	      (progn
+		(delete-process stream)
+		nil)
+	    ;; Otherwise, just return this plain network connection.
+	    (list stream greeting capabilities)))
+	 ;; We have some kind of STARTTLS support, so we try to
+	 ;; upgrade the connection opportunistically.
+	 ((or (fboundp 'open-gnutls-stream)
+	      (executable-find "gnutls-cli"))
+	  (unless (fboundp 'open-gnutls-stream)
+	    (delete-process stream)
+	    (setq start (with-current-buffer buffer (point-max)))
+	    (let* ((starttls-use-gnutls t)
+		   (starttls-extra-arguments
+		    (if (not (eq type 'starttls))
+			;; When doing opportunistic TLS upgrades we
+			;; don't really care about the identity of the
+			;; peer.
+			(cons "--insecure" starttls-extra-arguments)
+		      starttls-extra-arguments)))
+	      (setq stream (starttls-open-stream name buffer host service)))
+	    (proto-stream-get-response stream start eoc))
+	  (if (not
+	       (string-match
+		(cadr (memq :success parameters))
+		(proto-stream-command stream starttls-command eoc)))
+	      ;; We got an error back from the STARTTLS command.
+	      (progn
+		(if (eq type 'starttls)
+		    (progn
+		      (delete-process stream)
+		      nil)
+		  (list stream greeting capabilities)))
+	    ;; The server said it was OK to start doing STARTTLS negotiations.
+	    (if (fboundp 'open-gnutls-stream)
+		(gnutls-negotiate stream nil)
+	      (unless (starttls-negotiate stream)
+		(delete-process stream)
+		(setq stream nil)))
+	    (when (or (null stream)
+		      (not (memq (process-status stream)
+				 '(open run))))
+	      ;; It didn't successfully negotiate STARTTLS, so we reopen
+	      ;; the connection.
+	      (setq stream (open-network-stream name buffer host service))
+	      (proto-stream-get-response stream start eoc))
+	    ;; Re-get the capabilities, since they may have changed
+	    ;; after switching to TLS.
+	    (list stream greeting
+		  (proto-stream-command stream capability-command eoc))))
+	 ;; We don't have STARTTLS support available, but the caller
+	 ;; requested a STARTTLS connection, so we give up.
+	 ((eq (cadr (memq :type parameters)) 'starttls)
+	  (delete-process stream)
+	  nil)
+	 ;; Fall back on using a plain network stream.
+	 (t
+	  (list stream greeting capabilities)))))))
+
+(defun proto-stream-command (stream command eoc)
+  (let ((start (with-current-buffer (process-buffer stream) (point-max))))
+    (process-send-string stream command)
+    (proto-stream-get-response stream start eoc)))
+
+(defun proto-stream-get-response (stream start end-of-command)
+  (with-current-buffer (process-buffer stream)
+    (save-excursion
+      (goto-char start)
+      (while (and (memq (process-status stream)
+			'(open run))
+		  (not (re-search-forward end-of-command nil t)))
+	(accept-process-output stream 0 50)
+	(goto-char start))
+      (if (= start (point))
+	  ;; The process died; return nil.
+	  nil
+	;; Return the data we got back.
+	(buffer-substring start (point))))))
+
+(defun proto-stream-open-tls (name buffer host service parameters)
+  (with-current-buffer buffer
+    (let ((start (point-max))
+	  (stream
+	   (funcall (if (fboundp 'open-gnutls-stream)
+			'open-gnutls-stream
+		      'open-tls-stream)
+		    name buffer host service)))
+      ;; If we're using tls.el, we have to delete the output from
+      ;; openssl/gnutls-cli.
+      (unless (fboundp 'open-gnutls-stream)
+	(proto-stream-get-response
+	 stream start (proto-stream-eoc parameters))
+	(goto-char (point-min))
+	(when (re-search-forward (proto-stream-eoc parameters) nil t)
+	  (goto-char (match-beginning 0))
+	  (delete-region (point-min) (line-beginning-position))))
+      (proto-stream-capability-open start stream parameters))))
+
+(defun proto-stream-open-shell (name buffer host service parameters)
+  (proto-stream-capability-open
+   (with-current-buffer buffer (point))
+   (let ((process-connection-type nil))
+     (start-process name buffer shell-file-name
+		    shell-command-switch
+		    (format-spec
+		     (cadr (memq :shell-command parameters))
+		     (format-spec-make
+		      ?s host
+		      ?p service))))
+   parameters))
+
+(defun proto-stream-capability-open (start stream parameters)
+  (let ((capability-command (cadr (memq :capability-command parameters)))
+	(greeting (proto-stream-get-response
+		   stream start (proto-stream-eoc parameters))))
+    (list stream greeting
+	  (and capability-command
+	       (proto-stream-command
+		stream capability-command (proto-stream-eoc parameters))))))
+
+(defun proto-stream-eoc (parameters)
+  (or (cadr (memq :end-of-command parameters))
+      "\r\n"))
+
+(provide 'proto-stream)
+
+;;; proto-stream.el ends here