;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019 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.
;;;
#:use-module (guix gexp)
#:use-module (guix utils)
#: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 file-systems)
+ #:use-module (gnu system shadow)
#:use-module (gnu services)
+ #:use-module (gnu services base)
#:use-module (gnu services shepherd)
- #:use-module ((gnu packages) #:select (scheme-modules))
+ #:use-module (guix discovery)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (ice-9 match)
marionette-operating-system
define-os-with-source
+ simple-operating-system
+
system-test
system-test?
system-test-name
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
(modules '((ice-9 match)
(srfi srfi-9 gnu)
- (guix build syscalls)
(rnrs bytevectors)))
(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)
(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)
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)
(operating-system fields ...)))))))
\f
+;;;
+;;; Simple operating systems.
+;;;
+
+(define %simple-os
+ (operating-system
+ (host-name "komputilo")
+ (timezone "Europe/Berlin")
+ (locale "en_US.UTF-8")
+
+ (bootloader (bootloader-configuration
+ (bootloader grub-bootloader)
+ (target "/dev/sdX")))
+ (file-systems (cons (file-system
+ (device (file-system-label "my-root"))
+ (mount-point "/")
+ (type "ext4"))
+ %base-file-systems))
+ (firmware '())
+
+ (users (cons (user-account
+ (name "alice")
+ (comment "Bob's sister")
+ (group "users")
+ (supplementary-groups '("wheel" "audio" "video")))
+ %base-user-accounts))))
+
+(define-syntax-rule (simple-operating-system user-services ...)
+ "Return an operating system that includes USER-SERVICES in addition to
+%BASE-SERVICES."
+ (operating-system (inherit %simple-os)
+ (services (cons* user-services ... %base-services))))
+
+
+\f
;;;
;;; Tests.
;;;
(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
result."
- (fold (lambda (module result)
- (fold (lambda (thing result)
- (if (system-test? thing)
- (proc thing result)
- result))
- result
- (module-map (lambda (sym var)
- (false-if-exception (variable-ref var)))
- module)))
- '()
- (test-modules)))
+ (fold-module-public-variables (lambda (obj result)
+ (if (system-test? obj)
+ (cons obj result)
+ result))
+ '()
+ (test-modules)))
(define (all-system-tests)
"Return the list of system tests."