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