gnu/tests.scm

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