Commit f2eefd24 authored by Chong Yidong's avatar Chong Yidong
Browse files

Changes to open-protocol-stream, preparing for merging it with open-network-stream.

* lisp/gnus/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.

* lisp/gnus/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.

* lisp/gnus/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.
parent 181855e6
2011-03-26 Chong Yidong <cyd@stupidchicken.com>
* 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 <tzz@lifelogs.com>
 
* mm-util.el (mm-handle-filename): Move to mm-decode.el (bug#8330).
......
......@@ -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)
......
......@@ -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)
......
......@@ -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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment