X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fproto-stream.el;h=0d2bc5c0d31cafa80f40ed52b2608391e2ea602a;hb=d84b26f66f1975b52a15ca2caf5f10da5103e42e;hp=da6cab969f5f34cb93d21a82e27f4c1ea0d4e4d5;hpb=a92c6279bb25b6d69876b692ac5d848498caace5;p=gnus diff --git a/lisp/proto-stream.el b/lisp/proto-stream.el index da6cab969..0d2bc5c0d 100644 --- a/lisp/proto-stream.el +++ b/lisp/proto-stream.el @@ -1,25 +1,24 @@ ;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections -;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Copyright (C) 2010-2012 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 +;; 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 . ;;; Commentary: @@ -36,10 +35,11 @@ ;; Usage example: -;; (open-proto-stream +;; (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)) @@ -48,106 +48,173 @@ ;;; Code: -(eval-when-compile - (require 'cl)) (require 'tls) (require 'starttls) -(require 'format-spec) - -(defcustom proto-stream-always-use-starttls t - "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 'gnutls-negotiate "gnutls") +(autoload 'open-gnutls-stream "gnutls") ;;;###autoload -(defun open-proto-stream (name buffer host service &rest parameters) - "Open a network stream to HOST. -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', `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 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." - (let ((type (or (cadr (memq :type parameters)) 'network))) - (when (and (eq type 'starttls) - (fboundp 'open-gnutls-stream)) - (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)))) - -(defun proto-stream-open-network (name buffer host service parameters) +(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\". + +: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. + +: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)) + (eo-capa (or (plist-get parameters :end-of-capability) + eoc)) + ;; 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)) - (greeting (proto-stream-get-response stream start eoc))) - (if (not capability-command) - (list stream greeting nil) - (let* ((capabilities - (proto-stream-command stream capability-command eoc)) - (starttls-command - (funcall (cadr (memq :starttls-function parameters)) - capabilities))) - (cond - ((or (not starttls-command) - (not proto-stream-always-use-starttls)) - ;; 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) - (progn - (delete-process stream) - nil) - ;; Otherwise, just return this plain network connection. - (list stream greeting capabilities))) - ((or (fboundp 'open-gnutls-stream) - (executable-find "gnutls-cli")) - (unless (fboundp 'open-gnutls-stream) - (delete-process stream) - (setq stream (starttls-open-stream name buffer host service)) - (proto-stream-get-response stream start eoc)) - (proto-stream-command stream starttls-command eoc) - (if (fboundp 'open-gnutls-stream) - (gnutls-negotiate stream nil) - (starttls-negotiate stream)) - ;; Re-get the capabilities, since they may have changed - ;; after switching to TLS. - (list stream greeting - (proto-stream-command stream capability-command eoc))) - ((eq (cadr (memq :type parameters)) 'starttls) - (delete-process stream) - nil) - (t - (list stream greeting capabilities))))))) + (greeting (proto-stream-get-response stream start eoc)) + (capabilities (when capability-command + (proto-stream-command stream + capability-command + (or eo-capa eoc)))) + (resulting-type 'plain) + (builtin-starttls (and (fboundp 'gnutls-available-p) + (gnutls-available-p))) + starttls-command) + + ;; 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 builtin-starttls + (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 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. + (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 eo-capa)))) + + ;; 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)))) @@ -171,48 +238,54 @@ command to switch on STARTTLS otherwise." (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 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)))) + (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 'plain) + ;; If we're using tls.el, we have to delete the output from + ;; openssl/gnutls-cli. + (unless builtin-starttls + (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 - (cadr (memq :shell-command parameters)) + (plist-get parameters :shell-command) (format-spec-make ?s host ?p service)))) - parameters)) + parameters 'plain)) -(defun proto-stream-capability-open (start stream parameters) - (let ((capability-command (cadr (memq :capability-command parameters))) - (greeting (proto-stream-get-response - stream start (proto-stream-eoc parameters)))) +(defun proto-stream-capability-open (start stream parameters stream-type) + (let* ((capability-command (plist-get parameters :capability-command)) + (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 (proto-stream-eoc parameters)))))) - -(defun proto-stream-eoc (parameters) - (or (cadr (memq :end-of-command parameters)) - "\r\n")) + stream capability-command + (or + (plist-get parameters :end-of-capability) + (plist-get parameters :end-of-command)))) + stream-type))) (provide 'proto-stream)