X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/f6ab314e6ed2e3ad335fde222e6b649ead481040..3e93bafb95608467e438ba7f725fd1f020669f8c:/lisp/net/network-stream.el diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index a8989398e1..28e9d0ccf3 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -1,6 +1,6 @@ ;;; network-stream.el --- open network processes, possibly with encryption -;; Copyright (C) 2010-2011 Free Software Foundation, Inc. +;; Copyright (C) 2010-2014 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: network @@ -98,6 +98,10 @@ values: :end-of-command specifies a regexp matching the end of a command. +: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. @@ -111,7 +115,7 @@ values: capability command, and should return the command to switch on STARTTLS if the server supports STARTTLS, and nil otherwise. -:always-query-capabilies says whether to query the server for +:always-query-capabilities says whether to query the server for capabilities, even if we're doing a `plain' network connection. :client-certificate should either be a list where the first @@ -121,9 +125,11 @@ values: certificate. This parameter will only be used when doing TLS or STARTTLS connections. -If :use-starttls-if-possible is non-nil, do opportunistic -STARTTLS upgrades even if Emacs doesn't have built-in TLS -functionality. +:use-starttls-if-possible is a boolean that says to do opportunistic +STARTTLS upgrades even if Emacs doesn't have built-in TLS functionality. + +:nogreeting is a boolean that can be used to inhibit waiting for +a greeting from the server. :nowait is a boolean that says the connection should be made asynchronously, if possible." @@ -203,15 +209,19 @@ functionality. (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 (make-network-process :name name :buffer buffer :host host :service service)) - (greeting (network-stream-get-response stream start eoc)) - (capabilities (network-stream-command stream capability-command eoc)) + (greeting (and (not (plist-get parameters :nogreeting)) + (network-stream-get-response stream start eoc))) + (capabilities (network-stream-command stream capability-command + eo-capa)) (resulting-type 'plain) (builtin-starttls (and (fboundp 'gnutls-available-p) (gnutls-available-p))) - starttls-command error) + starttls-available starttls-command error) ;; First check whether the server supports STARTTLS at all. (when (and capabilities success-string starttls-function) @@ -220,23 +230,25 @@ functionality. ;; If we have built-in STARTTLS support, try to upgrade the ;; connection. (when (and starttls-command - (or builtin-starttls - (and (or require-tls - (plist-get parameters :use-starttls-if-possible)) - (executable-find "gnutls-cli"))) + (setq starttls-available + (or builtin-starttls + (and (or require-tls + (plist-get parameters :use-starttls-if-possible)) + (starttls-available-p)))) (not (eq (plist-get parameters :type) 'plain))) ;; 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 + (let* ((starttls-extra-arguments + (if (or require-tls + (member "--insecure" starttls-extra-arguments)) starttls-extra-arguments ;; For opportunistic TLS upgrades, we don't really ;; care about the identity of the peer. (cons "--insecure" starttls-extra-arguments))) + (starttls-extra-args starttls-extra-args) (cert (network-stream-certificate host service parameters))) ;; There are client certificates requested, so add them to ;; the command line. @@ -244,20 +256,33 @@ functionality. (setq starttls-extra-arguments (nconc (list "--x509keyfile" (expand-file-name (nth 0 cert)) "--x509certfile" (expand-file-name (nth 1 cert))) - starttls-extra-arguments))) + starttls-extra-arguments) + starttls-extra-args + (nconc (list "--key-file" (expand-file-name (nth 0 cert)) + "--cert-file" (expand-file-name (nth 1 cert))) + starttls-extra-args))) (setq stream (starttls-open-stream name buffer host service))) (network-stream-get-response stream start eoc) ;; Requery capabilities for protocols that require it; i.e., ;; EHLO for SMTP. (when (plist-get parameters :always-query-capabilities) - (network-stream-command stream capability-command eoc))) - (when (string-match success-string - (network-stream-command stream starttls-command eoc)) + (network-stream-command stream capability-command eo-capa))) + (when (let ((response + (network-stream-command stream starttls-command eoc))) + (and response (string-match success-string response))) ;; The server said it was OK to begin STARTTLS negotiations. (if builtin-starttls (let ((cert (network-stream-certificate host service parameters))) - (gnutls-negotiate :process stream :hostname host - :keylist (and cert (list cert)))) + (condition-case nil + (gnutls-negotiate :process stream :hostname host + :keylist (and cert (list cert))) + ;; If we get a gnutls-specific error (for instance if + ;; the certificate the server gives us is completely + ;; syntactically invalid), then close the connection + ;; and possibly (further down) try to create a + ;; non-encrypted connection. + (gnutls-error + (delete-process stream)))) (unless (starttls-negotiate stream) (delete-process stream))) (if (memq (process-status stream) '(open run)) @@ -271,21 +296,27 @@ functionality. (network-stream-get-response stream start eoc))) ;; Re-get the capabilities, which may have now changed. (setq capabilities - (network-stream-command stream capability-command eoc)))) + (network-stream-command stream capability-command eo-capa)))) ;; If TLS is mandatory, close the connection if it's unencrypted. - (when (and (or require-tls - ;; The server said it was possible to do STARTTLS, - ;; and we wanted to use it... - (and starttls-command - (plist-get parameters :use-starttls-if-possible))) + (when (and require-tls ;; ... but Emacs wasn't able to -- either no built-in ;; support, or no gnutls-cli installed. (eq resulting-type 'plain)) - (setq error - (if require-tls - "Server does not support TLS" - "Server supports STARTTLS, but Emacs does not have support for it")) + (setq error + (if (or (null starttls-command) + starttls-available) + "Server does not support TLS" + ;; See `starttls-available-p'. If this predicate + ;; changes to allow running under Windows, the error + ;; message below should be amended. + (if (memq system-type '(windows-nt ms-dos)) + (concat "Emacs does not support TLS") + (concat "Emacs does not support TLS, and no external `" + (if starttls-use-gnutls + starttls-gnutls-program + starttls-program) + "' program was found")))) (delete-process stream) (setq stream nil)) ;; Return value: @@ -353,7 +384,9 @@ functionality. ?p service)))))) (list stream (network-stream-get-response stream start eoc) - (network-stream-command stream capability-command eoc) + (network-stream-command stream capability-command + (or (plist-get parameters :end-of-capability) + eoc)) 'plain))) (provide 'network-stream)