X-Git-Url: http://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/61b1df6f2791a2afa291b56708d73a5264ca70eb..12580eb435b4a43be76ad3b900657ec67a70fee7:/gnu/tests.scm

diff --git a/gnu/tests.scm b/gnu/tests.scm
index 810711ab91..3b10a6d5ac 100644
--- a/gnu/tests.scm
+++ b/gnu/tests.scm
@@ -1,5 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 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>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,10 +20,12 @@
 
 (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)
-  #:use-module (gnu system grub)
   #:use-module (gnu system file-systems)
   #:use-module (gnu system shadow)
   #:use-module (gnu services)
@@ -41,6 +45,7 @@
             marionette-operating-system
             define-os-with-source
 
+            %simple-os
             simple-operating-system
 
             system-test
@@ -57,7 +62,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:
@@ -66,7 +71,7 @@
   marionette-configuration make-marionette-configuration
   marionette-configuration?
   (device           marionette-configuration-device ;string
-                    (default "/dev/hvc0"))
+                    (default "/dev/virtio-ports/org.gnu.guix.port.0"))
   (imported-modules marionette-configuration-imported-modules
                     (default '()))
   (requirements     marionette-configuration-requirements ;list of symbols
@@ -83,39 +88,26 @@
             (requirement `(udev ,@requirement))
 
             (modules '((ice-9 match)
-                       (srfi srfi-9 gnu)
-                       (guix build syscalls)
-                       (rnrs bytevectors)))
+                       (srfi srfi-9 gnu)))
             (start
-             (with-imported-modules `((guix build syscalls)
-                                      ,@imported-modules)
+             (with-imported-modules imported-modules
                #~(lambda ()
-                   (define (clear-echo termios)
-                     (set-field termios (termios-local-flags)
-                                (logand (lognot (local-flags ECHO))
-                                        (termios-local-flags termios))))
-
                    (define (self-quoting? x)
                      (letrec-syntax ((one-of (syntax-rules ()
                                                ((_) #f)
                                                ((_ 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
                       (dynamic-wind
                         (const #t)
                         (lambda ()
-                          (let* ((repl    (open-file #$device "r+0"))
-                                 (termios (tcgetattr (fileno repl)))
-                                 (console (open-file "/dev/console" "r+0")))
-                            ;; Don't echo input back.
-                            (tcsetattr (fileno repl) (tcsetattr-action TCSANOW)
-                                       (clear-echo termios))
-
+                          (let ((repl    (open-file #$device "r+0"))
+                                (console (open-file "/dev/console" "r+0")))
                             ;; Redirect output to the console.
                             (close-fdes 1)
                             (close-fdes 2)
@@ -169,6 +161,14 @@ marionette service in the guest is started after the Shepherd services listed
 in REQUIREMENTS."
   (operating-system
     (inherit os)
+    ;; Make sure the guest dies on error.
+    (kernel-arguments (cons "panic=1"
+                            (operating-system-user-kernel-arguments os)))
+    ;; Make sure the guest doesn't hang in the REPL on error.
+    (initrd (lambda (fs . rest)
+              (apply (operating-system-initrd os) fs
+                     #:on-error 'backtrace
+                     rest)))
     (services (cons (service marionette-service-type
                              (marionette-configuration
                               (requirements requirements)
@@ -205,10 +205,11 @@ the system under test."
     (timezone "Europe/Berlin")
     (locale "en_US.UTF-8")
 
-    (bootloader (grub-configuration (device "/dev/sdX")))
+    (bootloader (bootloader-configuration
+                 (bootloader grub-bootloader)
+                 (target "/dev/sdX")))
     (file-systems (cons (file-system
-                          (device "my-root")
-                          (title 'label)
+                          (device (file-system-label "my-root"))
                           (mount-point "/")
                           (type "ext4"))
                         %base-file-systems))
@@ -218,8 +219,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 +255,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