code.delx.au - gnu-emacs/blob - lisp/net/nsm.el

   1 ;;; nsm.el --- Network Security Manager
   2
   3 ;; Copyright (C) 2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: encryption, security, network
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (require 'cl-lib)
  28
  29 (defvar nsm-permanent-host-settings nil)
  30 (defvar nsm-temporary-host-settings nil)
  31
  32 (defgroup nsm nil
  33   "Network Security Manager"
  34   :version "25.1"
  35   :group 'comm)
  36
  37 (defcustom network-security-level 'medium
  38   "How secure the network should be.
  39 If a potential problem with the security of the network
  40 connection is found, the user is asked to give input into how the
  41 connection should be handled.
  42
  43 The following values are possible:
  44
  45 `low': Absolutely no checks are performed.
  46
  47 `medium': This is the default level, and the following things will
  48 be prompted for.
  49
  50 * invalid, self-signed or otherwise unverifiable certificates
  51 * whether a previously accepted unverifiable certificate has changed
  52 * when a connection that was previously protected by STARTTLS is
  53   now unencrypted
  54
  55 `high': In addition to the above.
  56
  57 * any certificate that changes its public key
  58
  59 `paranoid': In addition to the above.
  60
  61 * any new certificate that you haven't seen before"
  62   :version "25.1"
  63   :group 'nsm
  64   :type '(choice (const :tag "Low" low)
  65                  (const :tag "Medium" medium)
  66                  (const :tag "High" high)
  67                  (const :tag "Paranoid" paranoid)))
  68
  69 (defcustom nsm-settings-file (expand-file-name "network-security.data"
  70                                                  user-emacs-directory)
  71   "The file the security manager settings will be stored in."
  72   :version "25.1"
  73   :group 'nsm
  74   :type 'file)
  75
  76 (defcustom nsm-save-host-names nil
  77   "If non-nil, always save host names in the structures in `nsm-settings-file'.
  78 By default, only hosts that have exceptions have their names
  79 stored in plain text."
  80   :version "25.1"
  81   :group 'nsm
  82   :type 'boolean)
  83
  84 (defvar nsm-noninteractive nil
  85   "If non-nil, the connection is opened in a non-interactive context.
  86 This means that no queries should be performed.")
  87
  88 (defun nsm-verify-connection (process host port &optional
  89                                       save-fingerprint warn-unencrypted)
  90   "Verify the security status of PROCESS that's connected to HOST:PORT.
  91 If PROCESS is a gnutls connection, the certificate validity will
  92 be examined.  If it's a non-TLS connection, it may be compared
  93 against previous connections.  If the function determines that
  94 there is something odd about the connection, the user will be
  95 queried about what to do about it.
  96
  97 The process it returned if everything is OK, and otherwise, the
  98 process will be deleted and nil is returned.
  99
 100 If SAVE-FINGERPRINT, always save the fingerprint of the
 101 server (if the connection is a TLS connection).  This is useful
 102 to keep track of the TLS status of STARTTLS servers.
 103
 104 If WARN-UNENCRYPTED, query the user if the connection is
 105 unencrypted."
 106   (if (eq network-security-level 'low)
 107       process
 108     (let* ((status (gnutls-peer-status process))
 109            (id (nsm-id host port))
 110            (settings (nsm-host-settings id)))
 111       (cond
 112        ((not (process-live-p process))
 113         nil)
 114        ((not status)
 115         ;; This is a non-TLS connection.
 116         (nsm-check-plain-connection process host port settings
 117                                     warn-unencrypted))
 118        (t
 119         (let ((process
 120                (nsm-check-tls-connection process host port status settings)))
 121           (when (and process save-fingerprint
 122                      (null (nsm-host-settings id)))
 123             (nsm-save-host host port status 'fingerprint 'always))
 124           process))))))
 125
 126 (defun nsm-check-tls-connection (process host port status settings)
 127   (let ((warnings (plist-get status :warnings)))
 128     (cond
 129
 130      ;; The certificate validated, but perhaps we want to do
 131      ;; certificate pinning.
 132      ((null warnings)
 133       (cond
 134        ((< (nsm-level network-security-level) (nsm-level 'high))
 135         process)
 136        ;; The certificate is fine, but if we're paranoid, we might
 137        ;; want to check whether it's changed anyway.
 138        ((and (>= (nsm-level network-security-level) (nsm-level 'high))
 139              (not (nsm-fingerprint-ok-p host port status settings)))
 140         (delete-process process)
 141         nil)
 142        ;; We haven't seen this before, and we're paranoid.
 143        ((and (eq network-security-level 'paranoid)
 144              (null settings)
 145              (not (nsm-new-fingerprint-ok-p host port status)))
 146         (delete-process process)
 147         nil)
 148        ((>= (nsm-level network-security-level) (nsm-level 'high))
 149         ;; Save the host fingerprint so that we can check it the
 150         ;; next time we connect.
 151         (nsm-save-host host port status 'fingerprint 'always)
 152         process)
 153        (t
 154         process)))
 155
 156      ;; The certificate did not validate.
 157      ((not (equal network-security-level 'low))
 158       ;; We always want to pin the certificate of invalid connections
 159       ;; to track man-in-the-middle or the like.
 160       (if (not (nsm-fingerprint-ok-p host port status settings))
 161           (progn
 162             (delete-process process)
 163             nil)
 164         ;; We have a warning, so query the user.
 165         (if (and (not (nsm-warnings-ok-p status settings))
 166                  (not (nsm-query
 167                        host port status 'conditions
 168                        "The TLS connection to %s:%s is insecure\nfor the following reason%s:\n\n%s"
 169                        host port
 170                        (if (> (length warnings) 1)
 171                            "s" "")
 172                        (mapconcat #'gnutls-peer-status-warning-describe
 173                                   warnings
 174                                   "\n"))))
 175             (progn
 176               (delete-process process)
 177               nil)
 178           process))))))
 179
 180 (defun nsm-fingerprint (status)
 181   (plist-get (plist-get status :certificate) :public-key-id))
 182
 183 (defun nsm-fingerprint-ok-p (host port status settings)
 184   (let ((did-query nil))
 185     (if (and settings
 186              (not (eq (plist-get settings :fingerprint) :none))
 187              (not (equal (nsm-fingerprint status)
 188                          (plist-get settings :fingerprint)))
 189              (not
 190               (setq did-query
 191                     (nsm-query
 192                      host port status 'fingerprint
 193                      "The fingerprint for the connection to %s:%s has changed from\n%s to\n%s"
 194                      host port
 195                      (plist-get settings :fingerprint)
 196                      (nsm-fingerprint status)))))
 197         ;; Not OK.
 198         nil
 199       (when did-query
 200         ;; Remove any exceptions that have been set on the previous
 201         ;; certificate.
 202         (plist-put settings :conditions nil))
 203       t)))
 204
 205 (defun nsm-new-fingerprint-ok-p (host port status)
 206   (nsm-query
 207    host port status 'fingerprint
 208    "The fingerprint for the connection to %s:%s is new:\n%s"
 209    host port
 210    (nsm-fingerprint status)))
 211
 212 (defun nsm-check-plain-connection (process host port settings warn-unencrypted)
 213   ;; If this connection used to be TLS, but is now plain, then it's
 214   ;; possible that we're being Man-In-The-Middled by a proxy that's
 215   ;; stripping out STARTTLS announcements.
 216   (cond
 217    ((and (plist-get settings :fingerprint)
 218          (not (eq (plist-get settings :fingerprint) :none))
 219          (not
 220           (nsm-query
 221            host port nil 'conditions
 222            "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."
 223            host port)))
 224     (delete-process process)
 225     nil)
 226    ((and warn-unencrypted
 227          (not (memq :unencrypted (plist-get settings :conditions)))
 228          (not (nsm-query
 229                host port nil 'conditions
 230                "The connection to %s:%s is unencrypted."
 231                host port)))
 232     (delete-process process)
 233     nil)
 234    (t
 235     process)))
 236
 237 (defun nsm-query (host port status what message &rest args)
 238   ;; If there is no user to answer queries, then say `no' to everything.
 239   (if (or noninteractive
 240           nsm-noninteractive)
 241       nil
 242     (let ((response
 243            (condition-case nil
 244                (nsm-query-user message args (nsm-format-certificate status))
 245              ;; Make sure we manage to close the process if the user hits
 246              ;; `C-g'.
 247              (quit 'no)
 248              (error 'no))))
 249       (if (eq response 'no)
 250           nil
 251         (nsm-save-host host port status what response)
 252         t))))
 253
 254 (defun nsm-query-user (message args cert)
 255   (let ((buffer (get-buffer-create "*Network Security Manager*")))
 256     (with-help-window buffer
 257       (with-current-buffer buffer
 258         (erase-buffer)
 259         (when (> (length cert) 0)
 260           (insert cert "\n"))
 261         (insert (apply 'format message args))))
 262     (let ((responses '((?n . no)
 263                        (?s . session)
 264                        (?a . always)))
 265           (prefix "")
 266           response)
 267       (while (not response)
 268         (setq response
 269               (cdr
 270                (assq (downcase
 271                       (read-char
 272                        (concat prefix
 273                                "Continue connecting? (No, Session only, Always)")))
 274                      responses)))
 275         (unless response
 276           (ding)
 277           (setq prefix "Invalid choice.  ")))
 278       (kill-buffer buffer)
 279       ;; If called from a callback, `read-char' will insert things
 280       ;; into the pending input.  Clear that.
 281       (clear-this-command-keys)
 282       response)))
 283
 284 (defun nsm-save-host (host port status what permanency)
 285   (let* ((id (nsm-id host port))
 286          (saved
 287           (list :id id
 288                 :fingerprint (or (nsm-fingerprint status)
 289                                  ;; Plain connection.
 290                                  :none))))
 291     (when (or (eq what 'conditions)
 292               nsm-save-host-names)
 293       (nconc saved (list :host (format "%s:%s" host port))))
 294     ;; We either want to save/update the fingerprint or the conditions
 295     ;; of the certificate/unencrypted connection.
 296     (when (eq what 'conditions)
 297       (nconc saved (list :host (format "%s:%s" host port)))
 298       (cond
 299        ((not status)
 300         (nconc saved `(:conditions (:unencrypted))))
 301        ((plist-get status :warnings)
 302         (nconc saved
 303                `(:conditions ,(plist-get status :warnings))))))
 304     (if (eq permanency 'always)
 305         (progn
 306           (nsm-remove-temporary-setting id)
 307           (nsm-remove-permanent-setting id)
 308           (push saved nsm-permanent-host-settings)
 309           (nsm-write-settings))
 310       (nsm-remove-temporary-setting id)
 311       (push saved nsm-temporary-host-settings))))
 312
 313 (defun nsm-write-settings ()
 314   (with-temp-file nsm-settings-file
 315     (insert "(\n")
 316     (dolist (setting nsm-permanent-host-settings)
 317       (insert " ")
 318       (prin1 setting (current-buffer))
 319       (insert "\n"))
 320     (insert ")\n")))
 321
 322 (defun nsm-read-settings ()
 323   (setq nsm-permanent-host-settings
 324         (with-temp-buffer
 325           (insert-file-contents nsm-settings-file)
 326           (goto-char (point-min))
 327           (ignore-errors (read (current-buffer))))))
 328
 329 (defun nsm-id (host port)
 330   (concat "sha1:" (sha1 (format "%s:%s" host port))))
 331
 332 (defun nsm-host-settings (id)
 333   (when (and (not nsm-permanent-host-settings)
 334              (file-exists-p nsm-settings-file))
 335     (nsm-read-settings))
 336   (let ((result nil))
 337     (dolist (elem (append nsm-temporary-host-settings
 338                           nsm-permanent-host-settings))
 339       (when (and (not result)
 340                  (equal (plist-get elem :id) id))
 341         (setq result elem)))
 342     result))
 343
 344 (defun nsm-warnings-ok-p (status settings)
 345   (let ((ok t)
 346         (conditions (plist-get settings :conditions)))
 347     (dolist (warning (plist-get status :warnings))
 348       (unless (memq warning conditions)
 349         (setq ok nil)))
 350     ok))
 351
 352 (defun nsm-remove-permanent-setting (id)
 353   (setq nsm-permanent-host-settings
 354         (cl-delete-if
 355          (lambda (elem)
 356            (equal (plist-get elem :id) id))
 357          nsm-permanent-host-settings)))
 358
 359 (defun nsm-remove-temporary-setting (id)
 360   (setq nsm-temporary-host-settings
 361         (cl-delete-if
 362          (lambda (elem)
 363            (equal (plist-get elem :id) id))
 364          nsm-temporary-host-settings)))
 365
 366 (defun nsm-format-certificate (status)
 367   (let ((cert (plist-get status :certificate)))
 368     (when cert
 369       (with-temp-buffer
 370         (insert
 371          "Certificate information\n"
 372          "Issued by:"
 373          (nsm-certificate-part (plist-get cert :issuer) "CN" t) "\n"
 374          "Issued to:"
 375          (or (nsm-certificate-part (plist-get cert :subject) "O")
 376              (nsm-certificate-part (plist-get cert :subject) "OU" t))
 377          "\n"
 378          "Hostname:"
 379          (nsm-certificate-part (plist-get cert :subject) "CN" t) "\n")
 380         (when (and (plist-get cert :public-key-algorithm)
 381                    (plist-get cert :signature-algorithm))
 382           (insert
 383            "Public key:" (plist-get cert :public-key-algorithm)
 384            ", signature: " (plist-get cert :signature-algorithm) "\n"))
 385         (when (plist-get cert :certificate-security-level)
 386           (insert
 387            "Security level:"
 388            (propertize (plist-get cert :certificate-security-level)
 389                        'face 'bold)
 390            "\n"))
 391         (insert
 392          "Valid:From " (plist-get cert :valid-from)
 393          " to " (plist-get cert :valid-to) "\n\n")
 394         (goto-char (point-min))
 395         (while (re-search-forward "^[^:]+:" nil t)
 396           (insert (make-string (- 20 (current-column)) ? )))
 397         (buffer-string)))))
 398
 399 (defun nsm-certificate-part (string part &optional full)
 400   (let ((part (cadr (assoc part (nsm-parse-subject string)))))
 401     (cond
 402      (part part)
 403      (full string)
 404      (t nil))))
 405
 406 (defun nsm-parse-subject (string)
 407   (with-temp-buffer
 408     (insert string)
 409     (goto-char (point-min))
 410     (let ((start (point))
 411           (result nil))
 412       (while (not (eobp))
 413         (push (replace-regexp-in-string
 414                "[\\]\\(.\\)" "\\1"
 415                (buffer-substring start
 416                                  (if (re-search-forward "[^\\]," nil 'move)
 417                                      (1- (point))
 418                                    (point))))
 419               result)
 420         (setq start (point)))
 421       (mapcar
 422        (lambda (elem)
 423          (let ((pos (cl-position ?= elem)))
 424            (if pos
 425                (list (substring elem 0 pos)
 426                      (substring elem (1+ pos)))
 427              elem)))
 428        (nreverse result)))))
 429
 430 (defun nsm-level (symbol)
 431   "Return a numerical level for SYMBOL for easier comparison."
 432   (cond
 433    ((eq symbol 'low) 0)
 434    ((eq symbol 'medium) 1)
 435    ((eq symbol 'high) 2)
 436    (t 3)))
 437
 438 (provide 'nsm)
 439
 440 ;;; nsm.el ends here