lisp/net/nsm.el

   1 ;;; nsm.el --- Network Security Manager
   2
   3 ;; Copyright (C) 2014-2015 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 `medium': This is the default level, should be reasonable for most usage.
  47 `high': This warns about additional things that many people would
  48 not find useful.
  49 `paranoid': On this level, the user is queried for most new connections.
  50
  51 See the Emacs manual for a description of all things that are
  52 checked and warned against."
  53   :version "25.1"
  54   :group 'nsm
  55   :type '(choice (const :tag "Low" low)
  56                  (const :tag "Medium" medium)
  57                  (const :tag "High" high)
  58                  (const :tag "Paranoid" paranoid)))
  59
  60 (defcustom nsm-settings-file (expand-file-name "network-security.data"
  61                                                  user-emacs-directory)
  62   "The file the security manager settings will be stored in."
  63   :version "25.1"
  64   :group 'nsm
  65   :type 'file)
  66
  67 (defcustom nsm-save-host-names nil
  68   "If non-nil, always save host names in the structures in `nsm-settings-file'.
  69 By default, only hosts that have exceptions have their names
  70 stored in plain text."
  71   :version "25.1"
  72   :group 'nsm
  73   :type 'boolean)
  74
  75 (defvar nsm-noninteractive nil
  76   "If non-nil, the connection is opened in a non-interactive context.
  77 This means that no queries should be performed.")
  78
  79 (defun nsm-verify-connection (process host port &optional
  80                                       save-fingerprint warn-unencrypted)
  81   "Verify the security status of PROCESS that's connected to HOST:PORT.
  82 If PROCESS is a gnutls connection, the certificate validity will
  83 be examined.  If it's a non-TLS connection, it may be compared
  84 against previous connections.  If the function determines that
  85 there is something odd about the connection, the user will be
  86 queried about what to do about it.
  87
  88 The process it returned if everything is OK, and otherwise, the
  89 process will be deleted and nil is returned.
  90
  91 If SAVE-FINGERPRINT, always save the fingerprint of the
  92 server (if the connection is a TLS connection).  This is useful
  93 to keep track of the TLS status of STARTTLS servers.
  94
  95 If WARN-UNENCRYPTED, query the user if the connection is
  96 unencrypted."
  97   (if (eq network-security-level 'low)
  98       process
  99     (let* ((status (gnutls-peer-status process))
 100            (id (nsm-id host port))
 101            (settings (nsm-host-settings id)))
 102       (cond
 103        ((not (process-live-p process))
 104         nil)
 105        ((not status)
 106         ;; This is a non-TLS connection.
 107         (nsm-check-plain-connection process host port settings
 108                                     warn-unencrypted))
 109        (t
 110         (let ((process
 111                (nsm-check-tls-connection process host port status settings)))
 112           (when (and process save-fingerprint
 113                      (null (nsm-host-settings id)))
 114             (nsm-save-host host port status 'fingerprint 'always))
 115           process))))))
 116
 117 (defun nsm-check-tls-connection (process host port status settings)
 118   (let ((process (nsm-check-certificate process host port status settings)))
 119     (if (and process
 120              (>= (nsm-level network-security-level) (nsm-level 'high)))
 121         ;; Do further protocol-level checks if the security is high.
 122         (nsm-check-protocol process host port status settings)
 123       process)))
 124
 125 (defun nsm-check-certificate (process host port status settings)
 126   (let ((warnings (plist-get status :warnings)))
 127     (cond
 128
 129      ;; The certificate validated, but perhaps we want to do
 130      ;; certificate pinning.
 131      ((null warnings)
 132       (cond
 133        ((< (nsm-level network-security-level) (nsm-level 'high))
 134         process)
 135        ;; The certificate is fine, but if we're paranoid, we might
 136        ;; want to check whether it's changed anyway.
 137        ((and (>= (nsm-level network-security-level) (nsm-level 'high))
 138              (not (nsm-fingerprint-ok-p host port status settings)))
 139         (delete-process process)
 140         nil)
 141        ;; We haven't seen this before, and we're paranoid.
 142        ((and (eq network-security-level 'paranoid)
 143              (null settings)
 144              (not (nsm-new-fingerprint-ok-p host port status)))
 145         (delete-process process)
 146         nil)
 147        ((>= (nsm-level network-security-level) (nsm-level 'high))
 148         ;; Save the host fingerprint so that we can check it the
 149         ;; next time we connect.
 150         (nsm-save-host host port status 'fingerprint 'always)
 151         process)
 152        (t
 153         process)))
 154
 155      ;; The certificate did not validate.
 156      ((not (equal network-security-level 'low))
 157       ;; We always want to pin the certificate of invalid connections
 158       ;; to track man-in-the-middle or the like.
 159       (if (not (nsm-fingerprint-ok-p host port status settings))
 160           (progn
 161             (delete-process process)
 162             nil)
 163         ;; We have a warning, so query the user.
 164         (if (and (not (nsm-warnings-ok-p status settings))
 165                  (not (nsm-query
 166                        host port status 'conditions
 167                        "The TLS connection to %s:%s is insecure for the following reason%s:\n\n%s"
 168                        host port
 169                        (if (> (length warnings) 1)
 170                            "s" "")
 171                        (mapconcat #'gnutls-peer-status-warning-describe
 172                                   warnings
 173                                   "\n"))))
 174             (progn
 175               (delete-process process)
 176               nil)
 177           process))))))
 178
 179 (defun nsm-check-protocol (process host port status settings)
 180   (let ((prime-bits (plist-get status :diffie-hellman-prime-bits))
 181         (encryption (format "%s-%s-%s"
 182                             (plist-get status :key-exchange)
 183                             (plist-get status :cipher)
 184                             (plist-get status :mac)))
 185         (protocol (plist-get status :protocol)))
 186     (cond
 187      ((and prime-bits
 188            (< prime-bits 1024)
 189            (not (memq :diffie-hellman-prime-bits
 190                       (plist-get settings :conditions)))
 191            (not
 192             (nsm-query
 193              host port status :diffie-hellman-prime-bits
 194              "The Diffie-Hellman prime bits (%s) used for this connection to %s:%s is less than what is considered safe (%s)."
 195              prime-bits host port 1024)))
 196       (delete-process process)
 197       nil)
 198      ((and (string-match "\\bRC4\\b" encryption)
 199            (not (memq :rc4 (plist-get settings :conditions)))
 200            (not
 201             (nsm-query
 202              host port status :rc4
 203              "The connection to %s:%s uses the RC4 algorithm (%s), which is believed to be unsafe."
 204              host port encryption)))
 205       (delete-process process)
 206       nil)
 207      ((and protocol
 208            (string-match "SSL" protocol)
 209            (not (memq :ssl (plist-get settings :conditions)))
 210            (not
 211             (nsm-query
 212              host port status :ssl
 213              "The connection to %s:%s uses the %s protocol, which is believed to be unsafe."
 214              host port protocol)))
 215       (delete-process process)
 216       nil)
 217      (t
 218       process))))
 219
 220 (defun nsm-fingerprint (status)
 221   (plist-get (plist-get status :certificate) :public-key-id))
 222
 223 (defun nsm-fingerprint-ok-p (host port status settings)
 224   (let ((did-query nil))
 225     (if (and settings
 226              (not (eq (plist-get settings :fingerprint) :none))
 227              (not (equal (nsm-fingerprint status)
 228                          (plist-get settings :fingerprint)))
 229              (not
 230               (setq did-query
 231                     (nsm-query
 232                      host port status 'fingerprint
 233                      "The fingerprint for the connection to %s:%s has changed from %s to %s"
 234                      host port
 235                      (plist-get settings :fingerprint)
 236                      (nsm-fingerprint status)))))
 237         ;; Not OK.
 238         nil
 239       (when did-query
 240         ;; Remove any exceptions that have been set on the previous
 241         ;; certificate.
 242         (plist-put settings :conditions nil))
 243       t)))
 244
 245 (defun nsm-new-fingerprint-ok-p (host port status)
 246   (nsm-query
 247    host port status 'fingerprint
 248    "The fingerprint for the connection to %s:%s is new: %s"
 249    host port
 250    (nsm-fingerprint status)))
 251
 252 (defun nsm-check-plain-connection (process host port settings warn-unencrypted)
 253   ;; If this connection used to be TLS, but is now plain, then it's
 254   ;; possible that we're being Man-In-The-Middled by a proxy that's
 255   ;; stripping out STARTTLS announcements.
 256   (cond
 257    ((and (plist-get settings :fingerprint)
 258          (not (eq (plist-get settings :fingerprint) :none))
 259          (not
 260           (nsm-query
 261            host port nil 'conditions
 262            "The connection to %s:%s used to be an encrypted connection, but is now unencrypted.  This might mean that there's a man-in-the-middle tapping this connection."
 263            host port)))
 264     (delete-process process)
 265     nil)
 266    ((and warn-unencrypted
 267          (not (memq :unencrypted (plist-get settings :conditions)))
 268          (not (nsm-query
 269                host port nil 'conditions
 270                "The connection to %s:%s is unencrypted."
 271                host port)))
 272     (delete-process process)
 273     nil)
 274    (t
 275     process)))
 276
 277 (defun nsm-query (host port status what message &rest args)
 278   ;; If there is no user to answer queries, then say `no' to everything.
 279   (if (or noninteractive
 280           nsm-noninteractive)
 281       nil
 282     (let ((response
 283            (condition-case nil
 284                (nsm-query-user message args (nsm-format-certificate status))
 285              ;; Make sure we manage to close the process if the user hits
 286              ;; `C-g'.
 287              (quit 'no)
 288              (error 'no))))
 289       (if (eq response 'no)
 290           nil
 291         (nsm-save-host host port status what response)
 292         t))))
 293
 294 (defun nsm-query-user (message args cert)
 295   (let ((buffer (get-buffer-create "*Network Security Manager*")))
 296     (with-help-window buffer
 297       (with-current-buffer buffer
 298         (erase-buffer)
 299         (when (> (length cert) 0)
 300           (insert cert "\n"))
 301         (let ((start (point)))
 302           (insert (apply 'format message args))
 303           (goto-char start)
 304           ;; Fill the first line of the message, which usually
 305           ;; contains lots of explanatory text.
 306           (fill-region (point) (line-end-position)))))
 307     (let ((responses '((?n . no)
 308                        (?s . session)
 309                        (?a . always)))
 310           (prefix "")
 311           response)
 312       (while (not response)
 313         (setq response
 314               (cdr
 315                (assq (downcase
 316                       (read-char
 317                        (concat prefix
 318                                "Continue connecting? (No, Session only, Always)")))
 319                      responses)))
 320         (unless response
 321           (ding)
 322           (setq prefix "Invalid choice.  ")))
 323       (kill-buffer buffer)
 324       ;; If called from a callback, `read-char' will insert things
 325       ;; into the pending input.  Clear that.
 326       (clear-this-command-keys)
 327       response)))
 328
 329 (defun nsm-save-host (host port status what permanency)
 330   (let* ((id (nsm-id host port))
 331          (saved
 332           (list :id id
 333                 :fingerprint (or (nsm-fingerprint status)
 334                                  ;; Plain connection.
 335                                  :none))))
 336     (when (or (eq what 'conditions)
 337               nsm-save-host-names)
 338       (nconc saved (list :host (format "%s:%s" host port))))
 339     ;; We either want to save/update the fingerprint or the conditions
 340     ;; of the certificate/unencrypted connection.
 341     (cond
 342      ((eq what 'conditions)
 343       (cond
 344        ((not status)
 345         (nconc saved '(:conditions (:unencrypted))))
 346        ((plist-get status :warnings)
 347         (nconc saved
 348                (list :conditions (plist-get status :warnings))))))
 349      ((not (eq what 'fingerprint))
 350       ;; Store additional protocol settings.
 351       (let ((settings (nsm-host-settings id)))
 352         (when settings
 353           (setq saved settings))
 354         (if (plist-get saved :conditions)
 355             (nconc (plist-get saved :conditions) (list what))
 356           (nconc saved (list :conditions (list what)))))))
 357     (if (eq permanency 'always)
 358         (progn
 359           (nsm-remove-temporary-setting id)
 360           (nsm-remove-permanent-setting id)
 361           (push saved nsm-permanent-host-settings)
 362           (nsm-write-settings))
 363       (nsm-remove-temporary-setting id)
 364       (push saved nsm-temporary-host-settings))))
 365
 366 (defun nsm-write-settings ()
 367   (with-temp-file nsm-settings-file
 368     (insert "(\n")
 369     (dolist (setting nsm-permanent-host-settings)
 370       (insert " ")
 371       (prin1 setting (current-buffer))
 372       (insert "\n"))
 373     (insert ")\n")))
 374
 375 (defun nsm-read-settings ()
 376   (setq nsm-permanent-host-settings
 377         (with-temp-buffer
 378           (insert-file-contents nsm-settings-file)
 379           (goto-char (point-min))
 380           (ignore-errors (read (current-buffer))))))
 381
 382 (defun nsm-id (host port)
 383   (concat "sha1:" (sha1 (format "%s:%s" host port))))
 384
 385 (defun nsm-host-settings (id)
 386   (when (and (not nsm-permanent-host-settings)
 387              (file-exists-p nsm-settings-file))
 388     (nsm-read-settings))
 389   (let ((result nil))
 390     (dolist (elem (append nsm-temporary-host-settings
 391                           nsm-permanent-host-settings))
 392       (when (and (not result)
 393                  (equal (plist-get elem :id) id))
 394         (setq result elem)))
 395     result))
 396
 397 (defun nsm-warnings-ok-p (status settings)
 398   (let ((ok t)
 399         (conditions (plist-get settings :conditions)))
 400     (dolist (warning (plist-get status :warnings))
 401       (unless (memq warning conditions)
 402         (setq ok nil)))
 403     ok))
 404
 405 (defun nsm-remove-permanent-setting (id)
 406   (setq nsm-permanent-host-settings
 407         (cl-delete-if
 408          (lambda (elem)
 409            (equal (plist-get elem :id) id))
 410          nsm-permanent-host-settings)))
 411
 412 (defun nsm-remove-temporary-setting (id)
 413   (setq nsm-temporary-host-settings
 414         (cl-delete-if
 415          (lambda (elem)
 416            (equal (plist-get elem :id) id))
 417          nsm-temporary-host-settings)))
 418
 419 (defun nsm-format-certificate (status)
 420   (let ((cert (plist-get status :certificate)))
 421     (when cert
 422       (with-temp-buffer
 423         (insert
 424          "Certificate information\n"
 425          "Issued by:"
 426          (nsm-certificate-part (plist-get cert :issuer) "CN" t) "\n"
 427          "Issued to:"
 428          (or (nsm-certificate-part (plist-get cert :subject) "O")
 429              (nsm-certificate-part (plist-get cert :subject) "OU" t))
 430          "\n"
 431          "Hostname:"
 432          (nsm-certificate-part (plist-get cert :subject) "CN" t) "\n")
 433         (when (and (plist-get cert :public-key-algorithm)
 434                    (plist-get cert :signature-algorithm))
 435           (insert
 436            "Public key:" (plist-get cert :public-key-algorithm)
 437            ", signature: " (plist-get cert :signature-algorithm) "\n"))
 438         (when (and (plist-get status :key-exchange)
 439                    (plist-get status :cipher)
 440                    (plist-get status :mac)
 441                    (plist-get status :protocol))
 442           (insert
 443            "Protocol:" (plist-get status :protocol)
 444            ", key: " (plist-get status :key-exchange)
 445            ", cipher: " (plist-get status :cipher)
 446            ", mac: " (plist-get status :mac) "\n"))
 447         (when (plist-get cert :certificate-security-level)
 448           (insert
 449            "Security level:"
 450            (propertize (plist-get cert :certificate-security-level)
 451                        'face 'bold)
 452            "\n"))
 453         (insert
 454          "Valid:From " (plist-get cert :valid-from)
 455          " to " (plist-get cert :valid-to) "\n\n")
 456         (goto-char (point-min))
 457         (while (re-search-forward "^[^:]+:" nil t)
 458           (insert (make-string (- 20 (current-column)) ? )))
 459         (buffer-string)))))
 460
 461 (defun nsm-certificate-part (string part &optional full)
 462   (let ((part (cadr (assoc part (nsm-parse-subject string)))))
 463     (cond
 464      (part part)
 465      (full string)
 466      (t nil))))
 467
 468 (defun nsm-parse-subject (string)
 469   (with-temp-buffer
 470     (insert string)
 471     (goto-char (point-min))
 472     (let ((start (point))
 473           (result nil))
 474       (while (not (eobp))
 475         (push (replace-regexp-in-string
 476                "[\\]\\(.\\)" "\\1"
 477                (buffer-substring start
 478                                  (if (re-search-forward "[^\\]," nil 'move)
 479                                      (1- (point))
 480                                    (point))))
 481               result)
 482         (setq start (point)))
 483       (mapcar
 484        (lambda (elem)
 485          (let ((pos (cl-position ?= elem)))
 486            (if pos
 487                (list (substring elem 0 pos)
 488                      (substring elem (1+ pos)))
 489              elem)))
 490        (nreverse result)))))
 491
 492 (defun nsm-level (symbol)
 493   "Return a numerical level for SYMBOL for easier comparison."
 494   (cond
 495    ((eq symbol 'low) 0)
 496    ((eq symbol 'medium) 1)
 497    ((eq symbol 'high) 2)
 498    (t 3)))
 499
 500 (provide 'nsm)
 501
 502 ;;; nsm.el ends here