gnu/tests.scm

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