Mercurial > emacs

comparison lisp/gnus/mml2015.el @ 110583:b6d2a63ad993

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge changes made in Gnus trunk. nnimap.el: Implement partial IMAP article fetch. nnimap.el: Have nnimap not update the infos if it can't get info from the server. Implement functions for showing the complete articles. gnus-int.el (gnus-open-server): Don't query whether to go offline -- just do it. gnus-art.el (gnus-mime-delete-part): Fix plural for "byte" when there isn't a single byte. nndoc.el (nndoc-type-alist): Move mime-parts after mbox. Suggested by Jay Berkenbilt. mm-decode.el (mm-save-part): Allow saving to other directories the normal Emacs way. gnus-html.el (gnus-html-rescale-image): Use our defalias gnus-window-inside-pixel-edges. gnus-srvr.el (gnus-server-copy-server): Add documentation. gnus.texi (Using IMAP): Document the new nnimap. nnimap.el (nnimap-wait-for-response): Search further when we're not using streaming. gnus-int.el (gnus-check-server): Say what the error was when opening failed. nnheader.el (nnheader-get-report-string): New function. gnus-int.el (gnus-check-server): Use report-string. nnimap.el (nnimap-open-connection): Add more error reporting when nnimap fails early. gnus-start.el (gnus-get-unread-articles): Don't try to open failed servers twice. nnimap.el (nnimap-wait-for-response): Reversed logic in the nnimap-streaming test. gnus-art.el: Removed CTAN button stuff, which I don't think is very relevant any more. Remove NoCeM support, since nobody seems to use it any more. Remove earcon and gnus-audio. gnus.el (gnus): Silence gnus-load message. gnus-group.el (gnus-read-ephemeral-bug-group): Add the bug email address to the To list for easier response. gnus.texi (Connecting to an IMAP Server): Show how to use as primary method instead of secondary.
author Katsumi Yamaoka <yamaoka@jpl.org>
date Sun, 26 Sep 2010 04:03:19 +0000
parents f567b340d004
children 6c6f3972c99c
comparison
equal deleted inserted replaced
110582:aa7656773a38 110583:b6d2a63ad993
61 ;; in Emacs 21.1. 61 ;; in Emacs 21.1.
62 (let ((recursive-load-depth-limit 100)) 62 (let ((recursive-load-depth-limit 100))
63 (require 'pgg))) 63 (require 'pgg)))
64 (and (fboundp 'pgg-sign-region) 64 (and (fboundp 'pgg-sign-region)
65 'pgg)) 65 'pgg))
66 (progn
67 (ignore-errors
68 (require 'gpg))
69 (and (fboundp 'gpg-sign-detached)
70 'gpg))
71 (progn (ignore-errors 66 (progn (ignore-errors
72 (load "mc-toplev")) 67 (load "mc-toplev"))
73 (and (fboundp 'mc-encrypt-generic) 68 (and (fboundp 'mc-encrypt-generic)
74 (fboundp 'mc-sign-generic) 69 (fboundp 'mc-sign-generic)
75 (fboundp 'mc-cleanup-recipient-headers) 70 (fboundp 'mc-cleanup-recipient-headers)
76 'mailcrypt))) 71 'mailcrypt)))
77 "The package used for PGP/MIME. 72 "The package used for PGP/MIME.
78 Valid packages include `epg', `pgg', `gpg' and `mailcrypt'.") 73 Valid packages include `epg', `pgg' and `mailcrypt'.")
79 74
80 ;; Something is not RFC2015. 75 ;; Something is not RFC2015.
81 (defvar mml2015-function-alist 76 (defvar mml2015-function-alist
82 '((mailcrypt mml2015-mailcrypt-sign 77 '((mailcrypt mml2015-mailcrypt-sign
83 mml2015-mailcrypt-encrypt 78 mml2015-mailcrypt-encrypt
84 mml2015-mailcrypt-verify 79 mml2015-mailcrypt-verify
85 mml2015-mailcrypt-decrypt 80 mml2015-mailcrypt-decrypt
86 mml2015-mailcrypt-clear-verify 81 mml2015-mailcrypt-clear-verify
87 mml2015-mailcrypt-clear-decrypt) 82 mml2015-mailcrypt-clear-decrypt)
88 (gpg mml2015-gpg-sign 83 (pgg mml2015-pgg-sign
89 mml2015-gpg-encrypt 84 mml2015-pgg-encrypt
90 mml2015-gpg-verify 85 mml2015-pgg-verify
91 mml2015-gpg-decrypt 86 mml2015-pgg-decrypt
92 mml2015-gpg-clear-verify 87 mml2015-pgg-clear-verify
93 mml2015-gpg-clear-decrypt) 88 mml2015-pgg-clear-decrypt)
94 (pgg mml2015-pgg-sign 89 (epg mml2015-epg-sign
95 mml2015-pgg-encrypt 90 mml2015-epg-encrypt
96 mml2015-pgg-verify 91 mml2015-epg-verify
97 mml2015-pgg-decrypt 92 mml2015-epg-decrypt
98 mml2015-pgg-clear-verify 93 mml2015-epg-clear-verify
99 mml2015-pgg-clear-decrypt) 94 mml2015-epg-clear-decrypt))
100 (epg mml2015-epg-sign
101 mml2015-epg-encrypt
102 mml2015-epg-verify
103 mml2015-epg-decrypt
104 mml2015-epg-clear-verify
105 mml2015-epg-clear-decrypt))
106 "Alist of PGP/MIME functions.") 95 "Alist of PGP/MIME functions.")
107 96
108 (defvar mml2015-result-buffer nil) 97 (defvar mml2015-result-buffer nil)
109 98
110 (defcustom mml2015-unabbrev-trust-alist 99 (defcustom mml2015-unabbrev-trust-alist
146 :group 'mime-security 135 :group 'mime-security
147 :type 'boolean) 136 :type 'boolean)
148 137
149 ;; Extract plaintext from cleartext signature. IMO, this kind of task 138 ;; Extract plaintext from cleartext signature. IMO, this kind of task
150 ;; should be done by GnuPG rather than Elisp, but older PGP backends 139 ;; should be done by GnuPG rather than Elisp, but older PGP backends
151 ;; (such as Mailcrypt, PGG, and gpg.el) discard the output from GnuPG. 140 ;; (such as Mailcrypt, and PGG) discard the output from GnuPG.
152 (defun mml2015-extract-cleartext-signature () 141 (defun mml2015-extract-cleartext-signature ()
153 ;; Daiki Ueno in 142 ;; Daiki Ueno in
154 ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still 143 ;; <54a15d860801080142l70b95d7dkac4bf51a86196011@mail.gmail.com>: ``I still
155 ;; believe that the right way is to use the plaintext output from GnuPG as 144 ;; believe that the right way is to use the plaintext output from GnuPG as
156 ;; it is, and mml2015-extract-cleartext-signature is just a kludge for 145 ;; it is, and mml2015-extract-cleartext-signature is just a kludge for
231 (mml2015-gpg-extract-signature-details)))) 220 (mml2015-gpg-extract-signature-details))))
232 (concat ", Signer: " sig)))) 221 (concat ", Signer: " sig))))
233 (if (listp (car handles)) 222 (if (listp (car handles))
234 handles 223 handles
235 (list handles))))) 224 (list handles)))))
225
226 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
227 (let* ((result "")
228 (fpr-length (string-width fingerprint))
229 (n-slice 0)
230 slice)
231 (setq fingerprint (string-to-list fingerprint))
232 (while 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))
237 (setq result
238 (concat
239 result
240 (case n-slice
241 (1 slice)
242 (otherwise (concat " " slice))))))
243 result))
244
245 (defun mml2015-gpg-extract-signature-details ()
246 (goto-char (point-min))
247 (let* ((expired (re-search-forward
248 "^\\[GNUPG:\\] SIGEXPIRED$"
249 nil t))
250 (signer (and (re-search-forward
251 "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
252 nil t)
253 (cons (match-string 1) (match-string 2))))
254 (fprint (and (re-search-forward
255 "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
256 nil t)
257 (match-string 1)))
258 (trust (and (re-search-forward
259 "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
260 nil t)
261 (match-string 1)))
262 (trust-good-enough-p
263 (cdr (assoc trust mml2015-unabbrev-trust-alist))))
264 (cond ((and signer fprint)
265 (concat (cdr signer)
266 (unless trust-good-enough-p
267 (concat "\nUntrusted, Fingerprint: "
268 (mml2015-gpg-pretty-print-fpr fprint)))
269 (when expired
270 (format "\nWARNING: Signature from expired key (%s)"
271 (car signer)))))
272 ((re-search-forward
273 "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
274 (match-string 2))
275 (t
276 "From unknown user"))))
236 277
237 (defun mml2015-mailcrypt-clear-decrypt () 278 (defun mml2015-mailcrypt-clear-decrypt ()
238 (let (result) 279 (let (result)
239 (setq result 280 (setq result
240 (condition-case err 281 (condition-case err
443 (insert (format "--%s\n" boundary)) 484 (insert (format "--%s\n" boundary))
444 (insert "Content-Type: application/octet-stream\n\n") 485 (insert "Content-Type: application/octet-stream\n\n")
445 (goto-char (point-max)) 486 (goto-char (point-max))
446 (insert (format "--%s--\n" boundary)) 487 (insert (format "--%s--\n" boundary))
447 (goto-char (point-max)))) 488 (goto-char (point-max))))
448
449 ;;; gpg wrapper
450
451 (autoload 'gpg-decrypt "gpg")
452 (autoload 'gpg-verify "gpg")
453 (autoload 'gpg-verify-cleartext "gpg")
454 (autoload 'gpg-sign-detached "gpg")
455 (autoload 'gpg-sign-encrypt "gpg")
456 (autoload 'gpg-encrypt "gpg")
457 (autoload 'gpg-passphrase-read "gpg")
458
459 (defun mml2015-gpg-passphrase ()
460 (or (message-options-get 'gpg-passphrase)
461 (message-options-set 'gpg-passphrase (gpg-passphrase-read))))
462
463 (defun mml2015-gpg-decrypt-1 ()
464 (let ((cipher (current-buffer)) plain result)
465 (if (with-temp-buffer
466 (prog1
467 (gpg-decrypt cipher (setq plain (current-buffer))
468 mml2015-result-buffer nil)
469 (mm-set-handle-multipart-parameter
470 mm-security-handle 'gnus-details
471 (with-current-buffer mml2015-result-buffer
472 (buffer-string)))
473 (set-buffer cipher)
474 (erase-buffer)
475 (insert-buffer-substring plain)
476 (goto-char (point-min))
477 (while (search-forward "\r\n" nil t)
478 (replace-match "\n" t t))))
479 '(t)
480 ;; Some wrong with the return value, check plain text buffer.
481 (if (> (point-max) (point-min))
482 '(t)
483 nil))))
484
485 (defun mml2015-gpg-decrypt (handle ctl)
486 (let ((mml2015-decrypt-function 'mml2015-gpg-decrypt-1))
487 (mml2015-mailcrypt-decrypt handle ctl)))
488
489 (defun mml2015-gpg-clear-decrypt ()
490 (let (result)
491 (setq result (mml2015-gpg-decrypt-1))
492 (if (car result)
493 (mm-set-handle-multipart-parameter
494 mm-security-handle 'gnus-info "OK")
495 (mm-set-handle-multipart-parameter
496 mm-security-handle 'gnus-info "Failed"))))
497
498 (defun mml2015-gpg-pretty-print-fpr (fingerprint)
499 (let* ((result "")
500 (fpr-length (string-width fingerprint))
501 (n-slice 0)
502 slice)
503 (setq fingerprint (string-to-list fingerprint))
504 (while fingerprint
505 (setq fpr-length (- fpr-length 4))
506 (setq slice (butlast fingerprint fpr-length))
507 (setq fingerprint (nthcdr 4 fingerprint))
508 (setq n-slice (1+ n-slice))
509 (setq result
510 (concat
511 result
512 (case n-slice
513 (1 slice)
514 (otherwise (concat " " slice))))))
515 result))
516
517 (defun mml2015-gpg-extract-signature-details ()
518 (goto-char (point-min))
519 (let* ((expired (re-search-forward
520 "^\\[GNUPG:\\] SIGEXPIRED$"
521 nil t))
522 (signer (and (re-search-forward
523 "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$"
524 nil t)
525 (cons (match-string 1) (match-string 2))))
526 (fprint (and (re-search-forward
527 "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) "
528 nil t)
529 (match-string 1)))
530 (trust (and (re-search-forward
531 "^\\[GNUPG:\\] \\(TRUST_.*\\)$"
532 nil t)
533 (match-string 1)))
534 (trust-good-enough-p
535 (cdr (assoc trust mml2015-unabbrev-trust-alist))))
536 (cond ((and signer fprint)
537 (concat (cdr signer)
538 (unless trust-good-enough-p
539 (concat "\nUntrusted, Fingerprint: "
540 (mml2015-gpg-pretty-print-fpr fprint)))
541 (when expired
542 (format "\nWARNING: Signature from expired key (%s)"
543 (car signer)))))
544 ((re-search-forward
545 "^\\(gpg: \\)?Good signature from \"\\(.*\\)\"$" nil t)
546 (match-string 2))
547 (t
548 "From unknown user"))))
549
550 (defun mml2015-gpg-verify (handle ctl)
551 (catch 'error
552 (let (part message signature info-is-set-p)
553 (unless (setq part (mm-find-raw-part-by-type
554 ctl (or (mm-handle-multipart-ctl-parameter
555 ctl 'protocol)
556 "application/pgp-signature")
557 t))
558 (mm-set-handle-multipart-parameter
559 mm-security-handle 'gnus-info "Corrupted")
560 (throw 'error handle))
561 (with-temp-buffer
562 (setq message (current-buffer))
563 (insert part)
564 ;; Convert <LF> to <CR><LF> in signed text. If --textmode is
565 ;; specified when signing, the conversion is not necessary.
566 (goto-char (point-min))
567 (end-of-line)
568 (while (not (eobp))
569 (unless (eq (char-before) ?\r)
570 (insert "\r"))
571 (forward-line)
572 (end-of-line))
573 (with-temp-buffer
574 (setq signature (current-buffer))
575 (unless (setq part (mm-find-part-by-type
576 (cdr handle) "application/pgp-signature" nil t))
577 (mm-set-handle-multipart-parameter
578 mm-security-handle 'gnus-info "Corrupted")
579 (throw 'error handle))
580 (mm-insert-part part)
581 (unless (condition-case err
582 (prog1
583 (gpg-verify message signature mml2015-result-buffer)
584 (mm-set-handle-multipart-parameter
585 mm-security-handle 'gnus-details
586 (with-current-buffer mml2015-result-buffer
587 (buffer-string))))
588 (error
589 (mm-set-handle-multipart-parameter
590 mm-security-handle 'gnus-details (mml2015-format-error err))
591 (mm-set-handle-multipart-parameter
592 mm-security-handle 'gnus-info "Error.")
593 (setq info-is-set-p t)
594 nil)
595 (quit
596 (mm-set-handle-multipart-parameter
597 mm-security-handle 'gnus-details "Quit.")
598 (mm-set-handle-multipart-parameter
599 mm-security-handle 'gnus-info "Quit.")
600 (setq info-is-set-p t)
601 nil))
602 (unless info-is-set-p
603 (mm-set-handle-multipart-parameter
604 mm-security-handle 'gnus-info "Failed"))
605 (throw 'error handle)))
606 (mm-set-handle-multipart-parameter
607 mm-security-handle 'gnus-info
608 (with-current-buffer mml2015-result-buffer
609 (mml2015-gpg-extract-signature-details))))
610 handle)))
611
612 (defun mml2015-gpg-clear-verify ()
613 (if (condition-case err
614 (prog1
615 (gpg-verify-cleartext (current-buffer) mml2015-result-buffer)
616 (mm-set-handle-multipart-parameter
617 mm-security-handle 'gnus-details
618 (with-current-buffer mml2015-result-buffer
619 (buffer-string))))
620 (error
621 (mm-set-handle-multipart-parameter
622 mm-security-handle 'gnus-details (mml2015-format-error err))
623 nil)
624 (quit
625 (mm-set-handle-multipart-parameter
626 mm-security-handle 'gnus-details "Quit.")
627 nil))
628 (mm-set-handle-multipart-parameter
629 mm-security-handle 'gnus-info
630 (with-current-buffer mml2015-result-buffer
631 (mml2015-gpg-extract-signature-details)))
632 (mm-set-handle-multipart-parameter
633 mm-security-handle 'gnus-info "Failed"))
634 (mml2015-extract-cleartext-signature))
635
636 (defun mml2015-gpg-sign (cont)
637 (let ((boundary (mml-compute-boundary cont))
638 (text (current-buffer)) signature)
639 (goto-char (point-max))
640 (unless (bolp)
641 (insert "\n"))
642 (with-temp-buffer
643 (unless (gpg-sign-detached text (setq signature (current-buffer))
644 mml2015-result-buffer
645 nil
646 (message-options-get 'message-sender)
647 t t) ; armor & textmode
648 (unless (> (point-max) (point-min))
649 (pop-to-buffer mml2015-result-buffer)
650 (error "Sign error")))
651 (goto-char (point-min))
652 (while (re-search-forward "\r+$" nil t)
653 (replace-match "" t t))
654 (set-buffer text)
655 (goto-char (point-min))
656 (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n"
657 boundary))
658 ;;; FIXME: what is the micalg?
659 (insert "\tmicalg=pgp-sha1; protocol=\"application/pgp-signature\"\n")
660 (insert (format "\n--%s\n" boundary))
661 (goto-char (point-max))
662 (insert (format "\n--%s\n" boundary))
663 (insert "Content-Type: application/pgp-signature\n\n")
664 (insert-buffer-substring signature)
665 (goto-char (point-max))
666 (insert (format "--%s--\n" boundary))
667 (goto-char (point-max)))))
668
669 (defun mml2015-gpg-encrypt (cont &optional sign)
670 (let ((boundary (mml-compute-boundary cont))
671 (text (current-buffer))
672 cipher)
673 (mm-with-unibyte-current-buffer
674 (with-temp-buffer
675 (mm-disable-multibyte)
676 ;; set up a function to call the correct gpg encrypt routine
677 ;; with the right arguments. (FIXME: this should be done
678 ;; differently.)
679 (flet ((gpg-encrypt-func
680 (sign plaintext ciphertext result recipients &optional
681 passphrase sign-with-key armor textmode)
682 (if sign
683 (gpg-sign-encrypt
684 plaintext ciphertext result recipients passphrase
685 sign-with-key armor textmode)
686 (gpg-encrypt
687 plaintext ciphertext result recipients passphrase
688 armor textmode))))
689 (unless (gpg-encrypt-func
690 sign ; passed in when using signencrypt
691 text (setq cipher (current-buffer))
692 mml2015-result-buffer
693 (split-string
694 (or
695 (message-options-get 'message-recipients)
696 (message-options-set 'message-recipients
697 (read-string "Recipients: ")))
698 "[ \f\t\n\r\v,]+")
699 nil
700 (message-options-get 'message-sender)
701 t t) ; armor & textmode
702 (unless (> (point-max) (point-min))
703 (pop-to-buffer mml2015-result-buffer)
704 (error "Encrypt error"))))
705 (goto-char (point-min))
706 (while (re-search-forward "\r+$" nil t)
707 (replace-match "" t t))
708 (set-buffer text)
709 (delete-region (point-min) (point-max))
710 (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n"
711 boundary))
712 (insert "\tprotocol=\"application/pgp-encrypted\"\n\n")
713 (insert (format "--%s\n" boundary))
714 (insert "Content-Type: application/pgp-encrypted\n\n")
715 (insert "Version: 1\n\n")
716 (insert (format "--%s\n" boundary))
717 (insert "Content-Type: application/octet-stream\n\n")
718 (insert-buffer-substring cipher)
719 (goto-char (point-max))
720 (insert (format "--%s--\n" boundary))
721 (goto-char (point-max))))))
722 489
723 ;;; pgg wrapper 490 ;;; pgg wrapper
724 491
725 (defvar pgg-default-user-id) 492 (defvar pgg-default-user-id)
726 (defvar pgg-errors-buffer) 493 (defvar pgg-errors-buffer)