;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; Copyright (C) 2010-2011 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
+;; 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.
+;; the Free Software Foundation, either version 3 of the License, 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
+;; 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.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; 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 '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-proto-stream (name buffer host service &rest parameters)
- "Open a network stream to HOST.
+(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 PARAMETERS is a keyword list that can
-have the following values:
+`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'.
-:type -- either `network', `tls', `shell' or `starttls'. If
-omitted, the default is `network'.
+:end-of-command -- a regexp saying what the end of a command is.
+This defaults to \"\\n\".
-:capability-command -- a function that takes a stream parameter"
- (let ((type (or (cadr (memq :type parameters)) 'stream)))
- (when (and (eq type 'starttls)
- (fboundp 'open-gnutls-stream))
+: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)))
+ (cond
+ ((eq type 'starttls)
(setq type 'network))
- (when (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))))
+ ((eq type 'ssl)
+ (setq type 'tls)))
+ (let ((open-result
+ (funcall (intern (format "proto-stream-open-%s" type) obarray)
+ 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 (name buffer host service parameters)
+(defun proto-stream-open-network-only (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)))
- (greeting (proto-stream-get-response stream start)))
+ (stream (open-network-stream name buffer host service)))
+ (list stream
+ (proto-stream-get-response
+ stream start (proto-stream-eoc parameters))
+ nil
+ 'network)))
+
+(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)
+ (list stream greeting nil 'network)
(let* ((capabilities
- (proto-stream-capabilities stream capability-command))
+ (proto-stream-command stream capability-command eoc))
(starttls-command
(funcall (cadr (memq :starttls-function parameters))
- stream capabilities)))
+ capabilities)))
(cond
- ((not starttls-command)
;; If this server doesn't support STARTTLS, but we have
;; requested it explicitly, then close the connection and
;; return nil.
- (if (eq (cadr (memq :type parameters)) 'starttls)
+ ((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)))
- ((fboundp 'open-gnutls-stream)
- (setq start (with-current-buffer buffer (point)))
- (process-send-string stream starttls-command)
- (proto-stream-get-response stream start)
- (gnutls-negotiate stream nil)
- ;; Re-get the capabilities, since they may have changed
- ;; after switching to TLS.
- (setq start (with-current-buffer buffer (point)))
- (process-send-string stream capability-command)
- (list stream greeting (proto-stream-get-response stream start)))
- (t
+ (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)
+ (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 'network)))
+ ;; 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) '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)
- (proto-stream-open-starttls name buffer host service parameters)))))))
+ nil)
+ ;; Fall back on using a plain network stream.
+ (t
+ (list stream greeting capabilities 'network)))))))
-(defun proto-stream-capabilities (stream command)
- (let ((start (with-current-buffer buffer (point))))
+(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)))
-
-(defun proto-stream-open-starttls (name buffer host service parameters)
- (proto-stream-capability-open
- (with-current-buffer buffer (point))
- (starttls-open-stream name buffer host service)
- parameters))
+ (proto-stream-get-response stream start eoc)))
-(defun proto-stream-get-response (stream start)
+(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 (search-forward "\n" nil t)))
+ (not (re-search-forward end-of-command nil t)))
(accept-process-output stream 0 50)
(goto-char start))
(if (= start (point))
(buffer-substring start (point))))))
(defun proto-stream-open-tls (name buffer host service parameters)
- (proto-stream-capability-open
- (with-current-buffer buffer (point))
- (funcall (if (fboundp 'open-gnutls-stream)
- 'open-gnutls-stream
- 'open-tls-stream)
- 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 (null stream)
+ nil
+ ;; 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 'tls)))))
(defun proto-stream-open-shell (name buffer host service parameters)
(proto-stream-capability-open
(cadr (memq :shell-command parameters))
(format-spec-make
?s host
- ?p port))))
- parameters))
+ ?p service))))
+ parameters 'network))
-(defun proto-stream-capability-open (start stream parameters)
+(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)))
+ (greeting (proto-stream-get-response
+ stream start (proto-stream-eoc parameters))))
(list stream greeting
(and capability-command
- (proto-stream-capabilities stream capability-command)))))
+ (proto-stream-command
+ stream capability-command (proto-stream-eoc parameters)))
+ stream-type)))
+
+(defun proto-stream-eoc (parameters)
+ (or (cadr (memq :end-of-command parameters))
+ "\r\n"))
(provide 'proto-stream)