X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmml2015.el;h=74290f4546998b5d54f7c4653dc49c19aea7ea78;hp=0bc83ad4fb0408f32d0f171e3f90ecdb2c33cef4;hb=7dc6931f0d00f624db4ec29ea5e94c2e32ff28a3;hpb=a4906a3fb61069d9231c9f1d12c6cd54a4738867 diff --git a/lisp/mml2015.el b/lisp/mml2015.el index 0bc83ad4f..74290f454 100644 --- a/lisp/mml2015.el +++ b/lisp/mml2015.el @@ -1,6 +1,6 @@ ;;; mml2015.el --- MIME Security with Pretty Good Privacy (PGP) -;; Copyright (C) 2000-2012 Free Software Foundation, Inc. +;; Copyright (C) 2000-2014 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu ;; Keywords: PGP MIME MML @@ -28,9 +28,6 @@ ;;; Code: (eval-and-compile - ;; For Emacs <22.2 and XEmacs. - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) - (if (locate-library "password-cache") (require 'password-cache) (require 'password))) @@ -47,13 +44,14 @@ (config &optional minimum-version)) (declare-function epg-configuration "ext:epg-config" ()) +;; Maybe this should be in eg mml-sec.el (and have a different name). +;; Then mml1991 would not need to require mml2015, and mml1991-use +;; could be removed. (defvar mml2015-use (or - (condition-case nil - (progn - (require 'epg-config) - (epg-check-configuration (epg-configuration)) - 'epg) - (error)) + (progn + (ignore-errors (require 'epg-config)) + (and (fboundp 'epg-check-configuration) + 'epg)) (progn (let ((abs-file (locate-library "pgg"))) ;; Don't load PGG if it is marked as obsolete @@ -143,6 +141,18 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." :group 'mime-security :type 'boolean) +(defcustom mml2015-maximum-key-image-dimension 64 + "The maximum dimension (width or height) of any key images." + :version "24.4" + :group 'mime-security + :type 'integer) + +(defcustom mml2015-display-key-image t + "If t, try to display key images." + :version "24.5" + :group 'mime-security + :type 'boolean) + ;; Extract plaintext from cleartext signature. IMO, this kind of task ;; should be done by GnuPG rather than Elisp, but older PGP backends ;; (such as Mailcrypt, and PGG) discard the output from GnuPG. @@ -757,6 +767,9 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (autoload 'epg-sub-key-fingerprint "epg") (autoload 'epg-signature-key-id "epg") (autoload 'epg-signature-to-string "epg") +(autoload 'epg-key-user-id-list "epg") +(autoload 'epg-user-id-string "epg") +(autoload 'epg-user-id-validity "epg") (autoload 'epg-configuration "epg-config") (autoload 'epg-expand-group "epg-config") (autoload 'epa-select-keys "epa") @@ -786,21 +799,53 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (cons password-cache-key-id mml2015-epg-secret-key-id-list)) (copy-sequence passphrase))))) -(defun mml2015-epg-find-usable-key (keys usage) - (catch 'found +(defun mml2015-epg-check-user-id (key recipient) + (let ((pointer (epg-key-user-id-list key)) + result) + (while pointer + (if (and (equal (car (mail-header-parse-address + (epg-user-id-string (car pointer)))) + (car (mail-header-parse-address + recipient))) + (not (memq (epg-user-id-validity (car pointer)) + '(revoked expired)))) + (setq result t + pointer nil) + (setq pointer (cdr pointer)))) + result)) + +(defun mml2015-epg-check-sub-key (key usage) + (let ((pointer (epg-key-sub-key-list key)) + result) + ;; The primary key will be marked as disabled, when the entire + ;; key is disabled (see 12 Field, Format of colon listings, in + ;; gnupg/doc/DETAILS) + (unless (memq 'disabled (epg-sub-key-capability (car pointer))) + (while pointer + (if (and (memq usage (epg-sub-key-capability (car pointer))) + (not (memq (epg-sub-key-validity (car pointer)) + '(revoked expired)))) + (setq result t + pointer nil) + (setq pointer (cdr pointer))))) + result)) + +(defun mml2015-epg-find-usable-key (context name usage + &optional name-is-key-id) + (let ((keys (epg-list-keys context name)) + key) (while keys - (let ((pointer (epg-key-sub-key-list (car keys)))) - ;; The primary key will be marked as disabled, when the entire - ;; key is disabled (see 12 Field, Format of colon listings, in - ;; gnupg/doc/DETAILS) - (unless (memq 'disabled (epg-sub-key-capability (car pointer))) - (while pointer - (if (and (memq usage (epg-sub-key-capability (car pointer))) - (not (memq (epg-sub-key-validity (car pointer)) - '(revoked expired)))) - (throw 'found (car keys))) - (setq pointer (cdr pointer))))) - (setq keys (cdr keys))))) + (if (and (or name-is-key-id + ;; Non email user-id can be supplied through + ;; mml2015-signers if mml2015-encrypt-to-self is set. + ;; Treat it as valid, as it is user's intention. + (not (string-match "\\`<" name)) + (mml2015-epg-check-user-id (car keys) name)) + (mml2015-epg-check-sub-key (car keys) usage)) + (setq key (car keys) + keys nil) + (setq keys (cdr keys)))) + key)) ;; XXX: since gpg --list-secret-keys does not return validity of each ;; key, `mml2015-epg-find-usable-key' defined above is not enough for @@ -811,15 +856,19 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." secret-key) (while (and (not secret-key) secret-keys) (if (mml2015-epg-find-usable-key - (epg-list-keys context (epg-sub-key-fingerprint - (car (epg-key-sub-key-list - (car secret-keys))))) - usage) + context + (epg-sub-key-fingerprint + (car (epg-key-sub-key-list + (car secret-keys)))) + usage + t) (setq secret-key (car secret-keys) secret-keys nil) (setq secret-keys (cdr secret-keys)))) secret-key)) +(autoload 'gnus-create-image "gnus-ems") + (defun mml2015-epg-key-image (key-id) "Return the image of a key, if any" (with-temp-buffer @@ -827,24 +876,36 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (let* ((coding-system-for-write 'binary) (coding-system-for-read 'binary) (data (shell-command-to-string - (format "%s --list-options no-show-photos --attribute-fd 2 --list-keys %s > /dev/null" - epg-gpg-program key-id)))) + (format "%s --list-options no-show-photos --attribute-fd 3 --list-keys %s 3>&1 >/dev/null 2>&1" + (shell-quote-argument epg-gpg-program) key-id)))) (when (> (length data) 0) (insert (substring data 16)) - (create-image (buffer-string) nil t))))) + (condition-case nil + (gnus-create-image (buffer-string) nil t) + (error)))))) + +(autoload 'gnus-rescale-image "gnus-util") (defun mml2015-epg-key-image-to-string (key-id) "Return a string with the image of a key, if any" - (let* ((result "") - (key-image (mml2015-epg-key-image key-id))) - (when key-image - (setq result " ") - (put-text-property 1 2 'display key-image result)) - result)) + (let ((key-image (mml2015-epg-key-image key-id))) + (if (not key-image) + "" + (condition-case error + (let ((result " ")) + (put-text-property + 1 2 'display + (gnus-rescale-image key-image + (cons mml2015-maximum-key-image-dimension + mml2015-maximum-key-image-dimension)) + result) + result) + (error ""))))) (defun mml2015-epg-signature-to-string (signature) (concat (epg-signature-to-string signature) - (mml2015-epg-key-image-to-string (epg-signature-key-id signature)))) + (when mml2015-display-key-image + (mml2015-epg-key-image-to-string (epg-signature-key-id signature))))) (defun mml2015-epg-verify-result-to-string (verify-result) (mapconcat #'mml2015-epg-signature-to-string verify-result "\n")) @@ -1045,6 +1106,10 @@ If no one is selected, default secret key is used. " (epg-context-set-passphrase-callback context #'mml2015-epg-passphrase-callback)) + ;; Signed data must end with a newline (RFC 3156, 5). + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) (condition-case error (setq signature (epg-sign-string context (buffer-string) t) mml2015-epg-secret-key-id-list nil) @@ -1069,7 +1134,7 @@ If no one is selected, default secret key is used. " (insert (format "\n--%s\n" boundary)) (goto-char (point-max)) (insert (format "\n--%s\n" boundary)) - (insert "Content-Type: application/pgp-signature\n\n") + (insert "Content-Type: application/pgp-signature; name=\"signature.asc\"\n\n") (insert signature) (goto-char (point-max)) (insert (format "--%s--\n" boundary)) @@ -1115,8 +1180,7 @@ If no one is selected, symmetric encryption will be performed. " (mapcar (lambda (recipient) (setq recipient-key (mml2015-epg-find-usable-key - (epg-list-keys context recipient) - 'encrypt)) + context recipient 'encrypt)) (unless (or recipient-key (y-or-n-p (format "No public key for %s; skip it? "