etc/system-tests.scm

   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
  83                              (if commit
  84                                  (string-append "guix-"
  85                                                 (string-take commit 7))
  86                                  "guix-source")
  87                              #:recursive? #t
  88                              #:select?
  89                              (or (git-predicate source)
  90                                  (const #t))))
  91          (tests  (tests-for-current-guix source commit)))
  92     (format (current-error-port) "Selected ~a system tests...~%"
  93             (length tests))
  94
  95     (manifest (map system-test->manifest-entry tests))))
  96
  97 ;; Return the manifest.
  98 (system-test-manifest)