gpgscm: Emit JUnit-style XML reports.
authorJustus Winter <justus@g10code.com>
Tue, 18 Apr 2017 16:51:06 +0000 (18:51 +0200)
committerJustus Winter <justus@g10code.com>
Mon, 24 Apr 2017 12:28:57 +0000 (14:28 +0200)
* 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
tests/gpgscm/Makefile.am
tests/gpgscm/lib.scm
tests/gpgscm/main.c
tests/gpgscm/tests.scm
tests/gpgscm/xml.scm [new file with mode: 0644]
tests/gpgsm/Makefile.am
tests/migrations/Makefile.am
tests/openpgp/Makefile.am

index daf7572..37485e7 100644 (file)
@@ -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.
index dc999fb..1bdd373 100644 (file)
@@ -25,6 +25,7 @@ EXTRA_DIST = \
        lib.scm \
        repl.scm \
        t-child.scm \
+       xml.scm \
        tests.scm \
        gnupg.scm \
        time.scm
index cafca8d..258f692 100644 (file)
 (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
index 5e04d97..e4b535e 100644 (file)
@@ -313,6 +313,8 @@ main (int argc, char **argv)
   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)
     err = load (sc, "gnupg.scm", 0, 1);
index b2dcc54..3118977 100644 (file)
        (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)
              (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))
                (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)))))
 
 ;; 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.
 
    (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")))
-         (catch '() (unlink filename))
-         (open filename (logior O_RDWR O_BINARY O_CREAT) #o600)))
+       (set! log-file-name (string-append (basename name) ".log"))
+       (catch '() (unlink log-file-name))
+       (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))
        (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! retcode (wait-process name pid #t)))
+         (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD)))
+       (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")))))
-         (if (not t) "FAIL" (cadr t))))
+       (let ((t (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR)))))
+         (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.
     (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')))
   (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')))
diff --git a/tests/gpgscm/xml.scm b/tests/gpgscm/xml.scm
new file mode 100644 (file)
index 0000000..771ec36
--- /dev/null
@@ -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)))))))
index 214c3b2..892d3bc 100644 (file)
@@ -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.
index e548723..398b15c 100644 (file)
@@ -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.
index 354dff9..a7281a5 100644 (file)
@@ -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