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