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