10ba126ae2b177807f6d0f73ca75901e2adaaf74
[gnus] / lisp / mml2015.el
1 ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
2
3 ;; Copyright (C) 2000-2016 Free Software Foundation, Inc.
4
5 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
6 ;; Keywords: PGP MIME MML
7
8 ;; This file is part of GNU Emacs.
9
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
14
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
22
23 ;;; Commentary:
24
25 ;; RFC 2015 is updated by RFC 3156, this file should be compatible
26 ;; with both.
27
28 ;;; Code:
29
30 (eval-and-compile
31   (if (locate-library "password-cache")
32       (require 'password-cache)
33     (require 'password)))
34
35 (eval-when-compile (require 'cl))
36 (require 'mm-decode)
37 (require 'mm-util)
38 (require 'mml)
39 (require 'mml-sec)
40
41 (defvar mc-pgp-always-sign)
42
43 (declare-function epg-check-configuration "ext:epg-config"
44                   (config &optional minimum-version))
45 (declare-function epg-configuration "ext:epg-config" ())
46
47 ;; Maybe this should be in eg mml-sec.el (and have a different name).
48 ;; Then mml1991 would not need to require mml2015, and mml1991-use
49 ;; could be removed.
50 (defvar mml2015-use (or
51                      (progn
52                        (ignore-errors (require 'epg-config))
53                        (and (fboundp 'epg-check-configuration)
54                            'epg))
55                      (progn
56                        (let ((abs-file (locate-library "pgg")))
57                          ;; Don't load PGG if it is marked as obsolete
58                          ;; (Emacs 24).
59                          (when (and abs-file
60                                     (not (string-match "/obsolete/[^/]*\\'"
61                                                        abs-file)))
62                            (ignore-errors (require 'pgg))
63                            (and (fboundp 'pgg-sign-region)
64                                 'pgg))))
65                      (progn (ignore-errors
66                               (load "mc-toplev"))
67                             (and (fboundp 'mc-encrypt-generic)
68                                  (fboundp 'mc-sign-generic)
69                                  (fboundp 'mc-cleanup-recipient-headers)
70                                  'mailcrypt)))
71   "The package used for PGP/MIME.
72 Valid packages include `epg', `pgg' and `mailcrypt'.")
73
74 ;; Something is not RFC2015.
75 (defvar mml2015-function-alist
76   '((mailcrypt mml2015-mailcrypt-sign
77                mml2015-mailcrypt-encrypt
78                mml2015-mailcrypt-verify
79                mml2015-mailcrypt-decrypt
80                mml2015-mailcrypt-clear-verify
81                mml2015-mailcrypt-clear-decrypt)
82     (pgg mml2015-pgg-sign
83          mml2015-pgg-encrypt
84          mml2015-pgg-verify
85          mml2015-pgg-decrypt
86          mml2015-pgg-clear-verify
87          mml2015-pgg-clear-decrypt)
88     (epg mml2015-epg-sign
89          mml2015-epg-encrypt
90          mml2015-epg-verify
91          mml2015-epg-decrypt
92          mml2015-epg-clear-verify
93          mml2015-epg-clear-decrypt))
94   "Alist of PGP/MIME functions.")
95
96 (defvar mml2015-result-buffer nil)
97
98 (defcustom mml2015-unabbrev-trust-alist
99   '(("TRUST_UNDEFINED" . nil)
100     ("TRUST_NEVER"     . nil)
101     ("TRUST_MARGINAL"  . t)
102     ("TRUST_FULLY"     . t)
103     ("TRUST_ULTIMATE"  . t))
104   "Map GnuPG trust output values to a boolean saying if you trust the key."
105   :version "22.1"
106   :group 'mime-security
107   :type '(repeat (cons (regexp :tag "GnuPG output regexp")
108                        (boolean :tag "Trust key"))))
109
110 (defcustom mml2015-cache-passphrase mml-secure-cache-passphrase
111   "If t, cache passphrase."
112   :group 'mime-security
113   :type 'boolean)
114
115 (defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
116   "How many seconds the passphrase is cached.
117 Whether the passphrase is cached at all is controlled by
118 `mml2015-cache-passphrase'."
119   :group 'mime-security
120   :type 'integer)
121
122 (defcustom mml2015-signers nil
123   "A list of your own key ID(s) which will be used to sign a message.
124 If set, it overrides the setting of `mml2015-sign-with-sender'."
125   :group 'mime-security
126   :type '(repeat (string :tag "Key ID")))
127
128 (defcustom mml2015-sign-with-sender nil
129   "If t, use message sender so find a key to sign with."
130   :group 'mime-security
131   :type 'boolean
132   :version "24.1")
133
134 (defcustom mml2015-encrypt-to-self nil
135   "If t, add your own key ID to recipient list when encryption."
136   :group 'mime-security
137   :type 'boolean)
138
139 (defcustom mml2015-always-trust t
140   "If t, GnuPG skip key validation on encryption."
141   :group 'mime-security
142   :type 'boolean)
143
144 (defcustom mml2015-maximum-key-image-dimension 64
145   "The maximum dimension (width or height) of any key images."
146   :version "24.4"
147   :group 'mime-security
148   :type 'integer)
149
150 (defcustom mml2015-display-key-image t
151   "If t, try to display key images."
152   :version "24.5"
153   :group 'mime-security
154   :type 'boolean)
155
156 ;; Extract plaintext from cleartext signature.  IMO, this kind of task
157 ;; should be done by GnuPG rather than Elisp, but older PGP backends
158 ;; (such as Mailcrypt, and PGG) discard the output from GnuPG.
159 (defun mml2015-extract-cleartext-signature ()
160   ;; Daiki Ueno in
161   ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still
162   ;; believe that the right way is to use the plaintext output from GnuPG as
163   ;; it is, and mml2015-extract-cleartext-signature is just a kludge for
164   ;; misdesigned libraries like PGG, which have no ability to do that.  So, I
165   ;; think it should not have descriptive documentation.''
166   ;;
167   ;; This function doesn't handle NotDashEscaped correctly.  EasyPG handles it
168   ;; correctly.
169   ;; http://thread.gmane.org/gmane.emacs.gnus.general/66062/focus=66082
170   ;; http://thread.gmane.org/gmane.emacs.gnus.general/65087/focus=65109
171   (goto-char (point-min))
172   (forward-line)
173   ;; We need to be careful not to strip beyond the armor headers.
174   ;; Previously, an attacker could replace the text inside our
175   ;; markup with trailing garbage by injecting whitespace into the
176   ;; message.
177   (while (looking-at "Hash:")           ; The only header allowed in cleartext
178     (forward-line))                     ; signatures according to RFC2440.
179   (when (looking-at "[\t ]*$")
180     (forward-line))
181   (delete-region (point-min) (point))
182   (if (re-search-forward "^-----BEGIN PGP SIGNATURE-----" nil t)
183       (delete-region (match-beginning 0) (point-max)))
184   (goto-char (point-min))
185   (while (re-search-forward "^- " nil t)
186     (replace-match "" t t)
187     (forward-line 1)))
188
189 ;;; mailcrypt wrapper
190
191 (autoload 'mailcrypt-decrypt "mailcrypt")
192 (autoload 'mailcrypt-verify "mailcrypt")
193 (autoload 'mc-pgp-always-sign "mailcrypt")
194 (autoload 'mc-encrypt-generic "mc-toplev")
195 (autoload 'mc-cleanup-recipient-headers "mc-toplev")
196 (autoload 'mc-sign-generic "mc-toplev")
197
198 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
199 (defvar mml2015-verify-function 'mailcrypt-verify)
200
201 (defun mml2015-format-error (err)
202   (if (stringp (cadr err))
203       (cadr err)
204     (format "%S" (cdr err))))
205
206 (defun mml2015-mailcrypt-decrypt (handle ctl)
207   (catch 'error
208     (let (child handles result)
209       (unless (setq child (mm-find-part-by-type
210                            (cdr handle)
211                            "application/octet-stream" nil t))
212         (mm-set-handle-multipart-parameter
213          mm-security-handle 'gnus-info "Corrupted")
214         (throw 'error handle))
215       (with-temp-buffer
216         (mm-insert-part child)
217         (setq result
218               (condition-case err
219                   (funcall mml2015-decrypt-function)
220                 (error
221                  (mm-set-handle-multipart-parameter
222                   mm-security-handle 'gnus-details (mml2015-format-error err))
223                  nil)
224                 (quit
225                  (mm-set-handle-multipart-parameter
226                   mm-security-handle 'gnus-details "Quit.")
227                  nil)))
228         (unless (car result)
229           (mm-set-handle-multipart-parameter
230            mm-security-handle 'gnus-info "Failed")
231           (throw 'error handle))
232         (setq handles (mm-dissect-buffer t)))
233       (mm-destroy-parts handle)
234       (mm-set-handle-multipart-parameter
235        mm-security-handle 'gnus-info
236        (concat "OK"
237                (let ((sig (with-current-buffer mml2015-result-buffer
238                             (mml2015-gpg-extract-signature-details))))
239                  (concat ", Signer: " sig))))
240       (if (listp (car handles))
241           handles
242         (list handles)))))
243
244 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
245   (let* ((result "")
246          (fpr-length (string-width fingerprint))
247          (n-slice 0)
248          slice)
249     (setq fingerprint (string-to-list fingerprint))
250     (while fingerprint
251       (setq fpr-length (- fpr-length 4))
252       (setq slice (butlast fingerprint fpr-length))
253       (setq fingerprint (nthcdr 4 fingerprint))
254       (setq n-slice (1+ n-slice))
255       (setq result
256             (concat
257              result
258              (case n-slice
259                (1  slice)
260                (otherwise (concat " " slice))))))
261     result))
262
263 (defun mml2015-gpg-extract-signature-details ()
264   (goto-char (point-min))
265   (let* ((expired (re-search-forward
266                    "^\\[GNUPG:\\] SIGEXPIRED$"
267                    nil t))
268          (signer (and (re-search-forward
269                        "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
270                        nil t)
271                       (cons (match-string 1) (match-string 2))))
272          (fprint (and (re-search-forward
273                        "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
274                        nil t)
275                       (match-string 1)))
276          (trust  (and (re-search-forward
277                        "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
278                        nil t)
279                       (match-string 1)))
280          (trust-good-enough-p
281           (cdr (assoc trust mml2015-unabbrev-trust-alist))))
282     (cond ((and signer fprint)
283            (concat (cdr signer)
284                    (unless trust-good-enough-p
285                      (concat "\nUntrusted, Fingerprint: "
286                              (mml2015-gpg-pretty-print-fpr fprint)))
287                    (when expired
288                      (format "\nWARNING: Signature from expired key (%s)"
289                              (car signer)))))
290           ((re-search-forward
291             "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
292            (match-string 2))
293           (t
294            "From unknown user"))))
295
296 (defun mml2015-mailcrypt-clear-decrypt ()
297   (let (result)
298     (setq result
299           (condition-case err
300               (funcall mml2015-decrypt-function)
301             (error
302              (mm-set-handle-multipart-parameter
303               mm-security-handle 'gnus-details (mml2015-format-error err))
304              nil)
305             (quit
306              (mm-set-handle-multipart-parameter
307               mm-security-handle 'gnus-details "Quit.")
308              nil)))
309     (if (car result)
310         (mm-set-handle-multipart-parameter
311          mm-security-handle 'gnus-info "OK")
312       (mm-set-handle-multipart-parameter
313        mm-security-handle 'gnus-info "Failed"))))
314
315 (defun mml2015-fix-micalg (alg)
316   (and alg
317        ;; Mutt/1.2.5i has seen sending micalg=php-sha1
318        (upcase (if (string-match "^p[gh]p-" alg)
319                    (substring alg (match-end 0))
320                  alg))))
321
322 (defun mml2015-mailcrypt-verify (handle ctl)
323   (catch 'error
324     (let (part)
325       (unless (setq part (mm-find-raw-part-by-type
326                           ctl (or (mm-handle-multipart-ctl-parameter
327                                    ctl 'protocol)
328                                   "application/pgp-signature")
329                           t))
330         (mm-set-handle-multipart-parameter
331          mm-security-handle 'gnus-info "Corrupted")
332         (throw 'error handle))
333       (with-temp-buffer
334         (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
335         (insert (format "Hash: %s\n\n"
336                         (or (mml2015-fix-micalg
337                              (mm-handle-multipart-ctl-parameter
338                               ctl 'micalg))
339                             "SHA1")))
340         (save-restriction
341           (narrow-to-region (point) (point))
342           (insert part "\n")
343           (goto-char (point-min))
344           (while (not (eobp))
345             (if (looking-at "^-")
346                 (insert "- "))
347             (forward-line)))
348         (unless (setq part (mm-find-part-by-type
349                             (cdr handle) "application/pgp-signature" nil t))
350           (mm-set-handle-multipart-parameter
351            mm-security-handle 'gnus-info "Corrupted")
352           (throw 'error handle))
353         (save-restriction
354           (narrow-to-region (point) (point))
355           (mm-insert-part part)
356           (goto-char (point-min))
357           (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
358               (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
359           (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
360               (replace-match "-----END PGP SIGNATURE-----" t t)))
361         (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
362           (unless (condition-case err
363                       (prog1
364                           (funcall mml2015-verify-function)
365                         (if (get-buffer " *mailcrypt stderr temp")
366                             (mm-set-handle-multipart-parameter
367                              mm-security-handle 'gnus-details
368                              (with-current-buffer " *mailcrypt stderr temp"
369                                (buffer-string))))
370                         (if (get-buffer " *mailcrypt stdout temp")
371                             (kill-buffer " *mailcrypt stdout temp"))
372                         (if (get-buffer " *mailcrypt stderr temp")
373                             (kill-buffer " *mailcrypt stderr temp"))
374                         (if (get-buffer " *mailcrypt status temp")
375                             (kill-buffer " *mailcrypt status temp"))
376                         (if (get-buffer mc-gpg-debug-buffer)
377                             (kill-buffer mc-gpg-debug-buffer)))
378                     (error
379                      (mm-set-handle-multipart-parameter
380                       mm-security-handle 'gnus-details (mml2015-format-error err))
381                      nil)
382                     (quit
383                      (mm-set-handle-multipart-parameter
384                       mm-security-handle 'gnus-details "Quit.")
385                      nil))
386             (mm-set-handle-multipart-parameter
387              mm-security-handle 'gnus-info "Failed")
388             (throw 'error handle))))
389       (mm-set-handle-multipart-parameter
390        mm-security-handle 'gnus-info "OK")
391       handle)))
392
393 (defun mml2015-mailcrypt-clear-verify ()
394   (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
395     (if (condition-case err
396             (prog1
397                 (funcall mml2015-verify-function)
398               (if (get-buffer " *mailcrypt stderr temp")
399                   (mm-set-handle-multipart-parameter
400                    mm-security-handle 'gnus-details
401                    (with-current-buffer " *mailcrypt stderr temp"
402                      (buffer-string))))
403               (if (get-buffer " *mailcrypt stdout temp")
404                   (kill-buffer " *mailcrypt stdout temp"))
405               (if (get-buffer " *mailcrypt stderr temp")
406                   (kill-buffer " *mailcrypt stderr temp"))
407               (if (get-buffer " *mailcrypt status temp")
408                   (kill-buffer " *mailcrypt status temp"))
409               (if (get-buffer mc-gpg-debug-buffer)
410                   (kill-buffer mc-gpg-debug-buffer)))
411           (error
412            (mm-set-handle-multipart-parameter
413             mm-security-handle 'gnus-details (mml2015-format-error err))
414            nil)
415           (quit
416            (mm-set-handle-multipart-parameter
417             mm-security-handle 'gnus-details "Quit.")
418            nil))
419         (mm-set-handle-multipart-parameter
420          mm-security-handle 'gnus-info "OK")
421       (mm-set-handle-multipart-parameter
422        mm-security-handle 'gnus-info "Failed")))
423   (mml2015-extract-cleartext-signature))
424
425 (defun mml2015-mailcrypt-sign (cont)
426   (mc-sign-generic (message-options-get 'message-sender)
427                    nil nil nil nil)
428   (let ((boundary (mml-compute-boundary cont))
429         hash point)
430     (goto-char (point-min))
431     (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
432       (error "Cannot find signed begin line"))
433     (goto-char (match-beginning 0))
434     (forward-line 1)
435     (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
436       (error "Cannot not find PGP hash"))
437     (setq hash (match-string 1))
438     (unless (re-search-forward "^$" nil t)
439       (error "Cannot not find PGP message"))
440     (forward-line 1)
441     (delete-region (point-min) (point))
442     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
443                     boundary))
444     (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
445                     (downcase hash)))
446     (insert (format "\n--%s\n" boundary))
447     (setq point (point))
448     (goto-char (point-max))
449     (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
450       (error "Cannot find signature part"))
451     (replace-match "-----END PGP MESSAGE-----" t t)
452     (goto-char (match-beginning 0))
453     (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
454                                 nil t)
455       (error "Cannot find signature part"))
456     (replace-match "-----BEGIN PGP MESSAGE-----" t t)
457     (goto-char (match-beginning 0))
458     (save-restriction
459       (narrow-to-region point (point))
460       (goto-char point)
461       (while (re-search-forward "^- -" nil t)
462         (replace-match "-" t t))
463       (goto-char (point-max)))
464     (insert (format "--%s\n" boundary))
465     (insert "Content-Type: application/pgp-signature\n\n")
466     (goto-char (point-max))
467     (insert (format "--%s--\n" boundary))
468     (goto-char (point-max))))
469
470 ;; We require mm-decode, which requires mm-bodies, which autoloads
471 ;; message-options-get (!).
472 (declare-function message-options-set "message" (symbol value))
473
474 (defun mml2015-mailcrypt-encrypt (cont &optional sign)
475   (let ((mc-pgp-always-sign
476          (or mc-pgp-always-sign
477              sign
478              (eq t (or (message-options-get 'message-sign-encrypt)
479                        (message-options-set
480                         'message-sign-encrypt
481                         (or (y-or-n-p "Sign the message? ")
482                             'not))))
483              'never)))
484     (mm-with-unibyte-current-buffer
485       (mc-encrypt-generic
486        (or (message-options-get 'message-recipients)
487            (message-options-set 'message-recipients
488                               (mc-cleanup-recipient-headers
489                                (read-string "Recipients: "))))
490        nil nil nil
491        (message-options-get 'message-sender))))
492   (goto-char (point-min))
493   (unless (looking-at "-----BEGIN PGP MESSAGE-----")
494     (error "Fail to encrypt the message"))
495   (let ((boundary (mml-compute-boundary cont)))
496     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
497                     boundary))
498     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
499     (insert (format "--%s\n" boundary))
500     (insert "Content-Type: application/pgp-encrypted\n\n")
501     (insert "Version: 1\n\n")
502     (insert (format "--%s\n" boundary))
503     (insert "Content-Type: application/octet-stream\n\n")
504     (goto-char (point-max))
505     (insert (format "--%s--\n" boundary))
506     (goto-char (point-max))))
507
508 ;;; pgg wrapper
509
510 (defvar pgg-default-user-id)
511 (defvar pgg-errors-buffer)
512 (defvar pgg-output-buffer)
513
514 (autoload 'pgg-decrypt-region "pgg")
515 (autoload 'pgg-verify-region "pgg")
516 (autoload 'pgg-sign-region "pgg")
517 (autoload 'pgg-encrypt-region "pgg")
518 (autoload 'pgg-parse-armor "pgg-parse")
519
520 (defun mml2015-pgg-decrypt (handle ctl)
521   (catch 'error
522     (let ((pgg-errors-buffer mml2015-result-buffer)
523           child handles result decrypt-status)
524       (unless (setq child (mm-find-part-by-type
525                            (cdr handle)
526                            "application/octet-stream" nil t))
527         (mm-set-handle-multipart-parameter
528          mm-security-handle 'gnus-info "Corrupted")
529         (throw 'error handle))
530       (with-temp-buffer
531         (mm-insert-part child)
532         (if (condition-case err
533                 (prog1
534                     (pgg-decrypt-region (point-min) (point-max))
535                   (setq decrypt-status
536                         (with-current-buffer mml2015-result-buffer
537                           (buffer-string)))
538                   (mm-set-handle-multipart-parameter
539                    mm-security-handle 'gnus-details
540                    decrypt-status))
541               (error
542                (mm-set-handle-multipart-parameter
543                 mm-security-handle 'gnus-details (mml2015-format-error err))
544                nil)
545               (quit
546                (mm-set-handle-multipart-parameter
547                 mm-security-handle 'gnus-details "Quit.")
548                nil))
549             (with-current-buffer pgg-output-buffer
550               (goto-char (point-min))
551               (while (search-forward "\r\n" nil t)
552                 (replace-match "\n" t t))
553               (setq handles (mm-dissect-buffer t))
554               (mm-destroy-parts handle)
555               (mm-set-handle-multipart-parameter
556                mm-security-handle 'gnus-info "OK")
557               (mm-set-handle-multipart-parameter
558                mm-security-handle 'gnus-details
559                (concat decrypt-status
560                        (when (stringp (car handles))
561                          "\n" (mm-handle-multipart-ctl-parameter
562                                handles 'gnus-details))))
563               (if (listp (car handles))
564                   handles
565                 (list handles)))
566           (mm-set-handle-multipart-parameter
567            mm-security-handle 'gnus-info "Failed")
568           (throw 'error handle))))))
569
570 (defun mml2015-pgg-clear-decrypt ()
571   (let ((pgg-errors-buffer mml2015-result-buffer))
572     (if (prog1
573             (pgg-decrypt-region (point-min) (point-max))
574           (mm-set-handle-multipart-parameter
575            mm-security-handle 'gnus-details
576            (with-current-buffer mml2015-result-buffer
577              (buffer-string))))
578         (progn
579           (erase-buffer)
580           ;; Treat data which pgg returns as a unibyte string.
581           (mm-disable-multibyte)
582           (insert-buffer-substring pgg-output-buffer)
583           (goto-char (point-min))
584           (while (search-forward "\r\n" nil t)
585             (replace-match "\n" t t))
586           (mm-set-handle-multipart-parameter
587            mm-security-handle 'gnus-info "OK"))
588       (mm-set-handle-multipart-parameter
589        mm-security-handle 'gnus-info "Failed"))))
590
591 (defun mml2015-pgg-verify (handle ctl)
592   (let ((pgg-errors-buffer mml2015-result-buffer)
593         signature-file part signature)
594     (if (or (null (setq part (mm-find-raw-part-by-type
595                               ctl (or (mm-handle-multipart-ctl-parameter
596                                        ctl 'protocol)
597                                       "application/pgp-signature")
598                               t)))
599             (null (setq signature (mm-find-part-by-type
600                                    (cdr handle) "application/pgp-signature" nil t))))
601         (progn
602           (mm-set-handle-multipart-parameter
603            mm-security-handle 'gnus-info "Corrupted")
604           handle)
605       (with-temp-buffer
606         (insert part)
607         ;; Convert <LF> to <CR><LF> in signed text.  If --textmode is
608         ;; specified when signing, the conversion is not necessary.
609         (goto-char (point-min))
610         (end-of-line)
611         (while (not (eobp))
612           (unless (eq (char-before) ?\r)
613             (insert "\r"))
614           (forward-line)
615           (end-of-line))
616         (with-temp-file (setq signature-file (mm-make-temp-file "pgg"))
617           (mm-insert-part signature))
618         (if (condition-case err
619                 (prog1
620                     (pgg-verify-region (point-min) (point-max)
621                                        signature-file t)
622                   (goto-char (point-min))
623                   (while (search-forward "\r\n" nil t)
624                     (replace-match "\n" t t))
625                   (mm-set-handle-multipart-parameter
626                    mm-security-handle 'gnus-details
627                    (concat (with-current-buffer pgg-output-buffer
628                              (buffer-string))
629                            (with-current-buffer pgg-errors-buffer
630                              (buffer-string)))))
631               (error
632                (mm-set-handle-multipart-parameter
633                 mm-security-handle 'gnus-details (mml2015-format-error err))
634                nil)
635               (quit
636                (mm-set-handle-multipart-parameter
637                 mm-security-handle 'gnus-details "Quit.")
638                nil))
639             (progn
640               (delete-file signature-file)
641               (mm-set-handle-multipart-parameter
642                mm-security-handle 'gnus-info
643                (with-current-buffer pgg-errors-buffer
644                  (mml2015-gpg-extract-signature-details))))
645           (delete-file signature-file)
646           (mm-set-handle-multipart-parameter
647            mm-security-handle 'gnus-info "Failed")))))
648   handle)
649
650 (defun mml2015-pgg-clear-verify ()
651   (let ((pgg-errors-buffer mml2015-result-buffer)
652         (text (buffer-string))
653         (coding-system buffer-file-coding-system))
654     (if (condition-case err
655             (prog1
656                 (mm-with-unibyte-buffer
657                   (insert (mm-encode-coding-string text coding-system))
658                   (pgg-verify-region (point-min) (point-max) nil t))
659               (goto-char (point-min))
660               (while (search-forward "\r\n" nil t)
661                 (replace-match "\n" t t))
662               (mm-set-handle-multipart-parameter
663                mm-security-handle 'gnus-details
664                (concat (with-current-buffer pgg-output-buffer
665                          (buffer-string))
666                        (with-current-buffer pgg-errors-buffer
667                          (buffer-string)))))
668           (error
669            (mm-set-handle-multipart-parameter
670             mm-security-handle 'gnus-details (mml2015-format-error err))
671            nil)
672           (quit
673            (mm-set-handle-multipart-parameter
674             mm-security-handle 'gnus-details "Quit.")
675            nil))
676         (mm-set-handle-multipart-parameter
677          mm-security-handle 'gnus-info
678          (with-current-buffer pgg-errors-buffer
679            (mml2015-gpg-extract-signature-details)))
680       (mm-set-handle-multipart-parameter
681        mm-security-handle 'gnus-info "Failed")))
682   (mml2015-extract-cleartext-signature))
683
684 (defun mml2015-pgg-sign (cont)
685   (let ((pgg-errors-buffer mml2015-result-buffer)
686         (boundary (mml-compute-boundary cont))
687         (pgg-default-user-id (or (message-options-get 'mml-sender)
688                                  pgg-default-user-id))
689         (pgg-text-mode t)
690         entry)
691     (unless (pgg-sign-region (point-min) (point-max))
692       (pop-to-buffer mml2015-result-buffer)
693       (error "Sign error"))
694     (goto-char (point-min))
695     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
696                     boundary))
697     (if (setq entry (assq 2 (pgg-parse-armor
698                              (with-current-buffer pgg-output-buffer
699                                (buffer-string)))))
700         (setq entry (assq 'hash-algorithm (cdr entry))))
701     (insert (format "\tmicalg=%s; "
702                     (if (cdr entry)
703                         (downcase (format "pgp-%s" (cdr entry)))
704                       "pgp-sha1")))
705     (insert "protocol=\"application/pgp-signature\"\n")
706     (insert (format "\n--%s\n" boundary))
707     (goto-char (point-max))
708     (insert (format "\n--%s\n" boundary))
709     (insert "Content-Type: application/pgp-signature\n\n")
710     (insert-buffer-substring pgg-output-buffer)
711     (goto-char (point-max))
712     (insert (format "--%s--\n" boundary))
713     (goto-char (point-max))))
714
715 (defun mml2015-pgg-encrypt (cont &optional sign)
716   (let ((pgg-errors-buffer mml2015-result-buffer)
717         (pgg-text-mode t)
718         (boundary (mml-compute-boundary cont)))
719     (unless (pgg-encrypt-region (point-min) (point-max)
720                                 (split-string
721                                  (or
722                                   (message-options-get 'message-recipients)
723                                   (message-options-set 'message-recipients
724                                                        (read-string "Recipients: ")))
725                                  "[ \f\t\n\r\v,]+")
726                                 sign)
727       (pop-to-buffer mml2015-result-buffer)
728       (error "Encrypt error"))
729     (delete-region (point-min) (point-max))
730     (goto-char (point-min))
731     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
732                     boundary))
733     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
734     (insert (format "--%s\n" boundary))
735     (insert "Content-Type: application/pgp-encrypted\n\n")
736     (insert "Version: 1\n\n")
737     (insert (format "--%s\n" boundary))
738     (insert "Content-Type: application/octet-stream\n\n")
739     (insert-buffer-substring pgg-output-buffer)
740     (goto-char (point-max))
741     (insert (format "--%s--\n" boundary))
742     (goto-char (point-max))))
743
744 ;;; epg wrapper
745
746 (defvar epg-user-id-alist)
747 (defvar epg-digest-algorithm-alist)
748 (defvar epg-gpg-program)
749 (defvar inhibit-redisplay)
750
751 (autoload 'epg-make-context "epg")
752 (autoload 'epg-context-set-armor "epg")
753 (autoload 'epg-context-set-textmode "epg")
754 (autoload 'epg-context-set-signers "epg")
755 (autoload 'epg-context-result-for "epg")
756 (autoload 'epg-new-signature-digest-algorithm "epg")
757 (autoload 'epg-list-keys "epg")
758 (autoload 'epg-decrypt-string "epg")
759 (autoload 'epg-verify-string "epg")
760 (autoload 'epg-sign-string "epg")
761 (autoload 'epg-encrypt-string "epg")
762 (autoload 'epg-passphrase-callback-function "epg")
763 (autoload 'epg-context-set-passphrase-callback "epg")
764 (autoload 'epg-key-sub-key-list "epg")
765 (autoload 'epg-sub-key-capability "epg")
766 (autoload 'epg-sub-key-validity "epg")
767 (autoload 'epg-sub-key-fingerprint "epg")
768 (autoload 'epg-signature-key-id "epg")
769 (autoload 'epg-signature-to-string "epg")
770 (autoload 'epg-key-user-id-list "epg")
771 (autoload 'epg-user-id-string "epg")
772 (autoload 'epg-user-id-validity "epg")
773 (autoload 'epg-configuration "epg-config")
774 (autoload 'epg-expand-group "epg-config")
775 (autoload 'epa-select-keys "epa")
776
777 (defvar mml2015-epg-secret-key-id-list nil)
778
779 (defun mml2015-epg-passphrase-callback (context key-id ignore)
780   (if (eq key-id 'SYM)
781       (epg-passphrase-callback-function context key-id nil)
782     (let* ((password-cache-key-id
783             (if (eq key-id 'PIN)
784                 "PIN"
785                key-id))
786            entry
787            (passphrase
788             (password-read
789              (if (eq key-id 'PIN)
790                  "Passphrase for PIN: "
791                (if (setq entry (assoc key-id epg-user-id-alist))
792                    (format "Passphrase for %s %s: " key-id (cdr entry))
793                  (format "Passphrase for %s: " key-id)))
794              password-cache-key-id)))
795       (when passphrase
796         (let ((password-cache-expiry mml2015-passphrase-cache-expiry))
797           (password-cache-add password-cache-key-id passphrase))
798         (setq mml2015-epg-secret-key-id-list
799               (cons password-cache-key-id mml2015-epg-secret-key-id-list))
800         (copy-sequence passphrase)))))
801
802 (defun mml2015-epg-check-user-id (key recipient)
803   (let ((pointer (epg-key-user-id-list key))
804         result)
805     (while pointer
806       (if (and (equal (car (mail-header-parse-address
807                             (epg-user-id-string (car pointer))))
808                       (car (mail-header-parse-address
809                             recipient)))
810                (not (memq (epg-user-id-validity (car pointer))
811                           '(revoked expired))))
812           (setq result t
813                 pointer nil)
814         (setq pointer (cdr pointer))))
815     result))
816
817 (defun mml2015-epg-check-sub-key (key usage)
818   (let ((pointer (epg-key-sub-key-list key))
819         result)
820     ;; The primary key will be marked as disabled, when the entire
821     ;; key is disabled (see 12 Field, Format of colon listings, in
822     ;; gnupg/doc/DETAILS)
823     (unless (memq 'disabled (epg-sub-key-capability (car pointer)))
824       (while pointer
825         (if (and (memq usage (epg-sub-key-capability (car pointer)))
826                  (not (memq (epg-sub-key-validity (car pointer))
827                             '(revoked expired))))
828             (setq result t
829                   pointer nil)
830           (setq pointer (cdr pointer)))))
831     result))
832
833 (defun mml2015-epg-find-usable-key (context name usage
834                                             &optional name-is-key-id)
835   (let ((keys (epg-list-keys context name))
836         key)
837     (while keys
838       (if (and (or name-is-key-id
839                    ;; Non email user-id can be supplied through
840                    ;; mml2015-signers if mml2015-encrypt-to-self is set.
841                    ;; Treat it as valid, as it is user's intention.
842                    (not (string-match "\\`<" name))
843                    (mml2015-epg-check-user-id (car keys) name))
844                (mml2015-epg-check-sub-key (car keys) usage))
845           (setq key (car keys)
846                 keys nil)
847         (setq keys (cdr keys))))
848     key))
849
850 ;; XXX: since gpg --list-secret-keys does not return validity of each
851 ;; key, `mml2015-epg-find-usable-key' defined above is not enough for
852 ;; secret keys.  The function `mml2015-epg-find-usable-secret-key'
853 ;; below looks at appropriate public keys to check usability.
854 (defun mml2015-epg-find-usable-secret-key (context name usage)
855   (let ((secret-keys (epg-list-keys context name t))
856         secret-key)
857     (while (and (not secret-key) secret-keys)
858       (if (mml2015-epg-find-usable-key
859            context
860            (epg-sub-key-fingerprint
861             (car (epg-key-sub-key-list
862                   (car secret-keys))))
863            usage
864            t)
865           (setq secret-key (car secret-keys)
866                 secret-keys nil)
867         (setq secret-keys (cdr secret-keys))))
868     secret-key))
869
870 (autoload 'gnus-create-image "gnus-ems")
871
872 (defun mml2015-epg-key-image (key-id)
873   "Return the image of a key, if any"
874   (with-temp-buffer
875     (mm-set-buffer-multibyte nil)
876     (let* ((coding-system-for-write 'binary)
877            (coding-system-for-read 'binary)
878            (data (shell-command-to-string
879                   (format "%s --list-options no-show-photos --attribute-fd 3 --list-keys %s 3>&1 >/dev/null 2>&1"
880                           (shell-quote-argument epg-gpg-program) key-id))))
881       (when (> (length data) 0)
882         (insert (substring data 16))
883         (condition-case nil
884             (gnus-create-image (buffer-string) nil t)
885           (error))))))
886
887 (autoload 'gnus-rescale-image "gnus-util")
888
889 (defun mml2015-epg-key-image-to-string (key-id)
890   "Return a string with the image of a key, if any"
891   (let ((key-image (mml2015-epg-key-image key-id)))
892     (if (not key-image)
893         ""
894       (condition-case error
895           (let ((result "  "))
896             (put-text-property
897              1 2 'display
898              (gnus-rescale-image key-image
899                                  (cons mml2015-maximum-key-image-dimension
900                                        mml2015-maximum-key-image-dimension))
901              result)
902             result)
903         (error "")))))
904
905 (defun mml2015-epg-signature-to-string (signature)
906   (concat (epg-signature-to-string signature)
907           (when mml2015-display-key-image
908             (mml2015-epg-key-image-to-string (epg-signature-key-id signature)))))
909
910 (defun mml2015-epg-verify-result-to-string (verify-result)
911   (mapconcat #'mml2015-epg-signature-to-string verify-result "\n"))
912
913 (defun mml2015-epg-decrypt (handle ctl)
914   (catch 'error
915     (let ((inhibit-redisplay t)
916           context plain child handles result decrypt-status)
917       (unless (setq child (mm-find-part-by-type
918                            (cdr handle)
919                            "application/octet-stream" nil t))
920         (mm-set-handle-multipart-parameter
921          mm-security-handle 'gnus-info "Corrupted")
922         (throw 'error handle))
923       (setq context (epg-make-context))
924       (if mml2015-cache-passphrase
925           (epg-context-set-passphrase-callback
926            context
927            #'mml2015-epg-passphrase-callback))
928       (condition-case error
929           (setq plain (epg-decrypt-string context (mm-get-part child))
930                 mml2015-epg-secret-key-id-list nil)
931         (error
932          (while mml2015-epg-secret-key-id-list
933            (password-cache-remove (car mml2015-epg-secret-key-id-list))
934            (setq mml2015-epg-secret-key-id-list
935                  (cdr mml2015-epg-secret-key-id-list)))
936          (mm-set-handle-multipart-parameter
937           mm-security-handle 'gnus-info "Failed")
938          (if (eq (car error) 'quit)
939              (mm-set-handle-multipart-parameter
940               mm-security-handle 'gnus-details "Quit.")
941            (mm-set-handle-multipart-parameter
942             mm-security-handle 'gnus-details (mml2015-format-error error)))
943          (throw 'error handle)))
944       (with-temp-buffer
945         (insert plain)
946         (goto-char (point-min))
947         (while (search-forward "\r\n" nil t)
948           (replace-match "\n" t t))
949         (setq handles (mm-dissect-buffer t))
950         (mm-destroy-parts handle)
951         (if (epg-context-result-for context 'verify)
952             (mm-set-handle-multipart-parameter
953              mm-security-handle 'gnus-info
954              (concat "OK\n"
955                      (mml2015-epg-verify-result-to-string
956                       (epg-context-result-for context 'verify))))
957           (mm-set-handle-multipart-parameter
958            mm-security-handle 'gnus-info "OK"))
959         (if (stringp (car handles))
960             (mm-set-handle-multipart-parameter
961              mm-security-handle 'gnus-details
962              (mm-handle-multipart-ctl-parameter handles 'gnus-details))))
963         (if (listp (car handles))
964             handles
965           (list handles)))))
966
967 (defun mml2015-epg-clear-decrypt ()
968   (let ((inhibit-redisplay t)
969         (context (epg-make-context))
970         plain)
971     (if mml2015-cache-passphrase
972         (epg-context-set-passphrase-callback
973          context
974          #'mml2015-epg-passphrase-callback))
975     (condition-case error
976         (setq plain (epg-decrypt-string context (buffer-string))
977               mml2015-epg-secret-key-id-list nil)
978       (error
979        (while mml2015-epg-secret-key-id-list
980          (password-cache-remove (car mml2015-epg-secret-key-id-list))
981          (setq mml2015-epg-secret-key-id-list
982                (cdr mml2015-epg-secret-key-id-list)))
983        (mm-set-handle-multipart-parameter
984         mm-security-handle 'gnus-info "Failed")
985        (if (eq (car error) 'quit)
986            (mm-set-handle-multipart-parameter
987             mm-security-handle 'gnus-details "Quit.")
988          (mm-set-handle-multipart-parameter
989           mm-security-handle 'gnus-details (mml2015-format-error error)))))
990     (when plain
991       (erase-buffer)
992       ;; Treat data which epg returns as a unibyte string.
993       (mm-disable-multibyte)
994       (insert plain)
995       (goto-char (point-min))
996       (while (search-forward "\r\n" nil t)
997         (replace-match "\n" t t))
998       (mm-set-handle-multipart-parameter
999        mm-security-handle 'gnus-info "OK")
1000       (if (epg-context-result-for context 'verify)
1001           (mm-set-handle-multipart-parameter
1002            mm-security-handle 'gnus-details
1003            (mml2015-epg-verify-result-to-string
1004             (epg-context-result-for context 'verify)))))))
1005
1006 (defun mml2015-epg-verify (handle ctl)
1007   (catch 'error
1008     (let ((inhibit-redisplay t)
1009           context plain signature-file part signature)
1010       (when (or (null (setq part (mm-find-raw-part-by-type
1011                                   ctl (or (mm-handle-multipart-ctl-parameter
1012                                            ctl 'protocol)
1013                                           "application/pgp-signature")
1014                                   t)))
1015                 (null (setq signature (mm-find-part-by-type
1016                                        (cdr handle) "application/pgp-signature"
1017                                        nil t))))
1018         (mm-set-handle-multipart-parameter
1019          mm-security-handle 'gnus-info "Corrupted")
1020         (throw 'error handle))
1021       (setq part (mm-replace-in-string part "\n" "\r\n")
1022             signature (mm-get-part signature)
1023             context (epg-make-context))
1024       (condition-case error
1025           (setq plain (epg-verify-string context signature part))
1026         (error
1027          (mm-set-handle-multipart-parameter
1028           mm-security-handle 'gnus-info "Failed")
1029          (if (eq (car error) 'quit)
1030              (mm-set-handle-multipart-parameter
1031               mm-security-handle 'gnus-details "Quit.")
1032            (mm-set-handle-multipart-parameter
1033             mm-security-handle 'gnus-details (mml2015-format-error error)))
1034          (throw 'error handle)))
1035       (mm-set-handle-multipart-parameter
1036        mm-security-handle 'gnus-info
1037        (mml2015-epg-verify-result-to-string
1038         (epg-context-result-for context 'verify)))
1039       handle)))
1040
1041 (defun mml2015-epg-clear-verify ()
1042   (let ((inhibit-redisplay t)
1043         (context (epg-make-context))
1044         (signature (mm-encode-coding-string (buffer-string)
1045                                             coding-system-for-write))
1046         plain)
1047     (condition-case error
1048         (setq plain (epg-verify-string context signature))
1049       (error
1050        (mm-set-handle-multipart-parameter
1051         mm-security-handle 'gnus-info "Failed")
1052        (if (eq (car error) 'quit)
1053            (mm-set-handle-multipart-parameter
1054             mm-security-handle 'gnus-details "Quit.")
1055          (mm-set-handle-multipart-parameter
1056           mm-security-handle 'gnus-details (mml2015-format-error error)))))
1057     (if plain
1058         (progn
1059           (mm-set-handle-multipart-parameter
1060            mm-security-handle 'gnus-info
1061            (mml2015-epg-verify-result-to-string
1062             (epg-context-result-for context 'verify)))
1063           (delete-region (point-min) (point-max))
1064           (insert (mm-decode-coding-string plain coding-system-for-read)))
1065       (mml2015-extract-cleartext-signature))))
1066
1067 (defun mml2015-epg-sign (cont)
1068   (let* ((inhibit-redisplay t)
1069          (context (epg-make-context))
1070          (boundary (mml-compute-boundary cont))
1071          (sender (message-options-get 'message-sender))
1072          (signer-names (or mml2015-signers
1073                            (if (and mml2015-sign-with-sender sender)
1074                                (list (concat "<" sender ">")))))
1075          signer-key
1076          (signers
1077           (or (message-options-get 'mml2015-epg-signers)
1078               (message-options-set
1079                'mml2015-epg-signers
1080                (if (eq mm-sign-option 'guided)
1081                    (epa-select-keys context "\
1082 Select keys for signing.
1083 If no one is selected, default secret key is used.  "
1084                                     signer-names
1085                                     t)
1086                  (if (or sender mml2015-signers)
1087                      (delq nil
1088                            (mapcar
1089                             (lambda (signer)
1090                               (setq signer-key
1091                                     (mml2015-epg-find-usable-secret-key
1092                                      context signer 'sign))
1093                               (unless (or signer-key
1094                                           (y-or-n-p
1095                                            (format
1096                                             "No secret key for %s; skip it? "
1097                                             signer)))
1098                                 (error "No secret key for %s" signer))
1099                               signer-key)
1100                             signer-names)))))))
1101          signature micalg)
1102     (epg-context-set-armor context t)
1103     (epg-context-set-textmode context t)
1104     (epg-context-set-signers context signers)
1105     (if mml2015-cache-passphrase
1106         (epg-context-set-passphrase-callback
1107          context
1108          #'mml2015-epg-passphrase-callback))
1109     ;; Signed data must end with a newline (RFC 3156, 5).
1110     (goto-char (point-max))
1111     (unless (bolp)
1112       (insert "\n"))
1113     (condition-case error
1114         (setq signature (epg-sign-string context (buffer-string) t)
1115               mml2015-epg-secret-key-id-list nil)
1116       (error
1117        (while mml2015-epg-secret-key-id-list
1118          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1119          (setq mml2015-epg-secret-key-id-list
1120                (cdr mml2015-epg-secret-key-id-list)))
1121        (signal (car error) (cdr error))))
1122     (if (epg-context-result-for context 'sign)
1123         (setq micalg (epg-new-signature-digest-algorithm
1124                       (car (epg-context-result-for context 'sign)))))
1125     (goto-char (point-min))
1126     (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
1127                     boundary))
1128     (if micalg
1129         (insert (format "\tmicalg=pgp-%s; "
1130                         (downcase
1131                          (cdr (assq micalg
1132                                     epg-digest-algorithm-alist))))))
1133     (insert "protocol=\"application/pgp-signature\"\n")
1134     (insert (format "\n--%s\n" boundary))
1135     (goto-char (point-max))
1136     (insert (format "\n--%s\n" boundary))
1137     (insert "Content-Type: application/pgp-signature; name=\"signature.asc\"\n\n")
1138     (insert signature)
1139     (goto-char (point-max))
1140     (insert (format "--%s--\n" boundary))
1141     (goto-char (point-max))))
1142
1143 (defun mml2015-epg-encrypt (cont &optional sign)
1144   (let* ((inhibit-redisplay t)
1145          (context (epg-make-context))
1146          (boundary (mml-compute-boundary cont))
1147          (config (epg-configuration))
1148          (recipients (message-options-get 'mml2015-epg-recipients))
1149          cipher
1150          (sender (message-options-get 'message-sender))
1151          (signer-names (or mml2015-signers
1152                            (if (and mml2015-sign-with-sender sender)
1153                                (list (concat "<" sender ">")))))
1154          signers
1155          recipient-key signer-key)
1156     (unless recipients
1157       (setq recipients
1158             (apply #'nconc
1159                    (mapcar
1160                     (lambda (recipient)
1161                       (or (epg-expand-group config recipient)
1162                           (list (concat "<" recipient ">"))))
1163                     (split-string
1164                      (or (message-options-get 'message-recipients)
1165                          (message-options-set 'message-recipients
1166                                               (read-string "Recipients: ")))
1167                      "[ \f\t\n\r\v,]+"))))
1168       (when mml2015-encrypt-to-self
1169         (unless signer-names
1170           (error "Neither message sender nor mml2015-signers are set"))
1171         (setq recipients (nconc recipients signer-names)))
1172       (if (eq mm-encrypt-option 'guided)
1173           (setq recipients
1174                 (epa-select-keys context "\
1175 Select recipients for encryption.
1176 If no one is selected, symmetric encryption will be performed.  "
1177                                  recipients))
1178         (setq recipients
1179               (delq nil
1180                     (mapcar
1181                      (lambda (recipient)
1182                        (setq recipient-key (mml2015-epg-find-usable-key
1183                                             context recipient 'encrypt))
1184                        (unless (or recipient-key
1185                                    (y-or-n-p
1186                                     (format "No public key for %s; skip it? "
1187                                             recipient)))
1188                          (error "No public key for %s" recipient))
1189                        recipient-key)
1190                      recipients)))
1191         (unless recipients
1192           (error "No recipient specified")))
1193       (message-options-set 'mml2015-epg-recipients recipients))
1194     (when sign
1195       (setq signers
1196             (or (message-options-get 'mml2015-epg-signers)
1197                 (message-options-set
1198                  'mml2015-epg-signers
1199                  (if (eq mm-sign-option 'guided)
1200                      (epa-select-keys context "\
1201 Select keys for signing.
1202 If no one is selected, default secret key is used.  "
1203                                       signer-names
1204                                       t)
1205                    (if (or sender mml2015-signers)
1206                        (delq nil
1207                              (mapcar
1208                               (lambda (signer)
1209                                 (setq signer-key
1210                                       (mml2015-epg-find-usable-secret-key
1211                                        context signer 'sign))
1212                                 (unless (or signer-key
1213                                             (y-or-n-p
1214                                              (format
1215                                               "No secret key for %s; skip it? "
1216                                               signer)))
1217                                   (error "No secret key for %s" signer))
1218                                 signer-key)
1219                               signer-names)))))))
1220       (epg-context-set-signers context signers))
1221     (epg-context-set-armor context t)
1222     (epg-context-set-textmode context t)
1223     (if mml2015-cache-passphrase
1224         (epg-context-set-passphrase-callback
1225          context
1226          #'mml2015-epg-passphrase-callback))
1227     (condition-case error
1228         (setq cipher
1229               (epg-encrypt-string context (buffer-string) recipients sign
1230                                   mml2015-always-trust)
1231               mml2015-epg-secret-key-id-list nil)
1232       (error
1233        (while mml2015-epg-secret-key-id-list
1234          (password-cache-remove (car mml2015-epg-secret-key-id-list))
1235          (setq mml2015-epg-secret-key-id-list
1236                (cdr mml2015-epg-secret-key-id-list)))
1237        (signal (car error) (cdr error))))
1238     (delete-region (point-min) (point-max))
1239     (goto-char (point-min))
1240     (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
1241                     boundary))
1242     (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
1243     (insert (format "--%s\n" boundary))
1244     (insert "Content-Type: application/pgp-encrypted\n\n")
1245     (insert "Version: 1\n\n")
1246     (insert (format "--%s\n" boundary))
1247     (insert "Content-Type: application/octet-stream\n\n")
1248     (insert cipher)
1249     (goto-char (point-max))
1250     (insert (format "--%s--\n" boundary))
1251     (goto-char (point-max))))
1252
1253 ;;; General wrapper
1254
1255 (autoload 'gnus-buffer-live-p "gnus-util")
1256 (autoload 'gnus-get-buffer-create "gnus")
1257
1258 (defun mml2015-clean-buffer ()
1259   (if (gnus-buffer-live-p mml2015-result-buffer)
1260       (with-current-buffer mml2015-result-buffer
1261         (erase-buffer)
1262         t)
1263     (setq mml2015-result-buffer
1264           (gnus-get-buffer-create " *MML2015 Result*"))
1265     nil))
1266
1267 (defsubst mml2015-clear-decrypt-function ()
1268   (nth 6 (assq mml2015-use mml2015-function-alist)))
1269
1270 (defsubst mml2015-clear-verify-function ()
1271   (nth 5 (assq mml2015-use mml2015-function-alist)))
1272
1273 ;;;###autoload
1274 (defun mml2015-decrypt (handle ctl)
1275   (mml2015-clean-buffer)
1276   (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
1277     (if func
1278         (funcall func handle ctl)
1279       handle)))
1280
1281 ;;;###autoload
1282 (defun mml2015-decrypt-test (handle ctl)
1283   mml2015-use)
1284
1285 ;;;###autoload
1286 (defun mml2015-verify (handle ctl)
1287   (mml2015-clean-buffer)
1288   (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
1289     (if func
1290         (funcall func handle ctl)
1291       handle)))
1292
1293 ;;;###autoload
1294 (defun mml2015-verify-test (handle ctl)
1295   mml2015-use)
1296
1297 ;;;###autoload
1298 (defun mml2015-encrypt (cont &optional sign)
1299   (mml2015-clean-buffer)
1300   (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
1301     (if func
1302         (funcall func cont sign)
1303       (error "Cannot find encrypt function"))))
1304
1305 ;;;###autoload
1306 (defun mml2015-sign (cont)
1307   (mml2015-clean-buffer)
1308   (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
1309     (if func
1310         (funcall func cont)
1311       (error "Cannot find sign function"))))
1312
1313 ;;;###autoload
1314 (defun mml2015-self-encrypt ()
1315   (mml2015-encrypt nil))
1316
1317 (provide 'mml2015)
1318
1319 ;;; mml2015.el ends here