diff --git a/tests/gpgme/Makefile.am b/tests/gpgme/Makefile.am
index d7fd87c71..0d0edc03c 100644
--- a/tests/gpgme/Makefile.am
+++ b/tests/gpgme/Makefile.am
@@ -1,60 +1,57 @@
# Makefile.am - For tests/gpgme
# 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 .
# Process this file with automake to create Makefile.in
# Programs required before we can run these tests.
required_pgms = ../../g10/gpg$(EXEEXT) ../../agent/gpg-agent$(EXEEXT) \
../../tools/gpg-connect-agent$(EXEEXT) \
../gpgscm/gpgscm$(EXEEXT)
AM_CPPFLAGS = -I$(top_srcdir)/common
include $(top_srcdir)/am/cmacros.am
AM_CFLAGS =
-TMP ?= /tmp
-
TESTS_ENVIRONMENT = LC_ALL=C \
EXEEXT=$(EXEEXT) \
PATH=../gpgscm:$(PATH) \
- TMP=$(TMP) \
srcdir=$(abs_srcdir) \
objdir=$(abs_top_builddir) \
GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm:$(abs_top_srcdir)/tests/openpgp:$(abs_top_srcdir)/tests/gpgme
# XXX: Currently, one cannot override automake's 'check' target. As a
# workaround, we avoid defining 'TESTS', thus automake will not emit
# the 'check' target. For extra robustness, we merely define a
# dependency on 'xcheck', so this hack should also work even if
# automake would emit the 'check' target, as adding dependencies to
# targets is okay.
check: xcheck
.PHONY: xcheck
xcheck:
$(TESTS_ENVIRONMENT) $(abs_top_builddir)/tests/gpgscm/gpgscm \
$(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(XTESTS)
EXTRA_DIST = gpgme-defs.scm run-tests.scm setup.scm wrap.scm
CLEANFILES = *.log
# We need to depend on a couple of programs so that the tests don't
# start before all programs are built.
all-local: $(required_pgms)
diff --git a/tests/gpgme/gpgme-defs.scm b/tests/gpgme/gpgme-defs.scm
index c102c9386..7a7166c58 100644
--- a/tests/gpgme/gpgme-defs.scm
+++ b/tests/gpgme/gpgme-defs.scm
@@ -1,144 +1,145 @@
#!/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 .
(load (with-path "defs.scm"))
(define gpgme-srcdir (getenv "XTEST_GPGME_SRCDIR"))
(when (string=? "" gpgme-srcdir)
(info
"SKIP: Environment variable 'XTEST_GPGME_SRCDIR' not set. Please"
"point it to a recent GPGME source tree to run the GPGME test suite.")
(exit 0))
(define (in-gpgme-srcdir . names)
(canonical-path (apply path-join (cons gpgme-srcdir names))))
(define gpgme-builddir (getenv "XTEST_GPGME_BUILDDIR"))
(when (string=? "" gpgme-builddir)
(info
"SKIP: Environment variable 'XTEST_GPGME_BUILDDIR' not set. Please"
"point it to a recent GPGME build tree to run the GPGME test suite.")
(exit 0))
;; Make sure that GPGME picks up our gpgconf. This makes GPGME use
;; and thus executes the tests with GnuPG components from the build
;; tree.
(setenv "PATH" (string-append (path-join (getenv "GNUPG_BUILDDIR") "tools")
(string *pathsep*) (getenv "PATH")) #t)
;; The tests expect the pinentry to return the passphrase "abc".
(setenv "PINENTRY_USER_DATA" "abc" #t)
(define (create-file name content)
(letfd ((fd (open name (logior O_WRONLY O_CREAT O_BINARY) #o600)))
(display content (fdopen fd "wb"))))
(define (create-gpgmehome . path)
(create-file "gpg.conf" "no-force-v3-sigs\n")
(create-file
"gpg-agent.conf"
(string-append "pinentry-program " (tool 'pinentry)))
- (mkdir "private-keys-v1.d" "-rwx")
+
+ (start-agent)
(log "Storing private keys")
(for-each
(lambda (name)
(file-copy (apply in-gpgme-srcdir `(,@path ,name))
(path-join "private-keys-v1.d"
(string-append name ".key"))))
'("13CD0F3BDF24BE53FE192D62F18737256FF6E4FD"
"76F7E2B35832976B50A27A282D9B87E44577EB66"
"A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD"
"13CBE3758AFE42B5E5E2AE4CED27AFA455E3F87F"
"7A030357C0F253A5BBCD282FFC4E521B37558F5C"))
(log "Importing public demo and test keys")
(for-each
(lambda (file)
(call-check `(,@GPG --yes --import ,(apply in-gpgme-srcdir
`(,@path ,file)))))
(list "pubdemo.asc" "secdemo.asc"))
(stop-agent))
;; Initialize the test environment, install appropriate configuration
;; and start the agent, with the keys from the legacy test suite.
(define (setup-gpgme-environment . path)
(if (member "--unpack-tarball" *args*)
(begin
(call-check `(,(tool 'gpgtar) --extract --directory=. ,(cadr *args*)))
(start-agent))
(apply create-gpgme-gpghome path)))
(define (parse-makefile port key)
(define (is-continuation? tokens)
(string=? (last tokens) "\\"))
(define (valid-token? s)
(< 0 (string-length s)))
(define (drop-continuations tokens)
(let loop ((acc '()) (tks tokens))
(if (null? tks)
(reverse acc)
(loop (if (string=? "\\" (car tks))
acc
(cons (car tks) acc)) (cdr tks)))))
(let next ((acc '()) (found #f))
(let ((line (read-line port)))
(if (eof-object? line)
acc
(let ((tokens (filter valid-token?
(string-splitp (string-trim char-whitespace?
line)
char-whitespace? -1))))
(cond
((or (null? tokens)
(string-prefix? (car tokens) "#")
(and (not found) (not (and (string=? key (car tokens))
(string=? "=" (cadr tokens))))))
(next acc found))
((not found)
(assert (and (string=? key (car tokens))
(string=? "=" (cadr tokens))))
(if (is-continuation? tokens)
(next (drop-continuations (cddr tokens)) #t)
(drop-continuations (cddr tokens))))
(else
(assert found)
(if (is-continuation? tokens)
(next (append acc (drop-continuations tokens)) found)
(append acc (drop-continuations tokens))))))))))
(define (parse-makefile-expand filename expand key)
(define (variable? v)
(and (string-prefix? v "$(") (string-suffix? v ")")))
(let expand-all ((values (parse-makefile (open-input-file filename) key)))
(if (any variable? values)
(expand-all
(let expand-one ((acc '()) (v values))
(cond
((null? v)
acc)
((variable? (car v))
(let ((makefile (open-input-file filename))
(key (substring (car v) 2 (- (string-length (car v)) 1))))
(expand-one (append acc (expand filename makefile key))
(cdr v))))
(else
(expand-one (append acc (list (car v))) (cdr v))))))
values)))
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index e5858d960..b3da919d4 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -1,676 +1,675 @@
;; Common definitions for writing tests.
;;
;; 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 .
;; Trace displays and returns the given value. A debugging aid.
(define (trace x)
(display x)
(newline)
x)
;; Stringification.
(define (stringify expression)
(let ((p (open-output-string)))
(write expression p)
(get-output-string p)))
;; Reporting.
(define (echo . msg)
(for-each (lambda (x) (display x) (display " ")) msg)
(newline))
(define (info . msg)
(apply echo msg)
(flush-stdio))
(define (log . msg)
(if (> (*verbose*) 0)
(apply info msg)))
(define (fail . msg)
(apply info msg)
(exit 1))
(define (skip . msg)
(apply info msg)
(exit 77))
(define (make-counter)
(let ((c 0))
(lambda ()
(let ((r c))
(set! c (+ 1 c))
r))))
(define *progress-nesting* 0)
(define (call-with-progress msg what)
(set! *progress-nesting* (+ 1 *progress-nesting*))
(if (= 1 *progress-nesting*)
(begin
(info msg)
(display " > ")
(flush-stdio)
(what (lambda (item)
(display item)
(display " ")
(flush-stdio)))
(info "< "))
(begin
(what (lambda (item) (display ".") (flush-stdio)))
(display " ")
(flush-stdio)))
(set! *progress-nesting* (- *progress-nesting* 1)))
(define (for-each-p msg proc lst . lsts)
(apply for-each-p' `(,msg ,proc ,(lambda (x . xs) x) ,lst ,@lsts)))
(define (for-each-p' msg proc fmt lst . lsts)
(call-with-progress
msg
(lambda (progress)
(apply for-each
`(,(lambda args
(progress (apply fmt args))
(apply proc args))
,lst ,@lsts)))))
;; Process management.
(define CLOSED_FD -1)
(define (call-with-fds what infd outfd errfd)
(wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t))
(define (call what)
(call-with-fds what
CLOSED_FD
(if (< (*verbose*) 0) STDOUT_FILENO CLOSED_FD)
(if (< (*verbose*) 0) STDERR_FILENO CLOSED_FD)))
;; Accessor functions for the results of 'spawn-process'.
(define :stdin car)
(define :stdout cadr)
(define :stderr caddr)
(define :pid cadddr)
(define (call-with-io what in)
(let ((h (spawn-process what 0)))
(es-write (:stdin h) in)
(es-fclose (:stdin h))
(let* ((out (es-read-all (:stdout h)))
(err (es-read-all (:stderr h)))
(result (wait-process (car what) (:pid h) #t)))
(es-fclose (:stdout h))
(es-fclose (:stderr h))
(if (> (*verbose*) 2)
(begin
(echo (stringify what) "returned:" result)
(echo (stringify what) "wrote to stdout:" out)
(echo (stringify what) "wrote to stderr:" err)))
(list result out err))))
;; Accessor function for the results of 'call-with-io'. ':stdout' and
;; ':stderr' can also be used.
(define :retcode car)
(define (call-check what)
(let ((result (call-with-io what "")))
(if (= 0 (:retcode result))
(:stdout result)
(throw (string-append (stringify what) " failed")
(:stderr result)))))
(define (call-popen command input-string)
(let ((result (call-with-io command input-string)))
(if (= 0 (:retcode result))
(:stdout result)
(throw (:stderr result)))))
;;
;; estream helpers.
;;
(define (es-read-all stream)
(let loop
((acc ""))
(if (es-feof stream)
acc
(loop (string-append acc (es-read stream 4096))))))
;;
;; File management.
;;
(define (file-exists? name)
(call-with-input-file name (lambda (port) #t)))
(define (file=? a b)
(file-equal a b #t))
(define (text-file=? a b)
(file-equal a b #f))
(define (file-copy from to)
(catch '() (unlink to))
(letfd ((source (open from (logior O_RDONLY O_BINARY)))
(sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600)))
(splice source sink)))
(define (text-file-copy from to)
(catch '() (unlink to))
(letfd ((source (open from O_RDONLY))
(sink (open to (logior O_WRONLY O_CREAT) #o600)))
(splice source sink)))
(define (path-join . components)
(let loop ((acc #f) (rest (filter (lambda (s)
(not (string=? "" s))) components)))
(if (null? rest)
acc
(loop (if (string? acc)
(string-append acc "/" (car rest))
(car rest))
(cdr rest)))))
(assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz"))
(assert (string=? (path-join "" "bar" "baz") "bar/baz"))
;; Is PATH an absolute path?
(define (absolute-path? path)
(or (char=? #\/ (string-ref path 0))
(and *win32* (char=? #\\ (string-ref path 0)))
(and *win32*
(char-alphabetic? (string-ref path 0))
(char=? #\: (string-ref path 1))
(or (char=? #\/ (string-ref path 2))
(char=? #\\ (string-ref path 2))))))
;; Make PATH absolute.
(define (canonical-path path)
(if (absolute-path? path) path (path-join (getcwd) path)))
(define (in-srcdir . names)
(canonical-path (apply path-join (cons (getenv "srcdir") names))))
;; Try to find NAME in PATHS. Returns the full path name on success,
;; or raises an error.
(define (path-expand name paths)
(let loop ((path paths))
(if (null? path)
(throw "Could not find" name "in" paths)
(let* ((qualified-name (path-join (car path) name))
(file-exists (call-with-input-file qualified-name
(lambda (x) #t))))
(if file-exists
qualified-name
(loop (cdr path)))))))
;; Expand NAME using the gpgscm load path. Use like this:
;; (load (with-path "library.scm"))
(define (with-path name)
(catch name
(path-expand name (string-split (getenv "GPGSCM_PATH") *pathsep*))))
(define (basename path)
(let ((i (string-index path #\/)))
(if (equal? i #f)
path
(basename (substring path (+ 1 i) (string-length path))))))
(define (basename-suffix path suffix)
(basename
(if (string-suffix? path suffix)
(substring path 0 (- (string-length path) (string-length suffix)))
path)))
;; Helper for (pipe).
(define :read-end car)
(define :write-end cadr)
;; let-like macro that manages file descriptors.
;;
;; (letfd )
;;
;; Bind all variables given in and initialize each of them
;; to the given initial value, and close them after evaluting .
(define-macro (letfd bindings . body)
(let bind ((bindings' bindings))
(if (null? bindings')
`(begin ,@body)
(let* ((binding (car bindings'))
(name (car binding))
(initializer (cadr binding)))
`(let ((,name ,initializer))
(finally (close ,name)
,(bind (cdr bindings'))))))))
(define-macro (with-working-directory new-directory . expressions)
(let ((new-dir (gensym))
(old-dir (gensym)))
`(let* ((,new-dir ,new-directory)
(,old-dir (getcwd)))
(dynamic-wind
(lambda () (if ,new-dir (chdir ,new-dir)))
(lambda () ,@expressions)
(lambda () (chdir ,old-dir))))))
;; Make a temporary directory. If arguments are given, they are
;; joined using path-join, and must end in a component ending in
;; "XXXXXX". If no arguments are given, a suitable location and
-;; generic name is used.
+;; generic name is used. Returns an absolute path.
(define (mkdtemp . components)
- (_mkdtemp (if (null? components)
- (path-join (getenv "TMP")
- (string-append "gpgscm-" (get-isotime) "-"
- (basename-suffix *scriptname* ".scm")
- "-XXXXXX"))
- (apply path-join components))))
+ (canonical-path (_mkdtemp (if (null? components)
+ (string-append "gpgscm-" (get-isotime) "-"
+ (basename-suffix *scriptname* ".scm")
+ "-XXXXXX")
+ (apply path-join components)))))
(define-macro (with-temporary-working-directory . expressions)
(let ((tmp-sym (gensym)))
`(let* ((,tmp-sym (mkdtemp)))
(finally (unlink-recursively ,tmp-sym)
(with-working-directory ,tmp-sym
,@expressions)))))
(define (make-temporary-file . args)
(canonical-path (path-join
(mkdtemp)
(if (null? args) "a" (car args)))))
(define (remove-temporary-file filename)
(catch '()
(unlink filename))
(let ((dirname (substring filename 0 (string-rindex filename #\/))))
(catch (echo "removing temporary directory" dirname "failed")
(rmdir dirname))))
;; let-like macro that manages temporary files.
;;
;; (lettmp )
;;
;; Bind all variables given in , initialize each of them to
;; a string representing an unique path in the filesystem, and delete
;; them after evaluting .
(define-macro (lettmp bindings . body)
(let bind ((bindings' bindings))
(if (null? bindings')
`(begin ,@body)
(let ((name (car bindings'))
(rest (cdr bindings')))
`(let ((,name (make-temporary-file ,(symbol->string name))))
(finally (remove-temporary-file ,name)
,(bind rest)))))))
(define (check-execution source transformer)
(lettmp (sink)
(transformer source sink)))
(define (check-identity source transformer)
(lettmp (sink)
(transformer source sink)
(if (not (file=? source sink))
(fail "mismatch"))))
;;
;; Monadic pipe support.
;;
(define pipeM
(package
(define (new procs source sink producer)
(package
(define (dump)
(write (list procs source sink producer))
(newline))
(define (add-proc command pid)
(new (cons (list command pid) procs) source sink producer))
(define (commands)
(map car procs))
(define (pids)
(map cadr procs))
(define (set-source source')
(new procs source' sink producer))
(define (set-sink sink')
(new procs source sink' producer))
(define (set-producer producer')
(if producer
(throw "producer already set"))
(new procs source sink producer'))))))
(define (pipe:do . commands)
(let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands))
(if (null? cmds)
(begin
(if M::producer (M::producer))
(if (not (null? M::procs))
(let* ((retcodes (wait-processes (map stringify (M::commands))
(M::pids) #t))
(results (map (lambda (p r) (append p (list r)))
M::procs retcodes))
(failed (filter (lambda (x) (not (= 0 (caddr x))))
results)))
(if (not (null? failed))
(throw failed))))) ; xxx nicer reporting
(if (and (= 2 (length cmds)) (number? (cadr cmds)))
;; hack: if it's an fd, use it as sink
(let ((M' ((car cmds) (M::set-sink (cadr cmds)))))
(if (> M::source 2) (close M::source))
(if (> (cadr cmds) 2) (close (cadr cmds)))
(loop M' '()))
(let ((M' ((car cmds) M)))
(if (> M::source 2) (close M::source))
(loop M' (cdr cmds)))))))
(define (pipe:open pathname flags)
(lambda (M)
(M::set-source (open pathname flags))))
(define (pipe:defer producer)
(lambda (M)
(let* ((p (outbound-pipe))
(M' (M::set-source (:read-end p))))
(M'::set-producer (lambda ()
(producer (:write-end p))
(close (:write-end p)))))))
(define (pipe:echo data)
(pipe:defer (lambda (sink) (display data (fdopen sink "wb")))))
(define (pipe:spawn command)
(lambda (M)
(define (do-spawn M new-source)
(let ((pid (spawn-process-fd command M::source M::sink
(if (> (*verbose*) 0)
STDERR_FILENO CLOSED_FD)))
(M' (M::set-source new-source)))
(M'::add-proc command pid)))
(if (= CLOSED_FD M::sink)
(let* ((p (pipe))
(M' (do-spawn (M::set-sink (:write-end p)) (:read-end p))))
(close (:write-end p))
(M'::set-sink CLOSED_FD))
(do-spawn M CLOSED_FD))))
(define (pipe:splice sink)
(lambda (M)
(splice M::source sink)
(M::set-source CLOSED_FD)))
(define (pipe:write-to pathname flags mode)
(open pathname flags mode))
;;
;; Monadic transformer support.
;;
(define (tr:do . commands)
(let loop ((tmpfiles '()) (source #f) (cmds commands))
(if (null? cmds)
(for-each remove-temporary-file tmpfiles)
(let* ((v ((car cmds) tmpfiles source))
(tmpfiles' (car v))
(sink (cadr v))
(error (caddr v)))
(if error
(begin
(for-each remove-temporary-file tmpfiles')
(apply throw error)))
(loop tmpfiles' sink (cdr cmds))))))
(define (tr:open pathname)
(lambda (tmpfiles source)
(list tmpfiles pathname #f)))
(define (tr:spawn input command)
(lambda (tmpfiles source)
(if (and (member '**in** command) (not source))
(fail (string-append (stringify cmd) " needs an input")))
(let* ((t (make-temporary-file))
(cmd (map (lambda (x)
(cond
((equal? '**in** x) source)
((equal? '**out** x) t)
(else x))) command)))
(catch (list (cons t tmpfiles) t *error*)
(call-popen cmd input)
(if (and (member '**out** command) (not (file-exists? t)))
(fail (string-append (stringify cmd)
" did not produce '" t "'.")))
(list (cons t tmpfiles) t #f)))))
(define (tr:write-to pathname)
(lambda (tmpfiles source)
(rename source pathname)
(list tmpfiles pathname #f)))
(define (tr:pipe-do . commands)
(lambda (tmpfiles source)
(let ((t (make-temporary-file)))
(apply pipe:do
`(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '())
,@commands
,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600)))
(list (cons t tmpfiles) t #f))))
(define (tr:assert-identity reference)
(lambda (tmpfiles source)
(if (not (file=? source reference))
(fail "mismatch"))
(list tmpfiles source #f)))
(define (tr:assert-weak-identity reference)
(lambda (tmpfiles source)
(if (not (text-file=? source reference))
(fail "mismatch"))
(list tmpfiles source #f)))
(define (tr:call-with-content function . args)
(lambda (tmpfiles source)
(catch (list tmpfiles source *error*)
(apply function `(,(call-with-input-file source read-all) ,@args)))
(list tmpfiles source #f)))
;;
;; Developing and debugging tests.
;;
;; Spawn an os shell.
(define (interactive-shell)
(call-with-fds `(,(getenv "SHELL") -i) 0 1 2))
;;
;; The main test framework.
;;
;; A pool of tests.
(define test-pool
(package
(define (new procs)
(package
(define (add test)
(new (cons test procs)))
(define (wait)
(let ((unfinished (filter (lambda (t) (not t::retcode)) procs)))
(if (null? unfinished)
(package)
(let* ((names (map (lambda (t) t::name) unfinished))
(pids (map (lambda (t) t::pid) unfinished))
(results
(map (lambda (pid retcode) (list pid retcode))
pids
(wait-processes (map stringify names) pids #t))))
(new
(map (lambda (t)
(if t::retcode
t
(t::set-retcode (cadr (assoc t::pid results)))))
procs))))))
(define (passed)
(filter (lambda (p) (= 0 p::retcode)) procs))
(define (skipped)
(filter (lambda (p) (= 77 p::retcode)) procs))
(define (hard-errored)
(filter (lambda (p) (= 99 p::retcode)) procs))
(define (failed)
(filter (lambda (p)
(not (or (= 0 p::retcode) (= 77 p::retcode)
(= 99 p::retcode))))
procs))
(define (report)
(define (print-tests tests message)
(unless (null? tests)
(apply echo (cons message
(map (lambda (t) t::name) tests)))))
(let ((failed' (failed)) (skipped' (skipped)))
(echo (length procs) "tests run,"
(length (passed)) "succeeded,"
(length failed') "failed,"
(length skipped') "skipped.")
(print-tests failed' "Failed tests:")
(print-tests skipped' "Skipped tests:")
(length failed')))))))
(define (verbosity n)
(if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
(define (locate-test path)
(if (absolute-path? path) path (in-srcdir path)))
;; A single test.
(define test
(package
(define (scm name path . args)
;; Start the process.
(define (spawn-scm args' in out err)
(spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
,(locate-test path)
,@args' ,@args) in out err))
(new name #f spawn-scm #f #f CLOSED_FD))
(define (binary name path . args)
;; Start the process.
(define (spawn-binary args' in out err)
(spawn-process-fd `(,path ,@args' ,@args) in out err))
(new name #f spawn-binary #f #f CLOSED_FD))
(define (new name directory spawn pid retcode logfd)
(package
(define (set-directory x)
(new name x spawn pid retcode logfd))
(define (set-retcode x)
(new name directory spawn pid x logfd))
(define (set-pid x)
(new name directory spawn x retcode logfd))
(define (set-logfd x)
(new name directory spawn pid retcode x))
(define (open-log-file)
(let ((filename (string-append (basename name) ".log")))
(catch '() (unlink filename))
(open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
(define (run-sync . args)
(letfd ((log (open-log-file)))
(with-working-directory directory
(let* ((p (inbound-pipe))
(pid (spawn args 0 (:write-end p) (:write-end p))))
(close (:write-end p))
(splice (:read-end p) STDERR_FILENO log)
(close (:read-end p))
(let ((t' (set-retcode (wait-process name pid #t))))
(t'::report)
t')))))
(define (run-sync-quiet . args)
(with-working-directory directory
(set-retcode
(wait-process
name (spawn args CLOSED_FD CLOSED_FD CLOSED_FD) #t))))
(define (run-async . args)
(let ((log (open-log-file)))
(with-working-directory directory
(new name directory spawn
(spawn args CLOSED_FD log log)
retcode log))))
(define (status)
(let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
(if (not t) "FAIL" (cadr t))))
(define (report)
(unless (= logfd CLOSED_FD)
(seek logfd 0 SEEK_SET)
(splice logfd STDERR_FILENO)
(close logfd))
(echo (string-append (status) ":") name))))))
;; Run the setup target to create an environment, then run all given
;; tests in parallel.
(define (run-tests-parallel setup tests)
(lettmp (gpghome-tar)
(setup::run-sync '--create-tarball gpghome-tar)
(let loop ((pool (test-pool::new '())) (tests' tests))
(if (null? tests')
(let ((results (pool::wait)))
(for-each (lambda (t)
(catch (echo "Removing" t::directory "failed:" *error*)
(unlink-recursively t::directory))
(t::report)) (reverse results::procs))
(exit (results::report)))
(let* ((wd (mkdtemp))
(test (car tests'))
(test' (test::set-directory wd)))
(loop (pool::add (test'::run-async '--unpack-tarball gpghome-tar))
(cdr tests')))))))
;; Run the setup target to create an environment, then run all given
;; tests in sequence.
(define (run-tests-sequential setup tests)
(lettmp (gpghome-tar)
(setup::run-sync '--create-tarball gpghome-tar)
(let loop ((pool (test-pool::new '())) (tests' tests))
(if (null? tests')
(let ((results (pool::wait)))
(for-each (lambda (t)
(catch (echo "Removing" t::directory "failed:" *error*)
(unlink-recursively t::directory)))
results::procs)
(exit (results::report)))
(let* ((wd (mkdtemp))
(test (car tests'))
(test' (test::set-directory wd)))
(loop (pool::add (test'::run-sync '--unpack-tarball gpghome-tar))
(cdr tests')))))))
;; Command line flag handling. Returns the elements following KEY in
;; ARGUMENTS up to the next argument, or #f if KEY is not in
;; ARGUMENTS.
(define (flag key arguments)
(cond
((null? arguments)
#f)
((string=? key (car arguments))
(let loop ((acc '())
(args (cdr arguments)))
(if (or (null? args) (string-prefix? (car args) "--"))
(reverse acc)
(loop (cons (car args) acc) (cdr args)))))
((string=? "--" (car arguments))
#f)
(else
(flag key (cdr arguments)))))
(assert (equal? (flag "--xxx" '("--yyy")) #f))
(assert (equal? (flag "--xxx" '("--xxx")) '()))
(assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy")))
(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz")))
(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz")))
(assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy")))
(assert (equal? (flag "--" '("--" "xxx" "yyy" "--" "zzz")) '("xxx" "yyy")))
diff --git a/tests/gpgsm/Makefile.am b/tests/gpgsm/Makefile.am
index aad328bef..28db50133 100644
--- a/tests/gpgsm/Makefile.am
+++ b/tests/gpgsm/Makefile.am
@@ -1,78 +1,75 @@
# Makefile.am - For tests/gpgme
# 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 .
# Process this file with automake to create Makefile.in
# Programs required before we can run these tests.
required_pgms = ../../g10/gpg$(EXEEXT) ../../agent/gpg-agent$(EXEEXT) \
../../tools/gpg-connect-agent$(EXEEXT) \
../gpgscm/gpgscm$(EXEEXT)
AM_CPPFLAGS = -I$(top_srcdir)/common
include $(top_srcdir)/am/cmacros.am
AM_CFLAGS =
-TMP ?= /tmp
-
TESTS_ENVIRONMENT = LC_ALL=C \
EXEEXT=$(EXEEXT) \
PATH=../gpgscm:$(PATH) \
- TMP=$(TMP) \
srcdir=$(abs_srcdir) \
objdir=$(abs_top_builddir) \
GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm:$(abs_top_srcdir)/tests/openpgp:$(abs_top_srcdir)/tests/gpgsm
XTESTS = \
import.scm \
encrypt.scm \
verify.scm \
decrypt.scm \
sign.scm \
export.scm
# XXX: Currently, one cannot override automake's 'check' target. As a
# workaround, we avoid defining 'TESTS', thus automake will not emit
# the 'check' target. For extra robustness, we merely define a
# dependency on 'xcheck', so this hack should also work even if
# automake would emit the 'check' target, as adding dependencies to
# targets is okay.
check: xcheck
.PHONY: xcheck
xcheck:
$(TESTS_ENVIRONMENT) $(abs_top_builddir)/tests/gpgscm/gpgscm \
$(abs_srcdir)/run-tests.scm $(TESTFLAGS) $(XTESTS)
KEYS = 32100C27173EF6E9C4E9A25D3D69F86D37A4F939
CERTS = cert_g10code_test1.der \
cert_dfn_pca01.der \
cert_dfn_pca15.der
TEST_FILES = plain-1.cms.asc \
plain-2.cms.asc \
plain-3.cms.asc \
plain-large.cms.asc
EXTRA_DIST = $(XTESTS) $(KEYS) $(CERTS) $(TEST_FILES) \
gpgsm-defs.scm run-tests.scm setup.scm
CLEANFILES = *.log
# We need to depend on a couple of programs so that the tests don't
# start before all programs are built.
all-local: $(required_pgms)
diff --git a/tests/gpgsm/gpgsm-defs.scm b/tests/gpgsm/gpgsm-defs.scm
index aa5af3d59..5f9be7f0f 100644
--- a/tests/gpgsm/gpgsm-defs.scm
+++ b/tests/gpgsm/gpgsm-defs.scm
@@ -1,103 +1,103 @@
;; Common definitions for the GPGSM test scripts.
;;
;; 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 .
(load (with-path "defs.scm"))
;; This is the list of certificates that we install in the test
;; environment.
(define certs
(package
(define (new fpr issuer-fpr uid)
(package))
(define (new-uid CN OU O L C)
(package))
(define test-1 (new "3CF405464F66ED4A7DF45BBDD1E4282E33BDB76E"
"3CF405464F66ED4A7DF45BBDD1E4282E33BDB76E"
(new-uid "test cert 1"
"Aegypten Project"
"g10 Code GmbH"
"Düsseldorf"
"DE")))))
(define all-certs (list certs::test-1))
(define gpgsm `(,(tool 'gpgsm) --yes)) ;; more/less options
(define (tr:gpgsm input args)
(tr:spawn input `(,@gpgsm --output **out** ,@args **in**)))
(define (pipe:gpgsm args)
(pipe:spawn `(,@gpgsm --output - ,@args -)))
(define (gpgsm-with-colons args)
(let ((s (call-popen `(,@gpgsm --with-colons ,@args) "")))
(map (lambda (line) (string-split line #\:))
(string-split-newlines s))))
(define (sm-have-public-key? key)
(catch #f
(pair? (filter (lambda (l) (and (equal? 'fpr (:type l))
(equal? key::fpr (:fpr l))))
(gpgsm-with-colons `(--list-keys ,key::fpr))))))
(define (sm-have-secret-key? key)
(catch #f
(pair? (filter (lambda (l) (and (equal? 'fpr (:type l))
(equal? key::fpr (:fpr l))))
(gpgsm-with-colons `(--list-secret-keys ,key::fpr))))))
(define (create-file name . lines)
(letfd ((fd (open name (logior O_WRONLY O_CREAT O_BINARY) #o600)))
(let ((port (fdopen fd "wb")))
(for-each (lambda (line) (display line port) (newline port))
lines))))
(define (create-gpgsmhome)
(create-file "gpgsm.conf"
"disable-crl-checks"
"faked-system-time 1008241200")
(create-file "gpg-agent.conf"
(string-append "pinentry-program " (tool 'pinentry)))
+ (start-agent)
(create-file
"trustlist.txt"
"32100C27173EF6E9C4E9A25D3D69F86D37A4F939"
"# CN=test cert 1,OU=Aegypten Project,O=g10 Code GmbH,L=Düsseldorf,C=DE"
"3CF405464F66ED4A7DF45BBDD1E4282E33BDB76E S")
(log "Storing private keys")
- (mkdir "private-keys-v1.d" "-rwx")
(for-each
(lambda (name)
(file-copy (in-srcdir name)
(path-join "private-keys-v1.d"
(string-append name ".key"))))
'("32100C27173EF6E9C4E9A25D3D69F86D37A4F939"))
(log "Importing public demo and test keys")
(call-check `(,@gpgsm --import ,(in-srcdir "cert_g10code_test1.der")))
(create-sample-files)
(stop-agent))
;; Initialize the test environment, install appropriate configuration
;; and start the agent, with the keys from the legacy test suite.
(define (setup-gpgsm-environment)
(if (member "--unpack-tarball" *args*)
(call-check `(,(tool 'gpgtar) --extract --directory=. ,(cadr *args*)))
(create-gpgsm-gpghome))
(start-agent))
diff --git a/tests/migrations/Makefile.am b/tests/migrations/Makefile.am
index d0cd9ee60..0895aff04 100644
--- a/tests/migrations/Makefile.am
+++ b/tests/migrations/Makefile.am
@@ -1,68 +1,65 @@
# Makefile.am - For tests/openpgp
# 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 .
# Process this file with automake to create Makefile.in
# Programs required before we can run these tests.
required_pgms = ../../g10/gpg$(EXEEXT) ../../agent/gpg-agent$(EXEEXT) \
../../tools/gpgtar$(EXEEXT) \
../gpgscm/gpgscm$(EXEEXT)
AM_CPPFLAGS = -I$(top_srcdir)/common
include $(top_srcdir)/am/cmacros.am
AM_CFLAGS =
-TMP ?= /tmp
-
TESTS_ENVIRONMENT = GPG_AGENT_INFO= LC_ALL=C \
EXEEXT=$(EXEEXT) \
PATH=../gpgscm:$(PATH) \
- TMP=$(TMP) \
srcdir=$(abs_srcdir) \
objdir=$(abs_top_builddir) \
GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm:$(abs_top_srcdir)/tests/migrations
XTESTS = from-classic.scm \
extended-pkf.scm \
issue2276.scm
TEST_FILES = from-classic.tar.asc \
extended-pkf.tar.asc \
issue2276.tar.asc
# XXX: Currently, one cannot override automake's 'check' target. As a
# workaround, we avoid defining 'TESTS', thus automake will not emit
# the 'check' target. For extra robustness, we merely define a
# dependency on 'xcheck', so this hack should also work even if
# automake would emit the 'check' target, as adding dependencies to
# targets is okay.
check: xcheck
.PHONY: xcheck
xcheck:
$(TESTS_ENVIRONMENT) $(abs_top_builddir)/tests/gpgscm/gpgscm \
run-tests.scm $(TESTFLAGS) $(XTESTS)
EXTRA_DIST = common.scm run-tests.scm setup.scm $(XTESTS) $(TEST_FILES)
CLEANFILES = *.log
# We need to depend on a couple of programs so that the tests don't
# start before all programs are built.
all-local: $(required_pgms)
diff --git a/tests/migrations/common.scm b/tests/migrations/common.scm
index 30ac62ba1..fa8f1295a 100644
--- a/tests/migrations/common.scm
+++ b/tests/migrations/common.scm
@@ -1,54 +1,60 @@
;; 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 .
(if (string=? "" (getenv "srcdir"))
(error "not called from make"))
(let ((verbose (string->number (getenv "verbose"))))
(if (number? verbose)
(*set-verbose!* verbose)))
(define (qualify executable)
(string-append executable (getenv "EXEEXT")))
;; We may not use a relative name for gpg-agent.
+(define gpgconf (path-join (getenv "objdir") "tools" (qualify "gpgconf")))
(define GPG-AGENT (path-join (getenv "objdir") "agent" (qualify "gpg-agent")))
(define GPG `(,(path-join (getenv "objdir") "g10" (qualify "gpg"))
--no-permission-warning --no-greeting
--no-secmem-warning --batch
,(string-append "--agent-program=" GPG-AGENT
"|--debug-quick-random")))
(define GPG-no-batch
(filter (lambda (arg) (not (equal? arg '--batch))) GPG))
(define GPGTAR (path-join (getenv "objdir") "tools" (qualify "gpgtar")))
(define (untar-armored source-name)
(pipe:do
(pipe:open source-name (logior O_RDONLY O_BINARY))
(pipe:spawn `(,@GPG --dearmor))
(pipe:spawn `(,GPGTAR --extract --directory=. -))))
(define (run-test message src-tarball test)
(catch (skip "gpgtar not built")
(call-check `(,GPGTAR --help)))
(with-temporary-working-directory
(info message)
(untar-armored src-tarball)
(setenv "GNUPGHOME" (getcwd) #t)
- (test (getcwd))))
+
+ (catch (log "Warning: Creating socket directory failed:" (car *error*))
+ (call-popen `(,gpgconf --create-socketdir) ""))
+ (test (getcwd))
+ (catch (log "Warning: Removing socket directory failed.")
+ (call-popen `(,gpgconf --remove-socketdir) ""))))
diff --git a/tests/migrations/extended-pkf.scm b/tests/migrations/extended-pkf.scm
index bf2c49e20..1317cd4f8 100755
--- a/tests/migrations/extended-pkf.scm
+++ b/tests/migrations/extended-pkf.scm
@@ -1,46 +1,38 @@
#!/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 .
(load (with-path "common.scm"))
(catch (skip "gpgtar not built")
(call-check `(,GPGTAR --help)))
-(define src-tarball (in-srcdir "extended-pkf.tar.asc"))
-
-(define (setup)
- (untar-armored src-tarball)
- (setenv "GNUPGHOME" (getcwd) #t))
-
-(define (trigger-migration)
- (call-check `(,@GPG --list-secret-keys)))
-
(define (assert-keys-usable)
(for-each
(lambda (keyid)
(catch (error "Key not found:" keyid)
(call-check `(,@GPG --list-secret-keys ,keyid))))
'("C40FDECF" "ECABF51D")))
-(info "Testing the extended private key format ...")
-(with-temporary-working-directory
- (setup)
- (assert-keys-usable))
+(run-test
+ "Testing the extended private key format ..."
+ (in-srcdir "extended-pkf.tar.asc")
+ (lambda (gpghome)
+ (assert-keys-usable)))
;; XXX try changing a key, and check that the format is not changed.
diff --git a/tests/migrations/from-classic.scm b/tests/migrations/from-classic.scm
index d540470c3..ace458e22 100755
--- a/tests/migrations/from-classic.scm
+++ b/tests/migrations/from-classic.scm
@@ -1,64 +1,61 @@
#!/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 .
(load (with-path "common.scm"))
(catch (skip "gpgtar not built")
(call-check `(,GPGTAR --help)))
-(define src-tarball (in-srcdir "from-classic.tar.asc"))
-
-(define (setup)
- (untar-armored src-tarball)
- (setenv "GNUPGHOME" (getcwd) #t))
-
(define (trigger-migration)
(call-check `(,@GPG --list-secret-keys)))
(define (assert-migrated)
(unless (file-exists? ".gpg-v21-migrated")
(error "Not migrated"))
(for-each
(lambda (keyid)
(catch (error "Key not found:" keyid)
(call-check `(,@GPG --list-secret-keys ,keyid))))
'("D74C5F22" "C40FDECF" "ECABF51D")))
-(info "Testing a clean migration ...")
-(with-temporary-working-directory
- (setup)
- (trigger-migration)
- (assert-migrated))
-
-(info "Testing a migration with existing private-keys-v1.d ...")
-(with-temporary-working-directory
- (setup)
- (mkdir "private-keys-v1.d" "-rwx")
- (trigger-migration)
- (assert-migrated))
-
-(info "Testing a migration with existing but weird private-keys-v1.d ...")
-(with-temporary-working-directory
- (setup)
- (mkdir "private-keys-v1.d" "")
- (trigger-migration)
- (assert-migrated))
+(run-test
+ "Testing a clean migration ..."
+ (in-srcdir "from-classic.tar.asc")
+ (lambda (gpghome)
+ (trigger-migration)
+ (assert-migrated)))
+
+(run-test
+ "Testing a migration with existing private-keys-v1.d ..."
+ (in-srcdir "from-classic.tar.asc")
+ (lambda (gpghome)
+ (mkdir "private-keys-v1.d" "-rwx")
+ (trigger-migration)
+ (assert-migrated)))
+
+(run-test
+ "Testing a migration with existing but weird private-keys-v1.d ..."
+ (in-srcdir "from-classic.tar.asc")
+ (lambda (gpghome)
+ (mkdir "private-keys-v1.d" "")
+ (trigger-migration)
+ (assert-migrated)))
;; XXX Check a case where the migration fails.
diff --git a/tests/openpgp/Makefile.am b/tests/openpgp/Makefile.am
index afac58fc8..518af200c 100644
--- a/tests/openpgp/Makefile.am
+++ b/tests/openpgp/Makefile.am
@@ -1,248 +1,245 @@
# Makefile.am - For tests/openpgp
# Copyright (C) 1998, 1999, 2000, 2001, 2003,
# 2010 Free Software Foundation, Inc.
#
# 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 .
# Process this file with automake to create Makefile.in
# Programs required before we can run these tests.
required_pgms = ../../g10/gpg$(EXEEXT) ../../agent/gpg-agent$(EXEEXT) \
../../tools/gpg-connect-agent$(EXEEXT) \
../gpgscm/gpgscm$(EXEEXT)
AM_CPPFLAGS = -I$(top_srcdir)/common
include $(top_srcdir)/am/cmacros.am
AM_CFLAGS =
noinst_PROGRAMS = fake-pinentry
fake_pinentry_SOURCES = fake-pinentry.c
-TMP ?= /tmp
-
TESTS_ENVIRONMENT = LC_ALL=C \
EXEEXT=$(EXEEXT) \
PATH=../gpgscm:$(PATH) \
- TMP=$(TMP) \
srcdir=$(abs_srcdir) \
objdir=$(abs_top_builddir) \
GPGSCM_PATH=$(abs_top_srcdir)/tests/gpgscm:$(abs_top_srcdir)/tests/openpgp
XTESTS = \
version.scm \
enarmor.scm \
mds.scm \
decrypt.scm \
decrypt-multifile.scm \
decrypt-dsa.scm \
decrypt-session-key.scm \
sigs.scm \
sigs-dsa.scm \
encrypt.scm \
encrypt-multifile.scm \
encrypt-dsa.scm \
compression.scm \
seat.scm \
clearsig.scm \
encryptp.scm \
detach.scm \
detachm.scm \
armsigs.scm \
armencrypt.scm \
armencryptp.scm \
signencrypt.scm \
signencrypt-dsa.scm \
armsignencrypt.scm \
armdetach.scm \
armdetachm.scm \
genkey1024.scm \
conventional.scm \
conventional-mdc.scm \
multisig.scm \
verify.scm \
verify-multifile.scm \
gpgv-forged-keyring.scm \
armor.scm \
import.scm \
import-revocation-certificate.scm \
ecc.scm \
4gb-packet.scm \
tofu.scm \
gpgtar.scm \
use-exact-key.scm \
default-key.scm \
export.scm \
ssh-import.scm \
ssh-export.scm \
quick-key-manipulation.scm \
key-selection.scm \
delete-keys.scm \
gpgconf.scm \
issue2015.scm \
issue2346.scm \
issue2417.scm \
issue2419.scm \
issue2929.scm \
issue2941.scm
# XXX: Currently, one cannot override automake's 'check' target. As a
# workaround, we avoid defining 'TESTS', thus automake will not emit
# the 'check' target. For extra robustness, we merely define a
# dependency on 'xcheck', so this hack should also work even if
# automake would emit the 'check' target, as adding dependencies to
# targets is okay.
check: xcheck
.PHONY: xcheck
xcheck:
$(TESTS_ENVIRONMENT) $(abs_top_builddir)/tests/gpgscm/gpgscm \
run-tests.scm $(TESTFLAGS) $(XTESTS)
TEST_FILES = pubring.asc secring.asc plain-1o.asc plain-2o.asc plain-3o.asc \
plain-1.asc plain-2.asc plain-3.asc plain-1-pgp.asc \
plain-largeo.asc plain-large.asc \
pubring.pkr.asc secring.skr.asc secdemo.asc pubdemo.asc \
gpg.conf.tmpl gpg-agent.conf.tmpl \
bug537-test.data.asc bug894-test.asc \
bug1223-good.asc bug1223-bogus.asc 4gb-packet.asc \
tofu/conflicting/1C005AF3.gpg \
tofu/conflicting/1C005AF3-secret.gpg \
tofu/conflicting/1C005AF3-1.txt \
tofu/conflicting/1C005AF3-2.txt \
tofu/conflicting/1C005AF3-3.txt \
tofu/conflicting/1C005AF3-4.txt \
tofu/conflicting/1C005AF3-5.txt \
tofu/conflicting/B662E42F.gpg \
tofu/conflicting/B662E42F-secret.gpg \
tofu/conflicting/B662E42F-1.txt \
tofu/conflicting/B662E42F-2.txt \
tofu/conflicting/B662E42F-3.txt \
tofu/conflicting/B662E42F-4.txt \
tofu/conflicting/B662E42F-5.txt \
tofu/conflicting/BE04EB2B.gpg \
tofu/conflicting/BE04EB2B-secret.gpg \
tofu/conflicting/BE04EB2B-1.txt \
tofu/conflicting/BE04EB2B-2.txt \
tofu/conflicting/BE04EB2B-3.txt \
tofu/conflicting/BE04EB2B-4.txt \
tofu/conflicting/BE04EB2B-5.txt \
tofu/cross-sigs/EC38277E-secret.gpg \
tofu/cross-sigs/EC38277E-1.gpg \
tofu/cross-sigs/EC38277E-1.txt \
tofu/cross-sigs/EC38277E-2.gpg \
tofu/cross-sigs/EC38277E-2.txt \
tofu/cross-sigs/EC38277E-3.txt \
tofu/cross-sigs/871C2247-secret.gpg \
tofu/cross-sigs/871C2247-1.gpg \
tofu/cross-sigs/871C2247-1.txt \
tofu/cross-sigs/871C2247-2.gpg \
tofu/cross-sigs/871C2247-2.txt \
tofu/cross-sigs/871C2247-3.gpg \
tofu/cross-sigs/871C2247-3.txt \
tofu/cross-sigs/871C2247-4.gpg \
tofu/cross-sigs/README \
key-selection/0.asc \
key-selection/1.asc \
key-selection/2.asc \
key-selection/3.asc \
key-selection/4.asc
data_files = data-500 data-9000 data-32000 data-80000 plain-large
priv_keys = privkeys/50B2D4FA4122C212611048BC5FC31BD44393626E.asc \
privkeys/7E201E28B6FEB2927B321F443205F4724EBE637E.asc \
privkeys/13FDB8809B17C5547779F9D205C45F47CE0217CE.asc \
privkeys/343D8AF79796EE107D645A2787A9D9252F924E6F.asc \
privkeys/8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34.asc \
privkeys/0D6F6AD4C4C803B25470F9104E9F4E6A4CA64255.asc \
privkeys/FD692BD59D6640A84C8422573D469F84F3B98E53.asc \
privkeys/76F7E2B35832976B50A27A282D9B87E44577EB66.asc \
privkeys/A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD.asc \
privkeys/0DD40284FF992CD24DC4AAC367037E066FCEE26A.asc \
privkeys/2BC997C0B8691D41D29A4EC81CCBCF08454E4961.asc \
privkeys/3C9D5ECA70130C2DBB1FC6AC0076BEEEC197716F.asc \
privkeys/449E644892C951A37525654730DD32C202079926.asc \
privkeys/58FFE844087634E62440224908BDE44BEA7EB730.asc \
privkeys/4DF9172D6FF428C97A0E9AA96F03E8BCE3B2F188.asc \
privkeys/9D7CD8F53F2F14C3E2177D1E9D1D11F39513A4A4.asc \
privkeys/6E6B7ED0BD4425018FFC54F3921D5467A3AE00EB.asc \
privkeys/C905D0AB6AE9655C5A35975939997BBF3325D6DD.asc \
privkeys/B2BAA7144303DF19BB6FDE23781DD3FDD97918D4.asc \
privkeys/CF60965BF51F67CF80DECE853E0D2D343468571D.asc \
privkeys/DF00E361D34F80868D06879AC21D7A7D4E4FAD76.asc \
privkeys/00FE67F28A52A8AA08FFAED20AF832DA916D1985.asc \
privkeys/1DF48228FEFF3EC2481B106E0ACA8C465C662CC5.asc \
privkeys/A2832820DC9F40751BDCD375BB0945BA33EC6B4C.asc \
privkeys/ADE710D74409777B7729A7653373D820F67892E0.asc \
privkeys/CEFC51AF91F68A2904FBFF62C4F075A4785B803F.asc \
privkeys/1E28F20E41B54C2D1234D896096495FF57E08D18.asc \
privkeys/EB33B687EB8581AB64D04852A54453E85F3DF62D.asc \
privkeys/C6A6390E9388CDBAD71EAEA698233FE5E04F001E.asc \
privkeys/D69102E0F5AC6B6DB8E4D16DA8E18CF46D88CAE3.asc
sample_keys = samplekeys/README \
samplekeys/ecc-sample-1-pub.asc \
samplekeys/ecc-sample-2-pub.asc \
samplekeys/ecc-sample-3-pub.asc \
samplekeys/ecc-sample-1-sec.asc \
samplekeys/ecc-sample-2-sec.asc \
samplekeys/ecc-sample-3-sec.asc \
samplekeys/eddsa-sample-1-pub.asc \
samplekeys/eddsa-sample-1-sec.asc \
samplekeys/dda252ebb8ebe1af-1.asc \
samplekeys/dda252ebb8ebe1af-2.asc \
samplekeys/whats-new-in-2.1.asc \
samplekeys/e2e-p256-1-clr.asc \
samplekeys/e2e-p256-1-prt.asc \
samplekeys/E657FB607BB4F21C90BB6651BC067AF28BC90111.asc \
samplekeys/rsa-rsa-sample-1.asc \
samplekeys/ed25519-cv25519-sample-1.asc \
samplekeys/silent-running.asc \
samplekeys/ssh-dsa.key \
samplekeys/ssh-ecdsa.key \
samplekeys/ssh-ed25519.key \
samplekeys/ssh-rsa.key \
samplekeys/issue2346.gpg \
samplekeys/authenticate-only.pub.asc \
samplekeys/authenticate-only.sec.asc
sample_msgs = samplemsgs/issue2419.asc \
samplemsgs/clearsig-1-key-1.asc \
samplemsgs/signed-1-key-1.asc \
samplemsgs/revoke-2D727CC768697734.asc
EXTRA_DIST = defs.scm $(XTESTS) $(TEST_FILES) \
mkdemodirs signdemokey $(priv_keys) $(sample_keys) \
$(sample_msgs) ChangeLog-2011 run-tests.scm \
setup.scm shell.scm
CLEANFILES = prepared.stamp x y yy z out err $(data_files) \
plain-1 plain-2 plain-3 trustdb.gpg *.lock .\#lk* \
*.log gpg_dearmor gpg.conf gpg-agent.conf S.gpg-agent \
pubring.gpg pubring.gpg~ pubring.kbx pubring.kbx~ \
secring.gpg pubring.pkr secring.skr \
gnupg-test.stop random_seed gpg-agent.log tofu.db \
passphrases sshcontrol S.gpg-agent.ssh
clean-local:
-rm -rf private-keys-v1.d openpgp-revocs.d tofu.d gpgtar.d
# We need to depend on a couple of programs so that the tests don't
# start before all programs are built.
all-local: $(required_pgms)
diff --git a/tests/openpgp/README b/tests/openpgp/README
index eba77b1ae..b9d560797 100644
--- a/tests/openpgp/README
+++ b/tests/openpgp/README
@@ -1,217 +1,217 @@
# Emacs, this is an -*- org -*- file.
* How to run the test suite
From your build directory, run
obj $ make -C tests/openpgp check
to run all tests or
obj $ make -C tests/openpgp check XTESTS=your-test.scm
to run a specific test (or any number of tests separated by spaces).
If you want to debug a test, add verbose=1 to see messages printed by
spawned programs to their standard error stream, verbose=2 to see what
programs are executed, or verbose=3 to see even more program output
and exit codes.
** Passing options to the test driver
You can set TESTFLAGS to pass flags to 'run-tests.scm'. For example,
to speed up the test suite when bisecting, do
obj $ make -C tests/openpgp check TESTFLAGS=--parallel
See below for the arguments supported by the driver.
** Calling the test driver directly
This is a bit tricky because one needs to manually set some
environment variables. We should make that easier. See discussion
below. From your build directory, do:
- obj $ TMP=/tmp srcdir=/tests/openpgp \
+ obj $ srcdir=/tests/openpgp \
GPGSCM_PATH=/tests/gpgscm:/tests/openpgp \
$(pwd)/tests/gpgscm/gpgscm [gpgscm args] \
run-tests.scm [test suite runner args]
*** Arguments supported by the test suite runner
The test suite runner supports two modes of operation, '--sequential'
and '--parallel'. By default the tests are run in sequential order,
each one in a clean environment.
You can specify the tests to run as positional arguments relative to
srcdir (e.g. just 'version.scm'). Note that you do not have to
specify setup.scm and finish.scm, they are executed implicitly.
The test suite runner can be executed in any location that the current
user can write to. It will create temporary files and directories,
but will in general clean up all of them.
*** Discussion of the various environment variables
**** srcdir
Must be set to the source of the openpgp test suite. Used to locate
data files.
**** GPGSCM_PATH
Used to locate the Scheme library as well as code used by the test
suite.
**** BIN_PREFIX
The test suite does not hardcode any paths to tools. If set it is
used to locate the tools to test, otherwise the test suite assumes to
be run from the build directory.
**** MKTDATA and GPG_PRESET_PASSPHRASE
These two tools are not installed by 'make install', hence we need to
explicitly override their position. In fact, the location of any tool
used by the test suite can be overridden this way. See defs.scm.
**** argv[0]
run-tests.scm depends on being able to re-exec gpgscm. It uses
argv[0] for that. Therefore you must use an absolute path to invoke
gpgscm.
* How to write tests
gpgscm provides a number of functions to aid you in writing tests, as
well as bindings to process management abstractions provided by GnuPG.
For the Scheme environment provided by TinySCHEME, see the TinySCHEME
manual that is included in tests/gpgscm/Manual.txt.
For a quick start, please have a look at various tests that are
already implemented, e.g. 'encrypt.scm'.
** The test framework
The functions info, error, and skip display their first argument and
flush the output buffers. error and skip will also terminate the
process, signaling that the test failed or should be skipped.
(for-each-p msg proc list) will display msg, and call proc with each
element of list while displaying the progress appropriately.
for-each-p' is similar, but accepts another callback before the 'list'
argument to format each item. for-each-p can be safely nested, and
the inner progress indicator will be abbreviated using '.'.
** Debugging tests
Say you are working on a new test called 'your-test.scm', you can run
it on its own using
obj $ make -C tests/openpgp check XTESTS=your-test.scm
but something isn't working as expected. There are several little
gadgets that might help. The first one is 'trace', a function that
prints the value given to it and evaluates to it. E.g.
(trace (+ 2 3))
prints '5' and evaluates to 5. Also, there is an 'assert' macro that
aborts the execution if its argument does not evaluate to a trueish
value. Feel free to express invariants with it.
You can also get an interactive repl by dropping
(interactive-repl (current-environment))
anywhere you like. Or, if you want to examine the environment from an
operating system shell, use
(interactive-shell)
** Interfacing with gpg
defs.scm defines several convenience functions. Say you want to parse
the colon output from gpg, there is gpg-with-colons that splits the
result at newlines and colons, so you can use the result like this:
(define (fpr some-key)
(list-ref (assoc "fpr" (gpg-with-colons
`(--with-fingerprint
--list-secret-keys ,some-key)))
9))
Or if you want to count all non-revoked uids for a given key, do
(define (count-uids-of-secret-key some-key)
(length (filter (lambda (x) (and (string=? "uid" (car x))
(string=? "u" (cadr x))))
(gpg-with-colons
`(--with-fingerprint
--list-secret-keys ,some-key)))))
** Temporary files
(lettmp ) will create and delete temporary files that
you can use in . (with-temporary-working-directory ) will
create a temporary director, change to that, and clean it up after
executing ).
make-temporary-file will create a temporary file. You can optionally
provide an argument to that function that will serve as tag so you can
distinguish the files for debugging. remove-temporary-file will
delete a file created using make-temporary-file.
** Monadic transformer and pipe support
Tests often perform sequential transformations on files, or connect
processes using pipes. To aid you in this, the test framework
provides two monadic data structures.
(Currently, the implementation mashes the 'bind' operation together
with the application of the monad. Also, there is no 'return'
operation. I guess all of that could be implemented on top of
call/cc, but it isn't at the moment.)
*** pipe
The pipe monad constructs pipe lines. It consists of a function
pipe:do that binds the functions together and manages the execution of
the child processes, a family of functions that act as sources, a
function to spawn processes, and a family of functions acting as
sinks.
Sources are pipe:open, pipe:defer, pipe:echo. To spawn a process use
pipe:spawn, or the convenience function pipe:gpg. To sink the data
use pipe:splice, or pipe:write-to.
Example:
(pipe:do
(pipe:echo "3\n1\n2\n")
(pipe:spawn '("/usr/bin/sort"))
(pipe:write-to "sorted" (logior O_WRONLY O_CREAT) #o600))
Caveats: Due to the single-threaded nature of gpgscm you cannot use
both a source and sink that is implemented in Scheme. pipe:defer and
pipe:echo are executing in gpgscm, and so does pipe:splice.
*** tr
The transformer monad describes sequential file transformations.
There is one source function, tr:open. To describe a transformation
using some process, use tr:spawn, tr:gpg, or tr:pipe-do. There are
several sinks, although sink is not quite the right term, because the
data is not consumed, and hence one can use them at any position. The
"sinks" are tr:write-to, tr:call-with-content, tr:assert-identity, and
tr:assert-weak-identity.
A somewhat contrived example demonstrating many functions is:
(tr:do
(tr:pipe-do
(pipe:echo "3\n1\n2\n")
(pipe:spawn '("/usr/bin/sort")))
(tr:write-to "reference")
(tr:call-with-content
(lambda (c)
(echo "currently, c contains" (string-length c) "bytes")))
(tr:spawn "" '("/usr/bin/gcc" -x c "-E" -o **out** **in**))
(tr:pipe-do
(pipe:spawn '("/bin/grep" -v "#")))
(tr:assert-identity "reference"))
Caveats: As a convenience, gpgscm allows one to specify command line
arguments as Scheme symbols. Scheme symbols, however, are
case-insensitive, and get converted to lower case. Therefore, the -E
argument must be given as a string in the example above. Similarly,
you need to quote numerical values.
** Process management
If you just need to execute a single command, there is (call-with-fds
cmdline infd outfd errfd) which executes cmdline with the given file
descriptors bound to it, and waits for its completion returning the
status code. There is (call cmdline) which is similar, but calls the
command with a closed stdin, connecting stdout and stderr to stderr if
gpgscm is executed with --verbose. (call-check cmdline) raises an
exception if the command does not return 0.
(call-popen cmdline input) calls a command, writes input to its stdin,
and returns any output from stdout, or raises an exception containing
stderr on failure.
* Sample messages
diff --git a/tests/openpgp/defs.scm b/tests/openpgp/defs.scm
index a06a570ac..568ffab18 100644
--- a/tests/openpgp/defs.scm
+++ b/tests/openpgp/defs.scm
@@ -1,451 +1,462 @@
;; Common definitions for the OpenPGP test scripts.
;;
;; Copyright (C) 2016, 2017 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 .
;;
;; Constants.
;;
(define usrname1 "one@example.com")
(define usrpass1 "def")
(define usrname2 "two@example.com")
(define usrpass2 "")
(define usrname3 "three@example.com")
(define usrpass3 "")
(define dsa-usrname1 "pgp5")
;; we use the sub key because we do not yet have the logic to derive
;; the first encryption key from a keyblock (I guess) (Well of course
;; we have this by now and the notation below will lookup the primary
;; first and then search for the encryption subkey.)
(define dsa-usrname2 "0xCB879DE9")
(define keys
(package
(define (new fpr grip uids subkeys)
(package))
(define (subkey fpr grip)
(package))
(define alfa (new "A0FF4590BB6122EDEF6E3C542D727CC768697734"
"76F7E2B35832976B50A27A282D9B87E44577EB66"
'("alfa@example.net" "alpha@example.net")
(list
(subkey "3B3FBC948FE59301ED629EFB6AE6D7EE46A871F8"
"A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD"))))
(define one (new "289B0EF1D105E124B6F626020EF77096D74C5F22"
"50B2D4FA4122C212611048BC5FC31BD44393626E"
'("one@example.com")
(list
(subkey "EB467DCA4AD7676A6A62B2ABABAB28A247BE2775"
"7E201E28B6FEB2927B321F443205F4724EBE637E"))))
(define two (new "C1DEBB34EA8B71009EAFA474973D50E1C40FDECF"
"343D8AF79796EE107D645A2787A9D9252F924E6F"
'("two@example.com")
(list
(subkey "CD3D0F5701CBFCACB2A4907305A37887B27907AA"
"8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34"))))))
(define key-file1 "samplekeys/rsa-rsa-sample-1.asc")
(define key-file2 "samplekeys/ed25519-cv25519-sample-1.asc")
(define plain-files '("plain-1" "plain-2" "plain-3" "plain-large"))
(define data-files '("data-500" "data-9000" "data-32000" "data-80000"))
(define exp-files '())
(define all-files (append plain-files data-files))
(let ((verbose (string->number (getenv "verbose"))))
(if (number? verbose)
(*set-verbose!* verbose)))
(define (qualify executable)
(string-append executable (getenv "EXEEXT")))
(define (getenv' key default)
(let ((value (getenv key)))
(if (string=? "" value)
default
value)))
(define (percent-decode s)
(define (decode c)
(if (and (> (length c) 2) (char=? #\% (car c)))
(integer->char (string->number (string #\# #\x (cadr c) (caddr c))))
#f))
(let loop ((i 0) (c (string->list s)) (r (make-string (string-length s))))
(if (null? c)
(substring r 0 i)
(let ((decoded (decode c)))
(string-set! r i (if decoded decoded (car c)))
(loop (+ 1 i) (if decoded (cdddr c) (cdr c)) r)))))
(assert (equal? (percent-decode "") ""))
(assert (equal? (percent-decode "%61") "a"))
(assert (equal? (percent-decode "foob%61r") "foobar"))
(define (percent-encode s)
(define (encode c)
`(#\% ,@(string->list (number->string (char->integer c) 16))))
(let loop ((acc '()) (cs (reverse (string->list s))))
(if (null? cs)
(list->string acc)
(case (car cs)
((#\: #\%)
(loop (append (encode (car cs)) acc) (cdr cs)))
(else
(loop (cons (car cs) acc) (cdr cs)))))))
(assert (equal? (percent-encode "") ""))
(assert (equal? (percent-encode "%61") "%2561"))
(assert (equal? (percent-encode "foob%61r") "foob%2561r"))
(define tools
'((gpgv "GPGV" "g10/gpgv")
(gpg-connect-agent "GPG_CONNECT_AGENT" "tools/gpg-connect-agent")
(gpgconf "GPGCONF" "tools/gpgconf")
(gpg-preset-passphrase "GPG_PRESET_PASSPHRASE"
"agent/gpg-preset-passphrase")
(gpgtar "GPGTAR" "tools/gpgtar")
(gpg-zip "GPGZIP" "tools/gpg-zip")
(pinentry "PINENTRY" "tests/openpgp/fake-pinentry")))
(define bin-prefix (getenv "BIN_PREFIX"))
(define installed? (not (string=? "" bin-prefix)))
(define (tool-hardcoded which)
(let ((t (assoc which tools)))
(getenv' (cadr t)
(qualify (if installed?
(string-append bin-prefix "/" (basename (caddr t)))
(string-append (getenv "objdir") "/" (caddr t)))))))
;; You can splice VALGRIND into your argument vector to run programs
;; under valgrind. For example, to run valgrind on gpg, you may want
;; to redefine gpg:
;;
;; (set! gpg `(,@valgrind ,@gpg))
;;
(define valgrind
'("/usr/bin/valgrind" --leak-check=full --error-exitcode=154))
(define (gpg-conf . args)
(gpg-conf' "" args))
(define (gpg-conf' input args)
(let ((s (call-popen `(,(tool-hardcoded 'gpgconf) ,@args) input)))
(map (lambda (line) (map percent-decode (string-split line #\:)))
(string-split-newlines s))))
(define :gc:c:name car)
(define :gc:c:description cadr)
(define :gc:c:pgmname caddr)
(define (:gc:o:name x) (list-ref x 0))
(define (:gc:o:flags x) (string->number (list-ref x 1)))
(define (:gc:o:level x) (string->number (list-ref x 2)))
(define (:gc:o:description x) (list-ref x 3))
(define (:gc:o:type x) (string->number (list-ref x 4)))
(define (:gc:o:alternate-type x) (string->number (list-ref x 5)))
(define (:gc:o:argument-name x) (list-ref x 6))
(define (:gc:o:default-value x) (list-ref x 7))
(define (:gc:o:default-argument x) (list-ref x 8))
(define (:gc:o:value x) (if (< (length x) 10) "" (list-ref x 9)))
(define (gpg-config component key)
(package
(define (value)
(let* ((conf (assoc key (gpg-conf '--list-options component)))
(type (:gc:o:type conf))
(value (:gc:o:value conf)))
(case type
((0 2 3) (string->number value))
((1 32) (substring value 1 (string-length value))))))
(define (update value)
(let ((value' (cond
((string? value) (string-append "\"" value))
((number? value) (number->string value))
(else (throw "Unsupported value" value)))))
(gpg-conf' (string-append key ":0:" (percent-encode value'))
`(--change-options ,component))))
(define (clear)
(gpg-conf' (string-append key ":16:")
`(--change-options ,component)))))
(unless installed?
(setenv "GNUPG_BUILDDIR" (getenv "objdir") #t))
(define gpg-components (apply gpg-conf
`(,@(if installed? '()
(list '--build-prefix (getenv "objdir")))
--list-components)))
(define (tool which)
(case which
((gpg gpg-agent scdaemon gpgsm dirmngr)
(:gc:c:pgmname (assoc (symbol->string which) gpg-components)))
(else
(tool-hardcoded which))))
(define (gpg-has-option? option)
(string-contains? (call-popen `(,(tool 'gpg) --dump-options) "")
option))
(define have-opt-always-trust
(catch #f
(call-check `(,(tool 'gpg) --gpgconf-test --always-trust))
#t))
(define GPG `(,(tool 'gpg) --no-permission-warning
,@(if have-opt-always-trust '(--always-trust) '())))
(define GPGV `(,(tool 'gpgv)))
(define PINENTRY (tool 'pinentry))
(define (tr:gpg input args)
(tr:spawn input `(,@GPG --output **out** ,@args **in**)))
(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-newlines s))))
;; Convenient accessors for the colon output.
(define (:type x) (string->symbol (list-ref x 0)))
(define (:length x) (string->number (list-ref x 2)))
(define (:alg x) (string->number (list-ref x 3)))
(define (:expire x) (list-ref x 6))
(define (:fpr x) (list-ref x 9))
(define (:cap x) (list-ref x 11))
(define (have-public-key? key)
(catch #f
(pair? (filter (lambda (l) (and (equal? 'fpr (:type l))
(equal? key::fpr (:fpr l))))
(gpg-with-colons `(--list-keys ,key::fpr))))))
(define (have-secret-key? key)
(catch #f
(pair? (filter (lambda (l) (and (equal? 'fpr (:type l))
(equal? key::fpr (:fpr l))))
(gpg-with-colons `(--list-secret-keys ,key::fpr))))))
(define (have-secret-key-file? key)
(file-exists? (path-join (getenv "GNUPGHOME") "private-keys-v1.d"
(string-append key::grip ".key"))))
(define (get-config what)
(string-split (caddar (gpg-with-colons `(--list-config ,what))) #\;))
(define all-pubkey-algos (delay (get-config "pubkeyname")))
(define all-hash-algos (delay (get-config "digestname")))
(define all-cipher-algos (delay (get-config "ciphername")))
(define all-compression-algos (delay (get-config "compressname")))
(define (have-pubkey-algo? x)
(not (not (member x (force all-pubkey-algos)))))
(define (have-hash-algo? x)
(not (not (member x (force all-hash-algos)))))
(define (have-cipher-algo? x)
(not (not (member x (force all-cipher-algos)))))
(define (gpg-pipe args0 args1 errfd)
(lambda (source sink)
(let* ((p (pipe))
(task0 (spawn-process-fd `(,@GPG ,@args0)
source (:write-end p) errfd))
(_ (close (:write-end p)))
(task1 (spawn-process-fd `(,@GPG ,@args1)
(:read-end p) sink errfd)))
(close (:read-end p))
(wait-processes (list GPG GPG) (list task0 task1) #t))))
(setenv "GPG_AGENT_INFO" "" #t)
(setenv "GNUPGHOME" (getcwd) #t)
(define GNUPGHOME (getcwd))
;;
;; GnuPG helper.
;;
+;; Evaluate a sequence of expressions with the given home directory.
+(define-macro (with-home-directory gnupghome . expressions)
+ (let ((original-home-directory (gensym)))
+ `(let ((,original-home-directory (getenv "GNUPGHOME")))
+ (dynamic-wind
+ (lambda () (setenv "GNUPGHOME" ,gnupghome #t))
+ (lambda () ,@expressions)
+ (lambda () (setenv "GNUPGHOME" ,original-home-directory #t))))))
+
;; Evaluate a sequence of expressions with an ephemeral home
;; directory.
(define-macro (with-ephemeral-home-directory . expressions)
(let ((original-home-directory (gensym))
(ephemeral-home-directory (gensym)))
`(let ((,original-home-directory (getenv "GNUPGHOME"))
(,ephemeral-home-directory (mkdtemp)))
(finally (unlink-recursively ,ephemeral-home-directory)
(dynamic-wind
(lambda () (setenv "GNUPGHOME" ,ephemeral-home-directory #t))
(lambda () ,@expressions)
(lambda () (setenv "GNUPGHOME" ,original-home-directory #t)))))))
;; Call GPG to obtain the hash sums. Either specify an input file in
;; ARGS, or an string in INPUT. Returns a list of (
;; "") lists.
(define (gpg-hash-string args input)
(map
(lambda (line)
(let ((p (string-split line #\:)))
(list (string->number (cadr p)) (caddr p))))
(string-split-newlines
(call-popen `(,@GPG --with-colons ,@args) input))))
;; Dearmor a file.
(define (dearmor source-name sink-name)
(pipe:do
(pipe:open source-name (logior O_RDONLY O_BINARY))
(pipe:spawn `(,@GPG --dearmor))
(pipe:write-to sink-name (logior O_WRONLY O_CREAT O_BINARY) #o600)))
;;
;; Support for test environment creation and teardown.
;;
(define (make-test-data filename size)
(call-with-binary-output-file
filename
(lambda (port)
(display (make-random-string size) port))))
(define (create-gpghome)
(log "Creating test environment...")
(srandom (getpid))
(make-test-data "random_seed" 600)
(log "Creating configuration files")
(for-each
(lambda (name)
(file-copy (in-srcdir (string-append name ".tmpl")) name)
(let ((p (open-input-output-file name)))
(cond
((string=? "gpg.conf" name)
(if have-opt-always-trust
(display "no-auto-check-trustdb\n" p))
(display (string-append "agent-program "
(tool 'gpg-agent)
"|--debug-quick-random\n") p)
(display "allow-weak-digest-algos\n" p))
((string=? "gpg-agent.conf" name)
(display (string-append "pinentry-program " PINENTRY "\n") p)))))
'("gpg.conf" "gpg-agent.conf")))
;; Initialize the test environment, install appropriate configuration
;; and start the agent, without any keys.
(define (setup-environment)
(create-gpghome)
(start-agent))
(define (create-sample-files)
(log "Creating sample data files")
(for-each
(lambda (size)
(make-test-data (string-append "data-" (number->string size))
size))
'(500 9000 32000 80000))
(log "Unpacking samples")
(for-each
(lambda (name)
(dearmor (in-srcdir ".." "openpgp" (string-append name "o.asc")) name))
plain-files))
(define (create-legacy-gpghome)
(create-sample-files)
- (mkdir "private-keys-v1.d" "-rwx")
(log "Storing private keys")
(for-each
(lambda (name)
(dearmor (in-srcdir (string-append "/privkeys/" name ".asc"))
(string-append "private-keys-v1.d/" name ".key")))
'("50B2D4FA4122C212611048BC5FC31BD44393626E"
"7E201E28B6FEB2927B321F443205F4724EBE637E"
"13FDB8809B17C5547779F9D205C45F47CE0217CE"
"343D8AF79796EE107D645A2787A9D9252F924E6F"
"8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34"
"0D6F6AD4C4C803B25470F9104E9F4E6A4CA64255"
"FD692BD59D6640A84C8422573D469F84F3B98E53"
"76F7E2B35832976B50A27A282D9B87E44577EB66"
"A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD"
"00FE67F28A52A8AA08FFAED20AF832DA916D1985"
"1DF48228FEFF3EC2481B106E0ACA8C465C662CC5"
"A2832820DC9F40751BDCD375BB0945BA33EC6B4C"
"ADE710D74409777B7729A7653373D820F67892E0"
"CEFC51AF91F68A2904FBFF62C4F075A4785B803F"
"1E28F20E41B54C2D1234D896096495FF57E08D18"
"EB33B687EB8581AB64D04852A54453E85F3DF62D"
"C6A6390E9388CDBAD71EAEA698233FE5E04F001E"
"D69102E0F5AC6B6DB8E4D16DA8E18CF46D88CAE3"))
(log "Importing public demo and test keys")
(for-each
(lambda (file)
(call-check `(,@GPG --yes --import ,(in-srcdir file))))
(list "pubdemo.asc" "pubring.asc" key-file1))
(pipe:do
(pipe:open (in-srcdir "pubring.pkr.asc") (logior O_RDONLY O_BINARY))
(pipe:spawn `(,@GPG --dearmor))
(pipe:spawn `(,@GPG --yes --import))))
(define (preset-passphrases)
(log "Presetting passphrases")
;; one@example.com
(call-check `(,(tool 'gpg-preset-passphrase)
--preset --passphrase def
"50B2D4FA4122C212611048BC5FC31BD44393626E"))
(call-check `(,(tool 'gpg-preset-passphrase)
--preset --passphrase def
"7E201E28B6FEB2927B321F443205F4724EBE637E"))
;; alpha@example.net
(call-check `(,(tool 'gpg-preset-passphrase)
--preset --passphrase abc
"76F7E2B35832976B50A27A282D9B87E44577EB66"))
(call-check `(,(tool 'gpg-preset-passphrase)
--preset --passphrase abc
"A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD")))
;; Initialize the test environment, install appropriate configuration
;; and start the agent, with the keys from the legacy test suite.
(define (setup-legacy-environment)
(create-gpghome)
(if (member "--unpack-tarball" *args*)
(begin
(call-check `(,(tool 'gpgtar) --extract --directory=. ,(cadr *args*)))
(start-agent))
(begin
(start-agent)
(create-legacy-gpghome)))
(preset-passphrases))
;; Create the socket dir and start the agent.
(define (start-agent)
(log "Starting gpg-agent...")
- (atexit stop-agent)
+ (let ((gnupghome (getenv "GNUPGHOME")))
+ (atexit (lambda ()
+ (with-home-directory gnupghome
+ (stop-agent)))))
(catch (log "Warning: Creating socket directory failed:" (car *error*))
(call-popen `(,(tool 'gpgconf) --create-socketdir) ""))
(call-check `(,(tool 'gpg-connect-agent) --verbose
,(string-append "--agent-program=" (tool 'gpg-agent)
"|--debug-quick-random")
/bye)))
;; Stop the agent and remove the socket dir.
(define (stop-agent)
(log "Stopping gpg-agent...")
(catch (log "Warning: Removing socket directory failed.")
(call-popen `(,(tool 'gpgconf) --remove-socketdir) ""))
(call-check `(,(tool 'gpg-connect-agent) --verbose --no-autostart
killagent /bye)))
diff --git a/tests/openpgp/setup.scm b/tests/openpgp/setup.scm
index d13799d90..bf1876e2d 100755
--- a/tests/openpgp/setup.scm
+++ b/tests/openpgp/setup.scm
@@ -1,30 +1,31 @@
#!/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 .
(load (with-path "defs.scm"))
(unless (member "--create-tarball" *args*)
(fail "Usage: setup.scm --create-tarball "))
(with-ephemeral-home-directory
(chdir (getenv "GNUPGHOME"))
(create-gpghome)
+ (start-agent)
(create-legacy-gpghome)
(stop-agent)
(call-check `(,(tool 'gpgtar) --create --output ,(cadr *args*) ".")))