1;;; mml-sec.el --- A package with security functions for MML documents -*- lexical-binding: t; -*- 2 3;; Copyright (C) 2000-2021 Free Software Foundation, Inc. 4 5;; Author: Simon Josefsson <simon@josefsson.org> 6 7;; This file is part of GNU Emacs. 8 9;; GNU Emacs is free software: you can redistribute it and/or modify 10;; it under the terms of the GNU General Public License as published by 11;; the Free Software Foundation, either version 3 of the License, or 12;; (at your option) any later version. 13 14;; GNU Emacs is distributed in the hope that it will be useful, 15;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17;; GNU General Public License for more details. 18 19;; You should have received a copy of the GNU General Public License 20;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. 21 22;;; Commentary: 23 24;;; Code: 25 26(require 'cl-lib) 27 28(require 'gnus-util) 29(require 'epg) 30(require 'epa) 31(require 'password-cache) 32(require 'mm-encode) 33 34(autoload 'mail-strip-quoted-names "mail-utils") 35(autoload 'mml2015-sign "mml2015") 36(autoload 'mml2015-encrypt "mml2015") 37(autoload 'mml1991-sign "mml1991") 38(autoload 'mml1991-encrypt "mml1991") 39(autoload 'message-fetch-field "message") 40(autoload 'message-goto-body "message") 41(autoload 'message-options-get "message") 42(autoload 'mml-insert-tag "mml") 43(autoload 'mml-smime-sign "mml-smime") 44(autoload 'mml-smime-encrypt "mml-smime") 45(autoload 'mml-smime-sign-query "mml-smime") 46(autoload 'mml-smime-encrypt-query "mml-smime") 47(autoload 'mml-smime-verify "mml-smime") 48(autoload 'mml-smime-verify-test "mml-smime") 49(autoload 'epa--select-keys "epa") 50(autoload 'message-options-get "message") 51(autoload 'message-options-set "message") 52 53(declare-function message-options-set "message" (symbol value)) 54 55(defvar mml-sign-alist 56 '(("smime" mml-smime-sign-buffer mml-smime-sign-query) 57 ("pgp" mml-pgp-sign-buffer list) 58 ("pgpauto" mml-pgpauto-sign-buffer list) 59 ("pgpmime" mml-pgpmime-sign-buffer list)) 60 "Alist of MIME signer functions.") 61 62(defcustom mml-default-sign-method "pgpmime" 63 "Default sign method. 64The string must have an entry in `mml-sign-alist'." 65 :version "22.1" 66 :type '(choice (const "smime") 67 (const "pgp") 68 (const "pgpauto") 69 (const "pgpmime") 70 string) 71 :group 'message) 72 73(defvar mml-encrypt-alist 74 '(("smime" mml-smime-encrypt-buffer mml-smime-encrypt-query) 75 ("pgp" mml-pgp-encrypt-buffer list) 76 ("pgpauto" mml-pgpauto-sign-buffer list) 77 ("pgpmime" mml-pgpmime-encrypt-buffer list)) 78 "Alist of MIME encryption functions.") 79 80(defcustom mml-default-encrypt-method "pgpmime" 81 "Default encryption method. 82The string must have an entry in `mml-encrypt-alist'." 83 :version "22.1" 84 :type '(choice (const "smime") 85 (const "pgp") 86 (const "pgpauto") 87 (const "pgpmime") 88 string) 89 :group 'message) 90 91(defcustom mml-signencrypt-style-alist 92 '(("smime" separate) 93 ("pgp" combined) 94 ("pgpauto" combined) 95 ("pgpmime" combined)) 96 "Alist specifying if `signencrypt' results in two separate operations or not. 97The first entry indicates the MML security type, valid entries include 98the strings \"smime\", \"pgp\", and \"pgpmime\". The second entry is 99a symbol `separate' or `combined' where `separate' means that MML signs 100and encrypt messages in a two step process, and `combined' means that MML 101signs and encrypt the message in one step. 102 103Note that the output generated by using a `combined' mode is NOT 104understood by all PGP implementations, in particular PGP version 1052 does not support it! See Info node `(message) Security' for 106details." 107 :version "22.1" 108 :group 'message 109 :type '(repeat (list (choice (const :tag "S/MIME" "smime") 110 (const :tag "PGP" "pgp") 111 (const :tag "PGP/MIME" "pgpmime") 112 (string :tag "User defined")) 113 (choice (const :tag "Separate" separate) 114 (const :tag "Combined" combined))))) 115 116(defcustom mml-secure-verbose nil 117 "If non-nil, ask the user about the current operation more verbosely." 118 :group 'message 119 :type 'boolean) 120 121;; FIXME If it's "NOT recommended", why is it the default? 122(defcustom mml-secure-cache-passphrase password-cache 123 "If t, cache OpenPGP or S/MIME passphrases inside Emacs. 124Passphrase caching in Emacs is NOT recommended. Use gpg-agent instead. 125See Info node `(message) Security'." 126 :group 'message 127 :type 'boolean) 128 129(defcustom mml-secure-passphrase-cache-expiry password-cache-expiry 130 "How many seconds the passphrase is cached. 131Whether the passphrase is cached at all is controlled by 132`mml-secure-cache-passphrase'." 133 :group 'message 134 :type 'integer) 135 136(defcustom mml-secure-safe-bcc-list nil 137 "List of e-mail addresses that are safe to use in Bcc headers. 138EasyPG encrypts e-mails to Bcc addresses, and the encrypted e-mail 139by default identifies the used encryption keys, giving away the 140Bcc'ed identities. Clearly, this contradicts the original goal of 141*blind* copies. 142For an academic paper explaining the problem, see URL 143`https://crypto.stanford.edu/portia/papers/bb-bcc.pdf'. 144Use this variable to specify e-mail addresses whose owners do not 145mind if they are identifiable as recipients. This may be useful if 146you use Bcc headers to encrypt e-mails to yourself." 147 :version "25.1" 148 :group 'message 149 :type '(repeat string)) 150 151;;; Configuration/helper functions 152 153(defun mml-signencrypt-style (method &optional style) 154 "Function for setting/getting the signencrypt-style used. Takes two 155arguments, the method (e.g. \"pgp\") and optionally the mode 156\(e.g. combined). If the mode is omitted, the current value is returned. 157 158For example, if you prefer to use combined sign & encrypt with 159smime, putting the following in your Gnus startup file will 160enable that behavior: 161 162\(mml-set-signencrypt-style \"smime\" combined) 163 164You can also customize or set `mml-signencrypt-style-alist' instead." 165 (let ((style-item (assoc method mml-signencrypt-style-alist))) 166 (if style-item 167 (if (or (eq style 'separate) 168 (eq style 'combined)) 169 ;; valid style setting? 170 (setf (cadr style-item) style) 171 ;; otherwise, just return the current value 172 (cadr style-item)) 173 (message "Warning, attempt to set invalid signencrypt style")))) 174 175;;; Security functions 176 177(defun mml-smime-sign-buffer (cont) 178 (or (mml-smime-sign cont) 179 (error "Signing failed... inspect message logs for errors"))) 180 181(defun mml-smime-encrypt-buffer (cont &optional sign) 182 (when sign 183 (message "Combined sign and encrypt S/MIME not support yet") 184 (sit-for 1)) 185 (or (mml-smime-encrypt cont) 186 (error "Encryption failed... inspect message logs for errors"))) 187 188(defun mml-pgp-sign-buffer (cont) 189 (or (mml1991-sign cont) 190 (error "Signing failed... inspect message logs for errors"))) 191 192(defun mml-pgp-encrypt-buffer (cont &optional sign) 193 (or (mml1991-encrypt cont sign) 194 (error "Encryption failed... inspect message logs for errors"))) 195 196(defun mml-pgpmime-sign-buffer (cont) 197 (or (mml2015-sign cont) 198 (error "Signing failed... inspect message logs for errors"))) 199 200(defun mml-pgpmime-encrypt-buffer (cont &optional sign) 201 (or (mml2015-encrypt cont sign) 202 (error "Encryption failed... inspect message logs for errors"))) 203 204(defun mml-pgpauto-sign-buffer (cont) 205 (message-goto-body) 206 (or (if (re-search-backward "Content-Type: *multipart/.*" nil t) ; there must be a better way... 207 (mml2015-sign cont) 208 (mml1991-sign cont)) 209 (error "Encryption failed... inspect message logs for errors"))) 210 211(defun mml-pgpauto-encrypt-buffer (cont &optional sign) 212 (message-goto-body) 213 (or (if (re-search-backward "Content-Type: *multipart/.*" nil t) ; there must be a better way... 214 (mml2015-encrypt cont sign) 215 (mml1991-encrypt cont sign)) 216 (error "Encryption failed... inspect message logs for errors"))) 217 218(defun mml-secure-part (method &optional sign) 219 (save-excursion 220 (let ((tags (funcall (nth 2 (assoc method (if sign mml-sign-alist 221 mml-encrypt-alist)))))) 222 (cond ((re-search-backward 223 "<#\\(multipart\\|part\\|external\\|mml\\)" nil t) 224 (goto-char (match-end 0)) 225 (insert (if sign " sign=" " encrypt=") method) 226 (while tags 227 (let ((key (pop tags)) 228 (value (pop tags))) 229 (when value 230 ;; Quote VALUE if it contains suspicious characters. 231 (when (string-match "[\"'\\~/*;() \t\n]" value) 232 (setq value (prin1-to-string value))) 233 (insert (format " %s=%s" key value)))))) 234 ((or (re-search-backward 235 (concat "^" (regexp-quote mail-header-separator) "\n") nil t) 236 (re-search-forward 237 (concat "^" (regexp-quote mail-header-separator) "\n") nil t)) 238 (goto-char (match-end 0)) 239 (apply #'mml-insert-tag 'part (cons (if sign 'sign 'encrypt) 240 (cons method tags)))) 241 (t (error "The message is corrupted. No mail header separator")))))) 242 243(defvar mml-secure-method 244 (if (equal mml-default-encrypt-method mml-default-sign-method) 245 mml-default-sign-method 246 "pgpmime") 247 "Current security method. Internal variable.") 248 249(defun mml-secure-sign (&optional method) 250 "Add MML tags to sign this MML part. 251Use METHOD if given. Else use `mml-secure-method' or 252`mml-default-sign-method'." 253 (interactive nil mml-mode) 254 (mml-secure-part 255 (or method mml-secure-method mml-default-sign-method) 256 'sign)) 257 258(defun mml-secure-encrypt (&optional method) 259 "Add MML tags to encrypt this MML part. 260Use METHOD if given. Else use `mml-secure-method' or 261`mml-default-sign-method'." 262 (interactive nil mml-mode) 263 (mml-secure-part 264 (or method mml-secure-method mml-default-sign-method))) 265 266(defun mml-secure-sign-pgp () 267 "Add MML tags to PGP sign this MML part." 268 (interactive nil mml-mode) 269 (mml-secure-part "pgp" 'sign)) 270 271(defun mml-secure-sign-pgpauto () 272 "Add MML tags to PGP-auto sign this MML part." 273 (interactive nil mml-mode) 274 (mml-secure-part "pgpauto" 'sign)) 275 276(defun mml-secure-sign-pgpmime () 277 "Add MML tags to PGP/MIME sign this MML part." 278 (interactive nil mml-mode) 279 (mml-secure-part "pgpmime" 'sign)) 280 281(defun mml-secure-sign-smime () 282 "Add MML tags to S/MIME sign this MML part." 283 (interactive nil mml-mode) 284 (mml-secure-part "smime" 'sign)) 285 286(defun mml-secure-encrypt-pgp () 287 "Add MML tags to PGP encrypt this MML part." 288 (interactive nil mml-mode) 289 (mml-secure-part "pgp")) 290 291(defun mml-secure-encrypt-pgpmime () 292 "Add MML tags to PGP/MIME encrypt this MML part." 293 (interactive nil mml-mode) 294 (mml-secure-part "pgpmime")) 295 296(defun mml-secure-encrypt-smime () 297 "Add MML tags to S/MIME encrypt this MML part." 298 (interactive nil mml-mode) 299 (mml-secure-part "smime")) 300 301(defun mml-secure-is-encrypted-p (&optional tag-present) 302 "Whether the current buffer contains a mail message that should be encrypted. 303If TAG-PRESENT, say whether the <#secure tag is present anywhere 304in the buffer." 305 (save-excursion 306 (goto-char (point-min)) 307 (message-goto-body) 308 (if tag-present 309 (re-search-forward "<#secure[^>]+encrypt" nil t) 310 (skip-chars-forward "[ \t\n") 311 (looking-at "<#secure[^>]+encrypt")))) 312 313(defun mml-secure-bcc-is-safe () 314 "Check whether usage of Bcc is safe (or absent). 315Bcc usage is safe in two cases: first, if the current message does 316not contain an MML secure encrypt tag; 317second, if the Bcc addresses are a subset of `mml-secure-safe-bcc-list'. 318In all other cases, ask the user whether Bcc usage is safe. 319Raise error if user answers no. 320Note that this function does not produce a meaningful return value: 321either an error is raised or not." 322 (when (mml-secure-is-encrypted-p) 323 (let ((bcc (mail-strip-quoted-names (message-fetch-field "bcc")))) 324 (when bcc 325 (let ((bcc-list (mapcar #'cadr 326 (mail-extract-address-components bcc t)))) 327 (unless (gnus-subsetp bcc-list mml-secure-safe-bcc-list) 328 (unless (yes-or-no-p "Message for encryption contains Bcc header.\ 329 This may give away all Bcc'ed identities to all recipients.\ 330 Are you sure that this is safe?\ 331 (Customize `mml-secure-safe-bcc-list' to avoid this warning.)") 332 (error "Aborted")))))))) 333 334;; defuns that add the proper <#secure ...> tag to the top of the message body 335(defun mml-secure-message (method &optional modesym) 336 (let ((mode (prin1-to-string modesym)) 337 (tags (append 338 (if (or (eq modesym 'sign) 339 (eq modesym 'signencrypt)) 340 (funcall (nth 2 (assoc method mml-sign-alist)))) 341 (if (or (eq modesym 'encrypt) 342 (eq modesym 'signencrypt)) 343 (funcall (nth 2 (assoc method mml-encrypt-alist)))))) 344 insert-loc) 345 (mml-unsecure-message) 346 (save-excursion 347 (goto-char (point-min)) 348 (cond ((re-search-forward 349 (concat "^" (regexp-quote mail-header-separator) "\n") nil t) 350 (goto-char (setq insert-loc (match-end 0))) 351 (unless (looking-at "<#secure") 352 (apply #'mml-insert-tag 353 'secure 'method method 'mode mode tags))) 354 (t (error 355 "The message is corrupted. No mail header separator")))) 356 (when (eql insert-loc (point)) 357 (forward-line 1)))) 358 359(defun mml-unsecure-message () 360 "Remove security related MML tags from message." 361 (interactive nil mml-mode) 362 (save-excursion 363 (goto-char (point-max)) 364 (when (re-search-backward "^<#secure.*>\n" nil t) 365 (delete-region (match-beginning 0) (match-end 0))))) 366 367 368(defun mml-secure-message-sign (&optional method) 369 "Add MML tags to sign the entire message. 370Use METHOD if given. Else use `mml-secure-method' or 371`mml-default-sign-method'." 372 (interactive nil mml-mode) 373 (mml-secure-message 374 (or method mml-secure-method mml-default-sign-method) 375 'sign)) 376 377(defun mml-secure-message-sign-encrypt (&optional method) 378 "Add MML tag to sign and encrypt the entire message. 379Use METHOD if given. Else use `mml-secure-method' or 380`mml-default-sign-method'." 381 (interactive nil mml-mode) 382 (mml-secure-message 383 (or method mml-secure-method mml-default-sign-method) 384 'signencrypt)) 385 386(defun mml-secure-message-encrypt (&optional method) 387 "Add MML tag to encrypt the entire message. 388Use METHOD if given. Else use `mml-secure-method' or 389`mml-default-sign-method'." 390 (interactive nil mml-mode) 391 (mml-secure-message 392 (or method mml-secure-method mml-default-sign-method) 393 'encrypt)) 394 395(defun mml-secure-message-sign-smime () 396 "Add MML tag to encrypt/sign the entire message." 397 (interactive nil mml-mode) 398 (mml-secure-message "smime" 'sign)) 399 400(defun mml-secure-message-sign-pgp () 401 "Add MML tag to encrypt/sign the entire message." 402 (interactive nil mml-mode) 403 (mml-secure-message "pgp" 'sign)) 404 405(defun mml-secure-message-sign-pgpmime () 406 "Add MML tag to encrypt/sign the entire message." 407 (interactive nil mml-mode) 408 (mml-secure-message "pgpmime" 'sign)) 409 410(defun mml-secure-message-sign-pgpauto () 411 "Add MML tag to encrypt/sign the entire message." 412 (interactive nil mml-mode) 413 (mml-secure-message "pgpauto" 'sign)) 414 415(defun mml-secure-message-encrypt-smime (&optional dontsign) 416 "Add MML tag to encrypt and sign the entire message. 417If called with a prefix argument, only encrypt (do NOT sign)." 418 (interactive "P" mml-mode) 419 (mml-secure-message "smime" (if dontsign 'encrypt 'signencrypt))) 420 421(defun mml-secure-message-encrypt-pgp (&optional dontsign) 422 "Add MML tag to encrypt and sign the entire message. 423If called with a prefix argument, only encrypt (do NOT sign)." 424 (interactive "P" mml-mode) 425 (mml-secure-message "pgp" (if dontsign 'encrypt 'signencrypt))) 426 427(defun mml-secure-message-encrypt-pgpmime (&optional dontsign) 428 "Add MML tag to encrypt and sign the entire message. 429If called with a prefix argument, only encrypt (do NOT sign)." 430 (interactive "P" mml-mode) 431 (mml-secure-message "pgpmime" (if dontsign 'encrypt 'signencrypt))) 432 433(defun mml-secure-message-encrypt-pgpauto (&optional dontsign) 434 "Add MML tag to encrypt and sign the entire message. 435If called with a prefix argument, only encrypt (do NOT sign)." 436 (interactive "P" mml-mode) 437 (mml-secure-message "pgpauto" (if dontsign 'encrypt 'signencrypt))) 438 439;;; Common functionality for mml1991.el, mml2015.el, mml-smime.el 440 441(define-obsolete-variable-alias 'mml1991-signers 'mml-secure-openpgp-signers 442 "25.1") 443(define-obsolete-variable-alias 'mml2015-signers 'mml-secure-openpgp-signers 444 "25.1") 445(defcustom mml-secure-openpgp-signers nil 446 "A list of your own key ID(s) which will be used to sign OpenPGP messages. 447If set, it is added to the setting of `mml-secure-openpgp-sign-with-sender'." 448 :group 'mime-security 449 :type '(repeat (string :tag "Key ID"))) 450 451(define-obsolete-variable-alias 'mml-smime-signers 'mml-secure-smime-signers 452 "25.1") 453(defcustom mml-secure-smime-signers nil 454 "A list of your own key ID(s) which will be used to sign S/MIME messages. 455If set, it is added to the setting of `mml-secure-smime-sign-with-sender'." 456 :group 'mime-security 457 :type '(repeat (string :tag "Key ID"))) 458 459(define-obsolete-variable-alias 460 'mml1991-encrypt-to-self 'mml-secure-openpgp-encrypt-to-self "25.1") 461(define-obsolete-variable-alias 462 'mml2015-encrypt-to-self 'mml-secure-openpgp-encrypt-to-self "25.1") 463(defcustom mml-secure-openpgp-encrypt-to-self nil 464 "List of own key ID(s) or t; determines additional recipients with OpenPGP. 465If t, also encrypt to key for message sender; if list, encrypt to those keys. 466With this variable, you can ensure that you can decrypt your own messages. 467Alternatives to this variable include Bcc'ing the message to yourself or 468using the encrypt-to or hidden-encrypt-to option in gpg.conf (see man gpg(1)). 469Note that this variable and the encrypt-to option give away your identity 470for *every* encryption without warning, which is not what you want if you are 471using, e.g., remailers. 472Also, use of Bcc gives away your identity for *every* encryption without 473warning, which is a bug, see: 474https://debbugs.gnu.org/cgi/bugreport.cgi?bug=18718" 475 :group 'mime-security 476 :type '(choice (const :tag "None" nil) 477 (const :tag "From address" t) 478 (repeat (string :tag "Key ID")))) 479 480(define-obsolete-variable-alias 481 'mml-smime-encrypt-to-self 'mml-secure-smime-encrypt-to-self "25.1") 482(defcustom mml-secure-smime-encrypt-to-self nil 483 "List of own key ID(s) or t; determines additional recipients with S/MIME. 484If t, also encrypt to key for message sender; if list, encrypt to those keys. 485With this variable, you can ensure that you can decrypt your own messages. 486Alternatives to this variable include Bcc'ing the message to yourself or 487using the encrypt-to option in gpgsm.conf (see man gpgsm(1)). 488Note that this variable and the encrypt-to option give away your identity 489for *every* encryption without warning, which is not what you want if you are 490using, e.g., remailers. 491Also, use of Bcc gives away your identity for *every* encryption without 492warning, which is a bug, see: 493https://debbugs.gnu.org/cgi/bugreport.cgi?bug=18718" 494 :group 'mime-security 495 :type '(choice (const :tag "None" nil) 496 (const :tag "From address" t) 497 (repeat (string :tag "Key ID")))) 498 499(define-obsolete-variable-alias 500 'mml2015-sign-with-sender 'mml-secure-openpgp-sign-with-sender "25.1") 501;mml1991-sign-with-sender did never exist. 502(defcustom mml-secure-openpgp-sign-with-sender nil 503 "If t, use message sender to find an OpenPGP key to sign with. 504Also use message's sender with GnuPG's --sender option." 505 :group 'mime-security 506 :type 'boolean) 507 508(define-obsolete-variable-alias 509 'mml-smime-sign-with-sender 'mml-secure-smime-sign-with-sender "25.1") 510(defcustom mml-secure-smime-sign-with-sender nil 511 "If t, use message sender to find an S/MIME key to sign with." 512 :group 'mime-security 513 :type 'boolean) 514 515(define-obsolete-variable-alias 516 'mml2015-always-trust 'mml-secure-openpgp-always-trust "25.1") 517;mml1991-always-trust did never exist. 518(defcustom mml-secure-openpgp-always-trust t 519 "If t, skip key validation of GnuPG on encryption." 520 :group 'mime-security 521 :type 'boolean) 522 523(defcustom mml-secure-fail-when-key-problem nil 524 "If t, raise an error if some key is missing or several keys exist. 525Otherwise, ask the user." 526 :version "25.1" 527 :group 'mime-security 528 :type 'boolean) 529 530(defcustom mml-secure-key-preferences 531 '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))) 532 "Protocol- and usage-specific fingerprints of preferred keys. 533This variable is only relevant if a recipient owns multiple key pairs (for 534encryption) or you own multiple key pairs (for signing). In such cases, 535you will be asked which key(s) should be used, and your choice can be 536customized in this variable." 537 :version "25.1" 538 :group 'mime-security 539 :type '(alist :key-type (symbol :tag "Protocol") :value-type 540 (alist :key-type (symbol :tag "Usage") :value-type 541 (alist :key-type (string :tag "Name") :value-type 542 (repeat (string :tag "Fingerprint")))))) 543 544(defun mml-secure-cust-usage-lookup (context usage) 545 "Return preferences for CONTEXT and USAGE." 546 (let* ((protocol (epg-context-protocol context)) 547 (protocol-prefs (cdr (assoc protocol mml-secure-key-preferences)))) 548 (assoc usage protocol-prefs))) 549 550(defun mml-secure-cust-fpr-lookup (context usage name) 551 "Return fingerprints of preferred keys for CONTEXT, USAGE, and NAME." 552 (let* ((usage-prefs (mml-secure-cust-usage-lookup context usage)) 553 (fprs (assoc name (cdr usage-prefs)))) 554 (when fprs 555 (cdr fprs)))) 556 557(defun mml-secure-cust-record-keys (context usage name keys &optional save) 558 "For CONTEXT, USAGE, and NAME record fingerprint(s) of KEYS. 559If optional SAVE is not nil, save customized fingerprints. 560Return keys." 561 (cl-assert keys) 562 (let* ((usage-prefs (mml-secure-cust-usage-lookup context usage)) 563 (curr-fprs (cdr (assoc name (cdr usage-prefs)))) 564 (key-fprs (mapcar #'mml-secure-fingerprint keys)) 565 (new-fprs (cl-union curr-fprs key-fprs :test 'equal))) 566 (if curr-fprs 567 (setcdr (assoc name (cdr usage-prefs)) new-fprs) 568 (setcdr usage-prefs (cons (cons name new-fprs) (cdr usage-prefs)))) 569 (when save 570 (customize-save-variable 571 'mml-secure-key-preferences mml-secure-key-preferences)) 572 keys)) 573 574(defun mml-secure-cust-remove-keys (context usage name) 575 "Remove keys for CONTEXT, USAGE, and NAME. 576Return t if a customization for NAME was present (and has been removed)." 577 (let* ((usage-prefs (mml-secure-cust-usage-lookup context usage)) 578 (current (assoc name usage-prefs))) 579 (when current 580 (setcdr usage-prefs (remove current (cdr usage-prefs))) 581 t))) 582 583(defvar mml-secure-secret-key-id-list nil) 584 585(defun mml-secure-add-secret-key-id (key-id) 586 "Record KEY-ID in list of secret keys." 587 (add-to-list 'mml-secure-secret-key-id-list key-id)) 588 589(defun mml-secure-clear-secret-key-id-list () 590 "Remove passwords from cache and clear list of secret keys." 591 ;; Loosely based on code inside mml2015-epg-encrypt, 592 ;; mml2015-epg-clear-decrypt, and mml2015-epg-decrypt 593 (dolist (key-id mml-secure-secret-key-id-list nil) 594 (password-cache-remove key-id)) 595 (setq mml-secure-secret-key-id-list nil)) 596 597(defvar mml1991-cache-passphrase) 598(defvar mml1991-passphrase-cache-expiry) 599 600(defun mml-secure-cache-passphrase-p (protocol) 601 "Return t if OpenPGP or S/MIME passphrases should be cached for PROTOCOL. 602Passphrase caching in Emacs is NOT recommended. Use gpg-agent instead." 603 (or (and (eq 'OpenPGP protocol) 604 (or mml-secure-cache-passphrase 605 (and (boundp 'mml2015-cache-passphrase) 606 mml2015-cache-passphrase) 607 (and (boundp 'mml1991-cache-passphrase) 608 mml1991-cache-passphrase))) 609 (and (eq 'CMS protocol) 610 (or mml-secure-cache-passphrase 611 (and (boundp 'mml-smime-cache-passphrase) 612 mml-smime-cache-passphrase))))) 613 614(defun mml-secure-cache-expiry-interval (protocol) 615 "Return time in seconds to cache passphrases for PROTOCOL. 616Passphrase caching in Emacs is NOT recommended. Use gpg-agent instead." 617 (or (and (eq 'OpenPGP protocol) 618 (or (and (boundp 'mml2015-passphrase-cache-expiry) 619 mml2015-passphrase-cache-expiry) 620 (and (boundp 'mml1991-passphrase-cache-expiry) 621 mml1991-passphrase-cache-expiry) 622 mml-secure-passphrase-cache-expiry)) 623 (and (eq 'CMS protocol) 624 (or (and (boundp 'mml-smime-passphrase-cache-expiry) 625 mml-smime-passphrase-cache-expiry) 626 mml-secure-passphrase-cache-expiry)))) 627 628(defun mml-secure-passphrase-callback (context key-id _standard) 629 "Ask for passphrase in CONTEXT for KEY-ID for STANDARD. 630The passphrase is read and cached." 631 ;; Based on mml2015-epg-passphrase-callback. 632 (if (eq key-id 'SYM) 633 (epa-passphrase-callback-function context key-id nil) 634 (let* ((password-cache-key-id 635 (if (eq key-id 'PIN) 636 "PIN" 637 key-id)) 638 (entry (assoc key-id epg-user-id-alist)) 639 (passphrase 640 (password-read 641 (if (eq key-id 'PIN) 642 "Passphrase for PIN: " 643 (if entry 644 (format "Passphrase for %s %s: " key-id (cdr entry)) 645 (format "Passphrase for %s: " key-id))) 646 ;; TODO: With mml-smime.el, password-cache-key-id is not passed 647 ;; as argument to password-read. 648 ;; Is that on purpose? If so, the following needs to be placed 649 ;; inside an if statement. 650 password-cache-key-id))) 651 (when passphrase 652 (let ((password-cache-expiry (mml-secure-cache-expiry-interval 653 (epg-context-protocol context)))) 654 ;; FIXME test passphrase works before caching it. 655 (password-cache-add password-cache-key-id passphrase)) 656 (mml-secure-add-secret-key-id password-cache-key-id) 657 (copy-sequence passphrase))))) 658 659(defun mml-secure-check-user-id (key recipient) 660 "Check whether KEY has a non-revoked, non-expired UID for RECIPIENT." 661 ;; Based on mml2015-epg-check-user-id. 662 (let ((uids (epg-key-user-id-list key))) 663 (catch 'break 664 (dolist (uid uids nil) 665 (if (and (stringp (epg-user-id-string uid)) 666 (car (ignore-errors 667 (mail-header-parse-address 668 (epg-user-id-string uid)))) 669 (equal (downcase (car (mail-header-parse-address 670 (epg-user-id-string uid)))) 671 (downcase (or (car (mail-header-parse-address 672 recipient)) 673 recipient))) 674 (not (memq (epg-user-id-validity uid) 675 '(revoked expired)))) 676 (throw 'break t)))))) 677 678(defun mml-secure-secret-key-exists-p (context subkey) 679 "Return t if keyring for CONTEXT contains secret key for public SUBKEY." 680 (let* ((fpr (epg-sub-key-fingerprint subkey)) 681 (candidates (epg-list-keys context fpr 'secret)) 682 (candno (length candidates))) 683 ;; If two or more subkeys with the same fingerprint exist, something is 684 ;; terribly wrong. 685 (when (>= candno 2) 686 (error "Found %d secret keys with same fingerprint %s" candno fpr)) 687 (= 1 candno))) 688 689(defun mml-secure-check-sub-key (context key usage &optional fingerprint) 690 "Check whether in CONTEXT the public KEY has a usable subkey for USAGE. 691This is the case if KEY is not disabled, and there is a subkey for 692USAGE that is neither revoked nor expired. Additionally, if optional 693FINGERPRINT is present and if it is not the primary key's fingerprint, then 694the returned subkey must have that FINGERPRINT. FINGERPRINT must consist of 695hexadecimal digits only (no leading \"0x\" allowed). 696If USAGE is not `encrypt', then additionally an appropriate secret key must 697be present in the keyring." 698 ;; Based on mml2015-epg-check-sub-key, extended by 699 ;; - check for secret keys if usage is not 'encrypt and 700 ;; - check for new argument FINGERPRINT. 701 (let* ((subkeys (epg-key-sub-key-list key)) 702 (primary (car subkeys)) 703 (fpr (epg-sub-key-fingerprint primary))) 704 ;; The primary key will be marked as disabled, when the entire 705 ;; key is disabled (see 12 Field, Format of colon listings, in 706 ;; gnupg/doc/DETAILS) 707 (unless (memq 'disabled (epg-sub-key-capability primary)) 708 (catch 'break 709 (dolist (subkey subkeys nil) 710 (if (and (memq usage (epg-sub-key-capability subkey)) 711 (not (memq (epg-sub-key-validity subkey) 712 '(revoked expired))) 713 (or (eq 'encrypt usage) ; Encryption works with public key. 714 ;; In contrast, signing requires secret key. 715 (mml-secure-secret-key-exists-p context subkey)) 716 (or (not fingerprint) 717 (string-match-p (concat fingerprint "$") fpr) 718 (string-match-p (concat fingerprint "$") 719 (epg-sub-key-fingerprint subkey)))) 720 (throw 'break t))))))) 721 722(defun mml-secure-find-usable-keys (context name usage &optional justone) 723 "In CONTEXT return a list of keys for NAME and USAGE. 724If USAGE is `encrypt' public keys are returned, otherwise secret ones. 725Only non-revoked and non-expired keys are returned whose primary key is 726not disabled. 727NAME can be an e-mail address or a key ID. 728If NAME just consists of hexadecimal digits (possibly prefixed by \"0x\"), it 729is treated as key ID for which at most one key must exist in the keyring. 730Otherwise, NAME is treated as user ID, for which no keys are returned if it 731is expired or revoked. 732If optional JUSTONE is not nil, return the first key instead of a list." 733 (let* ((keys (epg-list-keys context name)) 734 (iskeyid (string-match "\\(0x\\)?\\([[:xdigit:]]\\{8,\\}\\)" name)) 735 (fingerprint (match-string 2 name)) 736 result) 737 (when (and iskeyid (>= (length keys) 2)) 738 (error 739 "Name %s (for %s) looks like a key ID but multiple keys found" 740 name usage)) 741 (catch 'break 742 (dolist (key keys result) 743 (if (and (or iskeyid 744 (mml-secure-check-user-id key name)) 745 (mml-secure-check-sub-key context key usage fingerprint)) 746 (if justone 747 (throw 'break key) 748 (push key result))))))) 749 750(defun mml-secure-select-preferred-keys (context names usage) 751 "Return list of preferred keys in CONTEXT for NAMES and USAGE. 752This inspects the keyrings to find keys for each name in NAMES. If several 753keys are found for a name, `mml-secure-select-keys' is used to look for 754customized preferences or have the user select preferable ones. 755When `mml-secure-fail-when-key-problem' is t, fail with an error in 756case of missing, outdated, or multiple keys." 757 ;; Loosely based on code appearing inside mml2015-epg-sign and 758 ;; mml2015-epg-encrypt. 759 (apply 760 #'nconc 761 (mapcar 762 (lambda (name) 763 (let* ((keys (mml-secure-find-usable-keys context name usage)) 764 (keyno (length keys))) 765 (cond ((= 0 keyno) 766 (when (or mml-secure-fail-when-key-problem 767 (not (y-or-n-p 768 (format "No %s key for %s; skip it? " 769 usage name)))) 770 (error "No %s key for %s" usage name))) 771 ((= 1 keyno) keys) 772 (t (mml-secure-select-keys context name keys usage))))) 773 names))) 774 775(defun mml-secure-fingerprint (key) 776 "Return fingerprint for public KEY." 777 (epg-sub-key-fingerprint (car (epg-key-sub-key-list key)))) 778 779(defun mml-secure-filter-keys (keys fprs) 780 "Filter KEYS to subset with fingerprints in FPRS." 781 (when keys 782 (if (member (mml-secure-fingerprint (car keys)) fprs) 783 (cons (car keys) (mml-secure-filter-keys (cdr keys) fprs)) 784 (mml-secure-filter-keys (cdr keys) fprs)))) 785 786(defun mml-secure-normalize-cust-name (name) 787 "Normalize NAME to be used for customization. 788Currently, remove ankle brackets." 789 (if (string-match "^<\\(.*\\)>$" name) 790 (match-string 1 name) 791 name)) 792 793(defun mml-secure-select-keys (context name keys usage) 794 "In CONTEXT for NAME select among KEYS for USAGE. 795KEYS should be a list with multiple entries. 796NAME is normalized first as customized keys are inspected. 797When `mml-secure-fail-when-key-problem' is t, fail with an error in case of 798outdated or multiple keys." 799 (let* ((nname (mml-secure-normalize-cust-name name)) 800 (fprs (mml-secure-cust-fpr-lookup context usage nname)) 801 (usable-fprs (mapcar #'mml-secure-fingerprint keys))) 802 (if fprs 803 (if (gnus-subsetp fprs usable-fprs) 804 (mml-secure-filter-keys keys fprs) 805 (mml-secure-cust-remove-keys context usage nname) 806 (let ((diff (gnus-setdiff fprs usable-fprs))) 807 (if mml-secure-fail-when-key-problem 808 (error "Customization of %s keys for %s outdated" usage nname) 809 (mml-secure-select-keys-1 810 context nname keys usage (format "\ 811Customized keys 812 (%s) 813for %s not available any more. 814Select anew. " 815 diff nname))))) 816 (if mml-secure-fail-when-key-problem 817 (error "Multiple %s keys for %s" usage nname) 818 (mml-secure-select-keys-1 819 context nname keys usage (format "\ 820Multiple %s keys for: 821 %s 822Select preferred one(s). " 823 usage nname)))))) 824 825(defun mml-secure-select-keys-1 (context name keys usage message) 826 "In CONTEXT for NAME let user select among KEYS for USAGE, showing MESSAGE. 827Return selected keys." 828 (let* ((selected (epa--select-keys message keys)) 829 (selno (length selected)) 830 ;; TODO: y-or-n-p does not always resize the echo area but may 831 ;; truncate the message. Why? The following does not help. 832 ;; yes-or-no-p shows full message, though. 833 (message-truncate-lines nil)) 834 (if selected 835 (if (y-or-n-p 836 (format "%d %s key(s) selected. Store for %s? " 837 selno usage name)) 838 (mml-secure-cust-record-keys context usage name selected 'save) 839 selected) 840 (unless (y-or-n-p 841 (format "No %s key for %s; skip it? " usage name)) 842 (error "No %s key for %s" usage name))))) 843 844(defun mml-secure-signer-names (protocol sender) 845 "Determine signer names for PROTOCOL and message from SENDER. 846Returned names may be e-mail addresses or key IDs and are determined based 847on `mml-secure-openpgp-signers' and `mml-secure-openpgp-sign-with-sender' with 848OpenPGP or `mml-secure-smime-signers' and `mml-secure-smime-sign-with-sender' 849with S/MIME." 850 (if (eq 'OpenPGP protocol) 851 (append mml-secure-openpgp-signers 852 (if (and mml-secure-openpgp-sign-with-sender sender) 853 (list (concat "<" sender ">")))) 854 (append mml-secure-smime-signers 855 (if (and mml-secure-smime-sign-with-sender sender) 856 (list (concat "<" sender ">")))))) 857 858(defun mml-secure-signers (context signer-names) 859 "Determine signing keys in CONTEXT from SIGNER-NAMES. 860If `mm-sign-option' is `guided', the user is asked to choose. 861Otherwise, `mml-secure-select-preferred-keys' is used." 862 ;; Based on code appearing inside mml2015-epg-sign and 863 ;; mml2015-epg-encrypt. 864 (if (eq mm-sign-option 'guided) 865 (epa-select-keys context "\ 866Select keys for signing. 867If no one is selected, default secret key is used. " 868 signer-names t) 869 (mml-secure-select-preferred-keys context signer-names 'sign))) 870 871(defun mml-secure-self-recipients (protocol sender) 872 "Determine additional recipients based on encrypt-to-self variables. 873PROTOCOL specifies OpenPGP or S/MIME for a message from SENDER." 874 (let ((encrypt-to-self 875 (if (eq 'OpenPGP protocol) 876 mml-secure-openpgp-encrypt-to-self 877 mml-secure-smime-encrypt-to-self))) 878 (when encrypt-to-self 879 (if (listp encrypt-to-self) 880 encrypt-to-self 881 (list sender))))) 882 883(defun mml-secure-recipients (protocol context config sender) 884 "Determine encryption recipients. 885PROTOCOL specifies OpenPGP or S/MIME with matching CONTEXT and CONFIG 886for a message from SENDER." 887 ;; Based on code appearing inside mml2015-epg-encrypt. 888 (let ((recipients 889 (apply #'nconc 890 (mapcar 891 (lambda (recipient) 892 (or (epg-expand-group config recipient) 893 (list (concat "<" recipient ">")))) 894 (split-string 895 (or (message-options-get 'message-recipients) 896 (message-options-set 'message-recipients 897 (read-string "Recipients: "))) 898 "[ \f\t\n\r\v,]+"))))) 899 (nconc recipients (mml-secure-self-recipients protocol sender)) 900 (if (eq mm-encrypt-option 'guided) 901 (setq recipients 902 (epa-select-keys context "\ 903Select recipients for encryption. 904If no one is selected, symmetric encryption will be performed. " 905 recipients)) 906 (setq recipients 907 (mml-secure-select-preferred-keys context recipients 'encrypt)) 908 (unless recipients 909 (error "No recipient specified"))) 910 recipients)) 911 912(defun mml-secure-epg-encrypt (protocol _cont &optional sign) 913 ;; Based on code appearing inside mml2015-epg-encrypt. 914 (let* ((context (epg-make-context protocol)) 915 (config (epg-find-configuration 'OpenPGP)) 916 (sender (message-options-get 'message-sender)) 917 (recipients (mml-secure-recipients protocol context config sender)) 918 (signer-names (mml-secure-signer-names protocol sender)) 919 cipher signers) 920 (when sign 921 (setq signers (mml-secure-signers context signer-names)) 922 (setf (epg-context-signers context) signers) 923 (when (and (eq 'OpenPGP protocol) mml-secure-openpgp-sign-with-sender) 924 (setf (epg-context-sender context) sender))) 925 (when (eq 'OpenPGP protocol) 926 (setf (epg-context-armor context) t) 927 (setf (epg-context-textmode context) t)) 928 (when (mml-secure-cache-passphrase-p protocol) 929 (epg-context-set-passphrase-callback 930 context 931 (cons 'mml-secure-passphrase-callback protocol))) 932 (condition-case error 933 (setq cipher 934 (if (eq 'OpenPGP protocol) 935 (epg-encrypt-string context (buffer-string) recipients sign 936 mml-secure-openpgp-always-trust) 937 (epg-encrypt-string context (buffer-string) recipients)) 938 mml-secure-secret-key-id-list nil) 939 (error 940 (mml-secure-clear-secret-key-id-list) 941 (signal (car error) (cdr error)))) 942 cipher)) 943 944(defun mml-secure-sender-sign-query (protocol sender) 945 "Query whether to use SENDER to sign when using PROTOCOL. 946PROTOCOL will be `OpenPGP' or `CMS' (smime). 947This can also save the resulting value of 948`mml-secure-smime-sign-with-sender' or 949`mml-secure-openpgp-sign-with-sender' via Customize. 950Returns non-nil if the user has chosen to use SENDER." 951 (let ((buffer (get-buffer-create "*MML sender signing options*")) 952 (options '((?a "always" "Sign using this sender now and sign with message sender in future.") 953 (?s "session only" "Sign using this sender now, and sign with message sender for this session only.") 954 (?n "no" "Do not sign this message (and error out)"))) 955 answer done val) 956 (save-window-excursion 957 (pop-to-buffer buffer) 958 (erase-buffer) 959 (insert (format "No %s signing key was found for this message.\nThe sender of this message is \"%s\".\nWould you like to attempt looking up a signing key based on it?" 960 (if (eq protocol 'OpenPGP) 961 "openpgp" "smime") 962 sender)) 963 (while (not done) 964 (setq answer (read-multiple-choice "Sign this message using the sender?" options)) 965 (cl-case (car answer) 966 (?a 967 (if (eq protocol 'OpenPGP) 968 (progn 969 (setq mml-secure-openpgp-sign-with-sender t) 970 (customize-save-variable 971 'mml-secure-openpgp-sign-with-sender t)) 972 (setq mml-secure-smime-sign-with-sender t) 973 (customize-save-variable 'mml-secure-smime-sign-with-sender t)) 974 (setq done t 975 val t)) 976 (?s 977 (if (eq protocol 'OpenPGP) 978 (setq mml-secure-openpgp-sign-with-sender t) 979 (setq mml-secure-smime-sign-with-sender t)) 980 (setq done t 981 val t)) 982 (?n 983 (setq done t))))) 984 val)) 985 986(defun mml-secure-epg-sign (protocol mode) 987 ;; Based on code appearing inside mml2015-epg-sign. 988 (let* ((context (epg-make-context protocol)) 989 (sender (message-options-get 'message-sender)) 990 (signer-names (mml-secure-signer-names protocol sender)) 991 (signers (mml-secure-signers context signer-names)) 992 signature micalg) 993 (unless signers 994 (if (and (not noninteractive) 995 (mml-secure-sender-sign-query protocol sender)) 996 (setq signer-names (mml-secure-signer-names protocol sender) 997 signers (mml-secure-signers context signer-names))) 998 (unless signers 999 (let ((maybe-msg 1000 (if (or mml-secure-smime-sign-with-sender 1001 mml-secure-openpgp-sign-with-sender) 1002 "." 1003 "; try setting `mml-secure-smime-sign-with-sender' or 'mml-secure-openpgp-sign-with-sender'."))) 1004 ;; If `mml-secure-smime-sign-with-sender' or 1005 ;; `mml-secure-openpgp-sign-with-sender' are already non-nil 1006 ;; then there's no point advising the user to examine them. 1007 ;; If there are any other variables worth examining, please 1008 ;; improve this error message by having it mention them. 1009 (error "Couldn't find any signer names%s" maybe-msg)))) 1010 (when (eq 'OpenPGP protocol) 1011 (setf (epg-context-armor context) t) 1012 (setf (epg-context-textmode context) t) 1013 (when mml-secure-openpgp-sign-with-sender 1014 (setf (epg-context-sender context) sender))) 1015 (setf (epg-context-signers context) signers) 1016 (when (mml-secure-cache-passphrase-p protocol) 1017 (epg-context-set-passphrase-callback 1018 context 1019 (cons 'mml-secure-passphrase-callback protocol))) 1020 (condition-case error 1021 (setq signature 1022 (if (eq 'OpenPGP protocol) 1023 (epg-sign-string context (buffer-string) mode) 1024 (epg-sign-string context 1025 (string-replace 1026 "\n" "\r\n" (buffer-string)) 1027 t)) 1028 mml-secure-secret-key-id-list nil) 1029 (error 1030 (mml-secure-clear-secret-key-id-list) 1031 (signal (car error) (cdr error)))) 1032 (if (epg-context-result-for context 'sign) 1033 (setq micalg (epg-new-signature-digest-algorithm 1034 (car (epg-context-result-for context 'sign))))) 1035 (cons signature micalg))) 1036 1037(provide 'mml-sec) 1038 1039;;; mml-sec.el ends here 1040