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

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