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

;;; GNU Guix --- Functional package management for GNU
;;; 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.
;;;
;;; 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 '()))
  (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 extensions
                                   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-and-extensions imported-modules extensions
               #~(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)))
                (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.  The packages in the list EXTENSIONS are made available from
the backdoor REPL."
  (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)
                              (extensions extensions)
                              (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)
                 (targets '("/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 '())))


;; Local Variables:
;; eval: (put 'with-imported-modules-and-extensions 'scheme-indent-function 2)
;; End:

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