Implement a Network Security Manager

* processes.texi (Network): Mention the new :warn-unless-encrypted
parameter to `open-network-stream'.
(Network): Mention the Network Security Manager.

* net/nsm.el: New file that implements a Network Security Manager.

* net/network-stream.el (open-network-stream): Add a new
:warn-unless-encrypted parameter.
(network-stream-open-plain): Allow warning unless encrypted.
(network-stream-open-starttls): Call the Network Security Manager.
(network-stream-open-tls): Ditto.

3 files changed, 435 insertions, 1 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 43b3f9abc8c..e503a6e3194 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,13 @@
+2014-11-23  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+	* net/nsm.el: New file that implements a Network Security Manager.
+
+	* net/network-stream.el (open-network-stream): Add a new
+	:warn-unless-encrypted parameter.
+	(network-stream-open-plain): Allow warning unless encrypted.
+	(network-stream-open-starttls): Call the Network Security Manager.
+	(network-stream-open-tls): Ditto.
+
 2014-11-23  Leo Liu  <sdl.web@gmail.com>
 
 	* calendar/cal-china.el (calendar-chinese-from-absolute-for-diary)
diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el
index 28e9d0ccf32..a1e9729bac3 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))
@@ -319,6 +325,12 @@ a greeting from the server.
 			"' program was found"))))
       (delete-process stream)
       (setq stream nil))
+    ;; Check certificate validity etc.
+    (when builtin-starttls
+      (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)))
 
@@ -352,6 +364,9 @@ a greeting from the server.
 		       'open-tls-stream)
 		     name buffer host service))
 	   (eoc (plist-get parameters :end-of-command)))
+      ;; Check certificate validity etc.
+      (when (and use-builtin-gnutls 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
diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el
new file mode 100644
index 00000000000..f51201a1270
--- /dev/null
+++ b/lisp/net/nsm.el
@@ -0,0 +1,409 @@
+;;; nsm.el --- Network Security Manager
+
+;; Copyright (C) 2014 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: encryption, security, 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:
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defvar nsm-permanent-host-settings nil)
+(defvar nsm-temporary-host-settings nil)
+
+(defgroup nsm nil
+  "Network Security Manager"
+  :version "25.1"
+  :group 'comm)
+
+(defcustom nsm-security-level 'medium
+  "How secure the network should be."
+  :version "25.1"
+  :group 'nsm
+  :type '(choice (const :tag "Low" low)
+		 (const :tag "Medium" medium)
+		 (const :tag "High" high)
+		 (const :tag "Paranoid" paranoid)))
+
+(defcustom nsm-settings-file (expand-file-name "network-security.data"
+						 user-emacs-directory)
+  "The file the security manager settings will be stored in."
+  :version "25.1"
+  :group 'nsm
+  :type 'file)
+
+(defcustom nsm-save-host-names nil
+  "If non-nil, always save host names in the structures in `nsm-settings-file'.
+By default, only hosts that have exceptions have their names
+stored in plain text."
+  :version "25.1"
+  :group 'nsm
+  :type 'boolean)
+
+(defvar nsm-noninteractive nil
+  "If non-nil, the connection is opened in a non-interactive context.
+This means that no queries should be performed.")
+
+(defun nsm-verify-connection (process host port &optional
+				      save-fingerprint warn-unencrypted)
+  "Verify the security status of PROCESS that's connected to HOST:PORT.
+If PROCESS is a gnutls connection, the certificate validity will
+be examined.  If it's a non-TLS connection, it may be compared
+against previous connections.  If the function determines that
+there is something odd about the connection, the user will be
+queried about what to do about it.
+
+The process it returned if everything is OK, and otherwise, the
+process will be deleted and nil is returned.
+
+If SAVE-FINGERPRINT, always save the fingerprint of the
+server (if the connection is a TLS connection).  This is useful
+to keep track of the TLS status of STARTTLS servers.
+
+If WARN-UNENCRYPTED, query the user if the connection is
+unencrypted."
+  (if (eq nsm-security-level 'low)
+      process
+    (let* ((status (gnutls-peer-status process))
+	   (id (nsm-id host port))
+	   (settings (nsm-host-settings id)))
+      (cond
+       ((not (process-live-p process))
+	nil)
+       ((not status)
+	;; This is a non-TLS connection.
+	(nsm-check-plain-connection process host port settings
+				    warn-unencrypted))
+       (t
+	(let ((process
+	       (nsm-check-tls-connection process host port status settings)))
+	  (when (and process save-fingerprint
+		     (null (nsm-host-settings id)))
+	    (nsm-save-host host port status 'fingerprint 'always))
+	  process))))))
+
+(defun nsm-check-tls-connection (process host port status settings)
+  (let ((warnings (plist-get status :warnings)))
+    (cond
+
+     ;; The certificate validated, but perhaps we want to do
+     ;; certificate pinning.
+     ((null warnings)
+      (cond
+       ((< (nsm-level nsm-security-level) (nsm-level 'high))
+	process)
+       ;; The certificate is fine, but if we're paranoid, we might
+       ;; want to check whether it's changed anyway.
+       ((and (>= (nsm-level nsm-security-level) (nsm-level 'high))
+	     (not (nsm-fingerprint-ok-p host port status settings)))
+	(delete-process process)
+	nil)
+       ;; We haven't seen this before, and we're paranoid.
+       ((and (eq nsm-security-level 'paranoid)
+	     (null settings)
+	     (not (nsm-new-fingerprint-ok-p host port status)))
+	(delete-process process)
+	nil)
+       ((>= (nsm-level nsm-security-level) (nsm-level 'high))
+	;; Save the host fingerprint so that we can check it the
+	;; next time we connect.
+	(nsm-save-host host port status 'fingerprint 'always)
+	process)
+       (t
+	process)))
+
+     ;; The certificate did not validate.
+     ((not (equal nsm-security-level 'low))
+      ;; We always want to pin the certificate of invalid connections
+      ;; to track man-in-the-middle or the like.
+      (if (not (nsm-fingerprint-ok-p host port status settings))
+	  (progn
+	    (delete-process process)
+	    nil)
+	;; We have a warning, so query the user.
+	(if (and (not (nsm-warnings-ok-p status settings))
+		 (not (nsm-query
+		       host port status 'conditions
+		       "The TLS connection to %s:%s is insecure\nfor the following reason%s:\n\n%s"
+		       host port
+		       (if (> (length warnings) 1)
+			   "s" "")
+		       (mapconcat 'cadr warnings "\n"))))
+	    (progn
+	      (delete-process process)
+	      nil)
+	  process))))))
+
+(defun nsm-fingerprint (status)
+  (plist-get (plist-get status :certificate) :public-key-id))
+
+(defun nsm-fingerprint-ok-p (host port status settings)
+  (let ((did-query nil))
+    (if (and settings
+	     (not (eq (plist-get settings :fingerprint) :none))
+	     (not (equal (nsm-fingerprint status)
+			 (plist-get settings :fingerprint)))
+	     (not
+	      (setq did-query
+		    (nsm-query
+		     host port status 'fingerprint
+		     "The fingerprint for the connection to %s:%s has changed from\n%s to\n%s"
+		     host port
+		     (plist-get settings :fingerprint)
+		     (nsm-fingerprint status)))))
+	;; Not OK.
+	nil
+      (when did-query
+	;; Remove any exceptions that have been set on the previous
+	;; certificate.
+	(plist-put settings :conditions nil))
+      t)))
+
+(defun nsm-new-fingerprint-ok-p (host port status)
+  (nsm-query
+   host port nil 'fingerprint
+   "The fingerprint for the connection to %s:%s is new:\n%s"
+   host port
+   (nsm-fingerprint status)))
+
+(defun nsm-check-plain-connection (process host port settings warn-unencrypted)
+  ;; If this connection used to be TLS, but is now plain, then it's
+  ;; possible that we're being Man-In-The-Middled by a proxy that's
+  ;; stripping out STARTTLS announcements.
+  (cond
+   ((and (plist-get settings :fingerprint)
+	 (not (eq (plist-get settings :fingerprint) :none))
+	 (not
+	  (nsm-query
+	   host port nil 'conditions
+	   "The connection to %s:%s used to be an encrypted\nconnection, but is now unencrypted.  This might mean that there's a\nman-in-the-middle tapping this connection."
+	   host port)))
+    (delete-process process)
+    nil)
+   ((and warn-unencrypted
+	 (not (memq :unencrypted (plist-get settings :conditions)))
+	 (not (nsm-query
+	       host port nil 'conditions
+	       "The connection to %s:%s is unencrypted."
+	       host port)))
+    (delete-process process)
+    nil)
+   (t
+    process)))
+
+(defun nsm-query (host port status what message &rest args)
+  ;; If there is no user to answer queries, then say `no' to everything.
+  (if (or noninteractive
+	  nsm-noninteractive)
+      nil
+    (let ((response
+	   (condition-case nil
+	       (nsm-query-user message args (nsm-format-certificate status))
+	     ;; Make sure we manage to close the process if the user hits
+	     ;; `C-g'.
+	     (quit 'no)
+	     (error 'no))))
+      (if (eq response 'no)
+	  nil
+	(nsm-save-host host port status what response)
+	t))))
+
+(defun nsm-query-user (message args cert)
+  (let ((buffer (get-buffer-create "*Network Security Manager*")))
+    (with-help-window buffer
+      (with-current-buffer buffer
+	(erase-buffer)
+	(when (> (length cert) 0)
+	  (insert cert "\n"))
+	(insert (apply 'format message args))))
+    (let ((responses '((?n . no)
+		       (?s . session)
+		       (?a . always)))
+	  (prefix "")
+	  response)
+      (while (not response)
+	(setq response
+	      (cdr
+	       (assq (downcase
+		      (read-char
+		       (concat prefix
+			       "Continue connecting? (No, Session only, Always)")))
+		     responses)))
+	(unless response
+	  (ding)
+	  (setq prefix "Invalid choice.  ")))
+      (kill-buffer buffer)
+      ;; If called from a callback, `read-char' will insert things
+      ;; into the pending input.  Clear that.
+      (clear-this-command-keys)
+      response)))
+
+(defun nsm-save-host (host port status what permanency)
+  (let* ((id (nsm-id host port))
+	 (saved
+	  (list :id id
+		:fingerprint (or (nsm-fingerprint status)
+				 ;; Plain connection.
+				 :none))))
+    (when (or (eq what 'conditions)
+	      nsm-save-host-names)
+      (nconc saved (list :host (format "%s:%s" host port))))
+    ;; We either want to save/update the fingerprint or the conditions
+    ;; of the certificate/unencrypted connection.
+    (when (eq what 'conditions)
+      (nconc saved (list :host (format "%s:%s" host port)))
+      (cond
+       ((not status)
+	(nconc saved `(:conditions (:unencrypted))))
+       ((plist-get status :warnings)
+	(nconc saved
+	       `(:conditions ,(mapcar 'car (plist-get status :warnings)))))))
+    (if (eq permanency 'always)
+	(progn
+	  (nsm-remove-temporary-setting id)
+	  (nsm-remove-permanent-setting id)
+	  (push saved nsm-permanent-host-settings)
+	  (nsm-write-settings))
+      (nsm-remove-temporary-setting id)
+      (push saved nsm-temporary-host-settings))))
+
+(defun nsm-write-settings ()
+  (with-temp-file nsm-settings-file
+    (insert "(\n")
+    (dolist (setting nsm-permanent-host-settings)
+      (insert " ")
+      (prin1 setting (current-buffer))
+      (insert "\n"))
+    (insert ")\n")))
+
+(defun nsm-read-settings ()
+  (setq nsm-permanent-host-settings
+	(with-temp-buffer
+	  (insert-file-contents nsm-settings-file)
+	  (goto-char (point-min))
+	  (ignore-errors (read (current-buffer))))))
+
+(defun nsm-id (host port)
+  (concat "sha1:" (sha1 (format "%s:%s" host port))))
+
+(defun nsm-host-settings (id)
+  (when (and (not nsm-permanent-host-settings)
+	     (file-exists-p nsm-settings-file))
+    (nsm-read-settings))
+  (let ((result nil))
+    (dolist (elem (append nsm-temporary-host-settings
+			  nsm-permanent-host-settings))
+      (when (and (not result)
+		 (equal (plist-get elem :id) id))
+	(setq result elem)))
+    result))
+
+(defun nsm-warnings-ok-p (status settings)
+  (let ((not-ok nil)
+	(conditions (plist-get settings :conditions)))
+    (dolist (warning (plist-get status :warnings))
+      (when (memq (car warning) conditions)
+	(setq not-ok t)))
+    not-ok))
+
+(defun nsm-remove-permanent-setting (id)
+  (setq nsm-permanent-host-settings
+	(cl-delete-if
+	 (lambda (elem)
+	   (equal (plist-get elem :id) id))
+	 nsm-permanent-host-settings)))
+
+(defun nsm-remove-temporary-setting (id)
+  (setq nsm-temporary-host-settings
+	(cl-delete-if
+	 (lambda (elem)
+	   (equal (plist-get elem :id) id))
+	 nsm-temporary-host-settings)))
+
+(defun nsm-format-certificate (status)
+  (let ((cert (plist-get status :certificate)))
+    (when cert
+      (with-temp-buffer
+	(insert
+	 "Certificate information\n"
+	 "Issued by:"
+	 (nsm-certificate-part (plist-get cert :issuer) "CN" t) "\n"
+	 "Issued to:"
+	 (or (nsm-certificate-part (plist-get cert :subject) "O")
+	     (nsm-certificate-part (plist-get cert :subject) "OU" t))
+	 "\n"
+	 "Hostname:"
+	 (nsm-certificate-part (plist-get cert :subject) "CN" t) "\n"
+	 "Public key:" (plist-get cert :public-key-algorithm)
+	 ", signature: " (plist-get cert :signature-algorithm) "\n"
+	 "Security level:"
+	 (propertize (plist-get cert :certificate-security-level)
+		     'face 'bold)
+	 "\n"
+	 "Valid:From " (plist-get cert :valid-from)
+	 " to " (plist-get cert :valid-to) "\n\n")
+	(goto-char (point-min))
+	(while (re-search-forward "^[^:]+:" nil t)
+	  (insert (make-string (- 20 (current-column)) ? )))
+	(buffer-string)))))
+
+(defun nsm-certificate-part (string part &optional full)
+  (let ((part (cadr (assoc part (nsm-parse-subject string)))))
+    (cond
+     (part part)
+     (full string)
+     (t nil))))
+
+(defun nsm-parse-subject (string)
+  (with-temp-buffer
+    (insert string)
+    (goto-char (point-min))
+    (let ((start (point))
+	  (result nil))
+      (while (not (eobp))
+	(push (replace-regexp-in-string
+	       "[\\]\\(.\\)" "\\1"
+	       (buffer-substring start
+				 (if (re-search-forward "[^\\]," nil 'move)
+				     (1- (point))
+				   (point))))
+	      result)
+	(setq start (point)))
+      (mapcar
+       (lambda (elem)
+	 (let ((pos (cl-position ?= elem)))
+	   (if pos
+	       (list (substring elem 0 pos)
+		     (substring elem (1+ pos)))
+	     elem)))
+       (nreverse result)))))
+
+(defun nsm-level (symbol)
+  "Return a numerical level for SYMBOL for easier comparison."
+  (cond
+   ((eq symbol 'low) 0)
+   ((eq symbol 'medium) 1)
+   ((eq symbol 'high) 2)
+   (t 3)))
+
+(provide 'nsm)
+
+;;; nsm.el ends here