build-aux/run-system-tests.scm

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