cgit.sxemacs.org Git - gnus/blob - lisp/mml-sec.el

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