[gnus git] branch master updated: n0-15-10-g895b2a4 =1= Merge changes made in Emacs trunk.
Katsumi Yamaoka <[email protected]>
| Newsgroups | gmane.emacs.gnus.cvs |
|---|---|
| Message-ID | <[email protected]> |
via 895b2a4bf61fe21934f7e6391689c000e39ced7d (commit)
from 18378da5562b895709032a65016cedf885ed3625 (commit)
- Log -----------------------------------------------------------------
commit 895b2a4bf61fe21934f7e6391689c000e39ced7d
Author: Chong Yidong <[email protected]>
Date: Sun Mar 27 00:09:16 2011 +0000
Merge changes made in Emacs trunk.
proto-stream.el: Changes preparatory to merging open-protocol-stream with open-network-stream.
(proto-stream-always-use-starttls): Option removed.
(open-protocol-stream): Return a process object by default. Provide a new parameter :return-list specifying a list-type return value, which now has the form (PROP . PLIST) instead of a fixed-length list. Change :type `network' to `try-starttls', and `network-only' to `default'. Make `default' the default, for compatibility with open-network-stream. Handle the no-parameter case exactly as open-network-stream, with no additional stream processing. Search plists using plist-get. Explicitly add :end-of-commend parameter if it is missing.
(proto-stream-open-default): Renamed from proto-stream-open-network-only. Return 'default as the type.
(proto-stream-open-starttls): Rename from proto-stream-open-network. Use plist-get. Don't return `tls' as the type if STARTTLS negotiation failed. Always return a list with a (possibly dead) process as the first element, for compatibility with open-network-stream.
(proto-stream-open-tls): Use plist-get. Always return a list.
(proto-stream-open-shell): Return `default' as connection type.
(proto-stream-capability-open): Use plist-get.
(proto-stream-eoc): Function deleted.
nnimap.el (nnimap-stream, nnimap-open-connection, nnimap-open-connection-1): Handle renaming of :type parameter for open-protocol-stream.
(nnimap-open-connection-1): Pass a :return-list parameter open-protocol-stream to obtain a list return value. Parse this list using plist-get.
nntp.el (nntp-open-connection): Handle renaming of :type parameter for open-protocol-stream. Accept open-protocol-stream return value that is a subprocess object instead of a list. Handle the case of a dead returned process.
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index ab534bb..b63c256 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,39 @@
+2011-03-26 Chong Yidong <[email protected]>
+
+ * proto-stream.el: Changes preparatory to merging open-protocol-stream
+ with open-network-stream.
+ (proto-stream-always-use-starttls): Option removed.
+ (open-protocol-stream): Return a process object by default. Provide a
+ new parameter :return-list specifying a list-type return value, which
+ now has the form (PROP . PLIST) instead of a fixed-length list. Change
+ :type `network' to `try-starttls', and `network-only' to `default'.
+ Make `default' the default, for compatibility with open-network-stream.
+ Handle the no-parameter case exactly as open-network-stream, with no
+ additional stream processing. Search plists using plist-get.
+ Explicitly add :end-of-commend parameter if it is missing.
+ (proto-stream-open-default): Renamed from
+ proto-stream-open-network-only. Return 'default as the type.
+ (proto-stream-open-starttls): Rename from proto-stream-open-network.
+ Use plist-get. Don't return `tls' as the type if STARTTLS negotiation
+ failed. Always return a list with a (possibly dead) process as the
+ first element, for compatibility with open-network-stream.
+ (proto-stream-open-tls): Use plist-get. Always return a list.
+ (proto-stream-open-shell): Return `default' as connection type.
+ (proto-stream-capability-open): Use plist-get.
+ (proto-stream-eoc): Function deleted.
+
+ * nnimap.el (nnimap-stream, nnimap-open-connection)
+ (nnimap-open-connection-1): Handle renaming of :type parameter for
+ open-protocol-stream.
+ (nnimap-open-connection-1): Pass a :return-list parameter
+ open-protocol-stream to obtain a list return value. Parse this list
+ using plist-get.
+
+ * nntp.el (nntp-open-connection): Handle renaming of :type parameter
+ for open-protocol-stream. Accept open-protocol-stream return value
+ that is a subprocess object instead of a list. Handle the case of a
+ dead returned process.
+
2011-03-25 Teodor Zlatanov <[email protected]>
* mm-util.el (mm-handle-filename): Move to mm-decode.el (bug#8330).
diff --git a/lisp/nnimap.el b/lisp/nnimap.el
index bcbe7b6..15d7f46 100644
--- a/lisp/nnimap.el
+++ b/lisp/nnimap.el
@@ -62,9 +62,9 @@ it will default to `imap'.")
(defvoo nnimap-stream 'undecided
"How nnimap will talk to the IMAP server.
-Values are `ssl', `network', `network-only, `starttls' or
+Values are `ssl', `default', `try-starttls', `starttls' or
`shell'. The default is to try `ssl' first, and then
-`network'.")
+`try-starttls'.")
(defvoo nnimap-shell-program (if (boundp 'imap-shell-program)
(if (listp imap-shell-program)
@@ -319,7 +319,7 @@ textual parts.")
(setq nnimap-stream 'ssl))
(let ((stream
(if (eq nnimap-stream 'undecided)
- (loop for type in '(ssl network)
+ (loop for type in '(ssl try-starttls)
for stream = (let ((nnimap-stream type))
(nnimap-open-connection-1 buffer))
while (eq stream 'no-connect)
@@ -339,9 +339,7 @@ textual parts.")
(port nil)
(ports
(cond
- ((or (eq nnimap-stream 'network)
- (eq nnimap-stream 'network-only)
- (eq nnimap-stream 'starttls))
+ ((memq nnimap-stream '(try-starttls default starttls))
(nnheader-message 7 "Opening connection to %s..."
nnimap-address)
'("imap" "143"))
@@ -355,21 +353,28 @@ textual parts.")
'("imaps" "imap" "993" "143"))
(t
(error "Unknown stream type: %s" nnimap-stream))))
- (proto-stream-always-use-starttls t)
login-result credentials)
(when nnimap-server-port
(push nnimap-server-port ports))
- (destructuring-bind (stream greeting capabilities stream-type)
+ (let* ((stream-list
(open-protocol-stream
"*nnimap*" (current-buffer) nnimap-address (car ports)
:type nnimap-stream
+ :return-list t
:shell-command nnimap-shell-program
:capability-command "1 CAPABILITY\r\n"
:success " OK "
:starttls-function
(lambda (capabilities)
(when (gnus-string-match-p "STARTTLS" capabilities)
- "1 STARTTLS\r\n")))
+ "1 STARTTLS\r\n"))))
+ (stream (car stream-list))
+ (props (cdr stream-list))
+ (greeting (plist-get props :greeting))
+ (capabilities (plist-get props :capabilities))
+ (stream-type (plist-get props :type)))
+ (when (and stream (not (memq (process-status stream) '(open run))))
+ (setq stream nil))
(setf (nnimap-process nnimap-object) stream)
(setf (nnimap-stream-type nnimap-object) stream-type)
(if (not stream)
diff --git a/lisp/nntp.el b/lisp/nntp.el
index 66a6365..9065027 100644
--- a/lisp/nntp.el
+++ b/lisp/nntp.el
@@ -1339,15 +1339,15 @@ password contained in '~/.nntp-authinfo'."
(condition-case err
(let ((coding-system-for-read nntp-coding-system-for-read)
(coding-system-for-write nntp-coding-system-for-write)
- (map '((nntp-open-network-stream network)
- (network-only network-only)
+ (map '((nntp-open-network-stream try-starttls)
+ (network-only default)
(nntp-open-ssl-stream tls)
(nntp-open-tls-stream tls))))
(if (assoc nntp-open-connection-function map)
- (car (open-protocol-stream
+ (open-protocol-stream
"nntpd" pbuffer nntp-address nntp-port-number
- :type (cadr
- (assoc nntp-open-connection-function map))
+ :type (or (cadr (assoc nntp-open-connection-function map))
+ 'try-starttls)
:end-of-command "^\\([2345]\\|[.]\\).*\n"
:capability-command "CAPABILITIES\r\n"
:success "^3"
@@ -1355,10 +1355,10 @@ password contained in '~/.nntp-authinfo'."
(lambda (capabilities)
(if (not (string-match "STARTTLS" capabilities))
nil
- "STARTTLS\r\n"))))
+ "STARTTLS\r\n")))
(funcall nntp-open-connection-function pbuffer)))
(error
- (nnheader-report 'nntp "%s" err))
+ (nnheader-report 'nntp ">>> %s" err))
(quit
(message "Quit opening connection to %s" nntp-address)
(nntp-kill-buffer pbuffer)
@@ -1366,6 +1366,9 @@ password contained in '~/.nntp-authinfo'."
nil))))
(when timer
(nnheader-cancel-timer timer))
+ (when (and process
+ (not (memq (process-status process) '(open run))))
+ (setq process nil))
(unless process
(nntp-kill-buffer pbuffer))
(when (and (buffer-name pbuffer)
diff --git a/lisp/proto-stream.el b/lisp/proto-stream.el
index fdf2abf..5e92cb4 100644
--- a/lisp/proto-stream.el
+++ b/lisp/proto-stream.el
@@ -37,7 +37,7 @@
;; (open-protocol-stream
;; "*nnimap*" buffer address port
-;; :type 'network
+;; :type 'try-starttls
;; :capability-command "1 CAPABILITY\r\n"
;; :success " OK "
;; :starttls-function
@@ -48,171 +48,164 @@
;;; 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', `network-only, `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. If you don't want STARTTLS upgrades, use
-`network-only'.
-
-: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.
-
-The return value from this function is a four-element list, where
-the first element is the stream (if connection was successful);
-the second element is the \"greeting\", i. e., the string the
-server sent over on initial contact; the third element is the
-capability string; and the fourth element is either `network' or
-`tls', depending on whether the connection ended up being
-encrypted or not."
- (let ((type (or (cadr (memq :type parameters)) 'network)))
+ "Open a network stream to HOST, possibly with encryption.
+Normally, return a network process object; with a non-nil
+:return-list parameter, return a list instead (see below).
+
+The first four parameters, NAME, BUFFER, HOST, and SERVICE, have
+the same meanings as in `open-network-stream'. The remaining
+PARAMETERS should be a sequence of keywords and values:
+
+:type specifies the connection type, one of the following:
+ `default' -- An ordinary network connection.
+ `try-starttls'
+ -- Begin an ordinary network connection, and try
+ upgrading it to an encrypted connection via
+ STARTTLS if both HOST and Emacs support TLS. If
+ that fails, keep the unencrypted connection.
+ `starttls' -- Begin an ordinary connection, and try upgrading
+ it via STARTTLS. If that fails for any reason,
+ drop the connection; in this case, the returned
+ process object is a killed process.
+ `tls' or `ssl' -- A TLS connection.
+ `shell' -- A shell connection.
+
+:return-list specifies this function's return value.
+ If omitted or nil, return a process object. A non-nil means to
+ return (PROC . PROPS), where PROC is a process object and PROPS
+ is a plist of connection properties, with these keywords:
+ :greeting -- the greeting returned by HOST (a string), or nil.
+ :capabilities -- a string representing HOST's capabilities,
+ or nil if none could be found.
+ :type -- the actual connection type; either `default' for an
+ unencrypted connection, or `tls'.
+
+:end-of-command specifies a regexp matching the end of a command.
+ If non-nil, it defaults to \"\\n\".
+
+:success specifies a regexp matching a message indicating a
+ successful STARTTLS negotiation. For instance, the default
+ should be \"^3\" for an NNTP connection. If this is not
+ supplied, STARTTLS will always fail.
+
+:capability-command specifies a command used to query the HOST
+ for its capabilities. For instance, for IMAP this should be
+ \"1 CAPABILITY\\r\\n\".
+
+:starttls-function specifies a function for handling STARTTLS.
+ This function should take one parameter, the response to the
+ capability command, and should return the command to switch on
+ STARTTLS if the server supports STARTTLS, and nil otherwise."
+ (let ((type (plist-get parameters :type))
+ (return-list (plist-get parameters :return-list)))
+ (if (and (null return-list) (memq type '(nil default)))
+ ;; The simplest case---no encryption, and no need to report
+ ;; connection properties. Like `open-network-stream', this
+ ;; doesn't read anything into BUFFER yet.
+ (open-network-stream name buffer host service)
+ ;; For everything else, refer to proto-stream-open-*.
+ (unless (plist-get parameters :end-of-command)
+ (setq parameters
+ (append '(:end-of-command "\r\n") parameters)))
+ (let* ((connection-function
(cond
- ((eq type 'starttls)
- (setq type 'network))
- ((eq type 'ssl)
- (setq type 'tls)))
- (let ((open-result
- (funcall (intern (format "proto-stream-open-%s" type) obarray)
+ ((memq type '(nil default))
+ 'proto-stream-open-default)
+ ((memq type '(try-starttls starttls))
+ 'proto-stream-open-starttls)
+ ((memq type '(tls ssl))
+ 'proto-stream-open-tls)
+ ((eq type 'shell)
+ 'proto-stream-open-shell)
+ (t
+ (error "Invalid connection type %s" type))))
+ (result (funcall connection-function
name buffer host service parameters)))
- (if (null open-result)
- (list nil nil nil type)
- (let ((stream (car open-result)))
- (list (and stream
- (memq (process-status stream)
- '(open run))
- stream)
- (nth 1 open-result)
- (nth 2 open-result)
- (nth 3 open-result)))))))
-
-(defun proto-stream-open-network-only (name buffer host service parameters)
+ (if return-list
+ (list (car result)
+ :greeting (nth 1 result)
+ :capabilities (nth 2 result)
+ :type (nth 3 result))
+ (car result))))))
+
+(defun proto-stream-open-default (name buffer host service parameters)
(let ((start (with-current-buffer buffer (point)))
(stream (open-network-stream name buffer host service)))
(list stream
- (proto-stream-get-response
- stream start (proto-stream-eoc parameters))
+ (proto-stream-get-response stream start
+ (plist-get parameters :end-of-command))
nil
- 'network)))
+ 'default)))
-(defun proto-stream-open-network (name buffer host service parameters)
+(defun proto-stream-open-starttls (name buffer host service parameters)
(let* ((start (with-current-buffer buffer (point)))
+ ;; This should be `starttls' or `try-starttls'.
+ (type (plist-get parameters :type))
+ (starttls-function (plist-get parameters :starttls-function))
+ (success-string (plist-get parameters :success))
+ (capability-command (plist-get parameters :capability-command))
+ (eoc (plist-get parameters :end-of-command))
+ ;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE)
(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 'network)
- (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 'network)))
- ;; We have some kind of STARTTLS support, so we try to
- ;; upgrade the connection opportunistically.
- ((or (fboundp 'open-gnutls-stream)
+ (capabilities (when capability-command
+ (proto-stream-command stream
+ capability-command eoc)))
+ (resulting-type 'default)
+ starttls-command)
+
+ ;; If we have STARTTLS support, try to upgrade the connection.
+ (when (and (or (fboundp 'open-gnutls-stream)
(executable-find "gnutls-cli"))
+ capabilities success-string starttls-function
+ (setq starttls-command
+ (funcall starttls-function capabilities)))
+ ;; If using external STARTTLS, drop this connection and start
+ ;; anew with `starttls-open-stream'.
(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.
+ ;; For 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 'network)))
- ;; The server said it was OK to start doing STARTTLS negotiations.
+ (when (string-match success-string
+ (proto-stream-command stream starttls-command eoc))
+ ;; The server said it was OK to begin 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.
+ (delete-process stream)))
+ (if (memq (process-status stream) '(open run))
+ (setq resulting-type 'tls)
+ ;; We didn't successfully negotiate STARTTLS; if TLS
+ ;; isn't demanded, reopen an unencrypted connection.
+ (when (eq type 'try-starttls)
(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) 'tls)))
- ;; 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 'network)))))))
+ (proto-stream-get-response stream start eoc)))
+ ;; Re-get the capabilities, which may have now changed.
+ (setq capabilities
+ (proto-stream-command stream capability-command eoc))))
+
+ ;; If TLS is mandatory, close the connection if it's unencrypted.
+ (and (eq type 'starttls)
+ (eq resulting-type 'default)
+ (delete-process stream))
+ ;; Return value:
+ (list stream greeting capabilities resulting-type)))
(defun proto-stream-command (stream command eoc)
(let ((start (with-current-buffer (process-buffer stream) (point-max))))
@@ -241,47 +234,43 @@ encrypted or not."
(funcall (if (fboundp 'open-gnutls-stream)
'open-gnutls-stream
'open-tls-stream)
- name buffer host service)))
+ name buffer host service))
+ (eoc (plist-get parameters :end-of-command)))
(if (null stream)
- nil
+ (list nil nil nil 'default)
;; 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))
+ (proto-stream-get-response stream start eoc)
(goto-char (point-min))
- (when (re-search-forward (proto-stream-eoc parameters) nil t)
+ (when (re-search-forward eoc nil t)
(goto-char (match-beginning 0))
(delete-region (point-min) (line-beginning-position))))
(proto-stream-capability-open start stream parameters 'tls)))))
(defun proto-stream-open-shell (name buffer host service parameters)
+ (require 'format-spec)
(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))
+ (plist-get parameters :shell-command)
(format-spec-make
?s host
?p service))))
- parameters 'network))
+ parameters 'default))
(defun proto-stream-capability-open (start stream parameters stream-type)
- (let ((capability-command (cadr (memq :capability-command parameters)))
- (greeting (proto-stream-get-response
- stream start (proto-stream-eoc parameters))))
+ (let* ((capability-command (plist-get parameters :capability-command))
+ (eoc (plist-get parameters :end-of-command))
+ (greeting (proto-stream-get-response stream start eoc)))
(list stream greeting
(and capability-command
- (proto-stream-command
- stream capability-command (proto-stream-eoc parameters)))
+ (proto-stream-command stream capability-command eoc))
stream-type)))
-(defun proto-stream-eoc (parameters)
- (or (cadr (memq :end-of-command parameters))
- "\r\n"))
-
(provide 'proto-stream)
;;; proto-stream.el ends here
-----------------------------------------------------------------------
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we listed those
revisions in full, above.
Summary of changes:
lisp/ChangeLog | 36 ++++++
lisp/nnimap.el | 41 ++++---
lisp/nntp.el | 33 +++---
lisp/proto-stream.el | 321 ++++++++++++++++++++++++--------------------------
4 files changed, 232 insertions(+), 199 deletions(-)
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "Gnus Project".
The branch, master has been updated
hooks/post-receive
--
Gnus Project