tests/openpgp: Port the remaining tests to Scheme.

* tests/openpgp/Makefile.am (TESTS): Add new tests.
* tests/openpgp/defs.scm (gpg-with-colons): New function.
(get-config): Use new function.
* tests/openpgp/export.scm: New file.
* tests/openpgp/tofu.scm: Likewise.

Signed-off-by: Justus Winter <justus@g10code.com>

tests/openpgp/Makefile.am

@@ -40,12 +40,6 @@ TESTS_ENVIRONMENT = GNUPGHOME=$(abs_builddir) GPG_AGENT_INFO= LC_ALL=C \
 	objdir=$(abs_top_builddir) \
 	GPGSCM_PATH=$(top_srcdir)/tests/gpgscm:$(top_srcdir)/tests/openpgp
 
-if SQLITE3
-sqlite3_dependent_tests = tofu.test
-else
-sqlite3_dependent_tests =
-endif
-
 # Note: setup.scm needs to be the first test to run and finish.scm
 # the last one
 TESTS = setup.scm \
@@ -79,11 +73,11 @@ TESTS = setup.scm \
 	import.scm \
 	ecc.scm \
 	4gb-packet.scm \
-	$(sqlite3_dependent_tests) \
+	tofu.scm \
 	gpgtar.scm \
 	use-exact-key.scm \
 	default-key.scm \
-	export.test \
+	export.scm \
 	finish.scm
 
 

tests/openpgp/defs.scm

@@ -82,12 +82,13 @@
 (define (pipe:gpg args)
   (pipe:spawn `(,@GPG --output - ,@args -)))
 
+(define (gpg-with-colons args)
+  (let ((s (call-popen `(,@GPG --with-colons ,@args) "")))
+    (map (lambda (line) (string-split line #\:))
+	 (string-split s #\newline))))
+
 (define (get-config what)
-  (let* ((config-string
-	  (call-popen `(,@GPG --with-colons --list-config ,what) ""))
-	 (config (string-splitn
-		  (string-rtrim char-whitespace? config-string) #\: 2)))
-    (string-split (caddr config) #\;)))
+  (string-split (caddar (gpg-with-colons `(--list-config ,what))) #\;))
 
 (define all-pubkey-algos (get-config "pubkeyname"))
 (define all-hash-algos (get-config "digestname"))

tests/openpgp/export.scm

@@ -0,0 +1,99 @@
+#!/usr/bin/env gpgscm
+
+;; Copyright (C) 2016 g10 Code GmbH
+;;
+;; This file is part of GnuPG.
+;;
+;; GnuPG 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.
+;;
+;; GnuPG 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 this program; if not, see <http://www.gnu.org/licenses/>.
+
+(load (with-path "defs.scm"))
+
+(define (check-for predicate lines message)
+  (unless (any predicate lines)
+	  (error message)))
+
+(define (check-exported-key dump keyid)
+  (check-for (lambda (l)
+	       (and (string-prefix? l "	keyid: ")
+		    (string-suffix? l keyid))) dump
+		    "Keyid not found")
+  (check-for (lambda (l) (string-prefix? l ":user ID packet:")) dump
+	     "User ID packet not found")
+  (check-for (lambda (l)
+	       (and (string-prefix? l ":signature packet:")
+		    (string-contains? l "keyid")
+		    (string-suffix? l keyid))) dump
+		    "Signature packet not found"))
+
+(define (check-exported-public-key packet-dump keyid)
+  (let ((dump (string-split packet-dump #\newline)))
+    (check-for (lambda (l) (string-prefix? l ":public key packet:")) dump
+	       "Public key packet not found")
+    (check-exported-key dump keyid)))
+
+(define (check-exported-private-key packet-dump keyid)
+  (let ((dump (string-split packet-dump #\newline)))
+    (check-for (lambda (l) (string-prefix? l ":secret key packet:")) dump
+	       "Secret key packet not found")
+    (check-exported-key dump keyid)))
+
+(lettmp
+ ;; Prepare two temporary files for communication with the fake
+ ;; pinentry program.
+ (logfile ppfile)
+
+ (define (prepare-passphrases . passphrases)
+   (call-with-output-file ppfile
+     (lambda (port)
+       (for-each (lambda (passphrase)
+		   (display passphrase port)
+		   (display #\newline port)) passphrases))))
+
+ (define CONFIRM "fake-entry being started to CONFIRM the weak phrase")
+
+ (define (assert-passphrases-consumed)
+   (call-with-input-file ppfile
+     (lambda (port)
+       (unless
+	(eof-object? (peek-char port))
+	(error (string-append
+		"Expected all passphrases to be consumed, but found: "
+		(read-all port)))))))
+
+ (setenv "PINENTRY_USER_DATA"
+	 (string-append "--logfile=" logfile " --passphrasefile=" ppfile) #t)
+
+ (for-each-p
+  "Checking key export"
+  (lambda (keyid)
+    (tr:do
+     (tr:pipe-do
+      (pipe:gpg `(--export ,keyid))
+      (pipe:gpg '(--list-packets)))
+     (tr:call-with-content check-exported-public-key keyid))
+
+    (if (string=? "D74C5F22" keyid)
+	;; Key D74C5F22 is protected by a passphrase.  Prepare this
+	;; one.  Currently, GnuPG does not ask for an export passphrase
+	;; in this case.
+	(prepare-passphrases usrpass1))
+
+    (tr:do
+     (tr:pipe-do
+      (pipe:gpg `(--export-secret-keys ,keyid))
+      (pipe:gpg '(--list-packets)))
+     (tr:call-with-content check-exported-private-key keyid))
+
+    (assert-passphrases-consumed))
+  '("D74C5F22" "C40FDECF" "ECABF51D")))

tests/openpgp/tofu.scm

@@ -0,0 +1,165 @@
+#!/usr/bin/env gpgscm
+
+;; Copyright (C) 2016 g10 Code GmbH
+;;
+;; This file is part of GnuPG.
+;;
+;; GnuPG 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.
+;;
+;; GnuPG 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 this program; if not, see <http://www.gnu.org/licenses/>.
+
+(load (with-path "defs.scm"))
+
+(define GPG `(,(tool 'gpg) --no-permission-warning)) ;; w/o --always-trust
+(define GNUPGHOME (getenv "GNUPGHOME"))
+(if (string=? "" GNUPGHOME)
+    (error "GNUPGHOME not set"))
+
+(catch (skip "Tofu not supported")
+       (call-check `(,@GPG --trust-model=tofu --list-config)))
+
+(define KEYS '("2183839A" "BC15C85A" "EE37CF96"))
+
+;; Import the test keys.
+(call-check `(,@GPG --import ,(in-srcdir "tofu-keys.asc")))
+
+;; Make sure the keys are imported.
+(for-each (lambda (keyid)
+	    (catch (error "Missing key" keyid)
+		   (call-check `(,@GPG --list-keys ,keyid))))
+	  KEYS)
+
+;; Get tofu policy for KEYID.  Any remaining arguments are simply
+;; passed to GPG.
+;;
+;; This function only supports keys with a single user id.
+(define (getpolicy keyid format . args)
+  (let ((policy
+	 (list-ref (assoc "uid" (gpg-with-colons
+				 `(--tofu-db-format ,format
+				   --trust-model=tofu
+				   ,@args
+				   --list-keys ,keyid))) 17)))
+    (unless (member policy '("auto" "good" "unknown" "bad" "ask"))
+	    (error "Bad policy:" policy))
+    policy))
+
+;; Check that KEYID's tofu policy matches EXPECTED-POLICY.  Any
+;; remaining arguments are simply passed to GPG.
+;;
+;; This function only supports keys with a single user id.
+(define (checkpolicy keyid format expected-policy . args)
+  (let ((policy (apply getpolicy `(,keyid ,format ,@args))))
+    (unless (string=? policy expected-policy)
+	    (error keyid ": Expected policy to be" expected-policy
+		   "but got" policy))))
+
+;; Get the trust level for KEYID.  Any remaining arguments are simply
+;; passed to GPG.
+;;
+;; This function only supports keys with a single user id.
+(define (gettrust keyid format . args)
+  (let ((trust
+	 (list-ref (assoc "pub" (gpg-with-colons
+				 `(--tofu-db-format ,format
+				   --trust-model=tofu
+				   ,@args
+				   --list-keys ,keyid))) 1)))
+    (unless (and (= 1 (string-length trust))
+		 (member (string-ref trust 0) (string->list "oidreqnmfuws-")))
+	    (error "Bad trust value:" trust))
+    trust))
+
+;; Check that KEYID's trust level matches EXPECTED-TRUST.  Any
+;; remaining arguments are simply passed to GPG.
+;;
+;; This function only supports keys with a single user id.
+(define (checktrust keyid format expected-trust . args)
+  (let ((trust (apply gettrust `(,keyid ,format ,@args))))
+    (unless (string=? trust expected-trust)
+	    (error keyid ": Expected trust to be" expected-trust
+		   "but got" trust))))
+
+;; Set key KEYID's policy to POLICY.  Any remaining arguments are
+;; passed as options to gpg.
+(define (setpolicy keyid format policy . args)
+  (call-check `(,@GPG --tofu-db-format ,format
+		      --trust-model=tofu ,@args
+		      --tofu-policy ,policy ,keyid)))
+
+(for-each-p
+ "Testing tofu db formats"
+ (lambda (format)
+   ;; Carefully remove the TOFU db.
+   (catch '() (unlink (string-append GNUPGHOME "/tofu.db")))
+   (catch '() (unlink-recursively (string-append GNUPGHOME "/tofu.d")))
+
+   ;; Verify a message.  There should be no conflict and the trust
+   ;; policy should be set to auto.
+   (call-check `(,@GPG --tofu-db-format ,format --trust-model=tofu
+		       --verify ,(in-srcdir "tofu-2183839A-1.txt")))
+
+   (checkpolicy "2183839A" format "auto")
+   ;; Check default trust.
+   (checktrust "2183839A" format "m")
+
+   ;; Trust should be derived lazily.  Thus, if the policy is set to
+   ;; auto and we change --tofu-default-policy, then the trust should
+   ;; change as well.  Try it.
+   (checktrust "2183839A" format "f" '--tofu-default-policy=good)
+   (checktrust "2183839A" format "-" '--tofu-default-policy=unknown)
+   (checktrust "2183839A" format "n" '--tofu-default-policy=bad)
+
+   ;; Change the policy to something other than auto and make sure the
+   ;; policy and the trust are correct.
+   (for-each-p
+    ""
+    (lambda (policy)
+      (let ((expected-trust
+	     (cond
+	      ((string=? "good" policy) "f")
+	      ((string=? "unknown" policy) "-")
+	      (else "n"))))
+	(setpolicy "2183839A" format policy)
+
+	;; Since we have a fixed policy, the trust level shouldn't
+	;; change if we change the default policy.
+	(for-each-p
+	 ""
+	 (lambda (default-policy)
+	   (checkpolicy "2183839A" format policy
+			'--tofu-default-policy default-policy)
+	   (checktrust "2183839A" format expected-trust
+		       '--tofu-default-policy default-policy))
+	 '("auto" "good" "unknown" "bad" "ask"))))
+    '("good" "unknown" "bad"))
+
+   ;; BC15C85A conflicts with 2183839A.  On conflict, this will set
+   ;; BC15C85A to ask.  If 2183839A is auto (it's not, it's bad), then
+   ;; it will be set to ask.
+   (call-check `(,@GPG --tofu-db-format ,format --trust-model=tofu
+		       --verify ,(in-srcdir "tofu-BC15C85A-1.txt")))
+   (checkpolicy "BC15C85A" format "ask")
+   (checkpolicy "2183839A" format "bad")
+
+   ;; EE37CF96 conflicts with 2183839A and BC15C85A.  We change
+   ;; BC15C85A's policy to auto and leave 2183839A's policy at bad.
+   ;; This conflict should cause BC15C85A's policy to be changed to
+   ;; ask (since it is auto), but not affect 2183839A's policy.
+   (setpolicy "BC15C85A" format "auto")
+   (checkpolicy "BC15C85A" format "auto")
+   (call-check `(,@GPG --tofu-db-format ,format --trust-model=tofu
+		       --verify ,(in-srcdir "tofu-EE37CF96-1.txt")))
+   (checkpolicy "BC15C85A" format "ask")
+   (checkpolicy "2183839A" format "bad")
+   (checkpolicy "EE37CF96" format "ask"))
+ '("split" "flat"))