From f2eefd24778eb8d577ea09a5c2d28b4df1471b8b Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Sat, 26 Mar 2011 19:18:42 -0400 Subject: [PATCH] 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. --- lisp/gnus/ChangeLog | 36 +++ lisp/gnus/nnimap.el | 41 ++-- lisp/gnus/nntp.el | 33 +-- lisp/gnus/proto-stream.el | 563 +++++++++++++++++++++++----------------------- 4 files changed, 353 insertions(+), 320 deletions(-) rewrite lisp/gnus/proto-stream.el (60%) diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index ddc946383b6..f257ff51f3d 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,39 @@ +2011-03-26 Chong Yidong + + * 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 * mm-util.el (mm-handle-filename): Move to mm-decode.el (bug#8330). diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index bcbe7b678d5..15d7f463d41 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/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) - (open-protocol-stream - "*nnimap*" (current-buffer) nnimap-address (car ports) - :type nnimap-stream - :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"))) + (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")))) + (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/gnus/nntp.el b/lisp/gnus/nntp.el index 66a6365cb3b..9065027d34f 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -1339,26 +1339,26 @@ 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 - "nntpd" pbuffer nntp-address nntp-port-number - :type (cadr - (assoc nntp-open-connection-function map)) - :end-of-command "^\\([2345]\\|[.]\\).*\n" - :capability-command "CAPABILITIES\r\n" - :success "^3" - :starttls-function - (lambda (capabilities) - (if (not (string-match "STARTTLS" capabilities)) - nil - "STARTTLS\r\n")))) + (open-protocol-stream + "nntpd" pbuffer nntp-address nntp-port-number + :type (or (cadr (assoc nntp-open-connection-function map)) + 'try-starttls) + :end-of-command "^\\([2345]\\|[.]\\).*\n" + :capability-command "CAPABILITIES\r\n" + :success "^3" + :starttls-function + (lambda (capabilities) + (if (not (string-match "STARTTLS" capabilities)) + nil + "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/gnus/proto-stream.el b/lisp/gnus/proto-stream.el dissimilarity index 60% index fdf2abfea05..5e92cb40264 100644 --- a/lisp/gnus/proto-stream.el +++ b/lisp/gnus/proto-stream.el @@ -1,287 +1,276 @@ -;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections - -;; Copyright (C) 2010-2011 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; 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 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 -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see . - -;;; 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', `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))) - (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) - 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) - (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)) - 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 '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) - (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) - nil) - ;; Fall back on using a plain network stream. - (t - (list stream greeting capabilities 'network))))))) - -(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 (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 - (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 'network)) - -(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)))) - (list stream greeting - (and 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) - -;;; proto-stream.el ends here +;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections + +;; Copyright (C) 2010-2011 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; 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 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 +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; 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 'try-starttls +;; :capability-command "1 CAPABILITY\r\n" +;; :success " OK " +;; :starttls-function +;; (lambda (capabilities) +;; (if (not (string-match "STARTTLS" capabilities)) +;; nil +;; "1 STARTTLS\r\n"))) + +;;; Code: + +(require 'tls) +(require 'starttls) + +(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, 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 + ((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 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 + (plist-get parameters :end-of-command)) + nil + 'default))) + +(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)) + (greeting (proto-stream-get-response stream start eoc)) + (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)) + ;; 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)) + (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))) + (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, 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)))) + (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)) + (eoc (plist-get parameters :end-of-command))) + (if (null stream) + (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 eoc) + (goto-char (point-min)) + (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 + (plist-get parameters :shell-command) + (format-spec-make + ?s host + ?p service)))) + parameters 'default)) + +(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))) + (list stream greeting + (and capability-command + (proto-stream-command stream capability-command eoc)) + stream-type))) + +(provide 'proto-stream) + +;;; proto-stream.el ends here -- 2.11.4.GIT