1 ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
4 ;; 2008, 2009, 2010 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 by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;; RFC 2015 is updated by RFC 3156, this file should be compatible
33 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
35 (if (locate-library "password-cache")
36 (require 'password-cache)
39 (eval-when-compile (require 'cl))
45 (defvar mc-pgp-always-sign)
47 (declare-function epg-check-configuration "ext:epg-config"
48 (config &optional minimum-version))
49 (declare-function epg-configuration "ext:epg-config" ())
51 (defvar mml2015-use (or
55 (epg-check-configuration (epg-configuration))
60 ;; Avoid the "Recursive load suspected" error
62 (let ((recursive-load-depth-limit 100))
64 (and (fboundp 'pgg-sign-region)
69 (and (fboundp 'gpg-sign-detached)
73 (and (fboundp 'mc-encrypt-generic)
74 (fboundp 'mc-sign-generic)
75 (fboundp 'mc-cleanup-recipient-headers)
77 "The package used for PGP/MIME.
78 Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.")
80 ;; Something is not RFC2015.
81 (defvar mml2015-function-alist
82 '((mailcrypt mml2015-mailcrypt-sign
83 mml2015-mailcrypt-encrypt
84 mml2015-mailcrypt-verify
85 mml2015-mailcrypt-decrypt
86 mml2015-mailcrypt-clear-verify
87 mml2015-mailcrypt-clear-decrypt)
92 mml2015-gpg-clear-verify
93 mml2015-gpg-clear-decrypt)
98 mml2015-pgg-clear-verify
99 mml2015-pgg-clear-decrypt)
100 (epg mml2015-epg-sign
104 mml2015-epg-clear-verify
105 mml2015-epg-clear-decrypt))
106 "Alist of PGP/MIME functions.")
108 (defvar mml2015-result-buffer nil)
110 (defcustom mml2015-unabbrev-trust-alist
111 '(("TRUST_UNDEFINED" . nil)
112 ("TRUST_NEVER" . nil)
113 ("TRUST_MARGINAL" . t)
115 ("TRUST_ULTIMATE" . t))
116 "Map GnuPG trust output values to a boolean saying if you trust the key."
118 :group 'mime-security
119 :type '(repeat (cons (regexp :tag "GnuPG output regexp")
120 (boolean :tag "Trust key"))))
122 (defcustom mml2015-cache-passphrase mml-secure-cache-passphrase
123 "If t, cache passphrase."
124 :group 'mime-security
127 (defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
128 "How many seconds the passphrase is cached.
129 Whether the passphrase is cached at all is controlled by
130 `mml2015-cache-passphrase'."
131 :group 'mime-security
134 (defcustom mml2015-signers nil
135 "A list of your own key ID which will be used to sign a message."
136 :group 'mime-security
137 :type '(repeat (string :tag "Key ID")))
139 (defcustom mml2015-encrypt-to-self nil
140 "If t, add your own key ID to recipient list when encryption."
141 :group 'mime-security
144 (defcustom mml2015-always-trust t
145 "If t, GnuPG skip key validation on encryption."
146 :group 'mime-security
149 ;; Extract plaintext from cleartext signature. IMO, this kind of task
150 ;; should be done by GnuPG rather than Elisp, but older PGP backends
151 ;; (such as Mailcrypt, PGG, and gpg.el) discard the output from GnuPG.
152 (defun mml2015-extract-cleartext-signature ()
154 ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still
155 ;; believe that the right way is to use the plaintext output from GnuPG as
156 ;; it is, and mml2015-extract-cleartext-signature is just a kludge for
157 ;; misdesigned libraries like PGG, which have no ability to do that. So, I
158 ;; think it should not have descriptive documentation.''
160 ;; This function doesn't handle NotDashEscaped correctly. EasyPG handles it
162 ;; http://thread.gmane.org/gmane.emacs.gnus.general/66062/focus=66082
163 ;; http://thread.gmane.org/gmane.emacs.gnus.general/65087/focus=65109
164 (goto-char (point-min))
166 ;; We need to be careful not to strip beyond the armor headers.
167 ;; Previously, an attacker could replace the text inside our
168 ;; markup with trailing garbage by injecting whitespace into the
170 (while (looking-at "Hash:") ; The only header allowed in cleartext
171 (forward-line)) ; signatures according to RFC2440.
172 (when (looking-at "[\t ]*$")
174 (delete-region (point-min) (point))
175 (if (re-search-forward "^-----BEGIN PGP SIGNATURE-----" nil t)
176 (delete-region (match-beginning 0) (point-max)))
177 (goto-char (point-min))
178 (while (re-search-forward "^- " nil t)
179 (replace-match "" t t)
182 ;;; mailcrypt wrapper
184 (autoload 'mailcrypt-decrypt "mailcrypt")
185 (autoload 'mailcrypt-verify "mailcrypt")
186 (autoload 'mc-pgp-always-sign "mailcrypt")
187 (autoload 'mc-encrypt-generic "mc-toplev")
188 (autoload 'mc-cleanup-recipient-headers "mc-toplev")
189 (autoload 'mc-sign-generic "mc-toplev")
191 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
192 (defvar mml2015-verify-function 'mailcrypt-verify)
194 (defun mml2015-format-error (err)
195 (if (stringp (cadr err))
197 (format "%S" (cdr err))))
199 (defun mml2015-mailcrypt-decrypt (handle ctl)
201 (let (child handles result)
202 (unless (setq child (mm-find-part-by-type
204 "application/octet-stream" nil t))
205 (mm-set-handle-multipart-parameter
206 mm-security-handle 'gnus-info "Corrupted")
207 (throw 'error handle))
209 (mm-insert-part child)
212 (funcall mml2015-decrypt-function)
214 (mm-set-handle-multipart-parameter
215 mm-security-handle 'gnus-details (mml2015-format-error err))
218 (mm-set-handle-multipart-parameter
219 mm-security-handle 'gnus-details "Quit.")
222 (mm-set-handle-multipart-parameter
223 mm-security-handle 'gnus-info "Failed")
224 (throw 'error handle))
225 (setq handles (mm-dissect-buffer t)))
226 (mm-destroy-parts handle)
227 (mm-set-handle-multipart-parameter
228 mm-security-handle 'gnus-info
230 (let ((sig (with-current-buffer mml2015-result-buffer
231 (mml2015-gpg-extract-signature-details))))
232 (concat ", Signer: " sig))))
233 (if (listp (car handles))
237 (defun mml2015-mailcrypt-clear-decrypt ()
241 (funcall mml2015-decrypt-function)
243 (mm-set-handle-multipart-parameter
244 mm-security-handle 'gnus-details (mml2015-format-error err))
247 (mm-set-handle-multipart-parameter
248 mm-security-handle 'gnus-details "Quit.")
251 (mm-set-handle-multipart-parameter
252 mm-security-handle 'gnus-info "OK")
253 (mm-set-handle-multipart-parameter
254 mm-security-handle 'gnus-info "Failed"))))
256 (defun mml2015-fix-micalg (alg)
258 ;; Mutt/1.2.5i has seen sending micalg=php-sha1
259 (upcase (if (string-match "^p[gh]p-" alg)
260 (substring alg (match-end 0))
263 (defun mml2015-mailcrypt-verify (handle ctl)
266 (unless (setq part (mm-find-raw-part-by-type
267 ctl (or (mm-handle-multipart-ctl-parameter
269 "application/pgp-signature")
271 (mm-set-handle-multipart-parameter
272 mm-security-handle 'gnus-info "Corrupted")
273 (throw 'error handle))
275 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
276 (insert (format "Hash: %s\n\n"
277 (or (mml2015-fix-micalg
278 (mm-handle-multipart-ctl-parameter
282 (narrow-to-region (point) (point))
284 (goto-char (point-min))
286 (if (looking-at "^-")
289 (unless (setq part (mm-find-part-by-type
290 (cdr handle) "application/pgp-signature" nil t))
291 (mm-set-handle-multipart-parameter
292 mm-security-handle 'gnus-info "Corrupted")
293 (throw 'error handle))
295 (narrow-to-region (point) (point))
296 (mm-insert-part part)
297 (goto-char (point-min))
298 (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
299 (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
300 (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
301 (replace-match "-----END PGP SIGNATURE-----" t t)))
302 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
303 (unless (condition-case err
305 (funcall mml2015-verify-function)
306 (if (get-buffer " *mailcrypt stderr temp")
307 (mm-set-handle-multipart-parameter
308 mm-security-handle 'gnus-details
309 (with-current-buffer " *mailcrypt stderr temp"
311 (if (get-buffer " *mailcrypt stdout temp")
312 (kill-buffer " *mailcrypt stdout temp"))
313 (if (get-buffer " *mailcrypt stderr temp")
314 (kill-buffer " *mailcrypt stderr temp"))
315 (if (get-buffer " *mailcrypt status temp")
316 (kill-buffer " *mailcrypt status temp"))
317 (if (get-buffer mc-gpg-debug-buffer)
318 (kill-buffer mc-gpg-debug-buffer)))
320 (mm-set-handle-multipart-parameter
321 mm-security-handle 'gnus-details (mml2015-format-error err))
324 (mm-set-handle-multipart-parameter
325 mm-security-handle 'gnus-details "Quit.")
327 (mm-set-handle-multipart-parameter
328 mm-security-handle 'gnus-info "Failed")
329 (throw 'error handle))))
330 (mm-set-handle-multipart-parameter
331 mm-security-handle 'gnus-info "OK")
334 (defun mml2015-mailcrypt-clear-verify ()
335 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
336 (if (condition-case err
338 (funcall mml2015-verify-function)
339 (if (get-buffer " *mailcrypt stderr temp")
340 (mm-set-handle-multipart-parameter
341 mm-security-handle 'gnus-details
342 (with-current-buffer " *mailcrypt stderr temp"
344 (if (get-buffer " *mailcrypt stdout temp")
345 (kill-buffer " *mailcrypt stdout temp"))
346 (if (get-buffer " *mailcrypt stderr temp")
347 (kill-buffer " *mailcrypt stderr temp"))
348 (if (get-buffer " *mailcrypt status temp")
349 (kill-buffer " *mailcrypt status temp"))
350 (if (get-buffer mc-gpg-debug-buffer)
351 (kill-buffer mc-gpg-debug-buffer)))
353 (mm-set-handle-multipart-parameter
354 mm-security-handle 'gnus-details (mml2015-format-error err))
357 (mm-set-handle-multipart-parameter
358 mm-security-handle 'gnus-details "Quit.")
360 (mm-set-handle-multipart-parameter
361 mm-security-handle 'gnus-info "OK")
362 (mm-set-handle-multipart-parameter
363 mm-security-handle 'gnus-info "Failed")))
364 (mml2015-extract-cleartext-signature))
366 (defun mml2015-mailcrypt-sign (cont)
367 (mc-sign-generic (message-options-get 'message-sender)
369 (let ((boundary (mml-compute-boundary cont))
371 (goto-char (point-min))
372 (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
373 (error "Cannot find signed begin line"))
374 (goto-char (match-beginning 0))
376 (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
377 (error "Cannot not find PGP hash"))
378 (setq hash (match-string 1))
379 (unless (re-search-forward "^$" nil t)
380 (error "Cannot not find PGP message"))
382 (delete-region (point-min) (point))
383 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
385 (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
387 (insert (format "\n--%s\n" boundary))
389 (goto-char (point-max))
390 (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
391 (error "Cannot find signature part"))
392 (replace-match "-----END PGP MESSAGE-----" t t)
393 (goto-char (match-beginning 0))
394 (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
396 (error "Cannot find signature part"))
397 (replace-match "-----BEGIN PGP MESSAGE-----" t t)
398 (goto-char (match-beginning 0))
400 (narrow-to-region point (point))
402 (while (re-search-forward "^- -" nil t)
403 (replace-match "-" t t))
404 (goto-char (point-max)))
405 (insert (format "--%s\n" boundary))
406 (insert "Content-Type: application/pgp-signature\n\n")
407 (goto-char (point-max))
408 (insert (format "--%s--\n" boundary))
409 (goto-char (point-max))))
411 ;; We require mm-decode, which requires mm-bodies, which autoloads
412 ;; message-options-get (!).
413 (declare-function message-options-set "message" (symbol value))
415 (defun mml2015-mailcrypt-encrypt (cont &optional sign)
416 (let ((mc-pgp-always-sign
417 (or mc-pgp-always-sign
419 (eq t (or (message-options-get 'message-sign-encrypt)
421 'message-sign-encrypt
422 (or (y-or-n-p "Sign the message? ")
425 (mm-with-unibyte-current-buffer
427 (or (message-options-get 'message-recipients)
428 (message-options-set 'message-recipients
429 (mc-cleanup-recipient-headers
430 (read-string "Recipients: "))))
432 (message-options-get 'message-sender))))
433 (goto-char (point-min))
434 (unless (looking-at "-----BEGIN PGP MESSAGE-----")
435 (error "Fail to encrypt the message"))
436 (let ((boundary (mml-compute-boundary cont)))
437 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
439 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
440 (insert (format "--%s\n" boundary))
441 (insert "Content-Type: application/pgp-encrypted\n\n")
442 (insert "Version: 1\n\n")
443 (insert (format "--%s\n" boundary))
444 (insert "Content-Type: application/octet-stream\n\n")
445 (goto-char (point-max))
446 (insert (format "--%s--\n" boundary))
447 (goto-char (point-max))))
451 (autoload 'gpg-decrypt "gpg")
452 (autoload 'gpg-verify "gpg")
453 (autoload 'gpg-verify-cleartext "gpg")
454 (autoload 'gpg-sign-detached "gpg")
455 (autoload 'gpg-sign-encrypt "gpg")
456 (autoload 'gpg-encrypt "gpg")
457 (autoload 'gpg-passphrase-read "gpg")
459 (defun mml2015-gpg-passphrase ()
460 (or (message-options-get 'gpg-passphrase)
461 (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
463 (defun mml2015-gpg-decrypt-1 ()
464 (let ((cipher (current-buffer)) plain result)
465 (if (with-temp-buffer
467 (gpg-decrypt cipher (setq plain (current-buffer))
468 mml2015-result-buffer nil)
469 (mm-set-handle-multipart-parameter
470 mm-security-handle 'gnus-details
471 (with-current-buffer mml2015-result-buffer
475 (insert-buffer-substring plain)
476 (goto-char (point-min))
477 (while (search-forward "\r\n" nil t)
478 (replace-match "\n" t t))))
480 ;; Some wrong with the return value, check plain text buffer.
481 (if (> (point-max) (point-min))
485 (defun mml2015-gpg-decrypt (handle ctl)
486 (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
487 (mml2015-mailcrypt-decrypt handle ctl)))
489 (defun mml2015-gpg-clear-decrypt ()
491 (setq result (mml2015-gpg-decrypt-1))
493 (mm-set-handle-multipart-parameter
494 mm-security-handle 'gnus-info "OK")
495 (mm-set-handle-multipart-parameter
496 mm-security-handle 'gnus-info "Failed"))))
498 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
500 (fpr-length (string-width fingerprint))
503 (setq fingerprint (string-to-list fingerprint))
505 (setq fpr-length (- fpr-length 4))
506 (setq slice (butlast fingerprint fpr-length))
507 (setq fingerprint (nthcdr 4 fingerprint))
508 (setq n-slice (1+ n-slice))
514 (otherwise (concat " " slice))))))
517 (defun mml2015-gpg-extract-signature-details ()
518 (goto-char (point-min))
519 (let* ((expired (re-search-forward
520 "^\\[GNUPG:\\] SIGEXPIRED$"
522 (signer (and (re-search-forward
523 "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
525 (cons (match-string 1) (match-string 2))))
526 (fprint (and (re-search-forward
527 "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
530 (trust (and (re-search-forward
531 "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
535 (cdr (assoc trust mml2015-unabbrev-trust-alist))))
536 (cond ((and signer fprint)
538 (unless trust-good-enough-p
539 (concat "\nUntrusted, Fingerprint: "
540 (mml2015-gpg-pretty-print-fpr fprint)))
542 (format "\nWARNING: Signature from expired key (%s)"
545 "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
548 "From unknown user"))))
550 (defun mml2015-gpg-verify (handle ctl)
552 (let (part message signature info-is-set-p)
553 (unless (setq part (mm-find-raw-part-by-type
554 ctl (or (mm-handle-multipart-ctl-parameter
556 "application/pgp-signature")
558 (mm-set-handle-multipart-parameter
559 mm-security-handle 'gnus-info "Corrupted")
560 (throw 'error handle))
562 (setq message (current-buffer))
564 ;; Convert <LF> to <CR><LF> in signed text. If --textmode is
565 ;; specified when signing, the conversion is not necessary.
566 (goto-char (point-min))
569 (unless (eq (char-before) ?\r)
574 (setq signature (current-buffer))
575 (unless (setq part (mm-find-part-by-type
576 (cdr handle) "application/pgp-signature" nil t))
577 (mm-set-handle-multipart-parameter
578 mm-security-handle 'gnus-info "Corrupted")
579 (throw 'error handle))
580 (mm-insert-part part)
581 (unless (condition-case err
583 (gpg-verify message signature mml2015-result-buffer)
584 (mm-set-handle-multipart-parameter
585 mm-security-handle 'gnus-details
586 (with-current-buffer mml2015-result-buffer
589 (mm-set-handle-multipart-parameter
590 mm-security-handle 'gnus-details (mml2015-format-error err))
591 (mm-set-handle-multipart-parameter
592 mm-security-handle 'gnus-info "Error.")
593 (setq info-is-set-p t)
596 (mm-set-handle-multipart-parameter
597 mm-security-handle 'gnus-details "Quit.")
598 (mm-set-handle-multipart-parameter
599 mm-security-handle 'gnus-info "Quit.")
600 (setq info-is-set-p t)
602 (unless info-is-set-p
603 (mm-set-handle-multipart-parameter
604 mm-security-handle 'gnus-info "Failed"))
605 (throw 'error handle)))
606 (mm-set-handle-multipart-parameter
607 mm-security-handle 'gnus-info
608 (with-current-buffer mml2015-result-buffer
609 (mml2015-gpg-extract-signature-details))))
612 (defun mml2015-gpg-clear-verify ()
613 (if (condition-case err
615 (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
616 (mm-set-handle-multipart-parameter
617 mm-security-handle 'gnus-details
618 (with-current-buffer mml2015-result-buffer
621 (mm-set-handle-multipart-parameter
622 mm-security-handle 'gnus-details (mml2015-format-error err))
625 (mm-set-handle-multipart-parameter
626 mm-security-handle 'gnus-details "Quit.")
628 (mm-set-handle-multipart-parameter
629 mm-security-handle 'gnus-info
630 (with-current-buffer mml2015-result-buffer
631 (mml2015-gpg-extract-signature-details)))
632 (mm-set-handle-multipart-parameter
633 mm-security-handle 'gnus-info "Failed"))
634 (mml2015-extract-cleartext-signature))
636 (defun mml2015-gpg-sign (cont)
637 (let ((boundary (mml-compute-boundary cont))
638 (text (current-buffer)) signature)
639 (goto-char (point-max))
643 (unless (gpg-sign-detached text (setq signature (current-buffer))
644 mml2015-result-buffer
646 (message-options-get 'message-sender)
647 t t) ; armor & textmode
648 (unless (> (point-max) (point-min))
649 (pop-to-buffer mml2015-result-buffer)
650 (error "Sign error")))
651 (goto-char (point-min))
652 (while (re-search-forward "\r+$" nil t)
653 (replace-match "" t t))
655 (goto-char (point-min))
656 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
658 ;;; FIXME: what is the micalg?
659 (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
660 (insert (format "\n--%s\n" boundary))
661 (goto-char (point-max))
662 (insert (format "\n--%s\n" boundary))
663 (insert "Content-Type: application/pgp-signature\n\n")
664 (insert-buffer-substring signature)
665 (goto-char (point-max))
666 (insert (format "--%s--\n" boundary))
667 (goto-char (point-max)))))
669 (defun mml2015-gpg-encrypt (cont &optional sign)
670 (let ((boundary (mml-compute-boundary cont))
671 (text (current-buffer))
673 (mm-with-unibyte-current-buffer
675 (mm-disable-multibyte)
676 ;; set up a function to call the correct gpg encrypt routine
677 ;; with the right arguments. (FIXME: this should be done
679 (flet ((gpg-encrypt-func
680 (sign plaintext ciphertext result recipients &optional
681 passphrase sign-with-key armor textmode)
684 plaintext ciphertext result recipients passphrase
685 sign-with-key armor textmode)
687 plaintext ciphertext result recipients passphrase
689 (unless (gpg-encrypt-func
690 sign ; passed in when using signencrypt
691 text (setq cipher (current-buffer))
692 mml2015-result-buffer
695 (message-options-get 'message-recipients)
696 (message-options-set 'message-recipients
697 (read-string "Recipients: ")))
700 (message-options-get 'message-sender)
701 t t) ; armor & textmode
702 (unless (> (point-max) (point-min))
703 (pop-to-buffer mml2015-result-buffer)
704 (error "Encrypt error"))))
705 (goto-char (point-min))
706 (while (re-search-forward "\r+$" nil t)
707 (replace-match "" t t))
709 (delete-region (point-min) (point-max))
710 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
712 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
713 (insert (format "--%s\n" boundary))
714 (insert "Content-Type: application/pgp-encrypted\n\n")
715 (insert "Version: 1\n\n")
716 (insert (format "--%s\n" boundary))
717 (insert "Content-Type: application/octet-stream\n\n")
718 (insert-buffer-substring cipher)
719 (goto-char (point-max))
720 (insert (format "--%s--\n" boundary))
721 (goto-char (point-max))))))
725 (defvar pgg-default-user-id)
726 (defvar pgg-errors-buffer)
727 (defvar pgg-output-buffer)
729 (autoload 'pgg-decrypt-region "pgg")
730 (autoload 'pgg-verify-region "pgg")
731 (autoload 'pgg-sign-region "pgg")
732 (autoload 'pgg-encrypt-region "pgg")
733 (autoload 'pgg-parse-armor "pgg-parse")
735 (defun mml2015-pgg-decrypt (handle ctl)
737 (let ((pgg-errors-buffer mml2015-result-buffer)
738 child handles result decrypt-status)
739 (unless (setq child (mm-find-part-by-type
741 "application/octet-stream" nil t))
742 (mm-set-handle-multipart-parameter
743 mm-security-handle 'gnus-info "Corrupted")
744 (throw 'error handle))
746 (mm-insert-part child)
747 (if (condition-case err
749 (pgg-decrypt-region (point-min) (point-max))
751 (with-current-buffer mml2015-result-buffer
753 (mm-set-handle-multipart-parameter
754 mm-security-handle 'gnus-details
757 (mm-set-handle-multipart-parameter
758 mm-security-handle 'gnus-details (mml2015-format-error err))
761 (mm-set-handle-multipart-parameter
762 mm-security-handle 'gnus-details "Quit.")
764 (with-current-buffer pgg-output-buffer
765 (goto-char (point-min))
766 (while (search-forward "\r\n" nil t)
767 (replace-match "\n" t t))
768 (setq handles (mm-dissect-buffer t))
769 (mm-destroy-parts handle)
770 (mm-set-handle-multipart-parameter
771 mm-security-handle 'gnus-info "OK")
772 (mm-set-handle-multipart-parameter
773 mm-security-handle 'gnus-details
774 (concat decrypt-status
775 (when (stringp (car handles))
776 "\n" (mm-handle-multipart-ctl-parameter
777 handles 'gnus-details))))
778 (if (listp (car handles))
781 (mm-set-handle-multipart-parameter
782 mm-security-handle 'gnus-info "Failed")
783 (throw 'error handle))))))
785 (defun mml2015-pgg-clear-decrypt ()
786 (let ((pgg-errors-buffer mml2015-result-buffer))
788 (pgg-decrypt-region (point-min) (point-max))
789 (mm-set-handle-multipart-parameter
790 mm-security-handle 'gnus-details
791 (with-current-buffer mml2015-result-buffer
795 ;; Treat data which pgg returns as a unibyte string.
796 (mm-disable-multibyte)
797 (insert-buffer-substring pgg-output-buffer)
798 (goto-char (point-min))
799 (while (search-forward "\r\n" nil t)
800 (replace-match "\n" t t))
801 (mm-set-handle-multipart-parameter
802 mm-security-handle 'gnus-info "OK"))
803 (mm-set-handle-multipart-parameter
804 mm-security-handle 'gnus-info "Failed"))))
806 (defun mml2015-pgg-verify (handle ctl)
807 (let ((pgg-errors-buffer mml2015-result-buffer)
808 signature-file part signature)
809 (if (or (null (setq part (mm-find-raw-part-by-type
810 ctl (or (mm-handle-multipart-ctl-parameter
812 "application/pgp-signature")
814 (null (setq signature (mm-find-part-by-type
815 (cdr handle) "application/pgp-signature" nil t))))
817 (mm-set-handle-multipart-parameter
818 mm-security-handle 'gnus-info "Corrupted")
822 ;; Convert <LF> to <CR><LF> in signed text. If --textmode is
823 ;; specified when signing, the conversion is not necessary.
824 (goto-char (point-min))
827 (unless (eq (char-before) ?\r)
831 (with-temp-file (setq signature-file (mm-make-temp-file "pgg"))
832 (mm-insert-part signature))
833 (if (condition-case err
835 (pgg-verify-region (point-min) (point-max)
837 (goto-char (point-min))
838 (while (search-forward "\r\n" nil t)
839 (replace-match "\n" t t))
840 (mm-set-handle-multipart-parameter
841 mm-security-handle 'gnus-details
842 (concat (with-current-buffer pgg-output-buffer
844 (with-current-buffer pgg-errors-buffer
847 (mm-set-handle-multipart-parameter
848 mm-security-handle 'gnus-details (mml2015-format-error err))
851 (mm-set-handle-multipart-parameter
852 mm-security-handle 'gnus-details "Quit.")
855 (delete-file signature-file)
856 (mm-set-handle-multipart-parameter
857 mm-security-handle 'gnus-info
858 (with-current-buffer pgg-errors-buffer
859 (mml2015-gpg-extract-signature-details))))
860 (delete-file signature-file)
861 (mm-set-handle-multipart-parameter
862 mm-security-handle 'gnus-info "Failed")))))
865 (defun mml2015-pgg-clear-verify ()
866 (let ((pgg-errors-buffer mml2015-result-buffer)
867 (text (buffer-string))
868 (coding-system buffer-file-coding-system))
869 (if (condition-case err
871 (mm-with-unibyte-buffer
872 (insert (mm-encode-coding-string text coding-system))
873 (pgg-verify-region (point-min) (point-max) nil t))
874 (goto-char (point-min))
875 (while (search-forward "\r\n" nil t)
876 (replace-match "\n" t t))
877 (mm-set-handle-multipart-parameter
878 mm-security-handle 'gnus-details
879 (concat (with-current-buffer pgg-output-buffer
881 (with-current-buffer pgg-errors-buffer
884 (mm-set-handle-multipart-parameter
885 mm-security-handle 'gnus-details (mml2015-format-error err))
888 (mm-set-handle-multipart-parameter
889 mm-security-handle 'gnus-details "Quit.")
891 (mm-set-handle-multipart-parameter
892 mm-security-handle 'gnus-info
893 (with-current-buffer pgg-errors-buffer
894 (mml2015-gpg-extract-signature-details)))
895 (mm-set-handle-multipart-parameter
896 mm-security-handle 'gnus-info "Failed")))
897 (mml2015-extract-cleartext-signature))
899 (defun mml2015-pgg-sign (cont)
900 (let ((pgg-errors-buffer mml2015-result-buffer)
901 (boundary (mml-compute-boundary cont))
902 (pgg-default-user-id (or (message-options-get 'mml-sender)
903 pgg-default-user-id))
906 (unless (pgg-sign-region (point-min) (point-max))
907 (pop-to-buffer mml2015-result-buffer)
908 (error "Sign error"))
909 (goto-char (point-min))
910 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
912 (if (setq entry (assq 2 (pgg-parse-armor
913 (with-current-buffer pgg-output-buffer
915 (setq entry (assq 'hash-algorithm (cdr entry))))
916 (insert (format "\tmicalg=%s; "
918 (downcase (format "pgp-%s" (cdr entry)))
920 (insert "protocol=\"application/pgp-signature\"\n")
921 (insert (format "\n--%s\n" boundary))
922 (goto-char (point-max))
923 (insert (format "\n--%s\n" boundary))
924 (insert "Content-Type: application/pgp-signature\n\n")
925 (insert-buffer-substring pgg-output-buffer)
926 (goto-char (point-max))
927 (insert (format "--%s--\n" boundary))
928 (goto-char (point-max))))
930 (defun mml2015-pgg-encrypt (cont &optional sign)
931 (let ((pgg-errors-buffer mml2015-result-buffer)
933 (boundary (mml-compute-boundary cont)))
934 (unless (pgg-encrypt-region (point-min) (point-max)
937 (message-options-get 'message-recipients)
938 (message-options-set 'message-recipients
939 (read-string "Recipients: ")))
942 (pop-to-buffer mml2015-result-buffer)
943 (error "Encrypt error"))
944 (delete-region (point-min) (point-max))
945 (goto-char (point-min))
946 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
948 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
949 (insert (format "--%s\n" boundary))
950 (insert "Content-Type: application/pgp-encrypted\n\n")
951 (insert "Version: 1\n\n")
952 (insert (format "--%s\n" boundary))
953 (insert "Content-Type: application/octet-stream\n\n")
954 (insert-buffer-substring pgg-output-buffer)
955 (goto-char (point-max))
956 (insert (format "--%s--\n" boundary))
957 (goto-char (point-max))))
961 (defvar epg-user-id-alist)
962 (defvar epg-digest-algorithm-alist)
963 (defvar inhibit-redisplay)
965 (autoload 'epg-make-context "epg")
966 (autoload 'epg-context-set-armor "epg")
967 (autoload 'epg-context-set-textmode "epg")
968 (autoload 'epg-context-set-signers "epg")
969 (autoload 'epg-context-result-for "epg")
970 (autoload 'epg-new-signature-digest-algorithm "epg")
971 (autoload 'epg-verify-result-to-string "epg")
972 (autoload 'epg-list-keys "epg")
973 (autoload 'epg-decrypt-string "epg")
974 (autoload 'epg-verify-string "epg")
975 (autoload 'epg-sign-string "epg")
976 (autoload 'epg-encrypt-string "epg")
977 (autoload 'epg-passphrase-callback-function "epg")
978 (autoload 'epg-context-set-passphrase-callback "epg")
979 (autoload 'epg-key-sub-key-list "epg")
980 (autoload 'epg-sub-key-capability "epg")
981 (autoload 'epg-sub-key-validity "epg")
982 (autoload 'epg-configuration "epg-config")
983 (autoload 'epg-expand-group "epg-config")
984 (autoload 'epa-select-keys "epa")
986 (defvar mml2015-epg-secret-key-id-list nil)
988 (defun mml2015-epg-passphrase-callback (context key-id ignore)
990 (epg-passphrase-callback-function context key-id nil)
991 (let* ((password-cache-key-id
999 "Passphrase for PIN: "
1000 (if (setq entry (assoc key-id epg-user-id-alist))
1001 (format "Passphrase for %s %s: " key-id (cdr entry))
1002 (format "Passphrase for %s: " key-id)))
1003 password-cache-key-id)))
1005 (let ((password-cache-expiry mml2015-passphrase-cache-expiry))
1006 (password-cache-add password-cache-key-id passphrase))
1007 (setq mml2015-epg-secret-key-id-list
1008 (cons password-cache-key-id mml2015-epg-secret-key-id-list))
1009 (copy-sequence passphrase)))))
1011 (defun mml2015-epg-find-usable-key (keys usage)
1014 (let ((pointer (epg-key-sub-key-list (car keys))))
1016 (if (and (memq usage (epg-sub-key-capability (car pointer)))
1017 (not (memq 'disabled (epg-sub-key-capability (car pointer))))
1018 (not (memq (epg-sub-key-validity (car pointer))
1019 '(revoked expired))))
1020 (throw 'found (car keys)))
1021 (setq pointer (cdr pointer))))
1022 (setq keys (cdr keys)))))
1024 (defun mml2015-epg-decrypt (handle ctl)
1026 (let ((inhibit-redisplay t)
1027 context plain child handles result decrypt-status)
1028 (unless (setq child (mm-find-part-by-type
1030 "application/octet-stream" nil t))
1031 (mm-set-handle-multipart-parameter
1032 mm-security-handle 'gnus-info "Corrupted")
1033 (throw 'error handle))
1034 (setq context (epg-make-context))
1035 (if mml2015-cache-passphrase
1036 (epg-context-set-passphrase-callback
1038 #'mml2015-epg-passphrase-callback))
1039 (condition-case error
1040 (setq plain (epg-decrypt-string context (mm-get-part child))
1041 mml2015-epg-secret-key-id-list nil)
1043 (while mml2015-epg-secret-key-id-list
1044 (password-cache-remove (car mml2015-epg-secret-key-id-list))
1045 (setq mml2015-epg-secret-key-id-list
1046 (cdr mml2015-epg-secret-key-id-list)))
1047 (mm-set-handle-multipart-parameter
1048 mm-security-handle 'gnus-info "Failed")
1049 (if (eq (car error) 'quit)
1050 (mm-set-handle-multipart-parameter
1051 mm-security-handle 'gnus-details "Quit.")
1052 (mm-set-handle-multipart-parameter
1053 mm-security-handle 'gnus-details (mml2015-format-error error)))
1054 (throw 'error handle)))
1057 (goto-char (point-min))
1058 (while (search-forward "\r\n" nil t)
1059 (replace-match "\n" t t))
1060 (setq handles (mm-dissect-buffer t))
1061 (mm-destroy-parts handle)
1062 (if (epg-context-result-for context 'verify)
1063 (mm-set-handle-multipart-parameter
1064 mm-security-handle 'gnus-info
1066 (epg-verify-result-to-string
1067 (epg-context-result-for context 'verify))))
1068 (mm-set-handle-multipart-parameter
1069 mm-security-handle 'gnus-info "OK"))
1070 (if (stringp (car handles))
1071 (mm-set-handle-multipart-parameter
1072 mm-security-handle 'gnus-details
1073 (mm-handle-multipart-ctl-parameter handles 'gnus-details))))
1074 (if (listp (car handles))
1078 (defun mml2015-epg-clear-decrypt ()
1079 (let ((inhibit-redisplay t)
1080 (context (epg-make-context))
1082 (if mml2015-cache-passphrase
1083 (epg-context-set-passphrase-callback
1085 #'mml2015-epg-passphrase-callback))
1086 (condition-case error
1087 (setq plain (epg-decrypt-string context (buffer-string))
1088 mml2015-epg-secret-key-id-list nil)
1090 (while mml2015-epg-secret-key-id-list
1091 (password-cache-remove (car mml2015-epg-secret-key-id-list))
1092 (setq mml2015-epg-secret-key-id-list
1093 (cdr mml2015-epg-secret-key-id-list)))
1094 (mm-set-handle-multipart-parameter
1095 mm-security-handle 'gnus-info "Failed")
1096 (if (eq (car error) 'quit)
1097 (mm-set-handle-multipart-parameter
1098 mm-security-handle 'gnus-details "Quit.")
1099 (mm-set-handle-multipart-parameter
1100 mm-security-handle 'gnus-details (mml2015-format-error error)))))
1103 ;; Treat data which epg returns as a unibyte string.
1104 (mm-disable-multibyte)
1106 (goto-char (point-min))
1107 (while (search-forward "\r\n" nil t)
1108 (replace-match "\n" t t))
1109 (mm-set-handle-multipart-parameter
1110 mm-security-handle 'gnus-info "OK")
1111 (if (epg-context-result-for context 'verify)
1112 (mm-set-handle-multipart-parameter
1113 mm-security-handle 'gnus-details
1114 (epg-verify-result-to-string
1115 (epg-context-result-for context 'verify)))))))
1117 (defun mml2015-epg-verify (handle ctl)
1119 (let ((inhibit-redisplay t)
1120 context plain signature-file part signature)
1121 (when (or (null (setq part (mm-find-raw-part-by-type
1122 ctl (or (mm-handle-multipart-ctl-parameter
1124 "application/pgp-signature")
1126 (null (setq signature (mm-find-part-by-type
1127 (cdr handle) "application/pgp-signature"
1129 (mm-set-handle-multipart-parameter
1130 mm-security-handle 'gnus-info "Corrupted")
1131 (throw 'error handle))
1132 (setq part (mm-replace-in-string part "\n" "\r\n" t)
1133 signature (mm-get-part signature)
1134 context (epg-make-context))
1135 (condition-case error
1136 (setq plain (epg-verify-string context signature part))
1138 (mm-set-handle-multipart-parameter
1139 mm-security-handle 'gnus-info "Failed")
1140 (if (eq (car error) 'quit)
1141 (mm-set-handle-multipart-parameter
1142 mm-security-handle 'gnus-details "Quit.")
1143 (mm-set-handle-multipart-parameter
1144 mm-security-handle 'gnus-details (mml2015-format-error error)))
1145 (throw 'error handle)))
1146 (mm-set-handle-multipart-parameter
1147 mm-security-handle 'gnus-info
1148 (epg-verify-result-to-string (epg-context-result-for context 'verify)))
1151 (defun mml2015-epg-clear-verify ()
1152 (let ((inhibit-redisplay t)
1153 (context (epg-make-context))
1154 (signature (mm-encode-coding-string (buffer-string)
1155 coding-system-for-write))
1157 (condition-case error
1158 (setq plain (epg-verify-string context signature))
1160 (mm-set-handle-multipart-parameter
1161 mm-security-handle 'gnus-info "Failed")
1162 (if (eq (car error) 'quit)
1163 (mm-set-handle-multipart-parameter
1164 mm-security-handle 'gnus-details "Quit.")
1165 (mm-set-handle-multipart-parameter
1166 mm-security-handle 'gnus-details (mml2015-format-error error)))))
1169 (mm-set-handle-multipart-parameter
1170 mm-security-handle 'gnus-info
1171 (epg-verify-result-to-string
1172 (epg-context-result-for context 'verify)))
1173 (delete-region (point-min) (point-max))
1174 (insert (mm-decode-coding-string plain coding-system-for-read)))
1175 (mml2015-extract-cleartext-signature))))
1177 (defun mml2015-epg-sign (cont)
1178 (let* ((inhibit-redisplay t)
1179 (context (epg-make-context))
1180 (boundary (mml-compute-boundary cont))
1183 (or (message-options-get 'mml2015-epg-signers)
1184 (message-options-set
1185 'mml2015-epg-signers
1186 (if (eq mm-sign-option 'guided)
1187 (epa-select-keys context "\
1188 Select keys for signing.
1189 If no one is selected, default secret key is used. "
1195 (setq signer-key (mml2015-epg-find-usable-key
1196 (epg-list-keys context signer t)
1198 (unless (or signer-key
1201 "No secret key for %s; skip it? "
1203 (error "No secret key for %s" signer))
1205 mml2015-signers)))))))
1207 (epg-context-set-armor context t)
1208 (epg-context-set-textmode context t)
1209 (epg-context-set-signers context signers)
1210 (if mml2015-cache-passphrase
1211 (epg-context-set-passphrase-callback
1213 #'mml2015-epg-passphrase-callback))
1214 (condition-case error
1215 (setq signature (epg-sign-string context (buffer-string) t)
1216 mml2015-epg-secret-key-id-list nil)
1218 (while mml2015-epg-secret-key-id-list
1219 (password-cache-remove (car mml2015-epg-secret-key-id-list))
1220 (setq mml2015-epg-secret-key-id-list
1221 (cdr mml2015-epg-secret-key-id-list)))
1222 (signal (car error) (cdr error))))
1223 (if (epg-context-result-for context 'sign)
1224 (setq micalg (epg-new-signature-digest-algorithm
1225 (car (epg-context-result-for context 'sign)))))
1226 (goto-char (point-min))
1227 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
1230 (insert (format "\tmicalg=pgp-%s; "
1233 epg-digest-algorithm-alist))))))
1234 (insert "protocol=\"application/pgp-signature\"\n")
1235 (insert (format "\n--%s\n" boundary))
1236 (goto-char (point-max))
1237 (insert (format "\n--%s\n" boundary))
1238 (insert "Content-Type: application/pgp-signature\n\n")
1240 (goto-char (point-max))
1241 (insert (format "--%s--\n" boundary))
1242 (goto-char (point-max))))
1244 (defun mml2015-epg-encrypt (cont &optional sign)
1245 (let ((inhibit-redisplay t)
1246 (context (epg-make-context))
1247 (config (epg-configuration))
1248 (recipients (message-options-get 'mml2015-epg-recipients))
1250 (boundary (mml-compute-boundary cont))
1251 recipient-key signer-key)
1257 (or (epg-expand-group config recipient)
1258 (list (concat "<" recipient ">"))))
1260 (or (message-options-get 'message-recipients)
1261 (message-options-set 'message-recipients
1262 (read-string "Recipients: ")))
1263 "[ \f\t\n\r\v,]+"))))
1264 (when mml2015-encrypt-to-self
1265 (unless mml2015-signers
1266 (error "mml2015-signers not set"))
1267 (setq recipients (nconc recipients mml2015-signers)))
1268 (if (eq mm-encrypt-option 'guided)
1270 (epa-select-keys context "\
1271 Select recipients for encryption.
1272 If no one is selected, symmetric encryption will be performed. "
1278 (setq recipient-key (mml2015-epg-find-usable-key
1279 (epg-list-keys context recipient)
1281 (unless (or recipient-key
1283 (format "No public key for %s; skip it? "
1285 (error "No public key for %s" recipient))
1289 (error "No recipient specified")))
1290 (message-options-set 'mml2015-epg-recipients recipients))
1293 (or (message-options-get 'mml2015-epg-signers)
1294 (message-options-set
1295 'mml2015-epg-signers
1296 (if (eq mm-sign-option 'guided)
1297 (epa-select-keys context "\
1298 Select keys for signing.
1299 If no one is selected, default secret key is used. "
1305 (setq signer-key (mml2015-epg-find-usable-key
1306 (epg-list-keys context signer t)
1308 (unless (or signer-key
1311 "No secret key for %s; skip it? "
1313 (error "No secret key for %s" signer))
1315 mml2015-signers)))))))
1316 (epg-context-set-signers context signers))
1317 (epg-context-set-armor context t)
1318 (epg-context-set-textmode context t)
1319 (if mml2015-cache-passphrase
1320 (epg-context-set-passphrase-callback
1322 #'mml2015-epg-passphrase-callback))
1323 (condition-case error
1325 (epg-encrypt-string context (buffer-string) recipients sign
1326 mml2015-always-trust)
1327 mml2015-epg-secret-key-id-list nil)
1329 (while mml2015-epg-secret-key-id-list
1330 (password-cache-remove (car mml2015-epg-secret-key-id-list))
1331 (setq mml2015-epg-secret-key-id-list
1332 (cdr mml2015-epg-secret-key-id-list)))
1333 (signal (car error) (cdr error))))
1334 (delete-region (point-min) (point-max))
1335 (goto-char (point-min))
1336 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
1338 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
1339 (insert (format "--%s\n" boundary))
1340 (insert "Content-Type: application/pgp-encrypted\n\n")
1341 (insert "Version: 1\n\n")
1342 (insert (format "--%s\n" boundary))
1343 (insert "Content-Type: application/octet-stream\n\n")
1345 (goto-char (point-max))
1346 (insert (format "--%s--\n" boundary))
1347 (goto-char (point-max))))
1351 (autoload 'gnus-buffer-live-p "gnus-util")
1352 (autoload 'gnus-get-buffer-create "gnus")
1354 (defun mml2015-clean-buffer ()
1355 (if (gnus-buffer-live-p mml2015-result-buffer)
1356 (with-current-buffer mml2015-result-buffer
1359 (setq mml2015-result-buffer
1360 (gnus-get-buffer-create " *MML2015 Result*"))
1363 (defsubst mml2015-clear-decrypt-function ()
1364 (nth 6 (assq mml2015-use mml2015-function-alist)))
1366 (defsubst mml2015-clear-verify-function ()
1367 (nth 5 (assq mml2015-use mml2015-function-alist)))
1370 (defun mml2015-decrypt (handle ctl)
1371 (mml2015-clean-buffer)
1372 (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
1374 (funcall func handle ctl)
1378 (defun mml2015-decrypt-test (handle ctl)
1382 (defun mml2015-verify (handle ctl)
1383 (mml2015-clean-buffer)
1384 (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
1386 (funcall func handle ctl)
1390 (defun mml2015-verify-test (handle ctl)
1394 (defun mml2015-encrypt (cont &optional sign)
1395 (mml2015-clean-buffer)
1396 (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
1398 (funcall func cont sign)
1399 (error "Cannot find encrypt function"))))
1402 (defun mml2015-sign (cont)
1403 (mml2015-clean-buffer)
1404 (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
1407 (error "Cannot find sign function"))))
1410 (defun mml2015-self-encrypt ()
1411 (mml2015-encrypt nil))
1415 ;;; mml2015.el ends here