mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-16 10:50:49 -08:00
e742e11707
* nnimap.el (nnimap-stream, nnimap-open-connection-1): Accept `network' value. * nntp.el (nntp-open-connection-function): Document the fact that some values are not functions but are instead handled specially. Recognize nntp-open-plain-stream value. (nntp-open-connection): Recognize that value. * proto-stream.el (open-protocol-stream): Bring back `network' type. Make this the default type. (proto-stream-open-plain): Rename from proto-stream-open-default. (open-protocol-stream, proto-stream-open-starttls) (proto-stream-open-tls, proto-stream-open-shell): Replace `default' with `plain'.
274 lines
11 KiB
EmacsLisp
274 lines
11 KiB
EmacsLisp
;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections
|
|
|
|
;; 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
|
|
;; 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 <http://www.gnu.org/licenses/>.
|
|
|
|
;;; 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:
|
|
|
|
(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:
|
|
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.
|
|
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 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\".
|
|
|
|
:success specifies a regexp matching a message indicating a
|
|
successful STARTTLS negotiation. For instance, the default
|
|
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
|
|
\"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 (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)))
|
|
(let* ((connection-function
|
|
(cond
|
|
((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))))
|
|
(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-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
|
|
'plain)))
|
|
|
|
(defun proto-stream-open-starttls (name buffer host service parameters)
|
|
(let* ((start (with-current-buffer buffer (point)))
|
|
(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))
|
|
;; 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 'plain)
|
|
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 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)
|
|
(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.
|
|
(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))))
|
|
|
|
;; If TLS is mandatory, close the connection if it's unencrypted.
|
|
(and require-tls
|
|
(eq resulting-type 'plain)
|
|
(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 'plain)
|
|
;; 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 '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)))
|
|
(list stream greeting
|
|
(and capability-command
|
|
(proto-stream-command stream capability-command eoc))
|
|
stream-type)))
|
|
|
|
(provide 'proto-stream)
|
|
|
|
;;; proto-stream.el ends here
|