aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am8
-rw-r--r--build-aux/run-system-tests.scm135
-rw-r--r--etc/system-tests.scm94
3 files changed, 97 insertions, 140 deletions
diff --git a/Makefile.am b/Makefile.am
index e18c17d8b3..3b951be7f5 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 <ludo@gnu.org>
+# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2013 Andreas Enge <andreas@enge.fr>
# Copyright © 2015, 2017 Alex Kost <alezost@gmail.com>
# Copyright © 2016, 2018 Mathieu Lirzin <mthl@gnu.org>
@@ -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 b5403e0ece..0000000000
--- 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 <ludo@gnu.org>
-;;;
-;;; 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 0000000000..ab2827e70a
--- /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 <ludo@gnu.org>
+;;;
+;;; 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)