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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 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 utils)
  #:use-module (guix records)
  #: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 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/hvc0"))
  (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)
                       (guix build syscalls)
                       (rnrs bytevectors)))
            (start
             (with-imported-modules `((guix build syscalls)
                                      ,@imported-modules)
               #~(lambda ()
                   (define (clear-echo termios)
                     (set-field termios (termios-local-flags)
                                (logand (lognot (local-flags ECHO))
                                        (termios-local-flags termios))))

                   (define (self-quoting? x)
                     (letrec-syntax ((one-of (syntax-rules ()
                                               ((_) #f)
                                               ((_ pred rest ...)
                                                (or (pred x)
                                                    (one-of rest ...))))))
                       (one-of symbol? string? pair? null? vector?
                               bytevector? number? boolean?)))

                   (match (primitive-fork)
                     (0
                      (dynamic-wind
                        (const #t)
                        (lambda ()
                          (let* ((repl    (open-file #$device "r+0"))
                                 (termios (tcgetattr (fileno repl)))
                                 (console (open-file "/dev/console" "r+0")))
                            ;; Don't echo input back.
                            (tcsetattr (fileno repl) (tcsetattr-action TCSANOW)
                                       (clear-echo termios))

                            ;; 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 "my-root")
                          (title 'label)
                          (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"))
                  (home-directory "/home/alice"))
                 %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 (test-modules)
  "Return the list of modules that define system tests."
  (scheme-modules (dirname (search-path %load-path "guix.scm"))
                  "gnu/tests"))

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