1 ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
3 ;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
5 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
6 ;; Keywords: PGP MIME MML
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;; RFC 2015 is updated by RFC 3156, this file should be compatible
31 ;; For Emacs <22.2 and XEmacs.
32 (unless (fboundp 'declare-function
) (defmacro declare-function
(&rest r
)))
34 (if (locate-library "password-cache")
35 (require 'password-cache
)
38 (eval-when-compile (require 'cl
))
44 (defvar mc-pgp-always-sign
)
46 (declare-function epg-check-configuration
"ext:epg-config"
47 (config &optional minimum-version
))
48 (declare-function epg-configuration
"ext:epg-config" ())
50 (defvar mml2015-use
(or
54 (epg-check-configuration (epg-configuration))
58 (ignore-errors (require 'pgg
))
59 (and (fboundp 'pgg-sign-region
)
63 (and (fboundp 'mc-encrypt-generic
)
64 (fboundp 'mc-sign-generic
)
65 (fboundp 'mc-cleanup-recipient-headers
)
67 "The package used for PGP/MIME.
68 Valid packages include `epg', `pgg' and `mailcrypt'.")
70 ;; Something is not RFC2015.
71 (defvar mml2015-function-alist
72 '((mailcrypt mml2015-mailcrypt-sign
73 mml2015-mailcrypt-encrypt
74 mml2015-mailcrypt-verify
75 mml2015-mailcrypt-decrypt
76 mml2015-mailcrypt-clear-verify
77 mml2015-mailcrypt-clear-decrypt
)
82 mml2015-pgg-clear-verify
83 mml2015-pgg-clear-decrypt
)
88 mml2015-epg-clear-verify
89 mml2015-epg-clear-decrypt
))
90 "Alist of PGP/MIME functions.")
92 (defvar mml2015-result-buffer nil
)
94 (defcustom mml2015-unabbrev-trust-alist
95 '(("TRUST_UNDEFINED" . nil
)
97 ("TRUST_MARGINAL" . t
)
99 ("TRUST_ULTIMATE" . t
))
100 "Map GnuPG trust output values to a boolean saying if you trust the key."
102 :group
'mime-security
103 :type
'(repeat (cons (regexp :tag
"GnuPG output regexp")
104 (boolean :tag
"Trust key"))))
106 (defcustom mml2015-cache-passphrase mml-secure-cache-passphrase
107 "If t, cache passphrase."
108 :group
'mime-security
111 (defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
112 "How many seconds the passphrase is cached.
113 Whether the passphrase is cached at all is controlled by
114 `mml2015-cache-passphrase'."
115 :group
'mime-security
118 (defcustom mml2015-signers nil
119 "A list of your own key ID(s) which will be used to sign a message.
120 If set, it overrides the setting of `mml2015-sign-with-sender'."
121 :group
'mime-security
122 :type
'(repeat (string :tag
"Key ID")))
124 (defcustom mml2015-sign-with-sender nil
125 "If t, use message sender so find a key to sign with."
126 :group
'mime-security
130 (defcustom mml2015-encrypt-to-self nil
131 "If t, add your own key ID to recipient list when encryption."
132 :group
'mime-security
135 (defcustom mml2015-always-trust t
136 "If t, GnuPG skip key validation on encryption."
137 :group
'mime-security
140 ;; Extract plaintext from cleartext signature. IMO, this kind of task
141 ;; should be done by GnuPG rather than Elisp, but older PGP backends
142 ;; (such as Mailcrypt, and PGG) discard the output from GnuPG.
143 (defun mml2015-extract-cleartext-signature ()
145 ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still
146 ;; believe that the right way is to use the plaintext output from GnuPG as
147 ;; it is, and mml2015-extract-cleartext-signature is just a kludge for
148 ;; misdesigned libraries like PGG, which have no ability to do that. So, I
149 ;; think it should not have descriptive documentation.''
151 ;; This function doesn't handle NotDashEscaped correctly. EasyPG handles it
153 ;; http://thread.gmane.org/gmane.emacs.gnus.general/66062/focus=66082
154 ;; http://thread.gmane.org/gmane.emacs.gnus.general/65087/focus=65109
155 (goto-char (point-min))
157 ;; We need to be careful not to strip beyond the armor headers.
158 ;; Previously, an attacker could replace the text inside our
159 ;; markup with trailing garbage by injecting whitespace into the
161 (while (looking-at "Hash:") ; The only header allowed in cleartext
162 (forward-line)) ; signatures according to RFC2440.
163 (when (looking-at "[\t ]*$")
165 (delete-region (point-min) (point))
166 (if (re-search-forward "^-----BEGIN PGP SIGNATURE-----" nil t
)
167 (delete-region (match-beginning 0) (point-max)))
168 (goto-char (point-min))
169 (while (re-search-forward "^- " nil t
)
170 (replace-match "" t t
)
173 ;;; mailcrypt wrapper
175 (autoload 'mailcrypt-decrypt
"mailcrypt")
176 (autoload 'mailcrypt-verify
"mailcrypt")
177 (autoload 'mc-pgp-always-sign
"mailcrypt")
178 (autoload 'mc-encrypt-generic
"mc-toplev")
179 (autoload 'mc-cleanup-recipient-headers
"mc-toplev")
180 (autoload 'mc-sign-generic
"mc-toplev")
182 (defvar mml2015-decrypt-function
'mailcrypt-decrypt
)
183 (defvar mml2015-verify-function
'mailcrypt-verify
)
185 (defun mml2015-format-error (err)
186 (if (stringp (cadr err
))
188 (format "%S" (cdr err
))))
190 (defun mml2015-mailcrypt-decrypt (handle ctl
)
192 (let (child handles result
)
193 (unless (setq child
(mm-find-part-by-type
195 "application/octet-stream" nil t
))
196 (mm-set-handle-multipart-parameter
197 mm-security-handle
'gnus-info
"Corrupted")
198 (throw 'error handle
))
200 (mm-insert-part child
)
203 (funcall mml2015-decrypt-function
)
205 (mm-set-handle-multipart-parameter
206 mm-security-handle
'gnus-details
(mml2015-format-error err
))
209 (mm-set-handle-multipart-parameter
210 mm-security-handle
'gnus-details
"Quit.")
213 (mm-set-handle-multipart-parameter
214 mm-security-handle
'gnus-info
"Failed")
215 (throw 'error handle
))
216 (setq handles
(mm-dissect-buffer t
)))
217 (mm-destroy-parts handle
)
218 (mm-set-handle-multipart-parameter
219 mm-security-handle
'gnus-info
221 (let ((sig (with-current-buffer mml2015-result-buffer
222 (mml2015-gpg-extract-signature-details))))
223 (concat ", Signer: " sig
))))
224 (if (listp (car handles
))
228 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
230 (fpr-length (string-width fingerprint
))
233 (setq fingerprint
(string-to-list fingerprint
))
235 (setq fpr-length
(- fpr-length
4))
236 (setq slice
(butlast fingerprint fpr-length
))
237 (setq fingerprint
(nthcdr 4 fingerprint
))
238 (setq n-slice
(1+ n-slice
))
244 (otherwise (concat " " slice
))))))
247 (defun mml2015-gpg-extract-signature-details ()
248 (goto-char (point-min))
249 (let* ((expired (re-search-forward
250 "^\\[GNUPG:\\] SIGEXPIRED$"
252 (signer (and (re-search-forward
253 "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
255 (cons (match-string 1) (match-string 2))))
256 (fprint (and (re-search-forward
257 "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
260 (trust (and (re-search-forward
261 "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
265 (cdr (assoc trust mml2015-unabbrev-trust-alist
))))
266 (cond ((and signer fprint
)
268 (unless trust-good-enough-p
269 (concat "\nUntrusted, Fingerprint: "
270 (mml2015-gpg-pretty-print-fpr fprint
)))
272 (format "\nWARNING: Signature from expired key (%s)"
275 "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t
)
278 "From unknown user"))))
280 (defun mml2015-mailcrypt-clear-decrypt ()
284 (funcall mml2015-decrypt-function
)
286 (mm-set-handle-multipart-parameter
287 mm-security-handle
'gnus-details
(mml2015-format-error err
))
290 (mm-set-handle-multipart-parameter
291 mm-security-handle
'gnus-details
"Quit.")
294 (mm-set-handle-multipart-parameter
295 mm-security-handle
'gnus-info
"OK")
296 (mm-set-handle-multipart-parameter
297 mm-security-handle
'gnus-info
"Failed"))))
299 (defun mml2015-fix-micalg (alg)
301 ;; Mutt/1.2.5i has seen sending micalg=php-sha1
302 (upcase (if (string-match "^p[gh]p-" alg
)
303 (substring alg
(match-end 0))
306 (defun mml2015-mailcrypt-verify (handle ctl
)
309 (unless (setq part
(mm-find-raw-part-by-type
310 ctl
(or (mm-handle-multipart-ctl-parameter
312 "application/pgp-signature")
314 (mm-set-handle-multipart-parameter
315 mm-security-handle
'gnus-info
"Corrupted")
316 (throw 'error handle
))
318 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
319 (insert (format "Hash: %s\n\n"
320 (or (mml2015-fix-micalg
321 (mm-handle-multipart-ctl-parameter
325 (narrow-to-region (point) (point))
327 (goto-char (point-min))
329 (if (looking-at "^-")
332 (unless (setq part
(mm-find-part-by-type
333 (cdr handle
) "application/pgp-signature" nil t
))
334 (mm-set-handle-multipart-parameter
335 mm-security-handle
'gnus-info
"Corrupted")
336 (throw 'error handle
))
338 (narrow-to-region (point) (point))
339 (mm-insert-part part
)
340 (goto-char (point-min))
341 (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t
)
342 (replace-match "-----BEGIN PGP SIGNATURE-----" t t
))
343 (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t
)
344 (replace-match "-----END PGP SIGNATURE-----" t t
)))
345 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
346 (unless (condition-case err
348 (funcall mml2015-verify-function
)
349 (if (get-buffer " *mailcrypt stderr temp")
350 (mm-set-handle-multipart-parameter
351 mm-security-handle
'gnus-details
352 (with-current-buffer " *mailcrypt stderr temp"
354 (if (get-buffer " *mailcrypt stdout temp")
355 (kill-buffer " *mailcrypt stdout temp"))
356 (if (get-buffer " *mailcrypt stderr temp")
357 (kill-buffer " *mailcrypt stderr temp"))
358 (if (get-buffer " *mailcrypt status temp")
359 (kill-buffer " *mailcrypt status temp"))
360 (if (get-buffer mc-gpg-debug-buffer
)
361 (kill-buffer mc-gpg-debug-buffer
)))
363 (mm-set-handle-multipart-parameter
364 mm-security-handle
'gnus-details
(mml2015-format-error err
))
367 (mm-set-handle-multipart-parameter
368 mm-security-handle
'gnus-details
"Quit.")
370 (mm-set-handle-multipart-parameter
371 mm-security-handle
'gnus-info
"Failed")
372 (throw 'error handle
))))
373 (mm-set-handle-multipart-parameter
374 mm-security-handle
'gnus-info
"OK")
377 (defun mml2015-mailcrypt-clear-verify ()
378 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
379 (if (condition-case err
381 (funcall mml2015-verify-function
)
382 (if (get-buffer " *mailcrypt stderr temp")
383 (mm-set-handle-multipart-parameter
384 mm-security-handle
'gnus-details
385 (with-current-buffer " *mailcrypt stderr temp"
387 (if (get-buffer " *mailcrypt stdout temp")
388 (kill-buffer " *mailcrypt stdout temp"))
389 (if (get-buffer " *mailcrypt stderr temp")
390 (kill-buffer " *mailcrypt stderr temp"))
391 (if (get-buffer " *mailcrypt status temp")
392 (kill-buffer " *mailcrypt status temp"))
393 (if (get-buffer mc-gpg-debug-buffer
)
394 (kill-buffer mc-gpg-debug-buffer
)))
396 (mm-set-handle-multipart-parameter
397 mm-security-handle
'gnus-details
(mml2015-format-error err
))
400 (mm-set-handle-multipart-parameter
401 mm-security-handle
'gnus-details
"Quit.")
403 (mm-set-handle-multipart-parameter
404 mm-security-handle
'gnus-info
"OK")
405 (mm-set-handle-multipart-parameter
406 mm-security-handle
'gnus-info
"Failed")))
407 (mml2015-extract-cleartext-signature))
409 (defun mml2015-mailcrypt-sign (cont)
410 (mc-sign-generic (message-options-get 'message-sender
)
412 (let ((boundary (mml-compute-boundary cont
))
414 (goto-char (point-min))
415 (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t
)
416 (error "Cannot find signed begin line"))
417 (goto-char (match-beginning 0))
419 (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
420 (error "Cannot not find PGP hash"))
421 (setq hash
(match-string 1))
422 (unless (re-search-forward "^$" nil t
)
423 (error "Cannot not find PGP message"))
425 (delete-region (point-min) (point))
426 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
428 (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
430 (insert (format "\n--%s\n" boundary
))
432 (goto-char (point-max))
433 (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t
)
434 (error "Cannot find signature part"))
435 (replace-match "-----END PGP MESSAGE-----" t t
)
436 (goto-char (match-beginning 0))
437 (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
439 (error "Cannot find signature part"))
440 (replace-match "-----BEGIN PGP MESSAGE-----" t t
)
441 (goto-char (match-beginning 0))
443 (narrow-to-region point
(point))
445 (while (re-search-forward "^- -" nil t
)
446 (replace-match "-" t t
))
447 (goto-char (point-max)))
448 (insert (format "--%s\n" boundary
))
449 (insert "Content-Type: application/pgp-signature\n\n")
450 (goto-char (point-max))
451 (insert (format "--%s--\n" boundary
))
452 (goto-char (point-max))))
454 ;; We require mm-decode, which requires mm-bodies, which autoloads
455 ;; message-options-get (!).
456 (declare-function message-options-set
"message" (symbol value
))
458 (defun mml2015-mailcrypt-encrypt (cont &optional sign
)
459 (let ((mc-pgp-always-sign
460 (or mc-pgp-always-sign
462 (eq t
(or (message-options-get 'message-sign-encrypt
)
464 'message-sign-encrypt
465 (or (y-or-n-p "Sign the message? ")
468 (mm-with-unibyte-current-buffer
470 (or (message-options-get 'message-recipients
)
471 (message-options-set 'message-recipients
472 (mc-cleanup-recipient-headers
473 (read-string "Recipients: "))))
475 (message-options-get 'message-sender
))))
476 (goto-char (point-min))
477 (unless (looking-at "-----BEGIN PGP MESSAGE-----")
478 (error "Fail to encrypt the message"))
479 (let ((boundary (mml-compute-boundary cont
)))
480 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
482 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
483 (insert (format "--%s\n" boundary
))
484 (insert "Content-Type: application/pgp-encrypted\n\n")
485 (insert "Version: 1\n\n")
486 (insert (format "--%s\n" boundary
))
487 (insert "Content-Type: application/octet-stream\n\n")
488 (goto-char (point-max))
489 (insert (format "--%s--\n" boundary
))
490 (goto-char (point-max))))
494 (defvar pgg-default-user-id
)
495 (defvar pgg-errors-buffer
)
496 (defvar pgg-output-buffer
)
498 (autoload 'pgg-decrypt-region
"pgg")
499 (autoload 'pgg-verify-region
"pgg")
500 (autoload 'pgg-sign-region
"pgg")
501 (autoload 'pgg-encrypt-region
"pgg")
502 (autoload 'pgg-parse-armor
"pgg-parse")
504 (defun mml2015-pgg-decrypt (handle ctl
)
506 (let ((pgg-errors-buffer mml2015-result-buffer
)
507 child handles result decrypt-status
)
508 (unless (setq child
(mm-find-part-by-type
510 "application/octet-stream" nil t
))
511 (mm-set-handle-multipart-parameter
512 mm-security-handle
'gnus-info
"Corrupted")
513 (throw 'error handle
))
515 (mm-insert-part child
)
516 (if (condition-case err
518 (pgg-decrypt-region (point-min) (point-max))
520 (with-current-buffer mml2015-result-buffer
522 (mm-set-handle-multipart-parameter
523 mm-security-handle
'gnus-details
526 (mm-set-handle-multipart-parameter
527 mm-security-handle
'gnus-details
(mml2015-format-error err
))
530 (mm-set-handle-multipart-parameter
531 mm-security-handle
'gnus-details
"Quit.")
533 (with-current-buffer pgg-output-buffer
534 (goto-char (point-min))
535 (while (search-forward "\r\n" nil t
)
536 (replace-match "\n" t t
))
537 (setq handles
(mm-dissect-buffer t
))
538 (mm-destroy-parts handle
)
539 (mm-set-handle-multipart-parameter
540 mm-security-handle
'gnus-info
"OK")
541 (mm-set-handle-multipart-parameter
542 mm-security-handle
'gnus-details
543 (concat decrypt-status
544 (when (stringp (car handles
))
545 "\n" (mm-handle-multipart-ctl-parameter
546 handles
'gnus-details
))))
547 (if (listp (car handles
))
550 (mm-set-handle-multipart-parameter
551 mm-security-handle
'gnus-info
"Failed")
552 (throw 'error handle
))))))
554 (defun mml2015-pgg-clear-decrypt ()
555 (let ((pgg-errors-buffer mml2015-result-buffer
))
557 (pgg-decrypt-region (point-min) (point-max))
558 (mm-set-handle-multipart-parameter
559 mm-security-handle
'gnus-details
560 (with-current-buffer mml2015-result-buffer
564 ;; Treat data which pgg returns as a unibyte string.
565 (mm-disable-multibyte)
566 (insert-buffer-substring pgg-output-buffer
)
567 (goto-char (point-min))
568 (while (search-forward "\r\n" nil t
)
569 (replace-match "\n" t t
))
570 (mm-set-handle-multipart-parameter
571 mm-security-handle
'gnus-info
"OK"))
572 (mm-set-handle-multipart-parameter
573 mm-security-handle
'gnus-info
"Failed"))))
575 (defun mml2015-pgg-verify (handle ctl
)
576 (let ((pgg-errors-buffer mml2015-result-buffer
)
577 signature-file part signature
)
578 (if (or (null (setq part
(mm-find-raw-part-by-type
579 ctl
(or (mm-handle-multipart-ctl-parameter
581 "application/pgp-signature")
583 (null (setq signature
(mm-find-part-by-type
584 (cdr handle
) "application/pgp-signature" nil t
))))
586 (mm-set-handle-multipart-parameter
587 mm-security-handle
'gnus-info
"Corrupted")
591 ;; Convert <LF> to <CR><LF> in signed text. If --textmode is
592 ;; specified when signing, the conversion is not necessary.
593 (goto-char (point-min))
596 (unless (eq (char-before) ?
\r)
600 (with-temp-file (setq signature-file
(mm-make-temp-file "pgg"))
601 (mm-insert-part signature
))
602 (if (condition-case err
604 (pgg-verify-region (point-min) (point-max)
606 (goto-char (point-min))
607 (while (search-forward "\r\n" nil t
)
608 (replace-match "\n" t t
))
609 (mm-set-handle-multipart-parameter
610 mm-security-handle
'gnus-details
611 (concat (with-current-buffer pgg-output-buffer
613 (with-current-buffer pgg-errors-buffer
616 (mm-set-handle-multipart-parameter
617 mm-security-handle
'gnus-details
(mml2015-format-error err
))
620 (mm-set-handle-multipart-parameter
621 mm-security-handle
'gnus-details
"Quit.")
624 (delete-file signature-file
)
625 (mm-set-handle-multipart-parameter
626 mm-security-handle
'gnus-info
627 (with-current-buffer pgg-errors-buffer
628 (mml2015-gpg-extract-signature-details))))
629 (delete-file signature-file
)
630 (mm-set-handle-multipart-parameter
631 mm-security-handle
'gnus-info
"Failed")))))
634 (defun mml2015-pgg-clear-verify ()
635 (let ((pgg-errors-buffer mml2015-result-buffer
)
636 (text (buffer-string))
637 (coding-system buffer-file-coding-system
))
638 (if (condition-case err
640 (mm-with-unibyte-buffer
641 (insert (mm-encode-coding-string text coding-system
))
642 (pgg-verify-region (point-min) (point-max) nil t
))
643 (goto-char (point-min))
644 (while (search-forward "\r\n" nil t
)
645 (replace-match "\n" t t
))
646 (mm-set-handle-multipart-parameter
647 mm-security-handle
'gnus-details
648 (concat (with-current-buffer pgg-output-buffer
650 (with-current-buffer pgg-errors-buffer
653 (mm-set-handle-multipart-parameter
654 mm-security-handle
'gnus-details
(mml2015-format-error err
))
657 (mm-set-handle-multipart-parameter
658 mm-security-handle
'gnus-details
"Quit.")
660 (mm-set-handle-multipart-parameter
661 mm-security-handle
'gnus-info
662 (with-current-buffer pgg-errors-buffer
663 (mml2015-gpg-extract-signature-details)))
664 (mm-set-handle-multipart-parameter
665 mm-security-handle
'gnus-info
"Failed")))
666 (mml2015-extract-cleartext-signature))
668 (defun mml2015-pgg-sign (cont)
669 (let ((pgg-errors-buffer mml2015-result-buffer
)
670 (boundary (mml-compute-boundary cont
))
671 (pgg-default-user-id (or (message-options-get 'mml-sender
)
672 pgg-default-user-id
))
675 (unless (pgg-sign-region (point-min) (point-max))
676 (pop-to-buffer mml2015-result-buffer
)
677 (error "Sign error"))
678 (goto-char (point-min))
679 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
681 (if (setq entry
(assq 2 (pgg-parse-armor
682 (with-current-buffer pgg-output-buffer
684 (setq entry
(assq 'hash-algorithm
(cdr entry
))))
685 (insert (format "\tmicalg=%s; "
687 (downcase (format "pgp-%s" (cdr entry
)))
689 (insert "protocol=\"application/pgp-signature\"\n")
690 (insert (format "\n--%s\n" boundary
))
691 (goto-char (point-max))
692 (insert (format "\n--%s\n" boundary
))
693 (insert "Content-Type: application/pgp-signature\n\n")
694 (insert-buffer-substring pgg-output-buffer
)
695 (goto-char (point-max))
696 (insert (format "--%s--\n" boundary
))
697 (goto-char (point-max))))
699 (defun mml2015-pgg-encrypt (cont &optional sign
)
700 (let ((pgg-errors-buffer mml2015-result-buffer
)
702 (boundary (mml-compute-boundary cont
)))
703 (unless (pgg-encrypt-region (point-min) (point-max)
706 (message-options-get 'message-recipients
)
707 (message-options-set 'message-recipients
708 (read-string "Recipients: ")))
711 (pop-to-buffer mml2015-result-buffer
)
712 (error "Encrypt error"))
713 (delete-region (point-min) (point-max))
714 (goto-char (point-min))
715 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
717 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
718 (insert (format "--%s\n" boundary
))
719 (insert "Content-Type: application/pgp-encrypted\n\n")
720 (insert "Version: 1\n\n")
721 (insert (format "--%s\n" boundary
))
722 (insert "Content-Type: application/octet-stream\n\n")
723 (insert-buffer-substring pgg-output-buffer
)
724 (goto-char (point-max))
725 (insert (format "--%s--\n" boundary
))
726 (goto-char (point-max))))
730 (defvar epg-user-id-alist
)
731 (defvar epg-digest-algorithm-alist
)
732 (defvar inhibit-redisplay
)
734 (autoload 'epg-make-context
"epg")
735 (autoload 'epg-context-set-armor
"epg")
736 (autoload 'epg-context-set-textmode
"epg")
737 (autoload 'epg-context-set-signers
"epg")
738 (autoload 'epg-context-result-for
"epg")
739 (autoload 'epg-new-signature-digest-algorithm
"epg")
740 (autoload 'epg-verify-result-to-string
"epg")
741 (autoload 'epg-list-keys
"epg")
742 (autoload 'epg-decrypt-string
"epg")
743 (autoload 'epg-verify-string
"epg")
744 (autoload 'epg-sign-string
"epg")
745 (autoload 'epg-encrypt-string
"epg")
746 (autoload 'epg-passphrase-callback-function
"epg")
747 (autoload 'epg-context-set-passphrase-callback
"epg")
748 (autoload 'epg-key-sub-key-list
"epg")
749 (autoload 'epg-sub-key-capability
"epg")
750 (autoload 'epg-sub-key-validity
"epg")
751 (autoload 'epg-sub-key-fingerprint
"epg")
752 (autoload 'epg-configuration
"epg-config")
753 (autoload 'epg-expand-group
"epg-config")
754 (autoload 'epa-select-keys
"epa")
756 (defvar mml2015-epg-secret-key-id-list nil
)
758 (defun mml2015-epg-passphrase-callback (context key-id ignore
)
760 (epg-passphrase-callback-function context key-id nil
)
761 (let* ((password-cache-key-id
769 "Passphrase for PIN: "
770 (if (setq entry
(assoc key-id epg-user-id-alist
))
771 (format "Passphrase for %s %s: " key-id
(cdr entry
))
772 (format "Passphrase for %s: " key-id
)))
773 password-cache-key-id
)))
775 (let ((password-cache-expiry mml2015-passphrase-cache-expiry
))
776 (password-cache-add password-cache-key-id passphrase
))
777 (setq mml2015-epg-secret-key-id-list
778 (cons password-cache-key-id mml2015-epg-secret-key-id-list
))
779 (copy-sequence passphrase
)))))
781 (defun mml2015-epg-find-usable-key (keys usage
)
784 (let ((pointer (epg-key-sub-key-list (car keys
))))
786 (if (and (memq usage
(epg-sub-key-capability (car pointer
)))
787 (not (memq 'disabled
(epg-sub-key-capability (car pointer
))))
788 (not (memq (epg-sub-key-validity (car pointer
))
789 '(revoked expired
))))
790 (throw 'found
(car keys
)))
791 (setq pointer
(cdr pointer
))))
792 (setq keys
(cdr keys
)))))
794 ;; XXX: since gpg --list-secret-keys does not return validity of each
795 ;; key, `mml2015-epg-find-usable-key' defined above is not enough for
796 ;; secret keys. The function `mml2015-epg-find-usable-secret-key'
797 ;; below looks at appropriate public keys to check usability.
798 (defun mml2015-epg-find-usable-secret-key (context name usage
)
799 (let ((secret-keys (epg-list-keys context name t
))
801 (while (and (not secret-key
) secret-keys
)
802 (if (mml2015-epg-find-usable-key
803 (epg-list-keys context
(epg-sub-key-fingerprint
804 (car (epg-key-sub-key-list
805 (car secret-keys
)))))
807 (setq secret-key
(car secret-keys
)
809 (setq secret-keys
(cdr secret-keys
))))
812 (defun mml2015-epg-decrypt (handle ctl
)
814 (let ((inhibit-redisplay t
)
815 context plain child handles result decrypt-status
)
816 (unless (setq child
(mm-find-part-by-type
818 "application/octet-stream" nil t
))
819 (mm-set-handle-multipart-parameter
820 mm-security-handle
'gnus-info
"Corrupted")
821 (throw 'error handle
))
822 (setq context
(epg-make-context))
823 (if mml2015-cache-passphrase
824 (epg-context-set-passphrase-callback
826 #'mml2015-epg-passphrase-callback
))
827 (condition-case error
828 (setq plain
(epg-decrypt-string context
(mm-get-part child
))
829 mml2015-epg-secret-key-id-list nil
)
831 (while mml2015-epg-secret-key-id-list
832 (password-cache-remove (car mml2015-epg-secret-key-id-list
))
833 (setq mml2015-epg-secret-key-id-list
834 (cdr mml2015-epg-secret-key-id-list
)))
835 (mm-set-handle-multipart-parameter
836 mm-security-handle
'gnus-info
"Failed")
837 (if (eq (car error
) 'quit
)
838 (mm-set-handle-multipart-parameter
839 mm-security-handle
'gnus-details
"Quit.")
840 (mm-set-handle-multipart-parameter
841 mm-security-handle
'gnus-details
(mml2015-format-error error
)))
842 (throw 'error handle
)))
845 (goto-char (point-min))
846 (while (search-forward "\r\n" nil t
)
847 (replace-match "\n" t t
))
848 (setq handles
(mm-dissect-buffer t
))
849 (mm-destroy-parts handle
)
850 (if (epg-context-result-for context
'verify
)
851 (mm-set-handle-multipart-parameter
852 mm-security-handle
'gnus-info
854 (epg-verify-result-to-string
855 (epg-context-result-for context
'verify
))))
856 (mm-set-handle-multipart-parameter
857 mm-security-handle
'gnus-info
"OK"))
858 (if (stringp (car handles
))
859 (mm-set-handle-multipart-parameter
860 mm-security-handle
'gnus-details
861 (mm-handle-multipart-ctl-parameter handles
'gnus-details
))))
862 (if (listp (car handles
))
866 (defun mml2015-epg-clear-decrypt ()
867 (let ((inhibit-redisplay t
)
868 (context (epg-make-context))
870 (if mml2015-cache-passphrase
871 (epg-context-set-passphrase-callback
873 #'mml2015-epg-passphrase-callback
))
874 (condition-case error
875 (setq plain
(epg-decrypt-string context
(buffer-string))
876 mml2015-epg-secret-key-id-list nil
)
878 (while mml2015-epg-secret-key-id-list
879 (password-cache-remove (car mml2015-epg-secret-key-id-list
))
880 (setq mml2015-epg-secret-key-id-list
881 (cdr mml2015-epg-secret-key-id-list
)))
882 (mm-set-handle-multipart-parameter
883 mm-security-handle
'gnus-info
"Failed")
884 (if (eq (car error
) 'quit
)
885 (mm-set-handle-multipart-parameter
886 mm-security-handle
'gnus-details
"Quit.")
887 (mm-set-handle-multipart-parameter
888 mm-security-handle
'gnus-details
(mml2015-format-error error
)))))
891 ;; Treat data which epg returns as a unibyte string.
892 (mm-disable-multibyte)
894 (goto-char (point-min))
895 (while (search-forward "\r\n" nil t
)
896 (replace-match "\n" t t
))
897 (mm-set-handle-multipart-parameter
898 mm-security-handle
'gnus-info
"OK")
899 (if (epg-context-result-for context
'verify
)
900 (mm-set-handle-multipart-parameter
901 mm-security-handle
'gnus-details
902 (epg-verify-result-to-string
903 (epg-context-result-for context
'verify
)))))))
905 (defun mml2015-epg-verify (handle ctl
)
907 (let ((inhibit-redisplay t
)
908 context plain signature-file part signature
)
909 (when (or (null (setq part
(mm-find-raw-part-by-type
910 ctl
(or (mm-handle-multipart-ctl-parameter
912 "application/pgp-signature")
914 (null (setq signature
(mm-find-part-by-type
915 (cdr handle
) "application/pgp-signature"
917 (mm-set-handle-multipart-parameter
918 mm-security-handle
'gnus-info
"Corrupted")
919 (throw 'error handle
))
920 (setq part
(mm-replace-in-string part
"\n" "\r\n" t
)
921 signature
(mm-get-part signature
)
922 context
(epg-make-context))
923 (condition-case error
924 (setq plain
(epg-verify-string context signature part
))
926 (mm-set-handle-multipart-parameter
927 mm-security-handle
'gnus-info
"Failed")
928 (if (eq (car error
) 'quit
)
929 (mm-set-handle-multipart-parameter
930 mm-security-handle
'gnus-details
"Quit.")
931 (mm-set-handle-multipart-parameter
932 mm-security-handle
'gnus-details
(mml2015-format-error error
)))
933 (throw 'error handle
)))
934 (mm-set-handle-multipart-parameter
935 mm-security-handle
'gnus-info
936 (epg-verify-result-to-string (epg-context-result-for context
'verify
)))
939 (defun mml2015-epg-clear-verify ()
940 (let ((inhibit-redisplay t
)
941 (context (epg-make-context))
942 (signature (mm-encode-coding-string (buffer-string)
943 coding-system-for-write
))
945 (condition-case error
946 (setq plain
(epg-verify-string context signature
))
948 (mm-set-handle-multipart-parameter
949 mm-security-handle
'gnus-info
"Failed")
950 (if (eq (car error
) 'quit
)
951 (mm-set-handle-multipart-parameter
952 mm-security-handle
'gnus-details
"Quit.")
953 (mm-set-handle-multipart-parameter
954 mm-security-handle
'gnus-details
(mml2015-format-error error
)))))
957 (mm-set-handle-multipart-parameter
958 mm-security-handle
'gnus-info
959 (epg-verify-result-to-string
960 (epg-context-result-for context
'verify
)))
961 (delete-region (point-min) (point-max))
962 (insert (mm-decode-coding-string plain coding-system-for-read
)))
963 (mml2015-extract-cleartext-signature))))
965 (defun mml2015-epg-sign (cont)
966 (let* ((inhibit-redisplay t
)
967 (context (epg-make-context))
968 (boundary (mml-compute-boundary cont
))
969 (sender (message-options-get 'message-sender
))
970 (signer-names (or mml2015-signers
971 (if (and mml2015-sign-with-sender sender
)
972 (list (concat "<" sender
">")))))
975 (or (message-options-get 'mml2015-epg-signers
)
978 (if (eq mm-sign-option
'guided
)
979 (epa-select-keys context
"\
980 Select keys for signing.
981 If no one is selected, default secret key is used. "
984 (if (or sender mml2015-signers
)
989 (mml2015-epg-find-usable-secret-key
990 context signer
'sign
))
991 (unless (or signer-key
994 "No secret key for %s; skip it? "
996 (error "No secret key for %s" signer
))
1000 (epg-context-set-armor context t
)
1001 (epg-context-set-textmode context t
)
1002 (epg-context-set-signers context signers
)
1003 (if mml2015-cache-passphrase
1004 (epg-context-set-passphrase-callback
1006 #'mml2015-epg-passphrase-callback
))
1007 (condition-case error
1008 (setq signature
(epg-sign-string context
(buffer-string) t
)
1009 mml2015-epg-secret-key-id-list nil
)
1011 (while mml2015-epg-secret-key-id-list
1012 (password-cache-remove (car mml2015-epg-secret-key-id-list
))
1013 (setq mml2015-epg-secret-key-id-list
1014 (cdr mml2015-epg-secret-key-id-list
)))
1015 (signal (car error
) (cdr error
))))
1016 (if (epg-context-result-for context
'sign
)
1017 (setq micalg
(epg-new-signature-digest-algorithm
1018 (car (epg-context-result-for context
'sign
)))))
1019 (goto-char (point-min))
1020 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
1023 (insert (format "\tmicalg=pgp-%s; "
1026 epg-digest-algorithm-alist
))))))
1027 (insert "protocol=\"application/pgp-signature\"\n")
1028 (insert (format "\n--%s\n" boundary
))
1029 (goto-char (point-max))
1030 (insert (format "\n--%s\n" boundary
))
1031 (insert "Content-Type: application/pgp-signature\n\n")
1033 (goto-char (point-max))
1034 (insert (format "--%s--\n" boundary
))
1035 (goto-char (point-max))))
1037 (defun mml2015-epg-encrypt (cont &optional sign
)
1038 (let* ((inhibit-redisplay t
)
1039 (context (epg-make-context))
1040 (boundary (mml-compute-boundary cont
))
1041 (config (epg-configuration))
1042 (recipients (message-options-get 'mml2015-epg-recipients
))
1044 (sender (message-options-get 'message-sender
))
1045 (signer-names (or mml2015-signers
1046 (if (and mml2015-sign-with-sender sender
)
1047 (list (concat "<" sender
">")))))
1049 recipient-key signer-key
)
1055 (or (epg-expand-group config recipient
)
1056 (list (concat "<" recipient
">"))))
1058 (or (message-options-get 'message-recipients
)
1059 (message-options-set 'message-recipients
1060 (read-string "Recipients: ")))
1061 "[ \f\t\n\r\v,]+"))))
1062 (when mml2015-encrypt-to-self
1063 (unless signer-names
1064 (error "Neither message sender nor mml2015-signers are set"))
1065 (setq recipients
(nconc recipients signer-names
)))
1066 (if (eq mm-encrypt-option
'guided
)
1068 (epa-select-keys context
"\
1069 Select recipients for encryption.
1070 If no one is selected, symmetric encryption will be performed. "
1076 (setq recipient-key
(mml2015-epg-find-usable-key
1077 (epg-list-keys context recipient
)
1079 (unless (or recipient-key
1081 (format "No public key for %s; skip it? "
1083 (error "No public key for %s" recipient
))
1087 (error "No recipient specified")))
1088 (message-options-set 'mml2015-epg-recipients recipients
))
1091 (or (message-options-get 'mml2015-epg-signers
)
1092 (message-options-set
1093 'mml2015-epg-signers
1094 (if (eq mm-sign-option
'guided
)
1095 (epa-select-keys context
"\
1096 Select keys for signing.
1097 If no one is selected, default secret key is used. "
1100 (if (or sender mml2015-signers
)
1105 (mml2015-epg-find-usable-secret-key
1106 context signer
'sign
))
1107 (unless (or signer-key
1110 "No secret key for %s; skip it? "
1112 (error "No secret key for %s" signer
))
1115 (epg-context-set-signers context signers
))
1116 (epg-context-set-armor context t
)
1117 (epg-context-set-textmode context t
)
1118 (if mml2015-cache-passphrase
1119 (epg-context-set-passphrase-callback
1121 #'mml2015-epg-passphrase-callback
))
1122 (condition-case error
1124 (epg-encrypt-string context
(buffer-string) recipients sign
1125 mml2015-always-trust
)
1126 mml2015-epg-secret-key-id-list nil
)
1128 (while mml2015-epg-secret-key-id-list
1129 (password-cache-remove (car mml2015-epg-secret-key-id-list
))
1130 (setq mml2015-epg-secret-key-id-list
1131 (cdr mml2015-epg-secret-key-id-list
)))
1132 (signal (car error
) (cdr error
))))
1133 (delete-region (point-min) (point-max))
1134 (goto-char (point-min))
1135 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
1137 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
1138 (insert (format "--%s\n" boundary
))
1139 (insert "Content-Type: application/pgp-encrypted\n\n")
1140 (insert "Version: 1\n\n")
1141 (insert (format "--%s\n" boundary
))
1142 (insert "Content-Type: application/octet-stream\n\n")
1144 (goto-char (point-max))
1145 (insert (format "--%s--\n" boundary
))
1146 (goto-char (point-max))))
1150 (autoload 'gnus-buffer-live-p
"gnus-util")
1151 (autoload 'gnus-get-buffer-create
"gnus")
1153 (defun mml2015-clean-buffer ()
1154 (if (gnus-buffer-live-p mml2015-result-buffer
)
1155 (with-current-buffer mml2015-result-buffer
1158 (setq mml2015-result-buffer
1159 (gnus-get-buffer-create " *MML2015 Result*"))
1162 (defsubst mml2015-clear-decrypt-function
()
1163 (nth 6 (assq mml2015-use mml2015-function-alist
)))
1165 (defsubst mml2015-clear-verify-function
()
1166 (nth 5 (assq mml2015-use mml2015-function-alist
)))
1169 (defun mml2015-decrypt (handle ctl
)
1170 (mml2015-clean-buffer)
1171 (let ((func (nth 4 (assq mml2015-use mml2015-function-alist
))))
1173 (funcall func handle ctl
)
1177 (defun mml2015-decrypt-test (handle ctl
)
1181 (defun mml2015-verify (handle ctl
)
1182 (mml2015-clean-buffer)
1183 (let ((func (nth 3 (assq mml2015-use mml2015-function-alist
))))
1185 (funcall func handle ctl
)
1189 (defun mml2015-verify-test (handle ctl
)
1193 (defun mml2015-encrypt (cont &optional sign
)
1194 (mml2015-clean-buffer)
1195 (let ((func (nth 2 (assq mml2015-use mml2015-function-alist
))))
1197 (funcall func cont sign
)
1198 (error "Cannot find encrypt function"))))
1201 (defun mml2015-sign (cont)
1202 (mml2015-clean-buffer)
1203 (let ((func (nth 1 (assq mml2015-use mml2015-function-alist
))))
1206 (error "Cannot find sign function"))))
1209 (defun mml2015-self-encrypt ()
1210 (mml2015-encrypt nil
))
1214 ;;; mml2015.el ends here