gnu/tests.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 2018, 2019, 2020 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 diagnostics)
  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 it 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             (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? keyword? pair? null? array?
 101                                number? boolean? char?)))
 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 (file-system-label "my-root"))
 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                  %base-user-accounts))))
 223
 224 (define-syntax-rule (simple-operating-system user-services ...)
 225   "Return an operating system that includes USER-SERVICES in addition to
 226 %BASE-SERVICES."
 227   (operating-system (inherit %simple-os)
 228                     (services (cons* user-services ... %base-services))))
 229
 230
 231 \f
 232 ;;;
 233 ;;; Tests.
 234 ;;;
 235
 236 (define-record-type* <system-test> system-test make-system-test
 237   system-test?
 238   (name        system-test-name)                  ;string
 239   (value       system-test-value)                 ;%STORE-MONAD value
 240   (description system-test-description)           ;string
 241   (location    system-test-location (innate)      ;<location>
 242                (default (and=> (current-source-location)
 243                                source-properties->location))))
 244
 245 (define (write-system-test test port)
 246   (match test
 247     (($ <system-test> name _ _ ($ <location> file line))
 248      (format port "#<system-test ~a ~a:~a ~a>"
 249              name file line
 250              (number->string (object-address test) 16)))
 251     (($ <system-test> name)
 252      (format port "#<system-test ~a ~a>" name
 253              (number->string (object-address test) 16)))))
 254
 255 (set-record-type-printer! <system-test> write-system-test)
 256
 257 (define-gexp-compiler (compile-system-test (test <system-test>)
 258                                            system target)
 259   "Compile TEST to a derivation."
 260   ;; XXX: SYSTEM and TARGET are ignored.
 261   (system-test-value test))
 262
 263 (define (test-modules)
 264   "Return the list of modules that define system tests."
 265   (scheme-modules (dirname (search-path %load-path "guix.scm"))
 266                   "gnu/tests"
 267                   #:warn warn-about-load-error))
 268
 269 (define (fold-system-tests proc seed)
 270   "Invoke PROC on each system test, passing it the test and the previous
 271 result."
 272   (fold-module-public-variables (lambda (obj result)
 273                                   (if (system-test? obj)
 274                                       (cons obj result)
 275                                       result))
 276                                 '()
 277                                 (test-modules)))
 278
 279 (define (all-system-tests)
 280   "Return the list of system tests."
 281   (reverse (fold-system-tests cons '())))
 282
 283 ;;; tests.scm ends here