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

   1 ;;; gnustest-mml-sec.el --- Tests mml-sec.el, see README-mml-secure.txt.
   2 ;; Copyright (C) 2015 Free Software Foundation, Inc.
   3
   4 ;; Author: Jens Lechtenbörger <jens.lechtenboerger@fsfe.org>
   5
   6 ;; This file is not part of GNU Emacs.
   7
   8 ;; GNU Emacs is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 3, or (at your option)
  11 ;; any later version.
  12
  13 ;; GNU Emacs is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;;; Code:
  24
  25 (require 'ert)
  26
  27 (require 'cl); mapcan
  28 (require 'message)
  29 (require 'epa)
  30 (require 'epg)
  31 (require 'mml-sec)
  32 (require 'gnus-sum)
  33
  34 (defvar with-smime t
  35   "If nil, exclude S/MIME from tests as passphrases need to entered manually.
  36 Mostly, the empty passphrase is used.  However, the keys for
  37  \"No Expiry two UIDs\" have the passphrase \"Passphrase\" (for OpenPGP as well
  38  as S/MIME).")
  39
  40 (defun enc-standards ()
  41   (if with-smime '(enc-pgp enc-pgp-mime enc-smime)
  42     '(enc-pgp enc-pgp-mime)))
  43 (defun enc-sign-standards ()
  44   (if with-smime
  45       '(enc-sign-pgp enc-sign-pgp-mime enc-sign-smime)
  46     '(enc-sign-pgp enc-sign-pgp-mime)))
  47 (defun sign-standards ()
  48   (if with-smime
  49       '(sign-pgp sign-pgp-mime sign-smime)
  50     '(sign-pgp sign-pgp-mime)))
  51
  52 (defun mml-secure-test-fixture (body &optional interactive)
  53   "Setup GnuPG home containing test keys and prepare environment for BODY.
  54 If optional INTERACTIVE is non-nil, allow questions to the user in case of
  55 key problems.
  56 This fixture temporarily unsets GPG_AGENT_INFO to enable passphrase tests,
  57 which will neither work with gpgsm nor GnuPG 2.1 any longer, I guess.
  58 Actually, I'm not sure why people would want to cache passwords in Emacs
  59 instead of gpg-agent."
  60   (unwind-protect
  61       (let ((agent-info (getenv "GPG_AGENT_INFO"))
  62             (gpghome (getenv "GNUPGHOME")))
  63         (condition-case error
  64             (let ((epg-gpg-home-directory
  65                    (expand-file-name
  66                     "mml-gpghome" (getenv "EMACS_TEST_DIRECTORY")))
  67                   (mml-smime-use 'epg)
  68                   ;; Create debug output in empty epg-debug-buffer.
  69                   (epg-debug t)
  70                   (epg-debug-buffer (get-buffer-create " *epg-test*"))
  71                   (mml-secure-fail-when-key-problem (not interactive)))
  72               (with-current-buffer epg-debug-buffer
  73                 (erase-buffer))
  74               ;; Unset GPG_AGENT_INFO to enable passphrase caching inside Emacs.
  75               ;; Just for testing.  Jens does not recommend this for daily use.
  76               (setenv "GPG_AGENT_INFO")
  77               ;; Set GNUPGHOME as gpg-agent started by gpgsm does
  78               ;; not look in the proper places otherwise, see:
  79               ;; https://bugs.gnupg.org/gnupg/issue2126
  80               (setenv "GNUPGHOME" epg-gpg-home-directory)
  81               (funcall body))
  82           (error
  83            (setenv "GPG_AGENT_INFO" agent-info)
  84            (setenv "GNUPGHOME" gpghome)
  85            (signal (car error) (cdr error))))
  86         (setenv "GPG_AGENT_INFO" agent-info)
  87         (setenv "GNUPGHOME" gpghome))))
  88
  89 (defun mml-secure-test-message-setup (method to from &optional text bcc)
  90   "Setup a buffer with MML METHOD, TO, and FROM headers.
  91 Optionally, a message TEXT and BCC header can be passed."
  92   (with-temp-buffer
  93     (when bcc (insert (format "Bcc: %s\n" bcc)))
  94     (insert (format "To: %s
  95 From: %s
  96 Subject: Test
  97 %s\n" to from mail-header-separator))
  98     (if text
  99         (insert (format "%s" text))
 100       (spook))
 101     (cond ((eq method 'enc-pgp-mime)
 102            (mml-secure-message-encrypt-pgpmime 'nosig))
 103           ((eq method 'enc-sign-pgp-mime)
 104            (mml-secure-message-encrypt-pgpmime))
 105           ((eq method 'enc-pgp) (mml-secure-message-encrypt-pgp 'nosig))
 106           ((eq method 'enc-sign-pgp) (mml-secure-message-encrypt-pgp))
 107           ((eq method 'enc-smime) (mml-secure-message-encrypt-smime 'nosig))
 108           ((eq method 'enc-sign-smime) (mml-secure-message-encrypt-smime))
 109           ((eq method 'sign-pgp-mime) (mml-secure-message-sign-pgpmime))
 110           ((eq method 'sign-pgp) (mml-secure-message-sign-pgp))
 111           ((eq method 'sign-smime) (mml-secure-message-sign-smime))
 112           (t (error "Unknown method")))
 113     (buffer-string)))
 114
 115 (defun mml-secure-test-mail-fixture (method to from body2
 116                                             &optional interactive)
 117   "Setup buffer encrypted using METHOD for TO from FROM, call BODY2.
 118 Pass optional INTERACTIVE to mml-secure-test-fixture."
 119   (mml-secure-test-fixture
 120    (lambda ()
 121      (let ((context (if (memq method '(enc-smime enc-sign-smime sign-smime))
 122                         (epg-make-context 'CMS)
 123                       (epg-make-context 'OpenPGP)))
 124            ;; Verify and decrypt by default.
 125            (mm-verify-option 'known)
 126            (mm-decrypt-option 'known)
 127            (plaintext "The Magic Words are Squeamish Ossifrage"))
 128        (with-temp-buffer
 129          (insert (mml-secure-test-message-setup method to from plaintext))
 130          (message-options-set-recipient)
 131          (message-encode-message-body)
 132          ;; Replace separator line with newline.
 133          (goto-char (point-min))
 134          (re-search-forward
 135           (concat "^" (regexp-quote mail-header-separator) "\n"))
 136          (replace-match "\n")
 137          ;; The following treatment of handles, plainbuf, and multipart
 138          ;; resulted from trial-and-error.
 139          ;; Someone with more knowledge on how to decrypt messages and verify
 140          ;; signatures might know more appropriate functions to invoke
 141          ;; instead.
 142          (let* ((handles (or (mm-dissect-buffer)
 143                              (mm-uu-dissect)))
 144                 (isplain (bufferp (car handles)))
 145                 (ismultipart (equal (car handles) "multipart/mixed"))
 146                 (plainbuf (if isplain
 147                               (car handles)
 148                             (if ismultipart
 149                                 (car (cadadr handles))
 150                               (caadr handles))))
 151                 (decrypted
 152                  (with-current-buffer plainbuf (buffer-string)))
 153                 (gnus-info
 154                  (if isplain
 155                      nil
 156                    (if ismultipart
 157                        (or (mm-handle-multipart-ctl-parameter
 158                             (cadr handles) 'gnus-details)
 159                            (mm-handle-multipart-ctl-parameter
 160                             (cadr handles) 'gnus-info))
 161                      (mm-handle-multipart-ctl-parameter
 162                       handles 'gnus-info)))))
 163            (funcall body2 gnus-info plaintext decrypted)))))
 164    interactive))
 165
 166 ;; TODO If the variable BODY3 is renamed to BODY, an infinite recursion
 167 ;; occurs.  Emacs bug?
 168 (defun mml-secure-test-key-fixture (body3)
 169   "Customize unique keys for sub@example.org and call BODY3.
 170 For OpenPGP, we have:
 171 - 1E6B FA97 3D9E 3103 B77F  D399 C399 9CF1 268D BEA2
 172   uid                  Different subkeys <sub@example.org>
 173 - 1463 2ECA B9E2 2736 9C8D  D97B F7E7 9AB7 AE31 D471
 174   uid                  Second Key Pair <sub@example.org>
 175
 176 For S/MIME:
 177           ID: 0x479DC6E2
 178       Subject: /CN=Second Key Pair
 179           aka: sub@example.org
 180   fingerprint: 0E:58:22:9B:80:EE:33:95:9F:F7:18:FE:EF:25:40:2B:47:9D:C6:E2
 181
 182            ID: 0x5F88E9FC
 183       Subject: /CN=Different subkeys
 184           aka: sub@example.org
 185   fingerprint: 4F:96:2A:B7:F4:76:61:6A:78:3D:72:AA:40:35:D5:9B:5F:88:E9:FC
 186
 187 In both cases, the first key is customized for signing and encryption."
 188   (mml-secure-test-fixture
 189    (lambda ()
 190      (let* ((mml-secure-key-preferences
 191              '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))
 192             (pcontext (epg-make-context 'OpenPGP))
 193             (pkey (epg-list-keys pcontext "C3999CF1268DBEA2"))
 194             (scontext (epg-make-context 'CMS))
 195             (skey (epg-list-keys scontext "0x479DC6E2")))
 196        (mml-secure-cust-record-keys pcontext 'encrypt "sub@example.org" pkey)
 197        (mml-secure-cust-record-keys pcontext 'sign "sub@example.org" pkey)
 198        (mml-secure-cust-record-keys scontext 'encrypt "sub@example.org" skey)
 199        (mml-secure-cust-record-keys scontext 'sign "sub@example.org" skey)
 200        (funcall body3)))))
 201
 202 (ert-deftest mml-secure-key-checks ()
 203   "Test mml-secure-check-user-id and mml-secure-check-sub-key on sample keys."
 204   (mml-secure-test-fixture
 205    (lambda ()
 206      (let* ((context (epg-make-context 'OpenPGP))
 207             (keys1 (epg-list-keys context "expired@example.org"))
 208             (keys2 (epg-list-keys context "no-exp@example.org"))
 209             (keys3 (epg-list-keys context "sub@example.org"))
 210             (keys4 (epg-list-keys context "revoked-uid@example.org"))
 211             (keys5 (epg-list-keys context "disabled@example.org"))
 212             (keys6 (epg-list-keys context "sign@example.org"))
 213             (keys7 (epg-list-keys context "jens.lechtenboerger@fsfe"))
 214             )
 215        (should (and (= 1 (length keys1)) (= 1 (length keys2))
 216                     (= 2 (length keys3))
 217                     (= 1 (length keys4)) (= 1 (length keys5))
 218                     ))
 219        ;; key1 is expired
 220        (should-not (mml-secure-check-user-id (car keys1) "expired@example.org"))
 221        (should-not (mml-secure-check-sub-key context (car keys1) 'encrypt))
 222        (should-not (mml-secure-check-sub-key context (car keys1) 'sign))
 223
 224        ;; key2 does not expire, but does not have the UID expired@example.org
 225        (should-not (mml-secure-check-user-id (car keys2) "expired@example.org"))
 226        (should (mml-secure-check-user-id (car keys2) "no-exp@example.org"))
 227        (should (mml-secure-check-sub-key context (car keys2) 'encrypt))
 228        (should (mml-secure-check-sub-key context (car keys2) 'sign))
 229
 230        ;; Two keys exist for sub@example.org.
 231        (should (mml-secure-check-user-id (car keys3) "sub@example.org"))
 232        (should (mml-secure-check-sub-key context (car keys3) 'encrypt))
 233        (should (mml-secure-check-sub-key context (car keys3) 'sign))
 234        (should (mml-secure-check-user-id (cadr keys3) "sub@example.org"))
 235        (should (mml-secure-check-sub-key context (cadr keys3) 'encrypt))
 236        (should (mml-secure-check-sub-key context (cadr keys3) 'sign))
 237
 238        ;; The UID revoked-uid@example.org is revoked.  The key itself is
 239        ;; usable, though (with the UID sub@example.org).
 240        (should-not
 241         (mml-secure-check-user-id (car keys4) "revoked-uid@example.org"))
 242        (should (mml-secure-check-sub-key context (car keys4) 'encrypt))
 243        (should (mml-secure-check-sub-key context (car keys4) 'sign))
 244        (should (mml-secure-check-user-id (car keys4) "sub@example.org"))
 245
 246        ;; The next key is disabled and, thus, unusable.
 247        (should (mml-secure-check-user-id (car keys5) "disabled@example.org"))
 248        (should-not (mml-secure-check-sub-key context (car keys5) 'encrypt))
 249        (should-not (mml-secure-check-sub-key context (car keys5) 'sign))
 250
 251        ;; The next key has multiple subkeys.
 252        ;; 42466F0F is valid sign subkey, 501FFD98 is expired
 253        (should (mml-secure-check-sub-key context (car keys6) 'sign "42466F0F"))
 254        (should-not
 255         (mml-secure-check-sub-key context (car keys6) 'sign "501FFD98"))
 256        ;; DC7F66E7 is encrypt subkey
 257        (should
 258         (mml-secure-check-sub-key context (car keys6) 'encrypt "DC7F66E7"))
 259        (should-not
 260         (mml-secure-check-sub-key context (car keys6) 'sign "DC7F66E7"))
 261        (should-not
 262         (mml-secure-check-sub-key context (car keys6) 'encrypt "42466F0F"))
 263
 264        ;; The final key is just a public key.
 265        (should (mml-secure-check-sub-key context (car keys7) 'encrypt))
 266        (should-not (mml-secure-check-sub-key context (car keys7) 'sign))
 267        ))))
 268
 269 (ert-deftest mml-secure-find-usable-keys-1 ()
 270   "Make sure that expired and disabled keys and revoked UIDs are not used."
 271   (mml-secure-test-fixture
 272    (lambda ()
 273      (let ((context (epg-make-context 'OpenPGP)))
 274        (should-not
 275         (mml-secure-find-usable-keys context "expired@example.org" 'encrypt))
 276        (should-not
 277         (mml-secure-find-usable-keys context "expired@example.org" 'sign))
 278
 279        (should-not
 280         (mml-secure-find-usable-keys context "disabled@example.org" 'encrypt))
 281        (should-not
 282         (mml-secure-find-usable-keys context "disabled@example.org" 'sign))
 283
 284        (should-not
 285         (mml-secure-find-usable-keys
 286          context "<revoked-uid@example.org>" 'encrypt))
 287        (should-not
 288         (mml-secure-find-usable-keys
 289          context "<revoked-uid@example.org>" 'sign))
 290        ;; Same test without ankles.  Will fail for Ma Gnus v0.14 and earlier.
 291        (should-not
 292         (mml-secure-find-usable-keys
 293          context "revoked-uid@example.org" 'encrypt))
 294
 295        ;; Expired key should not be usable.
 296        ;; Will fail for Ma Gnus v0.14 and earlier.
 297        ;; sign@example.org has the expired subkey 0x501FFD98.
 298        (should-not
 299         (mml-secure-find-usable-keys context "0x501FFD98" 'sign))
 300
 301        (should
 302         (mml-secure-find-usable-keys context "no-exp@example.org" 'encrypt))
 303        (should
 304         (mml-secure-find-usable-keys context "no-exp@example.org" 'sign))
 305        ))))
 306
 307 (ert-deftest mml-secure-find-usable-keys-2 ()
 308   "Test different ways to search for keys."
 309   (mml-secure-test-fixture
 310    (lambda ()
 311      (let ((context (epg-make-context 'OpenPGP)))
 312        ;; Plain substring search is not supported.
 313        (should
 314         (= 0 (length
 315               (mml-secure-find-usable-keys context "No Expiry" 'encrypt))))
 316        (should
 317         (= 0 (length
 318               (mml-secure-find-usable-keys context "No Expiry" 'sign))))
 319
 320        ;; Search for e-mail addresses works with and without ankle brackets.
 321        (should
 322         (= 1 (length (mml-secure-find-usable-keys
 323                       context "<no-exp@example.org>" 'encrypt))))
 324        (should
 325         (= 1 (length (mml-secure-find-usable-keys
 326                       context "<no-exp@example.org>" 'sign))))
 327        (should
 328         (= 1 (length (mml-secure-find-usable-keys
 329                       context "no-exp@example.org" 'encrypt))))
 330        (should
 331         (= 1 (length (mml-secure-find-usable-keys
 332                       context "no-exp@example.org" 'sign))))
 333
 334        ;; Use full UID string.
 335        (should
 336         (= 1 (length (mml-secure-find-usable-keys
 337                       context "No Expiry <no-exp@example.org>" 'encrypt))))
 338        (should
 339         (= 1 (length (mml-secure-find-usable-keys
 340                       context "No Expiry <no-exp@example.org>" 'sign))))
 341
 342        ;; If just the public key is present, only encryption is possible.
 343        ;; Search works with key IDs, with and without prefix "0x".
 344        (should
 345         (= 1 (length (mml-secure-find-usable-keys
 346                       context "A142FD84" 'encrypt))))
 347        (should
 348         (= 1 (length (mml-secure-find-usable-keys
 349                       context "0xA142FD84" 'encrypt))))
 350        (should
 351         (= 0 (length (mml-secure-find-usable-keys
 352                       context "A142FD84" 'sign))))
 353        (should
 354         (= 0 (length (mml-secure-find-usable-keys
 355                       context "0xA142FD84" 'sign))))
 356        ))))
 357
 358 (ert-deftest mml-secure-select-preferred-keys-1 ()
 359   "If only one key exists for an e-mail address, it is the preferred one."
 360   (mml-secure-test-fixture
 361    (lambda ()
 362      (let ((context (epg-make-context 'OpenPGP)))
 363        (should (equal "832F3CC6518D37BC658261B802372A42CA6D40FB"
 364                       (mml-secure-fingerprint
 365                        (car (mml-secure-select-preferred-keys
 366                              context '("no-exp@example.org") 'encrypt)))))))))
 367
 368 (ert-deftest mml-secure-select-preferred-keys-2 ()
 369   "If multiple keys exists for an e-mail address, customization is necessary."
 370   (mml-secure-test-fixture
 371    (lambda ()
 372      (let* ((context (epg-make-context 'OpenPGP))
 373             (mml-secure-key-preferences
 374              '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))
 375             (pref (car (mml-secure-find-usable-keys
 376                         context "sub@example.org" 'encrypt))))
 377        (should-error (mml-secure-select-preferred-keys
 378                       context '("sub@example.org") 'encrypt))
 379        (mml-secure-cust-record-keys
 380         context 'encrypt "sub@example.org" (list pref))
 381        (should (mml-secure-select-preferred-keys
 382                 context '("sub@example.org") 'encrypt))
 383        (should-error (mml-secure-select-preferred-keys
 384                       context '("sub@example.org") 'sign))
 385        (should (mml-secure-select-preferred-keys
 386                 context '("sub@example.org") 'encrypt))
 387        (should
 388         (equal (list (mml-secure-fingerprint pref))
 389                (mml-secure-cust-fpr-lookup context 'encrypt "sub@example.org")))
 390        (should (mml-secure-cust-remove-keys context 'encrypt "sub@example.org"))
 391        (should-error (mml-secure-select-preferred-keys
 392                       context '("sub@example.org") 'encrypt))))))
 393
 394 (ert-deftest mml-secure-select-preferred-keys-3 ()
 395   "Expired customized keys are removed if multiple keys are available."
 396   (mml-secure-test-fixture
 397    (lambda ()
 398      (let ((context (epg-make-context 'OpenPGP))
 399            (mml-secure-key-preferences
 400             '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))))
 401        ;; sub@example.org has two keys (268DBEA2, AE31D471).
 402        ;; Normal preference works.
 403        (mml-secure-cust-record-keys
 404         context 'encrypt "sub@example.org" (epg-list-keys context "268DBEA2"))
 405        (should (mml-secure-select-preferred-keys
 406                 context '("sub@example.org") 'encrypt))
 407        (mml-secure-cust-remove-keys context 'encrypt "sub@example.org")
 408
 409        ;; Fake preference for expired (unrelated) key CE15FAE7,
 410        ;; results in error (and automatic removal of outdated preference).
 411        (mml-secure-cust-record-keys
 412         context 'encrypt "sub@example.org" (epg-list-keys context "CE15FAE7"))
 413        (should-error (mml-secure-select-preferred-keys
 414                       context '("sub@example.org") 'encrypt))
 415        (should-not
 416         (mml-secure-cust-remove-keys context 'encrypt "sub@example.org"))))))
 417
 418 (ert-deftest mml-secure-select-preferred-keys-4 ()
 419   "Multiple keys can be recorded per recipient or signature."
 420   (mml-secure-test-fixture
 421    (lambda ()
 422      (let ((pcontext (epg-make-context 'OpenPGP))
 423            (scontext (epg-make-context 'CMS))
 424            (pkeys '("1E6BFA973D9E3103B77FD399C3999CF1268DBEA2"
 425                     "14632ECAB9E227369C8DD97BF7E79AB7AE31D471"))
 426            (skeys  '("0x5F88E9FC" "0x479DC6E2"))
 427            (mml-secure-key-preferences
 428             '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))))
 429
 430        ;; OpenPGP preferences via pcontext
 431        (dolist (key pkeys nil)
 432          (mml-secure-cust-record-keys
 433           pcontext 'encrypt "sub@example.org" (epg-list-keys pcontext key))
 434          (mml-secure-cust-record-keys
 435           pcontext 'sign "sub@example.org" (epg-list-keys pcontext key 'secret)))
 436        (let ((p-e-fprs (mml-secure-cust-fpr-lookup
 437                         pcontext 'encrypt "sub@example.org"))
 438              (p-s-fprs (mml-secure-cust-fpr-lookup
 439                         pcontext 'sign "sub@example.org")))
 440          (should (= 2 (length p-e-fprs)))
 441          (should (= 2 (length p-s-fprs)))
 442          (should (member "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" p-e-fprs))
 443          (should (member "14632ECAB9E227369C8DD97BF7E79AB7AE31D471" p-e-fprs))
 444          (should (member "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" p-s-fprs))
 445          (should (member "14632ECAB9E227369C8DD97BF7E79AB7AE31D471" p-s-fprs)))
 446        ;; Duplicate record does not change anything.
 447        (mml-secure-cust-record-keys
 448         pcontext 'encrypt "sub@example.org"
 449         (epg-list-keys pcontext "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2"))
 450        (mml-secure-cust-record-keys
 451         pcontext 'sign "sub@example.org"
 452         (epg-list-keys pcontext "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2"))
 453        (let ((p-e-fprs (mml-secure-cust-fpr-lookup
 454                         pcontext 'encrypt "sub@example.org"))
 455              (p-s-fprs (mml-secure-cust-fpr-lookup
 456                         pcontext 'sign "sub@example.org")))
 457          (should (= 2 (length p-e-fprs)))
 458          (should (= 2 (length p-s-fprs))))
 459
 460        ;; S/MIME preferences via scontext
 461        (dolist (key skeys nil)
 462          (mml-secure-cust-record-keys
 463           scontext 'encrypt "sub@example.org"
 464           (epg-list-keys scontext key))
 465          (mml-secure-cust-record-keys
 466           scontext 'sign "sub@example.org"
 467           (epg-list-keys scontext key 'secret)))
 468        (let ((s-e-fprs (mml-secure-cust-fpr-lookup
 469                         scontext 'encrypt "sub@example.org"))
 470              (s-s-fprs (mml-secure-cust-fpr-lookup
 471                         scontext 'sign "sub@example.org")))
 472          (should (= 2 (length s-e-fprs)))
 473          (should (= 2 (length s-s-fprs))))
 474        ))))
 475
 476 (defun mml-secure-test-en-decrypt
 477     (method to from
 478             &optional checksig checkplain enc-keys expectfail interactive)
 479   "Encrypt message using METHOD, addressed to TO, from FROM.
 480 If optional CHECKSIG is non-nil, it must be a number, and a signature check is
 481 performed; the number indicates how many signatures are expected.
 482 If optional CHECKPLAIN is non-nil, the expected plaintext should be obtained
 483 via decryption.
 484 If optional ENC-KEYS is non-nil, it is a list of pairs of encryption keys (for
 485 OpenPGP and S/SMIME) expected in `epg-debug-buffer'.
 486 If optional EXPECTFAIL is non-nil, a decryption failure is expected.
 487 Pass optional INTERACTIVE to mml-secure-test-mail-fixture."
 488   (mml-secure-test-mail-fixture method to from
 489    (lambda (gnus-info plaintext decrypted)
 490      (if expectfail
 491          (should-not (equal plaintext decrypted))
 492        (when checkplain
 493          (should (equal plaintext decrypted)))
 494        (let ((protocol (if (memq method
 495                                  '(enc-smime enc-sign-smime sign-smime))
 496                            'CMS
 497                          'OpenPGP)))
 498          (when checksig
 499            (let* ((context (epg-make-context protocol))
 500                   (signer-names (mml-secure-signer-names protocol from))
 501                   (signer-keys (mml-secure-signers context signer-names))
 502                   (signer-fprs (mapcar 'mml-secure-fingerprint signer-keys)))
 503              (should (eq checksig (length signer-fprs)))
 504              (if (eq checksig 0)
 505                  ;; First key in keyring
 506                  (should (string-match-p
 507                           (concat "Good signature from "
 508                                   (if (eq protocol 'CMS)
 509                                       "0E58229B80EE33959FF718FEEF25402B479DC6E2"
 510                                     "02372A42CA6D40FB"))
 511                           gnus-info)))
 512              (dolist (fpr signer-fprs nil)
 513                ;; OpenPGP: "Good signature from 02372A42CA6D40FB No Expiry <no-exp@example.org> (trust undefined) created ..."
 514                ;; S/MIME:  "Good signature from D06AA118653CC38E9D0CAF56ED7A2135E1582177 /CN=No Expiry (trust full) ..."
 515                (should (string-match-p
 516                         (concat "Good signature from "
 517                                 (if (eq protocol 'CMS)
 518                                     fpr
 519                                   (substring fpr -16 nil)))
 520                         gnus-info)))))
 521          (when enc-keys
 522            (with-current-buffer epg-debug-buffer
 523              (goto-char (point-min))
 524              ;; The following regexp does not necessarily match at the
 525              ;; start of the line as a path may or may not be present.
 526              ;; Also note that gpg.* matches gpg2 and gpgsm as well.
 527              (let* ((line (concat "gpg.*--encrypt.*$"))
 528                     (end (re-search-forward line))
 529                     (match (match-string 0)))
 530                (should (and end match))
 531                (dolist (pair enc-keys nil)
 532                  (let ((fpr (if (eq protocol 'OpenPGP)
 533                                 (car pair)
 534                               (cdr pair))))
 535                    (should (string-match-p (concat "-r " fpr) match))))
 536                (goto-char (point-max))
 537                ))))))
 538    interactive))
 539
 540 (defun mml-secure-test-en-decrypt-with-passphrase
 541     (method to from checksig jl-passphrase do-cache
 542             &optional enc-keys expectfail)
 543   "Call mml-secure-test-en-decrypt with changed passphrase caching.
 544 Args METHOD, TO, FROM, CHECKSIG are passed to mml-secure-test-en-decrypt.
 545 JL-PASSPHRASE is fixed as return value for `read-passwd',
 546 boolean DO-CACHE determines whether to cache the passphrase.
 547 If optional ENC-KEYS is non-nil, it is a list of encryption keys expected
 548 in `epg-debug-buffer'.
 549 If optional EXPECTFAIL is non-nil, a decryption failure is expected."
 550   (let ((mml-secure-cache-passphrase do-cache)
 551         (mml1991-cache-passphrase do-cache)
 552         (mml2015-cache-passphrase do-cache)
 553         (mml-smime-cache-passphrase do-cache)
 554         )
 555     (cl-letf (((symbol-function 'read-passwd)
 556                (lambda (prompt &optional confirm default) jl-passphrase)))
 557       (mml-secure-test-en-decrypt method to from checksig t enc-keys expectfail)
 558       )))
 559
 560 (ert-deftest mml-secure-en-decrypt-1 ()
 561   "Encrypt message; then decrypt and test for expected result.
 562 In this test, the single matching key is chosen automatically."
 563   (dolist (method (enc-standards) nil)
 564     ;; no-exp@example.org with single encryption key
 565     (mml-secure-test-en-decrypt
 566      method "no-exp@example.org" "sub@example.org" nil t
 567      (list (cons "02372A42CA6D40FB" "ED7A2135E1582177")))))
 568
 569 (ert-deftest mml-secure-en-decrypt-2 ()
 570   "Encrypt message; then decrypt and test for expected result.
 571 In this test, the encryption key needs to fixed among multiple ones."
 572   ;; sub@example.org with multiple candidate keys,
 573   ;; fixture customizes preferred ones.
 574   (mml-secure-test-key-fixture
 575    (lambda ()
 576      (dolist (method (enc-standards) nil)
 577        (mml-secure-test-en-decrypt
 578         method "sub@example.org" "no-exp@example.org" nil t
 579         (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2")))))))
 580
 581 (ert-deftest mml-secure-en-decrypt-3 ()
 582   "Encrypt message; then decrypt and test for expected result.
 583 In this test, encrypt-to-self variables are set to t."
 584   ;; sub@example.org with multiple candidate keys,
 585   ;; fixture customizes preferred ones.
 586   (mml-secure-test-key-fixture
 587    (lambda ()
 588      (let ((mml-secure-openpgp-encrypt-to-self t)
 589            (mml-secure-smime-encrypt-to-self t))
 590        (dolist (method (enc-standards) nil)
 591          (mml-secure-test-en-decrypt
 592           method "sub@example.org" "no-exp@example.org" nil t
 593           (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2")
 594                 (cons "02372A42CA6D40FB" "ED7A2135E1582177"))))))))
 595
 596 (ert-deftest mml-secure-en-decrypt-4 ()
 597   "Encrypt message; then decrypt and test for expected result.
 598 In this test, encrypt-to-self variables are set to lists."
 599   ;; Send from sub@example.org, which has two keys; encrypt to both.
 600   (let ((mml-secure-openpgp-encrypt-to-self
 601          '("C3999CF1268DBEA2" "F7E79AB7AE31D471"))
 602         (mml-secure-smime-encrypt-to-self
 603          '("EF25402B479DC6E2" "4035D59B5F88E9FC")))
 604     (dolist (method (enc-standards) nil)
 605       (mml-secure-test-en-decrypt
 606        method "no-exp@example.org" "sub@example.org" nil t
 607        (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2")
 608              (cons "F7E79AB7AE31D471" "4035D59B5F88E9FC"))))))
 609
 610 (ert-deftest mml-secure-en-decrypt-sign-1 ()
 611   "Sign and encrypt message; then decrypt and test for expected result.
 612 In this test, just multiple encryption and signing keys may be available."
 613   (mml-secure-test-key-fixture
 614    (lambda ()
 615      (let ((mml-secure-openpgp-sign-with-sender t)
 616            (mml-secure-smime-sign-with-sender t))
 617        (dolist (method (enc-sign-standards) nil)
 618          ;; no-exp with just one key
 619          (mml-secure-test-en-decrypt
 620           method "no-exp@example.org" "no-exp@example.org" 1 t)
 621          ;; customized choice for encryption key
 622          (mml-secure-test-en-decrypt
 623           method "sub@example.org" "no-exp@example.org" 1 t)
 624          ;; customized choice for signing key
 625          (mml-secure-test-en-decrypt
 626           method "no-exp@example.org" "sub@example.org" 1 t)
 627          ;; customized choice for both keys
 628          (mml-secure-test-en-decrypt
 629           method "sub@example.org" "sub@example.org" 1 t)
 630          )
 631
 632        ;; Now use both keys to sign.  The customized one via sign-with-sender,
 633        ;; the other one via the following setting.
 634        (let ((mml-secure-openpgp-signers '("F7E79AB7AE31D471"))
 635              (mml-secure-smime-signers '("0x5F88E9FC")))
 636          (dolist (method (enc-sign-standards) nil)
 637            (mml-secure-test-en-decrypt
 638             method "no-exp@example.org" "sub@example.org" 2 t)
 639          )))
 640
 641      ;; Now use both keys for sub@example.org to sign an e-mail from
 642      ;; a different address (without associated keys).
 643      (let ((mml-secure-openpgp-sign-with-sender nil)
 644            (mml-secure-smime-sign-with-sender nil)
 645            (mml-secure-openpgp-signers
 646             '("F7E79AB7AE31D471" "C3999CF1268DBEA2"))
 647            (mml-secure-smime-signers '("0x5F88E9FC" "0x479DC6E2")))
 648        (dolist (method (enc-sign-standards) nil)
 649          (mml-secure-test-en-decrypt
 650           method "no-exp@example.org" "no-keys@example.org" 2 t)
 651          )))))
 652
 653 (ert-deftest mml-secure-en-decrypt-sign-2 ()
 654   "Sign and encrypt message; then decrypt and test for expected result.
 655 In this test, lists of encryption and signing keys are customized."
 656   (mml-secure-test-key-fixture
 657    (lambda ()
 658      (let ((mml-secure-key-preferences
 659             '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))
 660            (pcontext (epg-make-context 'OpenPGP))
 661            (scontext (epg-make-context 'CMS))
 662            (mml-secure-openpgp-sign-with-sender t)
 663            (mml-secure-smime-sign-with-sender t))
 664        (dolist (key '("F7E79AB7AE31D471" "C3999CF1268DBEA2") nil)
 665          (mml-secure-cust-record-keys
 666           pcontext 'encrypt "sub@example.org" (epg-list-keys pcontext key))
 667          (mml-secure-cust-record-keys
 668           pcontext 'sign "sub@example.org" (epg-list-keys pcontext key t)))
 669        (dolist (key '("0x5F88E9FC" "0x479DC6E2") nil)
 670          (mml-secure-cust-record-keys
 671           scontext 'encrypt "sub@example.org" (epg-list-keys scontext key))
 672          (mml-secure-cust-record-keys
 673           scontext 'sign "sub@example.org" (epg-list-keys scontext key t)))
 674        (dolist (method (enc-sign-standards) nil)
 675          ;; customized choice for encryption key
 676          (mml-secure-test-en-decrypt
 677           method "sub@example.org" "no-exp@example.org" 1 t)
 678          ;; customized choice for signing key
 679          (mml-secure-test-en-decrypt
 680           method "no-exp@example.org" "sub@example.org" 2 t)
 681          ;; customized choice for both keys
 682          (mml-secure-test-en-decrypt
 683           method "sub@example.org" "sub@example.org" 2 t)
 684          )))))
 685
 686 (ert-deftest mml-secure-en-decrypt-sign-3 ()
 687   "Sign and encrypt message; then decrypt and test for expected result.
 688 Use sign-with-sender and encrypt-to-self."
 689   (mml-secure-test-key-fixture
 690    (lambda ()
 691      (let ((mml-secure-openpgp-sign-with-sender t)
 692            (mml-secure-openpgp-encrypt-to-self t)
 693            (mml-secure-smime-sign-with-sender t)
 694            (mml-secure-smime-encrypt-to-self t))
 695        (dolist (method (enc-sign-standards) nil)
 696          (mml-secure-test-en-decrypt
 697           method "sub@example.org" "no-exp@example.org" 1 t
 698           (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2")
 699                 (cons "02372A42CA6D40FB" "ED7A2135E1582177"))))
 700        ))))
 701
 702 (ert-deftest mml-secure-sign-verify-1 ()
 703   "Sign message with sender; then verify and test for expected result."
 704   (mml-secure-test-key-fixture
 705    (lambda ()
 706      (dolist (method (sign-standards) nil)
 707        (let ((mml-secure-openpgp-sign-with-sender t)
 708              (mml-secure-smime-sign-with-sender t))
 709          ;; A single signing key for sender sub@example.org is customized
 710          ;; in the fixture.
 711          (mml-secure-test-en-decrypt
 712           method "uid1@example.org" "sub@example.org" 1 nil)
 713
 714          ;; From sub@example.org, sign with two keys;
 715          ;; sign-with-sender and one from signers-variable:
 716          (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB"))
 717                (mml-secure-smime-signers
 718                 '("D06AA118653CC38E9D0CAF56ED7A2135E1582177")))
 719            (mml-secure-test-en-decrypt
 720             method "no-exp@example.org" "sub@example.org" 2 nil))
 721          )))))
 722
 723 (ert-deftest mml-secure-sign-verify-2 ()
 724   "Sign message without sender; then verify and test for expected result."
 725   (mml-secure-test-key-fixture
 726    (lambda ()
 727      (dolist (method (sign-standards) nil)
 728        (let ((mml-secure-openpgp-sign-with-sender nil)
 729              (mml-secure-smime-sign-with-sender nil))
 730          ;; A single signing key for sender sub@example.org is customized
 731          ;; in the fixture, but not used here.
 732          ;; By default, gpg uses the first secret key in the keyring, which
 733          ;; is 02372A42CA6D40FB (OpenPGP) or
 734          ;; 0E58229B80EE33959FF718FEEF25402B479DC6E2 (S/MIME) here.
 735          (mml-secure-test-en-decrypt
 736           method "uid1@example.org" "sub@example.org" 0 nil)
 737
 738          ;; From sub@example.org, sign with specified key:
 739          (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB"))
 740                (mml-secure-smime-signers
 741                 '("D06AA118653CC38E9D0CAF56ED7A2135E1582177")))
 742            (mml-secure-test-en-decrypt
 743             method "no-exp@example.org" "sub@example.org" 1 nil))
 744
 745          ;; From sub@example.org, sign with different specified key:
 746          (let ((mml-secure-openpgp-signers '("C3999CF1268DBEA2"))
 747                (mml-secure-smime-signers
 748                 '("0E58229B80EE33959FF718FEEF25402B479DC6E2")))
 749            (mml-secure-test-en-decrypt
 750             method "no-exp@example.org" "sub@example.org" 1 nil))
 751          )))))
 752
 753 (ert-deftest mml-secure-sign-verify-3 ()
 754   "Try to sign message with expired OpenPGP subkey, which raises an error.
 755 With Ma Gnus v0.14 and earlier a signature would be created with a wrong key."
 756   (should-error
 757    (mml-secure-test-key-fixture
 758     (lambda ()
 759       (let ((with-smime nil)
 760             (mml-secure-openpgp-sign-with-sender nil)
 761             (mml-secure-openpgp-signers '("501FFD98")))
 762         (dolist (method (sign-standards) nil)
 763           (mml-secure-test-en-decrypt
 764            method "no-exp@example.org" "sign@example.org" 1 nil)
 765           ))))))
 766
 767 ;; TODO Passphrase passing and caching in Emacs does not seem to work
 768 ;; with gpgsm at all.
 769 ;; Independently of caching settings, a pinentry dialogue is displayed.
 770 ;; Thus, the following tests require the user to enter the correct gpgsm
 771 ;; passphrases at the correct points in time.  (Either empty string or
 772 ;; "Passphrase".)
 773 (ert-deftest mml-secure-en-decrypt-passphrase-cache ()
 774   "Encrypt message; then decrypt and test for expected result.
 775 In this test, a key is used that requires the passphrase \"Passphrase\".
 776 In the first decryption this passphrase is hardcoded, in the second one it
 777  is taken from a cache."
 778   (mml-secure-test-key-fixture
 779    (lambda ()
 780      (dolist (method (enc-standards) nil)
 781        (mml-secure-test-en-decrypt-with-passphrase
 782         method "uid1@example.org" "sub@example.org" nil
 783         ;; Beware!  For passphrases copy-sequence is necessary, as they may
 784         ;; be erased, which actually changes the function's code and causes
 785         ;; multiple invokations to fail.  I was surprised...
 786         (copy-sequence "Passphrase") t)
 787        (mml-secure-test-en-decrypt-with-passphrase
 788         method "uid1@example.org" "sub@example.org" nil
 789         (copy-sequence "Incorrect") t)))))
 790
 791 (defun mml-secure-en-decrypt-passphrase-no-cache (method)
 792   "Encrypt message with METHOD; then decrypt and test for expected result.
 793 In this test, a key is used that requires the passphrase \"Passphrase\".
 794 In the first decryption this passphrase is hardcoded, but caching disabled.
 795 So the second decryption fails."
 796   (mml-secure-test-key-fixture
 797    (lambda ()
 798      (mml-secure-test-en-decrypt-with-passphrase
 799       method "uid1@example.org" "sub@example.org" nil
 800       (copy-sequence "Passphrase") nil)
 801      (mml-secure-test-en-decrypt-with-passphrase
 802       method "uid1@example.org" "sub@example.org" nil
 803       (copy-sequence "Incorrect") nil nil t))))
 804
 805 (ert-deftest mml-secure-en-decrypt-passphrase-no-cache-openpgp-todo ()
 806   "Passphrase caching with OpenPGP only for GnuPG 1.x."
 807   (skip-unless (string< (cdr (assq 'version (epg-configuration))) "2"))
 808   (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp)
 809   (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp-mime))
 810
 811 (ert-deftest mml-secure-en-decrypt-passphrase-no-cache-smime-todo ()
 812   "Passphrase caching does not work with S/MIME (and gpgsm)."
 813   :expected-result :failed
 814   (if with-smime
 815       (mml-secure-en-decrypt-passphrase-no-cache 'enc-smime)
 816     (should nil)))
 817
 818
 819 ;; Test truncation of question in y-or-n-p.
 820 (defun mml-secure-select-preferred-keys-todo ()
 821   "Manual customization with truncated question."
 822   (mml-secure-test-key-fixture
 823    (lambda ()
 824      (mml-secure-test-en-decrypt
 825       'enc-pgp-mime
 826       "jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de"
 827       "no-exp@example.org" nil t nil nil t))))
 828
 829 (defun mml-secure-select-preferred-keys-ok ()
 830   "Manual customization with entire question."
 831   (mml-secure-test-fixture
 832    (lambda ()
 833      (mml-secure-select-preferred-keys
 834       (epg-make-context 'OpenPGP)
 835       '("jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de")
 836       'encrypt))
 837    t))
 838
 839
 840 ;; ERT entry points
 841 (defun mml-secure-run-tests ()
 842     "Run all tests with defaults."
 843   (ert-run-tests-batch))
 844
 845 (defun mml-secure-run-tests-with-gpg2 ()
 846   "Run all tests with gpg2 instead of gpg."
 847   (let* ((epg-gpg-program "gpg2"); ~/local/gnupg-2.1.9/PLAY/inst/bin/gpg2
 848          (gpg-version (cdr (assq 'version (epg-configuration))))
 849          ;; Empty passphrases do not seem to work with gpgsm in 2.1.x:
 850          ;; https://lists.gnupg.org/pipermail/gnupg-users/2015-October/054575.html
 851          (with-smime (string< gpg-version "2.1")))
 852     (ert-run-tests-batch)))
 853
 854 (defun mml-secure-run-tests-without-smime ()
 855     "Skip S/MIME tests (as they require manual passphrase entry)."
 856   (let ((with-smime nil))
 857     (ert-run-tests-batch)))
 858
 859 ;;; gnustest-mml-sec.el ends here