mirror of
https://https.git.savannah.gnu.org/git/guix.git/
synced 2025-07-12 01:50:46 +02:00
228 lines
7.9 KiB
Scheme
228 lines
7.9 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
|
;;; Copyright © 2025 Mathieu Othacehe <othacehe@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)
|
|
(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))
|
|
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)))
|