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