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