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