gnu/tests.scm

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