build-aux/run-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 (define-module (run-system-tests)
  20   #:use-module (gnu tests)
  21   #:use-module (gnu packages package-management)
  22   #:use-module ((gnu ci) #:select (channel-source->package))
  23   #:use-module (guix gexp)
  24   #:use-module (guix store)
  25   #:use-module ((guix status) #:select (with-status-verbosity))
  26   #:use-module (guix monads)
  27   #:use-module (guix channels)
  28   #:use-module (guix derivations)
  29   #:use-module ((guix git-download) #:select (git-predicate))
  30   #:use-module (guix utils)
  31   #:use-module (guix ui)
  32   #:use-module (git)
  33   #:use-module (srfi srfi-1)
  34   #:use-module (srfi srfi-34)
  35   #:use-module (ice-9 match)
  36   #:export (run-system-tests))
  37
  38 (define (built-derivations* drv)
  39   (lambda (store)
  40     (guard (c ((store-protocol-error? c)
  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
  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)
  74   "Return a list of tests for perform, using Guix built from SOURCE, a channel
  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
  81                   (channel-source->package source #:commit commit)))
  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))
  88                (all-system-tests))))))
  89
  90 (define (run-system-tests . args)
  91   (define source
  92     (string-append (current-source-directory) "/.."))
  93
  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
  99   (with-store store
 100     (with-status-verbosity 2
 101       (run-with-store store
 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'.
 105         (mlet* %store-monad ((source -> (local-file source "guix-source"
 106                                                     #:recursive? #t
 107                                                     #:select?
 108                                                     (or (git-predicate source)
 109                                                         (const #t))))
 110                              (tests ->  (tests-for-current-guix source commit))
 111                              (drv (mapm %store-monad system-test-value tests))
 112                              (out -> (map derivation->output-path drv)))
 113           (format (current-error-port) "Running ~a system tests...~%"
 114                   (length tests))
 115
 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)))))))))