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
))
36 (defvar mc-pgp-always-sign
)
38 (declare-function epg-check-configuration
"ext:epg-config"
39 (config &optional minimum-version
))
40 (declare-function epg-configuration
"ext:epg-config" ())
42 ;; Maybe this should be in eg mml-sec.el (and have a different name).
43 ;; Then mml1991 would not need to require mml2015, and mml1991-use
45 (defvar mml2015-use
(or
47 (ignore-errors (require 'epg-config
))
48 (and (fboundp 'epg-check-configuration
)
51 (let ((abs-file (locate-library "pgg")))
52 ;; Don't load PGG if it is marked as obsolete
55 (not (string-match "/obsolete/[^/]*\\'"
57 (ignore-errors (require 'pgg
))
58 (and (fboundp 'pgg-sign-region
)
62 (and (fboundp 'mc-encrypt-generic
)
63 (fboundp 'mc-sign-generic
)
64 (fboundp 'mc-cleanup-recipient-headers
)
66 "The package used for PGP/MIME.
67 Valid packages include `epg', `pgg' and `mailcrypt'.")
69 ;; Something is not RFC2015.
70 (defvar mml2015-function-alist
71 '((mailcrypt mml2015-mailcrypt-sign
72 mml2015-mailcrypt-encrypt
73 mml2015-mailcrypt-verify
74 mml2015-mailcrypt-decrypt
75 mml2015-mailcrypt-clear-verify
76 mml2015-mailcrypt-clear-decrypt
)
81 mml2015-pgg-clear-verify
82 mml2015-pgg-clear-decrypt
)
87 mml2015-epg-clear-verify
88 mml2015-epg-clear-decrypt
))
89 "Alist of PGP/MIME functions.")
91 (defvar mml2015-result-buffer nil
)
93 (defcustom mml2015-unabbrev-trust-alist
94 '(("TRUST_UNDEFINED" . nil
)
96 ("TRUST_MARGINAL" . t
)
98 ("TRUST_ULTIMATE" . t
))
99 "Map GnuPG trust output values to a boolean saying if you trust the key."
101 :group
'mime-security
102 :type
'(repeat (cons (regexp :tag
"GnuPG output regexp")
103 (boolean :tag
"Trust key"))))
105 (defcustom mml2015-cache-passphrase mml-secure-cache-passphrase
106 "If t, cache passphrase."
107 :group
'mime-security
109 (make-obsolete-variable 'mml2015-cache-passphrase
110 'mml-secure-cache-passphrase
113 (defcustom mml2015-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
114 "How many seconds the passphrase is cached.
115 Whether the passphrase is cached at all is controlled by
116 `mml2015-cache-passphrase'."
117 :group
'mime-security
119 (make-obsolete-variable 'mml2015-passphrase-cache-expiry
120 'mml-secure-passphrase-cache-expiry
123 (defcustom mml2015-signers nil
124 "A list of your own key ID(s) which will be used to sign a message.
125 If set, it overrides the setting of `mml2015-sign-with-sender'."
126 :group
'mime-security
127 :type
'(repeat (string :tag
"Key ID")))
129 (defcustom mml2015-sign-with-sender nil
130 "If t, use message sender so find a key to sign with."
131 :group
'mime-security
135 (defcustom mml2015-encrypt-to-self nil
136 "If t, add your own key ID to recipient list when encryption."
137 :group
'mime-security
140 (defcustom mml2015-always-trust t
141 "If t, GnuPG skip key validation on encryption."
142 :group
'mime-security
145 (defcustom mml2015-maximum-key-image-dimension
64
146 "The maximum dimension (width or height) of any key images."
148 :group
'mime-security
151 (defcustom mml2015-display-key-image t
152 "If t, try to display key images."
154 :group
'mime-security
157 ;; Extract plaintext from cleartext signature. IMO, this kind of task
158 ;; should be done by GnuPG rather than Elisp, but older PGP backends
159 ;; (such as Mailcrypt, and PGG) discard the output from GnuPG.
160 (defun mml2015-extract-cleartext-signature ()
162 ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still
163 ;; believe that the right way is to use the plaintext output from GnuPG as
164 ;; it is, and mml2015-extract-cleartext-signature is just a kludge for
165 ;; misdesigned libraries like PGG, which have no ability to do that. So, I
166 ;; think it should not have descriptive documentation.''
168 ;; This function doesn't handle NotDashEscaped correctly. EasyPG handles it
170 ;; http://thread.gmane.org/gmane.emacs.gnus.general/66062/focus=66082
171 ;; http://thread.gmane.org/gmane.emacs.gnus.general/65087/focus=65109
172 (goto-char (point-min))
174 ;; We need to be careful not to strip beyond the armor headers.
175 ;; Previously, an attacker could replace the text inside our
176 ;; markup with trailing garbage by injecting whitespace into the
178 (while (looking-at "Hash:") ; The only header allowed in cleartext
179 (forward-line)) ; signatures according to RFC2440.
180 (when (looking-at "[\t ]*$")
182 (delete-region (point-min) (point))
183 (if (re-search-forward "^-----BEGIN PGP SIGNATURE-----" nil t
)
184 (delete-region (match-beginning 0) (point-max)))
185 (goto-char (point-min))
186 (while (re-search-forward "^- " nil t
)
187 (replace-match "" t t
)
190 ;;; mailcrypt wrapper
192 (autoload 'mailcrypt-decrypt
"mailcrypt")
193 (autoload 'mailcrypt-verify
"mailcrypt")
194 (autoload 'mc-pgp-always-sign
"mailcrypt")
195 (autoload 'mc-encrypt-generic
"mc-toplev")
196 (autoload 'mc-cleanup-recipient-headers
"mc-toplev")
197 (autoload 'mc-sign-generic
"mc-toplev")
199 (defvar mml2015-decrypt-function
'mailcrypt-decrypt
)
200 (defvar mml2015-verify-function
'mailcrypt-verify
)
202 (defun mml2015-format-error (err)
203 (if (stringp (cadr err
))
205 (format "%S" (cdr err
))))
207 (defun mml2015-mailcrypt-decrypt (handle ctl
)
209 (let (child handles result
)
210 (unless (setq child
(mm-find-part-by-type
212 "application/octet-stream" nil t
))
213 (mm-set-handle-multipart-parameter
214 mm-security-handle
'gnus-info
"Corrupted")
215 (throw 'error handle
))
217 (mm-insert-part child
)
220 (funcall mml2015-decrypt-function
)
222 (mm-set-handle-multipart-parameter
223 mm-security-handle
'gnus-details
(mml2015-format-error err
))
226 (mm-set-handle-multipart-parameter
227 mm-security-handle
'gnus-details
"Quit.")
230 (mm-set-handle-multipart-parameter
231 mm-security-handle
'gnus-info
"Failed")
232 (throw 'error handle
))
233 (setq handles
(mm-dissect-buffer t
)))
234 (mm-destroy-parts handle
)
235 (mm-set-handle-multipart-parameter
236 mm-security-handle
'gnus-info
238 (let ((sig (with-current-buffer mml2015-result-buffer
239 (mml2015-gpg-extract-signature-details))))
240 (concat ", Signer: " sig
))))
241 (if (listp (car handles
))
245 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
247 (fpr-length (string-width fingerprint
))
250 (setq fingerprint
(string-to-list fingerprint
))
252 (setq fpr-length
(- fpr-length
4))
253 (setq slice
(butlast fingerprint fpr-length
))
254 (setq fingerprint
(nthcdr 4 fingerprint
))
255 (setq n-slice
(1+ n-slice
))
261 (otherwise (concat " " slice
))))))
264 (defun mml2015-gpg-extract-signature-details ()
265 (goto-char (point-min))
266 (let* ((expired (re-search-forward
267 "^\\[GNUPG:\\] SIGEXPIRED$"
269 (signer (and (re-search-forward
270 "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
272 (cons (match-string 1) (match-string 2))))
273 (fprint (and (re-search-forward
274 "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
277 (trust (and (re-search-forward
278 "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
282 (cdr (assoc trust mml2015-unabbrev-trust-alist
))))
283 (cond ((and signer fprint
)
285 (unless trust-good-enough-p
286 (concat "\nUntrusted, Fingerprint: "
287 (mml2015-gpg-pretty-print-fpr fprint
)))
289 (format "\nWARNING: Signature from expired key (%s)"
292 "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t
)
295 "From unknown user"))))
297 (defun mml2015-mailcrypt-clear-decrypt ()
301 (funcall mml2015-decrypt-function
)
303 (mm-set-handle-multipart-parameter
304 mm-security-handle
'gnus-details
(mml2015-format-error err
))
307 (mm-set-handle-multipart-parameter
308 mm-security-handle
'gnus-details
"Quit.")
311 (mm-set-handle-multipart-parameter
312 mm-security-handle
'gnus-info
"OK")
313 (mm-set-handle-multipart-parameter
314 mm-security-handle
'gnus-info
"Failed"))))
316 (defun mml2015-fix-micalg (alg)
318 ;; Mutt/1.2.5i has seen sending micalg=php-sha1
319 (upcase (if (string-match "^p[gh]p-" alg
)
320 (substring alg
(match-end 0))
323 (defun mml2015-mailcrypt-verify (handle ctl
)
326 (unless (setq part
(mm-find-raw-part-by-type
327 ctl
(or (mm-handle-multipart-ctl-parameter
329 "application/pgp-signature")
331 (mm-set-handle-multipart-parameter
332 mm-security-handle
'gnus-info
"Corrupted")
333 (throw 'error handle
))
335 (insert "-----BEGIN PGP SIGNED MESSAGE-----\n")
336 (insert (format "Hash: %s\n\n"
337 (or (mml2015-fix-micalg
338 (mm-handle-multipart-ctl-parameter
342 (narrow-to-region (point) (point))
344 (goto-char (point-min))
346 (if (looking-at "^-")
349 (unless (setq part
(mm-find-part-by-type
350 (cdr handle
) "application/pgp-signature" nil t
))
351 (mm-set-handle-multipart-parameter
352 mm-security-handle
'gnus-info
"Corrupted")
353 (throw 'error handle
))
355 (narrow-to-region (point) (point))
356 (mm-insert-part part
)
357 (goto-char (point-min))
358 (if (re-search-forward "^-----BEGIN PGP [^-]+-----\r?$" nil t
)
359 (replace-match "-----BEGIN PGP SIGNATURE-----" t t
))
360 (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t
)
361 (replace-match "-----END PGP SIGNATURE-----" t t
)))
362 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
363 (unless (condition-case err
365 (funcall mml2015-verify-function
)
366 (if (get-buffer " *mailcrypt stderr temp")
367 (mm-set-handle-multipart-parameter
368 mm-security-handle
'gnus-details
369 (with-current-buffer " *mailcrypt stderr temp"
371 (if (get-buffer " *mailcrypt stdout temp")
372 (kill-buffer " *mailcrypt stdout temp"))
373 (if (get-buffer " *mailcrypt stderr temp")
374 (kill-buffer " *mailcrypt stderr temp"))
375 (if (get-buffer " *mailcrypt status temp")
376 (kill-buffer " *mailcrypt status temp"))
377 (if (get-buffer mc-gpg-debug-buffer
)
378 (kill-buffer mc-gpg-debug-buffer
)))
380 (mm-set-handle-multipart-parameter
381 mm-security-handle
'gnus-details
(mml2015-format-error err
))
384 (mm-set-handle-multipart-parameter
385 mm-security-handle
'gnus-details
"Quit.")
387 (mm-set-handle-multipart-parameter
388 mm-security-handle
'gnus-info
"Failed")
389 (throw 'error handle
))))
390 (mm-set-handle-multipart-parameter
391 mm-security-handle
'gnus-info
"OK")
394 (defun mml2015-mailcrypt-clear-verify ()
395 (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*")))
396 (if (condition-case err
398 (funcall mml2015-verify-function
)
399 (if (get-buffer " *mailcrypt stderr temp")
400 (mm-set-handle-multipart-parameter
401 mm-security-handle
'gnus-details
402 (with-current-buffer " *mailcrypt stderr temp"
404 (if (get-buffer " *mailcrypt stdout temp")
405 (kill-buffer " *mailcrypt stdout temp"))
406 (if (get-buffer " *mailcrypt stderr temp")
407 (kill-buffer " *mailcrypt stderr temp"))
408 (if (get-buffer " *mailcrypt status temp")
409 (kill-buffer " *mailcrypt status temp"))
410 (if (get-buffer mc-gpg-debug-buffer
)
411 (kill-buffer mc-gpg-debug-buffer
)))
413 (mm-set-handle-multipart-parameter
414 mm-security-handle
'gnus-details
(mml2015-format-error err
))
417 (mm-set-handle-multipart-parameter
418 mm-security-handle
'gnus-details
"Quit.")
420 (mm-set-handle-multipart-parameter
421 mm-security-handle
'gnus-info
"OK")
422 (mm-set-handle-multipart-parameter
423 mm-security-handle
'gnus-info
"Failed")))
424 (mml2015-extract-cleartext-signature))
426 (defun mml2015-mailcrypt-sign (cont)
427 (mc-sign-generic (message-options-get 'message-sender
)
429 (let ((boundary (mml-compute-boundary cont
))
431 (goto-char (point-min))
432 (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t
)
433 (error "Cannot find signed begin line"))
434 (goto-char (match-beginning 0))
436 (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)")
437 (error "Cannot not find PGP hash"))
438 (setq hash
(match-string 1))
439 (unless (re-search-forward "^$" nil t
)
440 (error "Cannot not find PGP message"))
442 (delete-region (point-min) (point))
443 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
445 (insert (format "\tmicalg=pgp-%s; protocol=\"application/pgp-signature\"\n"
447 (insert (format "\n--%s\n" boundary
))
449 (goto-char (point-max))
450 (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t
)
451 (error "Cannot find signature part"))
452 (replace-match "-----END PGP MESSAGE-----" t t
)
453 (goto-char (match-beginning 0))
454 (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$"
456 (error "Cannot find signature part"))
457 (replace-match "-----BEGIN PGP MESSAGE-----" t t
)
458 (goto-char (match-beginning 0))
460 (narrow-to-region point
(point))
462 (while (re-search-forward "^- -" nil t
)
463 (replace-match "-" t t
))
464 (goto-char (point-max)))
465 (insert (format "--%s\n" boundary
))
466 (insert "Content-Type: application/pgp-signature\n\n")
467 (goto-char (point-max))
468 (insert (format "--%s--\n" boundary
))
469 (goto-char (point-max))))
471 ;; We require mm-decode, which requires mm-bodies, which autoloads
472 ;; message-options-get (!).
473 (declare-function message-options-set
"message" (symbol value
))
475 (defun mml2015-mailcrypt-encrypt (cont &optional sign
)
476 (let ((mc-pgp-always-sign
477 (or mc-pgp-always-sign
479 (eq t
(or (message-options-get 'message-sign-encrypt
)
481 'message-sign-encrypt
482 (or (y-or-n-p "Sign the message? ")
485 (mm-with-unibyte-current-buffer
487 (or (message-options-get 'message-recipients
)
488 (message-options-set 'message-recipients
489 (mc-cleanup-recipient-headers
490 (read-string "Recipients: "))))
492 (message-options-get 'message-sender
))))
493 (goto-char (point-min))
494 (unless (looking-at "-----BEGIN PGP MESSAGE-----")
495 (error "Fail to encrypt the message"))
496 (let ((boundary (mml-compute-boundary cont
)))
497 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
499 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
500 (insert (format "--%s\n" boundary
))
501 (insert "Content-Type: application/pgp-encrypted\n\n")
502 (insert "Version: 1\n\n")
503 (insert (format "--%s\n" boundary
))
504 (insert "Content-Type: application/octet-stream\n\n")
505 (goto-char (point-max))
506 (insert (format "--%s--\n" boundary
))
507 (goto-char (point-max))))
511 (defvar pgg-default-user-id
)
512 (defvar pgg-errors-buffer
)
513 (defvar pgg-output-buffer
)
515 (autoload 'pgg-decrypt-region
"pgg")
516 (autoload 'pgg-verify-region
"pgg")
517 (autoload 'pgg-sign-region
"pgg")
518 (autoload 'pgg-encrypt-region
"pgg")
519 (autoload 'pgg-parse-armor
"pgg-parse")
521 (defun mml2015-pgg-decrypt (handle ctl
)
523 (let ((pgg-errors-buffer mml2015-result-buffer
)
524 child handles result decrypt-status
)
525 (unless (setq child
(mm-find-part-by-type
527 "application/octet-stream" nil t
))
528 (mm-set-handle-multipart-parameter
529 mm-security-handle
'gnus-info
"Corrupted")
530 (throw 'error handle
))
532 (mm-insert-part child
)
533 (if (condition-case err
535 (pgg-decrypt-region (point-min) (point-max))
537 (with-current-buffer mml2015-result-buffer
539 (mm-set-handle-multipart-parameter
540 mm-security-handle
'gnus-details
543 (mm-set-handle-multipart-parameter
544 mm-security-handle
'gnus-details
(mml2015-format-error err
))
547 (mm-set-handle-multipart-parameter
548 mm-security-handle
'gnus-details
"Quit.")
550 (with-current-buffer pgg-output-buffer
551 (goto-char (point-min))
552 (while (search-forward "\r\n" nil t
)
553 (replace-match "\n" t t
))
554 (setq handles
(mm-dissect-buffer t
))
555 (mm-destroy-parts handle
)
556 (mm-set-handle-multipart-parameter
557 mm-security-handle
'gnus-info
"OK")
558 (mm-set-handle-multipart-parameter
559 mm-security-handle
'gnus-details
560 (concat decrypt-status
561 (when (stringp (car handles
))
562 "\n" (mm-handle-multipart-ctl-parameter
563 handles
'gnus-details
))))
564 (if (listp (car handles
))
567 (mm-set-handle-multipart-parameter
568 mm-security-handle
'gnus-info
"Failed")
569 (throw 'error handle
))))))
571 (defun mml2015-pgg-clear-decrypt ()
572 (let ((pgg-errors-buffer mml2015-result-buffer
))
574 (pgg-decrypt-region (point-min) (point-max))
575 (mm-set-handle-multipart-parameter
576 mm-security-handle
'gnus-details
577 (with-current-buffer mml2015-result-buffer
581 ;; Treat data which pgg returns as a unibyte string.
582 (mm-disable-multibyte)
583 (insert-buffer-substring pgg-output-buffer
)
584 (goto-char (point-min))
585 (while (search-forward "\r\n" nil t
)
586 (replace-match "\n" t t
))
587 (mm-set-handle-multipart-parameter
588 mm-security-handle
'gnus-info
"OK"))
589 (mm-set-handle-multipart-parameter
590 mm-security-handle
'gnus-info
"Failed"))))
592 (defun mml2015-pgg-verify (handle ctl
)
593 (let ((pgg-errors-buffer mml2015-result-buffer
)
594 signature-file part signature
)
595 (if (or (null (setq part
(mm-find-raw-part-by-type
596 ctl
(or (mm-handle-multipart-ctl-parameter
598 "application/pgp-signature")
600 (null (setq signature
(mm-find-part-by-type
601 (cdr handle
) "application/pgp-signature" nil t
))))
603 (mm-set-handle-multipart-parameter
604 mm-security-handle
'gnus-info
"Corrupted")
608 ;; Convert <LF> to <CR><LF> in signed text. If --textmode is
609 ;; specified when signing, the conversion is not necessary.
610 (goto-char (point-min))
613 (unless (eq (char-before) ?
\r)
617 (with-temp-file (setq signature-file
(mm-make-temp-file "pgg"))
618 (mm-insert-part signature
))
619 (if (condition-case err
621 (pgg-verify-region (point-min) (point-max)
623 (goto-char (point-min))
624 (while (search-forward "\r\n" nil t
)
625 (replace-match "\n" t t
))
626 (mm-set-handle-multipart-parameter
627 mm-security-handle
'gnus-details
628 (concat (with-current-buffer pgg-output-buffer
630 (with-current-buffer pgg-errors-buffer
633 (mm-set-handle-multipart-parameter
634 mm-security-handle
'gnus-details
(mml2015-format-error err
))
637 (mm-set-handle-multipart-parameter
638 mm-security-handle
'gnus-details
"Quit.")
641 (delete-file signature-file
)
642 (mm-set-handle-multipart-parameter
643 mm-security-handle
'gnus-info
644 (with-current-buffer pgg-errors-buffer
645 (mml2015-gpg-extract-signature-details))))
646 (delete-file signature-file
)
647 (mm-set-handle-multipart-parameter
648 mm-security-handle
'gnus-info
"Failed")))))
651 (defun mml2015-pgg-clear-verify ()
652 (let ((pgg-errors-buffer mml2015-result-buffer
)
653 (text (buffer-string))
654 (coding-system buffer-file-coding-system
))
655 (if (condition-case err
657 (mm-with-unibyte-buffer
658 (insert (mm-encode-coding-string text coding-system
))
659 (pgg-verify-region (point-min) (point-max) nil t
))
660 (goto-char (point-min))
661 (while (search-forward "\r\n" nil t
)
662 (replace-match "\n" t t
))
663 (mm-set-handle-multipart-parameter
664 mm-security-handle
'gnus-details
665 (concat (with-current-buffer pgg-output-buffer
667 (with-current-buffer pgg-errors-buffer
670 (mm-set-handle-multipart-parameter
671 mm-security-handle
'gnus-details
(mml2015-format-error err
))
674 (mm-set-handle-multipart-parameter
675 mm-security-handle
'gnus-details
"Quit.")
677 (mm-set-handle-multipart-parameter
678 mm-security-handle
'gnus-info
679 (with-current-buffer pgg-errors-buffer
680 (mml2015-gpg-extract-signature-details)))
681 (mm-set-handle-multipart-parameter
682 mm-security-handle
'gnus-info
"Failed")))
683 (mml2015-extract-cleartext-signature))
685 (defun mml2015-pgg-sign (cont)
686 (let ((pgg-errors-buffer mml2015-result-buffer
)
687 (boundary (mml-compute-boundary cont
))
688 (pgg-default-user-id (or (message-options-get 'mml-sender
)
689 pgg-default-user-id
))
692 (unless (pgg-sign-region (point-min) (point-max))
693 (pop-to-buffer mml2015-result-buffer
)
694 (error "Sign error"))
695 (goto-char (point-min))
696 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
698 (if (setq entry
(assq 2 (pgg-parse-armor
699 (with-current-buffer pgg-output-buffer
701 (setq entry
(assq 'hash-algorithm
(cdr entry
))))
702 (insert (format "\tmicalg=%s; "
704 (downcase (format "pgp-%s" (cdr entry
)))
706 (insert "protocol=\"application/pgp-signature\"\n")
707 (insert (format "\n--%s\n" boundary
))
708 (goto-char (point-max))
709 (insert (format "\n--%s\n" boundary
))
710 (insert "Content-Type: application/pgp-signature\n\n")
711 (insert-buffer-substring pgg-output-buffer
)
712 (goto-char (point-max))
713 (insert (format "--%s--\n" boundary
))
714 (goto-char (point-max))))
716 (defun mml2015-pgg-encrypt (cont &optional sign
)
717 (let ((pgg-errors-buffer mml2015-result-buffer
)
719 (boundary (mml-compute-boundary cont
)))
720 (unless (pgg-encrypt-region (point-min) (point-max)
723 (message-options-get 'message-recipients
)
724 (message-options-set 'message-recipients
725 (read-string "Recipients: ")))
728 (pop-to-buffer mml2015-result-buffer
)
729 (error "Encrypt error"))
730 (delete-region (point-min) (point-max))
731 (goto-char (point-min))
732 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
734 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
735 (insert (format "--%s\n" boundary
))
736 (insert "Content-Type: application/pgp-encrypted\n\n")
737 (insert "Version: 1\n\n")
738 (insert (format "--%s\n" boundary
))
739 (insert "Content-Type: application/octet-stream\n\n")
740 (insert-buffer-substring pgg-output-buffer
)
741 (goto-char (point-max))
742 (insert (format "--%s--\n" boundary
))
743 (goto-char (point-max))))
747 (defvar epg-user-id-alist
)
748 (defvar epg-digest-algorithm-alist
)
749 (defvar epg-gpg-program
)
750 (defvar inhibit-redisplay
)
752 (autoload 'epg-make-context
"epg")
753 (autoload 'epg-context-set-armor
"epg")
754 (autoload 'epg-context-set-textmode
"epg")
755 (autoload 'epg-context-set-signers
"epg")
756 (autoload 'epg-context-result-for
"epg")
757 (autoload 'epg-new-signature-digest-algorithm
"epg")
758 (autoload 'epg-list-keys
"epg")
759 (autoload 'epg-decrypt-string
"epg")
760 (autoload 'epg-verify-string
"epg")
761 (autoload 'epg-sign-string
"epg")
762 (autoload 'epg-encrypt-string
"epg")
763 (autoload 'epg-passphrase-callback-function
"epg")
764 (autoload 'epg-context-set-passphrase-callback
"epg")
765 (autoload 'epg-key-sub-key-list
"epg")
766 (autoload 'epg-sub-key-capability
"epg")
767 (autoload 'epg-sub-key-validity
"epg")
768 (autoload 'epg-sub-key-fingerprint
"epg")
769 (autoload 'epg-signature-key-id
"epg")
770 (autoload 'epg-signature-to-string
"epg")
771 (autoload 'epg-key-user-id-list
"epg")
772 (autoload 'epg-user-id-string
"epg")
773 (autoload 'epg-user-id-validity
"epg")
774 (autoload 'epg-configuration
"epg-config")
775 (autoload 'epg-expand-group
"epg-config")
776 (autoload 'epa-select-keys
"epa")
778 (autoload 'gnus-create-image
"gnus-ems")
780 (defun mml2015-epg-key-image (key-id)
781 "Return the image of a key, if any"
783 (mm-set-buffer-multibyte nil
)
784 (let* ((coding-system-for-write 'binary
)
785 (coding-system-for-read 'binary
)
786 (data (shell-command-to-string
787 (format "%s --list-options no-show-photos --attribute-fd 3 --list-keys %s 3>&1 >/dev/null 2>&1"
788 (shell-quote-argument epg-gpg-program
) key-id
))))
789 (when (> (length data
) 0)
790 (insert (substring data
16))
792 (gnus-create-image (buffer-string) nil t
)
795 (autoload 'gnus-rescale-image
"gnus-util")
797 (defun mml2015-epg-key-image-to-string (key-id)
798 "Return a string with the image of a key, if any"
799 (let ((key-image (mml2015-epg-key-image key-id
)))
802 (condition-case error
806 (gnus-rescale-image key-image
807 (cons mml2015-maximum-key-image-dimension
808 mml2015-maximum-key-image-dimension
))
813 (defun mml2015-epg-signature-to-string (signature)
814 (concat (epg-signature-to-string signature
)
815 (when mml2015-display-key-image
816 (mml2015-epg-key-image-to-string (epg-signature-key-id signature
)))))
818 (defun mml2015-epg-verify-result-to-string (verify-result)
819 (mapconcat #'mml2015-epg-signature-to-string verify-result
"\n"))
821 (defun mml2015-epg-decrypt (handle ctl
)
823 (let ((inhibit-redisplay t
)
824 context plain child handles result decrypt-status
)
825 (unless (setq child
(mm-find-part-by-type
827 "application/octet-stream" nil t
))
828 (mm-set-handle-multipart-parameter
829 mm-security-handle
'gnus-info
"Corrupted")
830 (throw 'error handle
))
831 (setq context
(epg-make-context))
832 (if (or mml2015-cache-passphrase mml-secure-cache-passphrase
)
833 (epg-context-set-passphrase-callback
835 (cons 'mml-secure-passphrase-callback
'OpenPGP
)))
836 (condition-case error
837 (setq plain
(epg-decrypt-string context
(mm-get-part child
))
838 mml-secure-secret-key-id-list nil
)
840 (mml-secure-clear-secret-key-id-list)
841 (mm-set-handle-multipart-parameter
842 mm-security-handle
'gnus-info
"Failed")
843 (if (eq (car error
) 'quit
)
844 (mm-set-handle-multipart-parameter
845 mm-security-handle
'gnus-details
"Quit.")
846 (mm-set-handle-multipart-parameter
847 mm-security-handle
'gnus-details
(mml2015-format-error error
)))
848 (throw 'error handle
)))
851 (goto-char (point-min))
852 (while (search-forward "\r\n" nil t
)
853 (replace-match "\n" t t
))
854 (setq handles
(mm-dissect-buffer t
))
855 (mm-destroy-parts handle
)
856 (if (epg-context-result-for context
'verify
)
857 (mm-set-handle-multipart-parameter
858 mm-security-handle
'gnus-info
860 (mml2015-epg-verify-result-to-string
861 (epg-context-result-for context
'verify
))))
862 (mm-set-handle-multipart-parameter
863 mm-security-handle
'gnus-info
"OK"))
864 (if (stringp (car handles
))
865 (mm-set-handle-multipart-parameter
866 mm-security-handle
'gnus-details
867 (mm-handle-multipart-ctl-parameter handles
'gnus-details
))))
868 (if (listp (car handles
))
872 (defun mml2015-epg-clear-decrypt ()
873 (let ((inhibit-redisplay t
)
874 (context (epg-make-context))
876 (if (or mml2015-cache-passphrase mml-secure-cache-passphrase
)
877 (epg-context-set-passphrase-callback
879 (cons 'mml-secure-passphrase-callback
'OpenPGP
)))
880 (condition-case error
881 (setq plain
(epg-decrypt-string context
(buffer-string))
882 mml-secure-secret-key-id-list nil
)
884 (mml-secure-clear-secret-key-id-list)
885 (mm-set-handle-multipart-parameter
886 mm-security-handle
'gnus-info
"Failed")
887 (if (eq (car error
) 'quit
)
888 (mm-set-handle-multipart-parameter
889 mm-security-handle
'gnus-details
"Quit.")
890 (mm-set-handle-multipart-parameter
891 mm-security-handle
'gnus-details
(mml2015-format-error error
)))))
894 ;; Treat data which epg returns as a unibyte string.
895 (mm-disable-multibyte)
897 (goto-char (point-min))
898 (while (search-forward "\r\n" nil t
)
899 (replace-match "\n" t t
))
900 (mm-set-handle-multipart-parameter
901 mm-security-handle
'gnus-info
"OK")
902 (if (epg-context-result-for context
'verify
)
903 (mm-set-handle-multipart-parameter
904 mm-security-handle
'gnus-details
905 (mml2015-epg-verify-result-to-string
906 (epg-context-result-for context
'verify
)))))))
908 (defun mml2015-epg-verify (handle ctl
)
910 (let ((inhibit-redisplay t
)
911 context plain signature-file part signature
)
912 (when (or (null (setq part
(mm-find-raw-part-by-type
913 ctl
(or (mm-handle-multipart-ctl-parameter
915 "application/pgp-signature")
917 (null (setq signature
(mm-find-part-by-type
918 (cdr handle
) "application/pgp-signature"
920 (mm-set-handle-multipart-parameter
921 mm-security-handle
'gnus-info
"Corrupted")
922 (throw 'error handle
))
923 (setq part
(mm-replace-in-string part
"\n" "\r\n")
924 signature
(mm-get-part signature
)
925 context
(epg-make-context))
926 (condition-case error
927 (setq plain
(epg-verify-string context signature part
))
929 (mm-set-handle-multipart-parameter
930 mm-security-handle
'gnus-info
"Failed")
931 (if (eq (car error
) 'quit
)
932 (mm-set-handle-multipart-parameter
933 mm-security-handle
'gnus-details
"Quit.")
934 (mm-set-handle-multipart-parameter
935 mm-security-handle
'gnus-details
(mml2015-format-error error
)))
936 (throw 'error handle
)))
937 (mm-set-handle-multipart-parameter
938 mm-security-handle
'gnus-info
939 (mml2015-epg-verify-result-to-string
940 (epg-context-result-for context
'verify
)))
943 (defun mml2015-epg-clear-verify ()
944 (let ((inhibit-redisplay t
)
945 (context (epg-make-context))
946 (signature (mm-encode-coding-string (buffer-string)
947 coding-system-for-write
))
949 (condition-case error
950 (setq plain
(epg-verify-string context signature
))
952 (mm-set-handle-multipart-parameter
953 mm-security-handle
'gnus-info
"Failed")
954 (if (eq (car error
) 'quit
)
955 (mm-set-handle-multipart-parameter
956 mm-security-handle
'gnus-details
"Quit.")
957 (mm-set-handle-multipart-parameter
958 mm-security-handle
'gnus-details
(mml2015-format-error error
)))))
961 (mm-set-handle-multipart-parameter
962 mm-security-handle
'gnus-info
963 (mml2015-epg-verify-result-to-string
964 (epg-context-result-for context
'verify
)))
965 (delete-region (point-min) (point-max))
966 (insert (mm-decode-coding-string plain coding-system-for-read
)))
967 (mml2015-extract-cleartext-signature))))
969 (defun mml2015-epg-sign (cont)
970 (let ((inhibit-redisplay t
)
971 (boundary (mml-compute-boundary cont
)))
972 ;; Signed data must end with a newline (RFC 3156, 5).
973 (goto-char (point-max))
976 (let* ((pair (mml-secure-epg-sign 'OpenPGP t
))
977 (signature (car pair
))
979 (goto-char (point-min))
980 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
983 (insert (format "\tmicalg=pgp-%s; "
986 epg-digest-algorithm-alist
))))))
987 (insert "protocol=\"application/pgp-signature\"\n")
988 (insert (format "\n--%s\n" boundary
))
989 (goto-char (point-max))
990 (insert (format "\n--%s\n" boundary
))
991 (insert "Content-Type: application/pgp-signature; name=\"signature.asc\"\n\n")
993 (goto-char (point-max))
994 (insert (format "--%s--\n" boundary
))
995 (goto-char (point-max)))))
997 (defun mml2015-epg-encrypt (cont &optional sign
)
998 (let* ((inhibit-redisplay t
)
999 (boundary (mml-compute-boundary cont
))
1000 (cipher (mml-secure-epg-encrypt 'OpenPGP cont sign
)))
1001 (delete-region (point-min) (point-max))
1002 (goto-char (point-min))
1003 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
1005 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
1006 (insert (format "--%s\n" boundary
))
1007 (insert "Content-Type: application/pgp-encrypted\n\n")
1008 (insert "Version: 1\n\n")
1009 (insert (format "--%s\n" boundary
))
1010 (insert "Content-Type: application/octet-stream\n\n")
1012 (goto-char (point-max))
1013 (insert (format "--%s--\n" boundary
))
1014 (goto-char (point-max))))
1018 (autoload 'gnus-buffer-live-p
"gnus-util")
1019 (autoload 'gnus-get-buffer-create
"gnus")
1021 (defun mml2015-clean-buffer ()
1022 (if (gnus-buffer-live-p mml2015-result-buffer
)
1023 (with-current-buffer mml2015-result-buffer
1026 (setq mml2015-result-buffer
1027 (gnus-get-buffer-create " *MML2015 Result*"))
1030 (defsubst mml2015-clear-decrypt-function
()
1031 (nth 6 (assq mml2015-use mml2015-function-alist
)))
1033 (defsubst mml2015-clear-verify-function
()
1034 (nth 5 (assq mml2015-use mml2015-function-alist
)))
1037 (defun mml2015-decrypt (handle ctl
)
1038 (mml2015-clean-buffer)
1039 (let ((func (nth 4 (assq mml2015-use mml2015-function-alist
))))
1041 (funcall func handle ctl
)
1045 (defun mml2015-decrypt-test (handle ctl
)
1049 (defun mml2015-verify (handle ctl
)
1050 (mml2015-clean-buffer)
1051 (let ((func (nth 3 (assq mml2015-use mml2015-function-alist
))))
1053 (funcall func handle ctl
)
1057 (defun mml2015-verify-test (handle ctl
)
1061 (defun mml2015-encrypt (cont &optional sign
)
1062 (mml2015-clean-buffer)
1063 (let ((func (nth 2 (assq mml2015-use mml2015-function-alist
))))
1065 (funcall func cont sign
)
1066 (error "Cannot find encrypt function"))))
1069 (defun mml2015-sign (cont)
1070 (mml2015-clean-buffer)
1071 (let ((func (nth 1 (assq mml2015-use mml2015-function-alist
))))
1074 (error "Cannot find sign function"))))
1077 (defun mml2015-self-encrypt ()
1078 (mml2015-encrypt nil
))
1082 ;;; mml2015.el ends here