Merge from origin/emacs-24

[gnu-emacs] / lisp / net / network-stream.el

diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el
index 81d05eabc5ab7d4c43db7cae0cde750d100604ad..9e4b0bab6ac3991880ab20574fb7c5aae28777c0 100644 (file)
--- 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-2012 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2014 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: network
@@ -45,6 +45,7 @@
 (require 'tls)
 (require 'starttls)
 (require 'auth-source)
+(require 'nsm)
 
 (autoload 'gnutls-negotiate "gnutls")
 (autoload 'open-gnutls-stream "gnutls")
@@ -128,8 +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))
@@ -193,6 +200,8 @@ STARTTLS upgrades even if Emacs doesn't have built-in TLS functionality.
        (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))
@@ -211,12 +220,11 @@ STARTTLS upgrades even if Emacs doesn't have built-in TLS functionality.
         ;; 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))
+        (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-available starttls-command error)
 
     ;; First check whether the server supports STARTTLS at all.
@@ -227,18 +235,19 @@ STARTTLS upgrades even if Emacs doesn't have built-in TLS functionality.
     ;; 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
-               (if require-tls
+               (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.
@@ -262,10 +271,11 @@ STARTTLS upgrades even if Emacs doesn't have built-in TLS functionality.
        ;; EHLO for SMTP.
        (when (plist-get parameters :always-query-capabilities)
          (network-stream-command stream capability-command eo-capa)))
-      (when (string-match success-string
-                         (network-stream-command stream starttls-command eoc))
+      (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
+       (if (gnutls-available-p)
            (let ((cert (network-stream-certificate host service parameters)))
              (condition-case nil
                  (gnutls-negotiate :process stream :hostname host
@@ -313,6 +323,12 @@ STARTTLS upgrades even if Emacs doesn't have built-in TLS functionality.
                        "' 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)))
 
@@ -338,19 +354,20 @@ STARTTLS upgrades even if Emacs doesn't have built-in TLS functionality.
 (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))