[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>
;;; 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)))))

(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)
                 (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 '())))


;; 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
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>
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
	164	marionette-shepherd-service)))))
	165
	166	(define* (marionette-operating-system os
037f9e07 LC	167	#:key
037f9e07 LC	168	(imported-modules '())
3332f436	169	(extensions '())
037f9e07 LC	170	(requirements '()))
	171	"Return a marionetteed variant of OS such that OS can be used as a
	172	marionette in a virtual machine--i.e., controlled from the host system. The
	173	marionette service in the guest is started after the Shepherd services listed
3332f436 MD	174	in REQUIREMENTS. The packages in the list EXTENSIONS are made available from
3332f436 MD	175	the backdoor REPL."
957afcae LC	176	(operating-system
957afcae LC	177	(inherit os)
16d78a8f DM	178	;; Make sure the guest dies on error.
	179	(kernel-arguments (cons "panic=1"
	180	(operating-system-user-kernel-arguments os)))
	181	;; Make sure the guest doesn't hang in the REPL on error.
	182	(initrd (lambda (fs . rest)
	183	(apply (operating-system-initrd os) fs
	184	#:on-error 'backtrace
	185	rest)))
037f9e07 LC	186	(services (cons (service marionette-service-type
	187	(marionette-configuration
	188	(requirements requirements)
3332f436	189	(extensions extensions)
037f9e07	190	(imported-modules imported-modules)))
957afcae LC	191	(operating-system-user-services os)))))
957afcae LC	192
94b4274d LC	193	(define-syntax define-os-with-source
	194	(syntax-rules (use-modules operating-system)
	195	"Define two variables: OS containing the given operating system, and
	196	SOURCE containing the source to define OS as an sexp.
	197
	198	This is convenient when we need both the <operating-system> object so we can
	199	instantiate it, and the source to create it so we can store in in a file in
	200	the system under test."
	201	((_ (os source)
	202	(use-modules modules ...)
	203	(operating-system fields ...))
	204	(begin
	205	(define os
	206	(operating-system fields ...))
	207	(define source
	208	'(begin
	209	(use-modules modules ...)
	210	(operating-system fields ...)))))))
	211
98b65b5f	212	\f
892d9089 LC	213	;;;
	214	;;; Simple operating systems.
	215	;;;
	216
	217	(define %simple-os
	218	(operating-system
	219	(host-name "komputilo")
	220	(timezone "Europe/Berlin")
	221	(locale "en_US.UTF-8")
	222
fdfdecdb TGR	223	(bootloader (bootloader-configuration
	224	(bootloader grub-bootloader)
	225	(target "/dev/sdX")))
892d9089	226	(file-systems (cons (file-system
9ceeca08	227	(device (file-system-label "my-root"))
892d9089 LC	228	(mount-point "/")
	229	(type "ext4"))
	230	%base-file-systems))
	231	(firmware '())
	232
	233	(users (cons (user-account
	234	(name "alice")
	235	(comment "Bob's sister")
	236	(group "users")
cf848cc0	237	(supplementary-groups '("wheel" "audio" "video")))
892d9089 LC	238	%base-user-accounts))))
	239
	240	(define-syntax-rule (simple-operating-system user-services ...)
	241	"Return an operating system that includes USER-SERVICES in addition to
	242	%BASE-SERVICES."
	243	(operating-system (inherit %simple-os)
	244	(services (cons* user-services ... %base-services))))
	245
	246
	247	\f
98b65b5f LC	248	;;;
	249	;;; Tests.
	250	;;;
	251
	252	(define-record-type* <system-test> system-test make-system-test
	253	system-test?
	254	(name system-test-name) ;string
	255	(value system-test-value) ;%STORE-MONAD value
	256	(description system-test-description) ;string
	257	(location system-test-location (innate) ;<location>
	258	(default (and=> (current-source-location)
	259	source-properties->location))))
	260
	261	(define (write-system-test test port)
	262	(match test
	263	(($ <system-test> name _ _ ($ <location> file line))
	264	(format port "#<system-test ~a ~a:~a ~a>"
	265	name file line
	266	(number->string (object-address test) 16)))
	267	(($ <system-test> name)
	268	(format port "#<system-test ~a ~a>" name
	269	(number->string (object-address test) 16)))))
	270
	271	(set-record-type-printer! <system-test> write-system-test)
	272
c0b726c2 LC	273	(define-gexp-compiler (compile-system-test (test <system-test>)
	274	system target)
	275	"Compile TEST to a derivation."
	276	;; XXX: SYSTEM and TARGET are ignored.
	277	(system-test-value test))
	278
98b65b5f LC	279	(define (test-modules)
	280	"Return the list of modules that define system tests."
	281	(scheme-modules (dirname (search-path %load-path "guix.scm"))
d258c791 LC	282	"gnu/tests"
d258c791 LC	283	#:warn warn-about-load-error))
98b65b5f LC	284
	285	(define (fold-system-tests proc seed)
	286	"Invoke PROC on each system test, passing it the test and the previous
	287	result."
67d84d63 LC	288	(fold-module-public-variables (lambda (obj result)
	289	(if (system-test? obj)
	290	(cons obj result)
	291	result))
	292	'()
	293	(test-modules)))
98b65b5f LC	294
	295	(define (all-system-tests)
	296	"Return the list of system tests."
	297	(reverse (fold-system-tests cons '())))
	298
3332f436 MD	299
	300	;; Local Variables:
	301	;; eval: (put 'with-imported-modules-and-extensions 'scheme-indent-function 2)
	302	;; End:
	303
957afcae	304	;;; tests.scm ends here