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 `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     (cond
 186      ((and prime-bits
 187            (< prime-bits 1024)
 188            (not (memq :diffie-hellman-prime-bits
 189                       (plist-get settings :conditions)))
 190            (not
 191             (nsm-query
 192              host port status :diffie-hellman-prime-bits
 193              "The Diffie-Hellman prime bits (%s) used for this connection to %s:%s is less than what is considered safe (%s)."
 194              prime-bits host port 1024)))
 195       (delete-process process)
 196       nil)
 197      ((and (string-match "\\bRC4\\b" encryption)
 198            (not (memq :rc4 (plist-get settings :conditions)))
 199            (not
 200             (nsm-query
 201              host port status :rc4
 202              "The connection to %s:%s uses the RC4 algorithm (%s), which is believed to be unsafe."
 203              host port encryption)))
 204       (delete-process process)
 205       nil)
 206      (t
 207       process))))
 208
 209 (defun nsm-fingerprint (status)
 210   (plist-get (plist-get status :certificate) :public-key-id))
 211
 212 (defun nsm-fingerprint-ok-p (host port status settings)
 213   (let ((did-query nil))
 214     (if (and settings
 215              (not (eq (plist-get settings :fingerprint) :none))
 216              (not (equal (nsm-fingerprint status)
 217                          (plist-get settings :fingerprint)))
 218              (not
 219               (setq did-query
 220                     (nsm-query
 221                      host port status 'fingerprint
 222                      "The fingerprint for the connection to %s:%s has changed from %s to %s"
 223                      host port
 224                      (plist-get settings :fingerprint)
 225                      (nsm-fingerprint status)))))
 226         ;; Not OK.
 227         nil
 228       (when did-query
 229         ;; Remove any exceptions that have been set on the previous
 230         ;; certificate.
 231         (plist-put settings :conditions nil))
 232       t)))
 233
 234 (defun nsm-new-fingerprint-ok-p (host port status)
 235   (nsm-query
 236    host port status 'fingerprint
 237    "The fingerprint for the connection to %s:%s is new: %s"
 238    host port
 239    (nsm-fingerprint status)))
 240
 241 (defun nsm-check-plain-connection (process host port settings warn-unencrypted)
 242   ;; If this connection used to be TLS, but is now plain, then it's
 243   ;; possible that we're being Man-In-The-Middled by a proxy that's
 244   ;; stripping out STARTTLS announcements.
 245   (cond
 246    ((and (plist-get settings :fingerprint)
 247          (not (eq (plist-get settings :fingerprint) :none))
 248          (not
 249           (nsm-query
 250            host port nil 'conditions
 251            "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."
 252            host port)))
 253     (delete-process process)
 254     nil)
 255    ((and warn-unencrypted
 256          (not (memq :unencrypted (plist-get settings :conditions)))
 257          (not (nsm-query
 258                host port nil 'conditions
 259                "The connection to %s:%s is unencrypted."
 260                host port)))
 261     (delete-process process)
 262     nil)
 263    (t
 264     process)))
 265
 266 (defun nsm-query (host port status what message &rest args)
 267   ;; If there is no user to answer queries, then say `no' to everything.
 268   (if (or noninteractive
 269           nsm-noninteractive)
 270       nil
 271     (let ((response
 272            (condition-case nil
 273                (nsm-query-user message args (nsm-format-certificate status))
 274              ;; Make sure we manage to close the process if the user hits
 275              ;; `C-g'.
 276              (quit 'no)
 277              (error 'no))))
 278       (if (eq response 'no)
 279           nil
 280         (nsm-save-host host port status what response)
 281         t))))
 282
 283 (defun nsm-query-user (message args cert)
 284   (let ((buffer (get-buffer-create "*Network Security Manager*")))
 285     (with-help-window buffer
 286       (with-current-buffer buffer
 287         (erase-buffer)
 288         (when (> (length cert) 0)
 289           (insert cert "\n"))
 290         (let ((start (point)))
 291           (insert (apply 'format message args))
 292           (goto-char start)
 293           ;; Fill the first line of the message, which usually
 294           ;; contains lots of explanatory text.
 295           (fill-region (point) (line-end-position)))))
 296     (let ((responses '((?n . no)
 297                        (?s . session)
 298                        (?a . always)))
 299           (prefix "")
 300           response)
 301       (while (not response)
 302         (setq response
 303               (cdr
 304                (assq (downcase
 305                       (read-char
 306                        (concat prefix
 307                                "Continue connecting? (No, Session only, Always)")))
 308                      responses)))
 309         (unless response
 310           (ding)
 311           (setq prefix "Invalid choice.  ")))
 312       (kill-buffer buffer)
 313       ;; If called from a callback, `read-char' will insert things
 314       ;; into the pending input.  Clear that.
 315       (clear-this-command-keys)
 316       response)))
 317
 318 (defun nsm-save-host (host port status what permanency)
 319   (let* ((id (nsm-id host port))
 320          (saved
 321           (list :id id
 322                 :fingerprint (or (nsm-fingerprint status)
 323                                  ;; Plain connection.
 324                                  :none))))
 325     (when (or (eq what 'conditions)
 326               nsm-save-host-names)
 327       (nconc saved (list :host (format "%s:%s" host port))))
 328     ;; We either want to save/update the fingerprint or the conditions
 329     ;; of the certificate/unencrypted connection.
 330     (cond
 331      ((eq what 'conditions)
 332       (nconc saved (list :host (format "%s:%s" host port)))
 333       (cond
 334        ((not status)
 335         (nconc saved '(:conditions (:unencrypted))))
 336        ((plist-get status :warnings)
 337         (nconc saved
 338                (list :conditions (plist-get status :warnings))))))
 339      ((not (eq what 'fingerprint))
 340       ;; Store additional protocol settings.
 341       (let ((settings (nsm-host-settings id)))
 342         (when settings
 343           (setq saved settings))
 344         (if (plist-get saved :conditions)
 345             (nconc (plist-get saved :conditions) (list what))
 346           (nconc saved (list :conditions (list what)))))))
 347     (if (eq permanency 'always)
 348         (progn
 349           (nsm-remove-temporary-setting id)
 350           (nsm-remove-permanent-setting id)
 351           (push saved nsm-permanent-host-settings)
 352           (nsm-write-settings))
 353       (nsm-remove-temporary-setting id)
 354       (push saved nsm-temporary-host-settings))))
 355
 356 (defun nsm-write-settings ()
 357   (with-temp-file nsm-settings-file
 358     (insert "(\n")
 359     (dolist (setting nsm-permanent-host-settings)
 360       (insert " ")
 361       (prin1 setting (current-buffer))
 362       (insert "\n"))
 363     (insert ")\n")))
 364
 365 (defun nsm-read-settings ()
 366   (setq nsm-permanent-host-settings
 367         (with-temp-buffer
 368           (insert-file-contents nsm-settings-file)
 369           (goto-char (point-min))
 370           (ignore-errors (read (current-buffer))))))
 371
 372 (defun nsm-id (host port)
 373   (concat "sha1:" (sha1 (format "%s:%s" host port))))
 374
 375 (defun nsm-host-settings (id)
 376   (when (and (not nsm-permanent-host-settings)
 377              (file-exists-p nsm-settings-file))
 378     (nsm-read-settings))
 379   (let ((result nil))
 380     (dolist (elem (append nsm-temporary-host-settings
 381                           nsm-permanent-host-settings))
 382       (when (and (not result)
 383                  (equal (plist-get elem :id) id))
 384         (setq result elem)))
 385     result))
 386
 387 (defun nsm-warnings-ok-p (status settings)
 388   (let ((ok t)
 389         (conditions (plist-get settings :conditions)))
 390     (dolist (warning (plist-get status :warnings))
 391       (unless (memq warning conditions)
 392         (setq ok nil)))
 393     ok))
 394
 395 (defun nsm-remove-permanent-setting (id)
 396   (setq nsm-permanent-host-settings
 397         (cl-delete-if
 398          (lambda (elem)
 399            (equal (plist-get elem :id) id))
 400          nsm-permanent-host-settings)))
 401
 402 (defun nsm-remove-temporary-setting (id)
 403   (setq nsm-temporary-host-settings
 404         (cl-delete-if
 405          (lambda (elem)
 406            (equal (plist-get elem :id) id))
 407          nsm-temporary-host-settings)))
 408
 409 (defun nsm-format-certificate (status)
 410   (let ((cert (plist-get status :certificate)))
 411     (when cert
 412       (with-temp-buffer
 413         (insert
 414          "Certificate information\n"
 415          "Issued by:"
 416          (nsm-certificate-part (plist-get cert :issuer) "CN" t) "\n"
 417          "Issued to:"
 418          (or (nsm-certificate-part (plist-get cert :subject) "O")
 419              (nsm-certificate-part (plist-get cert :subject) "OU" t))
 420          "\n"
 421          "Hostname:"
 422          (nsm-certificate-part (plist-get cert :subject) "CN" t) "\n")
 423         (when (and (plist-get cert :public-key-algorithm)
 424                    (plist-get cert :signature-algorithm))
 425           (insert
 426            "Public key:" (plist-get cert :public-key-algorithm)
 427            ", signature: " (plist-get cert :signature-algorithm) "\n"))
 428         (when (and (plist-get status :key-exchange)
 429                    (plist-get status :cipher)
 430                    (plist-get status :mac)
 431                    (plist-get status :protocol))
 432           (insert
 433            "Protocol:" (plist-get status :protocol)
 434            ", key: " (plist-get status :key-exchange)
 435            ", cipher: " (plist-get status :cipher)
 436            ", mac: " (plist-get status :mac) "\n"))
 437         (when (plist-get cert :certificate-security-level)
 438           (insert
 439            "Security level:"
 440            (propertize (plist-get cert :certificate-security-level)
 441                        'face 'bold)
 442            "\n"))
 443         (insert
 444          "Valid:From " (plist-get cert :valid-from)
 445          " to " (plist-get cert :valid-to) "\n\n")
 446         (goto-char (point-min))
 447         (while (re-search-forward "^[^:]+:" nil t)
 448           (insert (make-string (- 20 (current-column)) ? )))
 449         (buffer-string)))))
 450
 451 (defun nsm-certificate-part (string part &optional full)
 452   (let ((part (cadr (assoc part (nsm-parse-subject string)))))
 453     (cond
 454      (part part)
 455      (full string)
 456      (t nil))))
 457
 458 (defun nsm-parse-subject (string)
 459   (with-temp-buffer
 460     (insert string)
 461     (goto-char (point-min))
 462     (let ((start (point))
 463           (result nil))
 464       (while (not (eobp))
 465         (push (replace-regexp-in-string
 466                "[\\]\\(.\\)" "\\1"
 467                (buffer-substring start
 468                                  (if (re-search-forward "[^\\]," nil 'move)
 469                                      (1- (point))
 470                                    (point))))
 471               result)
 472         (setq start (point)))
 473       (mapcar
 474        (lambda (elem)
 475          (let ((pos (cl-position ?= elem)))
 476            (if pos
 477                (list (substring elem 0 pos)
 478                      (substring elem (1+ pos)))
 479              elem)))
 480        (nreverse result)))))
 481
 482 (defun nsm-level (symbol)
 483   "Return a numerical level for SYMBOL for easier comparison."
 484   (cond
 485    ((eq symbol 'low) 0)
 486    ((eq symbol 'medium) 1)
 487    ((eq symbol 'high) 2)
 488    (t 3)))
 489
 490 (provide 'nsm)
 491
 492 ;;; nsm.el ends here