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 ;;; 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
 166 (define* (marionette-operating-system os
 167                                       #:key
 168                                       (imported-modules '())
 169                                       (extensions '())
 170                                       (requirements '()))
 171   "Return a marionetteed variant of OS such that OS can be used as a
 172 marionette in a virtual machine--i.e., controlled from the host system.  The
 173 marionette service in the guest is started after the Shepherd services listed
 174 in REQUIREMENTS.  The packages in the list EXTENSIONS are made available from
 175 the backdoor REPL."
 176   (operating-system
 177     (inherit os)
 178     ;; Make sure the guest dies on error.
 179     (kernel-arguments (cons "panic=1"
 180                             (operating-system-user-kernel-arguments os)))
 181     ;; Make sure the guest doesn't hang in the REPL on error.
 182     (initrd (lambda (fs . rest)
 183               (apply (operating-system-initrd os) fs
 184                      #:on-error 'backtrace
 185                      rest)))
 186     (services (cons (service marionette-service-type
 187                              (marionette-configuration
 188                               (requirements requirements)
 189                               (extensions extensions)
 190                               (imported-modules imported-modules)))
 191                     (operating-system-user-services os)))))
 192
 193 (define-syntax define-os-with-source
 194   (syntax-rules (use-modules operating-system)
 195     "Define two variables: OS containing the given operating system, and
 196 SOURCE containing the source to define OS as an sexp.
 197
 198 This is convenient when we need both the <operating-system> object so we can
 199 instantiate it, and the source to create it so we can store in in a file in
 200 the system under test."
 201     ((_ (os source)
 202         (use-modules modules ...)
 203         (operating-system fields ...))
 204      (begin
 205        (define os
 206          (operating-system fields ...))
 207        (define source
 208          '(begin
 209             (use-modules modules ...)
 210             (operating-system fields ...)))))))
 211
 212 \f
 213 ;;;
 214 ;;; Simple operating systems.
 215 ;;;
 216
 217 (define %simple-os
 218   (operating-system
 219     (host-name "komputilo")
 220     (timezone "Europe/Berlin")
 221     (locale "en_US.UTF-8")
 222
 223     (bootloader (bootloader-configuration
 224                  (bootloader grub-bootloader)
 225                  (target "/dev/sdX")))
 226     (file-systems (cons (file-system
 227                           (device (file-system-label "my-root"))
 228                           (mount-point "/")
 229                           (type "ext4"))
 230                         %base-file-systems))
 231     (firmware '())
 232
 233     (users (cons (user-account
 234                   (name "alice")
 235                   (comment "Bob's sister")
 236                   (group "users")
 237                   (supplementary-groups '("wheel" "audio" "video")))
 238                  %base-user-accounts))))
 239
 240 (define-syntax-rule (simple-operating-system user-services ...)
 241   "Return an operating system that includes USER-SERVICES in addition to
 242 %BASE-SERVICES."
 243   (operating-system (inherit %simple-os)
 244                     (services (cons* user-services ... %base-services))))
 245
 246
 247 \f
 248 ;;;
 249 ;;; Tests.
 250 ;;;
 251
 252 (define-record-type* <system-test> system-test make-system-test
 253   system-test?
 254   (name        system-test-name)                  ;string
 255   (value       system-test-value)                 ;%STORE-MONAD value
 256   (description system-test-description)           ;string
 257   (location    system-test-location (innate)      ;<location>
 258                (default (and=> (current-source-location)
 259                                source-properties->location))))
 260
 261 (define (write-system-test test port)
 262   (match test
 263     (($ <system-test> name _ _ ($ <location> file line))
 264      (format port "#<system-test ~a ~a:~a ~a>"
 265              name file line
 266              (number->string (object-address test) 16)))
 267     (($ <system-test> name)
 268      (format port "#<system-test ~a ~a>" name
 269              (number->string (object-address test) 16)))))
 270
 271 (set-record-type-printer! <system-test> write-system-test)
 272
 273 (define-gexp-compiler (compile-system-test (test <system-test>)
 274                                            system target)
 275   "Compile TEST to a derivation."
 276   ;; XXX: SYSTEM and TARGET are ignored.
 277   (system-test-value test))
 278
 279 (define (test-modules)
 280   "Return the list of modules that define system tests."
 281   (scheme-modules (dirname (search-path %load-path "guix.scm"))
 282                   "gnu/tests"
 283                   #:warn warn-about-load-error))
 284
 285 (define (fold-system-tests proc seed)
 286   "Invoke PROC on each system test, passing it the test and the previous
 287 result."
 288   (fold-module-public-variables (lambda (obj result)
 289                                   (if (system-test? obj)
 290                                       (cons obj result)
 291                                       result))
 292                                 '()
 293                                 (test-modules)))
 294
 295 (define (all-system-tests)
 296   "Return the list of system tests."
 297   (reverse (fold-system-tests cons '())))
 298
 299
 300 ;; Local Variables:
 301 ;; eval: (put 'with-imported-modules-and-extensions 'scheme-indent-function 2)
 302 ;; End:
 303
 304 ;;; tests.scm ends here