1 ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP)
3 ;; Copyright (C) 2000-2016 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
30 (eval-when-compile (require 'cl))
37 (defvar mc-pgp-always-sign)
39 (declare-function epg-check-configuration "ext:epg-config"
40 (config &optional minimum-version))
41 (declare-function epg-configuration "ext:epg-config" ())
43 ;; Maybe this should be in eg mml-sec.el (and have a different name).
44 ;; Then mml1991 would not need to require mml2015, and mml1991-use
46 (defvar mml2015-use 'epg
47 "The package used for PGP/MIME.
48 Valid packages include `epg', `pgg' and `mailcrypt'.")
50 ;; Something is not RFC2015.
51 (defvar mml2015-function-alist
52 '((mailcrypt mml2015-mailcrypt-sign
53 mml2015-mailcrypt-encrypt
54 mml2015-mailcrypt-verify
55 mml2015-mailcrypt-decrypt
56 mml2015-mailcrypt-clear-verify
57 mml2015-mailcrypt-clear-decrypt)
62 mml2015-pgg-clear-verify
63 mml2015-pgg-clear-decrypt)
68 mml2015-epg-clear-verify
69 mml2015-epg-clear-decrypt))
70 "Alist of PGP/MIME functions.")
72 (defvar mml2015-result-buffer nil)
74 (defcustom mml2015-unabbrev-trust-alist
75 '(("TRUST_UNDEFINED" . nil)
77 ("TRUST_MARGINAL" . t)
79 ("TRUST_ULTIMATE" . t))
80 "Map GnuPG trust output values to a boolean saying if you trust the key."
83 :type '(repeat (cons (regexp :tag "GnuPG output regexp")
84 (boolean :tag "Trust key"))))
86 (defcustom mml2015-cache-passphrase mml-secure-cache-passphrase
87 "If t, cache passphrase."
90 (make-obsolete-variable 'mml2015-cache-passphrase
91 'mml-secure-cache-passphrase
94 (defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
95 "How many seconds the passphrase is cached.
96 Whether the passphrase is cached at all is controlled by
97 `mml2015-cache-passphrase'."
100 (make-obsolete-variable 'mml2015-passphrase-cache-expiry
101 'mml-secure-passphrase-cache-expiry
104 (defcustom mml2015-signers nil
105 "A list of your own key ID(s) which will be used to sign a message.
106 If set, it overrides the setting of `mml2015-sign-with-sender'."
107 :group 'mime-security
108 :type '(repeat (string :tag "Key ID")))
110 (defcustom mml2015-sign-with-sender nil
111 "If t, use message sender so find a key to sign with."
112 :group 'mime-security
116 (defcustom mml2015-encrypt-to-self nil
117 "If t, add your own key ID to recipient list when encryption."
118 :group 'mime-security
121 (defcustom mml2015-always-trust t
122 "If t, GnuPG skip key validation on encryption."
123 :group 'mime-security
126 (defcustom mml2015-maximum-key-image-dimension 64
127 "The maximum dimension (width or height) of any key images."
129 :group 'mime-security
132 (defcustom mml2015-display-key-image t
133 "If t, try to display key images."
135 :group 'mime-security
138 ;; Extract plaintext from cleartext signature. IMO, this kind of task
139 ;; should be done by GnuPG rather than Elisp, but older PGP backends
140 ;; (such as Mailcrypt, and PGG) discard the output from GnuPG.
141 (defun mml2015-extract-cleartext-signature ()
143 ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still
144 ;; believe that the right way is to use the plaintext output from GnuPG as
145 ;; it is, and mml2015-extract-cleartext-signature is just a kludge for
146 ;; misdesigned libraries like PGG, which have no ability to do that. So, I
147 ;; think it should not have descriptive documentation.''
149 ;; This function doesn't handle NotDashEscaped correctly. EasyPG handles it
151 ;; http://thread.gmane.org/gmane.emacs.gnus.general/66062/focus=66082
152 ;; http://thread.gmane.org/gmane.emacs.gnus.general/65087/focus=65109
153 (goto-char (point-min))
155 ;; We need to be careful not to strip beyond the armor headers.
156 ;; Previously, an attacker could replace the text inside our
157 ;; markup with trailing garbage by injecting whitespace into the
159 (while (looking-at "Hash:") ; The only header allowed in cleartext
160 (forward-line)) ; signatures according to RFC2440.
161 (when (looking-at "[\t ]*$")
163 (delete-region (point-min) (point))
164 (if (re-search-forward "^-----BEGIN PGP SIGNATURE-----" nil t)
165 (delete-region (match-beginning 0) (point-max)))
166 (goto-char (point-min))
167 (while (re-search-forward "^- " nil t)
168 (replace-match "" t t)
171 ;;; mailcrypt wrapper
173 (autoload 'mailcrypt-decrypt "mailcrypt")
174 (autoload 'mailcrypt-verify "mailcrypt")
175 (autoload 'mc-pgp-always-sign "mailcrypt")
176 (autoload 'mc-encrypt-generic "mc-toplev")
177 (autoload 'mc-cleanup-recipient-headers "mc-toplev")
178 (autoload 'mc-sign-generic "mc-toplev")
180 (defvar mml2015-decrypt-function 'mailcrypt-decrypt)
181 (defvar mml2015-verify-function 'mailcrypt-verify)
183 (defun mml2015-format-error (err)
184 (if (stringp (cadr err))
186 (format "%S" (cdr err))))
188 (defun mml2015-mailcrypt-decrypt (handle ctl)
190 (let (child handles result)
191 (unless (setq child (mm-find-part-by-type
193 "application/octet-stream" nil t))
194 (mm-set-handle-multipart-parameter
195 mm-security-handle 'gnus-info "Corrupted")
196 (throw 'error handle))
198 (mm-insert-part child)
201 (funcall mml2015-decrypt-function)
203 (mm-set-handle-multipart-parameter
204 mm-security-handle 'gnus-details (mml2015-format-error err))
207 (mm-set-handle-multipart-parameter
208 mm-security-handle 'gnus-details "Quit.")
211 (mm-set-handle-multipart-parameter
212 mm-security-handle 'gnus-info "Failed")
213 (throw 'error handle))
214 (setq handles (mm-dissect-buffer t)))
215 (mm-destroy-parts handle)
216 (mm-set-handle-multipart-parameter
217 mm-security-handle 'gnus-info
219 (let ((sig (with-current-buffer mml2015-result-buffer
220 (mml2015-gpg-extract-signature-details))))
221 (concat ", Signer: " sig))))
222 (if (listp (car handles))
226 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
228 (fpr-length (string-width fingerprint))
231 (setq fingerprint (string-to-list fingerprint))
233 (setq fpr-length (- fpr-length 4))
234 (setq slice (butlast fingerprint fpr-length))
235 (setq fingerprint (nthcdr 4 fingerprint))
236 (setq n-slice (1+ n-slice))
242 (otherwise (concat " " slice))))))
245 (defun mml2015-gpg-extract-signature-details ()
246 (goto-char (point-min))
247 (let* ((expired (re-search-forward
248 "^\\[GNUPG:\\] SIGEXPIRED$"
250 (signer (and (re-search-forward
251 "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
253 (cons (match-string 1) (match-string 2))))
254 (fprint (and (re-search-forward
255 "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
258 (trust (and (re-search-forward
259 "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
263 (cdr (assoc trust mml2015-unabbrev-trust-alist))))
264 (cond ((and signer fprint)
266 (unless trust-good-enough-p
267 (concat "\nUntrusted, Fingerprint: "
268 (mml2015-gpg-pretty-print-fpr fprint)))
270 (format "\nWARNING: Signature from expired key (%s)"
273 "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
276 "From unknown user"))))
278 (defun mml2015-mailcrypt-clear-decrypt ()
282 (funcall mml2015-decrypt-function)
284 (mm-set-handle-multipart-parameter
285 mm-security-handle 'gnus-details (mml2015-format-error err))
288 (mm-set-handle-multipart-parameter
289 mm-security-handle 'gnus-details "Quit.")
292 (mm-set-handle-multipart-parameter
293 mm-security-handle 'gnus-info "OK")
294 (mm-set-handle-multipart-parameter
295 mm-security-handle 'gnus-info "Failed"))))
297 (defun mml2015-fix-micalg (alg)
299 ;; Mutt/1.2.5i has seen sending micalg=php-sha1
300 (upcase (if (string-match "^p[gh]p-" alg)
301 (substring alg (match-end 0))
304 (defun mml2015-mailcrypt-verify (handle ctl)
307 (unless (setq part (mm-find-raw-part-by-type
308 ctl (or (mm-handle-multipart-ctl-parameter
310 "application/pgp-signature")
312 (mm-set-handle-multipart-parameter
313 mm-security-handle 'gnus-info "Corrupted")
314 (throw 'error handle))
316 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
317 (insert (format "Hash: %s\n\n"
318 (or (mml2015-fix-micalg
319 (mm-handle-multipart-ctl-parameter
323 (narrow-to-region (point) (point))
325 (goto-char (point-min))
327 (if (looking-at "^-")
330 (unless (setq part (mm-find-part-by-type
331 (cdr handle) "application/pgp-signature" nil t))
332 (mm-set-handle-multipart-parameter
333 mm-security-handle 'gnus-info "Corrupted")
334 (throw 'error handle))
336 (narrow-to-region (point) (point))
337 (mm-insert-part part)
338 (goto-char (point-min))
339 (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t)
340 (replace-match "-----BEGIN PGP SIGNATURE-----" t t))
341 (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t)
342 (replace-match "-----END PGP SIGNATURE-----" t t)))
343 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
344 (unless (condition-case err
346 (funcall mml2015-verify-function)
347 (if (get-buffer " *mailcrypt stderr temp")
348 (mm-set-handle-multipart-parameter
349 mm-security-handle 'gnus-details
350 (with-current-buffer " *mailcrypt stderr temp"
352 (if (get-buffer " *mailcrypt stdout temp")
353 (kill-buffer " *mailcrypt stdout temp"))
354 (if (get-buffer " *mailcrypt stderr temp")
355 (kill-buffer " *mailcrypt stderr temp"))
356 (if (get-buffer " *mailcrypt status temp")
357 (kill-buffer " *mailcrypt status temp"))
358 (if (get-buffer mc-gpg-debug-buffer)
359 (kill-buffer mc-gpg-debug-buffer)))
361 (mm-set-handle-multipart-parameter
362 mm-security-handle 'gnus-details (mml2015-format-error err))
365 (mm-set-handle-multipart-parameter
366 mm-security-handle 'gnus-details "Quit.")
368 (mm-set-handle-multipart-parameter
369 mm-security-handle 'gnus-info "Failed")
370 (throw 'error handle))))
371 (mm-set-handle-multipart-parameter
372 mm-security-handle 'gnus-info "OK")
375 (defun mml2015-mailcrypt-clear-verify ()
376 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
377 (if (condition-case err
379 (funcall mml2015-verify-function)
380 (if (get-buffer " *mailcrypt stderr temp")
381 (mm-set-handle-multipart-parameter
382 mm-security-handle 'gnus-details
383 (with-current-buffer " *mailcrypt stderr temp"
385 (if (get-buffer " *mailcrypt stdout temp")
386 (kill-buffer " *mailcrypt stdout temp"))
387 (if (get-buffer " *mailcrypt stderr temp")
388 (kill-buffer " *mailcrypt stderr temp"))
389 (if (get-buffer " *mailcrypt status temp")
390 (kill-buffer " *mailcrypt status temp"))
391 (if (get-buffer mc-gpg-debug-buffer)
392 (kill-buffer mc-gpg-debug-buffer)))
394 (mm-set-handle-multipart-parameter
395 mm-security-handle 'gnus-details (mml2015-format-error err))
398 (mm-set-handle-multipart-parameter
399 mm-security-handle 'gnus-details "Quit.")
401 (mm-set-handle-multipart-parameter
402 mm-security-handle 'gnus-info "OK")
403 (mm-set-handle-multipart-parameter
404 mm-security-handle 'gnus-info "Failed")))
405 (mml2015-extract-cleartext-signature))
407 (defun mml2015-mailcrypt-sign (cont)
408 (mc-sign-generic (message-options-get 'message-sender)
410 (let ((boundary (mml-compute-boundary cont))
412 (goto-char (point-min))
413 (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t)
414 (error "Cannot find signed begin line"))
415 (goto-char (match-beginning 0))
417 (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
418 (error "Cannot not find PGP hash"))
419 (setq hash (match-string 1))
420 (unless (re-search-forward "^$" nil t)
421 (error "Cannot not find PGP message"))
423 (delete-region (point-min) (point))
424 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
426 (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
428 (insert (format "\n--%s\n" boundary))
430 (goto-char (point-max))
431 (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t)
432 (error "Cannot find signature part"))
433 (replace-match "-----END PGP MESSAGE-----" t t)
434 (goto-char (match-beginning 0))
435 (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
437 (error "Cannot find signature part"))
438 (replace-match "-----BEGIN PGP MESSAGE-----" t t)
439 (goto-char (match-beginning 0))
441 (narrow-to-region point (point))
443 (while (re-search-forward "^- -" nil t)
444 (replace-match "-" t t))
445 (goto-char (point-max)))
446 (insert (format "--%s\n" boundary))
447 (insert "Content-Type: application/pgp-signature\n\n")
448 (goto-char (point-max))
449 (insert (format "--%s--\n" boundary))
450 (goto-char (point-max))))
452 ;; We require mm-decode, which requires mm-bodies, which autoloads
453 ;; message-options-get (!).
454 (declare-function message-options-set "message" (symbol value))
456 (defun mml2015-mailcrypt-encrypt (cont &optional sign)
457 (let ((mc-pgp-always-sign
458 (or mc-pgp-always-sign
460 (eq t (or (message-options-get 'message-sign-encrypt)
462 'message-sign-encrypt
463 (or (y-or-n-p "Sign the message? ")
468 (set-buffer-multibyte nil)
470 (or (message-options-get 'message-recipients)
471 (message-options-set 'message-recipients
472 (mc-cleanup-recipient-headers
473 (read-string "Recipients: "))))
475 (message-options-get 'message-sender))
477 (goto-char (point-min))
478 (unless (looking-at "-----BEGIN PGP MESSAGE-----")
479 (error "Fail to encrypt the message"))
480 (let ((boundary (mml-compute-boundary cont)))
481 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
483 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
484 (insert (format "--%s\n" boundary))
485 (insert "Content-Type: application/pgp-encrypted\n\n")
486 (insert "Version: 1\n\n")
487 (insert (format "--%s\n" boundary))
488 (insert "Content-Type: application/octet-stream\n\n")
489 (goto-char (point-max))
490 (insert (format "--%s--\n" boundary))
491 (goto-char (point-max))))
495 (defvar pgg-default-user-id)
496 (defvar pgg-errors-buffer)
497 (defvar pgg-output-buffer)
499 (autoload 'pgg-decrypt-region "pgg")
500 (autoload 'pgg-verify-region "pgg")
501 (autoload 'pgg-sign-region "pgg")
502 (autoload 'pgg-encrypt-region "pgg")
503 (autoload 'pgg-parse-armor "pgg-parse")
505 (defun mml2015-pgg-decrypt (handle ctl)
507 (let ((pgg-errors-buffer mml2015-result-buffer)
508 child handles result decrypt-status)
509 (unless (setq child (mm-find-part-by-type
511 "application/octet-stream" nil t))
512 (mm-set-handle-multipart-parameter
513 mm-security-handle 'gnus-info "Corrupted")
514 (throw 'error handle))
516 (mm-insert-part child)
517 (if (condition-case err
519 (pgg-decrypt-region (point-min) (point-max))
521 (with-current-buffer mml2015-result-buffer
523 (mm-set-handle-multipart-parameter
524 mm-security-handle 'gnus-details
527 (mm-set-handle-multipart-parameter
528 mm-security-handle 'gnus-details (mml2015-format-error err))
531 (mm-set-handle-multipart-parameter
532 mm-security-handle 'gnus-details "Quit.")
534 (with-current-buffer pgg-output-buffer
535 (goto-char (point-min))
536 (while (search-forward "\r\n" nil t)
537 (replace-match "\n" t t))
538 (setq handles (mm-dissect-buffer t))
539 (mm-destroy-parts handle)
540 (mm-set-handle-multipart-parameter
541 mm-security-handle 'gnus-info "OK")
542 (mm-set-handle-multipart-parameter
543 mm-security-handle 'gnus-details
544 (concat decrypt-status
545 (when (stringp (car handles))
546 "\n" (mm-handle-multipart-ctl-parameter
547 handles 'gnus-details))))
548 (if (listp (car handles))
551 (mm-set-handle-multipart-parameter
552 mm-security-handle 'gnus-info "Failed")
553 (throw 'error handle))))))
555 (defun mml2015-pgg-clear-decrypt ()
556 (let ((pgg-errors-buffer mml2015-result-buffer))
558 (pgg-decrypt-region (point-min) (point-max))
559 (mm-set-handle-multipart-parameter
560 mm-security-handle 'gnus-details
561 (with-current-buffer mml2015-result-buffer
565 ;; Treat data which pgg returns as a unibyte string.
566 (mm-disable-multibyte)
567 (insert-buffer-substring pgg-output-buffer)
568 (goto-char (point-min))
569 (while (search-forward "\r\n" nil t)
570 (replace-match "\n" t t))
571 (mm-set-handle-multipart-parameter
572 mm-security-handle 'gnus-info "OK"))
573 (mm-set-handle-multipart-parameter
574 mm-security-handle 'gnus-info "Failed"))))
576 (defun mml2015-pgg-verify (handle ctl)
577 (let ((pgg-errors-buffer mml2015-result-buffer)
578 signature-file part signature)
579 (if (or (null (setq part (mm-find-raw-part-by-type
580 ctl (or (mm-handle-multipart-ctl-parameter
582 "application/pgp-signature")
584 (null (setq signature (mm-find-part-by-type
585 (cdr handle) "application/pgp-signature" nil t))))
587 (mm-set-handle-multipart-parameter
588 mm-security-handle 'gnus-info "Corrupted")
592 ;; Convert <LF> to <CR><LF> in signed text. If --textmode is
593 ;; specified when signing, the conversion is not necessary.
594 (goto-char (point-min))
597 (unless (eq (char-before) ?\r)
601 (with-temp-file (setq signature-file (make-temp-file "pgg"))
602 (mm-insert-part signature))
603 (if (condition-case err
605 (pgg-verify-region (point-min) (point-max)
607 (goto-char (point-min))
608 (while (search-forward "\r\n" nil t)
609 (replace-match "\n" t t))
610 (mm-set-handle-multipart-parameter
611 mm-security-handle 'gnus-details
612 (concat (with-current-buffer pgg-output-buffer
614 (with-current-buffer pgg-errors-buffer
617 (mm-set-handle-multipart-parameter
618 mm-security-handle 'gnus-details (mml2015-format-error err))
621 (mm-set-handle-multipart-parameter
622 mm-security-handle 'gnus-details "Quit.")
625 (delete-file signature-file)
626 (mm-set-handle-multipart-parameter
627 mm-security-handle 'gnus-info
628 (with-current-buffer pgg-errors-buffer
629 (mml2015-gpg-extract-signature-details))))
630 (delete-file signature-file)
631 (mm-set-handle-multipart-parameter
632 mm-security-handle 'gnus-info "Failed")))))
635 (defun mml2015-pgg-clear-verify ()
636 (let ((pgg-errors-buffer mml2015-result-buffer)
637 (text (buffer-string))
638 (coding-system buffer-file-coding-system))
639 (if (condition-case err
641 (mm-with-unibyte-buffer
642 (insert (encode-coding-string text coding-system))
643 (pgg-verify-region (point-min) (point-max) nil t))
644 (goto-char (point-min))
645 (while (search-forward "\r\n" nil t)
646 (replace-match "\n" t t))
647 (mm-set-handle-multipart-parameter
648 mm-security-handle 'gnus-details
649 (concat (with-current-buffer pgg-output-buffer
651 (with-current-buffer pgg-errors-buffer
654 (mm-set-handle-multipart-parameter
655 mm-security-handle 'gnus-details (mml2015-format-error err))
658 (mm-set-handle-multipart-parameter
659 mm-security-handle 'gnus-details "Quit.")
661 (mm-set-handle-multipart-parameter
662 mm-security-handle 'gnus-info
663 (with-current-buffer pgg-errors-buffer
664 (mml2015-gpg-extract-signature-details)))
665 (mm-set-handle-multipart-parameter
666 mm-security-handle 'gnus-info "Failed")))
667 (mml2015-extract-cleartext-signature))
669 (defun mml2015-pgg-sign (cont)
670 (let ((pgg-errors-buffer mml2015-result-buffer)
671 (boundary (mml-compute-boundary cont))
672 (pgg-default-user-id (or (message-options-get 'mml-sender)
673 pgg-default-user-id))
676 (unless (pgg-sign-region (point-min) (point-max))
677 (pop-to-buffer mml2015-result-buffer)
678 (error "Sign error"))
679 (goto-char (point-min))
680 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
682 (if (setq entry (assq 2 (pgg-parse-armor
683 (with-current-buffer pgg-output-buffer
685 (setq entry (assq 'hash-algorithm (cdr entry))))
686 (insert (format "\tmicalg=%s; "
688 (downcase (format "pgp-%s" (cdr entry)))
690 (insert "protocol=\"application/pgp-signature\"\n")
691 (insert (format "\n--%s\n" boundary))
692 (goto-char (point-max))
693 (insert (format "\n--%s\n" boundary))
694 (insert "Content-Type: application/pgp-signature\n\n")
695 (insert-buffer-substring pgg-output-buffer)
696 (goto-char (point-max))
697 (insert (format "--%s--\n" boundary))
698 (goto-char (point-max))))
700 (defun mml2015-pgg-encrypt (cont &optional sign)
701 (let ((pgg-errors-buffer mml2015-result-buffer)
703 (boundary (mml-compute-boundary cont)))
704 (unless (pgg-encrypt-region (point-min) (point-max)
707 (message-options-get 'message-recipients)
708 (message-options-set 'message-recipients
709 (read-string "Recipients: ")))
712 (pop-to-buffer mml2015-result-buffer)
713 (error "Encrypt error"))
714 (delete-region (point-min) (point-max))
715 (goto-char (point-min))
716 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
718 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
719 (insert (format "--%s\n" boundary))
720 (insert "Content-Type: application/pgp-encrypted\n\n")
721 (insert "Version: 1\n\n")
722 (insert (format "--%s\n" boundary))
723 (insert "Content-Type: application/octet-stream\n\n")
724 (insert-buffer-substring pgg-output-buffer)
725 (goto-char (point-max))
726 (insert (format "--%s--\n" boundary))
727 (goto-char (point-max))))
731 (defvar epg-user-id-alist)
732 (defvar epg-digest-algorithm-alist)
733 (defvar epg-gpg-program)
734 (defvar inhibit-redisplay)
736 (autoload 'epg-make-context "epg")
737 (autoload 'epg-context-set-armor "epg")
738 (autoload 'epg-context-set-textmode "epg")
739 (autoload 'epg-context-set-signers "epg")
740 (autoload 'epg-context-result-for "epg")
741 (autoload 'epg-new-signature-digest-algorithm "epg")
742 (autoload 'epg-list-keys "epg")
743 (autoload 'epg-decrypt-string "epg")
744 (autoload 'epg-verify-string "epg")
745 (autoload 'epg-sign-string "epg")
746 (autoload 'epg-encrypt-string "epg")
747 (autoload 'epg-passphrase-callback-function "epg")
748 (autoload 'epg-context-set-passphrase-callback "epg")
749 (autoload 'epg-key-sub-key-list "epg")
750 (autoload 'epg-sub-key-capability "epg")
751 (autoload 'epg-sub-key-validity "epg")
752 (autoload 'epg-sub-key-fingerprint "epg")
753 (autoload 'epg-signature-key-id "epg")
754 (autoload 'epg-signature-to-string "epg")
755 (autoload 'epg-key-user-id-list "epg")
756 (autoload 'epg-user-id-string "epg")
757 (autoload 'epg-user-id-validity "epg")
758 (autoload 'epg-configuration "epg-config")
759 (autoload 'epg-expand-group "epg-config")
760 (autoload 'epa-select-keys "epa")
762 (defun mml2015-epg-key-image (key-id)
763 "Return the image of a key, if any"
765 (set-buffer-multibyte nil)
766 (let* ((coding-system-for-write 'binary)
767 (coding-system-for-read 'binary)
768 (data (shell-command-to-string
769 (format "%s --list-options no-show-photos --attribute-fd 3 --list-keys %s 3>&1 >/dev/null 2>&1"
770 (shell-quote-argument epg-gpg-program) key-id))))
771 (when (> (length data) 0)
772 (insert (substring data 16))
774 (gnus-create-image (buffer-string) nil t)
777 (autoload 'gnus-rescale-image "gnus-util")
779 (defun mml2015-epg-key-image-to-string (key-id)
780 "Return a string with the image of a key, if any"
781 (let ((key-image (mml2015-epg-key-image key-id)))
784 (condition-case error
788 (gnus-rescale-image key-image
789 (cons mml2015-maximum-key-image-dimension
790 mml2015-maximum-key-image-dimension))
795 (defun mml2015-epg-signature-to-string (signature)
796 (concat (epg-signature-to-string signature)
797 (when mml2015-display-key-image
798 (mml2015-epg-key-image-to-string (epg-signature-key-id signature)))))
800 (defun mml2015-epg-verify-result-to-string (verify-result)
801 (mapconcat #'mml2015-epg-signature-to-string verify-result "\n"))
803 (defun mml2015-epg-decrypt (handle ctl)
805 (let ((inhibit-redisplay t)
806 context plain child handles result decrypt-status)
807 (unless (setq child (mm-find-part-by-type
809 "application/octet-stream" nil t))
810 (mm-set-handle-multipart-parameter
811 mm-security-handle 'gnus-info "Corrupted")
812 (throw 'error handle))
813 (setq context (epg-make-context))
814 (if (or mml2015-cache-passphrase mml-secure-cache-passphrase)
815 (epg-context-set-passphrase-callback
817 (cons 'mml-secure-passphrase-callback 'OpenPGP)))
818 (condition-case error
819 (setq plain (epg-decrypt-string context (mm-get-part child))
820 mml-secure-secret-key-id-list nil)
822 (mml-secure-clear-secret-key-id-list)
823 (mm-set-handle-multipart-parameter
824 mm-security-handle 'gnus-info "Failed")
825 (if (eq (car error) 'quit)
826 (mm-set-handle-multipart-parameter
827 mm-security-handle 'gnus-details "Quit.")
828 (mm-set-handle-multipart-parameter
829 mm-security-handle 'gnus-details (mml2015-format-error error)))
830 (throw 'error handle)))
833 (goto-char (point-min))
834 (while (search-forward "\r\n" nil t)
835 (replace-match "\n" t t))
836 (setq handles (mm-dissect-buffer t))
837 (mm-destroy-parts handle)
838 (if (epg-context-result-for context 'verify)
839 (mm-set-handle-multipart-parameter
840 mm-security-handle 'gnus-info
842 (mml2015-epg-verify-result-to-string
843 (epg-context-result-for context 'verify))))
844 (mm-set-handle-multipart-parameter
845 mm-security-handle 'gnus-info "OK"))
846 (if (stringp (car handles))
847 (mm-set-handle-multipart-parameter
848 mm-security-handle 'gnus-details
849 (mm-handle-multipart-ctl-parameter handles 'gnus-details))))
850 (if (listp (car handles))
854 (defun mml2015-epg-clear-decrypt ()
855 (let ((inhibit-redisplay t)
856 (context (epg-make-context))
858 (if (or mml2015-cache-passphrase mml-secure-cache-passphrase)
859 (epg-context-set-passphrase-callback
861 (cons 'mml-secure-passphrase-callback 'OpenPGP)))
862 (condition-case error
863 (setq plain (epg-decrypt-string context (buffer-string))
864 mml-secure-secret-key-id-list nil)
866 (mml-secure-clear-secret-key-id-list)
867 (mm-set-handle-multipart-parameter
868 mm-security-handle 'gnus-info "Failed")
869 (if (eq (car error) 'quit)
870 (mm-set-handle-multipart-parameter
871 mm-security-handle 'gnus-details "Quit.")
872 (mm-set-handle-multipart-parameter
873 mm-security-handle 'gnus-details (mml2015-format-error error)))))
876 ;; Treat data which epg returns as a unibyte string.
877 (mm-disable-multibyte)
879 (goto-char (point-min))
880 (while (search-forward "\r\n" nil t)
881 (replace-match "\n" t t))
882 (mm-set-handle-multipart-parameter
883 mm-security-handle 'gnus-info "OK")
884 (if (epg-context-result-for context 'verify)
885 (mm-set-handle-multipart-parameter
886 mm-security-handle 'gnus-details
887 (mml2015-epg-verify-result-to-string
888 (epg-context-result-for context 'verify)))))))
890 (defun mml2015-epg-verify (handle ctl)
892 (let ((inhibit-redisplay t)
893 context plain signature-file part signature)
894 (when (or (null (setq part (mm-find-raw-part-by-type
895 ctl (or (mm-handle-multipart-ctl-parameter
897 "application/pgp-signature")
899 (null (setq signature (mm-find-part-by-type
900 (cdr handle) "application/pgp-signature"
902 (mm-set-handle-multipart-parameter
903 mm-security-handle 'gnus-info "Corrupted")
904 (throw 'error handle))
905 (setq part (replace-regexp-in-string "\n" "\r\n" part)
906 signature (mm-get-part signature)
907 context (epg-make-context))
908 (condition-case error
909 (setq plain (epg-verify-string context signature part))
911 (mm-set-handle-multipart-parameter
912 mm-security-handle 'gnus-info "Failed")
913 (if (eq (car error) 'quit)
914 (mm-set-handle-multipart-parameter
915 mm-security-handle 'gnus-details "Quit.")
916 (mm-set-handle-multipart-parameter
917 mm-security-handle 'gnus-details (mml2015-format-error error)))
918 (throw 'error handle)))
919 (mm-set-handle-multipart-parameter
920 mm-security-handle 'gnus-info
921 (mml2015-epg-verify-result-to-string
922 (epg-context-result-for context 'verify)))
925 (defun mml2015-epg-clear-verify ()
926 (let ((inhibit-redisplay t)
927 (context (epg-make-context))
928 (signature (encode-coding-string (buffer-string)
929 coding-system-for-write))
931 (condition-case error
932 (setq plain (epg-verify-string context signature))
934 (mm-set-handle-multipart-parameter
935 mm-security-handle 'gnus-info "Failed")
936 (if (eq (car error) 'quit)
937 (mm-set-handle-multipart-parameter
938 mm-security-handle 'gnus-details "Quit.")
939 (mm-set-handle-multipart-parameter
940 mm-security-handle 'gnus-details (mml2015-format-error error)))))
943 (mm-set-handle-multipart-parameter
944 mm-security-handle 'gnus-info
945 (mml2015-epg-verify-result-to-string
946 (epg-context-result-for context 'verify)))
947 (delete-region (point-min) (point-max))
948 (insert (decode-coding-string plain coding-system-for-read)))
949 (mml2015-extract-cleartext-signature))))
951 (defun mml2015-epg-sign (cont)
952 (let ((inhibit-redisplay t)
953 (boundary (mml-compute-boundary cont)))
954 ;; Signed data must end with a newline (RFC 3156, 5).
955 (goto-char (point-max))
958 (let* ((pair (mml-secure-epg-sign 'OpenPGP t))
959 (signature (car pair))
961 (goto-char (point-min))
962 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
965 (insert (format "\tmicalg=pgp-%s; "
968 epg-digest-algorithm-alist))))))
969 (insert "protocol=\"application/pgp-signature\"\n")
970 (insert (format "\n--%s\n" boundary))
971 (goto-char (point-max))
972 (insert (format "\n--%s\n" boundary))
973 (insert "Content-Type: application/pgp-signature; name=\"signature.asc\"\n\n")
975 (goto-char (point-max))
976 (insert (format "--%s--\n" boundary))
977 (goto-char (point-max)))))
979 (defun mml2015-epg-encrypt (cont &optional sign)
980 (let* ((inhibit-redisplay t)
981 (boundary (mml-compute-boundary cont))
982 (cipher (mml-secure-epg-encrypt 'OpenPGP cont sign)))
983 (delete-region (point-min) (point-max))
984 (goto-char (point-min))
985 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
987 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
988 (insert (format "--%s\n" boundary))
989 (insert "Content-Type: application/pgp-encrypted\n\n")
990 (insert "Version: 1\n\n")
991 (insert (format "--%s\n" boundary))
992 (insert "Content-Type: application/octet-stream\n\n")
994 (goto-char (point-max))
995 (insert (format "--%s--\n" boundary))
996 (goto-char (point-max))))
1000 (autoload 'gnus-buffer-live-p "gnus-util")
1001 (autoload 'gnus-get-buffer-create "gnus")
1003 (defun mml2015-clean-buffer ()
1004 (if (gnus-buffer-live-p mml2015-result-buffer)
1005 (with-current-buffer mml2015-result-buffer
1008 (setq mml2015-result-buffer
1009 (gnus-get-buffer-create " *MML2015 Result*"))
1012 (defsubst mml2015-clear-decrypt-function ()
1013 (nth 6 (assq mml2015-use mml2015-function-alist)))
1015 (defsubst mml2015-clear-verify-function ()
1016 (nth 5 (assq mml2015-use mml2015-function-alist)))
1019 (defun mml2015-decrypt (handle ctl)
1020 (mml2015-clean-buffer)
1021 (let ((func (nth 4 (assq mml2015-use mml2015-function-alist))))
1023 (funcall func handle ctl)
1027 (defun mml2015-decrypt-test (handle ctl)
1031 (defun mml2015-verify (handle ctl)
1032 (mml2015-clean-buffer)
1033 (let ((func (nth 3 (assq mml2015-use mml2015-function-alist))))
1035 (funcall func handle ctl)
1039 (defun mml2015-verify-test (handle ctl)
1043 (defun mml2015-encrypt (cont &optional sign)
1044 (mml2015-clean-buffer)
1045 (let ((func (nth 2 (assq mml2015-use mml2015-function-alist))))
1047 (funcall func cont sign)
1048 (error "Cannot find encrypt function"))))
1051 (defun mml2015-sign (cont)
1052 (mml2015-clean-buffer)
1053 (let ((func (nth 1 (assq mml2015-use mml2015-function-alist))))
1056 (error "Cannot find sign function"))))
1059 (defun mml2015-self-encrypt ()
1060 (mml2015-encrypt nil))
1064 ;;; mml2015.el ends here