;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2017 Tobias Geerinckx-Rice ;;; ;;; 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 . (define-module (gnu tests) #:use-module (guix gexp) #: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 file-systems) #:use-module (gnu system shadow) #:use-module (gnu services) #:use-module (gnu services base) #:use-module (gnu services shepherd) #:use-module (guix discovery) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 match) #:export (marionette-configuration marionette-configuration? marionette-configuration-device marionette-configuration-imported-modules marionette-configuration-requirements marionette-service-type marionette-operating-system define-os-with-source simple-operating-system system-test system-test? system-test-name system-test-value system-test-description system-test-location fold-system-tests all-system-tests)) ;;; Commentary: ;;; ;;; 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 it to run in a virtual machine controlled by the host ;;; system--hence the name "marionette". ;;; ;;; Code: (define-record-type* marionette-configuration make-marionette-configuration marionette-configuration? (device marionette-configuration-device ;string (default "/dev/virtio-ports/org.gnu.guix.port.0")) (imported-modules marionette-configuration-imported-modules (default '())) (requirements marionette-configuration-requirements ;list of symbols (default '()))) (define (marionette-shepherd-service config) "Return the Shepherd service for the marionette REPL" (match config (($ device imported-modules requirement) (list (shepherd-service (provision '(marionette)) ;; Always depend on UDEV so that DEVICE is available. (requirement `(udev ,@requirement)) (modules '((ice-9 match) (srfi srfi-9 gnu))) (start (with-imported-modules imported-modules #~(lambda () (define (self-quoting? x) (letrec-syntax ((one-of (syntax-rules () ((_) #f) ((_ pred rest ...) (or (pred x) (one-of rest ...)))))) (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")) (console (open-file "/dev/console" "r+0"))) ;; Redirect output to the console. (close-fdes 1) (close-fdes 2) (dup2 (fileno console) 1) (dup2 (fileno console) 2) (close-port console) (display 'ready repl) (let loop () (newline repl) (match (read repl) ((? eof-object?) (primitive-exit 0)) (expr (catch #t (lambda () (let ((result (primitive-eval expr))) (write (if (self-quoting? result) result (object->string result)) repl))) (lambda (key . args) (print-exception (current-error-port) (stack-ref (make-stack #t) 1) key args) (write #f repl))))) (loop)))) (lambda () (primitive-exit 1)))) (pid pid))))) (stop #~(make-kill-destructor))))))) (define marionette-service-type ;; This is the type of the "marionette" service, allowing a guest system to ;; be manipulated from the host. This marionette REPL is essentially a ;; universal backdoor. (service-type (name 'marionette-repl) (extensions (list (service-extension shepherd-root-service-type marionette-shepherd-service))))) (define* (marionette-operating-system os #:key (imported-modules '()) 2020-10-25news: Add entry for the declarative substitute ACL....Ludovic Courtès 2020-10-22news: Add ‘de’ translation....Florian Pelz 2020-10-20news: Add 'es' translation.Miguel Ángel Arruga Vivas 2020-10-20news: Add entry for '--with-debug-info'....Ludovic Courtès 2020-10-16guix-install.sh: Check the service 'nscd' and suggest it....zimoun 2020-10-16guix-install.sh: Add symbolic links for supported shell completions....zimoun 2020-10-14news: Add ‘de’ translation....Florian Pelz 2020-10-13installer: Add Emacs EXWM desktop environment....Jan (janneke) Nieuwenhuizen (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)))) ;;; ;;; Tests. ;;; (define-record-type* system-test make-system-test system-test? (name system-test-name) ;string (value system-test-value) ;%STORE-MONAD value (description system-test-description) ;string (location system-test-location (innate) ; (default (and=> (current-source-location) source-properties->location)))) (define (write-system-test test port) (match test (($ name _ _ ($ file line)) (format port "#" name file line (number->string (object-address test) 16))) (($ name) (format port "#" name (number->string (object-address test) 16))))) (set-record-type-printer! write-system-test) (define-gexp-compiler (compile-system-test (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" #: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-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." (reverse (fold-system-tests cons '()))) ;;; tests.scm ends here