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