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.

5 files changed, 468 insertions, 1 deletions

diff --git a/doc/lispref/ChangeLog b/doc/lispref/ChangeLog
index 0c8792af81f..5cc85aa60dc 100644
--- a/doc/lispref/ChangeLog
+++ b/doc/lispref/ChangeLog
@@ -1,3 +1,9 @@
+2014-11-23  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+        * processes.texi (Network): Mention the new :warn-unless-encrypted
+        parameter to `open-network-stream'.
+        (Network): Mention the Network Security Manager.
+
 2014-11-21  Ulf Jasper  <ulf.jasper@web.de>
 
         * text.texi (Parsing HTML/XML): Document new optional parameter
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi
index db80f0537e0..48429e6fd93 100644
--- a/doc/lispref/processes.texi
+++ b/doc/lispref/processes.texi
@@ -2041,6 +2041,12 @@ Regular expression matching a successful @acronym{STARTTLS} negotiation.
 If non-@code{nil}, do opportunistic @acronym{STARTTLS} upgrades even if Emacs
 doesn't have built-in @acronym{TLS} support.
 
+@item :warn-unless-encrypted @var{boolean}
+If non-@code{nil}, and @code{:return-value} is also non-@code{nil},
+Emacs will warn if the connection isn't encrypted.  This is useful for
+protocols like @acronym{IMAP} and the like, where most users would
+expect the network traffic to be encrypted.
+
 @item :client-certificate @var{list-or-t}
 Either a list of the form @code{(@var{key-file} @var{cert-file})},
 naming the certificate key file and certificate file itself, or
@@ -2066,6 +2072,27 @@ The connection type: @samp{plain} or @samp{tls}.
 
 @end defun
 
+@cindex Network Security Manager
+After establishing the connection, the connection is then passed on to
+the Network Security Manager (@acronym{NSM}).  If the connection is a
+@acronym{TLS} or @acronym{STARTTLS} connection, the @acronym{NSM} will
+check whether the certificate used to establish the identity of the
+server we're connecting to can be verified.  If this can't be done,
+the @acronym{NSM} will query the user whether to proceed with the
+connection.
+
+The user is given the choice of registering a permanent security
+exception, a temporary one, or whether to refuse the connection
+entirely.
+
+If the connection is unencrypted, but it was encrypted in previous
+sessions, the user will also be notified about this.
+
+@vindex nsm-security-level
+The @code{nsm-security-level} variable determines the security level.
+If this is @code{low}, no security checks are performed.
+
+
 @node Network Servers
 @section Network Servers
 @cindex network servers
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