09/09: tests: Add a manifest for system tests.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 5ec4156bbcaec8337f78411204d59e59e706103b
Author: Ludovic Courtès <address@hidden>
AuthorDate: Thu Mar 5 16:16:02 2020 +0100

    tests: Add a manifest for system tests.
    
    The manifest can be passed to 'guix build -m', 'guix weather -m', and so
    on.  It can also be passed to an installed 'guix' (without
    ./pre-inst-env), with the exception so far of installation tests.
    
    * build-aux/run-system-tests.scm: Remove.  Move interesting bits move
    to...
    * etc/system-tests.scm: ... here.  New file.
    * Makefile.am (EXTRA_DIST): Remove 'build-aux/run-system-tests.scm' and
    add 'etc/system-tests.scm'.
    (check-system): Rewrite to run 'guix build -m etc/system-tests.scm'.
---
 Makefile.am                    |   8 +--
 build-aux/run-system-tests.scm | 135 -----------------------------------------
 etc/system-tests.scm           |  94 ++++++++++++++++++++++++++++
 3 files changed, 97 insertions(+), 140 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index e18c17d..3b951be 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès 
<address@hidden>
+# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic 
Courtès <address@hidden>
 # Copyright © 2013 Andreas Enge <address@hidden>
 # Copyright © 2015, 2017 Alex Kost <address@hidden>
 # Copyright © 2016, 2018 Mathieu Lirzin <address@hidden>
@@ -510,9 +510,7 @@ endif !CAN_RUN_TESTS
 
 check-system: $(GOBJECTS)
        $(AM_V_at)$(top_builddir)/pre-inst-env                  \
-          $(GUILE) --no-auto-compile                           \
-          -e '(@@ (run-system-tests) run-system-tests)'        \
-          $(top_srcdir)/build-aux/run-system-tests.scm
+         guix build -m $(top_srcdir)/etc/system-tests.scm -K
 
 # Public keys used to sign substitutes.
 dist_pkgdata_DATA =                            \
@@ -543,6 +541,7 @@ EXTRA_DIST +=                                               
\
   scripts/guix.in                                      \
   etc/guix-install.sh                                  \
   etc/news.scm                                         \
+  etc/system-tests.scm                                 \
   build-aux/build-self.scm                             \
   build-aux/compile-all.scm                            \
   build-aux/hydra/evaluate.scm                         \
@@ -560,7 +559,6 @@ EXTRA_DIST +=                                               
\
   build-aux/test-driver.scm                            \
   build-aux/update-guix-package.scm                    \
   build-aux/update-NEWS.scm                            \
-  build-aux/run-system-tests.scm                       \
   d3.v3.js                                             \
   graph.js                                             \
   tests/test.drv                                       \
diff --git a/build-aux/run-system-tests.scm b/build-aux/run-system-tests.scm
deleted file mode 100644
index b5403e0..0000000
--- a/build-aux/run-system-tests.scm
+++ /dev/null
@@ -1,135 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2018, 2019, 2020 Ludovic Courtès <address@hidden>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (run-system-tests)
-  #:use-module (gnu tests)
-  #:use-module (gnu packages package-management)
-  #:use-module ((gnu ci) #:select (channel-source->package))
-  #:use-module (guix gexp)
-  #:use-module (guix store)
-  #:use-module ((guix status) #:select (with-status-verbosity))
-  #:use-module (guix monads)
-  #:use-module (guix channels)
-  #:use-module (guix derivations)
-  #:use-module ((guix git-download) #:select (git-predicate))
-  #:use-module (guix utils)
-  #:use-module (guix ui)
-  #:use-module (git)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-34)
-  #:use-module (ice-9 match)
-  #:export (run-system-tests))
-
-(define (built-derivations* drv)
-  (lambda (store)
-    (guard (c ((store-protocol-error? c)
-               (values #f store)))
-      (values (build-derivations store drv) store))))
-
-(define (filterm mproc lst)                       ;XXX: move to (guix monads)
-  (with-monad %store-monad
-    (>>= (foldm %store-monad
-                (lambda (item result)
-                  (mlet %store-monad ((keep? (mproc item)))
-                    (return (if keep?
-                                (cons item result)
-                                result))))
-                '()
-                lst)
-         (lift1 reverse %store-monad))))
-
-(define (source-commit directory)
-  "Return the commit of the head of DIRECTORY or #f if it could not be
-determined."
-  (let ((repository #f))
-    (catch 'git-error
-      (lambda ()
-        (set! repository (repository-open directory))
-        (let* ((head   (repository-head repository))
-               (target (reference-target head))
-               (commit (oid->string target)))
-          (repository-close! repository)
-          commit))
-      (lambda _
-        (when repository
-          (repository-close! repository))
-        #f))))
-
-(define (tests-for-current-guix source commit)
-  "Return a list of tests for perform, using Guix built from SOURCE, a channel
-instance."
-  ;; Honor the 'TESTS' environment variable so that one can select a subset
-  ;; of tests to run in the usual way:
-  ;;
-  ;;   make check-system TESTS=installed-os
-  (parameterize ((current-guix-package
-                  (channel-source->package source #:commit commit)))
-    (match (getenv "TESTS")
-      (#f
-       (all-system-tests))
-      ((= string-tokenize (tests ...))
-       (filter (lambda (test)
-                 (member (system-test-name test) tests))
-               (all-system-tests))))))
-
-(define (run-system-tests . args)
-  (define source
-    (string-append (current-source-directory) "/.."))
-
-  (define commit
-    ;; Fetch the current commit ID so we can potentially build the same
-    ;; derivation as ci.guix.gnu.org.
-    (source-commit source))
-
-  (with-store store
-    (with-status-verbosity 2
-      (run-with-store store
-        ;; Intern SOURCE so that 'build-from-source' in (guix channels) sees
-        ;; "fresh" file names and thus doesn't find itself loading .go files
-        ;; from ~/.cache/guile when it loads 'build-aux/build-self.scm'.
-        (mlet* %store-monad ((source -> (local-file source "guix-source"
-                                                    #:recursive? #t
-                                                    #:select?
-                                                    (or (git-predicate source)
-                                                        (const #t))))
-                             (tests ->  (tests-for-current-guix source commit))
-                             (drv (mapm %store-monad system-test-value tests))
-                             (out -> (map derivation->output-path drv)))
-          (format (current-error-port) "Running ~a system tests...~%"
-                  (length tests))
-
-          (mbegin %store-monad
-            (show-what-to-build* drv)
-            (set-build-options* #:keep-going? #t #:keep-failed? #t
-                                #:print-build-trace #t
-                                #:print-extended-build-trace? #t
-                                #:fallback? #t)
-            (built-derivations* drv)
-            (mlet %store-monad ((valid  (filterm (store-lift valid-path?)
-                                                 out))
-                                (failed (filterm (store-lift
-                                                  (negate valid-path?))
-                                                 out)))
-              (format #t "TOTAL: ~a\n" (length drv))
-              (for-each (lambda (item)
-                          (format #t "PASS: ~a~%" item))
-                        valid)
-              (for-each (lambda (item)
-                          (format #t "FAIL: ~a~%" item))
-                        failed)
-              (exit (null? failed)))))))))
diff --git a/etc/system-tests.scm b/etc/system-tests.scm
new file mode 100644
index 0000000..ab2827e
--- /dev/null
+++ b/etc/system-tests.scm
@@ -0,0 +1,94 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016, 2018, 2019, 2020 Ludovic Courtès <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(use-modules (gnu tests)
+             (gnu packages package-management)
+             ((gnu ci) #:select (channel-source->package))
+             ((guix git-download) #:select (git-predicate))
+             ((guix utils) #:select (current-source-directory))
+             (git)
+             (ice-9 match))
+
+(define (source-commit directory)
+  "Return the commit of the head of DIRECTORY or #f if it could not be
+determined."
+  (let ((repository #f))
+    (catch 'git-error
+      (lambda ()
+        (set! repository (repository-open directory))
+        (let* ((head   (repository-head repository))
+               (target (reference-target head))
+               (commit (oid->string target)))
+          (repository-close! repository)
+          commit))
+      (lambda _
+        (when repository
+          (repository-close! repository))
+        #f))))
+
+(define (tests-for-current-guix source commit)
+  "Return a list of tests for perform, using Guix built from SOURCE, a channel
+instance."
+  ;; Honor the 'TESTS' environment variable so that one can select a subset
+  ;; of tests to run in the usual way:
+  ;;
+  ;;   make check-system TESTS=installed-os
+  (parameterize ((current-guix-package
+                  (channel-source->package source #:commit commit)))
+    (match (getenv "TESTS")
+      (#f
+       (all-system-tests))
+      ((= string-tokenize (tests ...))
+       (filter (lambda (test)
+                 (member (system-test-name test) tests))
+               (all-system-tests))))))
+
+(define (system-test->manifest-entry test)
+  "Return a manifest entry for TEST, a system test."
+  (manifest-entry
+    (name (string-append "test." (system-test-name test)))
+    (version "0")
+    (item test)))
+
+(define (system-test-manifest)
+  "Return a manifest containing all the system tests, or all those selected by
+the 'TESTS' environment variable."
+  (define source
+    (string-append (current-source-directory) "/.."))
+
+  (define commit
+    ;; Fetch the current commit ID so we can potentially build the same
+    ;; derivation as ci.guix.gnu.org.
+    (source-commit source))
+
+  ;; Intern SOURCE so that 'build-from-source' in (guix channels) sees
+  ;; "fresh" file names and thus doesn't find itself loading .go files
+  ;; from ~/.cache/guile when it loads 'build-aux/build-self.scm'.
+  (let* ((source (local-file source "guix-source"
+                             #:recursive? #t
+                             #:select?
+                             (or (git-predicate source)
+                                 (const #t))))
+         (tests  (tests-for-current-guix source commit)))
+    (format (current-error-port) "Selected ~a system tests...~%"
+            (length tests))
+
+    (manifest (map system-test->manifest-entry tests))))
+
+;; Return the manifest.
+(system-test-manifest)