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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 system)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module ((gnu packages) #:select (scheme-modules))
  #: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

            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)
    (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
;;;
;;; 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 (lambda (module result)
          (fold (lambda (thing result)
                  (if (system-test? thing)
                      (proc thing result)
                      result))
                result
                (module-map (lambda (sym var)
                              (false-if-exception (variable-ref var)))
                            module)))
        '()
        (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 LC	1	;;; GNU Guix --- Functional package management for GNU
	2	;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (gnu tests)
	20	#:use-module (guix gexp)
98b65b5f LC	21	#:use-module (guix utils)
98b65b5f LC	22	#:use-module (guix records)
957afcae LC	23	#:use-module (gnu system)
	24	#:use-module (gnu services)
	25	#:use-module (gnu services shepherd)
98b65b5f LC	26	#:use-module ((gnu packages) #:select (scheme-modules))
	27	#:use-module (srfi srfi-1)
	28	#:use-module (srfi srfi-9 gnu)
	29	#:use-module (ice-9 match)
037f9e07 LC	30	#:export (marionette-configuration
	31	marionette-configuration?
	32	marionette-configuration-device
	33	marionette-configuration-imported-modules
	34	marionette-configuration-requirements
	35
	36	marionette-service-type
94b4274d	37	marionette-operating-system
98b65b5f LC	38	define-os-with-source
	39
	40	system-test
	41	system-test?
	42	system-test-name
	43	system-test-value
	44	system-test-description
	45	system-test-location
	46
	47	fold-system-tests
	48	all-system-tests))
957afcae LC	49
	50	;;; Commentary:
	51	;;;
	52	;;; This module provides the infrastructure to run operating system tests.
	53	;;; The most important part of that is tools to instrument the OS under test,
	54	;;; essentially allowing to run in a virtual machine controlled by the host
	55	;;; system--hence the name "marionette".
	56	;;;
	57	;;; Code:
	58
037f9e07 LC	59	(define-record-type* <marionette-configuration>
	60	marionette-configuration make-marionette-configuration
	61	marionette-configuration?
	62	(device marionette-configuration-device ;string
	63	(default "/dev/hvc0"))
	64	(imported-modules marionette-configuration-imported-modules
	65	(default '()))
	66	(requirements marionette-configuration-requirements ;list of symbols
	67	(default '())))
	68
	69	(define (marionette-shepherd-service config)
957afcae	70	"Return the Shepherd service for the marionette REPL"
037f9e07 LC	71	(match config
	72	(($ <marionette-configuration> device imported-modules requirement)
	73	(list (shepherd-service
	74	(provision '(marionette))
	75
	76	;; Always depend on UDEV so that DEVICE is available.
	77	(requirement `(udev ,@requirement))
	78
	79	(modules '((ice-9 match)
	80	(srfi srfi-9 gnu)
	81	(guix build syscalls)
	82	(rnrs bytevectors)))
037f9e07	83	(start
a91c3fc7 LC	84	(with-imported-modules `((guix build syscalls)
	85	,@imported-modules)
	86	#~(lambda ()
	87	(define (clear-echo termios)
	88	(set-field termios (termios-local-flags)
	89	(logand (lognot (local-flags ECHO))
	90	(termios-local-flags termios))))
	91
	92	(define (self-quoting? x)
	93	(letrec-syntax ((one-of (syntax-rules ()
	94	((_) #f)
	95	((_ pred rest ...)
	96	(or (pred x)
	97	(one-of rest ...))))))
	98	(one-of symbol? string? pair? null? vector?
	99	bytevector? number? boolean?)))
	100
	101	(match (primitive-fork)
	102	(0
	103	(dynamic-wind
	104	(const #t)
	105	(lambda ()
	106	(let* ((repl (open-file #$device "r+0"))
	107	(termios (tcgetattr (fileno repl)))
	108	(console (open-file "/dev/console" "r+0")))
	109	;; Don't echo input back.
	110	(tcsetattr (fileno repl) (tcsetattr-action TCSANOW)
	111	(clear-echo termios))
	112
	113	;; Redirect output to the console.
	114	(close-fdes 1)
	115	(close-fdes 2)
	116	(dup2 (fileno console) 1)
	117	(dup2 (fileno console) 2)
	118	(close-port console)
	119
	120	(display 'ready repl)
	121	(let loop ()
	122	(newline repl)
	123
	124	(match (read repl)
	125	((? eof-object?)
	126	(primitive-exit 0))
	127	(expr
	128	(catch #t
	129	(lambda ()
	130	(let ((result (primitive-eval expr)))
	131	(write (if (self-quoting? result)
	132	result
	133	(object->string result))
	134	repl)))
	135	(lambda (key . args)
	136	(print-exception (current-error-port)
	137	(stack-ref (make-stack #t) 1)
	138	key args)
	139	(write #f repl)))))
	140	(loop))))
	141	(lambda ()
	142	(primitive-exit 1))))
	143	(pid
	144	pid)))))
037f9e07	145	(stop #~(make-kill-destructor)))))))
957afcae LC	146
	147	(define marionette-service-type
	148	;; This is the type of the "marionette" service, allowing a guest system to
	149	;; be manipulated from the host. This marionette REPL is essentially a
ca7a68eb	150	;; universal backdoor.
957afcae LC	151	(service-type (name 'marionette-repl)
	152	(extensions
	153	(list (service-extension shepherd-root-service-type
	154	marionette-shepherd-service)))))
	155
	156	(define* (marionette-operating-system os
037f9e07 LC	157	#:key
	158	(imported-modules '())
	159	(requirements '()))
	160	"Return a marionetteed variant of OS such that OS can be used as a
	161	marionette in a virtual machine--i.e., controlled from the host system. The
	162	marionette service in the guest is started after the Shepherd services listed
	163	in REQUIREMENTS."
957afcae LC	164	(operating-system
957afcae LC	165	(inherit os)
037f9e07 LC	166	(services (cons (service marionette-service-type
	167	(marionette-configuration
	168	(requirements requirements)
	169	(imported-modules imported-modules)))
957afcae LC	170	(operating-system-user-services os)))))
957afcae LC	171
94b4274d LC	172	(define-syntax define-os-with-source
	173	(syntax-rules (use-modules operating-system)
	174	"Define two variables: OS containing the given operating system, and
	175	SOURCE containing the source to define OS as an sexp.
	176
	177	This is convenient when we need both the <operating-system> object so we can
	178	instantiate it, and the source to create it so we can store in in a file in
	179	the system under test."
	180	((_ (os source)
	181	(use-modules modules ...)
	182	(operating-system fields ...))
	183	(begin
	184	(define os
	185	(operating-system fields ...))
	186	(define source
	187	'(begin
	188	(use-modules modules ...)
	189	(operating-system fields ...)))))))
	190
98b65b5f LC	191	\f
	192	;;;
	193	;;; Tests.
	194	;;;
	195
	196	(define-record-type* <system-test> system-test make-system-test
	197	system-test?
	198	(name system-test-name) ;string
	199	(value system-test-value) ;%STORE-MONAD value
	200	(description system-test-description) ;string
	201	(location system-test-location (innate) ;<location>
	202	(default (and=> (current-source-location)
	203	source-properties->location))))
	204
	205	(define (write-system-test test port)
	206	(match test
	207	(($ <system-test> name _ _ ($ <location> file line))
	208	(format port "#<system-test ~a ~a:~a ~a>"
	209	name file line
	210	(number->string (object-address test) 16)))
	211	(($ <system-test> name)
	212	(format port "#<system-test ~a ~a>" name
	213	(number->string (object-address test) 16)))))
	214
	215	(set-record-type-printer! <system-test> write-system-test)
	216
	217	(define (test-modules)
	218	"Return the list of modules that define system tests."
	219	(scheme-modules (dirname (search-path %load-path "guix.scm"))
	220	"gnu/tests"))
	221
	222	(define (fold-system-tests proc seed)
	223	"Invoke PROC on each system test, passing it the test and the previous
	224	result."
	225	(fold (lambda (module result)
	226	(fold (lambda (thing result)
	227	(if (system-test? thing)
	228	(proc thing result)
	229	result))
	230	result
	231	(module-map (lambda (sym var)
	232	(false-if-exception (variable-ref var)))
	233	module)))
	234	'()
	235	(test-modules)))
	236
	237	(define (all-system-tests)
	238	"Return the list of system tests."
	239	(reverse (fold-system-tests cons '())))
	240
957afcae	241	;;; tests.scm ends here