mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-02-07 11:29:59 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

tests: "make check-system" includes the current commit ID, if any.

Browse source 
* build-aux/run-system-tests.scm (source-commit): New procedure.
(tests-for-current-guix): Add 'commit' parameter and pass it to
'channel-source->package'.
(run-system-tests): Call 'source-commit' and pass the result to
'tests-for-current-guix'.
This commit is contained in:
Ludovic Courtès 2020-03-05 14:54:17 +01:00
parent dd1ee160be
commit c5a3d8f646
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 26 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
build-aux/run-system-tests.scm
View file

@ -29,6 +29,7 @@
#:use-module ((guix git-download) #:select (git-predicate)) #:use-module ((guix git-download) #:select (git-predicate))
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix ui) #:use-module (guix ui)
#:use-module (git)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -52,7 +53,24 @@
lst) lst)
(lift1 reverse %store-monad)))) (lift1 reverse %store-monad))))
(define (tests-for-current-guix source) (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 "Return a list of tests for perform, using Guix built from SOURCE, a channel
instance." instance."
;; Honor the 'TESTS' environment variable so that one can select a subset ;; Honor the 'TESTS' environment variable so that one can select a subset
@ -60,7 +78,7 @@ instance."
;; ;;
;; make check-system TESTS=installed-os ;; make check-system TESTS=installed-os
(parameterize ((current-guix-package (parameterize ((current-guix-package
(channel-source->package source))) (channel-source->package source #:commit commit)))
(match (getenv "TESTS") (match (getenv "TESTS")
(#f (#f
(all-system-tests)) (all-system-tests))
@ -69,12 +87,15 @@ instance."
(member (system-test-name test) tests)) (member (system-test-name test) tests))
(all-system-tests)))))) (all-system-tests))))))
(define (run-system-tests . args) (define (run-system-tests . args)
(define source (define source
(string-append (current-source-directory) "/..")) (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-store store
(with-status-verbosity 2 (with-status-verbosity 2
(run-with-store store (run-with-store store
@ -86,7 +107,7 @@ instance."
#:select? #:select?
(or (git-predicate source) (or (git-predicate source)
(const #t)))) (const #t))))
(tests -> (tests-for-current-guix source)) (tests -> (tests-for-current-guix source commit))
(drv (mapm %store-monad system-test-value tests)) (drv (mapm %store-monad system-test-value tests))
(out -> (map derivation->output-path drv))) (out -> (map derivation->output-path drv)))
(format (current-error-port) "Running ~a system tests...~%" (format (current-error-port) "Running ~a system tests...~%"