build-aux/run-system-tests.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2018, 2019 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 (guix store)
  22   #:use-module ((guix status) #:select (with-status-verbosity))
  23   #:use-module (guix monads)
  24   #:use-module (guix derivations)
  25   #:use-module (guix ui)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (srfi srfi-34)
  28   #:use-module (ice-9 match)
  29   #:export (run-system-tests))
  30
  31 (define (built-derivations* drv)
  32   (lambda (store)
  33     (guard (c ((store-protocol-error? c)
  34                (values #f store)))
  35       (values (build-derivations store drv) store))))
  36
  37 (define (filterm mproc lst)                       ;XXX: move to (guix monads)
  38   (with-monad %store-monad
  39     (>>= (foldm %store-monad
  40                 (lambda (item result)
  41                   (mlet %store-monad ((keep? (mproc item)))
  42                     (return (if keep?
  43                                 (cons item result)
  44                                 result))))
  45                 '()
  46                 lst)
  47          (lift1 reverse %store-monad))))
  48
  49 (define (run-system-tests . args)
  50   (define tests
  51     ;; Honor the 'TESTS' environment variable so that one can select a subset
  52     ;; of tests to run in the usual way:
  53     ;;
  54     ;;   make check-system TESTS=installed-os
  55     (match (getenv "TESTS")
  56       (#f
  57        (all-system-tests))
  58       ((= string-tokenize (tests ...))
  59        (filter (lambda (test)
  60                  (member (system-test-name test) tests))
  61                (all-system-tests)))))
  62
  63   (format (current-error-port) "Running ~a system tests...~%"
  64           (length tests))
  65
  66   (with-store store
  67     (with-status-verbosity 2
  68       (run-with-store store
  69         (mlet* %store-monad ((drv (mapm %store-monad system-test-value tests))
  70                              (out -> (map derivation->output-path drv)))
  71           (mbegin %store-monad
  72             (show-what-to-build* drv)
  73             (set-build-options* #:keep-going? #t #:keep-failed? #t
  74                                 #:print-build-trace #t
  75                                 #:print-extended-build-trace? #t
  76                                 #:fallback? #t)
  77             (built-derivations* drv)
  78             (mlet %store-monad ((valid  (filterm (store-lift valid-path?)
  79                                                  out))
  80                                 (failed (filterm (store-lift
  81                                                   (negate valid-path?))
  82                                                  out)))
  83               (format #t "TOTAL: ~a\n" (length drv))
  84               (for-each (lambda (item)
  85                           (format #t "PASS: ~a~%" item))
  86                         valid)
  87               (for-each (lambda (item)
  88                           (format #t "FAIL: ~a~%" item))
  89                         failed)
  90               (exit (null? failed)))))))))