gnu/tests.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   4 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
   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)
  23   #:use-module (guix utils)
  24   #:use-module (guix records)
  25   #:use-module (gnu bootloader)
  26   #:use-module (gnu bootloader grub)
  27   #:use-module (gnu system)
  28   #:use-module (gnu system file-systems)
  29   #:use-module (gnu system shadow)
  30   #:use-module (gnu services)
  31   #:use-module (gnu services base)
  32   #:use-module (gnu services shepherd)
  33   #:use-module (guix discovery)
  34   #:use-module (srfi srfi-1)
  35   #:use-module (srfi srfi-9 gnu)
  36   #:use-module (ice-9 match)
  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
  44             marionette-operating-system
  45             define-os-with-source
  46
  47             simple-operating-system
  48
  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))
  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
  68 (define-record-type* <marionette-configuration>
  69   marionette-configuration make-marionette-configuration
  70   marionette-configuration?
  71   (device           marionette-configuration-device ;string
  72                     (default "/dev/virtio-ports/org.gnu.guix.port.0"))
  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)
  79   "Return the Shepherd service for the marionette REPL"
  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                        (rnrs bytevectors)))
  91             (start
  92              (with-imported-modules imported-modules
  93                #~(lambda ()
  94                    (define (self-quoting? x)
  95                      (letrec-syntax ((one-of (syntax-rules ()
  96                                                ((_) #f)
  97                                                ((_ pred rest ...)
  98                                                 (or (pred x)
  99                                                     (one-of rest ...))))))
 100                        (one-of symbol? string? pair? null? vector?
 101                                bytevector? number? boolean?)))
 102
 103                    (match (primitive-fork)
 104                      (0
 105                       (dynamic-wind
 106                         (const #t)
 107                         (lambda ()
 108                           (let ((repl    (open-file #$device "r+0"))
 109                                 (console (open-file "/dev/console" "r+0")))
 110                             ;; Redirect output to the console.
 111                             (close-fdes 1)
 112                             (close-fdes 2)
 113                             (dup2 (fileno console) 1)
 114                             (dup2 (fileno console) 2)
 115                             (close-port console)
 116
 117                             (display 'ready repl)
 118                             (let loop ()
 119                               (newline repl)
 120
 121                               (match (read repl)
 122                                 ((? eof-object?)
 123                                  (primitive-exit 0))
 124                                 (expr
 125                                  (catch #t
 126                                    (lambda ()
 127                                      (let ((result (primitive-eval expr)))
 128                                        (write (if (self-quoting? result)
 129                                                   result
 130                                                   (object->string result))
 131                                               repl)))
 132                                    (lambda (key . args)
 133                                      (print-exception (current-error-port)
 134                                                       (stack-ref (make-stack #t) 1)
 135                                                       key args)
 136                                      (write #f repl)))))
 137                               (loop))))
 138                         (lambda ()
 139                           (primitive-exit 1))))
 140                      (pid
 141                       pid)))))
 142             (stop #~(make-kill-destructor)))))))
 143
 144 (define marionette-service-type
 145   ;; This is the type of the "marionette" service, allowing a guest system to
 146   ;; be manipulated from the host.  This marionette REPL is essentially a
 147   ;; universal backdoor.
 148   (service-type (name 'marionette-repl)
 149                 (extensions
 150                  (list (service-extension shepherd-root-service-type
 151                                           marionette-shepherd-service)))))
 152
 153 (define* (marionette-operating-system os
 154                                       #:key
 155                                       (imported-modules '())
 156                                       (requirements '()))
 157   "Return a marionetteed variant of OS such that OS can be used as a
 158 marionette in a virtual machine--i.e., controlled from the host system.  The
 159 marionette service in the guest is started after the Shepherd services listed
 160 in REQUIREMENTS."
 161   (operating-system
 162     (inherit os)
 163     ;; Make sure the guest dies on error.
 164     (kernel-arguments (cons "panic=1"
 165                             (operating-system-user-kernel-arguments os)))
 166     ;; Make sure the guest doesn't hang in the REPL on error.
 167     (initrd (lambda (fs . rest)
 168               (apply (operating-system-initrd os) fs
 169                      #:on-error 'backtrace
 170                      rest)))
 171     (services (cons (service marionette-service-type
 172                              (marionette-configuration
 173                               (requirements requirements)
 174                               (imported-modules imported-modules)))
 175                     (operating-system-user-services os)))))
 176
 177 (define-syntax define-os-with-source
 178   (syntax-rules (use-modules operating-system)
 179     "Define two variables: OS containing the given operating system, and
 180 SOURCE containing the source to define OS as an sexp.
 181
 182 This is convenient when we need both the <operating-system> object so we can
 183 instantiate it, and the source to create it so we can store in in a file in
 184 the system under test."
 185     ((_ (os source)
 186         (use-modules modules ...)
 187         (operating-system fields ...))
 188      (begin
 189        (define os
 190          (operating-system fields ...))
 191        (define source
 192          '(begin
 193             (use-modules modules ...)
 194             (operating-system fields ...)))))))
 195
 196 \f
 197 ;;;
 198 ;;; Simple operating systems.
 199 ;;;
 200
 201 (define %simple-os
 202   (operating-system
 203     (host-name "komputilo")
 204     (timezone "Europe/Berlin")
 205     (locale "en_US.UTF-8")
 206
 207     (bootloader (bootloader-configuration
 208                  (bootloader grub-bootloader)
 209                  (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