01/01: build: Add 'run-system-tests.scm'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 41c569d9b9c47ce8f2fb280f24c0a6d4e76f8bc7
Author: Ludovic Courtès <address@hidden>
Date:   Wed May 4 23:56:42 2016 +0200

    build: Add 'run-system-tests.scm'.
    
    This file was meant to be added as part of
    commit e9f693d06f94bd96488c3910dba6504f94a6b6f9.
    
    * build-aux/run-system-tests.scm: New file.
    * Makefile.am (EXTRA_DIST): Add it.
---
 Makefile.am                    |    1 +
 build-aux/run-system-tests.scm |   71 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 72 insertions(+)

diff --git a/Makefile.am b/Makefile.am
index e0be844..dfd486b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -361,6 +361,7 @@ EXTRA_DIST =                                                
\
   build-aux/make-binary-tarball.scm                    \
   build-aux/generate-authors.scm                       \
   build-aux/test-driver.scm                            \
+  build-aux/run-system-tests.scm                       \
   srfi/srfi-37.scm.in                                  \
   srfi/srfi-64.scm                                     \
   srfi/srfi-64.upstream.scm                            \
diff --git a/build-aux/run-system-tests.scm b/build-aux/run-system-tests.scm
new file mode 100644
index 0000000..e98de9c
--- /dev/null
+++ b/build-aux/run-system-tests.scm
@@ -0,0 +1,71 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ludovic Courtès <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (run-system-tests)
+  #:use-module (gnu tests base)
+  #:use-module (guix store)
+  #:use-module (guix monads)
+  #:use-module (guix derivations)
+  #:use-module (guix ui)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:export (run-system-tests))
+
+(define (built-derivations* drv)
+  (lambda (store)
+    (guard (c ((nix-protocol-error? c)
+               (values #f store)))
+      (values (build-derivations store drv) store))))
+
+(define (filterm mproc lst)                       ;XXX: move to (guix monads)
+  (with-monad %store-monad
+    (>>= (foldm %store-monad
+                (lambda (item result)
+                  (mlet %store-monad ((keep? (mproc item)))
+                    (return (if keep?
+                                (cons item result)
+                                result))))
+                '()
+                lst)
+         (lift1 reverse %store-monad))))
+
+(define %system-tests
+  (list %test-basic-os))
+
+(define (run-system-tests . args)
+  (with-store store
+    (run-with-store store
+      (mlet* %store-monad ((drv (sequence %store-monad %system-tests))
+                           (out -> (map derivation->output-path drv)))
+        (mbegin %store-monad
+          (show-what-to-build* drv)
+          (set-build-options* #:keep-going? #t #:keep-failed? #t)
+          (built-derivations* drv)
+          (mlet %store-monad ((valid  (filterm (store-lift valid-path?)
+                                               out))
+                              (failed (filterm (store-lift
+                                                (negate valid-path?))
+                                               out)))
+            (format #t "TOTAL: ~a\n" (length drv))
+            (for-each (lambda (item)
+                        (format #t "PASS: ~a~%" item))
+                      valid)
+            (for-each (lambda (item)
+                        (format #t "FAIL: ~a~%" item))
+                      failed)
+            (exit (null? failed))))))))