X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmml2015.el;h=ff6c04dc5028612845ac2a8e3790ef425ffc6bca;hb=9b741e050b400987d68ff761c6cc3276c932839c;hp=126f647ed8bcbd23e3277e9c9bfd459af05064f4;hpb=2cc5659442ce551b395b9aeebe213947e415ac6d;p=elisp%2Fgnus.git- diff --git a/lisp/mml2015.el b/lisp/mml2015.el index 126f647..ff6c04d 100644 --- a/lisp/mml2015.el +++ b/lisp/mml2015.el @@ -1,5 +1,5 @@ ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP) -;; Copyright (C) 2000 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu ;; Keywords: PGP MIME MML @@ -23,12 +23,16 @@ ;;; Commentary: +;; RFC 2015 is updated by RFC 3156, this file should be compatible +;; with both. + ;;; Code: (eval-when-compile (require 'cl)) +(eval-when-compile (require 'gnus-clfns)) (require 'mm-decode) -(defvar mml2015-use (or +(defvar mml2015-use (or (progn (ignore-errors (require 'gpg)) @@ -49,7 +53,7 @@ mml2015-mailcrypt-verify mml2015-mailcrypt-decrypt mml2015-mailcrypt-clear-verify - mml2015-mailcrypt-clear-decrypt) + mml2015-mailcrypt-clear-decrypt) (gpg mml2015-gpg-sign mml2015-gpg-encrypt mml2015-gpg-verify @@ -60,6 +64,18 @@ (defvar mml2015-result-buffer nil) +(defvar mml2015-trust-boundaries-alist + '((trust-undefined . nil) + (trust-none . nil) + (trust-marginal . t) + (trust-full . t) + (trust-ultimate . t)) + "Trust boundaries for a signer's GnuPG key. +This alist contains pairs of the form (trust-symbol . boolean), with +symbols that are contained in `gpg-unabbrev-trust-alist'. The boolean +specifies whether the given trust value is good enough to be trusted +by you.") + ;;; mailcrypt wrapper (eval-and-compile @@ -77,81 +93,91 @@ (defvar mml2015-decrypt-function 'mailcrypt-decrypt) (defvar mml2015-verify-function 'mailcrypt-verify) +(defun mml2015-format-error (err) + (if (stringp (cadr err)) + (cadr err) + (format "%S" (cdr err)))) + (defun mml2015-mailcrypt-decrypt (handle ctl) (catch 'error (let (child handles result) - (unless (setq child (mm-find-part-by-type - (cdr handle) + (unless (setq child (mm-find-part-by-type + (cdr handle) "application/octet-stream" nil t)) - (mm-set-handle-multipart-parameter + (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Corrupted") (throw 'error handle)) (with-temp-buffer (mm-insert-part child) - (setq result + (setq result (condition-case err (funcall mml2015-decrypt-function) - (error - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details (cadr err)) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (mml2015-format-error err)) nil) (quit - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details "Quit.") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") nil))) (unless (car result) - (mm-set-handle-multipart-parameter + (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Failed") (throw 'error handle)) (setq handles (mm-dissect-buffer t))) (mm-destroy-parts handle) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "OK") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info + (concat "OK" + (let ((sig (with-current-buffer mml2015-result-buffer + (mml2015-gpg-extract-signature-details)))) + (concat ", Signer: " sig)))) (if (listp (car handles)) handles (list handles))))) (defun mml2015-mailcrypt-clear-decrypt () (let (result) - (setq result + (setq result (condition-case err (funcall mml2015-decrypt-function) - (error - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details (cadr err)) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (mml2015-format-error err)) nil) (quit - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details "Quit.") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") nil))) (if (car result) - (mm-set-handle-multipart-parameter + (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "OK") - (mm-set-handle-multipart-parameter + (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Failed")))) (defun mml2015-fix-micalg (alg) (and alg - (upcase (if (string-match "^pgp-" alg) + ;; Mutt/1.2.5i has seen sending micalg=php-sha1 + (upcase (if (string-match "^p[gh]p-" alg) (substring alg (match-end 0)) alg)))) (defun mml2015-mailcrypt-verify (handle ctl) (catch 'error (let (part) - (unless (setq part (mm-find-raw-part-by-type - ctl (or (mm-handle-multipart-ctl-parameter + (unless (setq part (mm-find-raw-part-by-type + ctl (or (mm-handle-multipart-ctl-parameter ctl 'protocol) "application/pgp-signature") t)) - (mm-set-handle-multipart-parameter + (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Corrupted") (throw 'error handle)) (with-temp-buffer (insert "-----BEGIN PGP SIGNED MESSAGE-----\n") - (insert (format "Hash: %s\n\n" + (insert (format "Hash: %s\n\n" (or (mml2015-fix-micalg - (mm-handle-multipart-ctl-parameter + (mm-handle-multipart-ctl-parameter ctl 'micalg)) "SHA1"))) (save-restriction @@ -162,9 +188,9 @@ (if (looking-at "^-") (insert "- ")) (forward-line))) - (unless (setq part (mm-find-part-by-type + (unless (setq part (mm-find-part-by-type (cdr handle) "application/pgp-signature" nil t)) - (mm-set-handle-multipart-parameter + (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Corrupted") (throw 'error handle)) (save-restriction @@ -175,55 +201,85 @@ (replace-match "-----BEGIN PGP SIGNATURE-----" t t)) (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t) (replace-match "-----END PGP SIGNATURE-----" t t))) - (unless (condition-case err - (funcall mml2015-verify-function) - (error - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details (cadr err)) - nil) - (quit - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details "Quit.") - nil)) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Failed") - (throw 'error handle))) - (mm-set-handle-multipart-parameter + (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) + (unless (condition-case err + (prog1 + (funcall mml2015-verify-function) + (if (get-buffer " *mailcrypt stderr temp") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (with-current-buffer " *mailcrypt stderr temp" + (buffer-string)))) + (if (get-buffer " *mailcrypt stdout temp") + (kill-buffer " *mailcrypt stdout temp")) + (if (get-buffer " *mailcrypt stderr temp") + (kill-buffer " *mailcrypt stderr temp")) + (if (get-buffer " *mailcrypt status temp") + (kill-buffer " *mailcrypt status temp")) + (if (get-buffer mc-gpg-debug-buffer) + (kill-buffer mc-gpg-debug-buffer))) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (mml2015-format-error err)) + nil) + (quit + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") + nil)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (throw 'error handle)))) + (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "OK") handle))) (defun mml2015-mailcrypt-clear-verify () - (if (condition-case err - (funcall mml2015-verify-function) - (error - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details (cadr err)) - nil) - (quit - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details "Quit.") - nil)) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "OK") - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Failed"))) + (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) + (if (condition-case err + (prog1 + (funcall mml2015-verify-function) + (if (get-buffer " *mailcrypt stderr temp") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (with-current-buffer " *mailcrypt stderr temp" + (buffer-string)))) + (if (get-buffer " *mailcrypt stdout temp") + (kill-buffer " *mailcrypt stdout temp")) + (if (get-buffer " *mailcrypt stderr temp") + (kill-buffer " *mailcrypt stderr temp")) + (if (get-buffer " *mailcrypt status temp") + (kill-buffer " *mailcrypt status temp")) + (if (get-buffer mc-gpg-debug-buffer) + (kill-buffer mc-gpg-debug-buffer))) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (mml2015-format-error err)) + nil) + (quit + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") + nil)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "OK") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed")))) (defun mml2015-mailcrypt-sign (cont) (mc-sign-generic (message-options-get 'message-sender) nil nil nil nil) - (let ((boundary + (let ((boundary (funcall mml-boundary-function (incf mml-multipart-number))) hash point) (goto-char (point-min)) (unless (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\r?$" nil t) - (error "Cannot find signed begin line." )) + (error "Cannot find signed begin line")) (goto-char (match-beginning 0)) (forward-line 1) (unless (looking-at "Hash:[ \t]*\\([a-zA-Z0-9]+\\)") - (error "Cannot not find PGP hash." )) + (error "Cannot not find PGP hash")) (setq hash (match-string 1)) (unless (re-search-forward "^$" nil t) - (error "Cannot not find PGP message." )) + (error "Cannot not find PGP message")) (forward-line 1) (delete-region (point-min) (point)) (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" @@ -234,12 +290,12 @@ (setq point (point)) (goto-char (point-max)) (unless (re-search-backward "^-----END PGP SIGNATURE-----\r?$" nil t) - (error "Cannot find signature part." )) + (error "Cannot find signature part")) (replace-match "-----END PGP MESSAGE-----" t t) (goto-char (match-beginning 0)) - (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$" + (unless (re-search-backward "^-----BEGIN PGP SIGNATURE-----\r?$" nil t) - (error "Cannot find signature part." )) + (error "Cannot find signature part")) (replace-match "-----BEGIN PGP MESSAGE-----" t t) (goto-char (match-beginning 0)) (save-restriction @@ -254,27 +310,28 @@ (insert (format "--%s--\n" boundary)) (goto-char (point-max)))) -(defun mml2015-mailcrypt-encrypt (cont) +(defun mml2015-mailcrypt-encrypt (cont &optional sign) (let ((mc-pgp-always-sign (or mc-pgp-always-sign + sign (eq t (or (message-options-get 'message-sign-encrypt) - (message-options-set + (message-options-set 'message-sign-encrypt (or (y-or-n-p "Sign the message? ") 'not)))) 'never))) (mm-with-unibyte-current-buffer-mule4 - (mc-encrypt-generic + (mc-encrypt-generic (or (message-options-get 'message-recipients) (message-options-set 'message-recipients - (mc-cleanup-recipient-headers - (read-string "Recipients: ")))) + (mc-cleanup-recipient-headers + (read-string "Recipients: ")))) nil nil nil (message-options-get 'message-sender)))) (goto-char (point-min)) (unless (looking-at "-----BEGIN PGP MESSAGE-----") - (error "Fail to encrypt the message.")) - (let ((boundary + (error "Fail to encrypt the message")) + (let ((boundary (funcall mml-boundary-function (incf mml-multipart-number)))) (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n" boundary)) @@ -296,6 +353,7 @@ (autoload 'gpg-verify-cleartext "gpg") (autoload 'gpg-sign-detached "gpg") (autoload 'gpg-sign-encrypt "gpg") + (autoload 'gpg-encrypt "gpg") (autoload 'gpg-passphrase-read "gpg")) (defun mml2015-gpg-passphrase () @@ -306,15 +364,18 @@ (let ((cipher (current-buffer)) plain result) (if (with-temp-buffer (prog1 - (gpg-decrypt cipher (setq plain (current-buffer)) + (gpg-decrypt cipher (setq plain (current-buffer)) mml2015-result-buffer nil) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (with-current-buffer mml2015-result-buffer (buffer-string))) (set-buffer cipher) (erase-buffer) - (insert-buffer plain))) + (insert-buffer plain) + (goto-char (point-min)) + (while (search-forward "\r\n" nil t) + (replace-match "\n" t t)))) '(t) ;; Some wrong with the return value, check plain text buffer. (if (> (point-max) (point-min)) @@ -329,78 +390,151 @@ (let (result) (setq result (mml2015-gpg-decrypt-1)) (if (car result) - (mm-set-handle-multipart-parameter + (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "OK") - (mm-set-handle-multipart-parameter + (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Failed")))) +(defun mml2015-gpg-pretty-print-fpr (fingerprint) + (let* ((result "") + (fpr-length (string-width fingerprint)) + (n-slice 0) + slice) + (setq fingerprint (string-to-list fingerprint)) + (while fingerprint + (setq fpr-length (- fpr-length 4)) + (setq slice (butlast fingerprint fpr-length)) + (setq fingerprint (nthcdr 4 fingerprint)) + (setq n-slice (1+ n-slice)) + (setq result + (concat + result + (case n-slice + (1 slice) + (otherwise (concat " " slice)))))) + result)) + +(defun mml2015-gpg-extract-signature-details () + (goto-char (point-min)) + (if (boundp 'gpg-unabbrev-trust-alist) + (let* ((expired (re-search-forward + "^\\[GNUPG:\\] SIGEXPIRED$" + nil t)) + (signer (and (re-search-forward + "^\\[GNUPG:\\] GOODSIG \\([0-9A-Za-z]*\\) \\(.*\\)$" + nil t) + (cons (match-string 1) (match-string 2)))) + (fprint (and (re-search-forward + "^\\[GNUPG:\\] VALIDSIG \\([0-9a-zA-Z]*\\) " + nil t) + (match-string 1))) + (trust (and (re-search-forward "^\\[GNUPG:\\] \\(TRUST_.*\\)$" nil t) + (match-string 1))) + (trust-good-enough-p + (cdr (assoc (cdr (assoc trust gpg-unabbrev-trust-alist)) + mml2015-trust-boundaries-alist)))) + (cond ((and signer fprint) + (concat (cdr signer) + (unless trust-good-enough-p + (concat "\nUntrusted, Fingerprint: " + (mml2015-gpg-pretty-print-fpr fprint))) + (when expired + (format "\nWARNING: Signature from expired key (%s)" + (car signer))))) + (t + "From unknown user"))) + (if (re-search-forward "^gpg: Good signature from \"\\(.*\\)\"$" nil t) + (match-string 1) + "From unknown user"))) + (defun mml2015-gpg-verify (handle ctl) (catch 'error - (let (part message signature) - (unless (setq part (mm-find-raw-part-by-type - ctl (or (mm-handle-multipart-ctl-parameter + (let (part message signature info-is-set-p) + (unless (setq part (mm-find-raw-part-by-type + ctl (or (mm-handle-multipart-ctl-parameter ctl 'protocol) "application/pgp-signature") t)) - (mm-set-handle-multipart-parameter + (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Corrupted") (throw 'error handle)) (with-temp-buffer (setq message (current-buffer)) (insert part) + ;; Convert to in verify mode. Sign and + ;; clearsign use --textmode. The conversion is not necessary. + ;; In clearverify, the conversion is not necessary either. + (goto-char (point-min)) + (end-of-line) + (while (not (eobp)) + (unless (eq (char-before) ?\r) + (insert "\r")) + (forward-line) + (end-of-line)) (with-temp-buffer (setq signature (current-buffer)) - (unless (setq part (mm-find-part-by-type + (unless (setq part (mm-find-part-by-type (cdr handle) "application/pgp-signature" nil t)) - (mm-set-handle-multipart-parameter + (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Corrupted") (throw 'error handle)) (mm-insert-part part) (unless (condition-case err (prog1 (gpg-verify message signature mml2015-result-buffer) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (with-current-buffer mml2015-result-buffer (buffer-string)))) - (error - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details (cadr err)) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (mml2015-format-error err)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Error.") + (setq info-is-set-p t) nil) (quit - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details "Quit.") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Quit.") + (setq info-is-set-p t) nil)) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "Failed") + (unless info-is-set-p + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed")) (throw 'error handle))) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "OK")) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info + (with-current-buffer mml2015-result-buffer + (mml2015-gpg-extract-signature-details)))) handle))) (defun mml2015-gpg-clear-verify () (if (condition-case err (prog1 (gpg-verify-cleartext (current-buffer) mml2015-result-buffer) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (with-current-buffer mml2015-result-buffer (buffer-string)))) - (error - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details (cadr err)) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (mml2015-format-error err)) nil) (quit - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details "Quit.") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details "Quit.") nil)) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-info "OK") - (mm-set-handle-multipart-parameter + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info + (with-current-buffer mml2015-result-buffer + (mml2015-gpg-extract-signature-details))) + (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Failed"))) (defun mml2015-gpg-sign (cont) - (let ((boundary + (let ((boundary (funcall mml-boundary-function (incf mml-multipart-number))) (text (current-buffer)) signature) (goto-char (point-max)) @@ -408,13 +542,16 @@ (insert "\n")) (with-temp-buffer (unless (gpg-sign-detached text (setq signature (current-buffer)) - mml2015-result-buffer + mml2015-result-buffer nil (message-options-get 'message-sender) t t) ; armor & textmode (unless (> (point-max) (point-min)) (pop-to-buffer mml2015-result-buffer) - (error "Sign error."))) + (error "Sign error"))) + (goto-char (point-min)) + (while (re-search-forward "\r+$" nil t) + (replace-match "" t t)) (set-buffer text) (goto-char (point-min)) (insert (format "Content-Type: multipart/signed; boundary=\"%s\";\n" @@ -430,28 +567,45 @@ (insert (format "--%s--\n" boundary)) (goto-char (point-max))))) -(defun mml2015-gpg-encrypt (cont) - (let ((boundary +(defun mml2015-gpg-encrypt (cont &optional sign) + (let ((boundary (funcall mml-boundary-function (incf mml-multipart-number))) (text (current-buffer)) cipher) (mm-with-unibyte-current-buffer-mule4 (with-temp-buffer - (unless (gpg-sign-encrypt - text (setq cipher (current-buffer)) - mml2015-result-buffer - (split-string - (or - (message-options-get 'message-recipients) - (message-options-set 'message-recipients - (read-string "Recipients: "))) - "[ \f\t\n\r\v,]+") - nil - (message-options-get 'message-sender) - t t) ; armor & textmode - (unless (> (point-max) (point-min)) - (pop-to-buffer mml2015-result-buffer) - (error "Encrypt error."))) + ;; set up a function to call the correct gpg encrypt routine + ;; with the right arguments. (FIXME: this should be done + ;; differently.) + (flet ((gpg-encrypt-func + (sign plaintext ciphertext result recipients &optional + passphrase sign-with-key armor textmode) + (if sign + (gpg-sign-encrypt + plaintext ciphertext result recipients passphrase + sign-with-key armor textmode) + (gpg-encrypt + plaintext ciphertext result recipients passphrase + armor textmode)))) + (unless (gpg-encrypt-func + sign ; passed in when using signencrypt + text (setq cipher (current-buffer)) + mml2015-result-buffer + (split-string + (or + (message-options-get 'message-recipients) + (message-options-set 'message-recipients + (read-string "Recipients: "))) + "[ \f\t\n\r\v,]+") + nil + (message-options-get 'message-sender) + t t) ; armor & textmode + (unless (> (point-max) (point-min)) + (pop-to-buffer mml2015-result-buffer) + (error "Encrypt error")))) + (goto-char (point-min)) + (while (re-search-forward "\r+$" nil t) + (replace-match "" t t)) (set-buffer text) (delete-region (point-min) (point-max)) (insert (format "Content-Type: multipart/encrypted; boundary=\"%s\";\n" @@ -509,12 +663,12 @@ mml2015-use) ;;;###autoload -(defun mml2015-encrypt (cont) +(defun mml2015-encrypt (cont &optional sign) (mml2015-clean-buffer) (let ((func (nth 2 (assq mml2015-use mml2015-function-alist)))) (if func - (funcall func cont) - (error "Cannot find encrypt function.")))) + (funcall func cont sign) + (error "Cannot find encrypt function")))) ;;;###autoload (defun mml2015-sign (cont) @@ -522,7 +676,7 @@ (let ((func (nth 1 (assq mml2015-use mml2015-function-alist)))) (if func (funcall func cont) - (error "Cannot find sign function.")))) + (error "Cannot find sign function")))) ;;;###autoload (defun mml2015-self-encrypt ()