Commit | Line | Data |
---|---|---|
41c569d9 | 1 | ;;; GNU Guix --- Functional package management for GNU |
dd1ee160 | 2 | ;;; Copyright © 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
41c569d9 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 | (define-module (run-system-tests) | |
98b65b5f | 20 | #:use-module (gnu tests) |
887fd835 | 21 | #:use-module (gnu packages package-management) |
dd1ee160 LC |
22 | #:use-module ((gnu ci) #:select (channel-source->package)) |
23 | #:use-module (guix gexp) | |
41c569d9 | 24 | #:use-module (guix store) |
2637cfd7 | 25 | #:use-module ((guix status) #:select (with-status-verbosity)) |
41c569d9 | 26 | #:use-module (guix monads) |
887fd835 | 27 | #:use-module (guix channels) |
41c569d9 | 28 | #:use-module (guix derivations) |
887fd835 LC |
29 | #:use-module ((guix git-download) #:select (git-predicate)) |
30 | #:use-module (guix utils) | |
41c569d9 | 31 | #:use-module (guix ui) |
c5a3d8f6 | 32 | #:use-module (git) |
41c569d9 LC |
33 | #:use-module (srfi srfi-1) |
34 | #:use-module (srfi srfi-34) | |
de7e0e8e | 35 | #:use-module (ice-9 match) |
41c569d9 LC |
36 | #:export (run-system-tests)) |
37 | ||
38 | (define (built-derivations* drv) | |
39 | (lambda (store) | |
f9e8a123 | 40 | (guard (c ((store-protocol-error? c) |
41c569d9 LC |
41 | (values #f store))) |
42 | (values (build-derivations store drv) store)))) | |
43 | ||
44 | (define (filterm mproc lst) ;XXX: move to (guix monads) | |
45 | (with-monad %store-monad | |
46 | (>>= (foldm %store-monad | |
47 | (lambda (item result) | |
48 | (mlet %store-monad ((keep? (mproc item))) | |
49 | (return (if keep? | |
50 | (cons item result) | |
51 | result)))) | |
52 | '() | |
53 | lst) | |
54 | (lift1 reverse %store-monad)))) | |
55 | ||
c5a3d8f6 LC |
56 | (define (source-commit directory) |
57 | "Return the commit of the head of DIRECTORY or #f if it could not be | |
58 | determined." | |
59 | (let ((repository #f)) | |
60 | (catch 'git-error | |
61 | (lambda () | |
62 | (set! repository (repository-open directory)) | |
63 | (let* ((head (repository-head repository)) | |
64 | (target (reference-target head)) | |
65 | (commit (oid->string target))) | |
66 | (repository-close! repository) | |
67 | commit)) | |
68 | (lambda _ | |
69 | (when repository | |
70 | (repository-close! repository)) | |
71 | #f)))) | |
72 | ||
73 | (define (tests-for-current-guix source commit) | |
dd1ee160 | 74 | "Return a list of tests for perform, using Guix built from SOURCE, a channel |
887fd835 LC |
75 | instance." |
76 | ;; Honor the 'TESTS' environment variable so that one can select a subset | |
77 | ;; of tests to run in the usual way: | |
78 | ;; | |
79 | ;; make check-system TESTS=installed-os | |
80 | (parameterize ((current-guix-package | |
c5a3d8f6 | 81 | (channel-source->package source #:commit commit))) |
de7e0e8e LC |
82 | (match (getenv "TESTS") |
83 | (#f | |
84 | (all-system-tests)) | |
85 | ((= string-tokenize (tests ...)) | |
86 | (filter (lambda (test) | |
87 | (member (system-test-name test) tests)) | |
887fd835 LC |
88 | (all-system-tests)))))) |
89 | ||
887fd835 LC |
90 | (define (run-system-tests . args) |
91 | (define source | |
92 | (string-append (current-source-directory) "/..")) | |
98b65b5f | 93 | |
c5a3d8f6 LC |
94 | (define commit |
95 | ;; Fetch the current commit ID so we can potentially build the same | |
96 | ;; derivation as ci.guix.gnu.org. | |
97 | (source-commit source)) | |
98 | ||
41c569d9 | 99 | (with-store store |
7804c45b | 100 | (with-status-verbosity 2 |
276f3680 | 101 | (run-with-store store |
887fd835 LC |
102 | ;; Intern SOURCE so that 'build-from-source' in (guix channels) sees |
103 | ;; "fresh" file names and thus doesn't find itself loading .go files | |
104 | ;; from ~/.cache/guile when it loads 'build-aux/build-self.scm'. | |
dd1ee160 | 105 | (mlet* %store-monad ((source -> (local-file source "guix-source" |
887fd835 LC |
106 | #:recursive? #t |
107 | #:select? | |
108 | (or (git-predicate source) | |
109 | (const #t)))) | |
c5a3d8f6 | 110 | (tests -> (tests-for-current-guix source commit)) |
887fd835 | 111 | (drv (mapm %store-monad system-test-value tests)) |
276f3680 | 112 | (out -> (map derivation->output-path drv))) |
887fd835 LC |
113 | (format (current-error-port) "Running ~a system tests...~%" |
114 | (length tests)) | |
115 | ||
276f3680 LC |
116 | (mbegin %store-monad |
117 | (show-what-to-build* drv) | |
118 | (set-build-options* #:keep-going? #t #:keep-failed? #t | |
119 | #:print-build-trace #t | |
120 | #:print-extended-build-trace? #t | |
121 | #:fallback? #t) | |
122 | (built-derivations* drv) | |
123 | (mlet %store-monad ((valid (filterm (store-lift valid-path?) | |
124 | out)) | |
125 | (failed (filterm (store-lift | |
126 | (negate valid-path?)) | |
127 | out))) | |
128 | (format #t "TOTAL: ~a\n" (length drv)) | |
129 | (for-each (lambda (item) | |
130 | (format #t "PASS: ~a~%" item)) | |
131 | valid) | |
132 | (for-each (lambda (item) | |
133 | (format #t "FAIL: ~a~%" item)) | |
134 | failed) | |
135 | (exit (null? failed))))))))) |