gnu/tests.scm

   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)
  21   #:use-module (guix utils)
  22   #:use-module (guix records)
  23   #:use-module (gnu system)
  24   #:use-module (gnu services)
  25   #:use-module (gnu services shepherd)
  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)
  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
  37             marionette-operating-system
  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))
  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
  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)
  70   "Return the Shepherd service for the marionette REPL"
  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)))
  83             (imported-modules `((guix build syscalls)
  84                                 ,@imported-modules))
  85             (start
  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))))
 145             (stop #~(make-kill-destructor)))))))
 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
 150   ;; universal backdoor.
 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
 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."
 164   (operating-system
 165     (inherit os)
 166     (services (cons (service marionette-service-type
 167                              (marionette-configuration
 168                               (requirements requirements)
 169                               (imported-modules imported-modules)))
 170                     (operating-system-user-services os)))))
 171
 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
 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
 241 ;;; tests.scm ends here