;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections
-;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2012 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: network
;; (open-protocol-stream
;; "*nnimap*" buffer address port
-;; :type 'try-starttls
+;; :type 'network
;; :capability-command "1 CAPABILITY\r\n"
;; :success " OK "
;; :starttls-function
(require 'tls)
(require 'starttls)
-(declare-function gnutls-negotiate "gnutls"
- (proc type &optional priority-string trustfiles keyfiles))
+(autoload 'gnutls-negotiate "gnutls")
+(autoload 'open-gnutls-stream "gnutls")
;;;###autoload
(defun open-protocol-stream (name buffer host service &rest parameters)
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.
+ nil or `network'
+ -- Begin with an ordinary network connection, and if
+ the parameters :success and :capability-command
+ are also supplied, try to upgrade to an encrypted
+ connection via STARTTLS. Even if that
+ fails (e.g. if HOST does not support TLS), retain
+ an unencrypted connection.
+ `plain' -- An ordinary, unencrypted network connection.
+ `starttls' -- Begin with an ordinary connection, and try
+ upgrading via STARTTLS. If that fails for any
+ reason, drop the connection; in that case the
+ returned object is a killed process.
+ `tls' -- A TLS connection.
+ `ssl' -- Equivalent to `tls'.
`shell' -- A shell connection.
:return-list specifies this function's return value.
: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'.
+ :type -- the resulting connection type; `plain' (unencrypted)
+ or `tls' (TLS-encrypted).
:end-of-command specifies a regexp matching the end of a command.
If non-nil, it defaults to \"\\n\".
+:end-of-capability specifies a regexp matching the end of the
+ response to the command specified for :capability-command.
+ It defaults to the regexp specified for :end-of-command.
+
: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.
+ should be \"^3\" for an NNTP connection.
:capability-command specifies a command used to query the HOST
for its capabilities. For instance, for IMAP this should be
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.
+ (if (and (not return-list)
+ (or (eq type 'plain)
+ (and (memq type '(nil network))
+ (not (and (plist-get parameters :success)
+ (plist-get parameters :capability-command))))))
+ ;; The simplest case is equivalent to `open-network-stream'.
(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)))
+ (setq parameters (append '(:end-of-command "\r\n") parameters)))
(let* ((connection-function
(cond
- ((memq type '(nil default))
- 'proto-stream-open-default)
- ((memq type '(try-starttls starttls))
+ ((eq type 'plain) 'proto-stream-open-plain)
+ ((memq type '(nil network 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))))
+ ((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 return-list
:type (nth 3 result))
(car result))))))
-(defun proto-stream-open-default (name buffer host service parameters)
+(defun proto-stream-open-plain (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
(plist-get parameters :end-of-command))
nil
- 'default)))
+ 'plain)))
(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))
+ (require-tls (eq (plist-get parameters :type) 'starttls))
(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))
+ (eo-capa (or (plist-get parameters :end-of-capability)
+ eoc))
;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE)
(stream (open-network-stream name buffer host service))
(greeting (proto-stream-get-response stream start eoc))
(capabilities (when capability-command
(proto-stream-command stream
- capability-command eoc)))
- (resulting-type 'default)
+ capability-command
+ (or eo-capa eoc))))
+ (resulting-type 'plain)
+ (builtin-starttls (and (fboundp 'gnutls-available-p)
+ (gnutls-available-p)))
starttls-command)
- ;; If we have STARTTLS support, try to upgrade the connection.
- (when (and (or (fboundp 'open-gnutls-stream)
- (executable-find "gnutls-cli"))
+ ;; If we have built-in STARTTLS support, try to upgrade the
+ ;; connection.
+ (when (and (or builtin-starttls
+ (and require-tls
+ (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)
+ (unless builtin-starttls
(delete-process stream)
(setq start (with-current-buffer buffer (point-max)))
(let* ((starttls-use-gnutls t)
(starttls-extra-arguments
- (if (not (eq type 'starttls))
- ;; For opportunistic TLS upgrades, we don't
- ;; really care about the identity of the peer.
- (cons "--insecure" starttls-extra-arguments)
- starttls-extra-arguments)))
+ (if require-tls
+ starttls-extra-arguments
+ ;; For opportunistic TLS upgrades, we don't really
+ ;; care about the identity of the peer.
+ (cons "--insecure" starttls-extra-arguments))))
(setq stream (starttls-open-stream name buffer host service)))
(proto-stream-get-response stream start eoc))
(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)
+ (if builtin-starttls
+ (gnutls-negotiate :process stream :hostname host)
(unless (starttls-negotiate stream)
(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)
+ (unless require-tls
(setq stream (open-network-stream name buffer host service))
(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))))
+ (proto-stream-command stream capability-command eo-capa))))
;; If TLS is mandatory, close the connection if it's unencrypted.
- (and (eq type 'starttls)
- (eq resulting-type 'default)
+ (and require-tls
+ (eq resulting-type 'plain)
(delete-process stream))
;; Return value:
(list stream greeting capabilities resulting-type)))
(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))
- (eoc (plist-get parameters :end-of-command)))
+ (let* ((start (point-max))
+ (builtin-starttls (and (fboundp 'gnutls-available-p)
+ (gnutls-available-p)))
+ (stream
+ (funcall (if builtin-starttls
+ 'open-gnutls-stream
+ 'open-tls-stream)
+ name buffer host service))
+ (eoc (plist-get parameters :end-of-command)))
(if (null stream)
- (list nil nil nil 'default)
+ (list nil nil nil 'plain)
;; If we're using tls.el, we have to delete the output from
;; openssl/gnutls-cli.
- (unless (fboundp 'open-gnutls-stream)
+ (unless builtin-starttls
(proto-stream-get-response stream start eoc)
(goto-char (point-min))
(when (re-search-forward eoc nil t)
(format-spec-make
?s host
?p service))))
- parameters 'default))
+ parameters 'plain))
(defun proto-stream-capability-open (start stream parameters stream-type)
(let* ((capability-command (plist-get parameters :capability-command))
- (eoc (plist-get parameters :end-of-command))
- (greeting (proto-stream-get-response stream start eoc)))
+ (greeting (proto-stream-get-response
+ stream start
+ (plist-get parameters :end-of-command))))
(list stream greeting
(and capability-command
- (proto-stream-command stream capability-command eoc))
+ (proto-stream-command
+ stream capability-command
+ (or
+ (plist-get parameters :end-of-capability)
+ (plist-get parameters :end-of-command))))
stream-type)))
(provide 'proto-stream)
projects / gnus / blobdiff