diff options
Diffstat (limited to 'lisp/gnus/mml-sec.el')
| -rw-r--r-- | lisp/gnus/mml-sec.el | 534 |
1 files changed, 3 insertions, 531 deletions
diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index 0a5f472079d..dbd31629f97 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -25,9 +25,7 @@ (eval-when-compile (require 'cl)) -(require 'gnus-util) -(require 'epg) - +(autoload 'gnus-subsetp "gnus-util") (autoload 'mail-strip-quoted-names "mail-utils") (autoload 'mml2015-sign "mml2015") (autoload 'mml2015-encrypt "mml2015") @@ -42,7 +40,6 @@ (autoload 'mml-smime-encrypt-query "mml-smime") (autoload 'mml-smime-verify "mml-smime") (autoload 'mml-smime-verify-test "mml-smime") -(autoload 'epa--select-keys "epa") (defvar mml-sign-alist '(("smime" mml-smime-sign-buffer mml-smime-sign-query) @@ -94,7 +91,7 @@ signs and encrypt the message in one step. Note that the output generated by using a `combined' mode is NOT understood by all PGP implementations, in particular PGP version -2 does not support it! See Info node `(message) Security' for +2 does not support it! See Info node `(message)Security' for details." :version "22.1" :group 'message @@ -114,9 +111,7 @@ details." (if (boundp 'password-cache) password-cache t) - "If t, cache OpenPGP or S/MIME passphrases inside Emacs. -Passphrase caching in Emacs is NOT recommended. Use gpg-agent instead. -See Info node `(message) Security'." + "If t, cache passphrase." :group 'message :type 'boolean) @@ -430,529 +425,6 @@ If called with a prefix argument, only encrypt (do NOT sign)." (interactive "P") (mml-secure-message "pgpauto" (if dontsign 'encrypt 'signencrypt))) -;;; Common functionality for mml1991.el, mml2015.el, mml-smime.el - -(define-obsolete-variable-alias 'mml1991-signers 'mml-secure-openpgp-signers) -(define-obsolete-variable-alias 'mml2015-signers 'mml-secure-openpgp-signers) -(defcustom mml-secure-openpgp-signers nil - "A list of your own key ID(s) which will be used to sign OpenPGP messages. -If set, it is added to the setting of `mml-secure-openpgp-sign-with-sender'." - :group 'mime-security - :type '(repeat (string :tag "Key ID"))) - -(define-obsolete-variable-alias 'mml-smime-signers 'mml-secure-smime-signers) -(defcustom mml-secure-smime-signers nil - "A list of your own key ID(s) which will be used to sign S/MIME messages. -If set, it is added to the setting of `mml-secure-smime-sign-with-sender'." - :group 'mime-security - :type '(repeat (string :tag "Key ID"))) - -(define-obsolete-variable-alias - 'mml1991-encrypt-to-self 'mml-secure-openpgp-encrypt-to-self) -(define-obsolete-variable-alias - 'mml2015-encrypt-to-self 'mml-secure-openpgp-encrypt-to-self) -(defcustom mml-secure-openpgp-encrypt-to-self nil - "List of own key ID(s) or t; determines additional recipients with OpenPGP. -If t, also encrypt to key for message sender; if list, encrypt to those keys. -With this variable, you can ensure that you can decrypt your own messages. -Alternatives to this variable include Bcc'ing the message to yourself or -using the encrypt-to or hidden-encrypt-to option in gpg.conf (see man gpg(1)). -Note that this variable and the encrypt-to option give away your identity -for *every* encryption without warning, which is not what you want if you are -using, e.g., remailers. -Also, use of Bcc gives away your identity for *every* encryption without -warning, which is a bug, see: -https://debbugs.gnu.org/cgi/bugreport.cgi?bug=18718" - :group 'mime-security - :type '(choice (const :tag "None" nil) - (const :tag "From address" t) - (repeat (string :tag "Key ID")))) - -(define-obsolete-variable-alias - 'mml-smime-encrypt-to-self 'mml-secure-smime-encrypt-to-self) -(defcustom mml-secure-smime-encrypt-to-self nil - "List of own key ID(s) or t; determines additional recipients with S/MIME. -If t, also encrypt to key for message sender; if list, encrypt to those keys. -With this variable, you can ensure that you can decrypt your own messages. -Alternatives to this variable include Bcc'ing the message to yourself or -using the encrypt-to option in gpgsm.conf (see man gpgsm(1)). -Note that this variable and the encrypt-to option give away your identity -for *every* encryption without warning, which is not what you want if you are -using, e.g., remailers. -Also, use of Bcc gives away your identity for *every* encryption without -warning, which is a bug, see: -https://debbugs.gnu.org/cgi/bugreport.cgi?bug=18718" - :group 'mime-security - :type '(choice (const :tag "None" nil) - (const :tag "From address" t) - (repeat (string :tag "Key ID")))) - -(define-obsolete-variable-alias - 'mml2015-sign-with-sender 'mml-secure-openpgp-sign-with-sender) -;mml1991-sign-with-sender did never exist. -(defcustom mml-secure-openpgp-sign-with-sender nil - "If t, use message sender to find an OpenPGP key to sign with." - :group 'mime-security - :type 'boolean) - -(define-obsolete-variable-alias - 'mml-smime-sign-with-sender 'mml-secure-smime-sign-with-sender) -(defcustom mml-secure-smime-sign-with-sender nil - "If t, use message sender to find an S/MIME key to sign with." - :group 'mime-security - :type 'boolean) - -(define-obsolete-variable-alias - 'mml2015-always-trust 'mml-secure-openpgp-always-trust) -;mml1991-always-trust did never exist. -(defcustom mml-secure-openpgp-always-trust t - "If t, skip key validation of GnuPG on encryption." - :group 'mime-security - :type 'boolean) - -(defcustom mml-secure-fail-when-key-problem nil - "If t, raise an error if some key is missing or several keys exist. -Otherwise, ask the user." - :group 'mime-security - :type 'boolean) - -(defcustom mml-secure-key-preferences - '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))) - "Protocol- and usage-specific fingerprints of preferred keys. -This variable is only relevant if a recipient owns multiple key pairs (for -encryption) or you own multiple key pairs (for signing). In such cases, -you will be asked which key(s) should be used, and your choice can be -customized in this variable." - :group 'mime-security - :type '(alist :key-type (symbol :tag "Protocol") :value-type - (alist :key-type (symbol :tag "Usage") :value-type - (alist :key-type (string :tag "Name") :value-type - (repeat (string :tag "Fingerprint")))))) - -(defun mml-secure-cust-usage-lookup (context usage) - "Return preferences for CONTEXT and USAGE." - (let* ((protocol (epg-context-protocol context)) - (protocol-prefs (cdr (assoc protocol mml-secure-key-preferences)))) - (assoc usage protocol-prefs))) - -(defun mml-secure-cust-fpr-lookup (context usage name) - "Return fingerprints of preferred keys for CONTEXT, USAGE, and NAME." - (let* ((usage-prefs (mml-secure-cust-usage-lookup context usage)) - (fprs (assoc name (cdr usage-prefs)))) - (when fprs - (cdr fprs)))) - -(defun mml-secure-cust-record-keys (context usage name keys &optional save) - "For CONTEXT, USAGE, and NAME record fingerprint(s) of KEYS. -If optional SAVE is not nil, save customized fingerprints. -Return keys." - (assert keys) - (let* ((usage-prefs (mml-secure-cust-usage-lookup context usage)) - (curr-fprs (cdr (assoc name (cdr usage-prefs)))) - (key-fprs (mapcar 'mml-secure-fingerprint keys)) - (new-fprs (gnus-union curr-fprs key-fprs :test 'equal))) - (if curr-fprs - (setcdr (assoc name (cdr usage-prefs)) new-fprs) - (setcdr usage-prefs (cons (cons name new-fprs) (cdr usage-prefs)))) - (when save - (customize-save-variable - 'mml-secure-key-preferences mml-secure-key-preferences)) - keys)) - -(defun mml-secure-cust-remove-keys (context usage name) - "Remove keys for CONTEXT, USAGE, and NAME. -Return t if a customization for NAME was present (and has been removed)." - (let* ((usage-prefs (mml-secure-cust-usage-lookup context usage)) - (current (assoc name usage-prefs))) - (when current - (setcdr usage-prefs (remove current (cdr usage-prefs))) - t))) - -(defvar mml-secure-secret-key-id-list nil) - -(defun mml-secure-add-secret-key-id (key-id) - "Record KEY-ID in list of secret keys." - (add-to-list 'mml-secure-secret-key-id-list key-id)) - -(defun mml-secure-clear-secret-key-id-list () - "Remove passwords from cache and clear list of secret keys." - ;; Loosely based on code inside mml2015-epg-encrypt, - ;; mml2015-epg-clear-decrypt, and mml2015-epg-decrypt - (dolist (key-id mml-secure-secret-key-id-list nil) - (password-cache-remove key-id)) - (setq mml-secure-secret-key-id-list nil)) - -(defvar mml1991-cache-passphrase) -(defvar mml1991-passphrase-cache-expiry) - -(defun mml-secure-cache-passphrase-p (protocol) - "Return t if OpenPGP or S/MIME passphrases should be cached for PROTOCOL. -Passphrase caching in Emacs is NOT recommended. Use gpg-agent instead." - (or (and (eq 'OpenPGP protocol) - (or mml-secure-cache-passphrase - (and (boundp 'mml2015-cache-passphrase) - mml2015-cache-passphrase) - (and (boundp 'mml1991-cache-passphrase) - mml1991-cache-passphrase))) - (and (eq 'CMS protocol) - (or mml-secure-cache-passphrase - (and (boundp 'mml-smime-cache-passphrase) - mml-smime-cache-passphrase))))) - -(defun mml-secure-cache-expiry-interval (protocol) - "Return time in seconds to cache passphrases for PROTOCOL. -Passphrase caching in Emacs is NOT recommended. Use gpg-agent instead." - (or (and (eq 'OpenPGP protocol) - (or (and (boundp 'mml2015-passphrase-cache-expiry) - mml2015-passphrase-cache-expiry) - (and (boundp 'mml1991-passphrase-cache-expiry) - mml1991-passphrase-cache-expiry) - mml-secure-passphrase-cache-expiry)) - (and (eq 'CMS protocol) - (or (and (boundp 'mml-smime-passphrase-cache-expiry) - mml-smime-passphrase-cache-expiry) - mml-secure-passphrase-cache-expiry)))) - -(defun mml-secure-passphrase-callback (context key-id standard) - "Ask for passphrase in CONTEXT for KEY-ID for STANDARD. -The passphrase is read and cached." - ;; Based on mml2015-epg-passphrase-callback. - (if (eq key-id 'SYM) - (epg-passphrase-callback-function context key-id nil) - (let* ((password-cache-key-id - (if (eq key-id 'PIN) - "PIN" - key-id)) - (entry (assoc key-id epg-user-id-alist)) - (passphrase - (password-read - (if (eq key-id 'PIN) - "Passphrase for PIN: " - (if entry - (format "Passphrase for %s %s: " key-id (cdr entry)) - (format "Passphrase for %s: " key-id))) - ;; TODO: With mml-smime.el, password-cache-key-id is not passed - ;; as argument to password-read. - ;; Is that on purpose? If so, the following needs to be placed - ;; inside an if statement. - password-cache-key-id))) - (when passphrase - (let ((password-cache-expiry (mml-secure-cache-expiry-interval - (epg-context-protocol context)))) - (password-cache-add password-cache-key-id passphrase)) - (mml-secure-add-secret-key-id password-cache-key-id) - (copy-sequence passphrase))))) - -(defun mml-secure-check-user-id (key recipient) - "Check whether KEY has a non-revoked, non-expired UID for RECIPIENT." - ;; Based on mml2015-epg-check-user-id. - (let ((uids (epg-key-user-id-list key))) - (catch 'break - (dolist (uid uids nil) - (if (and (stringp (epg-user-id-string uid)) - (equal (car (mail-header-parse-address - (epg-user-id-string uid))) - (car (mail-header-parse-address - recipient))) - (not (memq (epg-user-id-validity uid) - '(revoked expired)))) - (throw 'break t)))))) - -(defun mml-secure-secret-key-exists-p (context subkey) - "Return t if keyring for CONTEXT contains secret key for public SUBKEY." - (let* ((fpr (epg-sub-key-fingerprint subkey)) - (candidates (epg-list-keys context fpr 'secret)) - (candno (length candidates))) - ;; If two or more subkeys with the same fingerprint exist, something is - ;; terribly wrong. - (when (>= candno 2) - (error "Found %d secret keys with same fingerprint %s" candno fpr)) - (= 1 candno))) - -(defun mml-secure-check-sub-key (context key usage &optional fingerprint) - "Check whether in CONTEXT the public KEY has a usable subkey for USAGE. -This is the case if KEY is not disabled, and there is a subkey for -USAGE that is neither revoked nor expired. Additionally, if optional -FINGERPRINT is present and if it is not the primary key's fingerprint, then -the returned subkey must have that FINGERPRINT. FINGERPRINT must consist of -hexadecimal digits only (no leading \"0x\" allowed). -If USAGE is not `encrypt', then additionally an appropriate secret key must -be present in the keyring." - ;; Based on mml2015-epg-check-sub-key, extended by - ;; - check for secret keys if usage is not 'encrypt and - ;; - check for new argument FINGERPRINT. - (let* ((subkeys (epg-key-sub-key-list key)) - (primary (car subkeys)) - (fpr (epg-sub-key-fingerprint primary))) - ;; 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 primary)) - (catch 'break - (dolist (subkey subkeys nil) - (if (and (memq usage (epg-sub-key-capability subkey)) - (not (memq (epg-sub-key-validity subkey) - '(revoked expired))) - (or (eq 'encrypt usage) ; Encryption works with public key. - ;; In contrast, signing requires secret key. - (mml-secure-secret-key-exists-p context subkey)) - (or (not fingerprint) - (gnus-string-match-p (concat fingerprint "$") fpr) - (gnus-string-match-p (concat fingerprint "$") - (epg-sub-key-fingerprint subkey)))) - (throw 'break t))))))) - -(defun mml-secure-find-usable-keys (context name usage &optional justone) - "In CONTEXT return a list of keys for NAME and USAGE. -If USAGE is `encrypt' public keys are returned, otherwise secret ones. -Only non-revoked and non-expired keys are returned whose primary key is -not disabled. -NAME can be an e-mail address or a key ID. -If NAME just consists of hexadecimal digits (possibly prefixed by \"0x\"), it -is treated as key ID for which at most one key must exist in the keyring. -Otherwise, NAME is treated as user ID, for which no keys are returned if it -is expired or revoked. -If optional JUSTONE is not nil, return the first key instead of a list." - (let* ((keys (epg-list-keys context name)) - (iskeyid (string-match "\\(0x\\)?\\([0-9a-fA-F]\\{8,\\}\\)" name)) - (fingerprint (match-string 2 name)) - result) - (when (and iskeyid (>= (length keys) 2)) - (error - "Name %s (for %s) looks like a key ID but multiple keys found" - name usage)) - (catch 'break - (dolist (key keys result) - (if (and (or iskeyid - (mml-secure-check-user-id key name)) - (mml-secure-check-sub-key context key usage fingerprint)) - (if justone - (throw 'break key) - (push key result))))))) - -(defun mml-secure-select-preferred-keys (context names usage) - "Return list of preferred keys in CONTEXT for NAMES and USAGE. -This inspects the keyrings to find keys for each name in NAMES. If several -keys are found for a name, `mml-secure-select-keys' is used to look for -customized preferences or have the user select preferable ones. -When `mml-secure-fail-when-key-problem' is t, fail with an error in -case of missing, outdated, or multiple keys." - ;; Loosely based on code appearing inside mml2015-epg-sign and - ;; mml2015-epg-encrypt. - (apply - #'nconc - (mapcar - (lambda (name) - (let* ((keys (mml-secure-find-usable-keys context name usage)) - (keyno (length keys))) - (cond ((= 0 keyno) - (when (or mml-secure-fail-when-key-problem - (not (y-or-n-p - (format "No %s key for %s; skip it? " - usage name)))) - (error "No %s key for %s" usage name))) - ((= 1 keyno) keys) - (t (mml-secure-select-keys context name keys usage))))) - names))) - -(defun mml-secure-fingerprint (key) - "Return fingerprint for public KEY." - (epg-sub-key-fingerprint (car (epg-key-sub-key-list key)))) - -(defun mml-secure-filter-keys (keys fprs) - "Filter KEYS to subset with fingerprints in FPRS." - (when keys - (if (member (mml-secure-fingerprint (car keys)) fprs) - (cons (car keys) (mml-secure-filter-keys (cdr keys) fprs)) - (mml-secure-filter-keys (cdr keys) fprs)))) - -(defun mml-secure-normalize-cust-name (name) - "Normalize NAME to be used for customization. -Currently, remove ankle brackets." - (if (string-match "^<\\(.*\\)>$" name) - (match-string 1 name) - name)) - -(defun mml-secure-select-keys (context name keys usage) - "In CONTEXT for NAME select among KEYS for USAGE. -KEYS should be a list with multiple entries. -NAME is normalized first as customized keys are inspected. -When `mml-secure-fail-when-key-problem' is t, fail with an error in case of -outdated or multiple keys." - (let* ((nname (mml-secure-normalize-cust-name name)) - (fprs (mml-secure-cust-fpr-lookup context usage nname)) - (usable-fprs (mapcar 'mml-secure-fingerprint keys))) - (if fprs - (if (gnus-subsetp fprs usable-fprs) - (mml-secure-filter-keys keys fprs) - (mml-secure-cust-remove-keys context usage nname) - (let ((diff (gnus-setdiff fprs usable-fprs))) - (if mml-secure-fail-when-key-problem - (error "Customization of %s keys for %s outdated" usage nname) - (mml-secure-select-keys-1 - context nname keys usage (format "\ -Customized keys - (%s) -for %s not available any more. -Select anew. " - diff nname))))) - (if mml-secure-fail-when-key-problem - (error "Multiple %s keys for %s" usage nname) - (mml-secure-select-keys-1 - context nname keys usage (format "\ -Multiple %s keys for: - %s -Select preferred one(s). " - usage nname)))))) - -(defun mml-secure-select-keys-1 (context name keys usage message) - "In CONTEXT for NAME let user select among KEYS for USAGE, showing MESSAGE. -Return selected keys." - (let* ((selected (epa--select-keys message keys)) - (selno (length selected)) - ;; TODO: y-or-n-p does not always resize the echo area but may - ;; truncate the message. Why? The following does not help. - ;; yes-or-no-p shows full message, though. - (message-truncate-lines nil)) - (if selected - (if (y-or-n-p - (format "%d %s key(s) selected. Store for %s? " - selno usage name)) - (mml-secure-cust-record-keys context usage name selected 'save) - selected) - (unless (y-or-n-p - (format "No %s key for %s; skip it? " usage name)) - (error "No %s key for %s" usage name))))) - -(defun mml-secure-signer-names (protocol sender) - "Determine signer names for PROTOCOL and message from SENDER. -Returned names may be e-mail addresses or key IDs and are determined based -on `mml-secure-openpgp-signers' and `mml-secure-openpgp-sign-with-sender' with -OpenPGP or `mml-secure-smime-signers' and `mml-secure-smime-sign-with-sender' -with S/MIME." - (if (eq 'OpenPGP protocol) - (append mml-secure-openpgp-signers - (if (and mml-secure-openpgp-sign-with-sender sender) - (list (concat "<" sender ">")))) - (append mml-secure-smime-signers - (if (and mml-secure-smime-sign-with-sender sender) - (list (concat "<" sender ">")))))) - -(defun mml-secure-signers (context signer-names) - "Determine signing keys in CONTEXT from SIGNER-NAMES. -If `mm-sign-option' is `guided', the user is asked to choose. -Otherwise, `mml-secure-select-preferred-keys' is used." - ;; Based on code appearing inside mml2015-epg-sign and - ;; mml2015-epg-encrypt. - (if (eq mm-sign-option 'guided) - (epa-select-keys context "\ -Select keys for signing. -If no one is selected, default secret key is used. " - signer-names t) - (mml-secure-select-preferred-keys context signer-names 'sign))) - -(defun mml-secure-self-recipients (protocol sender) - "Determine additional recipients based on encrypt-to-self variables. -PROTOCOL specifies OpenPGP or S/MIME for a message from SENDER." - (let ((encrypt-to-self - (if (eq 'OpenPGP protocol) - mml-secure-openpgp-encrypt-to-self - mml-secure-smime-encrypt-to-self))) - (when encrypt-to-self - (if (listp encrypt-to-self) - encrypt-to-self - (list sender))))) - -(defun mml-secure-recipients (protocol context config sender) - "Determine encryption recipients. -PROTOCOL specifies OpenPGP or S/MIME with matching CONTEXT and CONFIG -for a message from SENDER." - ;; Based on code appearing inside mml2015-epg-encrypt. - (let ((recipients - (apply #'nconc - (mapcar - (lambda (recipient) - (or (epg-expand-group config recipient) - (list (concat "<" recipient ">")))) - (split-string - (or (message-options-get 'message-recipients) - (message-options-set 'message-recipients - (read-string "Recipients: "))) - "[ \f\t\n\r\v,]+"))))) - (nconc recipients (mml-secure-self-recipients protocol sender)) - (if (eq mm-encrypt-option 'guided) - (setq recipients - (epa-select-keys context "\ -Select recipients for encryption. -If no one is selected, symmetric encryption will be performed. " - recipients)) - (setq recipients - (mml-secure-select-preferred-keys context recipients 'encrypt)) - (unless recipients - (error "No recipient specified"))) - recipients)) - -(defun mml-secure-epg-encrypt (protocol cont &optional sign) - ;; Based on code appearing inside mml2015-epg-encrypt. - (let* ((context (epg-make-context protocol)) - (config (epg-configuration)) - (sender (message-options-get 'message-sender)) - (recipients (mml-secure-recipients protocol context config sender)) - (signer-names (mml-secure-signer-names protocol sender)) - cipher signers) - (when sign - (setq signers (mml-secure-signers context signer-names)) - (epg-context-set-signers context signers)) - (when (eq 'OpenPGP protocol) - (epg-context-set-armor context t) - (epg-context-set-textmode context t)) - (when (mml-secure-cache-passphrase-p protocol) - (epg-context-set-passphrase-callback - context - (cons 'mml-secure-passphrase-callback protocol))) - (condition-case error - (setq cipher - (if (eq 'OpenPGP protocol) - (epg-encrypt-string context (buffer-string) recipients sign - mml-secure-openpgp-always-trust) - (epg-encrypt-string context (buffer-string) recipients)) - mml-secure-secret-key-id-list nil) - (error - (mml-secure-clear-secret-key-id-list) - (signal (car error) (cdr error)))) - cipher)) - -(defun mml-secure-epg-sign (protocol mode) - ;; Based on code appearing inside mml2015-epg-sign. - (let* ((context (epg-make-context protocol)) - (sender (message-options-get 'message-sender)) - (signer-names (mml-secure-signer-names protocol sender)) - (signers (mml-secure-signers context signer-names)) - signature micalg) - (when (eq 'OpenPGP protocol) - (epg-context-set-armor context t) - (epg-context-set-textmode context t)) - (epg-context-set-signers context signers) - (when (mml-secure-cache-passphrase-p protocol) - (epg-context-set-passphrase-callback - context - (cons 'mml-secure-passphrase-callback protocol))) - (condition-case error - (setq signature - (if (eq 'OpenPGP protocol) - (epg-sign-string context (buffer-string) mode) - (epg-sign-string context - (mm-replace-in-string (buffer-string) - "\n" "\r\n") t)) - mml-secure-secret-key-id-list nil) - (error - (mml-secure-clear-secret-key-id-list) - (signal (car error) (cdr error)))) - (if (epg-context-result-for context 'sign) - (setq micalg (epg-new-signature-digest-algorithm - (car (epg-context-result-for context 'sign))))) - (cons signature micalg))) - (provide 'mml-sec) ;;; mml-sec.el ends here |