X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmml2015.el;h=389b522aec8dd77ec1ed220d02004c35c11fa837;hb=d35146fa43e9e2d8d346073c3c0692162abf4759;hp=0ac6208d9d9f1b8c8cd7b5ce515c8e163a91c292;hpb=4c2a7a1c25d5b10316f35f28c972ef3e70225f25;p=gnus diff --git a/lisp/mml2015.el b/lisp/mml2015.el index 0ac6208d9..389b522ae 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-2011 Free Software Foundation, Inc. +;; Copyright (C) 2000-2013 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu ;; Keywords: PGP MIME MML @@ -47,6 +47,9 @@ (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 @@ -55,9 +58,15 @@ 'epg) (error)) (progn - (ignore-errors (require 'pgg)) - (and (fboundp 'pgg-sign-region) - 'pgg)) + (let ((abs-file (locate-library "pgg"))) + ;; Don't load PGG if it is marked as obsolete + ;; (Emacs 24). + (when (and abs-file + (not (string-match "/obsolete/[^/]*\\'" + abs-file))) + (ignore-errors (require 'pgg)) + (and (fboundp 'pgg-sign-region) + 'pgg)))) (progn (ignore-errors (load "mc-toplev")) (and (fboundp 'mc-encrypt-generic) @@ -116,10 +125,17 @@ Whether the passphrase is cached at all is controlled by :type 'integer) (defcustom mml2015-signers nil - "A list of your own key ID which will be used to sign a message." + "A list of your own key ID(s) which will be used to sign a message. +If set, it overrides the setting of `mml2015-sign-with-sender'." :group 'mime-security :type '(repeat (string :tag "Key ID"))) +(defcustom mml2015-sign-with-sender nil + "If t, use message sender so find a key to sign with." + :group 'mime-security + :type 'boolean + :version "24.1") + (defcustom mml2015-encrypt-to-self nil "If t, add your own key ID to recipient list when encryption." :group 'mime-security @@ -130,6 +146,12 @@ Whether the passphrase is cached at all is controlled by :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) + ;; 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. @@ -722,6 +744,7 @@ Whether the passphrase is cached at all is controlled by (defvar epg-user-id-alist) (defvar epg-digest-algorithm-alist) +(defvar epg-gpg-program) (defvar inhibit-redisplay) (autoload 'epg-make-context "epg") @@ -730,7 +753,6 @@ Whether the passphrase is cached at all is controlled by (autoload 'epg-context-set-signers "epg") (autoload 'epg-context-result-for "epg") (autoload 'epg-new-signature-digest-algorithm "epg") -(autoload 'epg-verify-result-to-string "epg") (autoload 'epg-list-keys "epg") (autoload 'epg-decrypt-string "epg") (autoload 'epg-verify-string "epg") @@ -742,6 +764,11 @@ Whether the passphrase is cached at all is controlled by (autoload 'epg-sub-key-capability "epg") (autoload 'epg-sub-key-validity "epg") (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") @@ -771,18 +798,53 @@ Whether the passphrase is cached at all is controlled by (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)))) - (while pointer - (if (and (memq usage (epg-sub-key-capability (car pointer))) - (not (memq 'disabled (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 @@ -793,15 +855,53 @@ Whether the passphrase is cached at all is controlled by 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)) +(defun mml2015-epg-key-image (key-id) + "Return the image of a key, if any" + (with-temp-buffer + (mm-set-buffer-multibyte nil) + (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 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))))) + +(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 + (gnus-rescale-image key-image + (cons mml2015-maximum-key-image-dimension + mml2015-maximum-key-image-dimension)) + result)) + result)) + +(defun mml2015-epg-signature-to-string (signature) + (concat (epg-signature-to-string signature) + (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")) + (defun mml2015-epg-decrypt (handle ctl) (catch 'error (let ((inhibit-redisplay t) @@ -844,7 +944,7 @@ Whether the passphrase is cached at all is controlled by (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info (concat "OK\n" - (epg-verify-result-to-string + (mml2015-epg-verify-result-to-string (epg-context-result-for context 'verify)))) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "OK")) @@ -892,7 +992,7 @@ Whether the passphrase is cached at all is controlled by (if (epg-context-result-for context 'verify) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details - (epg-verify-result-to-string + (mml2015-epg-verify-result-to-string (epg-context-result-for context 'verify))))))) (defun mml2015-epg-verify (handle ctl) @@ -910,7 +1010,7 @@ Whether the passphrase is cached at all is controlled by (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info "Corrupted") (throw 'error handle)) - (setq part (mm-replace-in-string part "\n" "\r\n" t) + (setq part (mm-replace-in-string part "\n" "\r\n") signature (mm-get-part signature) context (epg-make-context)) (condition-case error @@ -926,7 +1026,8 @@ Whether the passphrase is cached at all is controlled by (throw 'error handle))) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info - (epg-verify-result-to-string (epg-context-result-for context 'verify))) + (mml2015-epg-verify-result-to-string + (epg-context-result-for context 'verify))) handle))) (defun mml2015-epg-clear-verify () @@ -949,7 +1050,7 @@ Whether the passphrase is cached at all is controlled by (progn (mm-set-handle-multipart-parameter mm-security-handle 'gnus-info - (epg-verify-result-to-string + (mml2015-epg-verify-result-to-string (epg-context-result-for context 'verify))) (delete-region (point-min) (point-max)) (insert (mm-decode-coding-string plain coding-system-for-read))) @@ -960,6 +1061,9 @@ Whether the passphrase is cached at all is controlled by (context (epg-make-context)) (boundary (mml-compute-boundary cont)) (sender (message-options-get 'message-sender)) + (signer-names (or mml2015-signers + (if (and mml2015-sign-with-sender sender) + (list (concat "<" sender ">"))))) signer-key (signers (or (message-options-get 'mml2015-epg-signers) @@ -969,10 +1073,7 @@ Whether the passphrase is cached at all is controlled by (epa-select-keys context "\ Select keys for signing. If no one is selected, default secret key is used. " - (if sender - (cons (concat "<" sender ">") - mml2015-signers) - mml2015-signers) + signer-names t) (if (or sender mml2015-signers) (delq nil @@ -988,10 +1089,7 @@ If no one is selected, default secret key is used. " signer))) (error "No secret key for %s" signer)) signer-key) - (if sender - (cons (concat "<" sender ">") - mml2015-signers) - mml2015-signers)))))))) + signer-names))))))) signature micalg) (epg-context-set-armor context t) (epg-context-set-textmode context t) @@ -1000,6 +1098,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) @@ -1024,21 +1126,25 @@ 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)) (goto-char (point-max)))) (defun mml2015-epg-encrypt (cont &optional sign) - (let ((inhibit-redisplay t) - (context (epg-make-context)) - (config (epg-configuration)) - (sender (message-options-get 'message-sender)) - (recipients (message-options-get 'mml2015-epg-recipients)) - cipher signers - (boundary (mml-compute-boundary cont)) - recipient-key signer-key) + (let* ((inhibit-redisplay t) + (context (epg-make-context)) + (boundary (mml-compute-boundary cont)) + (config (epg-configuration)) + (recipients (message-options-get 'mml2015-epg-recipients)) + cipher + (sender (message-options-get 'message-sender)) + (signer-names (or mml2015-signers + (if (and mml2015-sign-with-sender sender) + (list (concat "<" sender ">"))))) + signers + recipient-key signer-key) (unless recipients (setq recipients (apply #'nconc @@ -1052,12 +1158,9 @@ If no one is selected, default secret key is used. " (read-string "Recipients: "))) "[ \f\t\n\r\v,]+")))) (when mml2015-encrypt-to-self - (unless (or sender mml2015-signers) - (error "Message sender and mml2015-signers not set")) - (setq recipients (nconc recipients (if sender - (cons (concat "<" sender ">") - mml2015-signers) - mml2015-signers)))) + (unless signer-names + (error "Neither message sender nor mml2015-signers are set")) + (setq recipients (nconc recipients signer-names))) (if (eq mm-encrypt-option 'guided) (setq recipients (epa-select-keys context "\ @@ -1069,8 +1172,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? " @@ -1090,10 +1192,7 @@ If no one is selected, symmetric encryption will be performed. " (epa-select-keys context "\ Select keys for signing. If no one is selected, default secret key is used. " - (if sender - (cons (concat "<" sender ">") - mml2015-signers) - mml2015-signers) + signer-names t) (if (or sender mml2015-signers) (delq nil @@ -1109,9 +1208,7 @@ If no one is selected, default secret key is used. " signer))) (error "No secret key for %s" signer)) signer-key) - (if sender - (cons (concat "<" sender ">") mml2015-signers) - mml2015-signers)))))))) + signer-names))))))) (epg-context-set-signers context signers)) (epg-context-set-armor context t) (epg-context-set-textmode context t)