gpgscm: Emit JUnit-style XML reports.

* tests/gpgscm/Makefile.am (EXTRA_DIST): Add new file.
* tests/gpgscm/lib.scm (string-translate): New function.
* tests/gpgscm/main.c (main): Load new file.
* tests/gpgscm/tests.scm (dirname): New function.
(test-pool): Record execution times, emit XML report.
(test): Record execution times, record log file name, emit XML report.
(run-tests-parallel): Write XML report.
(run-tests-sequential): Likewise.
* tests/gpgscm/xml.scm: New file.
* tests/gpgme/Makefile.am (CLEANFILES): Add 'report.xml'.
* tests/gpgsm/Makefile.am: Likewise.
* tests/migrations/Makefile.am: Likewise.
* tests/openpgp/Makefile.am: Likewise.

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

tests/gpgme/Makefile.am

@@ -50,7 +50,7 @@ xcheck:
 
 EXTRA_DIST = gpgme-defs.scm run-tests.scm setup.scm wrap.scm
 
-CLEANFILES = *.log
+CLEANFILES = *.log report.xml
 
 # We need to depend on a couple of programs so that the tests don't
 # start before all programs are built.

tests/gpgscm/Makefile.am

@@ -25,6 +25,7 @@ EXTRA_DIST = \
 	lib.scm \
 	repl.scm \
 	t-child.scm \
+	xml.scm \
 	tests.scm \
 	gnupg.scm \
 	time.scm

tests/gpgscm/lib.scm

@@ -199,6 +199,13 @@
 (assert (string-contains? "Hallo" "llo"))
 (assert (not (string-contains? "Hallo" "olla")))
 
+;; Translate characters.
+(define (string-translate s from to)
+  (list->string (map (lambda (c)
+		       (let ((i (string-index from c)))
+			 (if i (string-ref to i) c))) (string->list s))))
+(assert (equal? (string-translate "foo/bar" "/" ".") "foo.bar"))
+
 ;; Read a word from port P.
 (define (read-word . p)
   (list->string

tests/gpgscm/main.c

@@ -312,6 +312,8 @@ main (int argc, char **argv)
     err = load (sc, "lib.scm", 0, 1);
   if (! err)
     err = load (sc, "repl.scm", 0, 1);
+  if (! err)
+    err = load (sc, "xml.scm", 0, 1);
   if (! err)
     err = load (sc, "tests.scm", 0, 1);
   if (! err)

tests/gpgscm/tests.scm

@@ -223,6 +223,10 @@
        (substring path 0 (- (string-length path) (string-length suffix)))
        path)))
 
+(define (dirname path)
+  (let ((i (string-rindex path #\/)))
+    (if i (substring path 0 i) ".")))
+
 ;; Helper for (pipe).
 (define :read-end car)
 (define :write-end cadr)
@@ -511,7 +515,9 @@
 	      (let ((names (map (lambda (t) t::name) unfinished))
 		    (pids (map (lambda (t) t::pid) unfinished)))
 		(for-each
-		 (lambda (test retcode) (test:::set! 'retcode retcode))
+		 (lambda (test retcode)
+		   (test::set-end-time!)
+		   (test:::set! 'retcode retcode))
 		 (map pid->test pids)
 		 (wait-processes (map stringify names) pids #t)))))
 	(current-environment))
@@ -539,7 +545,15 @@
 		(length skipped') "skipped.")
 	  (print-tests failed' "Failed tests:")
 	  (print-tests skipped' "Skipped tests:")
-	  (length failed')))))))
+	  (length failed')))
+
+      (define (xml)
+	(xx::document
+	 (xx::tag 'testsuites
+		  `((xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance")
+		    ("xsi:noNamespaceSchemaLocation"
+		     "https://windyroad.com.au/dl/Open%20Source/JUnit.xsd"))
+		  (map (lambda (t) (t::xml)) procs))))))))
 
 (define (verbosity n)
   (if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
@@ -549,6 +563,23 @@
 
 ;; A single test.
 (define test
+ (begin
+
+  ;; Private definitions.
+
+  (define (isotime->junit t)
+    "[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}"
+    "20170418T145809"
+    (string-append (substring t 0 4)
+		   "-"
+		   (substring t 4 6)
+		   "-"
+		   (substring t 6 11)
+		   ":"
+		   (substring t 11 13)
+		   ":"
+		   (substring t 13 15)))
+
   (package
    (define (scm setup name path . args)
      ;; Start the process.
@@ -568,14 +599,34 @@
 
    (define (new name directory spawn pid retcode logfd)
      (package
+
+      ;; XXX: OO glue.
+      (define self (current-environment))
       (define (:set! key value)
 	(eval `(set! ,key ,value) (current-environment))
 	(current-environment))
+
+      ;; The log is written here.
+      (define log-file-name "not set")
+
+      ;; Record time stamps.
+      (define timestamp #f)
+      (define start-time 0)
+      (define end-time 0)
+
+      (define (set-start-time!)
+	(set! timestamp (isotime->junit (get-isotime)))
+	(set! start-time (get-time)))
+      (define (set-end-time!)
+	(set! end-time (get-time)))
+
       (define (open-log-file)
-	(let ((filename (string-append (basename name) ".log")))
+	(set! log-file-name (string-append (basename name) ".log"))
-	  (catch '() (unlink filename))
+	(catch '() (unlink log-file-name))
-	  (open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
+	(open log-file-name (logior O_RDWR O_BINARY O_CREAT) #o600))
+
       (define (run-sync . args)
+	(set-start-time!)
 	(letfd ((log (open-log-file)))
 	  (with-working-directory directory
 	    (let* ((p (inbound-pipe))
@@ -588,25 +639,62 @@
 	(report)
 	(current-environment))
       (define (run-sync-quiet . args)
+	(set-start-time!)
 	(with-working-directory directory
-	  (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD))
+	  (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD)))
-	  (set! retcode (wait-process name pid #t)))
+	(set! retcode (wait-process name pid #t))
+	(set-end-time!)
 	(current-environment))
       (define (run-async . args)
+	(set-start-time!)
 	(let ((log (open-log-file)))
 	  (with-working-directory directory
 	    (set! pid (spawn args CLOSED_FD log log)))
 	  (set! logfd log))
 	(current-environment))
       (define (status)
-	(let ((t (assoc retcode '((0 "PASS") (77 "SKIP") (99 "ERROR")))))
+	(let ((t (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR)))))
-	  (if (not t) "FAIL" (cadr t))))
+	  (if (not t) 'FAIL (cadr t))))
+      (define (status-string)
+	(cadr (assoc (status) '((PASS "PASS")
+			       (SKIP "SKIP")
+			       (ERROR "ERROR")
+			       (FAIL "FAIL")))))
       (define (report)
 	(unless (= logfd CLOSED_FD)
 		(seek logfd 0 SEEK_SET)
 		(splice logfd STDERR_FILENO)
 		(close logfd))
-	(echo (string-append (status) ":") name))))))
+	(echo (string-append (status-string) ":") name))
+
+      (define (xml)
+	(xx::tag
+	 'testsuite
+	 `((name ,name)
+	   (time ,(- end-time start-time))
+	   (package ,(dirname name))
+	   (id 0)
+	   (timestamp ,timestamp)
+	   (hostname "unknown")
+	   (tests 1)
+	   (failures ,(if (eq? FAIL (status)) 1 0))
+	   (errors ,(if (eq? ERROR (status)) 1 0)))
+	 (list
+	  (xx::tag 'properties)
+	  (xx::tag 'testcase
+		   `((name ,(basename name))
+		     (classname ,(string-translate (dirname name) "/" "."))
+		     (time ,(- end-time start-time)))
+		   `(,@(case (status)
+			 ((PASS) '())
+			 ((SKIP) (list (xx::tag 'skipped)))
+			 ((ERROR) (list
+				   (xx::tag 'error '((message "Unknown error.")))))
+			 (else
+			  (list (xx::tag 'failure '((message "Unknown error."))))))))
+	  (xx::tag 'system-out '()
+		   (list (xx::textnode (read-all (open-input-file log-file-name)))))
+	  (xx::tag 'system-err '() (list (xx::textnode "")))))))))))
 
 ;; Run the setup target to create an environment, then run all given
 ;; tests in parallel.
@@ -615,6 +703,7 @@
     (if (null? tests')
 	(let ((results (pool::wait)))
 	  (for-each (lambda (t) (t::report)) (reverse results::procs))
+	  ((results::xml) (open-output-file "report.xml"))
 	  (exit (results::report)))
 	(let ((wd (mkdtemp-autoremove))
 	      (test (car tests')))
@@ -628,6 +717,7 @@
   (let loop ((pool (test-pool::new '())) (tests' tests))
     (if (null? tests')
 	(let ((results (pool::wait)))
+	  ((results::xml) (open-output-file "report.xml"))
 	  (exit (results::report)))
 	(let ((wd (mkdtemp-autoremove))
 	      (test (car tests')))

tests/gpgscm/xml.scm

@@ -0,0 +1,142 @@
+;; A tiny XML library.
+;;
+;; Copyright (C) 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 <http://www.gnu.org/licenses/>.
+
+(define xx
+  (begin
+
+    ;; Private declarations.
+    (define quote-text
+      '((#\< "&lt;")
+	(#\> "&gt;")
+	(#\& "&amp;")))
+
+    (define quote-attribute-'
+      '((#\< "&lt;")
+	(#\> "&gt;")
+	(#\& "&amp;")
+	(#\' "&apos;")))
+
+    (define quote-attribute-''
+      '((#\< "&lt;")
+	(#\> "&gt;")
+	(#\& "&amp;")
+	(#\" "&quot;")))
+
+    (define (escape-string quotation string sink)
+      ;; This implementation is a bit awkward because iteration is so
+      ;; slow in TinySCHEME.  We rely on string-index to skip to the
+      ;; next character we need to escape.  We also avoid allocations
+      ;; wherever possible.
+
+      ;; Given a list of integers or #f, return the sublist that
+      ;; starts with the lowest integer.
+      (define (min* x)
+	(let loop ((lowest x) (rest x))
+	  (if (null? rest)
+	      lowest
+	      (loop (if (or (null? lowest) (not (car lowest))
+			    (and (car rest) (> (car lowest) (car rest)))) rest lowest)
+		    (cdr rest)))))
+
+      (let ((i 0) (start 0) (len (string-length string))
+	    (indices (map (lambda (x) (string-index string (car x))) quotation))
+	    (next #f) (c #f))
+
+	;; Set 'i' to the index of the next character that needs
+	;; escaping, 'c' to the character that needs to be escaped,
+	;; and update 'indices'.
+	(define (skip!)
+	  (set! next (min* indices))
+	  (set! i (if (null? next) #f (car next)))
+	  (if i
+	      (begin
+		(set! c (string-ref string i))
+		(set-car! next (string-index string c (+ 1 i))))
+	      (set! i (string-length string))))
+
+	(let loop ()
+	  (skip!)
+	  (if (< i len)
+	      (begin
+		(display (substring string start i) sink)
+		(display (cadr (assv c quotation)) sink)
+		(set! i (+ 1 i))
+		(set! start i)
+		(loop))
+	      (display (substring string start len) sink)))))
+
+    (let ((escape-string-s (lambda (quotation string)
+			     (let ((sink (open-output-string)))
+			       (escape-string quotation string sink)
+			       (get-output-string sink)))))
+      (assert (equal? (escape-string-s quote-text "foo") "foo"))
+      (assert (equal? (escape-string-s quote-text "foo&") "foo&amp;"))
+      (assert (equal? (escape-string-s quote-text "&foo") "&amp;foo"))
+      (assert (equal? (escape-string-s quote-text "foo&bar") "foo&amp;bar"))
+      (assert (equal? (escape-string-s quote-text "foo<bar") "foo&lt;bar"))
+      (assert (equal? (escape-string-s quote-text "foo>bar") "foo&gt;bar")))
+
+    (define (escape quotation datum sink)
+      (cond
+       ((string? datum) (escape-string quotation datum sink))
+       ((symbol? datum) (escape-string quotation (symbol->string datum) sink))
+       ((number? datum) (display (number->string datum) sink))
+       (else
+	(throw "Do not know how to encode" datum))))
+
+    (define (name->string name)
+      (cond
+       ((symbol? name) (symbol->string name))
+       (else name)))
+
+    (package
+
+     (define (textnode string)
+       (lambda (sink)
+	 (escape quote-text string sink)))
+
+     (define (tag name . rest)
+       (let ((attributes (if (null? rest) '() (car rest)))
+	     (children (if (> (length rest) 1) (cadr rest) '())))
+	 (lambda (sink)
+	   (display "<" sink)
+	   (display (name->string name) sink)
+	   (unless (null? attributes)
+		   (display " " sink)
+		   (for-each (lambda (a)
+			       (display (car a) sink)
+			       (display "=\"" sink)
+			       (escape quote-attribute-'' (cadr a) sink)
+			       (display "\" " sink)) attributes))
+	   (if (null? children)
+	       (display "/>\n" sink)
+	       (begin
+		 (display ">\n" sink)
+		 (for-each (lambda (c) (c sink)) children)
+		 (display "</" sink)
+		 (display (name->string name) sink)
+		 (display ">\n" sink))))))
+
+     (define (document root . rest)
+       (let ((attributes (if (null? rest) '() (car rest))))
+	 (lambda (sink)
+	   ;; xxx ignores attributes
+	   (display "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" sink)
+	   (root sink)
+	   (newline sink)))))))

tests/gpgsm/Makefile.am

@@ -68,7 +68,7 @@ TEST_FILES = plain-1.cms.asc \
 EXTRA_DIST = $(XTESTS) $(KEYS) $(CERTS) $(TEST_FILES) \
 	gpgsm-defs.scm run-tests.scm setup.scm
 
-CLEANFILES = *.log
+CLEANFILES = *.log report.xml
 
 # We need to depend on a couple of programs so that the tests don't
 # start before all programs are built.

tests/migrations/Makefile.am

@@ -58,7 +58,7 @@ xcheck:
 
 EXTRA_DIST = common.scm run-tests.scm setup.scm $(XTESTS) $(TEST_FILES)
 
-CLEANFILES = *.log
+CLEANFILES = *.log report.xml
 
 # We need to depend on a couple of programs so that the tests don't
 # start before all programs are built.

tests/openpgp/Makefile.am

@@ -259,7 +259,7 @@ CLEANFILES = prepared.stamp x y yy z out err  $(data_files) \
 	     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
+	     passphrases sshcontrol S.gpg-agent.ssh report.xml
 
 clean-local:
 	-rm -rf private-keys-v1.d openpgp-revocs.d tofu.d gpgtar.d