1 ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
3 ;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
5 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
6 ;; Keywords: PGP MIME MML
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;; RFC 2015 is updated by RFC 3156, this file should be compatible
31 ;; For Emacs <22.2 and XEmacs.
32 (unless (fboundp 'declare-function
) (defmacro declare-function
(&rest r
)))
34 (if (locate-library "password-cache")
35 (require 'password-cache
)
38 (eval-when-compile (require 'cl
))
44 (defvar mc-pgp-always-sign
)
46 (declare-function epg-check-configuration
"ext:epg-config"
47 (config &optional minimum-version
))
48 (declare-function epg-configuration
"ext:epg-config" ())
50 (defvar mml2015-use
(or
54 (epg-check-configuration (epg-configuration))
58 (ignore-errors (require 'pgg
))
59 (and (fboundp 'pgg-sign-region
)
63 (and (fboundp 'mc-encrypt-generic
)
64 (fboundp 'mc-sign-generic
)
65 (fboundp 'mc-cleanup-recipient-headers
)
67 "The package used for PGP/MIME.
68 Valid packages include `epg', `pgg' and `mailcrypt'.")
70 ;; Something is not RFC2015.
71 (defvar mml2015-function-alist
72 '((mailcrypt mml2015-mailcrypt-sign
73 mml2015-mailcrypt-encrypt
74 mml2015-mailcrypt-verify
75 mml2015-mailcrypt-decrypt
76 mml2015-mailcrypt-clear-verify
77 mml2015-mailcrypt-clear-decrypt
)
82 mml2015-pgg-clear-verify
83 mml2015-pgg-clear-decrypt
)
88 mml2015-epg-clear-verify
89 mml2015-epg-clear-decrypt
))
90 "Alist of PGP/MIME functions.")
92 (defvar mml2015-result-buffer nil
)
94 (defcustom mml2015-unabbrev-trust-alist
95 '(("TRUST_UNDEFINED" . nil
)
97 ("TRUST_MARGINAL" . t
)
99 ("TRUST_ULTIMATE" . t
))
100 "Map GnuPG trust output values to a boolean saying if you trust the key."
102 :group
'mime-security
103 :type
'(repeat (cons (regexp :tag
"GnuPG output regexp")
104 (boolean :tag
"Trust key"))))
106 (defcustom mml2015-cache-passphrase mml-secure-cache-passphrase
107 "If t, cache passphrase."
108 :group
'mime-security
111 (defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
112 "How many seconds the passphrase is cached.
113 Whether the passphrase is cached at all is controlled by
114 `mml2015-cache-passphrase'."
115 :group
'mime-security
118 (defcustom mml2015-signers nil
119 "A list of your own key ID which will be used to sign a message."
120 :group
'mime-security
121 :type
'(repeat (string :tag
"Key ID")))
123 (defcustom mml2015-encrypt-to-self nil
124 "If t, add your own key ID to recipient list when encryption."
125 :group
'mime-security
128 (defcustom mml2015-always-trust t
129 "If t, GnuPG skip key validation on encryption."
130 :group
'mime-security
133 ;; Extract plaintext from cleartext signature. IMO, this kind of task
134 ;; should be done by GnuPG rather than Elisp, but older PGP backends
135 ;; (such as Mailcrypt, and PGG) discard the output from GnuPG.
136 (defun mml2015-extract-cleartext-signature ()
138 ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still
139 ;; believe that the right way is to use the plaintext output from GnuPG as
140 ;; it is, and mml2015-extract-cleartext-signature is just a kludge for
141 ;; misdesigned libraries like PGG, which have no ability to do that. So, I
142 ;; think it should not have descriptive documentation.''
144 ;; This function doesn't handle NotDashEscaped correctly. EasyPG handles it
146 ;; http://thread.gmane.org/gmane.emacs.gnus.general/66062/focus=66082
147 ;; http://thread.gmane.org/gmane.emacs.gnus.general/65087/focus=65109
148 (goto-char (point-min))
150 ;; We need to be careful not to strip beyond the armor headers.
151 ;; Previously, an attacker could replace the text inside our
152 ;; markup with trailing garbage by injecting whitespace into the
154 (while (looking-at "Hash:") ; The only header allowed in cleartext
155 (forward-line)) ; signatures according to RFC2440.
156 (when (looking-at "[\t ]*$")
158 (delete-region (point-min) (point))
159 (if (re-search-forward "^-----BEGIN PGP SIGNATURE-----" nil t
)
160 (delete-region (match-beginning 0) (point-max)))
161 (goto-char (point-min))
162 (while (re-search-forward "^- " nil t
)
163 (replace-match "" t t
)
166 ;;; mailcrypt wrapper
168 (autoload 'mailcrypt-decrypt
"mailcrypt")
169 (autoload 'mailcrypt-verify
"mailcrypt")
170 (autoload 'mc-pgp-always-sign
"mailcrypt")
171 (autoload 'mc-encrypt-generic
"mc-toplev")
172 (autoload 'mc-cleanup-recipient-headers
"mc-toplev")
173 (autoload 'mc-sign-generic
"mc-toplev")
175 (defvar mml2015-decrypt-function
'mailcrypt-decrypt
)
176 (defvar mml2015-verify-function
'mailcrypt-verify
)
178 (defun mml2015-format-error (err)
179 (if (stringp (cadr err
))
181 (format "%S" (cdr err
))))
183 (defun mml2015-mailcrypt-decrypt (handle ctl
)
185 (let (child handles result
)
186 (unless (setq child
(mm-find-part-by-type
188 "application/octet-stream" nil t
))
189 (mm-set-handle-multipart-parameter
190 mm-security-handle
'gnus-info
"Corrupted")
191 (throw 'error handle
))
193 (mm-insert-part child
)
196 (funcall mml2015-decrypt-function
)
198 (mm-set-handle-multipart-parameter
199 mm-security-handle
'gnus-details
(mml2015-format-error err
))
202 (mm-set-handle-multipart-parameter
203 mm-security-handle
'gnus-details
"Quit.")
206 (mm-set-handle-multipart-parameter
207 mm-security-handle
'gnus-info
"Failed")
208 (throw 'error handle
))
209 (setq handles
(mm-dissect-buffer t
)))
210 (mm-destroy-parts handle
)
211 (mm-set-handle-multipart-parameter
212 mm-security-handle
'gnus-info
214 (let ((sig (with-current-buffer mml2015-result-buffer
215 (mml2015-gpg-extract-signature-details))))
216 (concat ", Signer: " sig
))))
217 (if (listp (car handles
))
221 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
223 (fpr-length (string-width fingerprint
))
226 (setq fingerprint
(string-to-list fingerprint
))
228 (setq fpr-length
(- fpr-length
4))
229 (setq slice
(butlast fingerprint fpr-length
))
230 (setq fingerprint
(nthcdr 4 fingerprint
))
231 (setq n-slice
(1+ n-slice
))
237 (otherwise (concat " " slice
))))))
240 (defun mml2015-gpg-extract-signature-details ()
241 (goto-char (point-min))
242 (let* ((expired (re-search-forward
243 "^\\[GNUPG:\\] SIGEXPIRED$"
245 (signer (and (re-search-forward
246 "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
248 (cons (match-string 1) (match-string 2))))
249 (fprint (and (re-search-forward
250 "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
253 (trust (and (re-search-forward
254 "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
258 (cdr (assoc trust mml2015-unabbrev-trust-alist
))))
259 (cond ((and signer fprint
)
261 (unless trust-good-enough-p
262 (concat "\nUntrusted, Fingerprint: "
263 (mml2015-gpg-pretty-print-fpr fprint
)))
265 (format "\nWARNING: Signature from expired key (%s)"
268 "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t
)
271 "From unknown user"))))
273 (defun mml2015-mailcrypt-clear-decrypt ()
277 (funcall mml2015-decrypt-function
)
279 (mm-set-handle-multipart-parameter
280 mm-security-handle
'gnus-details
(mml2015-format-error err
))
283 (mm-set-handle-multipart-parameter
284 mm-security-handle
'gnus-details
"Quit.")
287 (mm-set-handle-multipart-parameter
288 mm-security-handle
'gnus-info
"OK")
289 (mm-set-handle-multipart-parameter
290 mm-security-handle
'gnus-info
"Failed"))))
292 (defun mml2015-fix-micalg (alg)
294 ;; Mutt/1.2.5i has seen sending micalg=php-sha1
295 (upcase (if (string-match "^p[gh]p-" alg
)
296 (substring alg
(match-end 0))
299 (defun mml2015-mailcrypt-verify (handle ctl
)
302 (unless (setq part
(mm-find-raw-part-by-type
303 ctl
(or (mm-handle-multipart-ctl-parameter
305 "application/pgp-signature")
307 (mm-set-handle-multipart-parameter
308 mm-security-handle
'gnus-info
"Corrupted")
309 (throw 'error handle
))
311 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
312 (insert (format "Hash: %s\n\n"
313 (or (mml2015-fix-micalg
314 (mm-handle-multipart-ctl-parameter
318 (narrow-to-region (point) (point))
320 (goto-char (point-min))
322 (if (looking-at "^-")
325 (unless (setq part
(mm-find-part-by-type
326 (cdr handle
) "application/pgp-signature" nil t
))
327 (mm-set-handle-multipart-parameter
328 mm-security-handle
'gnus-info
"Corrupted")
329 (throw 'error handle
))
331 (narrow-to-region (point) (point))
332 (mm-insert-part part
)
333 (goto-char (point-min))
334 (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t
)
335 (replace-match "-----BEGIN PGP SIGNATURE-----" t t
))
336 (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t
)
337 (replace-match "-----END PGP SIGNATURE-----" t t
)))
338 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
339 (unless (condition-case err
341 (funcall mml2015-verify-function
)
342 (if (get-buffer " *mailcrypt stderr temp")
343 (mm-set-handle-multipart-parameter
344 mm-security-handle
'gnus-details
345 (with-current-buffer " *mailcrypt stderr temp"
347 (if (get-buffer " *mailcrypt stdout temp")
348 (kill-buffer " *mailcrypt stdout temp"))
349 (if (get-buffer " *mailcrypt stderr temp")
350 (kill-buffer " *mailcrypt stderr temp"))
351 (if (get-buffer " *mailcrypt status temp")
352 (kill-buffer " *mailcrypt status temp"))
353 (if (get-buffer mc-gpg-debug-buffer
)
354 (kill-buffer mc-gpg-debug-buffer
)))
356 (mm-set-handle-multipart-parameter
357 mm-security-handle
'gnus-details
(mml2015-format-error err
))
360 (mm-set-handle-multipart-parameter
361 mm-security-handle
'gnus-details
"Quit.")
363 (mm-set-handle-multipart-parameter
364 mm-security-handle
'gnus-info
"Failed")
365 (throw 'error handle
))))
366 (mm-set-handle-multipart-parameter
367 mm-security-handle
'gnus-info
"OK")
370 (defun mml2015-mailcrypt-clear-verify ()
371 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
372 (if (condition-case err
374 (funcall mml2015-verify-function
)
375 (if (get-buffer " *mailcrypt stderr temp")
376 (mm-set-handle-multipart-parameter
377 mm-security-handle
'gnus-details
378 (with-current-buffer " *mailcrypt stderr temp"
380 (if (get-buffer " *mailcrypt stdout temp")
381 (kill-buffer " *mailcrypt stdout temp"))
382 (if (get-buffer " *mailcrypt stderr temp")
383 (kill-buffer " *mailcrypt stderr temp"))
384 (if (get-buffer " *mailcrypt status temp")
385 (kill-buffer " *mailcrypt status temp"))
386 (if (get-buffer mc-gpg-debug-buffer
)
387 (kill-buffer mc-gpg-debug-buffer
)))
389 (mm-set-handle-multipart-parameter
390 mm-security-handle
'gnus-details
(mml2015-format-error err
))
393 (mm-set-handle-multipart-parameter
394 mm-security-handle
'gnus-details
"Quit.")
396 (mm-set-handle-multipart-parameter
397 mm-security-handle
'gnus-info
"OK")
398 (mm-set-handle-multipart-parameter
399 mm-security-handle
'gnus-info
"Failed")))
400 (mml2015-extract-cleartext-signature))
402 (defun mml2015-mailcrypt-sign (cont)
403 (mc-sign-generic (message-options-get 'message-sender
)
405 (let ((boundary (mml-compute-boundary cont
))
407 (goto-char (point-min))
408 (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t
)
409 (error "Cannot find signed begin line"))
410 (goto-char (match-beginning 0))
412 (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
413 (error "Cannot not find PGP hash"))
414 (setq hash
(match-string 1))
415 (unless (re-search-forward "^$" nil t
)
416 (error "Cannot not find PGP message"))
418 (delete-region (point-min) (point))
419 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
421 (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
423 (insert (format "\n--%s\n" boundary
))
425 (goto-char (point-max))
426 (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t
)
427 (error "Cannot find signature part"))
428 (replace-match "-----END PGP MESSAGE-----" t t
)
429 (goto-char (match-beginning 0))
430 (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
432 (error "Cannot find signature part"))
433 (replace-match "-----BEGIN PGP MESSAGE-----" t t
)
434 (goto-char (match-beginning 0))
436 (narrow-to-region point
(point))
438 (while (re-search-forward "^- -" nil t
)
439 (replace-match "-" t t
))
440 (goto-char (point-max)))
441 (insert (format "--%s\n" boundary
))
442 (insert "Content-Type: application/pgp-signature\n\n")
443 (goto-char (point-max))
444 (insert (format "--%s--\n" boundary
))
445 (goto-char (point-max))))
447 ;; We require mm-decode, which requires mm-bodies, which autoloads
448 ;; message-options-get (!).
449 (declare-function message-options-set
"message" (symbol value
))
451 (defun mml2015-mailcrypt-encrypt (cont &optional sign
)
452 (let ((mc-pgp-always-sign
453 (or mc-pgp-always-sign
455 (eq t
(or (message-options-get 'message-sign-encrypt
)
457 'message-sign-encrypt
458 (or (y-or-n-p "Sign the message? ")
461 (mm-with-unibyte-current-buffer
463 (or (message-options-get 'message-recipients
)
464 (message-options-set 'message-recipients
465 (mc-cleanup-recipient-headers
466 (read-string "Recipients: "))))
468 (message-options-get 'message-sender
))))
469 (goto-char (point-min))
470 (unless (looking-at "-----BEGIN PGP MESSAGE-----")
471 (error "Fail to encrypt the message"))
472 (let ((boundary (mml-compute-boundary cont
)))
473 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
475 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
476 (insert (format "--%s\n" boundary
))
477 (insert "Content-Type: application/pgp-encrypted\n\n")
478 (insert "Version: 1\n\n")
479 (insert (format "--%s\n" boundary
))
480 (insert "Content-Type: application/octet-stream\n\n")
481 (goto-char (point-max))
482 (insert (format "--%s--\n" boundary
))
483 (goto-char (point-max))))
487 (defvar pgg-default-user-id
)
488 (defvar pgg-errors-buffer
)
489 (defvar pgg-output-buffer
)
491 (autoload 'pgg-decrypt-region
"pgg")
492 (autoload 'pgg-verify-region
"pgg")
493 (autoload 'pgg-sign-region
"pgg")
494 (autoload 'pgg-encrypt-region
"pgg")
495 (autoload 'pgg-parse-armor
"pgg-parse")
497 (defun mml2015-pgg-decrypt (handle ctl
)
499 (let ((pgg-errors-buffer mml2015-result-buffer
)
500 child handles result decrypt-status
)
501 (unless (setq child
(mm-find-part-by-type
503 "application/octet-stream" nil t
))
504 (mm-set-handle-multipart-parameter
505 mm-security-handle
'gnus-info
"Corrupted")
506 (throw 'error handle
))
508 (mm-insert-part child
)
509 (if (condition-case err
511 (pgg-decrypt-region (point-min) (point-max))
513 (with-current-buffer mml2015-result-buffer
515 (mm-set-handle-multipart-parameter
516 mm-security-handle
'gnus-details
519 (mm-set-handle-multipart-parameter
520 mm-security-handle
'gnus-details
(mml2015-format-error err
))
523 (mm-set-handle-multipart-parameter
524 mm-security-handle
'gnus-details
"Quit.")
526 (with-current-buffer pgg-output-buffer
527 (goto-char (point-min))
528 (while (search-forward "\r\n" nil t
)
529 (replace-match "\n" t t
))
530 (setq handles
(mm-dissect-buffer t
))
531 (mm-destroy-parts handle
)
532 (mm-set-handle-multipart-parameter
533 mm-security-handle
'gnus-info
"OK")
534 (mm-set-handle-multipart-parameter
535 mm-security-handle
'gnus-details
536 (concat decrypt-status
537 (when (stringp (car handles
))
538 "\n" (mm-handle-multipart-ctl-parameter
539 handles
'gnus-details
))))
540 (if (listp (car handles
))
543 (mm-set-handle-multipart-parameter
544 mm-security-handle
'gnus-info
"Failed")
545 (throw 'error handle
))))))
547 (defun mml2015-pgg-clear-decrypt ()
548 (let ((pgg-errors-buffer mml2015-result-buffer
))
550 (pgg-decrypt-region (point-min) (point-max))
551 (mm-set-handle-multipart-parameter
552 mm-security-handle
'gnus-details
553 (with-current-buffer mml2015-result-buffer
557 ;; Treat data which pgg returns as a unibyte string.
558 (mm-disable-multibyte)
559 (insert-buffer-substring pgg-output-buffer
)
560 (goto-char (point-min))
561 (while (search-forward "\r\n" nil t
)
562 (replace-match "\n" t t
))
563 (mm-set-handle-multipart-parameter
564 mm-security-handle
'gnus-info
"OK"))
565 (mm-set-handle-multipart-parameter
566 mm-security-handle
'gnus-info
"Failed"))))
568 (defun mml2015-pgg-verify (handle ctl
)
569 (let ((pgg-errors-buffer mml2015-result-buffer
)
570 signature-file part signature
)
571 (if (or (null (setq part
(mm-find-raw-part-by-type
572 ctl
(or (mm-handle-multipart-ctl-parameter
574 "application/pgp-signature")
576 (null (setq signature
(mm-find-part-by-type
577 (cdr handle
) "application/pgp-signature" nil t
))))
579 (mm-set-handle-multipart-parameter
580 mm-security-handle
'gnus-info
"Corrupted")
584 ;; Convert <LF> to <CR><LF> in signed text. If --textmode is
585 ;; specified when signing, the conversion is not necessary.
586 (goto-char (point-min))
589 (unless (eq (char-before) ?
\r)
593 (with-temp-file (setq signature-file
(mm-make-temp-file "pgg"))
594 (mm-insert-part signature
))
595 (if (condition-case err
597 (pgg-verify-region (point-min) (point-max)
599 (goto-char (point-min))
600 (while (search-forward "\r\n" nil t
)
601 (replace-match "\n" t t
))
602 (mm-set-handle-multipart-parameter
603 mm-security-handle
'gnus-details
604 (concat (with-current-buffer pgg-output-buffer
606 (with-current-buffer pgg-errors-buffer
609 (mm-set-handle-multipart-parameter
610 mm-security-handle
'gnus-details
(mml2015-format-error err
))
613 (mm-set-handle-multipart-parameter
614 mm-security-handle
'gnus-details
"Quit.")
617 (delete-file signature-file
)
618 (mm-set-handle-multipart-parameter
619 mm-security-handle
'gnus-info
620 (with-current-buffer pgg-errors-buffer
621 (mml2015-gpg-extract-signature-details))))
622 (delete-file signature-file
)
623 (mm-set-handle-multipart-parameter
624 mm-security-handle
'gnus-info
"Failed")))))
627 (defun mml2015-pgg-clear-verify ()
628 (let ((pgg-errors-buffer mml2015-result-buffer
)
629 (text (buffer-string))
630 (coding-system buffer-file-coding-system
))
631 (if (condition-case err
633 (mm-with-unibyte-buffer
634 (insert (mm-encode-coding-string text coding-system
))
635 (pgg-verify-region (point-min) (point-max) nil t
))
636 (goto-char (point-min))
637 (while (search-forward "\r\n" nil t
)
638 (replace-match "\n" t t
))
639 (mm-set-handle-multipart-parameter
640 mm-security-handle
'gnus-details
641 (concat (with-current-buffer pgg-output-buffer
643 (with-current-buffer pgg-errors-buffer
646 (mm-set-handle-multipart-parameter
647 mm-security-handle
'gnus-details
(mml2015-format-error err
))
650 (mm-set-handle-multipart-parameter
651 mm-security-handle
'gnus-details
"Quit.")
653 (mm-set-handle-multipart-parameter
654 mm-security-handle
'gnus-info
655 (with-current-buffer pgg-errors-buffer
656 (mml2015-gpg-extract-signature-details)))
657 (mm-set-handle-multipart-parameter
658 mm-security-handle
'gnus-info
"Failed")))
659 (mml2015-extract-cleartext-signature))
661 (defun mml2015-pgg-sign (cont)
662 (let ((pgg-errors-buffer mml2015-result-buffer
)
663 (boundary (mml-compute-boundary cont
))
664 (pgg-default-user-id (or (message-options-get 'mml-sender
)
665 pgg-default-user-id
))
668 (unless (pgg-sign-region (point-min) (point-max))
669 (pop-to-buffer mml2015-result-buffer
)
670 (error "Sign error"))
671 (goto-char (point-min))
672 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
674 (if (setq entry
(assq 2 (pgg-parse-armor
675 (with-current-buffer pgg-output-buffer
677 (setq entry
(assq 'hash-algorithm
(cdr entry
))))
678 (insert (format "\tmicalg=%s; "
680 (downcase (format "pgp-%s" (cdr entry
)))
682 (insert "protocol=\"application/pgp-signature\"\n")
683 (insert (format "\n--%s\n" boundary
))
684 (goto-char (point-max))
685 (insert (format "\n--%s\n" boundary
))
686 (insert "Content-Type: application/pgp-signature\n\n")
687 (insert-buffer-substring pgg-output-buffer
)
688 (goto-char (point-max))
689 (insert (format "--%s--\n" boundary
))
690 (goto-char (point-max))))
692 (defun mml2015-pgg-encrypt (cont &optional sign
)
693 (let ((pgg-errors-buffer mml2015-result-buffer
)
695 (boundary (mml-compute-boundary cont
)))
696 (unless (pgg-encrypt-region (point-min) (point-max)
699 (message-options-get 'message-recipients
)
700 (message-options-set 'message-recipients
701 (read-string "Recipients: ")))
704 (pop-to-buffer mml2015-result-buffer
)
705 (error "Encrypt error"))
706 (delete-region (point-min) (point-max))
707 (goto-char (point-min))
708 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
710 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
711 (insert (format "--%s\n" boundary
))
712 (insert "Content-Type: application/pgp-encrypted\n\n")
713 (insert "Version: 1\n\n")
714 (insert (format "--%s\n" boundary
))
715 (insert "Content-Type: application/octet-stream\n\n")
716 (insert-buffer-substring pgg-output-buffer
)
717 (goto-char (point-max))
718 (insert (format "--%s--\n" boundary
))
719 (goto-char (point-max))))
723 (defvar epg-user-id-alist
)
724 (defvar epg-digest-algorithm-alist
)
725 (defvar inhibit-redisplay
)
727 (autoload 'epg-make-context
"epg")
728 (autoload 'epg-context-set-armor
"epg")
729 (autoload 'epg-context-set-textmode
"epg")
730 (autoload 'epg-context-set-signers
"epg")
731 (autoload 'epg-context-result-for
"epg")
732 (autoload 'epg-new-signature-digest-algorithm
"epg")
733 (autoload 'epg-verify-result-to-string
"epg")
734 (autoload 'epg-list-keys
"epg")
735 (autoload 'epg-decrypt-string
"epg")
736 (autoload 'epg-verify-string
"epg")
737 (autoload 'epg-sign-string
"epg")
738 (autoload 'epg-encrypt-string
"epg")
739 (autoload 'epg-passphrase-callback-function
"epg")
740 (autoload 'epg-context-set-passphrase-callback
"epg")
741 (autoload 'epg-key-sub-key-list
"epg")
742 (autoload 'epg-sub-key-capability
"epg")
743 (autoload 'epg-sub-key-validity
"epg")
744 (autoload 'epg-sub-key-fingerprint
"epg")
745 (autoload 'epg-configuration
"epg-config")
746 (autoload 'epg-expand-group
"epg-config")
747 (autoload 'epa-select-keys
"epa")
749 (defvar mml2015-epg-secret-key-id-list nil
)
751 (defun mml2015-epg-passphrase-callback (context key-id ignore
)
753 (epg-passphrase-callback-function context key-id nil
)
754 (let* ((password-cache-key-id
762 "Passphrase for PIN: "
763 (if (setq entry
(assoc key-id epg-user-id-alist
))
764 (format "Passphrase for %s %s: " key-id
(cdr entry
))
765 (format "Passphrase for %s: " key-id
)))
766 password-cache-key-id
)))
768 (let ((password-cache-expiry mml2015-passphrase-cache-expiry
))
769 (password-cache-add password-cache-key-id passphrase
))
770 (setq mml2015-epg-secret-key-id-list
771 (cons password-cache-key-id mml2015-epg-secret-key-id-list
))
772 (copy-sequence passphrase
)))))
774 (defun mml2015-epg-find-usable-key (keys usage
)
777 (let ((pointer (epg-key-sub-key-list (car keys
))))
779 (if (and (memq usage
(epg-sub-key-capability (car pointer
)))
780 (not (memq 'disabled
(epg-sub-key-capability (car pointer
))))
781 (not (memq (epg-sub-key-validity (car pointer
))
782 '(revoked expired
))))
783 (throw 'found
(car keys
)))
784 (setq pointer
(cdr pointer
))))
785 (setq keys
(cdr keys
)))))
787 ;; XXX: since gpg --list-secret-keys does not return validity of each
788 ;; key, `mml2015-epg-find-usable-key' defined above is not enough for
789 ;; secret keys. The function `mml2015-epg-find-usable-secret-key'
790 ;; below looks at appropriate public keys to check usability.
791 (defun mml2015-epg-find-usable-secret-key (context name usage
)
792 (let ((secret-keys (epg-list-keys context name t
))
794 (while (and (not secret-key
) secret-keys
)
795 (if (mml2015-epg-find-usable-key
796 (epg-list-keys context
(epg-sub-key-fingerprint
797 (car (epg-key-sub-key-list
798 (car secret-keys
)))))
800 (setq secret-key
(car secret-keys
)
802 (setq secret-keys
(cdr secret-keys
))))
805 (defun mml2015-epg-decrypt (handle ctl
)
807 (let ((inhibit-redisplay t
)
808 context plain child handles result decrypt-status
)
809 (unless (setq child
(mm-find-part-by-type
811 "application/octet-stream" nil t
))
812 (mm-set-handle-multipart-parameter
813 mm-security-handle
'gnus-info
"Corrupted")
814 (throw 'error handle
))
815 (setq context
(epg-make-context))
816 (if mml2015-cache-passphrase
817 (epg-context-set-passphrase-callback
819 #'mml2015-epg-passphrase-callback
))
820 (condition-case error
821 (setq plain
(epg-decrypt-string context
(mm-get-part child
))
822 mml2015-epg-secret-key-id-list nil
)
824 (while mml2015-epg-secret-key-id-list
825 (password-cache-remove (car mml2015-epg-secret-key-id-list
))
826 (setq mml2015-epg-secret-key-id-list
827 (cdr mml2015-epg-secret-key-id-list
)))
828 (mm-set-handle-multipart-parameter
829 mm-security-handle
'gnus-info
"Failed")
830 (if (eq (car error
) 'quit
)
831 (mm-set-handle-multipart-parameter
832 mm-security-handle
'gnus-details
"Quit.")
833 (mm-set-handle-multipart-parameter
834 mm-security-handle
'gnus-details
(mml2015-format-error error
)))
835 (throw 'error handle
)))
838 (goto-char (point-min))
839 (while (search-forward "\r\n" nil t
)
840 (replace-match "\n" t t
))
841 (setq handles
(mm-dissect-buffer t
))
842 (mm-destroy-parts handle
)
843 (if (epg-context-result-for context
'verify
)
844 (mm-set-handle-multipart-parameter
845 mm-security-handle
'gnus-info
847 (epg-verify-result-to-string
848 (epg-context-result-for context
'verify
))))
849 (mm-set-handle-multipart-parameter
850 mm-security-handle
'gnus-info
"OK"))
851 (if (stringp (car handles
))
852 (mm-set-handle-multipart-parameter
853 mm-security-handle
'gnus-details
854 (mm-handle-multipart-ctl-parameter handles
'gnus-details
))))
855 (if (listp (car handles
))
859 (defun mml2015-epg-clear-decrypt ()
860 (let ((inhibit-redisplay t
)
861 (context (epg-make-context))
863 (if mml2015-cache-passphrase
864 (epg-context-set-passphrase-callback
866 #'mml2015-epg-passphrase-callback
))
867 (condition-case error
868 (setq plain
(epg-decrypt-string context
(buffer-string))
869 mml2015-epg-secret-key-id-list nil
)
871 (while mml2015-epg-secret-key-id-list
872 (password-cache-remove (car mml2015-epg-secret-key-id-list
))
873 (setq mml2015-epg-secret-key-id-list
874 (cdr mml2015-epg-secret-key-id-list
)))
875 (mm-set-handle-multipart-parameter
876 mm-security-handle
'gnus-info
"Failed")
877 (if (eq (car error
) 'quit
)
878 (mm-set-handle-multipart-parameter
879 mm-security-handle
'gnus-details
"Quit.")
880 (mm-set-handle-multipart-parameter
881 mm-security-handle
'gnus-details
(mml2015-format-error error
)))))
884 ;; Treat data which epg returns as a unibyte string.
885 (mm-disable-multibyte)
887 (goto-char (point-min))
888 (while (search-forward "\r\n" nil t
)
889 (replace-match "\n" t t
))
890 (mm-set-handle-multipart-parameter
891 mm-security-handle
'gnus-info
"OK")
892 (if (epg-context-result-for context
'verify
)
893 (mm-set-handle-multipart-parameter
894 mm-security-handle
'gnus-details
895 (epg-verify-result-to-string
896 (epg-context-result-for context
'verify
)))))))
898 (defun mml2015-epg-verify (handle ctl
)
900 (let ((inhibit-redisplay t
)
901 context plain signature-file part signature
)
902 (when (or (null (setq part
(mm-find-raw-part-by-type
903 ctl
(or (mm-handle-multipart-ctl-parameter
905 "application/pgp-signature")
907 (null (setq signature
(mm-find-part-by-type
908 (cdr handle
) "application/pgp-signature"
910 (mm-set-handle-multipart-parameter
911 mm-security-handle
'gnus-info
"Corrupted")
912 (throw 'error handle
))
913 (setq part
(mm-replace-in-string part
"\n" "\r\n" t
)
914 signature
(mm-get-part signature
)
915 context
(epg-make-context))
916 (condition-case error
917 (setq plain
(epg-verify-string context signature part
))
919 (mm-set-handle-multipart-parameter
920 mm-security-handle
'gnus-info
"Failed")
921 (if (eq (car error
) 'quit
)
922 (mm-set-handle-multipart-parameter
923 mm-security-handle
'gnus-details
"Quit.")
924 (mm-set-handle-multipart-parameter
925 mm-security-handle
'gnus-details
(mml2015-format-error error
)))
926 (throw 'error handle
)))
927 (mm-set-handle-multipart-parameter
928 mm-security-handle
'gnus-info
929 (epg-verify-result-to-string (epg-context-result-for context
'verify
)))
932 (defun mml2015-epg-clear-verify ()
933 (let ((inhibit-redisplay t
)
934 (context (epg-make-context))
935 (signature (mm-encode-coding-string (buffer-string)
936 coding-system-for-write
))
938 (condition-case error
939 (setq plain
(epg-verify-string context signature
))
941 (mm-set-handle-multipart-parameter
942 mm-security-handle
'gnus-info
"Failed")
943 (if (eq (car error
) 'quit
)
944 (mm-set-handle-multipart-parameter
945 mm-security-handle
'gnus-details
"Quit.")
946 (mm-set-handle-multipart-parameter
947 mm-security-handle
'gnus-details
(mml2015-format-error error
)))))
950 (mm-set-handle-multipart-parameter
951 mm-security-handle
'gnus-info
952 (epg-verify-result-to-string
953 (epg-context-result-for context
'verify
)))
954 (delete-region (point-min) (point-max))
955 (insert (mm-decode-coding-string plain coding-system-for-read
)))
956 (mml2015-extract-cleartext-signature))))
958 (defun mml2015-epg-sign (cont)
959 (let* ((inhibit-redisplay t
)
960 (context (epg-make-context))
961 (boundary (mml-compute-boundary cont
))
962 (sender (message-options-get 'message-sender
))
965 (or (message-options-get 'mml2015-epg-signers
)
968 (if (eq mm-sign-option
'guided
)
969 (epa-select-keys context
"\
970 Select keys for signing.
971 If no one is selected, default secret key is used. "
973 (cons (concat "<" sender
">")
977 (if (or sender mml2015-signers
)
982 (mml2015-epg-find-usable-secret-key
983 context signer
'sign
))
984 (unless (or signer-key
987 "No secret key for %s; skip it? "
989 (error "No secret key for %s" signer
))
992 (cons (concat "<" sender
">")
994 mml2015-signers
))))))))
996 (epg-context-set-armor context t
)
997 (epg-context-set-textmode context t
)
998 (epg-context-set-signers context signers
)
999 (if mml2015-cache-passphrase
1000 (epg-context-set-passphrase-callback
1002 #'mml2015-epg-passphrase-callback
))
1003 (condition-case error
1004 (setq signature
(epg-sign-string context
(buffer-string) t
)
1005 mml2015-epg-secret-key-id-list nil
)
1007 (while mml2015-epg-secret-key-id-list
1008 (password-cache-remove (car mml2015-epg-secret-key-id-list
))
1009 (setq mml2015-epg-secret-key-id-list
1010 (cdr mml2015-epg-secret-key-id-list
)))
1011 (signal (car error
) (cdr error
))))
1012 (if (epg-context-result-for context
'sign
)
1013 (setq micalg
(epg-new-signature-digest-algorithm
1014 (car (epg-context-result-for context
'sign
)))))
1015 (goto-char (point-min))
1016 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
1019 (insert (format "\tmicalg=pgp-%s; "
1022 epg-digest-algorithm-alist
))))))
1023 (insert "protocol=\"application/pgp-signature\"\n")
1024 (insert (format "\n--%s\n" boundary
))
1025 (goto-char (point-max))
1026 (insert (format "\n--%s\n" boundary
))
1027 (insert "Content-Type: application/pgp-signature\n\n")
1029 (goto-char (point-max))
1030 (insert (format "--%s--\n" boundary
))
1031 (goto-char (point-max))))
1033 (defun mml2015-epg-encrypt (cont &optional sign
)
1034 (let ((inhibit-redisplay t
)
1035 (context (epg-make-context))
1036 (config (epg-configuration))
1037 (sender (message-options-get 'message-sender
))
1038 (recipients (message-options-get 'mml2015-epg-recipients
))
1040 (boundary (mml-compute-boundary cont
))
1041 recipient-key signer-key
)
1047 (or (epg-expand-group config recipient
)
1048 (list (concat "<" recipient
">"))))
1050 (or (message-options-get 'message-recipients
)
1051 (message-options-set 'message-recipients
1052 (read-string "Recipients: ")))
1053 "[ \f\t\n\r\v,]+"))))
1054 (when mml2015-encrypt-to-self
1055 (unless (or sender mml2015-signers
)
1056 (error "Message sender and mml2015-signers not set"))
1057 (setq recipients
(nconc recipients
(if sender
1058 (cons (concat "<" sender
">")
1061 (if (eq mm-encrypt-option
'guided
)
1063 (epa-select-keys context
"\
1064 Select recipients for encryption.
1065 If no one is selected, symmetric encryption will be performed. "
1071 (setq recipient-key
(mml2015-epg-find-usable-key
1072 (epg-list-keys context recipient
)
1074 (unless (or recipient-key
1076 (format "No public key for %s; skip it? "
1078 (error "No public key for %s" recipient
))
1082 (error "No recipient specified")))
1083 (message-options-set 'mml2015-epg-recipients recipients
))
1086 (or (message-options-get 'mml2015-epg-signers
)
1087 (message-options-set
1088 'mml2015-epg-signers
1089 (if (eq mm-sign-option
'guided
)
1090 (epa-select-keys context
"\
1091 Select keys for signing.
1092 If no one is selected, default secret key is used. "
1094 (cons (concat "<" sender
">")
1098 (if (or sender mml2015-signers
)
1103 (mml2015-epg-find-usable-secret-key
1104 context signer
'sign
))
1105 (unless (or signer-key
1108 "No secret key for %s; skip it? "
1110 (error "No secret key for %s" signer
))
1113 (cons (concat "<" sender
">") mml2015-signers
)
1114 mml2015-signers
))))))))
1115 (epg-context-set-signers context signers
))
1116 (epg-context-set-armor context t
)
1117 (epg-context-set-textmode context t
)
1118 (if mml2015-cache-passphrase
1119 (epg-context-set-passphrase-callback
1121 #'mml2015-epg-passphrase-callback
))
1122 (condition-case error
1124 (epg-encrypt-string context
(buffer-string) recipients sign
1125 mml2015-always-trust
)
1126 mml2015-epg-secret-key-id-list nil
)
1128 (while mml2015-epg-secret-key-id-list
1129 (password-cache-remove (car mml2015-epg-secret-key-id-list
))
1130 (setq mml2015-epg-secret-key-id-list
1131 (cdr mml2015-epg-secret-key-id-list
)))
1132 (signal (car error
) (cdr error
))))
1133 (delete-region (point-min) (point-max))
1134 (goto-char (point-min))
1135 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
1137 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
1138 (insert (format "--%s\n" boundary
))
1139 (insert "Content-Type: application/pgp-encrypted\n\n")
1140 (insert "Version: 1\n\n")
1141 (insert (format "--%s\n" boundary
))
1142 (insert "Content-Type: application/octet-stream\n\n")
1144 (goto-char (point-max))
1145 (insert (format "--%s--\n" boundary
))
1146 (goto-char (point-max))))
1150 (autoload 'gnus-buffer-live-p
"gnus-util")
1151 (autoload 'gnus-get-buffer-create
"gnus")
1153 (defun mml2015-clean-buffer ()
1154 (if (gnus-buffer-live-p mml2015-result-buffer
)
1155 (with-current-buffer mml2015-result-buffer
1158 (setq mml2015-result-buffer
1159 (gnus-get-buffer-create " *MML2015 Result*"))
1162 (defsubst mml2015-clear-decrypt-function
()
1163 (nth 6 (assq mml2015-use mml2015-function-alist
)))
1165 (defsubst mml2015-clear-verify-function
()
1166 (nth 5 (assq mml2015-use mml2015-function-alist
)))
1169 (defun mml2015-decrypt (handle ctl
)
1170 (mml2015-clean-buffer)
1171 (let ((func (nth 4 (assq mml2015-use mml2015-function-alist
))))
1173 (funcall func handle ctl
)
1177 (defun mml2015-decrypt-test (handle ctl
)
1181 (defun mml2015-verify (handle ctl
)
1182 (mml2015-clean-buffer)
1183 (let ((func (nth 3 (assq mml2015-use mml2015-function-alist
))))
1185 (funcall func handle ctl
)
1189 (defun mml2015-verify-test (handle ctl
)
1193 (defun mml2015-encrypt (cont &optional sign
)
1194 (mml2015-clean-buffer)
1195 (let ((func (nth 2 (assq mml2015-use mml2015-function-alist
))))
1197 (funcall func cont sign
)
1198 (error "Cannot find encrypt function"))))
1201 (defun mml2015-sign (cont)
1202 (mml2015-clean-buffer)
1203 (let ((func (nth 1 (assq mml2015-use mml2015-function-alist
))))
1206 (error "Cannot find sign function"))))
1209 (defun mml2015-self-encrypt ()
1210 (mml2015-encrypt nil
))
1214 ;;; mml2015.el ends here