[jackhill/guix/guix.git] / gnu / tests.scm

;;; GNU Guix --- Functional package management for GNU
;;; 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.
;;;
;;; 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 <http://www.gnu.org/licenses/>.

(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-os
            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>
  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
    (($ <marionette-configuration> 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 '())
                                      (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."
  (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)
                              (imported-modules imported-modules)))
                    (operating-system-user-services os)))))

(define-syntax define-os-with-source
  (syntax-rules (use-modules operating-system)
    "Define two variables: OS containing the given operating system, and
SOURCE containing the source to define OS as an sexp.

This is convenient when we need both the <operating-system> object so we can
instantiate it, and the source to create it so we can store in in a file in
the system under test."
    ((_ (os source)
        (use-modules modules ...)
        (operating-system fields ...))
     (begin
       (define os
         (operating-system fields ...))
       (define source
         '(begin
            (use-modules modules ...)
            (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-record-type* <system-test> 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)      ;<location>
               (default (and=> (current-source-location)
                               source-properties->location))))

(define (write-system-test test port)
  (match test
    (($ <system-test> name _ _ ($ <location> file line))
     (format port "#<system-test ~a ~a:~a ~a>"
             name file line
             (number->string (object-address test) 16)))
    (($ <system-test> name)
     (format port "#<system-test ~a ~a>" name
             (number->string (object-address test) 16)))))

(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"
                  #: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
Commit	Line	Data
957afcae	1	;;; GNU Guix --- Functional package management for GNU
c0b726c2	2	;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
b09a8da4	3	;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
fdfdecdb	4	;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
957afcae LC	5	;;;
	6	;;; This file is part of GNU Guix.
	7	;;;
	8	;;; GNU Guix is free software; you can redistribute it and/or modify it
	9	;;; under the terms of the GNU General Public License as published by
	10	;;; the Free Software Foundation; either version 3 of the License, or (at
	11	;;; your option) any later version.
	12	;;;
	13	;;; GNU Guix is distributed in the hope that it will be useful, but
	14	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	15	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	16	;;; GNU General Public License for more details.
	17	;;;
	18	;;; You should have received a copy of the GNU General Public License
	19	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	20
	21	(define-module (gnu tests)
	22	#:use-module (guix gexp)
a5e2fc73	23	#:use-module (guix diagnostics)
98b65b5f	24	#:use-module (guix records)
d258c791	25	#:use-module ((guix ui) #:select (warn-about-load-error))
fdfdecdb	26	#:use-module (gnu bootloader)
b09a8da4	27	#:use-module (gnu bootloader grub)
957afcae	28	#:use-module (gnu system)
892d9089 LC	29	#:use-module (gnu system file-systems)
892d9089 LC	30	#:use-module (gnu system shadow)
957afcae	31	#:use-module (gnu services)
892d9089	32	#:use-module (gnu services base)
957afcae	33	#:use-module (gnu services shepherd)
67d84d63	34	#:use-module (guix discovery)
98b65b5f LC	35	#:use-module (srfi srfi-1)
	36	#:use-module (srfi srfi-9 gnu)
	37	#:use-module (ice-9 match)
037f9e07 LC	38	#:export (marionette-configuration
	39	marionette-configuration?
	40	marionette-configuration-device
	41	marionette-configuration-imported-modules
	42	marionette-configuration-requirements
	43
	44	marionette-service-type
94b4274d	45	marionette-operating-system
98b65b5f LC	46	define-os-with-source
98b65b5f LC	47
f57b7cea	48	%simple-os
892d9089 LC	49	simple-operating-system
892d9089 LC	50
98b65b5f LC	51	system-test
	52	system-test?
	53	system-test-name
	54	system-test-value
	55	system-test-description
	56	system-test-location
	57
	58	fold-system-tests
	59	all-system-tests))
957afcae LC	60
	61	;;; Commentary:
	62	;;;
	63	;;; This module provides the infrastructure to run operating system tests.
	64	;;; The most important part of that is tools to instrument the OS under test,
f79313b3	65	;;; essentially allowing it to run in a virtual machine controlled by the host
957afcae LC	66	;;; system--hence the name "marionette".
	67	;;;
	68	;;; Code:
	69
037f9e07 LC	70	(define-record-type* <marionette-configuration>
	71	marionette-configuration make-marionette-configuration
	72	marionette-configuration?
	73	(device marionette-configuration-device ;string
27a2c9c3	74	(default "/dev/virtio-ports/org.gnu.guix.port.0"))
037f9e07 LC	75	(imported-modules marionette-configuration-imported-modules
	76	(default '()))
	77	(requirements marionette-configuration-requirements ;list of symbols
	78	(default '())))
	79
	80	(define (marionette-shepherd-service config)
957afcae	81	"Return the Shepherd service for the marionette REPL"
037f9e07 LC	82	(match config
	83	(($ <marionette-configuration> device imported-modules requirement)
	84	(list (shepherd-service
	85	(provision '(marionette))
	86
	87	;; Always depend on UDEV so that DEVICE is available.
	88	(requirement `(udev ,@requirement))
	89
	90	(modules '((ice-9 match)
7abd5997	91	(srfi srfi-9 gnu)))
037f9e07	92	(start
27a2c9c3	93	(with-imported-modules imported-modules
a91c3fc7	94	#~(lambda ()
a91c3fc7 LC	95	(define (self-quoting? x)
	96	(letrec-syntax ((one-of (syntax-rules ()
	97	((_) #f)
	98	((_ pred rest ...)
	99	(or (pred x)
	100	(one-of rest ...))))))
7abd5997	101	(one-of symbol? string? keyword? pair? null? array?
ab7010af	102	number? boolean? char?)))
a91c3fc7 LC	103
	104	(match (primitive-fork)
	105	(0
	106	(dynamic-wind
	107	(const #t)
	108	(lambda ()
27a2c9c3 LC	109	(let ((repl (open-file #$device "r+0"))
27a2c9c3 LC	110	(console (open-file "/dev/console" "r+0")))
a91c3fc7 LC	111	;; Redirect output to the console.
	112	(close-fdes 1)
	113	(close-fdes 2)
	114	(dup2 (fileno console) 1)
	115	(dup2 (fileno console) 2)
	116	(close-port console)
	117
	118	(display 'ready repl)
	119	(let loop ()
	120	(newline repl)
	121
	122	(match (read repl)
	123	((? eof-object?)
	124	(primitive-exit 0))
	125	(expr
	126	(catch #t
	127	(lambda ()
	128	(let ((result (primitive-eval expr)))
	129	(write (if (self-quoting? result)
	130	result
	131	(object->string result))
	132	repl)))
	133	(lambda (key . args)
	134	(print-exception (current-error-port)
	135	(stack-ref (make-stack #t) 1)
	136	key args)
	137	(write #f repl)))))
	138	(loop))))
	139	(lambda ()
	140	(primitive-exit 1))))
	141	(pid
	142	pid)))))
037f9e07	143	(stop #~(make-kill-destructor)))))))
957afcae LC	144
	145	(define marionette-service-type
	146	;; This is the type of the "marionette" service, allowing a guest system to
	147	;; be manipulated from the host. This marionette REPL is essentially a
ca7a68eb	148	;; universal backdoor.
957afcae LC	149	(service-type (name 'marionette-repl)
	150	(extensions
	151	(list (service-extension shepherd-root-service-type
	152	marionette-shepherd-service)))))
	153
	154	(define* (marionette-operating-system os
037f9e07 LC	155	#:key
	156	(imported-modules '())
	157	(requirements '()))
	158	"Return a marionetteed variant of OS such that OS can be used as a
	159	marionette in a virtual machine--i.e., controlled from the host system. The
	160	marionette service in the guest is started after the Shepherd services listed
	161	in REQUIREMENTS."
957afcae LC	162	(operating-system
957afcae LC	163	(inherit os)
16d78a8f DM	164	;; Make sure the guest dies on error.
	165	(kernel-arguments (cons "panic=1"
	166	(operating-system-user-kernel-arguments os)))
	167	;; Make sure the guest doesn't hang in the REPL on error.
	168	(initrd (lambda (fs . rest)
	169	(apply (operating-system-initrd os) fs
	170	#:on-error 'backtrace
	171	rest)))
037f9e07 LC	172	(services (cons (service marionette-service-type
	173	(marionette-configuration
	174	(requirements requirements)
	175	(imported-modules imported-modules)))
957afcae LC	176	(operating-system-user-services os)))))
957afcae LC	177
94b4274d LC	178	(define-syntax define-os-with-source
	179	(syntax-rules (use-modules operating-system)
	180	"Define two variables: OS containing the given operating system, and
	181	SOURCE containing the source to define OS as an sexp.
	182
	183	This is convenient when we need both the <operating-system> object so we can
	184	instantiate it, and the source to create it so we can store in in a file in
	185	the system under test."
	186	((_ (os source)
	187	(use-modules modules ...)
	188	(operating-system fields ...))
	189	(begin
	190	(define os
	191	(operating-system fields ...))
	192	(define source
	193	'(begin
	194	(use-modules modules ...)
	195	(operating-system fields ...)))))))
	196
98b65b5f	197	\f
892d9089 LC	198	;;;
	199	;;; Simple operating systems.
	200	;;;
	201
	202	(define %simple-os
	203	(operating-system
	204	(host-name "komputilo")
	205	(timezone "Europe/Berlin")
	206	(locale "en_US.UTF-8")
	207
fdfdecdb TGR	208	(bootloader (bootloader-configuration
	209	(bootloader grub-bootloader)
	210	(target "/dev/sdX")))
892d9089	211	(file-systems (cons (file-system
9ceeca08	212	(device (file-system-label "my-root"))
892d9089 LC	213	(mount-point "/")
	214	(type "ext4"))
	215	%base-file-systems))
	216	(firmware '())
	217
	218	(users (cons (user-account
	219	(name "alice")
	220	(comment "Bob's sister")
	221	(group "users")
cf848cc0	222	(supplementary-groups '("wheel" "audio" "video")))
892d9089 LC	223	%base-user-accounts))))
	224
	225	(define-syntax-rule (simple-operating-system user-services ...)
	226	"Return an operating system that includes USER-SERVICES in addition to
	227	%BASE-SERVICES."
	228	(operating-system (inherit %simple-os)
	229	(services (cons* user-services ... %base-services))))
	230
	231
	232	\f
98b65b5f LC	233	;;;
	234	;;; Tests.
	235	;;;
	236
	237	(define-record-type* <system-test> system-test make-system-test
	238	system-test?
	239	(name system-test-name) ;string
	240	(value system-test-value) ;%STORE-MONAD value
	241	(description system-test-description) ;string
	242	(location system-test-location (innate) ;<location>
	243	(default (and=> (current-source-location)
	244	source-properties->location))))
	245
	246	(define (write-system-test test port)
	247	(match test
	248	(($ <system-test> name _ _ ($ <location> file line))
	249	(format port "#<system-test ~a ~a:~a ~a>"
	250	name file line
	251	(number->string (object-address test) 16)))
	252	(($ <system-test> name)
	253	(format port "#<system-test ~a ~a>" name
	254	(number->string (object-address test) 16)))))
	255
	256	(set-record-type-printer! <system-test> write-system-test)
	257
c0b726c2 LC	258	(define-gexp-compiler (compile-system-test (test <system-test>)
	259	system target)
	260	"Compile TEST to a derivation."
	261	;; XXX: SYSTEM and TARGET are ignored.
	262	(system-test-value test))
	263
98b65b5f LC	264	(define (test-modules)
	265	"Return the list of modules that define system tests."
	266	(scheme-modules (dirname (search-path %load-path "guix.scm"))
d258c791 LC	267	"gnu/tests"
d258c791 LC	268	#:warn warn-about-load-error))
98b65b5f LC	269
	270	(define (fold-system-tests proc seed)
	271	"Invoke PROC on each system test, passing it the test and the previous
	272	result."
67d84d63 LC	273	(fold-module-public-variables (lambda (obj result)
	274	(if (system-test? obj)
	275	(cons obj result)
	276	result))
	277	'()
	278	(test-modules)))
98b65b5f LC	279
	280	(define (all-system-tests)
	281	"Return the list of system tests."
	282	(reverse (fold-system-tests cons '())))
	283
957afcae	284	;;; tests.scm ends here