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) | |
21 | ((gnu ci) #:select (channel-source->package)) | |
22 | ((guix git-download) #:select (git-predicate)) | |
23 | ((guix utils) #:select (current-source-directory)) | |
24 | (git) | |
25 | (ice-9 match)) | |
26 | ||
27 | (define (source-commit directory) | |
28 | "Return the commit of the head of DIRECTORY or #f if it could not be | |
29 | determined." | |
30 | (let ((repository #f)) | |
31 | (catch 'git-error | |
32 | (lambda () | |
33 | (set! repository (repository-open directory)) | |
34 | (let* ((head (repository-head repository)) | |
35 | (target (reference-target head)) | |
36 | (commit (oid->string target))) | |
37 | (repository-close! repository) | |
38 | commit)) | |
39 | (lambda _ | |
40 | (when repository | |
41 | (repository-close! repository)) | |
42 | #f)))) | |
43 | ||
44 | (define (tests-for-current-guix source commit) | |
45 | "Return a list of tests for perform, using Guix built from SOURCE, a channel | |
46 | instance." | |
47 | ;; Honor the 'TESTS' environment variable so that one can select a subset | |
48 | ;; of tests to run in the usual way: | |
49 | ;; | |
50 | ;; make check-system TESTS=installed-os | |
51 | (parameterize ((current-guix-package | |
52 | (channel-source->package source #:commit commit))) | |
53 | (match (getenv "TESTS") | |
54 | (#f | |
55 | (all-system-tests)) | |
56 | ((= string-tokenize (tests ...)) | |
57 | (filter (lambda (test) | |
58 | (member (system-test-name test) tests)) | |
59 | (all-system-tests)))))) | |
60 | ||
61 | (define (system-test->manifest-entry test) | |
62 | "Return a manifest entry for TEST, a system test." | |
63 | (manifest-entry | |
64 | (name (string-append "test." (system-test-name test))) | |
65 | (version "0") | |
66 | (item test))) | |
67 | ||
68 | (define (system-test-manifest) | |
69 | "Return a manifest containing all the system tests, or all those selected by | |
70 | the 'TESTS' environment variable." | |
71 | (define source | |
72 | (string-append (current-source-directory) "/..")) | |
73 | ||
74 | (define commit | |
75 | ;; Fetch the current commit ID so we can potentially build the same | |
76 | ;; derivation as ci.guix.gnu.org. | |
77 | (source-commit source)) | |
78 | ||
79 | ;; Intern SOURCE so that 'build-from-source' in (guix channels) sees | |
80 | ;; "fresh" file names and thus doesn't find itself loading .go files | |
81 | ;; from ~/.cache/guile when it loads 'build-aux/build-self.scm'. | |
82 | (let* ((source (local-file source "guix-source" | |
83 | #:recursive? #t | |
84 | #:select? | |
85 | (or (git-predicate source) | |
86 | (const #t)))) | |
87 | (tests (tests-for-current-guix source commit))) | |
88 | (format (current-error-port) "Selected ~a system tests...~%" | |
89 | (length tests)) | |
90 | ||
91 | (manifest (map system-test->manifest-entry tests)))) | |
92 | ||
93 | ;; Return the manifest. | |
94 | (system-test-manifest) |