;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016-2020, 2022 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.
;;;
(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)
marionette-operating-system
define-os-with-source
+ %simple-os
simple-operating-system
system-test
;;;
;;; 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:
(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))
(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 ()
((_ 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
(service-type (name 'marionette-repl)
(extensions
(list (service-extension shepherd-root-service-type
- marionette-shepherd-service)))))
+ marionette-shepherd-service)))
+ (description "The @dfn{marionette} service allows a guest
+system (virtual machine) to be manipulated by the host. It is used for system
+tests.")))
(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.
(services (cons (service marionette-service-type
(marionette-configuration
(requirements requirements)
+ (extensions extensions)
(imported-modules imported-modules)))
(operating-system-user-services os)))))
(bootloader (bootloader-configuration
(bootloader grub-bootloader)
- (target "/dev/sdX")))
+ (targets '("/dev/sdX"))))
(file-systems (cons (file-system
(device (file-system-label "my-root"))
(mount-point "/")
(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 ...)
(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
"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