Commit | Line | Data |
---|---|---|
5ec4156b LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (use-modules (gnu tests) | |
20 | (gnu packages package-management) | |
dbde3867 LC |
21 | (guix monads) |
22 | (guix store) | |
5ec4156b LC |
23 | ((gnu ci) #:select (channel-source->package)) |
24 | ((guix git-download) #:select (git-predicate)) | |
25 | ((guix utils) #:select (current-source-directory)) | |
26 | (git) | |
27 | (ice-9 match)) | |
28 | ||
29 | (define (source-commit directory) | |
30 | "Return the commit of the head of DIRECTORY or #f if it could not be | |
31 | determined." | |
32 | (let ((repository #f)) | |
33 | (catch 'git-error | |
34 | (lambda () | |
35 | (set! repository (repository-open directory)) | |
36 | (let* ((head (repository-head repository)) | |
37 | (target (reference-target head)) | |
38 | (commit (oid->string target))) | |
39 | (repository-close! repository) | |
40 | commit)) | |
41 | (lambda _ | |
42 | (when repository | |
43 | (repository-close! repository)) | |
44 | #f)))) | |
45 | ||
46 | (define (tests-for-current-guix source commit) | |
47 | "Return a list of tests for perform, using Guix built from SOURCE, a channel | |
48 | instance." | |
49 | ;; Honor the 'TESTS' environment variable so that one can select a subset | |
50 | ;; of tests to run in the usual way: | |
51 | ;; | |
52 | ;; make check-system TESTS=installed-os | |
dbde3867 LC |
53 | (let ((guix (channel-source->package source #:commit commit))) |
54 | (map (lambda (test) | |
55 | (system-test | |
56 | (inherit test) | |
57 | (value (mparameterize %store-monad ((current-guix-package guix)) | |
58 | (system-test-value test))))) | |
59 | (match (getenv "TESTS") | |
60 | (#f | |
61 | (all-system-tests)) | |
62 | ((= string-tokenize (tests ...)) | |
63 | (filter (lambda (test) | |
64 | (member (system-test-name test) tests)) | |
65 | (all-system-tests))))))) | |
5ec4156b LC |
66 | |
67 | (define (system-test->manifest-entry test) | |
68 | "Return a manifest entry for TEST, a system test." | |
69 | (manifest-entry | |
70 | (name (string-append "test." (system-test-name test))) | |
71 | (version "0") | |
72 | (item test))) | |
73 | ||
74 | (define (system-test-manifest) | |
75 | "Return a manifest containing all the system tests, or all those selected by | |
76 | the 'TESTS' environment variable." | |
77 | (define source | |
78 | (string-append (current-source-directory) "/..")) | |
79 | ||
80 | (define commit | |
81 | ;; Fetch the current commit ID so we can potentially build the same | |
82 | ;; derivation as ci.guix.gnu.org. | |
83 | (source-commit source)) | |
84 | ||
85 | ;; Intern SOURCE so that 'build-from-source' in (guix channels) sees | |
86 | ;; "fresh" file names and thus doesn't find itself loading .go files | |
87 | ;; from ~/.cache/guile when it loads 'build-aux/build-self.scm'. | |
8b18f5cb LC |
88 | (let* ((source (local-file source |
89 | (if commit | |
90 | (string-append "guix-" | |
91 | (string-take commit 7)) | |
92 | "guix-source") | |
5ec4156b LC |
93 | #:recursive? #t |
94 | #:select? | |
95 | (or (git-predicate source) | |
96 | (const #t)))) | |
97 | (tests (tests-for-current-guix source commit))) | |
98 | (format (current-error-port) "Selected ~a system tests...~%" | |
99 | (length tests)) | |
100 | ||
101 | (manifest (map system-test->manifest-entry tests)))) | |
102 | ||
103 | ;; Return the manifest. | |
104 | (system-test-manifest) |