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 ((guix ui) #:select (warn-about-load-error))
  26   #:use-module (gnu bootloader)
  27   #:use-module (gnu bootloader grub)
  28   #:use-module (gnu system)
  29   #:use-module (gnu system file-systems)
  30   #:use-module (gnu system shadow)
  31   #:use-module (gnu services)
  32   #:use-module (gnu services base)
  33   #:use-module (gnu services shepherd)
  34   #:use-module (guix discovery)
  35   #:use-module (srfi srfi-1)
  36   #:use-module (srfi srfi-9 gnu)
  37   #:use-module (ice-9 match)
  38   #:export (marionette-configuration
  39             marionette-configuration?
  40             marionette-configuration-device
  41             marionette-configuration-imported-modules
  42             marionette-configuration-requirements
  43
  44             marionette-service-type
  45             marionette-operating-system
  46             define-os-with-source
  47
  48             simple-operating-system
  49
  50             system-test
  51             system-test?
  52             system-test-name
  53             system-test-value
  54             system-test-description
  55             system-test-location
  56
  57             fold-system-tests
  58             all-system-tests))
  59
  60 ;;; Commentary:
  61 ;;;
  62 ;;; This module provides the infrastructure to run operating system tests.
  63 ;;; The most important part of that is tools to instrument the OS under test,
  64 ;;; essentially allowing to run in a virtual machine controlled by the host
  65 ;;; system--hence the name "marionette".
  66 ;;;
  67 ;;; Code:
  68
  69 (define-record-type* <marionette-configuration>
  70   marionette-configuration make-marionette-configuration
  71   marionette-configuration?
  72   (device           marionette-configuration-device ;string
  73                     (default "/dev/virtio-ports/org.gnu.guix.port.0"))
  74   (imported-modules marionette-configuration-imported-modules
  75                     (default '()))
  76   (requirements     marionette-configuration-requirements ;list of symbols
  77                     (default '())))
  78
  79 (define (marionette-shepherd-service config)
  80   "Return the Shepherd service for the marionette REPL"
  81   (match config
  82     (($ <marionette-configuration> device imported-modules requirement)
  83      (list (shepherd-service
  84             (provision '(marionette))
  85
  86             ;; Always depend on UDEV so that DEVICE is available.
  87             (requirement `(udev ,@requirement))
  88
  89             (modules '((ice-9 match)
  90                        (srfi srfi-9 gnu)
  91                        (rnrs bytevectors)))
  92             (start
  93              (with-imported-modules imported-modules
  94                #~(lambda ()
  95                    (define (self-quoting? x)
  96                      (letrec-syntax ((one-of (syntax-rules ()
  97                                                ((_) #f)
  98                                                ((_ pred rest ...)
  99                                                 (or (pred x)
 100                                                     (one-of rest ...))))))
 101                        (one-of symbol? string? pair? null? vector?
 102                                bytevector? number? boolean?)))
 103
 104                    (match (primitive-fork)
 105                      (0
 106                       (dynamic-wind
 107                         (const #t)
 108                         (lambda ()
 109                           (let ((repl    (open-file #$device "r+0"))
 110                                 (console (open-file "/dev/console" "r+0")))
 111                             ;; Redirect output to the console.
 112                             (close-fdes 1)
 113                             (close-fdes 2)
 114                             (dup2 (fileno console) 1)
 115                             (dup2 (fileno console) 2)
 116                             (close-port console)
 117
 118                             (display 'ready repl)
 119                             (let loop ()
 120                               (newline repl)
 121
 122                               (match (read repl)
 123                                 ((? eof-object?)
 124                                  (primitive-exit 0))
 125                                 (expr
 126                                  (catch #t
 127                                    (lambda ()
 128                                      (let ((result (primitive-eval expr)))
 129                                        (write (if (self-quoting? result)
 130                                                   result
 131                                                   (object->string result))
 132                                               repl)))
 133                                    (lambda (key . args)
 134                                      (print-exception (current-error-port)
 135                                                       (stack-ref (make-stack #t) 1)
 136                                                       key args)
 137                                      (write #f repl)))))
 138                               (loop))))
 139                         (lambda ()
 140                           (primitive-exit 1))))
 141                      (pid
 142                       pid)))))
 143             (stop #~(make-kill-destructor)))))))
 144
 145 (define marionette-service-type
 146   ;; This is the type of the "marionette" service, allowing a guest system to
 147   ;; be manipulated from the host.  This marionette REPL is essentially a
 148   ;; universal backdoor.
 149   (service-type (name 'marionette-repl)
 150                 (extensions
 151                  (list (service-extension shepherd-root-service-type
 152                                           marionette-shepherd-service)))))
 153
 154 (define* (marionette-operating-system os
 155                                       #:key
 156                                       (imported-modules '())
 157                                       (requirements '()))
 158   "Return a marionetteed variant of OS such that OS can be used as a
 159 marionette in a virtual machine--i.e., controlled from the host system.  The
 160 marionette service in the guest is started after the Shepherd services listed
 161 in REQUIREMENTS."
 162   (operating-system
 163     (inherit os)
 164     ;; Make sure the guest dies on error.
 165     (kernel-arguments (cons "panic=1"
 166                             (operating-system-user-kernel-arguments os)))
 167     ;; Make sure the guest doesn't hang in the REPL on error.
 168     (initrd (lambda (fs . rest)
 169               (apply (operating-system-initrd os) fs
 170                      #:on-error 'backtrace
 171                      rest)))
 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 (bootloader-configuration
 209                  (bootloader grub-bootloader)
 210                  (target "/dev/sdX")))
 211     (file-systems (cons (file-system
 212                           (device (file-system-label "my-root"))
 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                   #:warn warn-about-load-error))
 264
 265 (define (fold-system-tests proc seed)
 266   "Invoke PROC on each system test, passing it the test and the previous
 267 result."
 268   (fold-module-public-variables (lambda (obj result)
 269                                   (if (system-test? obj)
 270                                       (cons obj result)
 271                                       result))
 272                                 '()
 273                                 (test-modules)))
 274
 275 (define (all-system-tests)
 276   "Return the list of system tests."
 277   (reverse (fold-system-tests cons '())))
 278
 279 ;;; tests.scm ends here