1 ;;; mml-sec.el --- A package with security functions for MML documents
3 ;; Copyright (C) 2000-2016 Free Software Foundation, Inc.
5 ;; Author: Simon Josefsson <simon@josefsson.org>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 (eval-when-compile (require 'cl))
31 (require 'password-cache)
34 (autoload 'mail-strip-quoted-names "mail-utils")
35 (autoload 'mml2015-sign "mml2015")
36 (autoload 'mml2015-encrypt "mml2015")
37 (autoload 'mml1991-sign "mml1991")
38 (autoload 'mml1991-encrypt "mml1991")
39 (autoload 'message-fetch-field "message")
40 (autoload 'message-goto-body "message")
41 (autoload 'mml-insert-tag "mml")
42 (autoload 'mml-smime-sign "mml-smime")
43 (autoload 'mml-smime-encrypt "mml-smime")
44 (autoload 'mml-smime-sign-query "mml-smime")
45 (autoload 'mml-smime-encrypt-query "mml-smime")
46 (autoload 'mml-smime-verify "mml-smime")
47 (autoload 'mml-smime-verify-test "mml-smime")
48 (autoload 'epa--select-keys "epa")
49 (autoload 'message-options-get "message")
50 (autoload 'message-options-set "message")
52 (defvar mml-sign-alist
53 '(("smime" mml-smime-sign-buffer mml-smime-sign-query)
54 ("pgp" mml-pgp-sign-buffer list)
55 ("pgpauto" mml-pgpauto-sign-buffer list)
56 ("pgpmime" mml-pgpmime-sign-buffer list))
57 "Alist of MIME signer functions.")
59 (defcustom mml-default-sign-method "pgpmime"
61 The string must have an entry in `mml-sign-alist'."
63 :type '(choice (const "smime")
70 (defvar mml-encrypt-alist
71 '(("smime" mml-smime-encrypt-buffer mml-smime-encrypt-query)
72 ("pgp" mml-pgp-encrypt-buffer list)
73 ("pgpauto" mml-pgpauto-sign-buffer list)
74 ("pgpmime" mml-pgpmime-encrypt-buffer list))
75 "Alist of MIME encryption functions.")
77 (defcustom mml-default-encrypt-method "pgpmime"
78 "Default encryption method.
79 The string must have an entry in `mml-encrypt-alist'."
81 :type '(choice (const "smime")
88 (defcustom mml-signencrypt-style-alist
93 "Alist specifying if `signencrypt' results in two separate operations or not.
94 The first entry indicates the MML security type, valid entries include
95 the strings \"smime\", \"pgp\", and \"pgpmime\". The second entry is
96 a symbol `separate' or `combined' where `separate' means that MML signs
97 and encrypt messages in a two step process, and `combined' means that MML
98 signs and encrypt the message in one step.
100 Note that the output generated by using a `combined' mode is NOT
101 understood by all PGP implementations, in particular PGP version
102 2 does not support it! See Info node `(message) Security' for
106 :type '(repeat (list (choice (const :tag "S/MIME" "smime")
107 (const :tag "PGP" "pgp")
108 (const :tag "PGP/MIME" "pgpmime")
109 (string :tag "User defined"))
110 (choice (const :tag "Separate" separate)
111 (const :tag "Combined" combined)))))
113 (defcustom mml-secure-verbose nil
114 "If non-nil, ask the user about the current operation more verbosely."
118 (defcustom mml-secure-cache-passphrase password-cache
119 "If t, cache OpenPGP or S/MIME passphrases inside Emacs.
120 Passphrase caching in Emacs is NOT recommended. Use gpg-agent instead.
121 See Info node `(message) Security'."
125 (defcustom mml-secure-passphrase-cache-expiry password-cache-expiry
126 "How many seconds the passphrase is cached.
127 Whether the passphrase is cached at all is controlled by
128 `mml-secure-cache-passphrase'."
132 (defcustom mml-secure-safe-bcc-list nil
133 "List of e-mail addresses that are safe to use in Bcc headers.
134 EasyPG encrypts e-mails to Bcc addresses, and the encrypted e-mail
135 by default identifies the used encryption keys, giving away the
136 Bcc'ed identities. Clearly, this contradicts the original goal of
138 For an academic paper explaining the problem, see URL
139 `http://crypto.stanford.edu/portia/papers/bb-bcc.pdf'.
140 Use this variable to specify e-mail addresses whose owners do not
141 mind if they are identifiable as recipients. This may be useful if
142 you use Bcc headers to encrypt e-mails to yourself."
145 :type '(repeat string))
147 ;;; Configuration/helper functions
149 (defun mml-signencrypt-style (method &optional style)
150 "Function for setting/getting the signencrypt-style used. Takes two
151 arguments, the method (e.g. \"pgp\") and optionally the mode
152 \(e.g. combined). If the mode is omitted, the current value is returned.
154 For example, if you prefer to use combined sign & encrypt with
155 smime, putting the following in your Gnus startup file will
156 enable that behavior:
158 \(mml-set-signencrypt-style \"smime\" combined)
160 You can also customize or set `mml-signencrypt-style-alist' instead."
161 (let ((style-item (assoc method mml-signencrypt-style-alist)))
163 (if (or (eq style 'separate)
164 (eq style 'combined))
165 ;; valid style setting?
166 (setf (second style-item) style)
167 ;; otherwise, just return the current value
169 (message "Warning, attempt to set invalid signencrypt style"))))
171 ;;; Security functions
173 (defun mml-smime-sign-buffer (cont)
174 (or (mml-smime-sign cont)
175 (error "Signing failed... inspect message logs for errors")))
177 (defun mml-smime-encrypt-buffer (cont &optional sign)
179 (message "Combined sign and encrypt S/MIME not support yet")
181 (or (mml-smime-encrypt cont)
182 (error "Encryption failed... inspect message logs for errors")))
184 (defun mml-pgp-sign-buffer (cont)
185 (or (mml1991-sign cont)
186 (error "Signing failed... inspect message logs for errors")))
188 (defun mml-pgp-encrypt-buffer (cont &optional sign)
189 (or (mml1991-encrypt cont sign)
190 (error "Encryption failed... inspect message logs for errors")))
192 (defun mml-pgpmime-sign-buffer (cont)
193 (or (mml2015-sign cont)
194 (error "Signing failed... inspect message logs for errors")))
196 (defun mml-pgpmime-encrypt-buffer (cont &optional sign)
197 (or (mml2015-encrypt cont sign)
198 (error "Encryption failed... inspect message logs for errors")))
200 (defun mml-pgpauto-sign-buffer (cont)
202 (or (if (re-search-backward "Content-Type: *multipart/.*" nil t) ; there must be a better way...
205 (error "Encryption failed... inspect message logs for errors")))
207 (defun mml-pgpauto-encrypt-buffer (cont &optional sign)
209 (or (if (re-search-backward "Content-Type: *multipart/.*" nil t) ; there must be a better way...
210 (mml2015-encrypt cont sign)
211 (mml1991-encrypt cont sign))
212 (error "Encryption failed... inspect message logs for errors")))
214 (defun mml-secure-part (method &optional sign)
216 (let ((tags (funcall (nth 2 (assoc method (if sign mml-sign-alist
217 mml-encrypt-alist))))))
218 (cond ((re-search-backward
219 "<#\\(multipart\\|part\\|external\\|mml\\)" nil t)
220 (goto-char (match-end 0))
221 (insert (if sign " sign=" " encrypt=") method)
223 (let ((key (pop tags))
226 ;; Quote VALUE if it contains suspicious characters.
227 (when (string-match "[\"'\\~/*;() \t\n]" value)
228 (setq value (prin1-to-string value)))
229 (insert (format " %s=%s" key value))))))
230 ((or (re-search-backward
231 (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
233 (concat "^" (regexp-quote mail-header-separator) "\n") nil t))
234 (goto-char (match-end 0))
235 (apply 'mml-insert-tag 'part (cons (if sign 'sign 'encrypt)
236 (cons method tags))))
237 (t (error "The message is corrupted. No mail header separator"))))))
239 (defvar mml-secure-method
240 (if (equal mml-default-encrypt-method mml-default-sign-method)
241 mml-default-sign-method
243 "Current security method. Internal variable.")
245 (defun mml-secure-sign (&optional method)
246 "Add MML tags to sign this MML part.
247 Use METHOD if given. Else use `mml-secure-method' or
248 `mml-default-sign-method'."
251 (or method mml-secure-method mml-default-sign-method)
254 (defun mml-secure-encrypt (&optional method)
255 "Add MML tags to encrypt this MML part.
256 Use METHOD if given. Else use `mml-secure-method' or
257 `mml-default-sign-method'."
260 (or method mml-secure-method mml-default-sign-method)))
262 (defun mml-secure-sign-pgp ()
263 "Add MML tags to PGP sign this MML part."
265 (mml-secure-part "pgp" 'sign))
267 (defun mml-secure-sign-pgpauto ()
268 "Add MML tags to PGP-auto sign this MML part."
270 (mml-secure-part "pgpauto" 'sign))
272 (defun mml-secure-sign-pgpmime ()
273 "Add MML tags to PGP/MIME sign this MML part."
275 (mml-secure-part "pgpmime" 'sign))
277 (defun mml-secure-sign-smime ()
278 "Add MML tags to S/MIME sign this MML part."
280 (mml-secure-part "smime" 'sign))
282 (defun mml-secure-encrypt-pgp ()
283 "Add MML tags to PGP encrypt this MML part."
285 (mml-secure-part "pgp"))
287 (defun mml-secure-encrypt-pgpmime ()
288 "Add MML tags to PGP/MIME encrypt this MML part."
290 (mml-secure-part "pgpmime"))
292 (defun mml-secure-encrypt-smime ()
293 "Add MML tags to S/MIME encrypt this MML part."
295 (mml-secure-part "smime"))
297 (defun mml-secure-is-encrypted-p ()
298 "Check whether secure encrypt tag is present."
300 (goto-char (point-min))
302 (concat "^" (regexp-quote mail-header-separator) "\n"
303 "<#secure[^>]+encrypt")
306 (defun mml-secure-bcc-is-safe ()
307 "Check whether usage of Bcc is safe (or absent).
308 Bcc usage is safe in two cases: first, if the current message does
309 not contain an MML secure encrypt tag;
310 second, if the Bcc addresses are a subset of `mml-secure-safe-bcc-list'.
311 In all other cases, ask the user whether Bcc usage is safe.
312 Raise error if user answers no.
313 Note that this function does not produce a meaningful return value:
314 either an error is raised or not."
315 (when (mml-secure-is-encrypted-p)
316 (let ((bcc (mail-strip-quoted-names (message-fetch-field "bcc"))))
318 (let ((bcc-list (mapcar #'cadr
319 (mail-extract-address-components bcc t))))
320 (unless (gnus-subsetp bcc-list mml-secure-safe-bcc-list)
321 (unless (yes-or-no-p "Message for encryption contains Bcc header.\
322 This may give away all Bcc'ed identities to all recipients.\
323 Are you sure that this is safe?\
324 (Customize `mml-secure-safe-bcc-list' to avoid this warning.) ")
325 (error "Aborted"))))))))
327 ;; defuns that add the proper <#secure ...> tag to the top of the message body
328 (defun mml-secure-message (method &optional modesym)
329 (let ((mode (prin1-to-string modesym))
331 (if (or (eq modesym 'sign)
332 (eq modesym 'signencrypt))
333 (funcall (nth 2 (assoc method mml-sign-alist))))
334 (if (or (eq modesym 'encrypt)
335 (eq modesym 'signencrypt))
336 (funcall (nth 2 (assoc method mml-encrypt-alist))))))
338 (mml-unsecure-message)
340 (goto-char (point-min))
341 (cond ((re-search-forward
342 (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
343 (goto-char (setq insert-loc (match-end 0)))
344 (unless (looking-at "<#secure")
345 (apply 'mml-insert-tag
346 'secure 'method method 'mode mode tags)))
348 "The message is corrupted. No mail header separator"))))
349 (when (eql insert-loc (point))
352 (defun mml-unsecure-message ()
353 "Remove security related MML tags from message."
356 (goto-char (point-max))
357 (when (re-search-backward "^<#secure.*>\n" nil t)
358 (delete-region (match-beginning 0) (match-end 0)))))
361 (defun mml-secure-message-sign (&optional method)
362 "Add MML tags to sign the entire message.
363 Use METHOD if given. Else use `mml-secure-method' or
364 `mml-default-sign-method'."
367 (or method mml-secure-method mml-default-sign-method)
370 (defun mml-secure-message-sign-encrypt (&optional method)
371 "Add MML tag to sign and encrypt the entire message.
372 Use METHOD if given. Else use `mml-secure-method' or
373 `mml-default-sign-method'."
376 (or method mml-secure-method mml-default-sign-method)
379 (defun mml-secure-message-encrypt (&optional method)
380 "Add MML tag to encrypt the entire message.
381 Use METHOD if given. Else use `mml-secure-method' or
382 `mml-default-sign-method'."
385 (or method mml-secure-method mml-default-sign-method)
388 (defun mml-secure-message-sign-smime ()
389 "Add MML tag to encrypt/sign the entire message."
391 (mml-secure-message "smime" 'sign))
393 (defun mml-secure-message-sign-pgp ()
394 "Add MML tag to encrypt/sign the entire message."
396 (mml-secure-message "pgp" 'sign))
398 (defun mml-secure-message-sign-pgpmime ()
399 "Add MML tag to encrypt/sign the entire message."
401 (mml-secure-message "pgpmime" 'sign))
403 (defun mml-secure-message-sign-pgpauto ()
404 "Add MML tag to encrypt/sign the entire message."
406 (mml-secure-message "pgpauto" 'sign))
408 (defun mml-secure-message-encrypt-smime (&optional dontsign)
409 "Add MML tag to encrypt and sign the entire message.
410 If called with a prefix argument, only encrypt (do NOT sign)."
412 (mml-secure-message "smime" (if dontsign 'encrypt 'signencrypt)))
414 (defun mml-secure-message-encrypt-pgp (&optional dontsign)
415 "Add MML tag to encrypt and sign the entire message.
416 If called with a prefix argument, only encrypt (do NOT sign)."
418 (mml-secure-message "pgp" (if dontsign 'encrypt 'signencrypt)))
420 (defun mml-secure-message-encrypt-pgpmime (&optional dontsign)
421 "Add MML tag to encrypt and sign the entire message.
422 If called with a prefix argument, only encrypt (do NOT sign)."
424 (mml-secure-message "pgpmime" (if dontsign 'encrypt 'signencrypt)))
426 (defun mml-secure-message-encrypt-pgpauto (&optional dontsign)
427 "Add MML tag to encrypt and sign the entire message.
428 If called with a prefix argument, only encrypt (do NOT sign)."
430 (mml-secure-message "pgpauto" (if dontsign 'encrypt 'signencrypt)))
432 ;;; Common functionality for mml1991.el, mml2015.el, mml-smime.el
434 (define-obsolete-variable-alias 'mml1991-signers 'mml-secure-openpgp-signers
436 (define-obsolete-variable-alias 'mml2015-signers 'mml-secure-openpgp-signers
438 (defcustom mml-secure-openpgp-signers nil
439 "A list of your own key ID(s) which will be used to sign OpenPGP messages.
440 If set, it is added to the setting of `mml-secure-openpgp-sign-with-sender'."
441 :group 'mime-security
442 :type '(repeat (string :tag "Key ID")))
444 (define-obsolete-variable-alias 'mml-smime-signers 'mml-secure-smime-signers
446 (defcustom mml-secure-smime-signers nil
447 "A list of your own key ID(s) which will be used to sign S/MIME messages.
448 If set, it is added to the setting of `mml-secure-smime-sign-with-sender'."
449 :group 'mime-security
450 :type '(repeat (string :tag "Key ID")))
452 (define-obsolete-variable-alias
453 'mml1991-encrypt-to-self 'mml-secure-openpgp-encrypt-to-self "25.1")
454 (define-obsolete-variable-alias
455 'mml2015-encrypt-to-self 'mml-secure-openpgp-encrypt-to-self "25.1")
456 (defcustom mml-secure-openpgp-encrypt-to-self nil
457 "List of own key ID(s) or t; determines additional recipients with OpenPGP.
458 If t, also encrypt to key for message sender; if list, encrypt to those keys.
459 With this variable, you can ensure that you can decrypt your own messages.
460 Alternatives to this variable include Bcc'ing the message to yourself or
461 using the encrypt-to or hidden-encrypt-to option in gpg.conf (see man gpg(1)).
462 Note that this variable and the encrypt-to option give away your identity
463 for *every* encryption without warning, which is not what you want if you are
464 using, e.g., remailers.
465 Also, use of Bcc gives away your identity for *every* encryption without
466 warning, which is a bug, see:
467 https://debbugs.gnu.org/cgi/bugreport.cgi?bug=18718"
468 :group 'mime-security
469 :type '(choice (const :tag "None" nil)
470 (const :tag "From address" t)
471 (repeat (string :tag "Key ID"))))
473 (define-obsolete-variable-alias
474 'mml-smime-encrypt-to-self 'mml-secure-smime-encrypt-to-self "25.1")
475 (defcustom mml-secure-smime-encrypt-to-self nil
476 "List of own key ID(s) or t; determines additional recipients with S/MIME.
477 If t, also encrypt to key for message sender; if list, encrypt to those keys.
478 With this variable, you can ensure that you can decrypt your own messages.
479 Alternatives to this variable include Bcc'ing the message to yourself or
480 using the encrypt-to option in gpgsm.conf (see man gpgsm(1)).
481 Note that this variable and the encrypt-to option give away your identity
482 for *every* encryption without warning, which is not what you want if you are
483 using, e.g., remailers.
484 Also, use of Bcc gives away your identity for *every* encryption without
485 warning, which is a bug, see:
486 https://debbugs.gnu.org/cgi/bugreport.cgi?bug=18718"
487 :group 'mime-security
488 :type '(choice (const :tag "None" nil)
489 (const :tag "From address" t)
490 (repeat (string :tag "Key ID"))))
492 (define-obsolete-variable-alias
493 'mml2015-sign-with-sender 'mml-secure-openpgp-sign-with-sender "25.1")
494 ;mml1991-sign-with-sender did never exist.
495 (defcustom mml-secure-openpgp-sign-with-sender nil
496 "If t, use message sender to find an OpenPGP key to sign with."
497 :group 'mime-security
500 (define-obsolete-variable-alias
501 'mml-smime-sign-with-sender 'mml-secure-smime-sign-with-sender "25.1")
502 (defcustom mml-secure-smime-sign-with-sender nil
503 "If t, use message sender to find an S/MIME key to sign with."
504 :group 'mime-security
507 (define-obsolete-variable-alias
508 'mml2015-always-trust 'mml-secure-openpgp-always-trust "25.1")
509 ;mml1991-always-trust did never exist.
510 (defcustom mml-secure-openpgp-always-trust t
511 "If t, skip key validation of GnuPG on encryption."
512 :group 'mime-security
515 (defcustom mml-secure-fail-when-key-problem nil
516 "If t, raise an error if some key is missing or several keys exist.
517 Otherwise, ask the user."
519 :group 'mime-security
522 (defcustom mml-secure-key-preferences
523 '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))
524 "Protocol- and usage-specific fingerprints of preferred keys.
525 This variable is only relevant if a recipient owns multiple key pairs (for
526 encryption) or you own multiple key pairs (for signing). In such cases,
527 you will be asked which key(s) should be used, and your choice can be
528 customized in this variable."
530 :group 'mime-security
531 :type '(alist :key-type (symbol :tag "Protocol") :value-type
532 (alist :key-type (symbol :tag "Usage") :value-type
533 (alist :key-type (string :tag "Name") :value-type
534 (repeat (string :tag "Fingerprint"))))))
536 (defun mml-secure-cust-usage-lookup (context usage)
537 "Return preferences for CONTEXT and USAGE."
538 (let* ((protocol (epg-context-protocol context))
539 (protocol-prefs (cdr (assoc protocol mml-secure-key-preferences))))
540 (assoc usage protocol-prefs)))
542 (defun mml-secure-cust-fpr-lookup (context usage name)
543 "Return fingerprints of preferred keys for CONTEXT, USAGE, and NAME."
544 (let* ((usage-prefs (mml-secure-cust-usage-lookup context usage))
545 (fprs (assoc name (cdr usage-prefs))))
549 (defun mml-secure-cust-record-keys (context usage name keys &optional save)
550 "For CONTEXT, USAGE, and NAME record fingerprint(s) of KEYS.
551 If optional SAVE is not nil, save customized fingerprints.
554 (let* ((usage-prefs (mml-secure-cust-usage-lookup context usage))
555 (curr-fprs (cdr (assoc name (cdr usage-prefs))))
556 (key-fprs (mapcar 'mml-secure-fingerprint keys))
557 (new-fprs (cl-union curr-fprs key-fprs :test 'equal)))
559 (setcdr (assoc name (cdr usage-prefs)) new-fprs)
560 (setcdr usage-prefs (cons (cons name new-fprs) (cdr usage-prefs))))
562 (customize-save-variable
563 'mml-secure-key-preferences mml-secure-key-preferences))
566 (defun mml-secure-cust-remove-keys (context usage name)
567 "Remove keys for CONTEXT, USAGE, and NAME.
568 Return t if a customization for NAME was present (and has been removed)."
569 (let* ((usage-prefs (mml-secure-cust-usage-lookup context usage))
570 (current (assoc name usage-prefs)))
572 (setcdr usage-prefs (remove current (cdr usage-prefs)))
575 (defvar mml-secure-secret-key-id-list nil)
577 (defun mml-secure-add-secret-key-id (key-id)
578 "Record KEY-ID in list of secret keys."
579 (add-to-list 'mml-secure-secret-key-id-list key-id))
581 (defun mml-secure-clear-secret-key-id-list ()
582 "Remove passwords from cache and clear list of secret keys."
583 ;; Loosely based on code inside mml2015-epg-encrypt,
584 ;; mml2015-epg-clear-decrypt, and mml2015-epg-decrypt
585 (dolist (key-id mml-secure-secret-key-id-list nil)
586 (password-cache-remove key-id))
587 (setq mml-secure-secret-key-id-list nil))
589 (defvar mml1991-cache-passphrase)
590 (defvar mml1991-passphrase-cache-expiry)
592 (defun mml-secure-cache-passphrase-p (protocol)
593 "Return t if OpenPGP or S/MIME passphrases should be cached for PROTOCOL.
594 Passphrase caching in Emacs is NOT recommended. Use gpg-agent instead."
595 (or (and (eq 'OpenPGP protocol)
596 (or mml-secure-cache-passphrase
597 (and (boundp 'mml2015-cache-passphrase)
598 mml2015-cache-passphrase)
599 (and (boundp 'mml1991-cache-passphrase)
600 mml1991-cache-passphrase)))
601 (and (eq 'CMS protocol)
602 (or mml-secure-cache-passphrase
603 (and (boundp 'mml-smime-cache-passphrase)
604 mml-smime-cache-passphrase)))))
606 (defun mml-secure-cache-expiry-interval (protocol)
607 "Return time in seconds to cache passphrases for PROTOCOL.
608 Passphrase caching in Emacs is NOT recommended. Use gpg-agent instead."
609 (or (and (eq 'OpenPGP protocol)
610 (or (and (boundp 'mml2015-passphrase-cache-expiry)
611 mml2015-passphrase-cache-expiry)
612 (and (boundp 'mml1991-passphrase-cache-expiry)
613 mml1991-passphrase-cache-expiry)
614 mml-secure-passphrase-cache-expiry))
615 (and (eq 'CMS protocol)
616 (or (and (boundp 'mml-smime-passphrase-cache-expiry)
617 mml-smime-passphrase-cache-expiry)
618 mml-secure-passphrase-cache-expiry))))
620 (defun mml-secure-passphrase-callback (context key-id standard)
621 "Ask for passphrase in CONTEXT for KEY-ID for STANDARD.
622 The passphrase is read and cached."
623 ;; Based on mml2015-epg-passphrase-callback.
625 (epa-passphrase-callback-function context key-id nil)
626 (let* ((password-cache-key-id
630 (entry (assoc key-id epg-user-id-alist))
634 "Passphrase for PIN: "
636 (format "Passphrase for %s %s: " key-id (cdr entry))
637 (format "Passphrase for %s: " key-id)))
638 ;; TODO: With mml-smime.el, password-cache-key-id is not passed
639 ;; as argument to password-read.
640 ;; Is that on purpose? If so, the following needs to be placed
641 ;; inside an if statement.
642 password-cache-key-id)))
644 (let ((password-cache-expiry (mml-secure-cache-expiry-interval
645 (epg-context-protocol context))))
646 (password-cache-add password-cache-key-id passphrase))
647 (mml-secure-add-secret-key-id password-cache-key-id)
648 (copy-sequence passphrase)))))
650 (defun mml-secure-check-user-id (key recipient)
651 "Check whether KEY has a non-revoked, non-expired UID for RECIPIENT."
652 ;; Based on mml2015-epg-check-user-id.
653 (let ((uids (epg-key-user-id-list key)))
655 (dolist (uid uids nil)
656 (if (and (stringp (epg-user-id-string uid))
657 (equal (downcase (car (mail-header-parse-address
658 (epg-user-id-string uid))))
659 (downcase (car (mail-header-parse-address
661 (not (memq (epg-user-id-validity uid)
662 '(revoked expired))))
663 (throw 'break t))))))
665 (defun mml-secure-secret-key-exists-p (context subkey)
666 "Return t if keyring for CONTEXT contains secret key for public SUBKEY."
667 (let* ((fpr (epg-sub-key-fingerprint subkey))
668 (candidates (epg-list-keys context fpr 'secret))
669 (candno (length candidates)))
670 ;; If two or more subkeys with the same fingerprint exist, something is
673 (error "Found %d secret keys with same fingerprint %s" candno fpr))
676 (defun mml-secure-check-sub-key (context key usage &optional fingerprint)
677 "Check whether in CONTEXT the public KEY has a usable subkey for USAGE.
678 This is the case if KEY is not disabled, and there is a subkey for
679 USAGE that is neither revoked nor expired. Additionally, if optional
680 FINGERPRINT is present and if it is not the primary key's fingerprint, then
681 the returned subkey must have that FINGERPRINT. FINGERPRINT must consist of
682 hexadecimal digits only (no leading \"0x\" allowed).
683 If USAGE is not `encrypt', then additionally an appropriate secret key must
684 be present in the keyring."
685 ;; Based on mml2015-epg-check-sub-key, extended by
686 ;; - check for secret keys if usage is not 'encrypt and
687 ;; - check for new argument FINGERPRINT.
688 (let* ((subkeys (epg-key-sub-key-list key))
689 (primary (car subkeys))
690 (fpr (epg-sub-key-fingerprint primary)))
691 ;; The primary key will be marked as disabled, when the entire
692 ;; key is disabled (see 12 Field, Format of colon listings, in
693 ;; gnupg/doc/DETAILS)
694 (unless (memq 'disabled (epg-sub-key-capability primary))
696 (dolist (subkey subkeys nil)
697 (if (and (memq usage (epg-sub-key-capability subkey))
698 (not (memq (epg-sub-key-validity subkey)
700 (or (eq 'encrypt usage) ; Encryption works with public key.
701 ;; In contrast, signing requires secret key.
702 (mml-secure-secret-key-exists-p context subkey))
703 (or (not fingerprint)
704 (string-match-p (concat fingerprint "$") fpr)
705 (string-match-p (concat fingerprint "$")
706 (epg-sub-key-fingerprint subkey))))
707 (throw 'break t)))))))
709 (defun mml-secure-find-usable-keys (context name usage &optional justone)
710 "In CONTEXT return a list of keys for NAME and USAGE.
711 If USAGE is `encrypt' public keys are returned, otherwise secret ones.
712 Only non-revoked and non-expired keys are returned whose primary key is
714 NAME can be an e-mail address or a key ID.
715 If NAME just consists of hexadecimal digits (possibly prefixed by \"0x\"), it
716 is treated as key ID for which at most one key must exist in the keyring.
717 Otherwise, NAME is treated as user ID, for which no keys are returned if it
718 is expired or revoked.
719 If optional JUSTONE is not nil, return the first key instead of a list."
720 (let* ((keys (epg-list-keys context name))
721 (iskeyid (string-match "\\(0x\\)?\\([0-9a-fA-F]\\{8,\\}\\)" name))
722 (fingerprint (match-string 2 name))
724 (when (and iskeyid (>= (length keys) 2))
726 "Name %s (for %s) looks like a key ID but multiple keys found"
729 (dolist (key keys result)
731 (mml-secure-check-user-id key name))
732 (mml-secure-check-sub-key context key usage fingerprint))
735 (push key result)))))))
737 (defun mml-secure-select-preferred-keys (context names usage)
738 "Return list of preferred keys in CONTEXT for NAMES and USAGE.
739 This inspects the keyrings to find keys for each name in NAMES. If several
740 keys are found for a name, `mml-secure-select-keys' is used to look for
741 customized preferences or have the user select preferable ones.
742 When `mml-secure-fail-when-key-problem' is t, fail with an error in
743 case of missing, outdated, or multiple keys."
744 ;; Loosely based on code appearing inside mml2015-epg-sign and
745 ;; mml2015-epg-encrypt.
750 (let* ((keys (mml-secure-find-usable-keys context name usage))
751 (keyno (length keys)))
753 (when (or mml-secure-fail-when-key-problem
755 (format "No %s key for %s; skip it? "
757 (error "No %s key for %s" usage name)))
759 (t (mml-secure-select-keys context name keys usage)))))
762 (defun mml-secure-fingerprint (key)
763 "Return fingerprint for public KEY."
764 (epg-sub-key-fingerprint (car (epg-key-sub-key-list key))))
766 (defun mml-secure-filter-keys (keys fprs)
767 "Filter KEYS to subset with fingerprints in FPRS."
769 (if (member (mml-secure-fingerprint (car keys)) fprs)
770 (cons (car keys) (mml-secure-filter-keys (cdr keys) fprs))
771 (mml-secure-filter-keys (cdr keys) fprs))))
773 (defun mml-secure-normalize-cust-name (name)
774 "Normalize NAME to be used for customization.
775 Currently, remove ankle brackets."
776 (if (string-match "^<\\(.*\\)>$" name)
777 (match-string 1 name)
780 (defun mml-secure-select-keys (context name keys usage)
781 "In CONTEXT for NAME select among KEYS for USAGE.
782 KEYS should be a list with multiple entries.
783 NAME is normalized first as customized keys are inspected.
784 When `mml-secure-fail-when-key-problem' is t, fail with an error in case of
785 outdated or multiple keys."
786 (let* ((nname (mml-secure-normalize-cust-name name))
787 (fprs (mml-secure-cust-fpr-lookup context usage nname))
788 (usable-fprs (mapcar 'mml-secure-fingerprint keys)))
790 (if (gnus-subsetp fprs usable-fprs)
791 (mml-secure-filter-keys keys fprs)
792 (mml-secure-cust-remove-keys context usage nname)
793 (let ((diff (gnus-setdiff fprs usable-fprs)))
794 (if mml-secure-fail-when-key-problem
795 (error "Customization of %s keys for %s outdated" usage nname)
796 (mml-secure-select-keys-1
797 context nname keys usage (format "\
800 for %s not available any more.
803 (if mml-secure-fail-when-key-problem
804 (error "Multiple %s keys for %s" usage nname)
805 (mml-secure-select-keys-1
806 context nname keys usage (format "\
807 Multiple %s keys for:
809 Select preferred one(s). "
812 (defun mml-secure-select-keys-1 (context name keys usage message)
813 "In CONTEXT for NAME let user select among KEYS for USAGE, showing MESSAGE.
814 Return selected keys."
815 (let* ((selected (epa--select-keys message keys))
816 (selno (length selected))
817 ;; TODO: y-or-n-p does not always resize the echo area but may
818 ;; truncate the message. Why? The following does not help.
819 ;; yes-or-no-p shows full message, though.
820 (message-truncate-lines nil))
823 (format "%d %s key(s) selected. Store for %s? "
825 (mml-secure-cust-record-keys context usage name selected 'save)
828 (format "No %s key for %s; skip it? " usage name))
829 (error "No %s key for %s" usage name)))))
831 (defun mml-secure-signer-names (protocol sender)
832 "Determine signer names for PROTOCOL and message from SENDER.
833 Returned names may be e-mail addresses or key IDs and are determined based
834 on `mml-secure-openpgp-signers' and `mml-secure-openpgp-sign-with-sender' with
835 OpenPGP or `mml-secure-smime-signers' and `mml-secure-smime-sign-with-sender'
837 (if (eq 'OpenPGP protocol)
838 (append mml-secure-openpgp-signers
839 (if (and mml-secure-openpgp-sign-with-sender sender)
840 (list (concat "<" sender ">"))))
841 (append mml-secure-smime-signers
842 (if (and mml-secure-smime-sign-with-sender sender)
843 (list (concat "<" sender ">"))))))
845 (defun mml-secure-signers (context signer-names)
846 "Determine signing keys in CONTEXT from SIGNER-NAMES.
847 If `mm-sign-option' is `guided', the user is asked to choose.
848 Otherwise, `mml-secure-select-preferred-keys' is used."
849 ;; Based on code appearing inside mml2015-epg-sign and
850 ;; mml2015-epg-encrypt.
851 (if (eq mm-sign-option 'guided)
852 (epa-select-keys context "\
853 Select keys for signing.
854 If no one is selected, default secret key is used. "
856 (mml-secure-select-preferred-keys context signer-names 'sign)))
858 (defun mml-secure-self-recipients (protocol sender)
859 "Determine additional recipients based on encrypt-to-self variables.
860 PROTOCOL specifies OpenPGP or S/MIME for a message from SENDER."
861 (let ((encrypt-to-self
862 (if (eq 'OpenPGP protocol)
863 mml-secure-openpgp-encrypt-to-self
864 mml-secure-smime-encrypt-to-self)))
865 (when encrypt-to-self
866 (if (listp encrypt-to-self)
870 (defun mml-secure-recipients (protocol context config sender)
871 "Determine encryption recipients.
872 PROTOCOL specifies OpenPGP or S/MIME with matching CONTEXT and CONFIG
873 for a message from SENDER."
874 ;; Based on code appearing inside mml2015-epg-encrypt.
879 (or (epg-expand-group config recipient)
880 (list (concat "<" recipient ">"))))
882 (or (message-options-get 'message-recipients)
883 (message-options-set 'message-recipients
884 (read-string "Recipients: ")))
885 "[ \f\t\n\r\v,]+")))))
886 (nconc recipients (mml-secure-self-recipients protocol sender))
887 (if (eq mm-encrypt-option 'guided)
889 (epa-select-keys context "\
890 Select recipients for encryption.
891 If no one is selected, symmetric encryption will be performed. "
894 (mml-secure-select-preferred-keys context recipients 'encrypt))
896 (error "No recipient specified")))
899 (defun mml-secure-epg-encrypt (protocol cont &optional sign)
900 ;; Based on code appearing inside mml2015-epg-encrypt.
901 (let* ((context (epg-make-context protocol))
902 (config (epg-configuration))
903 (sender (message-options-get 'message-sender))
904 (recipients (mml-secure-recipients protocol context config sender))
905 (signer-names (mml-secure-signer-names protocol sender))
908 (setq signers (mml-secure-signers context signer-names))
909 (setf (epg-context-signers context) signers))
910 (when (eq 'OpenPGP protocol)
911 (setf (epg-context-armor context) t)
912 (setf (epg-context-textmode context) t))
913 (when (mml-secure-cache-passphrase-p protocol)
914 (epg-context-set-passphrase-callback
916 (cons 'mml-secure-passphrase-callback protocol)))
917 (condition-case error
919 (if (eq 'OpenPGP protocol)
920 (epg-encrypt-string context (buffer-string) recipients sign
921 mml-secure-openpgp-always-trust)
922 (epg-encrypt-string context (buffer-string) recipients))
923 mml-secure-secret-key-id-list nil)
925 (mml-secure-clear-secret-key-id-list)
926 (signal (car error) (cdr error))))
929 (defun mml-secure-epg-sign (protocol mode)
930 ;; Based on code appearing inside mml2015-epg-sign.
931 (let* ((context (epg-make-context protocol))
932 (sender (message-options-get 'message-sender))
933 (signer-names (mml-secure-signer-names protocol sender))
934 (signers (mml-secure-signers context signer-names))
936 (when (eq 'OpenPGP protocol)
937 (setf (epg-context-armor context) t)
938 (setf (epg-context-textmode context) t))
939 (setf (epg-context-signers context) signers)
940 (when (mml-secure-cache-passphrase-p protocol)
941 (epg-context-set-passphrase-callback
943 (cons 'mml-secure-passphrase-callback protocol)))
944 (condition-case error
946 (if (eq 'OpenPGP protocol)
947 (epg-sign-string context (buffer-string) mode)
948 (epg-sign-string context
949 (replace-regexp-in-string
950 "\n" "\r\n" (buffer-string))
952 mml-secure-secret-key-id-list nil)
954 (mml-secure-clear-secret-key-id-list)
955 (signal (car error) (cdr error))))
956 (if (epg-context-result-for context 'sign)
957 (setq micalg (epg-new-signature-digest-algorithm
958 (car (epg-context-result-for context 'sign)))))
959 (cons signature micalg)))
963 ;;; mml-sec.el ends here