lisp/net/nsm.el

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