diff options
| -rw-r--r-- | Makefile.am | 8 | ||||
| -rw-r--r-- | build-aux/run-system-tests.scm | 135 | ||||
| -rw-r--r-- | etc/system-tests.scm | 94 |
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) |