diff options
Diffstat (limited to 'lisp/net/network-stream.el')
| -rw-r--r-- | lisp/net/network-stream.el | 31 |
1 files changed, 21 insertions, 10 deletions
diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index ea03bc65499..e7b3150b792 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -45,6 +45,7 @@ (require 'tls) (require 'starttls) (require 'auth-source) +(require 'nsm) (autoload 'gnutls-negotiate "gnutls") (autoload 'open-gnutls-stream "gnutls") @@ -128,11 +129,14 @@ values: :use-starttls-if-possible is a boolean that says to do opportunistic STARTTLS upgrades even if Emacs doesn't have built-in TLS functionality. +:warn-unless-encrypted is a boolean which, if :return-list is +non-nil, is used warn the user if the connection isn't encrypted. + :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." +asynchronously, if possible." (unless (featurep 'make-network-process) (error "Emacs was compiled without networking support")) (let ((type (plist-get parameters :type)) @@ -196,6 +200,8 @@ a greeting from the server. (stream (make-network-process :name name :buffer buffer :host host :service service :nowait (plist-get parameters :nowait)))) + (when (plist-get parameters :warn-unless-encrypted) + (setq stream (nsm-verify-connection stream host service nil t))) (list stream (network-stream-get-response stream start (plist-get parameters :end-of-command)) @@ -219,8 +225,6 @@ a greeting from the server. (capabilities (network-stream-command stream capability-command eo-capa)) (resulting-type 'plain) - (builtin-starttls (and (fboundp 'gnutls-available-p) - (gnutls-available-p))) starttls-available starttls-command error) ;; First check whether the server supports STARTTLS at all. @@ -231,14 +235,14 @@ a greeting from the server. ;; connection. (when (and starttls-command (setq starttls-available - (or builtin-starttls + (or (gnutls-available-p) (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 + (unless (gnutls-available-p) (delete-process stream) (setq start (with-current-buffer buffer (point-max))) (let* ((starttls-extra-arguments @@ -271,7 +275,7 @@ a greeting from the server. (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 + (if (gnutls-available-p) (let ((cert (network-stream-certificate host service parameters))) (condition-case nil (gnutls-negotiate :process stream :hostname host @@ -319,6 +323,12 @@ a greeting from the server. "' program was found")))) (delete-process stream) (setq stream nil)) + ;; Check certificate validity etc. + (when (gnutls-available-p) + (setq stream (nsm-verify-connection + stream host service + (eq resulting-type 'tls) + (plist-get parameters :warn-unless-encrypted)))) ;; Return value: (list stream greeting capabilities resulting-type error))) @@ -344,19 +354,20 @@ a greeting from the server. (defun network-stream-open-tls (name buffer host service parameters) (with-current-buffer buffer (let* ((start (point-max)) - (use-builtin-gnutls (and (fboundp 'gnutls-available-p) - (gnutls-available-p))) (stream - (funcall (if use-builtin-gnutls + (funcall (if (gnutls-available-p) 'open-gnutls-stream 'open-tls-stream) name buffer host service)) (eoc (plist-get parameters :end-of-command))) + ;; Check certificate validity etc. + (when (and (gnutls-available-p) stream) + (setq stream (nsm-verify-connection stream host service))) (if (null stream) (list nil nil nil 'plain) ;; If we're using tls.el, we have to delete the output from ;; openssl/gnutls-cli. - (when (and (null use-builtin-gnutls) + (when (and (not (gnutls-available-p)) eoc) (network-stream-get-response stream start eoc) (goto-char (point-min)) |