1 ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006 Free Software Foundation, Inc.
6 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
7 ;; Keywords: PGP MIME MML
9 ;; This file is part of GNU Emacs.
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
13 ;; by the Free Software Foundation; either version 2, or (at your
14 ;; option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
28 ;; RFC 2015 is updated by RFC 3156, this file should be compatible
33 (eval-when-compile (require 'cl))
39 (defvar mc-pgp-always-sign)
41 (defvar mml2015-use (or
45 (epg-check-configuration (epg-configuration))
50 ;; Avoid the "Recursive load suspected" error
52 (let ((recursive-load-depth-limit 100))
54 (and (fboundp 'pgg-sign-region)
59 (and (fboundp 'gpg-sign-detached)
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', `gpg' 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-gpg-clear-verify
83 mml2015-gpg-clear-decrypt)
88 mml2015-pgg-clear-verify
89 mml2015-pgg-clear-decrypt)
94 mml2015-epg-clear-verify
95 mml2015-epg-clear-decrypt))
96 "Alist of PGP/MIME functions.")
98 (defvar mml2015-result-buffer nil)
100 (defcustom mml2015-unabbrev-trust-alist
101 '(("TRUST_UNDEFINED" . nil)
102 ("TRUST_NEVER" . nil)
103 ("TRUST_MARGINAL" . t)
105 ("TRUST_ULTIMATE" . t))
106 "Map GnuPG trust output values to a boolean saying if you trust the key."
108 :group 'mime-security
109 :type '(repeat (cons (regexp :tag "GnuPG output regexp")
110 (boolean :tag "Trust key"))))
112 (defcustom mml2015-verbose mml-secure-verbose
113 "If non-nil, ask the user about the current operation more verbosely."
114 :group 'mime-security
117 (defcustom mml2015-cache-passphrase mml-secure-cache-passphrase
118 "If t, cache passphrase."
119 :group 'mime-security
122 (defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
123 "How many seconds the passphrase is cached.
124 Whether the passphrase is cached at all is controlled by
125 `mml2015-cache-passphrase'."
126 :group 'mime-security
129 (defcustom mml2015-signers nil
130 "A list of your own key ID which will be used to sign a message."
131 :group 'mime-security
132 :type '(repeat (string :tag "Key ID")))
134 (defcustom mml2015-encrypt-to-self nil
135 "If t, add your own key ID to recipient list when encryption."
136 :group 'mime-security
139 ;;; mailcrypt wrapper
142 (autoload 'mailcrypt-decrypt "mailcrypt")
143 (autoload 'mailcrypt-verify "mailcrypt")
144 (autoload 'mc-pgp-always-sign "mailcrypt")
145 (autoload 'mc-encrypt-generic "mc-toplev")
146 (autoload 'mc-cleanup-recipient-headers "mc-toplev")
147 (autoload 'mc-sign-generic "mc-toplev"))
150 (defvar mc-default-scheme)
153 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
154 (defvar mml2015-verify-function 'mailcrypt-verify)
156 (defun mml2015-format-error (err)
157 (if (stringp (cadr err))
159 (format "%S" (cdr err))))
161 (defun mml2015-mailcrypt-decrypt (handle ctl)
163 (let (child handles result)
164 (unless (setq child (mm-find-part-by-type
166 "application/octet-stream" nil t))
167 (mm-set-handle-multipart-parameter
168 mm-security-handle 'gnus-info "Corrupted")
169 (throw 'error handle))
171 (mm-insert-part child)
174 (funcall mml2015-decrypt-function)
176 (mm-set-handle-multipart-parameter
177 mm-security-handle 'gnus-details (mml2015-format-error err))
180 (mm-set-handle-multipart-parameter
181 mm-security-handle 'gnus-details "Quit.")
184 (mm-set-handle-multipart-parameter
185 mm-security-handle 'gnus-info "Failed")
186 (throw 'error handle))
187 (setq handles (mm-dissect-buffer t)))
188 (mm-destroy-parts handle)
189 (mm-set-handle-multipart-parameter
190 mm-security-handle 'gnus-info
192 (let ((sig (with-current-buffer mml2015-result-buffer
193 (mml2015-gpg-extract-signature-details))))
194 (concat ", Signer: " sig))))
195 (if (listp (car handles))
199 (defun mml2015-mailcrypt-clear-decrypt ()
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 "OK")
215 (mm-set-handle-multipart-parameter
216 mm-security-handle 'gnus-info "Failed"))))
218 (defun mml2015-fix-micalg (alg)
220 ;; Mutt/1.2.5i has seen sending micalg=php-sha1
221 (upcase (if (string-match "^p[gh]p-" alg)
222 (substring alg (match-end 0))
225 (defun mml2015-mailcrypt-verify (handle ctl)
228 (unless (setq part (mm-find-raw-part-by-type
229 ctl (or (mm-handle-multipart-ctl-parameter
231 "application/pgp-signature")
233 (mm-set-handle-multipart-parameter
234 mm-security-handle 'gnus-info "Corrupted")
235 (throw 'error handle))
237 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
238 (insert (format "Hash: %s\n\n"
239 (or (mml2015-fix-micalg
240 (mm-handle-multipart-ctl-parameter
244 (narrow-to-region (point) (point))
246 (goto-char (point-min))
248 (if (looking-at "^-")
251 (unless (setq part (mm-find-part-by-type
252 (cdr handle) "application/pgp-signature" nil t))
253 (mm-set-handle-multipart-parameter
254 mm-security-handle 'gnus-info "Corrupted")
255 (throw 'error handle))
257 (narrow-to-region (point) (point))
258 (mm-insert-part part)
259 (goto-char (point-min))
260 (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
261 (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
262 (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
263 (replace-match "-----END PGP SIGNATURE-----" t t)))
264 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
265 (unless (condition-case err
267 (funcall mml2015-verify-function)
268 (if (get-buffer " *mailcrypt stderr temp")
269 (mm-set-handle-multipart-parameter
270 mm-security-handle 'gnus-details
271 (with-current-buffer " *mailcrypt stderr temp"
273 (if (get-buffer " *mailcrypt stdout temp")
274 (kill-buffer " *mailcrypt stdout temp"))
275 (if (get-buffer " *mailcrypt stderr temp")
276 (kill-buffer " *mailcrypt stderr temp"))
277 (if (get-buffer " *mailcrypt status temp")
278 (kill-buffer " *mailcrypt status temp"))
279 (if (get-buffer mc-gpg-debug-buffer)
280 (kill-buffer mc-gpg-debug-buffer)))
282 (mm-set-handle-multipart-parameter
283 mm-security-handle 'gnus-details (mml2015-format-error err))
286 (mm-set-handle-multipart-parameter
287 mm-security-handle 'gnus-details "Quit.")
289 (mm-set-handle-multipart-parameter
290 mm-security-handle 'gnus-info "Failed")
291 (throw 'error handle))))
292 (mm-set-handle-multipart-parameter
293 mm-security-handle 'gnus-info "OK")
296 (defun mml2015-mailcrypt-clear-verify ()
297 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
298 (if (condition-case err
300 (funcall mml2015-verify-function)
301 (if (get-buffer " *mailcrypt stderr temp")
302 (mm-set-handle-multipart-parameter
303 mm-security-handle 'gnus-details
304 (with-current-buffer " *mailcrypt stderr temp"
306 (if (get-buffer " *mailcrypt stdout temp")
307 (kill-buffer " *mailcrypt stdout temp"))
308 (if (get-buffer " *mailcrypt stderr temp")
309 (kill-buffer " *mailcrypt stderr temp"))
310 (if (get-buffer " *mailcrypt status temp")
311 (kill-buffer " *mailcrypt status temp"))
312 (if (get-buffer mc-gpg-debug-buffer)
313 (kill-buffer mc-gpg-debug-buffer)))
315 (mm-set-handle-multipart-parameter
316 mm-security-handle 'gnus-details (mml2015-format-error err))
319 (mm-set-handle-multipart-parameter
320 mm-security-handle 'gnus-details "Quit.")
322 (mm-set-handle-multipart-parameter
323 mm-security-handle 'gnus-info "OK")
324 (mm-set-handle-multipart-parameter
325 mm-security-handle 'gnus-info "Failed"))))
327 (defun mml2015-mailcrypt-sign (cont)
328 (mc-sign-generic (message-options-get 'message-sender)
330 (let ((boundary (mml-compute-boundary cont))
332 (goto-char (point-min))
333 (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
334 (error "Cannot find signed begin line"))
335 (goto-char (match-beginning 0))
337 (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
338 (error "Cannot not find PGP hash"))
339 (setq hash (match-string 1))
340 (unless (re-search-forward "^$" nil t)
341 (error "Cannot not find PGP message"))
343 (delete-region (point-min) (point))
344 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
346 (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
348 (insert (format "\n--%s\n" boundary))
350 (goto-char (point-max))
351 (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
352 (error "Cannot find signature part"))
353 (replace-match "-----END PGP MESSAGE-----" t t)
354 (goto-char (match-beginning 0))
355 (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
357 (error "Cannot find signature part"))
358 (replace-match "-----BEGIN PGP MESSAGE-----" t t)
359 (goto-char (match-beginning 0))
361 (narrow-to-region point (point))
363 (while (re-search-forward "^- -" nil t)
364 (replace-match "-" t t))
365 (goto-char (point-max)))
366 (insert (format "--%s\n" boundary))
367 (insert "Content-Type: application/pgp-signature\n\n")
368 (goto-char (point-max))
369 (insert (format "--%s--\n" boundary))
370 (goto-char (point-max))))
372 (defun mml2015-mailcrypt-encrypt (cont &optional sign)
373 (let ((mc-pgp-always-sign
374 (or mc-pgp-always-sign
376 (eq t (or (message-options-get 'message-sign-encrypt)
378 'message-sign-encrypt
379 (or (y-or-n-p "Sign the message? ")
382 (mm-with-unibyte-current-buffer
384 (or (message-options-get 'message-recipients)
385 (message-options-set 'message-recipients
386 (mc-cleanup-recipient-headers
387 (read-string "Recipients: "))))
389 (message-options-get 'message-sender))))
390 (goto-char (point-min))
391 (unless (looking-at "-----BEGIN PGP MESSAGE-----")
392 (error "Fail to encrypt the message"))
393 (let ((boundary (mml-compute-boundary cont)))
394 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
396 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
397 (insert (format "--%s\n" boundary))
398 (insert "Content-Type: application/pgp-encrypted\n\n")
399 (insert "Version: 1\n\n")
400 (insert (format "--%s\n" boundary))
401 (insert "Content-Type: application/octet-stream\n\n")
402 (goto-char (point-max))
403 (insert (format "--%s--\n" boundary))
404 (goto-char (point-max))))
409 (autoload 'gpg-decrypt "gpg")
410 (autoload 'gpg-verify "gpg")
411 (autoload 'gpg-verify-cleartext "gpg")
412 (autoload 'gpg-sign-detached "gpg")
413 (autoload 'gpg-sign-encrypt "gpg")
414 (autoload 'gpg-encrypt "gpg")
415 (autoload 'gpg-passphrase-read "gpg"))
417 (defun mml2015-gpg-passphrase ()
418 (or (message-options-get 'gpg-passphrase)
419 (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
421 (defun mml2015-gpg-decrypt-1 ()
422 (let ((cipher (current-buffer)) plain result)
423 (if (with-temp-buffer
425 (gpg-decrypt cipher (setq plain (current-buffer))
426 mml2015-result-buffer nil)
427 (mm-set-handle-multipart-parameter
428 mm-security-handle 'gnus-details
429 (with-current-buffer mml2015-result-buffer
433 (insert-buffer-substring plain)
434 (goto-char (point-min))
435 (while (search-forward "\r\n" nil t)
436 (replace-match "\n" t t))))
438 ;; Some wrong with the return value, check plain text buffer.
439 (if (> (point-max) (point-min))
443 (defun mml2015-gpg-decrypt (handle ctl)
444 (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
445 (mml2015-mailcrypt-decrypt handle ctl)))
447 (defun mml2015-gpg-clear-decrypt ()
449 (setq result (mml2015-gpg-decrypt-1))
451 (mm-set-handle-multipart-parameter
452 mm-security-handle 'gnus-info "OK")
453 (mm-set-handle-multipart-parameter
454 mm-security-handle 'gnus-info "Failed"))))
456 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
458 (fpr-length (string-width fingerprint))
461 (setq fingerprint (string-to-list fingerprint))
463 (setq fpr-length (- fpr-length 4))
464 (setq slice (butlast fingerprint fpr-length))
465 (setq fingerprint (nthcdr 4 fingerprint))
466 (setq n-slice (1+ n-slice))
472 (otherwise (concat " " slice))))))
475 (defun mml2015-gpg-extract-signature-details ()
476 (goto-char (point-min))
477 (let* ((expired (re-search-forward
478 "^\\[GNUPG:\\] SIGEXPIRED$"
480 (signer (and (re-search-forward
481 "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
483 (cons (match-string 1) (match-string 2))))
484 (fprint (and (re-search-forward
485 "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
488 (trust (and (re-search-forward
489 "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
493 (cdr (assoc trust mml2015-unabbrev-trust-alist))))
494 (cond ((and signer fprint)
496 (unless trust-good-enough-p
497 (concat "\nUntrusted, Fingerprint: "
498 (mml2015-gpg-pretty-print-fpr fprint)))
500 (format "\nWARNING: Signature from expired key (%s)"
503 "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
506 "From unknown user"))))
508 (defun mml2015-gpg-verify (handle ctl)
510 (let (part message signature info-is-set-p)
511 (unless (setq part (mm-find-raw-part-by-type
512 ctl (or (mm-handle-multipart-ctl-parameter
514 "application/pgp-signature")
516 (mm-set-handle-multipart-parameter
517 mm-security-handle 'gnus-info "Corrupted")
518 (throw 'error handle))
520 (setq message (current-buffer))
522 ;; Convert <LF> to <CR><LF> in verify mode. Sign and
523 ;; clearsign use --textmode. The conversion is not necessary.
524 ;; In clearverify, the conversion is not necessary either.
525 (goto-char (point-min))
528 (unless (eq (char-before) ?\r)
533 (setq signature (current-buffer))
534 (unless (setq part (mm-find-part-by-type
535 (cdr handle) "application/pgp-signature" nil t))
536 (mm-set-handle-multipart-parameter
537 mm-security-handle 'gnus-info "Corrupted")
538 (throw 'error handle))
539 (mm-insert-part part)
540 (unless (condition-case err
542 (gpg-verify message signature mml2015-result-buffer)
543 (mm-set-handle-multipart-parameter
544 mm-security-handle 'gnus-details
545 (with-current-buffer mml2015-result-buffer
548 (mm-set-handle-multipart-parameter
549 mm-security-handle 'gnus-details (mml2015-format-error err))
550 (mm-set-handle-multipart-parameter
551 mm-security-handle 'gnus-info "Error.")
552 (setq info-is-set-p t)
555 (mm-set-handle-multipart-parameter
556 mm-security-handle 'gnus-details "Quit.")
557 (mm-set-handle-multipart-parameter
558 mm-security-handle 'gnus-info "Quit.")
559 (setq info-is-set-p t)
561 (unless info-is-set-p
562 (mm-set-handle-multipart-parameter
563 mm-security-handle 'gnus-info "Failed"))
564 (throw 'error handle)))
565 (mm-set-handle-multipart-parameter
566 mm-security-handle 'gnus-info
567 (with-current-buffer mml2015-result-buffer
568 (mml2015-gpg-extract-signature-details))))
571 (defun mml2015-gpg-clear-verify ()
572 (if (condition-case err
574 (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
575 (mm-set-handle-multipart-parameter
576 mm-security-handle 'gnus-details
577 (with-current-buffer mml2015-result-buffer
580 (mm-set-handle-multipart-parameter
581 mm-security-handle 'gnus-details (mml2015-format-error err))
584 (mm-set-handle-multipart-parameter
585 mm-security-handle 'gnus-details "Quit.")
587 (mm-set-handle-multipart-parameter
588 mm-security-handle 'gnus-info
589 (with-current-buffer mml2015-result-buffer
590 (mml2015-gpg-extract-signature-details)))
591 (mm-set-handle-multipart-parameter
592 mm-security-handle 'gnus-info "Failed")))
594 (defun mml2015-gpg-sign (cont)
595 (let ((boundary (mml-compute-boundary cont))
596 (text (current-buffer)) signature)
597 (goto-char (point-max))
601 (unless (gpg-sign-detached text (setq signature (current-buffer))
602 mml2015-result-buffer
604 (message-options-get 'message-sender)
605 t t) ; armor & textmode
606 (unless (> (point-max) (point-min))
607 (pop-to-buffer mml2015-result-buffer)
608 (error "Sign error")))
609 (goto-char (point-min))
610 (while (re-search-forward "\r+$" nil t)
611 (replace-match "" t t))
613 (goto-char (point-min))
614 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
616 ;;; FIXME: what is the micalg?
617 (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
618 (insert (format "\n--%s\n" boundary))
619 (goto-char (point-max))
620 (insert (format "\n--%s\n" boundary))
621 (insert "Content-Type: application/pgp-signature\n\n")
622 (insert-buffer-substring signature)
623 (goto-char (point-max))
624 (insert (format "--%s--\n" boundary))
625 (goto-char (point-max)))))
627 (defun mml2015-gpg-encrypt (cont &optional sign)
628 (let ((boundary (mml-compute-boundary cont))
629 (text (current-buffer))
631 (mm-with-unibyte-current-buffer
633 ;; set up a function to call the correct gpg encrypt routine
634 ;; with the right arguments. (FIXME: this should be done
636 (flet ((gpg-encrypt-func
637 (sign plaintext ciphertext result recipients &optional
638 passphrase sign-with-key armor textmode)
641 plaintext ciphertext result recipients passphrase
642 sign-with-key armor textmode)
644 plaintext ciphertext result recipients passphrase
646 (unless (gpg-encrypt-func
647 sign ; passed in when using signencrypt
648 text (setq cipher (current-buffer))
649 mml2015-result-buffer
652 (message-options-get 'message-recipients)
653 (message-options-set 'message-recipients
654 (read-string "Recipients: ")))
657 (message-options-get 'message-sender)
658 t t) ; armor & textmode
659 (unless (> (point-max) (point-min))
660 (pop-to-buffer mml2015-result-buffer)
661 (error "Encrypt error"))))
662 (goto-char (point-min))
663 (while (re-search-forward "\r+$" nil t)
664 (replace-match "" t t))
666 (delete-region (point-min) (point-max))
667 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
669 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
670 (insert (format "--%s\n" boundary))
671 (insert "Content-Type: application/pgp-encrypted\n\n")
672 (insert "Version: 1\n\n")
673 (insert (format "--%s\n" boundary))
674 (insert "Content-Type: application/octet-stream\n\n")
675 (insert-buffer-substring cipher)
676 (goto-char (point-max))
677 (insert (format "--%s--\n" boundary))
678 (goto-char (point-max))))))
683 (defvar pgg-default-user-id)
684 (defvar pgg-errors-buffer)
685 (defvar pgg-output-buffer))
688 (autoload 'pgg-decrypt-region "pgg")
689 (autoload 'pgg-verify-region "pgg")
690 (autoload 'pgg-sign-region "pgg")
691 (autoload 'pgg-encrypt-region "pgg")
692 (autoload 'pgg-parse-armor "pgg-parse"))
694 (defun mml2015-pgg-decrypt (handle ctl)
696 (let ((pgg-errors-buffer mml2015-result-buffer)
697 child handles result decrypt-status)
698 (unless (setq child (mm-find-part-by-type
700 "application/octet-stream" nil t))
701 (mm-set-handle-multipart-parameter
702 mm-security-handle 'gnus-info "Corrupted")
703 (throw 'error handle))
705 (mm-insert-part child)
706 (if (condition-case err
708 (pgg-decrypt-region (point-min) (point-max))
710 (with-current-buffer mml2015-result-buffer
712 (mm-set-handle-multipart-parameter
713 mm-security-handle 'gnus-details
716 (mm-set-handle-multipart-parameter
717 mm-security-handle 'gnus-details (mml2015-format-error err))
720 (mm-set-handle-multipart-parameter
721 mm-security-handle 'gnus-details "Quit.")
723 (with-current-buffer pgg-output-buffer
724 (goto-char (point-min))
725 (while (search-forward "\r\n" nil t)
726 (replace-match "\n" t t))
727 (setq handles (mm-dissect-buffer t))
728 (mm-destroy-parts handle)
729 (mm-set-handle-multipart-parameter
730 mm-security-handle 'gnus-info "OK")
731 (mm-set-handle-multipart-parameter
732 mm-security-handle 'gnus-details
733 (concat decrypt-status
734 (when (stringp (car handles))
735 "\n" (mm-handle-multipart-ctl-parameter
736 handles 'gnus-details))))
737 (if (listp (car handles))
740 (mm-set-handle-multipart-parameter
741 mm-security-handle 'gnus-info "Failed")
742 (throw 'error handle))))))
744 (defun mml2015-pgg-clear-decrypt ()
745 (let ((pgg-errors-buffer mml2015-result-buffer))
747 (pgg-decrypt-region (point-min) (point-max))
748 (mm-set-handle-multipart-parameter
749 mm-security-handle 'gnus-details
750 (with-current-buffer mml2015-result-buffer
754 ;; Treat data which pgg returns as a unibyte string.
755 (mm-disable-multibyte)
756 (insert-buffer-substring pgg-output-buffer)
757 (goto-char (point-min))
758 (while (search-forward "\r\n" nil t)
759 (replace-match "\n" t t))
760 (mm-set-handle-multipart-parameter
761 mm-security-handle 'gnus-info "OK"))
762 (mm-set-handle-multipart-parameter
763 mm-security-handle 'gnus-info "Failed"))))
765 (defun mml2015-pgg-verify (handle ctl)
766 (let ((pgg-errors-buffer mml2015-result-buffer)
767 signature-file part signature)
768 (if (or (null (setq part (mm-find-raw-part-by-type
769 ctl (or (mm-handle-multipart-ctl-parameter
771 "application/pgp-signature")
773 (null (setq signature (mm-find-part-by-type
774 (cdr handle) "application/pgp-signature" nil t))))
776 (mm-set-handle-multipart-parameter
777 mm-security-handle 'gnus-info "Corrupted")
781 ;; Convert <LF> to <CR><LF> in verify mode. Sign and
782 ;; clearsign use --textmode. The conversion is not necessary.
783 ;; In clearverify, the conversion is not necessary either.
784 (goto-char (point-min))
787 (unless (eq (char-before) ?\r)
791 (with-temp-file (setq signature-file (mm-make-temp-file "pgg"))
792 (mm-insert-part signature))
793 (if (condition-case err
795 (pgg-verify-region (point-min) (point-max)
797 (goto-char (point-min))
798 (while (search-forward "\r\n" nil t)
799 (replace-match "\n" t t))
800 (mm-set-handle-multipart-parameter
801 mm-security-handle 'gnus-details
802 (concat (with-current-buffer pgg-output-buffer
804 (with-current-buffer pgg-errors-buffer
807 (mm-set-handle-multipart-parameter
808 mm-security-handle 'gnus-details (mml2015-format-error err))
811 (mm-set-handle-multipart-parameter
812 mm-security-handle 'gnus-details "Quit.")
815 (delete-file signature-file)
816 (mm-set-handle-multipart-parameter
817 mm-security-handle 'gnus-info
818 (with-current-buffer pgg-errors-buffer
819 (mml2015-gpg-extract-signature-details))))
820 (delete-file signature-file)
821 (mm-set-handle-multipart-parameter
822 mm-security-handle 'gnus-info "Failed")))))
825 (defun mml2015-pgg-clear-verify ()
826 (let ((pgg-errors-buffer mml2015-result-buffer)
827 (text (buffer-string))
828 (coding-system buffer-file-coding-system))
829 (if (condition-case err
831 (mm-with-unibyte-buffer
832 (insert (encode-coding-string text coding-system))
833 (pgg-verify-region (point-min) (point-max) nil t))
834 (goto-char (point-min))
835 (while (search-forward "\r\n" nil t)
836 (replace-match "\n" t t))
837 (mm-set-handle-multipart-parameter
838 mm-security-handle 'gnus-details
839 (concat (with-current-buffer pgg-output-buffer
841 (with-current-buffer pgg-errors-buffer
844 (mm-set-handle-multipart-parameter
845 mm-security-handle 'gnus-details (mml2015-format-error err))
848 (mm-set-handle-multipart-parameter
849 mm-security-handle 'gnus-details "Quit.")
851 (mm-set-handle-multipart-parameter
852 mm-security-handle 'gnus-info
853 (with-current-buffer pgg-errors-buffer
854 (mml2015-gpg-extract-signature-details)))
855 (mm-set-handle-multipart-parameter
856 mm-security-handle 'gnus-info "Failed"))))
858 (defun mml2015-pgg-sign (cont)
859 (let ((pgg-errors-buffer mml2015-result-buffer)
860 (boundary (mml-compute-boundary cont))
861 (pgg-default-user-id (or (message-options-get 'mml-sender)
862 pgg-default-user-id))
865 (unless (pgg-sign-region (point-min) (point-max))
866 (pop-to-buffer mml2015-result-buffer)
867 (error "Sign error"))
868 (goto-char (point-min))
869 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
871 (if (setq entry (assq 2 (pgg-parse-armor
872 (with-current-buffer pgg-output-buffer
874 (setq entry (assq 'hash-algorithm (cdr entry))))
875 (insert (format "\tmicalg=%s; "
877 (downcase (format "pgp-%s" (cdr entry)))
879 (insert "protocol=\"application/pgp-signature\"\n")
880 (insert (format "\n--%s\n" boundary))
881 (goto-char (point-max))
882 (insert (format "\n--%s\n" boundary))
883 (insert "Content-Type: application/pgp-signature\n\n")
884 (insert-buffer-substring pgg-output-buffer)
885 (goto-char (point-max))
886 (insert (format "--%s--\n" boundary))
887 (goto-char (point-max))))
889 (defun mml2015-pgg-encrypt (cont &optional sign)
890 (let ((pgg-errors-buffer mml2015-result-buffer)
892 (boundary (mml-compute-boundary cont)))
893 (unless (pgg-encrypt-region (point-min) (point-max)
896 (message-options-get 'message-recipients)
897 (message-options-set 'message-recipients
898 (read-string "Recipients: ")))
901 (pop-to-buffer mml2015-result-buffer)
902 (error "Encrypt error"))
903 (delete-region (point-min) (point-max))
904 (goto-char (point-min))
905 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
907 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
908 (insert (format "--%s\n" boundary))
909 (insert "Content-Type: application/pgp-encrypted\n\n")
910 (insert "Version: 1\n\n")
911 (insert (format "--%s\n" boundary))
912 (insert "Content-Type: application/octet-stream\n\n")
913 (insert-buffer-substring pgg-output-buffer)
914 (goto-char (point-max))
915 (insert (format "--%s--\n" boundary))
916 (goto-char (point-max))))
921 (autoload 'epg-make-context "epg"))
924 (defvar epg-user-id-alist)
925 (defvar epg-digest-algorithm-alist)
926 (defvar inhibit-redisplay)
927 (autoload 'epg-context-set-armor "epg")
928 (autoload 'epg-context-set-textmode "epg")
929 (autoload 'epg-context-set-signers "epg")
930 (autoload 'epg-context-result-for "epg")
931 (autoload 'epg-new-signature-digest-algorithm "epg")
932 (autoload 'epg-verify-result-to-string "epg")
933 (autoload 'epg-list-keys "epg")
934 (autoload 'epg-decrypt-string "epg")
935 (autoload 'epg-verify-string "epg")
936 (autoload 'epg-sign-string "epg")
937 (autoload 'epg-encrypt-string "epg")
938 (autoload 'epg-passphrase-callback-function "epg")
939 (autoload 'epg-context-set-passphrase-callback "epg")
940 (autoload 'epg-configuration "epg-config")
941 (autoload 'epg-expand-group "epg-config"))
944 (defvar password-cache-expiry)
945 (autoload 'password-read "password")
946 (autoload 'password-cache-add "password")
947 (autoload 'password-cache-remove "password"))
949 (defvar mml2015-epg-secret-key-id-list nil)
951 (defun mml2015-epg-passphrase-callback (context key-id ignore)
953 (epg-passphrase-callback-function context key-id nil)
954 (let* ((entry (assoc key-id epg-user-id-alist))
957 (format "GnuPG passphrase for %s: "
965 (let ((password-cache-expiry mml2015-passphrase-cache-expiry))
966 (password-cache-add key-id passphrase))
967 (setq mml2015-epg-secret-key-id-list
968 (cons key-id mml2015-epg-secret-key-id-list))
969 (copy-sequence passphrase)))))
971 (defun mml2015-epg-decrypt (handle ctl)
973 (let ((inhibit-redisplay t)
974 context plain child handles result decrypt-status)
975 (unless (setq child (mm-find-part-by-type
977 "application/octet-stream" nil t))
978 (mm-set-handle-multipart-parameter
979 mm-security-handle 'gnus-info "Corrupted")
980 (throw 'error handle))
981 (setq context (epg-make-context))
982 (if mml2015-cache-passphrase
983 (epg-context-set-passphrase-callback
985 #'mml2015-epg-passphrase-callback))
986 (condition-case error
987 (setq plain (epg-decrypt-string context (mm-get-part child))
988 mml2015-epg-secret-key-id-list nil)
990 (while mml2015-epg-secret-key-id-list
991 (password-cache-remove (car mml2015-epg-secret-key-id-list))
992 (setq mml2015-epg-secret-key-id-list
993 (cdr mml2015-epg-secret-key-id-list)))
994 (mm-set-handle-multipart-parameter
995 mm-security-handle 'gnus-info "Failed")
996 (if (eq (car error) 'quit)
997 (mm-set-handle-multipart-parameter
998 mm-security-handle 'gnus-details "Quit.")
999 (mm-set-handle-multipart-parameter
1000 mm-security-handle 'gnus-details (mml2015-format-error error)))
1001 (throw 'error handle)))
1004 (goto-char (point-min))
1005 (while (search-forward "\r\n" nil t)
1006 (replace-match "\n" t t))
1007 (setq handles (mm-dissect-buffer t))
1008 (mm-destroy-parts handle)
1009 (if (epg-context-result-for context 'verify)
1010 (mm-set-handle-multipart-parameter
1011 mm-security-handle 'gnus-info
1013 (epg-verify-result-to-string
1014 (epg-context-result-for context 'verify))))
1015 (mm-set-handle-multipart-parameter
1016 mm-security-handle 'gnus-info "OK"))
1017 (if (stringp (car handles))
1018 (mm-set-handle-multipart-parameter
1019 mm-security-handle 'gnus-details
1020 (mm-handle-multipart-ctl-parameter handles 'gnus-details))))
1021 (if (listp (car handles))
1025 (defun mml2015-epg-clear-decrypt ()
1026 (let ((inhibit-redisplay t)
1027 (context (epg-make-context))
1029 (if mml2015-cache-passphrase
1030 (epg-context-set-passphrase-callback
1032 #'mml2015-epg-passphrase-callback))
1033 (condition-case error
1034 (setq plain (epg-decrypt-string context (buffer-string))
1035 mml2015-epg-secret-key-id-list nil)
1037 (while mml2015-epg-secret-key-id-list
1038 (password-cache-remove (car mml2015-epg-secret-key-id-list))
1039 (setq mml2015-epg-secret-key-id-list
1040 (cdr mml2015-epg-secret-key-id-list)))
1041 (mm-set-handle-multipart-parameter
1042 mm-security-handle 'gnus-info "Failed")
1043 (if (eq (car error) 'quit)
1044 (mm-set-handle-multipart-parameter
1045 mm-security-handle 'gnus-details "Quit.")
1046 (mm-set-handle-multipart-parameter
1047 mm-security-handle 'gnus-details (mml2015-format-error error)))))
1050 ;; Treat data which epg returns as a unibyte string.
1051 (mm-disable-multibyte)
1053 (goto-char (point-min))
1054 (while (search-forward "\r\n" nil t)
1055 (replace-match "\n" t t))
1056 (if (epg-context-result-for context 'verify)
1057 (mm-set-handle-multipart-parameter
1058 mm-security-handle 'gnus-info
1060 (epg-verify-result-to-string
1061 (epg-context-result-for context 'verify))))
1062 (mm-set-handle-multipart-parameter
1063 mm-security-handle 'gnus-info "OK")))))
1065 (defun mml2015-epg-verify (handle ctl)
1067 (let ((inhibit-redisplay t)
1068 context plain signature-file part signature)
1069 (when (or (null (setq part (mm-find-raw-part-by-type
1070 ctl (or (mm-handle-multipart-ctl-parameter
1072 "application/pgp-signature")
1074 (null (setq signature (mm-find-part-by-type
1075 (cdr handle) "application/pgp-signature"
1077 (mm-set-handle-multipart-parameter
1078 mm-security-handle 'gnus-info "Corrupted")
1079 (throw 'error handle))
1080 (setq context (epg-make-context))
1081 (condition-case error
1082 (setq plain (epg-verify-string context (mm-get-part signature) part))
1084 (mm-set-handle-multipart-parameter
1085 mm-security-handle 'gnus-info "Failed")
1086 (if (eq (car error) 'quit)
1087 (mm-set-handle-multipart-parameter
1088 mm-security-handle 'gnus-details "Quit.")
1089 (mm-set-handle-multipart-parameter
1090 mm-security-handle 'gnus-details (mml2015-format-error error)))
1091 (throw 'error handle)))
1092 (mm-set-handle-multipart-parameter
1093 mm-security-handle 'gnus-info
1094 (epg-verify-result-to-string (epg-context-result-for context 'verify)))
1097 (defun mml2015-epg-clear-verify ()
1098 (let ((inhibit-redisplay t)
1099 (context (epg-make-context))
1100 (signature (encode-coding-string (buffer-string)
1101 buffer-file-coding-system))
1103 (condition-case error
1104 (setq plain (epg-verify-string context signature))
1106 (mm-set-handle-multipart-parameter
1107 mm-security-handle 'gnus-info "Failed")
1108 (if (eq (car error) 'quit)
1109 (mm-set-handle-multipart-parameter
1110 mm-security-handle 'gnus-details "Quit.")
1111 (mm-set-handle-multipart-parameter
1112 mm-security-handle 'gnus-details (mml2015-format-error error)))))
1114 (mm-set-handle-multipart-parameter
1115 mm-security-handle 'gnus-info
1116 (epg-verify-result-to-string
1117 (epg-context-result-for context 'verify))))))
1119 (defun mml2015-epg-sign (cont)
1120 (let ((inhibit-redisplay t)
1121 (context (epg-make-context))
1122 (boundary (mml-compute-boundary cont))
1123 signers signature micalg)
1125 (setq signers (epa-select-keys context "Select keys for signing.
1126 If no one is selected, default secret key is used. "
1129 (setq signers (mapcar (lambda (name)
1130 (car (epg-list-keys context name t)))
1132 (epg-context-set-armor context t)
1133 (epg-context-set-textmode context t)
1134 (epg-context-set-signers context signers)
1135 (if mml2015-cache-passphrase
1136 (epg-context-set-passphrase-callback
1138 #'mml2015-epg-passphrase-callback))
1139 (condition-case error
1140 (setq signature (epg-sign-string context (buffer-string) t)
1141 mml2015-epg-secret-key-id-list nil)
1143 (while mml2015-epg-secret-key-id-list
1144 (password-cache-remove (car mml2015-epg-secret-key-id-list))
1145 (setq mml2015-epg-secret-key-id-list
1146 (cdr mml2015-epg-secret-key-id-list)))
1147 (signal (car error) (cdr error))))
1148 (if (epg-context-result-for context 'sign)
1149 (setq micalg (epg-new-signature-digest-algorithm
1150 (car (epg-context-result-for context 'sign)))))
1151 (goto-char (point-min))
1152 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
1155 (insert (format "\tmicalg=%s; "
1158 epg-digest-algorithm-alist))))))
1159 (insert "protocol=\"application/pgp-signature\"\n")
1160 (insert (format "\n--%s\n" boundary))
1161 (goto-char (point-max))
1162 (insert (format "\n--%s\n" boundary))
1163 (insert "Content-Type: application/pgp-signature\n\n")
1165 (goto-char (point-max))
1166 (insert (format "--%s--\n" boundary))
1167 (goto-char (point-max))))
1169 (defun mml2015-epg-encrypt (cont &optional sign)
1170 (let ((inhibit-redisplay t)
1171 (context (epg-make-context))
1173 (if (message-options-get 'message-recipients)
1175 (message-options-get 'message-recipients)
1176 "[ \f\t\n\r\v,]+")))
1177 cipher signers config
1178 (boundary (mml-compute-boundary cont)))
1179 ;; We should remove this check if epg-0.0.6 is released.
1180 (if (and (condition-case nil
1181 (require 'epg-config)
1183 (functionp #'epg-expand-group))
1184 (setq config (epg-configuration)
1187 (mapcar (lambda (recipient)
1188 (or (epg-expand-group config recipient)
1193 (epa-select-keys context "Select recipients for encryption.
1194 If no one is selected, symmetric encryption will be performed. "
1197 (delq nil (mapcar (lambda (name)
1198 (car (epg-list-keys context name)))
1200 (if mml2015-encrypt-to-self
1204 (mapcar (lambda (name)
1205 (car (epg-list-keys context name)))
1207 (error "mml2015-signers not set")))
1210 (setq signers (epa-select-keys context "Select keys for signing.
1211 If no one is selected, default secret key is used. "
1214 (setq signers (mapcar (lambda (name)
1215 (car (epg-list-keys context name t)))
1217 (epg-context-set-signers context signers))
1218 (epg-context-set-armor context t)
1219 (epg-context-set-textmode context t)
1220 (if mml2015-cache-passphrase
1221 (epg-context-set-passphrase-callback
1223 #'mml2015-epg-passphrase-callback))
1224 (condition-case error
1226 (epg-encrypt-string context (buffer-string) recipients sign)
1227 mml2015-epg-secret-key-id-list nil)
1229 (while mml2015-epg-secret-key-id-list
1230 (password-cache-remove (car mml2015-epg-secret-key-id-list))
1231 (setq mml2015-epg-secret-key-id-list
1232 (cdr mml2015-epg-secret-key-id-list)))
1233 (signal (car error) (cdr error))))
1234 (delete-region (point-min) (point-max))
1235 (goto-char (point-min))
1236 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
1238 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
1239 (insert (format "--%s\n" boundary))
1240 (insert "Content-Type: application/pgp-encrypted\n\n")
1241 (insert "Version: 1\n\n")
1242 (insert (format "--%s\n" boundary))
1243 (insert "Content-Type: application/octet-stream\n\n")
1245 (goto-char (point-max))
1246 (insert (format "--%s--\n" boundary))
1247 (goto-char (point-max))))
1251 (defun mml2015-clean-buffer ()
1252 (if (gnus-buffer-live-p mml2015-result-buffer)
1253 (with-current-buffer mml2015-result-buffer
1256 (setq mml2015-result-buffer
1257 (gnus-get-buffer-create " *MML2015 Result*"))
1260 (defsubst mml2015-clear-decrypt-function ()
1261 (nth 6 (assq mml2015-use mml2015-function-alist)))
1263 (defsubst mml2015-clear-verify-function ()
1264 (nth 5 (assq mml2015-use mml2015-function-alist)))
1267 (defun mml2015-decrypt (handle ctl)
1268 (mml2015-clean-buffer)
1269 (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
1271 (funcall func handle ctl)
1275 (defun mml2015-decrypt-test (handle ctl)
1279 (defun mml2015-verify (handle ctl)
1280 (mml2015-clean-buffer)
1281 (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
1283 (funcall func handle ctl)
1287 (defun mml2015-verify-test (handle ctl)
1291 (defun mml2015-encrypt (cont &optional sign)
1292 (mml2015-clean-buffer)
1293 (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
1295 (funcall func cont sign)
1296 (error "Cannot find encrypt function"))))
1299 (defun mml2015-sign (cont)
1300 (mml2015-clean-buffer)
1301 (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
1304 (error "Cannot find sign function"))))
1307 (defun mml2015-self-encrypt ()
1308 (mml2015-encrypt nil))
1312 ;;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2
1313 ;;; mml2015.el ends here