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 mml-secure-verbose
107 "If non-nil, ask the user about the current operation more verbosely."
108 :group 'mime-security
111 (defcustom mml2015-cache-passphrase mml-secure-cache-passphrase
112 "If t, cache passphrase."
113 :group 'mime-security
116 (defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
117 "How many seconds the passphrase is cached.
118 Whether the passphrase is cached at all is controlled by
119 `mml2015-cache-passphrase'."
120 :group 'mime-security
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"))
926 (defvar password-cache-expiry)
927 (autoload 'password-read "password")
928 (autoload 'password-cache-add "password")
929 (autoload 'password-cache-remove "password"))
931 (defvar mml2015-epg-secret-key-id-list nil)
933 (defun mml2015-epg-passphrase-callback (context key-id ignore)
935 (epg-passphrase-callback-function context key-id nil)
936 (let* ((entry (assoc key-id epg-user-id-alist))
939 (format "GnuPG passphrase for %s: "
947 (let ((password-cache-expiry mml2015-passphrase-cache-expiry))
948 (password-cache-add key-id passphrase))
949 (setq mml2015-epg-secret-key-id-list
950 (cons key-id mml2015-epg-secret-key-id-list))
951 (copy-sequence passphrase)))))
953 (defun mml2015-epg-decrypt (handle ctl)
955 (let ((inhibit-redisplay t)
956 context plain child handles result decrypt-status)
957 (unless (setq child (mm-find-part-by-type
959 "application/octet-stream" nil t))
960 (mm-set-handle-multipart-parameter
961 mm-security-handle 'gnus-info "Corrupted")
962 (throw 'error handle))
963 (setq context (epg-make-context))
964 (if mml2015-cache-passphrase
965 (epg-context-set-passphrase-callback
967 #'mml2015-epg-passphrase-callback))
968 (condition-case error
969 (setq plain (epg-decrypt-string context (mm-get-part child))
970 mml2015-epg-secret-key-id-list nil)
972 (while mml2015-epg-secret-key-id-list
973 (password-cache-remove (car mml2015-epg-secret-key-id-list))
974 (setq mml2015-epg-secret-key-id-list
975 (cdr mml2015-epg-secret-key-id-list)))
976 (mm-set-handle-multipart-parameter
977 mm-security-handle 'gnus-info "Failed")
978 (if (eq (car error) 'quit)
979 (mm-set-handle-multipart-parameter
980 mm-security-handle 'gnus-details "Quit.")
981 (mm-set-handle-multipart-parameter
982 mm-security-handle 'gnus-details (mml2015-format-error error)))
983 (throw 'error handle)))
986 (goto-char (point-min))
987 (while (search-forward "\r\n" nil t)
988 (replace-match "\n" t t))
989 (setq handles (mm-dissect-buffer t))
990 (mm-destroy-parts handle)
991 (if (epg-context-result-for context 'verify)
992 (mm-set-handle-multipart-parameter
993 mm-security-handle 'gnus-info
995 (epg-verify-result-to-string
996 (epg-context-result-for context 'verify))))
997 (mm-set-handle-multipart-parameter
998 mm-security-handle 'gnus-info "OK"))
999 (if (stringp (car handles))
1000 (mm-set-handle-multipart-parameter
1001 mm-security-handle 'gnus-details
1002 (mm-handle-multipart-ctl-parameter handles 'gnus-details))))
1003 (if (listp (car handles))
1007 (defun mml2015-epg-clear-decrypt ()
1008 (let ((inhibit-redisplay t)
1009 (context (epg-make-context))
1011 (if mml2015-cache-passphrase
1012 (epg-context-set-passphrase-callback
1014 #'mml2015-epg-passphrase-callback))
1015 (condition-case error
1016 (setq plain (epg-decrypt-string context (buffer-string))
1017 mml2015-epg-secret-key-id-list nil)
1019 (while mml2015-epg-secret-key-id-list
1020 (password-cache-remove (car mml2015-epg-secret-key-id-list))
1021 (setq mml2015-epg-secret-key-id-list
1022 (cdr mml2015-epg-secret-key-id-list)))
1023 (mm-set-handle-multipart-parameter
1024 mm-security-handle 'gnus-info "Failed")
1025 (if (eq (car error) 'quit)
1026 (mm-set-handle-multipart-parameter
1027 mm-security-handle 'gnus-details "Quit.")
1028 (mm-set-handle-multipart-parameter
1029 mm-security-handle 'gnus-details (mml2015-format-error error)))))
1032 ;; Treat data which epg returns as a unibyte string.
1033 (mm-disable-multibyte)
1035 (goto-char (point-min))
1036 (while (search-forward "\r\n" nil t)
1037 (replace-match "\n" t t))
1038 (if (epg-context-result-for context 'verify)
1039 (mm-set-handle-multipart-parameter
1040 mm-security-handle 'gnus-info
1042 (epg-verify-result-to-string
1043 (epg-context-result-for context 'verify))))
1044 (mm-set-handle-multipart-parameter
1045 mm-security-handle 'gnus-info "OK")))))
1047 (defun mml2015-epg-verify (handle ctl)
1049 (let ((inhibit-redisplay t)
1050 context plain signature-file part signature)
1051 (when (or (null (setq part (mm-find-raw-part-by-type
1052 ctl (or (mm-handle-multipart-ctl-parameter
1054 "application/pgp-signature")
1056 (null (setq signature (mm-find-part-by-type
1057 (cdr handle) "application/pgp-signature"
1059 (mm-set-handle-multipart-parameter
1060 mm-security-handle 'gnus-info "Corrupted")
1061 (throw 'error handle))
1062 (setq context (epg-make-context))
1063 (condition-case error
1064 (setq plain (epg-verify-string context (mm-get-part signature) part))
1066 (mm-set-handle-multipart-parameter
1067 mm-security-handle 'gnus-info "Failed")
1068 (if (eq (car error) 'quit)
1069 (mm-set-handle-multipart-parameter
1070 mm-security-handle 'gnus-details "Quit.")
1071 (mm-set-handle-multipart-parameter
1072 mm-security-handle 'gnus-details (mml2015-format-error error)))
1073 (throw 'error handle)))
1074 (mm-set-handle-multipart-parameter
1075 mm-security-handle 'gnus-info
1076 (epg-verify-result-to-string (epg-context-result-for context 'verify)))
1079 (defun mml2015-epg-clear-verify ()
1080 (let ((inhibit-redisplay t)
1081 (context (epg-make-context))
1082 (signature (encode-coding-string (buffer-string)
1083 buffer-file-coding-system))
1085 (condition-case error
1086 (setq plain (epg-verify-string context signature))
1088 (mm-set-handle-multipart-parameter
1089 mm-security-handle 'gnus-info "Failed")
1090 (if (eq (car error) 'quit)
1091 (mm-set-handle-multipart-parameter
1092 mm-security-handle 'gnus-details "Quit.")
1093 (mm-set-handle-multipart-parameter
1094 mm-security-handle 'gnus-details (mml2015-format-error error)))))
1096 (mm-set-handle-multipart-parameter
1097 mm-security-handle 'gnus-info
1098 (epg-verify-result-to-string
1099 (epg-context-result-for context 'verify))))))
1101 (defun mml2015-epg-sign (cont)
1102 (let ((inhibit-redisplay t)
1103 (context (epg-make-context))
1104 (boundary (mml-compute-boundary cont))
1105 signers signature micalg)
1107 (setq signers (epa-select-keys context "Select keys for signing.
1108 If no one is selected, default secret key is used. "
1110 (setq signers (list (car (epg-list-keys
1112 (message-options-get 'mml-sender) t)))))
1113 (epg-context-set-armor context t)
1114 (epg-context-set-textmode context t)
1115 (epg-context-set-signers context signers)
1116 (if mml2015-cache-passphrase
1117 (epg-context-set-passphrase-callback
1119 #'mml2015-epg-passphrase-callback))
1120 (condition-case error
1121 (setq signature (epg-sign-string context (buffer-string) t)
1122 mml2015-epg-secret-key-id-list nil)
1124 (while mml2015-epg-secret-key-id-list
1125 (password-cache-remove (car mml2015-epg-secret-key-id-list))
1126 (setq mml2015-epg-secret-key-id-list
1127 (cdr mml2015-epg-secret-key-id-list)))
1128 (signal (car error) (cdr error))))
1129 (if (epg-context-result-for context 'sign)
1130 (setq micalg (epg-new-signature-digest-algorithm
1131 (car (epg-context-result-for context 'sign)))))
1132 (goto-char (point-min))
1133 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
1136 (insert (format "\tmicalg=%s; "
1139 epg-digest-algorithm-alist))))))
1140 (insert "protocol=\"application/pgp-signature\"\n")
1141 (insert (format "\n--%s\n" boundary))
1142 (goto-char (point-max))
1143 (insert (format "\n--%s\n" boundary))
1144 (insert "Content-Type: application/pgp-signature\n\n")
1146 (goto-char (point-max))
1147 (insert (format "--%s--\n" boundary))
1148 (goto-char (point-max))))
1150 (defun mml2015-epg-encrypt (cont &optional sign)
1151 (let ((inhibit-redisplay t)
1152 (context (epg-make-context))
1154 (boundary (mml-compute-boundary cont)))
1155 (if (or mml2015-verbose
1156 (null (message-options-get 'message-recipients)))
1158 (epa-select-keys context "Select recipients for encryption.
1159 If no one is selected, symmetric encryption will be performed. "
1160 (if (message-options-get 'message-recipients)
1162 (message-options-get 'message-recipients)
1163 "[ \f\t\n\r\v,]+"))))
1165 (mapcar (lambda (name)
1166 (car (epg-list-keys context name)))
1168 (message-options-get 'message-recipients)
1169 "[ \f\t\n\r\v,]+"))))
1170 (epg-context-set-armor context t)
1171 (epg-context-set-textmode context t)
1172 (if mml2015-cache-passphrase
1173 (epg-context-set-passphrase-callback
1175 #'mml2015-epg-passphrase-callback))
1176 (condition-case error
1178 (epg-encrypt-string context (buffer-string) recipients sign)
1179 mml2015-epg-secret-key-id-list nil)
1181 (while mml2015-epg-secret-key-id-list
1182 (password-cache-remove (car mml2015-epg-secret-key-id-list))
1183 (setq mml2015-epg-secret-key-id-list
1184 (cdr mml2015-epg-secret-key-id-list)))
1185 (signal (car error) (cdr error))))
1186 (delete-region (point-min) (point-max))
1187 (goto-char (point-min))
1188 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
1190 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
1191 (insert (format "--%s\n" boundary))
1192 (insert "Content-Type: application/pgp-encrypted\n\n")
1193 (insert "Version: 1\n\n")
1194 (insert (format "--%s\n" boundary))
1195 (insert "Content-Type: application/octet-stream\n\n")
1197 (goto-char (point-max))
1198 (insert (format "--%s--\n" boundary))
1199 (goto-char (point-max))))
1203 (defun mml2015-clean-buffer ()
1204 (if (gnus-buffer-live-p mml2015-result-buffer)
1205 (with-current-buffer mml2015-result-buffer
1208 (setq mml2015-result-buffer
1209 (gnus-get-buffer-create " *MML2015 Result*"))
1212 (defsubst mml2015-clear-decrypt-function ()
1213 (nth 6 (assq mml2015-use mml2015-function-alist)))
1215 (defsubst mml2015-clear-verify-function ()
1216 (nth 5 (assq mml2015-use mml2015-function-alist)))
1219 (defun mml2015-decrypt (handle ctl)
1220 (mml2015-clean-buffer)
1221 (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
1223 (funcall func handle ctl)
1227 (defun mml2015-decrypt-test (handle ctl)
1231 (defun mml2015-verify (handle ctl)
1232 (mml2015-clean-buffer)
1233 (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
1235 (funcall func handle ctl)
1239 (defun mml2015-verify-test (handle ctl)
1243 (defun mml2015-encrypt (cont &optional sign)
1244 (mml2015-clean-buffer)
1245 (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
1247 (funcall func cont sign)
1248 (error "Cannot find encrypt function"))))
1251 (defun mml2015-sign (cont)
1252 (mml2015-clean-buffer)
1253 (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
1256 (error "Cannot find sign function"))))
1259 (defun mml2015-self-encrypt ()
1260 (mml2015-encrypt nil))
1264 ;;; arch-tag: b04701d5-0b09-44d8-bed8-de901bf435f2
1265 ;;; mml2015.el ends here