f5bfcecca816d0c0957b51be8c4113e83f0bef75
[gnus] / lisp / mml-sec.el
1 ;;; mml-sec.el --- A package with security functions for MML documents
2
3 ;; Copyright (C) 2000-2016 Free Software Foundation, Inc.
4
5 ;; Author: Simon Josefsson <simon@josefsson.org>
6
7 ;; This file is part of GNU Emacs.
8
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.
13
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.
18
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/>.
21
22 ;;; Commentary:
23
24 ;;; Code:
25
26 (eval-when-compile (require 'cl))
27
28 (require 'gnus-util)
29 (require 'epg)
30
31 (autoload 'mail-strip-quoted-names "mail-utils")
32 (autoload 'mml2015-sign "mml2015")
33 (autoload 'mml2015-encrypt "mml2015")
34 (autoload 'mml1991-sign "mml1991")
35 (autoload 'mml1991-encrypt "mml1991")
36 (autoload 'message-fetch-field "message")
37 (autoload 'message-goto-body "message")
38 (autoload 'mml-insert-tag "mml")
39 (autoload 'mml-smime-sign "mml-smime")
40 (autoload 'mml-smime-encrypt "mml-smime")
41 (autoload 'mml-smime-sign-query "mml-smime")
42 (autoload 'mml-smime-encrypt-query "mml-smime")
43 (autoload 'mml-smime-verify "mml-smime")
44 (autoload 'mml-smime-verify-test "mml-smime")
45 (autoload 'epa--select-keys "epa")
46
47 (defvar mml-sign-alist
48   '(("smime"     mml-smime-sign-buffer     mml-smime-sign-query)
49     ("pgp"       mml-pgp-sign-buffer       list)
50     ("pgpauto"   mml-pgpauto-sign-buffer  list)
51     ("pgpmime"   mml-pgpmime-sign-buffer   list))
52   "Alist of MIME signer functions.")
53
54 (defcustom mml-default-sign-method "pgpmime"
55   "Default sign method.
56 The string must have an entry in `mml-sign-alist'."
57   :version "22.1"
58   :type '(choice (const "smime")
59                  (const "pgp")
60                  (const "pgpauto")
61                  (const "pgpmime")
62                  string)
63   :group 'message)
64
65 (defvar mml-encrypt-alist
66   '(("smime"     mml-smime-encrypt-buffer     mml-smime-encrypt-query)
67     ("pgp"       mml-pgp-encrypt-buffer       list)
68     ("pgpauto"   mml-pgpauto-sign-buffer  list)
69     ("pgpmime"   mml-pgpmime-encrypt-buffer   list))
70   "Alist of MIME encryption functions.")
71
72 (defcustom mml-default-encrypt-method "pgpmime"
73   "Default encryption method.
74 The string must have an entry in `mml-encrypt-alist'."
75   :version "22.1"
76   :type '(choice (const "smime")
77                  (const "pgp")
78                  (const "pgpauto")
79                  (const "pgpmime")
80                  string)
81   :group 'message)
82
83 (defcustom mml-signencrypt-style-alist
84   '(("smime"   separate)
85     ("pgp"     combined)
86     ("pgpauto" combined)
87     ("pgpmime" combined))
88   "Alist specifying if `signencrypt' results in two separate operations or not.
89 The first entry indicates the MML security type, valid entries include
90 the strings \"smime\", \"pgp\", and \"pgpmime\".  The second entry is
91 a symbol `separate' or `combined' where `separate' means that MML signs
92 and encrypt messages in a two step process, and `combined' means that MML
93 signs and encrypt the message in one step.
94
95 Note that the output generated by using a `combined' mode is NOT
96 understood by all PGP implementations, in particular PGP version
97 2 does not support it!  See Info node `(message) Security' for
98 details."
99   :version "22.1"
100   :group 'message
101   :type '(repeat (list (choice (const :tag "S/MIME" "smime")
102                                (const :tag "PGP" "pgp")
103                                (const :tag "PGP/MIME" "pgpmime")
104                                (string :tag "User defined"))
105                        (choice (const :tag "Separate" separate)
106                                (const :tag "Combined" combined)))))
107
108 (defcustom mml-secure-verbose nil
109   "If non-nil, ask the user about the current operation more verbosely."
110   :group 'message
111   :type 'boolean)
112
113 (defcustom mml-secure-cache-passphrase
114   (if (boundp 'password-cache)
115       password-cache
116     t)
117   "If t, cache OpenPGP or S/MIME passphrases inside Emacs.
118 Passphrase caching in Emacs is NOT recommended.  Use gpg-agent instead.
119 See Info node `(message) Security'."
120   :group 'message
121   :type 'boolean)
122
123 (defcustom mml-secure-passphrase-cache-expiry
124   (if (boundp 'password-cache-expiry)
125       password-cache-expiry
126     16)
127   "How many seconds the passphrase is cached.
128 Whether the passphrase is cached at all is controlled by
129 `mml-secure-cache-passphrase'."
130   :group 'message
131   :type 'integer)
132
133 (defcustom mml-secure-safe-bcc-list nil
134   "List of e-mail addresses that are safe to use in Bcc headers.
135 EasyPG encrypts e-mails to Bcc addresses, and the encrypted e-mail
136 by default identifies the used encryption keys, giving away the
137 Bcc'ed identities.  Clearly, this contradicts the original goal of
138 *blind* copies.
139 For an academic paper explaining the problem, see URL
140 `http://crypto.stanford.edu/portia/papers/bb-bcc.pdf'.
141 Use this variable to specify e-mail addresses whose owners do not
142 mind if they are identifiable as recipients.  This may be useful if
143 you use Bcc headers to encrypt e-mails to yourself."
144   :version "25.1"
145   :group 'message
146   :type '(repeat string))
147
148 ;;; Configuration/helper functions
149
150 (defun mml-signencrypt-style (method &optional style)
151   "Function for setting/getting the signencrypt-style used.  Takes two
152 arguments, the method (e.g. \"pgp\") and optionally the mode
153 \(e.g. combined).  If the mode is omitted, the current value is returned.
154
155 For example, if you prefer to use combined sign & encrypt with
156 smime, putting the following in your Gnus startup file will
157 enable that behavior:
158
159 \(mml-set-signencrypt-style \"smime\" combined)
160
161 You can also customize or set `mml-signencrypt-style-alist' instead."
162   (let ((style-item (assoc method mml-signencrypt-style-alist)))
163     (if style-item
164         (if (or (eq style 'separate)
165                 (eq style 'combined))
166             ;; valid style setting?
167             (setf (second style-item) style)
168           ;; otherwise, just return the current value
169           (second style-item))
170       (message "Warning, attempt to set invalid signencrypt style"))))
171
172 ;;; Security functions
173
174 (defun mml-smime-sign-buffer (cont)
175   (or (mml-smime-sign cont)
176       (error "Signing failed... inspect message logs for errors")))
177
178 (defun mml-smime-encrypt-buffer (cont &optional sign)
179   (when sign
180     (message "Combined sign and encrypt S/MIME not support yet")
181     (sit-for 1))
182   (or (mml-smime-encrypt cont)
183       (error "Encryption failed... inspect message logs for errors")))
184
185 (defun mml-pgp-sign-buffer (cont)
186   (or (mml1991-sign cont)
187       (error "Signing failed... inspect message logs for errors")))
188
189 (defun mml-pgp-encrypt-buffer (cont &optional sign)
190   (or (mml1991-encrypt cont sign)
191       (error "Encryption failed... inspect message logs for errors")))
192
193 (defun mml-pgpmime-sign-buffer (cont)
194   (or (mml2015-sign cont)
195       (error "Signing failed... inspect message logs for errors")))
196
197 (defun mml-pgpmime-encrypt-buffer (cont &optional sign)
198   (or (mml2015-encrypt cont sign)
199       (error "Encryption failed... inspect message logs for errors")))
200
201 (defun mml-pgpauto-sign-buffer (cont)
202   (message-goto-body)
203   (or (if (re-search-backward "Content-Type: *multipart/.*" nil t) ; there must be a better way...
204           (mml2015-sign cont)
205         (mml1991-sign cont))
206       (error "Encryption failed... inspect message logs for errors")))
207
208 (defun mml-pgpauto-encrypt-buffer (cont &optional sign)
209   (message-goto-body)
210   (or (if (re-search-backward "Content-Type: *multipart/.*" nil t) ; there must be a better way...
211           (mml2015-encrypt cont sign)
212         (mml1991-encrypt cont sign))
213       (error "Encryption failed... inspect message logs for errors")))
214
215 (defun mml-secure-part (method &optional sign)
216   (save-excursion
217     (let ((tags (funcall (nth 2 (assoc method (if sign mml-sign-alist
218                                                 mml-encrypt-alist))))))
219       (cond ((re-search-backward
220               "<#\\(multipart\\|part\\|external\\|mml\\)" nil t)
221              (goto-char (match-end 0))
222              (insert (if sign " sign=" " encrypt=") method)
223              (while tags
224                (let ((key (pop tags))
225                      (value (pop tags)))
226                  (when value
227                    ;; Quote VALUE if it contains suspicious characters.
228                    (when (string-match "[\"'\\~/*;() \t\n]" value)
229                      (setq value (prin1-to-string value)))
230                    (insert (format " %s=%s" key value))))))
231             ((or (re-search-backward
232                   (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
233                  (re-search-forward
234                   (concat "^" (regexp-quote mail-header-separator) "\n") nil t))
235              (goto-char (match-end 0))
236              (apply 'mml-insert-tag 'part (cons (if sign 'sign 'encrypt)
237                                                 (cons method tags))))
238             (t (error "The message is corrupted. No mail header separator"))))))
239
240 (defvar mml-secure-method
241   (if (equal mml-default-encrypt-method mml-default-sign-method)
242       mml-default-sign-method
243     "pgpmime")
244   "Current security method.  Internal variable.")
245
246 (defun mml-secure-sign (&optional method)
247   "Add MML tags to sign this MML part.
248 Use METHOD if given.  Else use `mml-secure-method' or
249 `mml-default-sign-method'."
250   (interactive)
251   (mml-secure-part
252    (or method mml-secure-method mml-default-sign-method)
253    'sign))
254
255 (defun mml-secure-encrypt (&optional method)
256   "Add MML tags to encrypt this MML part.
257 Use METHOD if given.  Else use `mml-secure-method' or
258 `mml-default-sign-method'."
259   (interactive)
260   (mml-secure-part
261    (or method mml-secure-method mml-default-sign-method)))
262
263 (defun mml-secure-sign-pgp ()
264   "Add MML tags to PGP sign this MML part."
265   (interactive)
266   (mml-secure-part "pgp" 'sign))
267
268 (defun mml-secure-sign-pgpauto ()
269   "Add MML tags to PGP-auto sign this MML part."
270   (interactive)
271   (mml-secure-part "pgpauto" 'sign))
272
273 (defun mml-secure-sign-pgpmime ()
274   "Add MML tags to PGP/MIME sign this MML part."
275   (interactive)
276   (mml-secure-part "pgpmime" 'sign))
277
278 (defun mml-secure-sign-smime ()
279   "Add MML tags to S/MIME sign this MML part."
280   (interactive)
281   (mml-secure-part "smime" 'sign))
282
283 (defun mml-secure-encrypt-pgp ()
284   "Add MML tags to PGP encrypt this MML part."
285   (interactive)
286   (mml-secure-part "pgp"))
287
288 (defun mml-secure-encrypt-pgpmime ()
289   "Add MML tags to PGP/MIME encrypt this MML part."
290   (interactive)
291   (mml-secure-part "pgpmime"))
292
293 (defun mml-secure-encrypt-smime ()
294   "Add MML tags to S/MIME encrypt this MML part."
295   (interactive)
296   (mml-secure-part "smime"))
297
298 (defun mml-secure-is-encrypted-p ()
299   "Check whether secure encrypt tag is present."
300   (save-excursion
301     (goto-char (point-min))
302     (re-search-forward
303      (concat "^" (regexp-quote mail-header-separator) "\n"
304              "<#secure[^>]+encrypt")
305      nil t)))
306
307 (defun mml-secure-bcc-is-safe ()
308   "Check whether usage of Bcc is safe (or absent).
309 Bcc usage is safe in two cases: first, if the current message does
310 not contain an MML secure encrypt tag;
311 second, if the Bcc addresses are a subset of `mml-secure-safe-bcc-list'.
312 In all other cases, ask the user whether Bcc usage is safe.
313 Raise error if user answers no.
314 Note that this function does not produce a meaningful return value:
315 either an error is raised or not."
316   (when (mml-secure-is-encrypted-p)
317     (let ((bcc (mail-strip-quoted-names (message-fetch-field "bcc"))))
318       (when bcc
319         (let ((bcc-list (mapcar #'cadr
320                                 (mail-extract-address-components bcc t))))
321           (unless (gnus-subsetp bcc-list mml-secure-safe-bcc-list)
322             (unless (yes-or-no-p "Message for encryption contains Bcc header.\
323   This may give away all Bcc'ed identities to all recipients.\
324   Are you sure that this is safe?\
325   (Customize `mml-secure-safe-bcc-list' to avoid this warning.) ")
326               (error "Aborted"))))))))
327
328 ;; defuns that add the proper <#secure ...> tag to the top of the message body
329 (defun mml-secure-message (method &optional modesym)
330   (let ((mode (prin1-to-string modesym))
331         (tags (append
332                (if (or (eq modesym 'sign)
333                        (eq modesym 'signencrypt))
334                    (funcall (nth 2 (assoc method mml-sign-alist))))
335                (if (or (eq modesym 'encrypt)
336                        (eq modesym 'signencrypt))
337                    (funcall (nth 2 (assoc method mml-encrypt-alist))))))
338         insert-loc)
339     (mml-unsecure-message)
340     (save-excursion
341       (goto-char (point-min))
342       (cond ((re-search-forward
343               (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
344              (goto-char (setq insert-loc (match-end 0)))
345              (unless (looking-at "<#secure")
346                (apply 'mml-insert-tag
347                 'secure 'method method 'mode mode tags)))
348             (t (error
349                 "The message is corrupted. No mail header separator"))))
350     (when (eql insert-loc (point))
351       (forward-line 1))))
352
353 (defun mml-unsecure-message ()
354   "Remove security related MML tags from message."
355   (interactive)
356   (save-excursion
357     (goto-char (point-max))
358     (when (re-search-backward "^<#secure.*>\n" nil t)
359       (delete-region (match-beginning 0) (match-end 0)))))
360
361
362 (defun mml-secure-message-sign (&optional method)
363   "Add MML tags to sign the entire message.
364 Use METHOD if given. Else use `mml-secure-method' or
365 `mml-default-sign-method'."
366   (interactive)
367   (mml-secure-message
368    (or method mml-secure-method mml-default-sign-method)
369    'sign))
370
371 (defun mml-secure-message-sign-encrypt (&optional method)
372   "Add MML tag to sign and encrypt the entire message.
373 Use METHOD if given. Else use `mml-secure-method' or
374 `mml-default-sign-method'."
375   (interactive)
376   (mml-secure-message
377    (or method mml-secure-method mml-default-sign-method)
378    'signencrypt))
379
380 (defun mml-secure-message-encrypt (&optional method)
381   "Add MML tag to encrypt the entire message.
382 Use METHOD if given. Else use `mml-secure-method' or
383 `mml-default-sign-method'."
384   (interactive)
385   (mml-secure-message
386    (or method mml-secure-method mml-default-sign-method)
387    'encrypt))
388
389 (defun mml-secure-message-sign-smime ()
390   "Add MML tag to encrypt/sign the entire message."
391   (interactive)
392   (mml-secure-message "smime" 'sign))
393
394 (defun mml-secure-message-sign-pgp ()
395   "Add MML tag to encrypt/sign the entire message."
396   (interactive)
397   (mml-secure-message "pgp" 'sign))
398
399 (defun mml-secure-message-sign-pgpmime ()
400   "Add MML tag to encrypt/sign the entire message."
401   (interactive)
402   (mml-secure-message "pgpmime" 'sign))
403
404 (defun mml-secure-message-sign-pgpauto ()
405   "Add MML tag to encrypt/sign the entire message."
406   (interactive)
407   (mml-secure-message "pgpauto" 'sign))
408
409 (defun mml-secure-message-encrypt-smime (&optional dontsign)
410   "Add MML tag to encrypt and sign the entire message.
411 If called with a prefix argument, only encrypt (do NOT sign)."
412   (interactive "P")
413   (mml-secure-message "smime" (if dontsign 'encrypt 'signencrypt)))
414
415 (defun mml-secure-message-encrypt-pgp (&optional dontsign)
416   "Add MML tag to encrypt and sign the entire message.
417 If called with a prefix argument, only encrypt (do NOT sign)."
418   (interactive "P")
419   (mml-secure-message "pgp" (if dontsign 'encrypt 'signencrypt)))
420
421 (defun mml-secure-message-encrypt-pgpmime (&optional dontsign)
422   "Add MML tag to encrypt and sign the entire message.
423 If called with a prefix argument, only encrypt (do NOT sign)."
424   (interactive "P")
425   (mml-secure-message "pgpmime" (if dontsign 'encrypt 'signencrypt)))
426
427 (defun mml-secure-message-encrypt-pgpauto (&optional dontsign)
428   "Add MML tag to encrypt and sign the entire message.
429 If called with a prefix argument, only encrypt (do NOT sign)."
430   (interactive "P")
431   (mml-secure-message "pgpauto" (if dontsign 'encrypt 'signencrypt)))
432
433 ;;; Common functionality for mml1991.el, mml2015.el, mml-smime.el
434
435 (define-obsolete-variable-alias 'mml1991-signers 'mml-secure-openpgp-signers)
436 (define-obsolete-variable-alias 'mml2015-signers 'mml-secure-openpgp-signers)
437 (defcustom mml-secure-openpgp-signers nil
438   "A list of your own key ID(s) which will be used to sign OpenPGP messages.
439 If set, it is added to the setting of `mml-secure-openpgp-sign-with-sender'."
440   :group 'mime-security
441   :type '(repeat (string :tag "Key ID")))
442
443 (define-obsolete-variable-alias 'mml-smime-signers 'mml-secure-smime-signers)
444 (defcustom mml-secure-smime-signers nil
445   "A list of your own key ID(s) which will be used to sign S/MIME messages.
446 If set, it is added to the setting of `mml-secure-smime-sign-with-sender'."
447   :group 'mime-security
448   :type '(repeat (string :tag "Key ID")))
449
450 (define-obsolete-variable-alias
451   'mml1991-encrypt-to-self 'mml-secure-openpgp-encrypt-to-self)
452 (define-obsolete-variable-alias
453   'mml2015-encrypt-to-self 'mml-secure-openpgp-encrypt-to-self)
454 (defcustom mml-secure-openpgp-encrypt-to-self nil
455   "List of own key ID(s) or t; determines additional recipients with OpenPGP.
456 If t, also encrypt to key for message sender; if list, encrypt to those keys.
457 With this variable, you can ensure that you can decrypt your own messages.
458 Alternatives to this variable include Bcc'ing the message to yourself or
459 using the encrypt-to or hidden-encrypt-to option in gpg.conf (see man gpg(1)).
460 Note that this variable and the encrypt-to option give away your identity
461 for *every* encryption without warning, which is not what you want if you are
462 using, e.g., remailers.
463 Also, use of Bcc gives away your identity for *every* encryption without
464 warning, which is a bug, see:
465 https://debbugs.gnu.org/cgi/bugreport.cgi?bug=18718"
466   :group 'mime-security
467   :type '(choice (const :tag "None" nil)
468                  (const :tag "From address" t)
469                  (repeat (string :tag "Key ID"))))
470
471 (define-obsolete-variable-alias
472   'mml-smime-encrypt-to-self 'mml-secure-smime-encrypt-to-self)
473 (defcustom mml-secure-smime-encrypt-to-self nil
474   "List of own key ID(s) or t; determines additional recipients with S/MIME.
475 If t, also encrypt to key for message sender; if list, encrypt to those keys.
476 With this variable, you can ensure that you can decrypt your own messages.
477 Alternatives to this variable include Bcc'ing the message to yourself or
478 using the encrypt-to option in gpgsm.conf (see man gpgsm(1)).
479 Note that this variable and the encrypt-to option give away your identity
480 for *every* encryption without warning, which is not what you want if you are
481 using, e.g., remailers.
482 Also, use of Bcc gives away your identity for *every* encryption without
483 warning, which is a bug, see:
484 https://debbugs.gnu.org/cgi/bugreport.cgi?bug=18718"
485   :group 'mime-security
486   :type '(choice (const :tag "None" nil)
487                  (const :tag "From address" t)
488                  (repeat (string :tag "Key ID"))))
489
490 (define-obsolete-variable-alias
491   'mml2015-sign-with-sender 'mml-secure-openpgp-sign-with-sender)
492 ;mml1991-sign-with-sender did never exist.
493 (defcustom mml-secure-openpgp-sign-with-sender nil
494   "If t, use message sender to find an OpenPGP key to sign with."
495   :group 'mime-security
496   :type 'boolean)
497
498 (define-obsolete-variable-alias
499   'mml-smime-sign-with-sender 'mml-secure-smime-sign-with-sender)
500 (defcustom mml-secure-smime-sign-with-sender nil
501   "If t, use message sender to find an S/MIME key to sign with."
502   :group 'mime-security
503   :type 'boolean)
504
505 (defcustom mml-secure-smime-sign-with-sender nil
506   "If t, use message sender to find an S/MIME key to sign with."
507   :group 'mime-security
508   :type 'boolean)
509 (define-obsolete-variable-alias
510   'mml2015-always-trust 'mml-secure-openpgp-always-trust)
511 ;mml1991-always-trust did never exist.
512 (defcustom mml-secure-openpgp-always-trust t
513   "If t, skip key validation of GnuPG on encryption."
514   :group 'mime-security
515   :type 'boolean)
516
517 (defcustom mml-secure-fail-when-key-problem nil
518   "If t, raise an error if some key is missing or several keys exist.
519 Otherwise, ask the user."
520   :group 'mime-security
521   :type 'boolean)
522
523 (defcustom mml-secure-key-preferences
524   '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))
525   "Protocol- and usage-specific fingerprints of preferred keys.
526 This variable is only relevant if a recipient owns multiple key pairs (for
527 encryption) or you own multiple key pairs (for signing).  In such cases,
528 you will be asked which key(s) should be used, and your choice can be
529 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"))))))
535
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)))
541
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))))
546     (when fprs
547       (cdr fprs))))
548
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.
552 Return keys."
553   (assert keys)
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)))
558     (if curr-fprs
559         (setcdr (assoc name (cdr usage-prefs)) new-fprs)
560       (setcdr usage-prefs (cons (cons name new-fprs) (cdr usage-prefs))))
561     (when save
562         (customize-save-variable
563          'mml-secure-key-preferences mml-secure-key-preferences))
564     keys))
565
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)))
571     (when current
572       (setcdr usage-prefs (remove current (cdr usage-prefs)))
573       t)))
574
575 (defvar mml-secure-secret-key-id-list nil)
576
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))
580
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))
588
589 (defun mml-secure-cache-passphrase-p (protocol)
590   "Return t if OpenPGP or S/MIME passphrases should be cached for PROTOCOL.
591 Passphrase caching in Emacs is NOT recommended.  Use gpg-agent instead."
592   (or (and (eq 'OpenPGP protocol)
593            (or mml-secure-cache-passphrase
594                (and (boundp 'mml2015-cache-passphrase)
595                     mml2015-cache-passphrase)
596                (and (boundp 'mml1991-cache-passphrase)
597                     mml1991-cache-passphrase)))
598       (and (eq 'CMS protocol)
599            (or mml-secure-cache-passphrase
600                (and (boundp 'mml-smime-cache-passphrase)
601                     mml-smime-cache-passphrase)))))
602
603 (defun mml-secure-cache-expiry-interval (protocol)
604   "Return time in seconds to cache passphrases for PROTOCOL.
605 Passphrase caching in Emacs is NOT recommended.  Use gpg-agent instead."
606   (or (and (eq 'OpenPGP protocol)
607            (or (and (boundp 'mml2015-passphrase-cache-expiry)
608                     mml2015-passphrase-cache-expiry)
609                (and (boundp 'mml1991-passphrase-cache-expiry)
610                     mml1991-passphrase-cache-expiry)
611                mml-secure-passphrase-cache-expiry))
612       (and (eq 'CMS protocol)
613            (or (and (boundp 'mml-smime-passphrase-cache-expiry)
614                     mml-smime-passphrase-cache-expiry)
615                mml-secure-passphrase-cache-expiry))))
616
617 (defun mml-secure-passphrase-callback (context key-id standard)
618   "Ask for passphrase in CONTEXT for KEY-ID for STANDARD.
619 The passphrase is read and cached."
620   ;; Based on mml2015-epg-passphrase-callback.
621   (if (eq key-id 'SYM)
622       (epg-passphrase-callback-function context key-id nil)
623     (let* ((password-cache-key-id
624             (if (eq key-id 'PIN)
625                 "PIN"
626                key-id))
627            (entry (assoc key-id epg-user-id-alist))
628            (passphrase
629             (password-read
630              (if (eq key-id 'PIN)
631                  "Passphrase for PIN: "
632                (if entry
633                    (format "Passphrase for %s %s: " key-id (cdr entry))
634                  (format "Passphrase for %s: " key-id)))
635              ;; TODO: With mml-smime.el, password-cache-key-id is not passed
636              ;; as argument to password-read.
637              ;; Is that on purpose?  If so, the following needs to be placed
638              ;; inside an if statement.
639              password-cache-key-id)))
640       (when passphrase
641         (let ((password-cache-expiry (mml-secure-cache-expiry-interval
642                                       (epg-context-protocol context))))
643           (password-cache-add password-cache-key-id passphrase))
644         (mml-secure-add-secret-key-id password-cache-key-id)
645         (copy-sequence passphrase)))))
646
647 (defun mml-secure-check-user-id (key recipient)
648   "Check whether KEY has a non-revoked, non-expired UID for RECIPIENT."
649   ;; Based on mml2015-epg-check-user-id.
650   (let ((uids (epg-key-user-id-list key)))
651     (catch 'break
652       (dolist (uid uids nil)
653         (if (and (stringp (epg-user-id-string uid))
654                  (equal (car (mail-header-parse-address
655                               (epg-user-id-string uid)))
656                         (car (mail-header-parse-address
657                               recipient)))
658                  (not (memq (epg-user-id-validity uid)
659                             '(revoked expired))))
660             (throw 'break t))))))
661
662 (defun mml-secure-secret-key-exists-p (context subkey)
663   "Return t if keyring for CONTEXT contains secret key for public SUBKEY."
664   (let* ((fpr (epg-sub-key-fingerprint subkey))
665          (candidates (epg-list-keys context fpr 'secret))
666          (candno (length candidates)))
667     ;; If two or more subkeys with the same fingerprint exist, something is
668     ;; terribly wrong.
669     (when (>= candno 2)
670       (error "Found %d secret keys with same fingerprint %s" candno fpr))
671     (= 1 candno)))
672
673 (defun mml-secure-check-sub-key (context key usage &optional fingerprint)
674   "Check whether in CONTEXT the public KEY has a usable subkey for USAGE.
675 This is the case if KEY is not disabled, and there is a subkey for
676 USAGE that is neither revoked nor expired.  Additionally, if optional
677 FINGERPRINT is present and if it is not the primary key's fingerprint, then
678 the returned subkey must have that FINGERPRINT.  FINGERPRINT must consist of
679 hexadecimal digits only (no leading \"0x\" allowed).
680 If USAGE is not `encrypt', then additionally an appropriate secret key must
681 be present in the keyring."
682   ;; Based on mml2015-epg-check-sub-key, extended by
683   ;; - check for secret keys if usage is not 'encrypt and
684   ;; - check for new argument FINGERPRINT.
685   (let* ((subkeys (epg-key-sub-key-list key))
686          (primary (car subkeys))
687          (fpr (epg-sub-key-fingerprint primary)))
688     ;; The primary key will be marked as disabled, when the entire
689     ;; key is disabled (see 12 Field, Format of colon listings, in
690     ;; gnupg/doc/DETAILS)
691     (unless (memq 'disabled (epg-sub-key-capability primary))
692       (catch 'break
693         (dolist (subkey subkeys nil)
694           (if (and (memq usage (epg-sub-key-capability subkey))
695                    (not (memq (epg-sub-key-validity subkey)
696                               '(revoked expired)))
697                    (or (eq 'encrypt usage) ; Encryption works with public key.
698                        ;; In contrast, signing requires secret key.
699                        (mml-secure-secret-key-exists-p context subkey))
700                    (or (not fingerprint)
701                        (string-match-p (concat fingerprint "$") fpr)
702                        (string-match-p (concat fingerprint "$")
703                                        (epg-sub-key-fingerprint subkey))))
704               (throw 'break t)))))))
705
706 (defun mml-secure-find-usable-keys (context name usage &optional justone)
707   "In CONTEXT return a list of keys for NAME and USAGE.
708 If USAGE is `encrypt' public keys are returned, otherwise secret ones.
709 Only non-revoked and non-expired keys are returned whose primary key is
710 not disabled.
711 NAME can be an e-mail address or a key ID.
712 If NAME just consists of hexadecimal digits (possibly prefixed by \"0x\"), it
713 is treated as key ID for which at most one key must exist in the keyring.
714 Otherwise, NAME is treated as user ID, for which no keys are returned if it
715 is expired or revoked.
716 If optional JUSTONE is not nil, return the first key instead of a list."
717   (let* ((keys (epg-list-keys context name))
718          (iskeyid (string-match "\\(0x\\)?\\([0-9a-fA-F]\\{8,\\}\\)" name))
719          (fingerprint (match-string 2 name))
720          result)
721     (when (and iskeyid (>= (length keys) 2))
722       (error
723        "Name %s (for %s) looks like a key ID but multiple keys found"
724        name usage))
725     (catch 'break
726       (dolist (key keys result)
727         (if (and (or iskeyid
728                      (mml-secure-check-user-id key name))
729                  (mml-secure-check-sub-key context key usage fingerprint))
730             (if justone
731                 (throw 'break key)
732               (push key result)))))))
733
734 (defun mml-secure-select-preferred-keys (context names usage)
735   "Return list of preferred keys in CONTEXT for NAMES and USAGE.
736 This inspects the keyrings to find keys for each name in NAMES.  If several
737 keys are found for a name, `mml-secure-select-keys' is used to look for
738 customized preferences or have the user select preferable ones.
739 When `mml-secure-fail-when-key-problem' is t, fail with an error in
740 case of missing, outdated, or multiple keys."
741   ;; Loosely based on code appearing inside mml2015-epg-sign and
742   ;; mml2015-epg-encrypt.
743   (mapcan
744    (lambda (name)
745      (let* ((keys (mml-secure-find-usable-keys context name usage))
746             (keyno (length keys)))
747        (cond ((= 0 keyno)
748               (when (or mml-secure-fail-when-key-problem
749                         (not (y-or-n-p
750                               (format "No %s key for %s; skip it? "
751                                       usage name))))
752                 (error "No %s key for %s" usage name)))
753              ((= 1 keyno) keys)
754              (t (mml-secure-select-keys context name keys usage)))))
755    names))
756
757 (defun mml-secure-fingerprint (key)
758   "Return fingerprint for public KEY."
759   (epg-sub-key-fingerprint (car (epg-key-sub-key-list key))))
760
761 (defun mml-secure-filter-keys (keys fprs)
762   "Filter KEYS to subset with fingerprints in FPRS."
763   (when keys
764     (if (member (mml-secure-fingerprint (car keys)) fprs)
765         (cons (car keys) (mml-secure-filter-keys (cdr keys) fprs))
766       (mml-secure-filter-keys (cdr keys) fprs))))
767
768 (defun mml-secure-normalize-cust-name (name)
769   "Normalize NAME to be used for customization.
770 Currently, remove ankle brackets."
771   (if (string-match "^<\\(.*\\)>$" name)
772       (match-string 1 name)
773     name))
774
775 (defun mml-secure-select-keys (context name keys usage)
776   "In CONTEXT for NAME select among KEYS for USAGE.
777 KEYS should be a list with multiple entries.
778 NAME is normalized first as customized keys are inspected.
779 When `mml-secure-fail-when-key-problem' is t, fail with an error in case of
780 outdated or multiple keys."
781   (let* ((nname (mml-secure-normalize-cust-name name))
782          (fprs (mml-secure-cust-fpr-lookup context usage nname))
783          (usable-fprs (mapcar 'mml-secure-fingerprint keys)))
784     (if fprs
785         (if (gnus-subsetp fprs usable-fprs)
786             (mml-secure-filter-keys keys fprs)
787           (mml-secure-cust-remove-keys context usage nname)
788           (let ((diff (gnus-setdiff fprs usable-fprs)))
789             (if mml-secure-fail-when-key-problem
790                 (error "Customization of %s keys for %s outdated" usage nname)
791               (mml-secure-select-keys-1
792                context nname keys usage (format "\
793 Customized keys
794  (%s)
795 for %s not available any more.
796 Select anew.  "
797                                                diff nname)))))
798       (if mml-secure-fail-when-key-problem
799           (error "Multiple %s keys for %s" usage nname)
800         (mml-secure-select-keys-1
801          context nname keys usage (format "\
802 Multiple %s keys for:
803  %s
804 Select preferred one(s).  "
805                                          usage nname))))))
806
807 (defun mml-secure-select-keys-1 (context name keys usage message)
808   "In CONTEXT for NAME let user select among KEYS for USAGE, showing MESSAGE.
809 Return selected keys."
810   (let* ((selected (epa--select-keys message keys))
811          (selno (length selected))
812          ;; TODO: y-or-n-p does not always resize the echo area but may
813          ;; truncate the message.  Why?  The following does not help.
814          ;; yes-or-no-p shows full message, though.
815          (message-truncate-lines nil))
816     (if selected
817         (if (y-or-n-p
818              (format "%d %s key(s) selected.  Store for %s? "
819                      selno usage name))
820             (mml-secure-cust-record-keys context usage name selected 'save)
821           selected)
822       (unless (y-or-n-p
823                (format "No %s key for %s; skip it? " usage name))
824         (error "No %s key for %s" usage name)))))
825
826 (defun mml-secure-signer-names (protocol sender)
827   "Determine signer names for PROTOCOL and message from SENDER.
828 Returned names may be e-mail addresses or key IDs and are determined based
829 on `mml-secure-openpgp-signers' and `mml-secure-openpgp-sign-with-sender' with
830 OpenPGP or `mml-secure-smime-signers' and `mml-secure-smime-sign-with-sender'
831 with S/MIME."
832   (if (eq 'OpenPGP protocol)
833       (append mml-secure-openpgp-signers
834               (if (and mml-secure-openpgp-sign-with-sender sender)
835                   (list (concat "<" sender ">"))))
836     (append mml-secure-smime-signers
837             (if (and mml-secure-smime-sign-with-sender sender)
838                 (list (concat "<" sender ">"))))))
839
840 (defun mml-secure-signers (context signer-names)
841   "Determine signing keys in CONTEXT from SIGNER-NAMES.
842 If `mm-sign-option' is `guided', the user is asked to choose.
843 Otherwise, `mml-secure-select-preferred-keys' is used."
844   ;; Based on code appearing inside mml2015-epg-sign and
845   ;; mml2015-epg-encrypt.
846   (if (eq mm-sign-option 'guided)
847       (epa-select-keys context "\
848 Select keys for signing.
849 If no one is selected, default secret key is used.  "
850                        signer-names t)
851     (mml-secure-select-preferred-keys context signer-names 'sign)))
852
853 (defun mml-secure-self-recipients (protocol sender)
854   "Determine additional recipients based on encrypt-to-self variables.
855 PROTOCOL specifies OpenPGP or S/MIME for a message from SENDER."
856   (let ((encrypt-to-self
857          (if (eq 'OpenPGP protocol)
858              mml-secure-openpgp-encrypt-to-self
859            mml-secure-smime-encrypt-to-self)))
860     (when encrypt-to-self
861       (if (listp encrypt-to-self)
862           encrypt-to-self
863         (list sender)))))
864
865 (defun mml-secure-recipients (protocol context config sender)
866   "Determine encryption recipients.
867 PROTOCOL specifies OpenPGP or S/MIME with matching CONTEXT and CONFIG
868 for a message from SENDER."
869   ;; Based on code appearing inside mml2015-epg-encrypt.
870   (let ((recipients
871          (apply #'nconc
872                 (mapcar
873                  (lambda (recipient)
874                    (or (epg-expand-group config recipient)
875                        (list (concat "<" recipient ">"))))
876                  (split-string
877                   (or (message-options-get 'message-recipients)
878                       (message-options-set 'message-recipients
879                                            (read-string "Recipients: ")))
880                   "[ \f\t\n\r\v,]+")))))
881     (nconc recipients (mml-secure-self-recipients protocol sender))
882     (if (eq mm-encrypt-option 'guided)
883         (setq recipients
884               (epa-select-keys context "\
885 Select recipients for encryption.
886 If no one is selected, symmetric encryption will be performed.  "
887                                recipients))
888       (setq recipients
889             (mml-secure-select-preferred-keys context recipients 'encrypt))
890       (unless recipients
891         (error "No recipient specified")))
892     recipients))
893
894 (defun mml-secure-epg-encrypt (protocol cont &optional sign)
895   ;; Based on code appearing inside mml2015-epg-encrypt.
896   (let* ((context (epg-make-context protocol))
897          (config (epg-configuration))
898          (sender (message-options-get 'message-sender))
899          (recipients (mml-secure-recipients protocol context config sender))
900          (signer-names (mml-secure-signer-names protocol sender))
901          cipher signers)
902     (when sign
903       (setq signers (mml-secure-signers context signer-names))
904       (epg-context-set-signers context signers))
905     (when (eq 'OpenPGP protocol)
906       (epg-context-set-armor context t)
907       (epg-context-set-textmode context t))
908     (when (mml-secure-cache-passphrase-p protocol)
909       (epg-context-set-passphrase-callback
910        context
911        (cons 'mml-secure-passphrase-callback protocol)))
912     (condition-case error
913         (setq cipher
914               (if (eq 'OpenPGP protocol)
915                   (epg-encrypt-string context (buffer-string) recipients sign
916                                       mml-secure-openpgp-always-trust)
917                 (epg-encrypt-string context (buffer-string) recipients))
918               mml-secure-secret-key-id-list nil)
919       (error
920        (mml-secure-clear-secret-key-id-list)
921        (signal (car error) (cdr error))))
922     cipher))
923
924 (defun mml-secure-epg-sign (protocol mode)
925   ;; Based on code appearing inside mml2015-epg-sign.
926   (let* ((context (epg-make-context protocol))
927          (sender (message-options-get 'message-sender))
928          (signer-names (mml-secure-signer-names protocol sender))
929          (signers (mml-secure-signers context signer-names))
930          signature micalg)
931     (when (eq 'OpenPGP protocol)
932       (epg-context-set-armor context t)
933       (epg-context-set-textmode context t))
934     (epg-context-set-signers context signers)
935     (when (mml-secure-cache-passphrase-p protocol)
936       (epg-context-set-passphrase-callback
937        context
938        (cons 'mml-secure-passphrase-callback protocol)))
939     (condition-case error
940         (setq signature
941               (if (eq 'OpenPGP protocol)
942                   (epg-sign-string context (buffer-string) mode)
943                 (epg-sign-string context
944                                  (mm-replace-in-string (buffer-string)
945                                                        "\n" "\r\n") t))
946               mml-secure-secret-key-id-list nil)
947       (error
948        (mml-secure-clear-secret-key-id-list)
949        (signal (car error) (cdr error))))
950     (if (epg-context-result-for context 'sign)
951         (setq micalg (epg-new-signature-digest-algorithm
952                       (car (epg-context-result-for context 'sign)))))
953     (cons signature micalg)))
954
955 (provide 'mml-sec)
956
957 ;;; mml-sec.el ends here