1;;; mml-sec.el --- A package with security functions for MML documents 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`http://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) 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) 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) 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) 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) 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) 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) 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) 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) 299 (mml-secure-part "smime")) 300 301(defun mml-secure-is-encrypted-p () 302 "Check whether secure encrypt tag is present." 303 (save-excursion 304 (goto-char (point-min)) 305 (re-search-forward 306 (concat "^" (regexp-quote mail-header-separator) "\n" 307 "<#secure[^>]+encrypt") 308 nil t))) 309 310(defun mml-secure-bcc-is-safe () 311 "Check whether usage of Bcc is safe (or absent). 312Bcc usage is safe in two cases: first, if the current message does 313not contain an MML secure encrypt tag; 314second, if the Bcc addresses are a subset of `mml-secure-safe-bcc-list'. 315In all other cases, ask the user whether Bcc usage is safe. 316Raise error if user answers no. 317Note that this function does not produce a meaningful return value: 318either an error is raised or not." 319 (when (mml-secure-is-encrypted-p) 320 (let ((bcc (mail-strip-quoted-names (message-fetch-field "bcc")))) 321 (when bcc 322 (let ((bcc-list (mapcar #'cadr 323 (mail-extract-address-components bcc t)))) 324 (unless (gnus-subsetp bcc-list mml-secure-safe-bcc-list) 325 (unless (yes-or-no-p "Message for encryption contains Bcc header.\ 326 This may give away all Bcc'ed identities to all recipients.\ 327 Are you sure that this is safe?\ 328 (Customize `mml-secure-safe-bcc-list' to avoid this warning.) ") 329 (error "Aborted")))))))) 330 331;; defuns that add the proper <#secure ...> tag to the top of the message body 332(defun mml-secure-message (method &optional modesym) 333 (let ((mode (prin1-to-string modesym)) 334 (tags (append 335 (if (or (eq modesym 'sign) 336 (eq modesym 'signencrypt)) 337 (funcall (nth 2 (assoc method mml-sign-alist)))) 338 (if (or (eq modesym 'encrypt) 339 (eq modesym 'signencrypt)) 340 (funcall (nth 2 (assoc method mml-encrypt-alist)))))) 341 insert-loc) 342 (mml-unsecure-message) 343 (save-excursion 344 (goto-char (point-min)) 345 (cond ((re-search-forward 346 (concat "^" (regexp-quote mail-header-separator) "\n") nil t) 347 (goto-char (setq insert-loc (match-end 0))) 348 (unless (looking-at "<#secure") 349 (apply 'mml-insert-tag 350 'secure 'method method 'mode mode tags))) 351 (t (error 352 "The message is corrupted. No mail header separator")))) 353 (when (eql insert-loc (point)) 354 (forward-line 1)))) 355 356(defun mml-unsecure-message () 357 "Remove security related MML tags from message." 358 (interactive) 359 (save-excursion 360 (goto-char (point-max)) 361 (when (re-search-backward "^<#secure.*>\n" nil t) 362 (delete-region (match-beginning 0) (match-end 0))))) 363 364 365(defun mml-secure-message-sign (&optional method) 366 "Add MML tags to sign the entire message. 367Use METHOD if given. Else use `mml-secure-method' or 368`mml-default-sign-method'." 369 (interactive) 370 (mml-secure-message 371 (or method mml-secure-method mml-default-sign-method) 372 'sign)) 373 374(defun mml-secure-message-sign-encrypt (&optional method) 375 "Add MML tag to sign and encrypt the entire message. 376Use METHOD if given. Else use `mml-secure-method' or 377`mml-default-sign-method'." 378 (interactive) 379 (mml-secure-message 380 (or method mml-secure-method mml-default-sign-method) 381 'signencrypt)) 382 383(defun mml-secure-message-encrypt (&optional method) 384 "Add MML tag to encrypt the entire message. 385Use METHOD if given. Else use `mml-secure-method' or 386`mml-default-sign-method'." 387 (interactive) 388 (mml-secure-message 389 (or method mml-secure-method mml-default-sign-method) 390 'encrypt)) 391 392(defun mml-secure-message-sign-smime () 393 "Add MML tag to encrypt/sign the entire message." 394 (interactive) 395 (mml-secure-message "smime" 'sign)) 396 397(defun mml-secure-message-sign-pgp () 398 "Add MML tag to encrypt/sign the entire message." 399 (interactive) 400 (mml-secure-message "pgp" 'sign)) 401 402(defun mml-secure-message-sign-pgpmime () 403 "Add MML tag to encrypt/sign the entire message." 404 (interactive) 405 (mml-secure-message "pgpmime" 'sign)) 406 407(defun mml-secure-message-sign-pgpauto () 408 "Add MML tag to encrypt/sign the entire message." 409 (interactive) 410 (mml-secure-message "pgpauto" 'sign)) 411 412(defun mml-secure-message-encrypt-smime (&optional dontsign) 413 "Add MML tag to encrypt and sign the entire message. 414If called with a prefix argument, only encrypt (do NOT sign)." 415 (interactive "P") 416 (mml-secure-message "smime" (if dontsign 'encrypt 'signencrypt))) 417 418(defun mml-secure-message-encrypt-pgp (&optional dontsign) 419 "Add MML tag to encrypt and sign the entire message. 420If called with a prefix argument, only encrypt (do NOT sign)." 421 (interactive "P") 422 (mml-secure-message "pgp" (if dontsign 'encrypt 'signencrypt))) 423 424(defun mml-secure-message-encrypt-pgpmime (&optional dontsign) 425 "Add MML tag to encrypt and sign the entire message. 426If called with a prefix argument, only encrypt (do NOT sign)." 427 (interactive "P") 428 (mml-secure-message "pgpmime" (if dontsign 'encrypt 'signencrypt))) 429 430(defun mml-secure-message-encrypt-pgpauto (&optional dontsign) 431 "Add MML tag to encrypt and sign the entire message. 432If called with a prefix argument, only encrypt (do NOT sign)." 433 (interactive "P") 434 (mml-secure-message "pgpauto" (if dontsign 'encrypt 'signencrypt))) 435 436;;; Common functionality for mml1991.el, mml2015.el, mml-smime.el 437 438(define-obsolete-variable-alias 'mml1991-signers 'mml-secure-openpgp-signers 439 "25.1") 440(define-obsolete-variable-alias 'mml2015-signers 'mml-secure-openpgp-signers 441 "25.1") 442(defcustom mml-secure-openpgp-signers nil 443 "A list of your own key ID(s) which will be used to sign OpenPGP messages. 444If set, it is added to the setting of `mml-secure-openpgp-sign-with-sender'." 445 :group 'mime-security 446 :type '(repeat (string :tag "Key ID"))) 447 448(define-obsolete-variable-alias 'mml-smime-signers 'mml-secure-smime-signers 449 "25.1") 450(defcustom mml-secure-smime-signers nil 451 "A list of your own key ID(s) which will be used to sign S/MIME messages. 452If set, it is added to the setting of `mml-secure-smime-sign-with-sender'." 453 :group 'mime-security 454 :type '(repeat (string :tag "Key ID"))) 455 456(define-obsolete-variable-alias 457 'mml1991-encrypt-to-self 'mml-secure-openpgp-encrypt-to-self "25.1") 458(define-obsolete-variable-alias 459 'mml2015-encrypt-to-self 'mml-secure-openpgp-encrypt-to-self "25.1") 460(defcustom mml-secure-openpgp-encrypt-to-self nil 461 "List of own key ID(s) or t; determines additional recipients with OpenPGP. 462If t, also encrypt to key for message sender; if list, encrypt to those keys. 463With this variable, you can ensure that you can decrypt your own messages. 464Alternatives to this variable include Bcc'ing the message to yourself or 465using the encrypt-to or hidden-encrypt-to option in gpg.conf (see man gpg(1)). 466Note that this variable and the encrypt-to option give away your identity 467for *every* encryption without warning, which is not what you want if you are 468using, e.g., remailers. 469Also, use of Bcc gives away your identity for *every* encryption without 470warning, which is a bug, see: 471https://debbugs.gnu.org/cgi/bugreport.cgi?bug=18718" 472 :group 'mime-security 473 :type '(choice (const :tag "None" nil) 474 (const :tag "From address" t) 475 (repeat (string :tag "Key ID")))) 476 477(define-obsolete-variable-alias 478 'mml-smime-encrypt-to-self 'mml-secure-smime-encrypt-to-self "25.1") 479(defcustom mml-secure-smime-encrypt-to-self nil 480 "List of own key ID(s) or t; determines additional recipients with S/MIME. 481If t, also encrypt to key for message sender; if list, encrypt to those keys. 482With this variable, you can ensure that you can decrypt your own messages. 483Alternatives to this variable include Bcc'ing the message to yourself or 484using the encrypt-to option in gpgsm.conf (see man gpgsm(1)). 485Note that this variable and the encrypt-to option give away your identity 486for *every* encryption without warning, which is not what you want if you are 487using, e.g., remailers. 488Also, use of Bcc gives away your identity for *every* encryption without 489warning, which is a bug, see: 490https://debbugs.gnu.org/cgi/bugreport.cgi?bug=18718" 491 :group 'mime-security 492 :type '(choice (const :tag "None" nil) 493 (const :tag "From address" t) 494 (repeat (string :tag "Key ID")))) 495 496(define-obsolete-variable-alias 497 'mml2015-sign-with-sender 'mml-secure-openpgp-sign-with-sender "25.1") 498;mml1991-sign-with-sender did never exist. 499(defcustom mml-secure-openpgp-sign-with-sender nil 500 "If t, use message sender to find an OpenPGP key to sign with. 501Also use message's sender with GnuPG's --sender option." 502 :group 'mime-security 503 :type 'boolean) 504 505(define-obsolete-variable-alias 506 'mml-smime-sign-with-sender 'mml-secure-smime-sign-with-sender "25.1") 507(defcustom mml-secure-smime-sign-with-sender nil 508 "If t, use message sender to find an S/MIME key to sign with." 509 :group 'mime-security 510 :type 'boolean) 511 512(define-obsolete-variable-alias 513 'mml2015-always-trust 'mml-secure-openpgp-always-trust "25.1") 514;mml1991-always-trust did never exist. 515(defcustom mml-secure-openpgp-always-trust t 516 "If t, skip key validation of GnuPG on encryption." 517 :group 'mime-security 518 :type 'boolean) 519 520(defcustom mml-secure-fail-when-key-problem nil 521 "If t, raise an error if some key is missing or several keys exist. 522Otherwise, ask the user." 523 :version "25.1" 524 :group 'mime-security 525 :type 'boolean) 526 527(defcustom mml-secure-key-preferences 528 '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))) 529 "Protocol- and usage-specific fingerprints of preferred keys. 530This variable is only relevant if a recipient owns multiple key pairs (for 531encryption) or you own multiple key pairs (for signing). In such cases, 532you will be asked which key(s) should be used, and your choice can be 533customized in this variable." 534 :version "25.1" 535 :group 'mime-security 536 :type '(alist :key-type (symbol :tag "Protocol") :value-type 537 (alist :key-type (symbol :tag "Usage") :value-type 538 (alist :key-type (string :tag "Name") :value-type 539 (repeat (string :tag "Fingerprint")))))) 540 541(defun mml-secure-cust-usage-lookup (context usage) 542 "Return preferences for CONTEXT and USAGE." 543 (let* ((protocol (epg-context-protocol context)) 544 (protocol-prefs (cdr (assoc protocol mml-secure-key-preferences)))) 545 (assoc usage protocol-prefs))) 546 547(defun mml-secure-cust-fpr-lookup (context usage name) 548 "Return fingerprints of preferred keys for CONTEXT, USAGE, and NAME." 549 (let* ((usage-prefs (mml-secure-cust-usage-lookup context usage)) 550 (fprs (assoc name (cdr usage-prefs)))) 551 (when fprs 552 (cdr fprs)))) 553 554(defun mml-secure-cust-record-keys (context usage name keys &optional save) 555 "For CONTEXT, USAGE, and NAME record fingerprint(s) of KEYS. 556If optional SAVE is not nil, save customized fingerprints. 557Return keys." 558 (cl-assert keys) 559 (let* ((usage-prefs (mml-secure-cust-usage-lookup context usage)) 560 (curr-fprs (cdr (assoc name (cdr usage-prefs)))) 561 (key-fprs (mapcar 'mml-secure-fingerprint keys)) 562 (new-fprs (cl-union curr-fprs key-fprs :test 'equal))) 563 (if curr-fprs 564 (setcdr (assoc name (cdr usage-prefs)) new-fprs) 565 (setcdr usage-prefs (cons (cons name new-fprs) (cdr usage-prefs)))) 566 (when save 567 (customize-save-variable 568 'mml-secure-key-preferences mml-secure-key-preferences)) 569 keys)) 570 571(defun mml-secure-cust-remove-keys (context usage name) 572 "Remove keys for CONTEXT, USAGE, and NAME. 573Return t if a customization for NAME was present (and has been removed)." 574 (let* ((usage-prefs (mml-secure-cust-usage-lookup context usage)) 575 (current (assoc name usage-prefs))) 576 (when current 577 (setcdr usage-prefs (remove current (cdr usage-prefs))) 578 t))) 579 580(defvar mml-secure-secret-key-id-list nil) 581 582(defun mml-secure-add-secret-key-id (key-id) 583 "Record KEY-ID in list of secret keys." 584 (add-to-list 'mml-secure-secret-key-id-list key-id)) 585 586(defun mml-secure-clear-secret-key-id-list () 587 "Remove passwords from cache and clear list of secret keys." 588 ;; Loosely based on code inside mml2015-epg-encrypt, 589 ;; mml2015-epg-clear-decrypt, and mml2015-epg-decrypt 590 (dolist (key-id mml-secure-secret-key-id-list nil) 591 (password-cache-remove key-id)) 592 (setq mml-secure-secret-key-id-list nil)) 593 594(defvar mml1991-cache-passphrase) 595(defvar mml1991-passphrase-cache-expiry) 596 597(defun mml-secure-cache-passphrase-p (protocol) 598 "Return t if OpenPGP or S/MIME passphrases should be cached for PROTOCOL. 599Passphrase caching in Emacs is NOT recommended. Use gpg-agent instead." 600 (or (and (eq 'OpenPGP protocol) 601 (or mml-secure-cache-passphrase 602 (and (boundp 'mml2015-cache-passphrase) 603 mml2015-cache-passphrase) 604 (and (boundp 'mml1991-cache-passphrase) 605 mml1991-cache-passphrase))) 606 (and (eq 'CMS protocol) 607 (or mml-secure-cache-passphrase 608 (and (boundp 'mml-smime-cache-passphrase) 609 mml-smime-cache-passphrase))))) 610 611(defun mml-secure-cache-expiry-interval (protocol) 612 "Return time in seconds to cache passphrases for PROTOCOL. 613Passphrase caching in Emacs is NOT recommended. Use gpg-agent instead." 614 (or (and (eq 'OpenPGP protocol) 615 (or (and (boundp 'mml2015-passphrase-cache-expiry) 616 mml2015-passphrase-cache-expiry) 617 (and (boundp 'mml1991-passphrase-cache-expiry) 618 mml1991-passphrase-cache-expiry) 619 mml-secure-passphrase-cache-expiry)) 620 (and (eq 'CMS protocol) 621 (or (and (boundp 'mml-smime-passphrase-cache-expiry) 622 mml-smime-passphrase-cache-expiry) 623 mml-secure-passphrase-cache-expiry)))) 624 625(defun mml-secure-passphrase-callback (context key-id standard) 626 "Ask for passphrase in CONTEXT for KEY-ID for STANDARD. 627The passphrase is read and cached." 628 ;; Based on mml2015-epg-passphrase-callback. 629 (if (eq key-id 'SYM) 630 (epa-passphrase-callback-function context key-id nil) 631 (let* ((password-cache-key-id 632 (if (eq key-id 'PIN) 633 "PIN" 634 key-id)) 635 (entry (assoc key-id epg-user-id-alist)) 636 (passphrase 637 (password-read 638 (if (eq key-id 'PIN) 639 "Passphrase for PIN: " 640 (if entry 641 (format "Passphrase for %s %s: " key-id (cdr entry)) 642 (format "Passphrase for %s: " key-id))) 643 ;; TODO: With mml-smime.el, password-cache-key-id is not passed 644 ;; as argument to password-read. 645 ;; Is that on purpose? If so, the following needs to be placed 646 ;; inside an if statement. 647 password-cache-key-id))) 648 (when passphrase 649 (let ((password-cache-expiry (mml-secure-cache-expiry-interval 650 (epg-context-protocol context)))) 651 ;; FIXME test passphrase works before caching it. 652 (password-cache-add password-cache-key-id passphrase)) 653 (mml-secure-add-secret-key-id password-cache-key-id) 654 (copy-sequence passphrase))))) 655 656(defun mml-secure-check-user-id (key recipient) 657 "Check whether KEY has a non-revoked, non-expired UID for RECIPIENT." 658 ;; Based on mml2015-epg-check-user-id. 659 (let ((uids (epg-key-user-id-list key))) 660 (catch 'break 661 (dolist (uid uids nil) 662 (if (and (stringp (epg-user-id-string uid)) 663 (car (ignore-errors 664 (mail-header-parse-address 665 (epg-user-id-string uid)))) 666 (equal (downcase (car (mail-header-parse-address 667 (epg-user-id-string uid)))) 668 (downcase (car (mail-header-parse-address 669 recipient)))) 670 (not (memq (epg-user-id-validity uid) 671 '(revoked expired)))) 672 (throw 'break t)))))) 673 674(defun mml-secure-secret-key-exists-p (context subkey) 675 "Return t if keyring for CONTEXT contains secret key for public SUBKEY." 676 (let* ((fpr (epg-sub-key-fingerprint subkey)) 677 (candidates (epg-list-keys context fpr 'secret)) 678 (candno (length candidates))) 679 ;; If two or more subkeys with the same fingerprint exist, something is 680 ;; terribly wrong. 681 (when (>= candno 2) 682 (error "Found %d secret keys with same fingerprint %s" candno fpr)) 683 (= 1 candno))) 684 685(defun mml-secure-check-sub-key (context key usage &optional fingerprint) 686 "Check whether in CONTEXT the public KEY has a usable subkey for USAGE. 687This is the case if KEY is not disabled, and there is a subkey for 688USAGE that is neither revoked nor expired. Additionally, if optional 689FINGERPRINT is present and if it is not the primary key's fingerprint, then 690the returned subkey must have that FINGERPRINT. FINGERPRINT must consist of 691hexadecimal digits only (no leading \"0x\" allowed). 692If USAGE is not `encrypt', then additionally an appropriate secret key must 693be present in the keyring." 694 ;; Based on mml2015-epg-check-sub-key, extended by 695 ;; - check for secret keys if usage is not 'encrypt and 696 ;; - check for new argument FINGERPRINT. 697 (let* ((subkeys (epg-key-sub-key-list key)) 698 (primary (car subkeys)) 699 (fpr (epg-sub-key-fingerprint primary))) 700 ;; The primary key will be marked as disabled, when the entire 701 ;; key is disabled (see 12 Field, Format of colon listings, in 702 ;; gnupg/doc/DETAILS) 703 (unless (memq 'disabled (epg-sub-key-capability primary)) 704 (catch 'break 705 (dolist (subkey subkeys nil) 706 (if (and (memq usage (epg-sub-key-capability subkey)) 707 (not (memq (epg-sub-key-validity subkey) 708 '(revoked expired))) 709 (or (eq 'encrypt usage) ; Encryption works with public key. 710 ;; In contrast, signing requires secret key. 711 (mml-secure-secret-key-exists-p context subkey)) 712 (or (not fingerprint) 713 (string-match-p (concat fingerprint "$") fpr) 714 (string-match-p (concat fingerprint "$") 715 (epg-sub-key-fingerprint subkey)))) 716 (throw 'break t))))))) 717 718(defun mml-secure-find-usable-keys (context name usage &optional justone) 719 "In CONTEXT return a list of keys for NAME and USAGE. 720If USAGE is `encrypt' public keys are returned, otherwise secret ones. 721Only non-revoked and non-expired keys are returned whose primary key is 722not disabled. 723NAME can be an e-mail address or a key ID. 724If NAME just consists of hexadecimal digits (possibly prefixed by \"0x\"), it 725is treated as key ID for which at most one key must exist in the keyring. 726Otherwise, NAME is treated as user ID, for which no keys are returned if it 727is expired or revoked. 728If optional JUSTONE is not nil, return the first key instead of a list." 729 (let* ((keys (epg-list-keys context name)) 730 (iskeyid (string-match "\\(0x\\)?\\([[:xdigit:]]\\{8,\\}\\)" name)) 731 (fingerprint (match-string 2 name)) 732 result) 733 (when (and iskeyid (>= (length keys) 2)) 734 (error 735 "Name %s (for %s) looks like a key ID but multiple keys found" 736 name usage)) 737 (catch 'break 738 (dolist (key keys result) 739 (if (and (or iskeyid 740 (mml-secure-check-user-id key name)) 741 (mml-secure-check-sub-key context key usage fingerprint)) 742 (if justone 743 (throw 'break key) 744 (push key result))))))) 745 746(defun mml-secure-select-preferred-keys (context names usage) 747 "Return list of preferred keys in CONTEXT for NAMES and USAGE. 748This inspects the keyrings to find keys for each name in NAMES. If several 749keys are found for a name, `mml-secure-select-keys' is used to look for 750customized preferences or have the user select preferable ones. 751When `mml-secure-fail-when-key-problem' is t, fail with an error in 752case of missing, outdated, or multiple keys." 753 ;; Loosely based on code appearing inside mml2015-epg-sign and 754 ;; mml2015-epg-encrypt. 755 (apply 756 #'nconc 757 (mapcar 758 (lambda (name) 759 (let* ((keys (mml-secure-find-usable-keys context name usage)) 760 (keyno (length keys))) 761 (cond ((= 0 keyno) 762 (when (or mml-secure-fail-when-key-problem 763 (not (y-or-n-p 764 (format "No %s key for %s; skip it? " 765 usage name)))) 766 (error "No %s key for %s" usage name))) 767 ((= 1 keyno) keys) 768 (t (mml-secure-select-keys context name keys usage))))) 769 names))) 770 771(defun mml-secure-fingerprint (key) 772 "Return fingerprint for public KEY." 773 (epg-sub-key-fingerprint (car (epg-key-sub-key-list key)))) 774 775(defun mml-secure-filter-keys (keys fprs) 776 "Filter KEYS to subset with fingerprints in FPRS." 777 (when keys 778 (if (member (mml-secure-fingerprint (car keys)) fprs) 779 (cons (car keys) (mml-secure-filter-keys (cdr keys) fprs)) 780 (mml-secure-filter-keys (cdr keys) fprs)))) 781 782(defun mml-secure-normalize-cust-name (name) 783 "Normalize NAME to be used for customization. 784Currently, remove ankle brackets." 785 (if (string-match "^<\\(.*\\)>$" name) 786 (match-string 1 name) 787 name)) 788 789(defun mml-secure-select-keys (context name keys usage) 790 "In CONTEXT for NAME select among KEYS for USAGE. 791KEYS should be a list with multiple entries. 792NAME is normalized first as customized keys are inspected. 793When `mml-secure-fail-when-key-problem' is t, fail with an error in case of 794outdated or multiple keys." 795 (let* ((nname (mml-secure-normalize-cust-name name)) 796 (fprs (mml-secure-cust-fpr-lookup context usage nname)) 797 (usable-fprs (mapcar 'mml-secure-fingerprint keys))) 798 (if fprs 799 (if (gnus-subsetp fprs usable-fprs) 800 (mml-secure-filter-keys keys fprs) 801 (mml-secure-cust-remove-keys context usage nname) 802 (let ((diff (gnus-setdiff fprs usable-fprs))) 803 (if mml-secure-fail-when-key-problem 804 (error "Customization of %s keys for %s outdated" usage nname) 805 (mml-secure-select-keys-1 806 context nname keys usage (format "\ 807Customized keys 808 (%s) 809for %s not available any more. 810Select anew. " 811 diff nname))))) 812 (if mml-secure-fail-when-key-problem 813 (error "Multiple %s keys for %s" usage nname) 814 (mml-secure-select-keys-1 815 context nname keys usage (format "\ 816Multiple %s keys for: 817 %s 818Select preferred one(s). " 819 usage nname)))))) 820 821(defun mml-secure-select-keys-1 (context name keys usage message) 822 "In CONTEXT for NAME let user select among KEYS for USAGE, showing MESSAGE. 823Return selected keys." 824 (let* ((selected (epa--select-keys message keys)) 825 (selno (length selected)) 826 ;; TODO: y-or-n-p does not always resize the echo area but may 827 ;; truncate the message. Why? The following does not help. 828 ;; yes-or-no-p shows full message, though. 829 (message-truncate-lines nil)) 830 (if selected 831 (if (y-or-n-p 832 (format "%d %s key(s) selected. Store for %s? " 833 selno usage name)) 834 (mml-secure-cust-record-keys context usage name selected 'save) 835 selected) 836 (unless (y-or-n-p 837 (format "No %s key for %s; skip it? " usage name)) 838 (error "No %s key for %s" usage name))))) 839 840(defun mml-secure-signer-names (protocol sender) 841 "Determine signer names for PROTOCOL and message from SENDER. 842Returned names may be e-mail addresses or key IDs and are determined based 843on `mml-secure-openpgp-signers' and `mml-secure-openpgp-sign-with-sender' with 844OpenPGP or `mml-secure-smime-signers' and `mml-secure-smime-sign-with-sender' 845with S/MIME." 846 (if (eq 'OpenPGP protocol) 847 (append mml-secure-openpgp-signers 848 (if (and mml-secure-openpgp-sign-with-sender sender) 849 (list (concat "<" sender ">")))) 850 (append mml-secure-smime-signers 851 (if (and mml-secure-smime-sign-with-sender sender) 852 (list (concat "<" sender ">")))))) 853 854(defun mml-secure-signers (context signer-names) 855 "Determine signing keys in CONTEXT from SIGNER-NAMES. 856If `mm-sign-option' is `guided', the user is asked to choose. 857Otherwise, `mml-secure-select-preferred-keys' is used." 858 ;; Based on code appearing inside mml2015-epg-sign and 859 ;; mml2015-epg-encrypt. 860 (if (eq mm-sign-option 'guided) 861 (epa-select-keys context "\ 862Select keys for signing. 863If no one is selected, default secret key is used. " 864 signer-names t) 865 (mml-secure-select-preferred-keys context signer-names 'sign))) 866 867(defun mml-secure-self-recipients (protocol sender) 868 "Determine additional recipients based on encrypt-to-self variables. 869PROTOCOL specifies OpenPGP or S/MIME for a message from SENDER." 870 (let ((encrypt-to-self 871 (if (eq 'OpenPGP protocol) 872 mml-secure-openpgp-encrypt-to-self 873 mml-secure-smime-encrypt-to-self))) 874 (when encrypt-to-self 875 (if (listp encrypt-to-self) 876 encrypt-to-self 877 (list sender))))) 878 879(defun mml-secure-recipients (protocol context config sender) 880 "Determine encryption recipients. 881PROTOCOL specifies OpenPGP or S/MIME with matching CONTEXT and CONFIG 882for a message from SENDER." 883 ;; Based on code appearing inside mml2015-epg-encrypt. 884 (let ((recipients 885 (apply #'nconc 886 (mapcar 887 (lambda (recipient) 888 (or (epg-expand-group config recipient) 889 (list (concat "<" recipient ">")))) 890 (split-string 891 (or (message-options-get 'message-recipients) 892 (message-options-set 'message-recipients 893 (read-string "Recipients: "))) 894 "[ \f\t\n\r\v,]+"))))) 895 (nconc recipients (mml-secure-self-recipients protocol sender)) 896 (if (eq mm-encrypt-option 'guided) 897 (setq recipients 898 (epa-select-keys context "\ 899Select recipients for encryption. 900If no one is selected, symmetric encryption will be performed. " 901 recipients)) 902 (setq recipients 903 (mml-secure-select-preferred-keys context recipients 'encrypt)) 904 (unless recipients 905 (error "No recipient specified"))) 906 recipients)) 907 908(defun mml-secure-epg-encrypt (protocol cont &optional sign) 909 ;; Based on code appearing inside mml2015-epg-encrypt. 910 (let* ((context (epg-make-context protocol)) 911 (config (epg-find-configuration 'OpenPGP)) 912 (sender (message-options-get 'message-sender)) 913 (recipients (mml-secure-recipients protocol context config sender)) 914 (signer-names (mml-secure-signer-names protocol sender)) 915 cipher signers) 916 (when sign 917 (setq signers (mml-secure-signers context signer-names)) 918 (setf (epg-context-signers context) signers) 919 (when (and (eq 'OpenPGP protocol) mml-secure-openpgp-sign-with-sender) 920 (setf (epg-context-sender context) sender))) 921 (when (eq 'OpenPGP protocol) 922 (setf (epg-context-armor context) t) 923 (setf (epg-context-textmode context) t)) 924 (when (mml-secure-cache-passphrase-p protocol) 925 (epg-context-set-passphrase-callback 926 context 927 (cons 'mml-secure-passphrase-callback protocol))) 928 (condition-case error 929 (setq cipher 930 (if (eq 'OpenPGP protocol) 931 (epg-encrypt-string context (buffer-string) recipients sign 932 mml-secure-openpgp-always-trust) 933 (epg-encrypt-string context (buffer-string) recipients)) 934 mml-secure-secret-key-id-list nil) 935 (error 936 (mml-secure-clear-secret-key-id-list) 937 (signal (car error) (cdr error)))) 938 cipher)) 939 940(defun mml-secure-epg-sign (protocol mode) 941 ;; Based on code appearing inside mml2015-epg-sign. 942 (let* ((context (epg-make-context protocol)) 943 (sender (message-options-get 'message-sender)) 944 (signer-names (mml-secure-signer-names protocol sender)) 945 (signers (mml-secure-signers context signer-names)) 946 signature micalg) 947 (when (eq 'OpenPGP protocol) 948 (setf (epg-context-armor context) t) 949 (setf (epg-context-textmode context) t) 950 (when mml-secure-openpgp-sign-with-sender 951 (setf (epg-context-sender context) sender))) 952 (setf (epg-context-signers context) signers) 953 (when (mml-secure-cache-passphrase-p protocol) 954 (epg-context-set-passphrase-callback 955 context 956 (cons 'mml-secure-passphrase-callback protocol))) 957 (condition-case error 958 (setq signature 959 (if (eq 'OpenPGP protocol) 960 (epg-sign-string context (buffer-string) mode) 961 (epg-sign-string context 962 (replace-regexp-in-string 963 "\n" "\r\n" (buffer-string)) 964 t)) 965 mml-secure-secret-key-id-list nil) 966 (error 967 (mml-secure-clear-secret-key-id-list) 968 (signal (car error) (cdr error)))) 969 (if (epg-context-result-for context 'sign) 970 (setq micalg (epg-new-signature-digest-algorithm 971 (car (epg-context-result-for context 'sign))))) 972 (cons signature micalg))) 973 974(provide 'mml-sec) 975 976;;; mml-sec.el ends here 977