guix_mirror_bot pushed a commit to branch wip-fix-system-tests in repository guix.
commit 35114531e32c91ec2e5e77a363621cea6c128015 Author: Mathieu Othacehe <[email protected]> AuthorDate: Mon Jul 7 19:32:09 2025 +0200 build: Add a system test runner. Change-Id: I79a61e2df996e202ac43a0b6037df676fec4a414 --- Makefile.am | 2 +- build-aux/run-system-tests.scm | 228 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 229 insertions(+), 1 deletion(-) diff --git a/Makefile.am b/Makefile.am index c4906e92f0..50efbb7af0 100644 --- a/Makefile.am +++ b/Makefile.am @@ -722,7 +722,7 @@ endif !CAN_RUN_TESTS check-system: $(GOBJECTS) $(AM_V_at)$(top_builddir)/pre-inst-env \ - guix build -m $(top_srcdir)/etc/manifests/system-tests.scm -K + guix repl -- $(top_srcdir)/build-aux/run-system-tests.scm -K # Public keys used to sign substitutes. dist_pkgdata_DATA = \ diff --git a/build-aux/run-system-tests.scm b/build-aux/run-system-tests.scm new file mode 100644 index 0000000000..5b1a8c2ffc --- /dev/null +++ b/build-aux/run-system-tests.scm @@ -0,0 +1,228 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2025 Mathieu Othacehe <[email protected]> +;;; +;;; 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) + (gnu tests) + (gnu packages package-management) + (guix) + (guix colors) + ((guix build utils) + #:select (delete-file-recursively)) + (guix store) + (guix packages) + (guix utils) + (guix ui) + (guix build syscalls) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 getopt-long) + (ice-9 match) + (ice-9 exceptions) + (ice-9 pretty-print) + (ice-9 rdelim) + (web uri)) + +;; Version of the script. +(define script-version "0.1") + +;; Directory for the system test logs. +(define tmpdir (mkdtemp! "/tmp/system-tests-XXXXXX")) + +;; Save the stdout and stderr ports. +(define output-port (duplicate-port (current-output-port) "w0")) +(define error-port (duplicate-port (current-error-port) "w0")) + +;; List of all the system tests, sorted alphabetically. +(define all-sorted-tests + (sort (all-system-tests) + (lambda (a b) + (string<? (system-test-name a) (system-test-name b))))) + +(define (test->log-file test) + "Return the name of the log file for the given system TEST." + (format #f "~a/~a.log" tmpdir (system-test-name test))) + +(define (print-failure) + "Print a failure message." + (format output-port + (colorize-string "FAIL" (color RED BOLD))) + (format output-port "~%")) + +(define (print-success) + "Print a success message." + (format output-port + (colorize-string "OK" (color GREEN BOLD))) + (format output-port "~%")) + +(define* (run-system-test test #:key redirect-output?) + "Run the given system-test and redirect the test output to a file. +Return true if the test is successful and false otherwise." + (define log-port + (and redirect-output? + (open-output-file (test->log-file test)))) + + (dynamic-wind + (lambda () + (when redirect-output? + (redirect-port log-port (current-output-port)) + (redirect-port log-port (current-warning-port)) + (redirect-port log-port (current-error-port)))) + (lambda () + (parameterize ((current-build-output-port + (if redirect-output? + log-port + (current-build-output-port)))) + (let ((store (open-connection))) + (run-with-store store + (mlet %store-monad + ((drv (lower-object test))) + (return + (guard (c ((store-protocol-error? c) + (print-failure) + #f)) + (and (build-derivations store (list drv)) + (print-success))))))))) + (lambda () + (and redirect-output? + (close-port log-port))))) + +(define* (print-results results #:key keep-logs) + "Use RESULTS, a list of booleans, to print out the test results. If +some tests are failing, exit with the error code 1. Otherwise, exit with +success." + (let* ((ok-count (count identity results)) + (fail-count (- (length results) ok-count))) + (format output-port "~%") + (if keep-logs + (format output-port "Test results are available in ~a~%" tmpdir) + (delete-file-recursively tmpdir)) + (if (= fail-count 0) + (begin + (format output-port "All system tests are successful.~%") + (exit 0)) + (begin + (format output-port "~a failing test~a~%" fail-count + (if (> fail-count 1) "s" "")) + (exit 1))))) + +(define* (run-tests tests #:key keep-logs redirect-output?) + "Run all the given TESTS. If KEEP-LOGS is set to true, keep the system test +log files." + (let* ((count (length tests)) + (indexes (iota count))) + (print-results + (map (lambda (index test) + (format output-port "Running ~a (~a/~a): " + (system-test-name test) + (1+ index) count) + (force-output output-port) + (run-system-test test #:redirect-output? redirect-output?)) + indexes tests) + #:keep-logs keep-logs))) + +(define (subset-tests tests subset) + "Return the subset of TESTS that are also in the given SUBSET list." + (filter + (lambda (test) + (let ((name (system-test-name test))) + (member name subset))) + tests)) + +(define (exclude-tests tests excludes) + "Return the given TESTS list without the tests that are part of the EXCLUDES +list." + (filter + (lambda (test) + (let ((name (system-test-name test))) + (not (member name excludes)))) + tests)) + +(define (show-help) + (display "Usage: run-system-tests.scm [OPTIONS] +Run the system tests.\n") + (display " --tests=TEST1,TEST2,... run only TEST1 and TEST2") + (newline) + (display " --exclude-tests=TEST1,TEST2,... run all tests but TEST1 and TEST2") + (newline) + (display " --list-tests list all the system tests") + (newline) + (display " -n, --no-redirect do not redirect the test logs") + (newline) + (display " -K, --keep-logs keep the test logs") + (newline) + (display " -h, --help display this help and exit") + (newline) + (display " -V, --version display verson information and exit") + (newline)) + +(define %options + '((tests (value #t)) + (exclude-tests (value #t)) + (list-tests (value #f)) + (keep-logs (single-char #\K) (value #f)) + (no-redirect (single-char #\n) (value #f)) + (help (single-char #\h) (value #f)) + (version (single-char #\V) (value #f)))) + +(define (main . args) + (define guix-source + (canonicalize-path + (string-append (current-source-directory) "/.."))) + + ;; Use the local Guix as the current-guix-package so that we do not compute + ;; the Guix derivation over and over. + (define guix-local + (package + (inherit guix) + (source (local-file guix-source #:recursive? #t)) + (arguments + (substitute-keyword-arguments (package-arguments guix) + ((#:tests? #f #f) #f))))) + + (let* ((opts (getopt-long (command-line) %options)) + (option (cut option-ref opts <> <>)) + (keep-logs (option 'keep-logs #f)) + (no-redirect (option 'no-redirect #f))) + (cond + ((option 'help #f) + (show-help)) + ((option 'version #f) + (format #t "run-system-tests.scm ~A~%" script-version)) + ((option 'list-tests #f) + (format #t "System tests:~%~{- ~a~%~}" + (map (lambda (test) + (system-test-name test)) + all-sorted-tests))) + (else + (let* ((subset + (and=> (option 'tests #f) + (cut string-split <> #\,))) + (excludes + (and=> (option 'exclude-tests #f) + (cut string-split <> #\,))) + (tests + (cond + (excludes (exclude-tests all-sorted-tests excludes)) + (subset (subset-tests all-sorted-tests subset)) + (else all-sorted-tests)))) + (parameterize ((current-guix-package guix-local)) + (run-tests tests + #:keep-logs keep-logs + #:redirect-output? (not no-redirect)))))))) + +(apply main (cdr (command-line)))
