;;; plstore-tests.el --- Test suite for plstore.el -*- lexical-binding: t -*-

;; Copyright (C) 2023 Free Software Foundation, Inc.

;; Author: Jens Schmidt <jschmidt4gnu@vodafonemail.de>
;; Keywords: PGP, GnuPG

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; These tests depend on EPG finding a usable GnuPG configuration with
;; a sufficiently new GnuPG version, see `plstore-tests-set-up-epg'.
;; If EPG cannot find any, this test suite skips all tests requiring
;; GnuPG.

;;; Code:

(require 'cl-lib)
(require 'ert)
(require 'ert-x)
(require 'plstore)

(defconst plstore-tests-recipient "plstore-tests-rcpt")

(defconst plstore-tests-recipient-passphrase "plstore-tests-passphrase")

\f

;;; plist and alist handling.

;; Return whether OBJECT is a valid plstore alist.  That is, a
;; string-indexed alist of plists having keyword symbols as property
;; names.
(defun plstore-tests-alist-p (object)
  (and (listp object)
       (cl-every
        (lambda (entry)
          (and
           (consp entry)
           (stringp (car entry))
           (listp (cdr entry))
           (cl-loop
            for member on (cdr entry) by #'cddr
            for pname  = (car member)
            for kwsymp = (and (symbolp pname)
                              (eq (aref (symbol-name pname) 0) ?:))
            unless kwsymp return nil
            finally return t)))
        object)))

;; Sort PLIST in a stable manner and return the result as a new plist.
;; Assume that all property names are symbols and default a missing
;; trailing property value to nil.
(defun plstore-tests-plist-sort (plist)
  ;; Keep this readable instead of functional: Convert PLIST to an
  ;; alist, sort that, and convert the sorted alist back to a plist.
  (let (alist)
    (setq alist
          (cl-loop
           for member on plist by #'cddr
           collect (cons (symbol-name (car member)) (cadr member))))
    (setq alist
          (cl-stable-sort alist
           #'string-lessp :key #'car))
    (setq plist
          (cl-loop
           for (key . value) in alist
           collect (intern key)
           collect value))
    plist))

;; Sort plstore alist ALIST both on alist and on plist level.  Sort it
;; in a stable manner on all levels and return the result as a new
;; alist, without modifying ALIST.
(defun plstore-tests-alist-sort (alist)
  (cl-stable-sort
   (mapcar
    (lambda (entry)
      (cons (car entry)
            (plstore-tests-plist-sort (cdr entry))))
    alist)
   #'string-lessp :key #'car))

;; Return whether ALIST is a plstore alist and whether it equals
;; (after plstore-alist-sorting) REF-ALIST.
(defun plstore-tests-alists-equal-p (alist ref-alist)
  (and
   (plstore-tests-alist-p alist)
   (equal (plstore-tests-alist-sort alist) ref-alist)))

\f

;;; Passphrase handling.

;; The items on this page care about:
;;
;; - Providing some response to loopbacked passphrase requests; and
;;
;; - tracking whether and which responses have been provided during
;;   execution of some form.

;; Response to provide to passphrase requests done through function
;; `plstore-tests-handle-passphrase-request'.  One of:
;;
;; - `ok': provide the correct passphrase from
;;   `plstore-tests-recipient-passphrase'
;;
;; - `wrong': provide an invalid (empty) passphrase
;;
;; - `quit': quit passphrase request with function `keyboard-quit'
;;
;; - any other symbol: signal an error
;;
;; Let-bound by macro `with-plstore-tests-passphrase' and (as default)
;; by macro `with-plstore-tests'.
(defvar plstore-tests-passphrase-response nil)

;; History of passphrase responses provided through function
;; `plstore-tests-handle-passphrase-request'.  This is a stack of
;; stacks of the collected passphrase responses.
(defvar plstore-tests-passphrase-history nil)

;; Handle a passphrase request according to
;; `plstore-tests-passphrase-response' and record the provided
;; response in `plstore-tests-passphrase-history'.
(defun plstore-tests-handle-passphrase-request ()
  (push plstore-tests-passphrase-response
        (car plstore-tests-passphrase-history))
  (pcase plstore-tests-passphrase-response
    ('ok    (copy-sequence plstore-tests-recipient-passphrase))
    ('wrong "")
    ('quit  (keyboard-quit))
    (_      (error "Invalid passphrase request"))))

;; Let-bind `plstore-tests-passphrase-response' to provide RESPONSE to
;; all passphrase requests done during execution of BODY.  If
;; PASSPHRASE-EXPECTED equals `no', ensure that no passphrases have
;; been requested during execution of BODY, if it equals `yes', ensure
;; that at least one passphrase has been requested, otherwise do not
;; assume anything on the number of passphrase requests.
;;
;; This macro is mostly intended to test for *absence* of passphrase
;; requests, since library `plstore' promises to use decryption and
;; encryption (and, accordingly, to request passphrases) only when
;; actually needed.
;;
;; This could be extended to track presence or absence of requests
;; even more closely, but the rules when to expect requests and when
;; not depend on agent caching and on encryption type, which would
;; make such tests rather tricky.
(cl-defmacro with-plstore-tests-passphrase ((&key
                                             (response ''ok)
                                             (passphrase-expected ''maybe))
                                            &rest body)
  (declare (indent 1) (debug (sexp body)))
  `(unwind-protect
       (let ((plstore-tests-passphrase-response ,response))
         (push nil plstore-tests-passphrase-history)
         ,@body
         (when (eq ,passphrase-expected 'no)
           (should (not (car plstore-tests-passphrase-history))))
         (when (eq ,passphrase-expected 'yes)
           (should (car plstore-tests-passphrase-history))))
     (pop plstore-tests-passphrase-history)))

\f

;;; Test execution infrastructure.

;; Create and return a new plstore test environment from TESTDIR.
;;
;; The test environment is a plist which gets successively filled by
;; the setup functions below with the following members:
;;
;;   :status
;;     Symbol describing environment status.  One of `initial',
;;     `epg-set-up', `gpg-home-directory-set-up', `skip-tests'.
;;   :skip-reason
;;     String describing the reason for the tests to be skipped if
;;     status equals `skip-tests', otherwise nil.
;;   :epg-homedir, :epg-config, :epg-context
;;     Self-explaining.
;;
;; The EPG configuration and context stored in the plstore test
;; environment are used only for the key management done by this test
;; suite, and not for the encryption and decryption operations done by
;; plstore.  For these, plstore sets up its own EPG context mainly
;; from `epg-gpg-home-directory' and `epg-pinentry-mode', which macro
;; `with-plstore-tests' sets as needed.
(defun plstore-tests-make-environment (testdir)
  (list
   :status      'initial
   :skip-reason nil
   :epg-homedir (expand-file-name ".gnupg" testdir)))

;; Set up EPG, determine a usable GnuPG configuration, and store the
;; resulting information in plstore test environment ENVIRONMENT.
;;
;; GnuPG 2.1.5 should already have a usable loopback pinentry (see
;; Info node `(epa) GnuPG version compatibility)', but
;; `epg-gpg2-minimum-version' mentions 2.1.6, so require that.
(defun plstore-tests-set-up-epg (environment)
  (if-let ((config (epg-find-configuration
                    'OpenPGP nil
                    '((OpenPGP epg-gpg-program
                               ("gpg"  . "2.1.6")
                               ("gpg2" . "2.1.6")))))
           (context (epg-make-context 'OpenPGP)))
      (progn
        (setf (epg-context-program context)
              (alist-get 'program config))
        (setf (epg-context-home-directory context)
              (plist-get environment :epg-homedir))
        (setf (epg-context-pinentry-mode context) 'loopback)
        (plist-put environment :epg-config  config)
        (plist-put environment :epg-context context)
        (plist-put environment :status     'epg-set-up))
    (plist-put environment :status      'skip-tests)
    (plist-put environment :skip-reason "no usable GnuPG configuration")))

;; Set up a GnuPG home directory for our tests below the path pointed
;; to by member `:epg-homedir' in plstore test environment
;; ENVIRONMENT.  Use the predefined public and private key from the
;; ERT resources to do so.  Perform a final encrypt-decrypt round-trip
;; test.
;;
;; The keys used below have been created with GnuPG 2.2.7 and exported
;; to the ERT resource directory as follows:
;;
;;   mkdir .gnupgtmphome && chmod 0700 .gnupgtmphome
;;   echo plstore-tests-passphrase |
;;   gpg --homedir .gnupgtmphome --quiet \
;;       --pinentry-mode loopback --passphrase-fd 0 \
;;       --quick-generate-key plstore-tests-rcpt default default 0
;;   gpg --homedir .gnupgtmphome --quiet \
;;       --armor --export plstore-tests-rcpt \
;;       > test/lisp/plstore-resources/plstore-tests.pubkey
;;   echo plstore-tests-passphrase |
;;   gpg --homedir .gnupgtmphome --quiet \
;;       --pinentry-mode loopback --passphrase-fd 0 \
;;       --armor --export-secret-key plstore-tests-rcpt \
;;       > test/lisp/plstore-resources/plstore-tests.seckey
;;   rm -rf .gnupgtmphome
(defun plstore-tests-set-up-gpg-home-directory (environment)
  (let ((homedir (plist-get environment :epg-homedir))
        (context (plist-get environment :epg-context))
        key (state 0) timeout-timer)

    ;; Create GnuPG home directory.
    (make-directory homedir)
    (set-file-modes homedir #o0700)

    ;; Configure passphrase handling to some sane defaults, even if
    ;; these should be already in effect as GnuPG agent defaults,
    ;; since the GnuPG agent gets started anew for every new GnuPG
    ;; home directory.
    (with-temp-file (expand-file-name "gpg-agent.conf" homedir)
      (insert "allow-loopback-pinentry\n")
      (insert "default-cache-ttl 600\n")
      (insert "max-cache-ttl 7200\n"))

    ;; Import and configure keys.  This step, most notably the import
    ;; of the private key, is expensive in terms of wall-clock time.
    (setf (epg-context-passphrase-callback context)
          '((lambda (_ _ _) (copy-sequence plstore-tests-recipient-passphrase))))
    (epg-import-keys-from-file context (ert-resource-file "plstore-tests.pubkey"))
    (epg-import-keys-from-file context (ert-resource-file "plstore-tests.seckey"))
    (setq key (car-safe (epg-list-keys context plstore-tests-recipient)))
    (cl-assert (cl-typep key 'epg-key))
    ;; Trust first subkey of KEY ultimately.
    (epg-edit-key
     context key
     (lambda (context status string _handback)
       (pcase (vector state status string)
         (`[0  "KEY_CONSIDERED" ,_])
         ('[1  "GET_LINE" "keyedit.prompt"]
          (process-send-string (epg-context-process context) "1\n"))
         ('[2  "GOT_IT" ""])
         ('[3  "GET_LINE" "keyedit.prompt"]
          (process-send-string (epg-context-process context) "trust\n"))
         ('[4  "GOT_IT" ""])
         ('[5  "GET_LINE" "edit_ownertrust.value"]
          (process-send-string (epg-context-process context) "5\n"))
         ('[6  "GOT_IT" ""])
         ('[7  "GET_BOOL" "edit_ownertrust.set_ultimate.okay"]
          (process-send-string (epg-context-process context) "yes\n"))
         ('[8  "GOT_IT" ""])
         ('[9  "GET_LINE" "keyedit.prompt"]
          (process-send-string (epg-context-process context) "quit\n"))
         ('[10 "GOT_IT" ""])
         (_
          (error "Key edit protocol error in state %d" state)))
       (setq state (1+ state)))
     nil)

    ;; Ensure an encrypt-decrypt round-trip works, in particular
    ;; without hangs related to GnuPG 2.4.* and its bug T6481.
    (unwind-protect
        (progn
          (setq timeout-timer
                (run-at-time
                 5 nil
                 (lambda ()
                   (when-let
                       ((process (epg-context-process context))
                        ((eq (process-status process) 'run)))
                     (kill-process process)
                     (plist-put environment :status      'skip-tests)
                     (plist-put environment :skip-reason "GnuPG process timeout")))))
          (pcase (condition-case err
                     (equal
                      (epg-decrypt-string
                       context
                       (epg-encrypt-string
                        context "foobarbaz" (list key)))
                      "foobarbaz")
                   (error err))
            ('t   (plist-put environment :status 'gpg-home-directory-set-up))
            ('nil (plist-put environment :status      'skip-tests)
                  (plist-put environment :skip-reason "GnuPG round-trip failure"))
            (err  (unless (eq (plist-get environment :status) 'skip-tests)
                    (plist-put environment :status      'skip-tests)
                    (plist-put environment :skip-reason (error-message-string err))))))
      (cancel-timer timeout-timer))))

;; Set up plstore test environment and execute BODY.  Execute BODY
;; with symmetric encryption if ENCRYPTION-TYPE equals `symmetric',
;; with public-key encryption if ENCRYPTION-TYPE equals `public-key',
;; otherwise execute BODY once for each of these encryption types.
;;
;; BODY can use the following lexical variables:
;;
;;   `plstore-encrypt-to'
;;     Non-nil for public-key encryption, nil for symmetric
;;     encryption.
;;
;;   `plstore-test-directory'
;;     Points to a test directory which is removed after the test.
;;     The test directory is initially empty except for the ".gnupg"
;;     GnuPG home directory.
;;
;;   `plstore-test-file'
;;     Points to a non-existent file below above directory.
;;     Initialized to a different file name for each execution of
;;     BODY.
;;
;;   `plstore'
;;     Scratch variable initialized to nil for each execution of BODY.
;;
;; Any form in BODY that potentially requests a passphrase must be
;; wrapped into an appropriate `with-plstore-tests-passphrase' macro.
;; Passphrase requests done outside that macro result in an error
;; being signaled.
;;
;; Test environment setup includes creation of a temporary GnuPG home
;; directory and startup of a corresponding GnuPG agent, which is a
;; somewhat expensive process in terms of wall-clock time.
;;
;; Started working off a similar macro and the test resources from
;; epg-tests.el, but there is not much left from that, probably.
(cl-defmacro with-plstore-tests ((&key encryption-type)
                                 &rest body)
  (declare (indent 1) (debug (sexp body)))
  `(ert-with-temp-directory testdir
     (let ((environment (plstore-tests-make-environment testdir)))
       ;; Set up plstore test environment.
       (when (eq (plist-get environment :status) 'initial)
         (plstore-tests-set-up-epg environment))
       (when (eq (plist-get environment :status) 'epg-set-up)
         (plstore-tests-set-up-gpg-home-directory environment))
       (when (eq (plist-get environment :status) 'skip-tests)
         (ert-skip (format "EPG or GnuPG setup failed (%s)"
                           (plist-get environment :skip-reason))))
       (cl-assert (eq (plist-get environment :status)
                      'gpg-home-directory-set-up))

       (dolist (recipient
                (pcase ,encryption-type
                  ('symmetric  (list nil))
                  ('public-key (list plstore-tests-recipient))
                  (_           (list nil plstore-tests-recipient))))
         (let (;; Silence plstore.
               (inhibit-message t)
               ;; Set up EPG (for use by plstore) and plstore itself.
               (epg-gpg-home-directory (plist-get environment :epg-homedir))
               (epg-pinentry-mode 'loopback)
               (plstore-encrypt-to recipient)
               (plstore-select-keys 'silent)
               ;; Prepare these to detect passphrase requests done
               ;; outside of any `with-plstore-tests-passphrase'
               ;; macros.
               (plstore-tests-passphrase-response 'error)
               (plstore-tests-passphrase-history '(nil))
               ;; Provide utility variables for BODY.
               (plstore-test-directory testdir)
               (plstore-test-file
                (expand-file-name (if plstore-encrypt-to
                                      (format "auth.%s.plist"
                                              plstore-encrypt-to)
                                    "auth.symmetric.plist")
                                  testdir))
               (plstore nil))
           (cl-letf
               (((symbol-function 'plstore-passphrase-callback-function)
                 (lambda (_ _ _) (plstore-tests-handle-passphrase-request))))
             ;; Silence byte compiler warnings related to unused
             ;; lexical utility variables.
             (when nil
               (ignore plstore-test-directory
                       plstore-test-file
                       plstore))
             ,@body)
           (should (equal plstore-tests-passphrase-history '(nil))))))))

\f

;;; The tests!

;; Ensure the test primitives work as intended.
(ert-deftest plstore-primitives ()
  ;; plstore-tests-alist-p
  (should     (plstore-tests-alist-p nil))
  (should-not (plstore-tests-alist-p 'foo))
  (should-not (plstore-tests-alist-p '(foo)))
  (should-not (plstore-tests-alist-p '((foo   . foo))))
  (should-not (plstore-tests-alist-p '(("foo" . foo))))
  (should-not (plstore-tests-alist-p '(("foo" . ("foo")))))
  (should-not (plstore-tests-alist-p '(("foo" . (foo)))))
  (should     (plstore-tests-alist-p '(("foo" . (:foo)))))
  ;; plstore-tests-plist-sort
  (should (equal (plstore-tests-plist-sort nil) nil))
  (should (equal (plstore-tests-plist-sort '(:foo "foo")) '(:foo "foo")))
  (should (equal (plstore-tests-plist-sort '(:foo "foo" :bar "bar")) '(:bar "bar" :foo "foo")))
  (let* ((plist '(:foo "foo" :baz "baz" :bar "bar"))
         (cars  (copy-sequence plist))
         (cdrs  (cl-maplist #'identity plist)))
    (plstore-tests-plist-sort plist)
    (should (and (cl-every #'eq plist cars)
                 (cl-every #'eq (cl-maplist #'identity plist) cdrs))))
  ;; plstore-tests-alist-sort
  (should (equal (plstore-tests-alist-sort nil) nil))
  (should (equal (plstore-tests-alist-sort '(("foo"))) '(("foo"))))
  (should (equal (plstore-tests-alist-sort '(("foo") ("bar"))) '(("bar") ("foo"))))
  (should (equal (plstore-tests-alist-sort
                  '(("foo" . (:foo "foo"))
                    ("baz" . (:foo "foo" :baz "baz" :bar "bar"))
                    ("bar" . (:foo "foo" :bar "bar"))))
                 '(("bar"  . (:bar "bar" :foo "foo"))
                   ("baz"  . (:bar "bar" :baz "baz" :foo "foo"))
                   ("foo"  . (:foo "foo")))))
  (let* ((alist '(("foo") ("baz") ("bar")))
         (cars  (copy-sequence alist))
         (cdrs  (cl-maplist #'identity alist)))
    (plstore-tests-alist-sort alist)
    (should (and (cl-every #'eq alist cars)
                 (cl-every #'eq (cl-maplist #'identity alist) cdrs)))))

;; Ensure passphrase handling works as intended.
(ert-deftest plstore-passphrase-handling ()
  (with-plstore-tests-passphrase (:passphrase-expected 'maybe)
    (should (string= (plstore-tests-handle-passphrase-request)
                     plstore-tests-recipient-passphrase)))
  (with-plstore-tests-passphrase (:response 'ok
                                  :passphrase-expected 'maybe)
    (should (string= (plstore-tests-handle-passphrase-request)
                     plstore-tests-recipient-passphrase)))
  (with-plstore-tests-passphrase (:response 'wrong
                                  :passphrase-expected 'maybe)
    (should (string= (plstore-tests-handle-passphrase-request) "")))
  (with-plstore-tests-passphrase (:response 'quit
                                  :passphrase-expected 'maybe)
    (should (condition-case nil
                (plstore-tests-handle-passphrase-request)
              (quit t) (:success nil))))
  (with-plstore-tests-passphrase (:passphrase-expected 'no))
  (with-plstore-tests-passphrase (:response 'ok
                                  :passphrase-expected 'yes)
    (plstore-tests-handle-passphrase-request)))

;; Ensure the examples from the plstore.el header come through without
;; errors.
(ert-deftest plstore-example-01 ()
  (with-plstore-tests (:encryption-type 'both)
    (setq plstore (plstore-open plstore-test-file))
    (plstore-put plstore "foo" '(:host "foo.example.org" :port 80) nil)
    (plstore-save plstore)
    (plstore-put plstore "bar" '(:host "bar.example.org") '(:user "test"))
    (plstore-put plstore "baz" '(:host "baz.example.org") '(:password "test"))
    ;; symmetric encryption: 'yes
    ;; public-key encryption: 'no
    (with-plstore-tests-passphrase (:passphrase-expected 'maybe)
      (plstore-save plstore))
    (plstore-close plstore)

    (should
     (> (file-attribute-size (file-attributes plstore-test-file)) 0))

    (setq plstore (plstore-open plstore-test-file))
    (should
     (plstore-tests-alists-equal-p
      (plstore-find plstore '(:host ("foo.example.org")))
      '(("foo" . (:host "foo.example.org" :port 80)))))
    ;; symmetric decryption: 'no (agent cache)
    ;; public-key decryption: 'yes
    (with-plstore-tests-passphrase (:passphrase-expected 'maybe)
      (should
       (plstore-tests-alists-equal-p
        (plstore-find plstore '(:host ("bar.example.org")))
        '(("bar" . (:host "bar.example.org" :user "test"))))))
    ;; symmetric decryption: 'no (agent cache)
    ;; public-key decryption: 'no (agent cache)
    (with-plstore-tests-passphrase (:passphrase-expected 'no)
      (should
       (plstore-tests-alists-equal-p
        (plstore-find plstore '(:host ("baz.example.org")))
        '(("baz" . (:host "baz.example.org" :password "test"))))))
    (plstore-close plstore)))

(provide 'plstore-tests)

;;; plstore-tests.el ends here