diff options
Diffstat (limited to 'build-aux/run-system-tests.scm')
| -rw-r--r-- | build-aux/run-system-tests.scm | 135 |
1 files changed, 0 insertions, 135 deletions
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))))))))) |