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
44 ;; Avoid the "Recursive load suspected" error
46 (let ((recursive-load-depth-limit 100))
48 (and (fboundp 'pgg-sign-region)
53 (and (fboundp 'gpg-sign-detached)
57 (and (fboundp 'mc-encrypt-generic)
58 (fboundp 'mc-sign-generic)
59 (fboundp 'mc-cleanup-recipient-headers)
61 "The package used for PGP/MIME.
62 Valid packages include `pgg', `gpg' and `mailcrypt'.")
64 ;; Something is not RFC2015.
65 (defvar mml2015-function-alist
66 '((mailcrypt mml2015-mailcrypt-sign
67 mml2015-mailcrypt-encrypt
68 mml2015-mailcrypt-verify
69 mml2015-mailcrypt-decrypt
70 mml2015-mailcrypt-clear-verify
71 mml2015-mailcrypt-clear-decrypt)
76 mml2015-gpg-clear-verify
77 mml2015-gpg-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-verbose nil
107 "If non-nil, ask the user about the current operation more verbosely."
108 :group 'mime-security
111 (defcustom mml2015-cache-passphrase t
112 "If t, cache passphrase."
113 :group 'mime-security
116 (defcustom mml2015-passphrase-cache-expiry 16
117 "How many seconds the passphrase is cached.
118 Whether the passphrase is cached at all is controlled by
119 `mml2015-cache-passphrase'."
120 :group 'mime-security
123 ;;; mailcrypt wrapper
126 (autoload 'mailcrypt-decrypt "mailcrypt")
127 (autoload 'mailcrypt-verify "mailcrypt")
128 (autoload 'mc-pgp-always-sign "mailcrypt")
129 (autoload 'mc-encrypt-generic "mc-toplev")
130 (autoload 'mc-cleanup-recipient-headers "mc-toplev")
131 (autoload 'mc-sign-generic "mc-toplev"))
134 (defvar mc-default-scheme)
137 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
138 (defvar mml2015-verify-function 'mailcrypt-verify)
140 (defun mml2015-format-error (err)
141 (if (stringp (cadr err))
143 (format "%S" (cdr err))))
145 (defun mml2015-mailcrypt-decrypt (handle ctl)
147 (let (child handles result)
148 (unless (setq child (mm-find-part-by-type
150 "application/octet-stream" nil t))
151 (mm-set-handle-multipart-parameter
152 mm-security-handle 'gnus-info "Corrupted")
153 (throw 'error handle))
155 (mm-insert-part child)
158 (funcall mml2015-decrypt-function)
160 (mm-set-handle-multipart-parameter
161 mm-security-handle 'gnus-details (mml2015-format-error err))
164 (mm-set-handle-multipart-parameter
165 mm-security-handle 'gnus-details "Quit.")
168 (mm-set-handle-multipart-parameter
169 mm-security-handle 'gnus-info "Failed")
170 (throw 'error handle))
171 (setq handles (mm-dissect-buffer t)))
172 (mm-destroy-parts handle)
173 (mm-set-handle-multipart-parameter
174 mm-security-handle 'gnus-info
176 (let ((sig (with-current-buffer mml2015-result-buffer
177 (mml2015-gpg-extract-signature-details))))
178 (concat ", Signer: " sig))))
179 (if (listp (car handles))
183 (defun mml2015-mailcrypt-clear-decrypt ()
187 (funcall mml2015-decrypt-function)
189 (mm-set-handle-multipart-parameter
190 mm-security-handle 'gnus-details (mml2015-format-error err))
193 (mm-set-handle-multipart-parameter
194 mm-security-handle 'gnus-details "Quit.")
197 (mm-set-handle-multipart-parameter
198 mm-security-handle 'gnus-info "OK")
199 (mm-set-handle-multipart-parameter
200 mm-security-handle 'gnus-info "Failed"))))
202 (defun mml2015-fix-micalg (alg)
204 ;; Mutt/1.2.5i has seen sending micalg=php-sha1
205 (upcase (if (string-match "^p[gh]p-" alg)
206 (substring alg (match-end 0))
209 (defun mml2015-mailcrypt-verify (handle ctl)
212 (unless (setq part (mm-find-raw-part-by-type
213 ctl (or (mm-handle-multipart-ctl-parameter
215 "application/pgp-signature")
217 (mm-set-handle-multipart-parameter
218 mm-security-handle 'gnus-info "Corrupted")
219 (throw 'error handle))
221 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
222 (insert (format "Hash: %s\n\n"
223 (or (mml2015-fix-micalg
224 (mm-handle-multipart-ctl-parameter
228 (narrow-to-region (point) (point))
230 (goto-char (point-min))
232 (if (looking-at "^-")
235 (unless (setq part (mm-find-part-by-type
236 (cdr handle) "application/pgp-signature" nil t))
237 (mm-set-handle-multipart-parameter
238 mm-security-handle 'gnus-info "Corrupted")
239 (throw 'error handle))
241 (narrow-to-region (point) (point))
242 (mm-insert-part part)
243 (goto-char (point-min))
244 (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
245 (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
246 (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
247 (replace-match "-----END PGP SIGNATURE-----" t t)))
248 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
249 (unless (condition-case err
251 (funcall mml2015-verify-function)
252 (if (get-buffer " *mailcrypt stderr temp")
253 (mm-set-handle-multipart-parameter
254 mm-security-handle 'gnus-details
255 (with-current-buffer " *mailcrypt stderr temp"
257 (if (get-buffer " *mailcrypt stdout temp")
258 (kill-buffer " *mailcrypt stdout temp"))
259 (if (get-buffer " *mailcrypt stderr temp")
260 (kill-buffer " *mailcrypt stderr temp"))
261 (if (get-buffer " *mailcrypt status temp")
262 (kill-buffer " *mailcrypt status temp"))
263 (if (get-buffer mc-gpg-debug-buffer)
264 (kill-buffer mc-gpg-debug-buffer)))
266 (mm-set-handle-multipart-parameter
267 mm-security-handle 'gnus-details (mml2015-format-error err))
270 (mm-set-handle-multipart-parameter
271 mm-security-handle 'gnus-details "Quit.")
273 (mm-set-handle-multipart-parameter
274 mm-security-handle 'gnus-info "Failed")
275 (throw 'error handle))))
276 (mm-set-handle-multipart-parameter
277 mm-security-handle 'gnus-info "OK")
280 (defun mml2015-mailcrypt-clear-verify ()
281 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
282 (if (condition-case err
284 (funcall mml2015-verify-function)
285 (if (get-buffer " *mailcrypt stderr temp")
286 (mm-set-handle-multipart-parameter
287 mm-security-handle 'gnus-details
288 (with-current-buffer " *mailcrypt stderr temp"
290 (if (get-buffer " *mailcrypt stdout temp")
291 (kill-buffer " *mailcrypt stdout temp"))
292 (if (get-buffer " *mailcrypt stderr temp")
293 (kill-buffer " *mailcrypt stderr temp"))
294 (if (get-buffer " *mailcrypt status temp")
295 (kill-buffer " *mailcrypt status temp"))
296 (if (get-buffer mc-gpg-debug-buffer)
297 (kill-buffer mc-gpg-debug-buffer)))
299 (mm-set-handle-multipart-parameter
300 mm-security-handle 'gnus-details (mml2015-format-error err))
303 (mm-set-handle-multipart-parameter
304 mm-security-handle 'gnus-details "Quit.")
306 (mm-set-handle-multipart-parameter
307 mm-security-handle 'gnus-info "OK")
308 (mm-set-handle-multipart-parameter
309 mm-security-handle 'gnus-info "Failed"))))
311 (defun mml2015-mailcrypt-sign (cont)
312 (mc-sign-generic (message-options-get 'message-sender)
314 (let ((boundary (mml-compute-boundary cont))
316 (goto-char (point-min))
317 (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
318 (error "Cannot find signed begin line"))
319 (goto-char (match-beginning 0))
321 (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
322 (error "Cannot not find PGP hash"))
323 (setq hash (match-string 1))
324 (unless (re-search-forward "^$" nil t)
325 (error "Cannot not find PGP message"))
327 (delete-region (point-min) (point))
328 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
330 (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
332 (insert (format "\n--%s\n" boundary))
334 (goto-char (point-max))
335 (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
336 (error "Cannot find signature part"))
337 (replace-match "-----END PGP MESSAGE-----" t t)
338 (goto-char (match-beginning 0))
339 (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
341 (error "Cannot find signature part"))
342 (replace-match "-----BEGIN PGP MESSAGE-----" t t)
343 (goto-char (match-beginning 0))
345 (narrow-to-region point (point))
347 (while (re-search-forward "^- -" nil t)
348 (replace-match "-" t t))
349 (goto-char (point-max)))
350 (insert (format "--%s\n" boundary))
351 (insert "Content-Type: application/pgp-signature\n\n")
352 (goto-char (point-max))
353 (insert (format "--%s--\n" boundary))
354 (goto-char (point-max))))
356 (defun mml2015-mailcrypt-encrypt (cont &optional sign)
357 (let ((mc-pgp-always-sign
358 (or mc-pgp-always-sign
360 (eq t (or (message-options-get 'message-sign-encrypt)
362 'message-sign-encrypt
363 (or (y-or-n-p "Sign the message? ")
366 (mm-with-unibyte-current-buffer
368 (or (message-options-get 'message-recipients)
369 (message-options-set 'message-recipients
370 (mc-cleanup-recipient-headers
371 (read-string "Recipients: "))))
373 (message-options-get 'message-sender))))
374 (goto-char (point-min))
375 (unless (looking-at "-----BEGIN PGP MESSAGE-----")
376 (error "Fail to encrypt the message"))
377 (let ((boundary (mml-compute-boundary cont)))
378 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
380 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
381 (insert (format "--%s\n" boundary))
382 (insert "Content-Type: application/pgp-encrypted\n\n")
383 (insert "Version: 1\n\n")
384 (insert (format "--%s\n" boundary))
385 (insert "Content-Type: application/octet-stream\n\n")
386 (goto-char (point-max))
387 (insert (format "--%s--\n" boundary))
388 (goto-char (point-max))))
393 (autoload 'gpg-decrypt "gpg")
394 (autoload 'gpg-verify "gpg")
395 (autoload 'gpg-verify-cleartext "gpg")
396 (autoload 'gpg-sign-detached "gpg")
397 (autoload 'gpg-sign-encrypt "gpg")
398 (autoload 'gpg-encrypt "gpg")
399 (autoload 'gpg-passphrase-read "gpg"))
401 (defun mml2015-gpg-passphrase ()
402 (or (message-options-get 'gpg-passphrase)
403 (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
405 (defun mml2015-gpg-decrypt-1 ()
406 (let ((cipher (current-buffer)) plain result)
407 (if (with-temp-buffer
409 (gpg-decrypt cipher (setq plain (current-buffer))
410 mml2015-result-buffer nil)
411 (mm-set-handle-multipart-parameter
412 mm-security-handle 'gnus-details
413 (with-current-buffer mml2015-result-buffer
417 (insert-buffer-substring plain)
418 (goto-char (point-min))
419 (while (search-forward "\r\n" nil t)
420 (replace-match "\n" t t))))
422 ;; Some wrong with the return value, check plain text buffer.
423 (if (> (point-max) (point-min))
427 (defun mml2015-gpg-decrypt (handle ctl)
428 (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
429 (mml2015-mailcrypt-decrypt handle ctl)))
431 (defun mml2015-gpg-clear-decrypt ()
433 (setq result (mml2015-gpg-decrypt-1))
435 (mm-set-handle-multipart-parameter
436 mm-security-handle 'gnus-info "OK")
437 (mm-set-handle-multipart-parameter
438 mm-security-handle 'gnus-info "Failed"))))
440 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
442 (fpr-length (string-width fingerprint))
445 (setq fingerprint (string-to-list fingerprint))
447 (setq fpr-length (- fpr-length 4))
448 (setq slice (butlast fingerprint fpr-length))
449 (setq fingerprint (nthcdr 4 fingerprint))
450 (setq n-slice (1+ n-slice))
456 (otherwise (concat " " slice))))))
459 (defun mml2015-gpg-extract-signature-details ()
460 (goto-char (point-min))
461 (let* ((expired (re-search-forward
462 "^\\[GNUPG:\\] SIGEXPIRED$"
464 (signer (and (re-search-forward
465 "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
467 (cons (match-string 1) (match-string 2))))
468 (fprint (and (re-search-forward
469 "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
472 (trust (and (re-search-forward
473 "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
477 (cdr (assoc trust mml2015-unabbrev-trust-alist))))
478 (cond ((and signer fprint)
480 (unless trust-good-enough-p
481 (concat "\nUntrusted, Fingerprint: "
482 (mml2015-gpg-pretty-print-fpr fprint)))
484 (format "\nWARNING: Signature from expired key (%s)"
487 "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
490 "From unknown user"))))
492 (defun mml2015-gpg-verify (handle ctl)
494 (let (part message signature info-is-set-p)
495 (unless (setq part (mm-find-raw-part-by-type
496 ctl (or (mm-handle-multipart-ctl-parameter
498 "application/pgp-signature")
500 (mm-set-handle-multipart-parameter
501 mm-security-handle 'gnus-info "Corrupted")
502 (throw 'error handle))
504 (setq message (current-buffer))
506 ;; Convert <LF> to <CR><LF> in verify mode. Sign and
507 ;; clearsign use --textmode. The conversion is not necessary.
508 ;; In clearverify, the conversion is not necessary either.
509 (goto-char (point-min))
512 (unless (eq (char-before) ?\r)
517 (setq signature (current-buffer))
518 (unless (setq part (mm-find-part-by-type
519 (cdr handle) "application/pgp-signature" nil t))
520 (mm-set-handle-multipart-parameter
521 mm-security-handle 'gnus-info "Corrupted")
522 (throw 'error handle))
523 (mm-insert-part part)
524 (unless (condition-case err
526 (gpg-verify message signature mml2015-result-buffer)
527 (mm-set-handle-multipart-parameter
528 mm-security-handle 'gnus-details
529 (with-current-buffer mml2015-result-buffer
532 (mm-set-handle-multipart-parameter
533 mm-security-handle 'gnus-details (mml2015-format-error err))
534 (mm-set-handle-multipart-parameter
535 mm-security-handle 'gnus-info "Error.")
536 (setq info-is-set-p t)
539 (mm-set-handle-multipart-parameter
540 mm-security-handle 'gnus-details "Quit.")
541 (mm-set-handle-multipart-parameter
542 mm-security-handle 'gnus-info "Quit.")
543 (setq info-is-set-p t)
545 (unless info-is-set-p
546 (mm-set-handle-multipart-parameter
547 mm-security-handle 'gnus-info "Failed"))
548 (throw 'error handle)))
549 (mm-set-handle-multipart-parameter
550 mm-security-handle 'gnus-info
551 (with-current-buffer mml2015-result-buffer
552 (mml2015-gpg-extract-signature-details))))
555 (defun mml2015-gpg-clear-verify ()
556 (if (condition-case err
558 (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
559 (mm-set-handle-multipart-parameter
560 mm-security-handle 'gnus-details
561 (with-current-buffer mml2015-result-buffer
564 (mm-set-handle-multipart-parameter
565 mm-security-handle 'gnus-details (mml2015-format-error err))
568 (mm-set-handle-multipart-parameter
569 mm-security-handle 'gnus-details "Quit.")
571 (mm-set-handle-multipart-parameter
572 mm-security-handle 'gnus-info
573 (with-current-buffer mml2015-result-buffer
574 (mml2015-gpg-extract-signature-details)))
575 (mm-set-handle-multipart-parameter
576 mm-security-handle 'gnus-info "Failed")))
578 (defun mml2015-gpg-sign (cont)
579 (let ((boundary (mml-compute-boundary cont))
580 (text (current-buffer)) signature)
581 (goto-char (point-max))
585 (unless (gpg-sign-detached text (setq signature (current-buffer))
586 mml2015-result-buffer
588 (message-options-get 'message-sender)
589 t t) ; armor & textmode
590 (unless (> (point-max) (point-min))
591 (pop-to-buffer mml2015-result-buffer)
592 (error "Sign error")))
593 (goto-char (point-min))
594 (while (re-search-forward "\r+$" nil t)
595 (replace-match "" t t))
597 (goto-char (point-min))
598 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
600 ;;; FIXME: what is the micalg?
601 (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
602 (insert (format "\n--%s\n" boundary))
603 (goto-char (point-max))
604 (insert (format "\n--%s\n" boundary))
605 (insert "Content-Type: application/pgp-signature\n\n")
606 (insert-buffer-substring signature)
607 (goto-char (point-max))
608 (insert (format "--%s--\n" boundary))
609 (goto-char (point-max)))))
611 (defun mml2015-gpg-encrypt (cont &optional sign)
612 (let ((boundary (mml-compute-boundary cont))
613 (text (current-buffer))
615 (mm-with-unibyte-current-buffer
617 ;; set up a function to call the correct gpg encrypt routine
618 ;; with the right arguments. (FIXME: this should be done
620 (flet ((gpg-encrypt-func
621 (sign plaintext ciphertext result recipients &optional
622 passphrase sign-with-key armor textmode)
625 plaintext ciphertext result recipients passphrase
626 sign-with-key armor textmode)
628 plaintext ciphertext result recipients passphrase
630 (unless (gpg-encrypt-func
631 sign ; passed in when using signencrypt
632 text (setq cipher (current-buffer))
633 mml2015-result-buffer
636 (message-options-get 'message-recipients)
637 (message-options-set 'message-recipients
638 (read-string "Recipients: ")))
641 (message-options-get 'message-sender)
642 t t) ; armor & textmode
643 (unless (> (point-max) (point-min))
644 (pop-to-buffer mml2015-result-buffer)
645 (error "Encrypt error"))))
646 (goto-char (point-min))
647 (while (re-search-forward "\r+$" nil t)
648 (replace-match "" t t))
650 (delete-region (point-min) (point-max))
651 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
653 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
654 (insert (format "--%s\n" boundary))
655 (insert "Content-Type: application/pgp-encrypted\n\n")
656 (insert "Version: 1\n\n")
657 (insert (format "--%s\n" boundary))
658 (insert "Content-Type: application/octet-stream\n\n")
659 (insert-buffer-substring cipher)
660 (goto-char (point-max))
661 (insert (format "--%s--\n" boundary))
662 (goto-char (point-max))))))
667 (defvar pgg-default-user-id)
668 (defvar pgg-errors-buffer)
669 (defvar pgg-output-buffer))
672 (autoload 'pgg-decrypt-region "pgg")
673 (autoload 'pgg-verify-region "pgg")
674 (autoload 'pgg-sign-region "pgg")
675 (autoload 'pgg-encrypt-region "pgg")
676 (autoload 'pgg-parse-armor "pgg-parse"))
678 (defun mml2015-pgg-decrypt (handle ctl)
680 (let ((pgg-errors-buffer mml2015-result-buffer)
681 child handles result decrypt-status)
682 (unless (setq child (mm-find-part-by-type
684 "application/octet-stream" nil t))
685 (mm-set-handle-multipart-parameter
686 mm-security-handle 'gnus-info "Corrupted")
687 (throw 'error handle))
689 (mm-insert-part child)
690 (if (condition-case err
692 (pgg-decrypt-region (point-min) (point-max))
694 (with-current-buffer mml2015-result-buffer
696 (mm-set-handle-multipart-parameter
697 mm-security-handle 'gnus-details
700 (mm-set-handle-multipart-parameter
701 mm-security-handle 'gnus-details (mml2015-format-error err))
704 (mm-set-handle-multipart-parameter
705 mm-security-handle 'gnus-details "Quit.")
707 (with-current-buffer pgg-output-buffer
708 (goto-char (point-min))
709 (while (search-forward "\r\n" nil t)
710 (replace-match "\n" t t))
711 (setq handles (mm-dissect-buffer t))
712 (mm-destroy-parts handle)
713 (mm-set-handle-multipart-parameter
714 mm-security-handle 'gnus-info "OK")
715 (mm-set-handle-multipart-parameter
716 mm-security-handle 'gnus-details
717 (concat decrypt-status
718 (when (stringp (car handles))
719 "\n" (mm-handle-multipart-ctl-parameter
720 handles 'gnus-details))))
721 (if (listp (car handles))
724 (mm-set-handle-multipart-parameter
725 mm-security-handle 'gnus-info "Failed")
726 (throw 'error handle))))))
728 (defun mml2015-pgg-clear-decrypt ()
729 (let ((pgg-errors-buffer mml2015-result-buffer))
731 (pgg-decrypt-region (point-min) (point-max))
732 (mm-set-handle-multipart-parameter
733 mm-security-handle 'gnus-details
734 (with-current-buffer mml2015-result-buffer
738 ;; Treat data which pgg returns as a unibyte string.
739 (mm-disable-multibyte)
740 (insert-buffer-substring pgg-output-buffer)
741 (goto-char (point-min))
742 (while (search-forward "\r\n" nil t)
743 (replace-match "\n" t t))
744 (mm-set-handle-multipart-parameter
745 mm-security-handle 'gnus-info "OK"))
746 (mm-set-handle-multipart-parameter
747 mm-security-handle 'gnus-info "Failed"))))
749 (defun mml2015-pgg-verify (handle ctl)
750 (let ((pgg-errors-buffer mml2015-result-buffer)
751 signature-file part signature)
752 (if (or (null (setq part (mm-find-raw-part-by-type
753 ctl (or (mm-handle-multipart-ctl-parameter
755 "application/pgp-signature")
757 (null (setq signature (mm-find-part-by-type
758 (cdr handle) "application/pgp-signature" nil t))))
760 (mm-set-handle-multipart-parameter
761 mm-security-handle 'gnus-info "Corrupted")
765 ;; Convert <LF> to <CR><LF> in verify mode. Sign and
766 ;; clearsign use --textmode. The conversion is not necessary.
767 ;; In clearverify, the conversion is not necessary either.
768 (goto-char (point-min))
771 (unless (eq (char-before) ?\r)
775 (with-temp-file (setq signature-file (mm-make-temp-file "pgg"))
776 (mm-insert-part signature))
777 (if (condition-case err
779 (pgg-verify-region (point-min) (point-max)
781 (goto-char (point-min))
782 (while (search-forward "\r\n" nil t)
783 (replace-match "\n" t t))
784 (mm-set-handle-multipart-parameter
785 mm-security-handle 'gnus-details
786 (concat (with-current-buffer pgg-output-buffer
788 (with-current-buffer pgg-errors-buffer
791 (mm-set-handle-multipart-parameter
792 mm-security-handle 'gnus-details (mml2015-format-error err))
795 (mm-set-handle-multipart-parameter
796 mm-security-handle 'gnus-details "Quit.")
799 (delete-file signature-file)
800 (mm-set-handle-multipart-parameter
801 mm-security-handle 'gnus-info
802 (with-current-buffer pgg-errors-buffer
803 (mml2015-gpg-extract-signature-details))))
804 (delete-file signature-file)
805 (mm-set-handle-multipart-parameter
806 mm-security-handle 'gnus-info "Failed")))))
809 (defun mml2015-pgg-clear-verify ()
810 (let ((pgg-errors-buffer mml2015-result-buffer)
811 (text (buffer-string))
812 (coding-system buffer-file-coding-system))
813 (if (condition-case err
815 (mm-with-unibyte-buffer
816 (insert (encode-coding-string text coding-system))
817 (pgg-verify-region (point-min) (point-max) nil t))
818 (goto-char (point-min))
819 (while (search-forward "\r\n" nil t)
820 (replace-match "\n" t t))
821 (mm-set-handle-multipart-parameter
822 mm-security-handle 'gnus-details
823 (concat (with-current-buffer pgg-output-buffer
825 (with-current-buffer pgg-errors-buffer
828 (mm-set-handle-multipart-parameter
829 mm-security-handle 'gnus-details (mml2015-format-error err))
832 (mm-set-handle-multipart-parameter
833 mm-security-handle 'gnus-details "Quit.")
835 (mm-set-handle-multipart-parameter
836 mm-security-handle 'gnus-info
837 (with-current-buffer pgg-errors-buffer
838 (mml2015-gpg-extract-signature-details)))
839 (mm-set-handle-multipart-parameter
840 mm-security-handle 'gnus-info "Failed"))))
842 (defun mml2015-pgg-sign (cont)
843 (let ((pgg-errors-buffer mml2015-result-buffer)
844 (boundary (mml-compute-boundary cont))
845 (pgg-default-user-id (or (message-options-get 'mml-sender)
846 pgg-default-user-id))
849 (unless (pgg-sign-region (point-min) (point-max))
850 (pop-to-buffer mml2015-result-buffer)
851 (error "Sign error"))
852 (goto-char (point-min))
853 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
855 (if (setq entry (assq 2 (pgg-parse-armor
856 (with-current-buffer pgg-output-buffer
858 (setq entry (assq 'hash-algorithm (cdr entry))))
859 (insert (format "\tmicalg=%s; "
861 (downcase (format "pgp-%s" (cdr entry)))
863 (insert "protocol=\"application/pgp-signature\"\n")
864 (insert (format "\n--%s\n" boundary))
865 (goto-char (point-max))
866 (insert (format "\n--%s\n" boundary))
867 (insert "Content-Type: application/pgp-signature\n\n")
868 (insert-buffer-substring pgg-output-buffer)
869 (goto-char (point-max))
870 (insert (format "--%s--\n" boundary))
871 (goto-char (point-max))))
873 (defun mml2015-pgg-encrypt (cont &optional sign)
874 (let ((pgg-errors-buffer mml2015-result-buffer)
876 (boundary (mml-compute-boundary cont)))
877 (unless (pgg-encrypt-region (point-min) (point-max)
880 (message-options-get 'message-recipients)
881 (message-options-set 'message-recipients
882 (read-string "Recipients: ")))
885 (pop-to-buffer mml2015-result-buffer)
886 (error "Encrypt error"))
887 (delete-region (point-min) (point-max))
888 (goto-char (point-min))
889 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
891 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
892 (insert (format "--%s\n" boundary))
893 (insert "Content-Type: application/pgp-encrypted\n\n")
894 (insert "Version: 1\n\n")
895 (insert (format "--%s\n" boundary))
896 (insert "Content-Type: application/octet-stream\n\n")
897 (insert-buffer-substring pgg-output-buffer)
898 (goto-char (point-max))
899 (insert (format "--%s--\n" boundary))
900 (goto-char (point-max))))
905 (autoload 'epg-make-context "epg"))
908 (defvar epg-user-id-alist)
909 (defvar epg-digest-algorithm-alist)
910 (defvar inhibit-redisplay)
911 (autoload 'epg-context-set-armor "epg")
912 (autoload 'epg-context-set-textmode "epg")
913 (autoload 'epg-context-set-signers "epg")
914 (autoload 'epg-context-result-for "epg")
915 (autoload 'epg-new-signature-digest-algorithm "epg")
916 (autoload 'epg-verify-result-to-string "epg")
917 (autoload 'epg-list-keys "epg")
918 (autoload 'epg-decrypt-string "epg")
919 (autoload 'epg-verify-string "epg")
920 (autoload 'epg-sign-string "epg")
921 (autoload 'epg-encrypt-string "epg")
922 (autoload 'epg-passphrase-callback-function "epg")
923 (autoload 'epg-context-set-passphrase-callback "epg"))
925 (defvar mml2015-epg-secret-key-id-list nil)
927 (defun mml2015-epg-passphrase-callback (context key-id ignore)
929 (epg-passphrase-callback-function context key-id nil)
930 (let* ((entry (assoc key-id epg-user-id-alist))
933 (format "GnuPG passphrase for %s: "
941 (let ((password-cache-expiry mml2015-passphrase-cache-expiry))
942 (password-cache-add key-id passphrase))
943 (setq mml2015-epg-secret-key-id-list
944 (cons key-id mml2015-epg-secret-key-id-list))
945 (copy-sequence passphrase)))))
947 (defun mml2015-epg-decrypt (handle ctl)
949 (let ((inhibit-redisplay t)
950 context plain child handles result decrypt-status)
951 (unless (setq child (mm-find-part-by-type
953 "application/octet-stream" nil t))
954 (mm-set-handle-multipart-parameter
955 mm-security-handle 'gnus-info "Corrupted")
956 (throw 'error handle))
957 (setq context (epg-make-context))
958 (if mml2015-cache-passphrase
959 (epg-context-set-passphrase-callback
961 #'mml2015-epg-passphrase-callback))
962 (condition-case error
963 (setq plain (epg-decrypt-string context (mm-get-part child))
964 mml2015-epg-secret-key-id-list nil)
966 (while mml2015-epg-secret-key-id-list
967 (password-cache-remove (car mml2015-epg-secret-key-id-list))
968 (setq mml2015-epg-secret-key-id-list
969 (cdr mml2015-epg-secret-key-id-list)))
970 (mm-set-handle-multipart-parameter
971 mm-security-handle 'gnus-info "Failed")
972 (if (eq (car error) 'quit)
973 (mm-set-handle-multipart-parameter
974 mm-security-handle 'gnus-details "Quit.")
975 (mm-set-handle-multipart-parameter
976 mm-security-handle 'gnus-details (mml2015-format-error error)))
977 (throw 'error handle)))
980 (goto-char (point-min))
981 (while (search-forward "\r\n" nil t)
982 (replace-match "\n" t t))
983 (setq handles (mm-dissect-buffer t))
984 (mm-destroy-parts handle)
985 (if (epg-context-result-for context 'verify)
986 (mm-set-handle-multipart-parameter
987 mm-security-handle 'gnus-info
989 (epg-verify-result-to-string
990 (epg-context-result-for context 'verify))))
991 (mm-set-handle-multipart-parameter
992 mm-security-handle 'gnus-info "OK"))
993 (if (stringp (car handles))
994 (mm-set-handle-multipart-parameter
995 mm-security-handle 'gnus-details
996 (mm-handle-multipart-ctl-parameter handles 'gnus-details))))
997 (if (listp (car handles))
1001 (defun mml2015-epg-clear-decrypt ()
1002 (let ((inhibit-redisplay t)
1003 (context (epg-make-context))
1005 (if mml2015-cache-passphrase
1006 (epg-context-set-passphrase-callback
1008 #'mml2015-epg-passphrase-callback))
1009 (condition-case error
1010 (setq plain (epg-decrypt-string context (buffer-string))
1011 mml2015-epg-secret-key-id-list nil)
1013 (while mml2015-epg-secret-key-id-list
1014 (password-cache-remove (car mml2015-epg-secret-key-id-list))
1015 (setq mml2015-epg-secret-key-id-list
1016 (cdr mml2015-epg-secret-key-id-list)))
1017 (mm-set-handle-multipart-parameter
1018 mm-security-handle 'gnus-info "Failed")
1019 (if (eq (car error) 'quit)
1020 (mm-set-handle-multipart-parameter
1021 mm-security-handle 'gnus-details "Quit.")
1022 (mm-set-handle-multipart-parameter
1023 mm-security-handle 'gnus-details (mml2015-format-error error)))))
1026 ;; Treat data which epg returns as a unibyte string.
1027 (mm-disable-multibyte)
1029 (goto-char (point-min))
1030 (while (search-forward "\r\n" nil t)
1031 (replace-match "\n" t t))
1032 (if (epg-context-result-for context 'verify)
1033 (mm-set-handle-multipart-parameter
1034 mm-security-handle 'gnus-info
1036 (epg-verify-result-to-string
1037 (epg-context-result-for context 'verify))))
1038 (mm-set-handle-multipart-parameter
1039 mm-security-handle 'gnus-info "OK")))))
1041 (defun mml2015-epg-verify (handle ctl)
1043 (let ((inhibit-redisplay t)
1044 context plain signature-file part signature)
1045 (when (or (null (setq part (mm-find-raw-part-by-type
1046 ctl (or (mm-handle-multipart-ctl-parameter
1048 "application/pgp-signature")
1050 (null (setq signature (mm-find-part-by-type
1051 (cdr handle) "application/pgp-signature"
1053 (mm-set-handle-multipart-parameter
1054 mm-security-handle 'gnus-info "Corrupted")
1055 (throw 'error handle))
1056 (setq context (epg-make-context))
1057 (condition-case error
1058 (setq plain (epg-verify-string context (mm-get-part signature) part))
1060 (mm-set-handle-multipart-parameter
1061 mm-security-handle 'gnus-info "Failed")
1062 (if (eq (car error) 'quit)
1063 (mm-set-handle-multipart-parameter
1064 mm-security-handle 'gnus-details "Quit.")
1065 (mm-set-handle-multipart-parameter
1066 mm-security-handle 'gnus-details (mml2015-format-error error)))
1067 (throw 'error handle)))
1068 (mm-set-handle-multipart-parameter
1069 mm-security-handle 'gnus-info
1070 (epg-verify-result-to-string (epg-context-result-for context 'verify)))
1073 (defun mml2015-epg-clear-verify ()
1074 (let ((inhibit-redisplay t)
1075 (context (epg-make-context))
1076 (signature (encode-coding-string (buffer-string)
1077 buffer-file-coding-system))
1079 (condition-case error
1080 (setq plain (epg-verify-string context signature))
1082 (mm-set-handle-multipart-parameter
1083 mm-security-handle 'gnus-info "Failed")
1084 (if (eq (car error) 'quit)
1085 (mm-set-handle-multipart-parameter
1086 mm-security-handle 'gnus-details "Quit.")
1087 (mm-set-handle-multipart-parameter
1088 mm-security-handle 'gnus-details (mml2015-format-error error)))))
1090 (mm-set-handle-multipart-parameter
1091 mm-security-handle 'gnus-info
1092 (epg-verify-result-to-string
1093 (epg-context-result-for context 'verify))))))
1095 (defun mml2015-epg-sign (cont)
1096 (let ((inhibit-redisplay t)
1097 (context (epg-make-context))
1098 (boundary (mml-compute-boundary cont))
1099 signers signature micalg)
1101 (setq signers (epa-select-keys context "Select keys for signing.
1102 If no one is selected, default secret key is used. "
1104 (setq signers (list (car (epg-list-keys
1106 (message-options-get 'mml-sender) t)))))
1107 (epg-context-set-armor context t)
1108 (epg-context-set-textmode context t)
1109 (epg-context-set-signers context signers)
1110 (if mml2015-cache-passphrase
1111 (epg-context-set-passphrase-callback
1113 #'mml2015-epg-passphrase-callback))
1114 (condition-case error
1115 (setq signature (epg-sign-string context (buffer-string) t)
1116 mml2015-epg-secret-key-id-list nil)
1118 (while mml2015-epg-secret-key-id-list
1119 (password-cache-remove (car mml2015-epg-secret-key-id-list))
1120 (setq mml2015-epg-secret-key-id-list
1121 (cdr mml2015-epg-secret-key-id-list)))
1122 (signal (car error) (cdr error))))
1123 (if (epg-context-result-for context 'sign)
1124 (setq micalg (epg-new-signature-digest-algorithm
1125 (car (epg-context-result-for context 'sign)))))
1126 (goto-char (point-min))
1127 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
1130 (insert (format "\tmicalg=%s; "
1133 epg-digest-algorithm-alist))))))
1134 (insert "protocol=\"application/pgp-signature\"\n")
1135 (insert (format "\n--%s\n" boundary))
1136 (goto-char (point-max))
1137 (insert (format "\n--%s\n" boundary))
1138 (insert "Content-Type: application/pgp-signature\n\n")
1140 (goto-char (point-max))
1141 (insert (format "--%s--\n" boundary))
1142 (goto-char (point-max))))
1144 (defun mml2015-epg-encrypt (cont &optional sign)
1145 (let ((inhibit-redisplay t)
1146 (context (epg-make-context))
1148 (boundary (mml-compute-boundary cont)))
1149 (if (or mml2015-verbose
1150 (null (message-options-get 'message-recipients)))
1152 (epa-select-keys context "Select recipients for encryption.
1153 If no one is selected, symmetric encryption will be performed. "
1154 (if (message-options-get 'message-recipients)
1156 (message-options-get 'message-recipients)
1157 "[ \f\t\n\r\v,]+"))))
1159 (mapcar (lambda (name)
1160 (car (epg-list-keys context name)))
1162 (message-options-get 'message-recipients)
1163 "[ \f\t\n\r\v,]+"))))
1164 (epg-context-set-armor context t)
1165 (epg-context-set-textmode context t)
1166 (if mml2015-cache-passphrase
1167 (epg-context-set-passphrase-callback
1169 #'mml2015-epg-passphrase-callback))
1170 (condition-case error
1172 (epg-encrypt-string context (buffer-string) recipients sign)
1173 mml2015-epg-secret-key-id-list nil)
1175 (while mml2015-epg-secret-key-id-list
1176 (password-cache-remove (car mml2015-epg-secret-key-id-list))
1177 (setq mml2015-epg-secret-key-id-list
1178 (cdr mml2015-epg-secret-key-id-list)))
1179 (signal (car error) (cdr error))))
1180 (delete-region (point-min) (point-max))
1181 (goto-char (point-min))
1182 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
1184 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
1185 (insert (format "--%s\n" boundary))
1186 (insert "Content-Type: application/pgp-encrypted\n\n")
1187 (insert "Version: 1\n\n")
1188 (insert (format "--%s\n" boundary))
1189 (insert "Content-Type: application/octet-stream\n\n")
1191 (goto-char (point-max))
1192 (insert (format "--%s--\n" boundary))
1193 (goto-char (point-max))))
1197 (defun mml2015-clean-buffer ()
1198 (if (gnus-buffer-live-p mml2015-result-buffer)
1199 (with-current-buffer mml2015-result-buffer
1202 (setq mml2015-result-buffer
1203 (gnus-get-buffer-create " *MML2015 Result*"))
1206 (defsubst mml2015-clear-decrypt-function ()
1207 (nth 6 (assq mml2015-use mml2015-function-alist)))
1209 (defsubst mml2015-clear-verify-function ()
1210 (nth 5 (assq mml2015-use mml2015-function-alist)))
1213 (defun mml2015-decrypt (handle ctl)
1214 (mml2015-clean-buffer)
1215 (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
1217 (funcall func handle ctl)
1221 (defun mml2015-decrypt-test (handle ctl)
1225 (defun mml2015-verify (handle ctl)
1226 (mml2015-clean-buffer)
1227 (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
1229 (funcall func handle ctl)
1233 (defun mml2015-verify-test (handle ctl)
1237 (defun mml2015-encrypt (cont &optional sign)
1238 (mml2015-clean-buffer)
1239 (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
1241 (funcall func cont sign)
1242 (error "Cannot find encrypt function"))))
1245 (defun mml2015-sign (cont)
1246 (mml2015-clean-buffer)
1247 (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
1250 (error "Cannot find sign function"))))
1253 (defun mml2015-self-encrypt ()
1254 (mml2015-encrypt nil))
1258 ;;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2
1259 ;;; mml2015.el ends here