X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/82b695b834f88c5561de40e68f3fe7aa24d3b796..refs/heads/wip-bees:/gnu/tests.scm

diff --git a/gnu/tests.scm b/gnu/tests.scm
index 5d4a4f8062..eb636873a2 100644
--- a/gnu/tests.scm
+++ b/gnu/tests.scm
@@ -1,7 +1,8 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,8 +21,9 @@
 
 (define-module (gnu tests)
   #:use-module (guix gexp)
-  #:use-module (guix utils)
+  #:use-module (guix diagnostics)
   #:use-module (guix records)
+  #:use-module ((guix ui) #:select (warn-about-load-error))
   #:use-module (gnu bootloader)
   #:use-module (gnu bootloader grub)
   #:use-module (gnu system)
@@ -44,6 +46,7 @@
             marionette-operating-system
             define-os-with-source
 
+            %simple-os
             simple-operating-system
 
             system-test
@@ -60,7 +63,7 @@
 ;;;
 ;;; This module provides the infrastructure to run operating system tests.
 ;;; The most important part of that is tools to instrument the OS under test,
-;;; essentially allowing to run in a virtual machine controlled by the host
+;;; essentially allowing it to run in a virtual machine controlled by the host
 ;;; system--hence the name "marionette".
 ;;;
 ;;; Code:
@@ -72,13 +75,24 @@
                     (default "/dev/virtio-ports/org.gnu.guix.port.0"))
   (imported-modules marionette-configuration-imported-modules
                     (default '()))
+  (extensions       marionette-configuration-extensions
+                    (default '())) ; list of packages
   (requirements     marionette-configuration-requirements ;list of symbols
                     (default '())))
 
+;; Hack: avoid indenting code beyond column 80 in marionette-shepherd-service.
+(define-syntax-rule (with-imported-modules-and-extensions imported-modules
+                                                          extensions
+                                                          gexp)
+  (with-imported-modules imported-modules
+    (with-extensions extensions
+      gexp)))
+
 (define (marionette-shepherd-service config)
   "Return the Shepherd service for the marionette REPL"
   (match config
-    (($ <marionette-configuration> device imported-modules requirement)
+    (($ <marionette-configuration> device imported-modules extensions
+                                   requirement)
      (list (shepherd-service
             (provision '(marionette))
 
@@ -86,10 +100,9 @@
             (requirement `(udev ,@requirement))
 
             (modules '((ice-9 match)
-                       (srfi srfi-9 gnu)
-                       (rnrs bytevectors)))
+                       (srfi srfi-9 gnu)))
             (start
-             (with-imported-modules imported-modules
+             (with-imported-modules-and-extensions imported-modules extensions
                #~(lambda ()
                    (define (self-quoting? x)
                      (letrec-syntax ((one-of (syntax-rules ()
@@ -97,8 +110,8 @@
                                                ((_ pred rest ...)
                                                 (or (pred x)
                                                     (one-of rest ...))))))
-                       (one-of symbol? string? pair? null? vector?
-                               bytevector? number? boolean?)))
+                       (one-of symbol? string? keyword? pair? null? array?
+                               number? boolean? char?)))
 
                    (match (primitive-fork)
                      (0
@@ -153,11 +166,13 @@
 (define* (marionette-operating-system os
                                       #:key
                                       (imported-modules '())
+                                      (extensions '())
                                       (requirements '()))
   "Return a marionetteed variant of OS such that OS can be used as a
 marionette in a virtual machine--i.e., controlled from the host system.  The
 marionette service in the guest is started after the Shepherd services listed
-in REQUIREMENTS."
+in REQUIREMENTS.  The packages in the list EXTENSIONS are made available from
+the backdoor REPL."
   (operating-system
     (inherit os)
     ;; Make sure the guest dies on error.
@@ -171,6 +186,7 @@ in REQUIREMENTS."
     (services (cons (service marionette-service-type
                              (marionette-configuration
                               (requirements requirements)
+                              (extensions extensions)
                               (imported-modules imported-modules)))
                     (operating-system-user-services os)))))
 
@@ -218,8 +234,7 @@ the system under test."
                   (name "alice")
                   (comment "Bob's sister")
                   (group "users")
-                  (supplementary-groups '("wheel" "audio" "video"))
-                  (home-directory "/home/alice"))
+                  (supplementary-groups '("wheel" "audio" "video")))
                  %base-user-accounts))))
 
 (define-syntax-rule (simple-operating-system user-services ...)
@@ -255,10 +270,17 @@ the system under test."
 
 (set-record-type-printer! <system-test> write-system-test)
 
+(define-gexp-compiler (compile-system-test (test <system-test>)
+                                           system target)
+  "Compile TEST to a derivation."
+  ;; XXX: SYSTEM and TARGET are ignored.
+  (system-test-value test))
+
 (define (test-modules)
   "Return the list of modules that define system tests."
   (scheme-modules (dirname (search-path %load-path "guix.scm"))
-                  "gnu/tests"))
+                  "gnu/tests"
+                  #:warn warn-about-load-error))
 
 (define (fold-system-tests proc seed)
   "Invoke PROC on each system test, passing it the test and the previous
@@ -274,4 +296,9 @@ result."
   "Return the list of system tests."
   (reverse (fold-system-tests cons '())))
 
+
+;; Local Variables:
+;; eval: (put 'with-imported-modules-and-extensions 'scheme-indent-function 2)
+;; End:
+
 ;;; tests.scm ends here