gnu/tests.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017 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/hvc0"))
  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                        (guix build syscalls)
  91                        (rnrs bytevectors)))
  92             (start
  93              (with-imported-modules `((guix build syscalls)
  94                                       ,@imported-modules)
  95                #~(lambda ()
  96                    (define (clear-echo termios)
  97                      (set-field termios (termios-local-flags)
  98                                 (logand (lognot (local-flags ECHO))
  99                                         (termios-local-flags termios))))
 100
 101                    (define (self-quoting? x)
 102                      (letrec-syntax ((one-of (syntax-rules ()
 103                                                ((_) #f)
 104                                                ((_ pred rest ...)
 105                                                 (or (pred x)
 106                                                     (one-of rest ...))))))
 107                        (one-of symbol? string? pair? null? vector?
 108                                bytevector? number? boolean?)))
 109
 110                    (match (primitive-fork)
 111                      (0
 112                       (dynamic-wind
 113                         (const #t)
 114                         (lambda ()
 115                           (let* ((repl    (open-file #$device "r+0"))
 116                                  (termios (tcgetattr (fileno repl)))
 117                                  (console (open-file "/dev/console" "r+0")))
 118                             ;; Don't echo input back.
 119                             (tcsetattr (fileno repl) (tcsetattr-action TCSANOW)
 120                                        (clear-echo termios))
 121
 122                             ;; Redirect output to the console.
 123                             (close-fdes 1)
 124                             (close-fdes 2)
 125                             (dup2 (fileno console) 1)
 126                             (dup2 (fileno console) 2)
 127                             (close-port console)
 128
 129                             (display 'ready repl)
 130                             (let loop ()
 131                               (newline repl)
 132
 133                               (match (read repl)
 134                                 ((? eof-object?)
 135                                  (primitive-exit 0))
 136                                 (expr
 137                                  (catch #t
 138                                    (lambda ()
 139                                      (let ((result (primitive-eval expr)))
 140                                        (write (if (self-quoting? result)
 141                                                   result
 142                                                   (object->string result))
 143                                               repl)))
 144                                    (lambda (key . args)
 145                                      (print-exception (current-error-port)
 146                                                       (stack-ref (make-stack #t) 1)
 147                                                       key args)
 148                                      (write #f repl)))))
 149                               (loop))))
 150                         (lambda ()
 151                           (primitive-exit 1))))
 152                      (pid
 153                       pid)))))
 154             (stop #~(make-kill-destructor)))))))
 155
 156 (define marionette-service-type
 157   ;; This is the type of the "marionette" service, allowing a guest system to
 158   ;; be manipulated from the host.  This marionette REPL is essentially a
 159   ;; universal backdoor.
 160   (service-type (name 'marionette-repl)
 161                 (extensions
 162                  (list (service-extension shepherd-root-service-type
 163                                           marionette-shepherd-service)))))
 164
 165 (define* (marionette-operating-system os
 166                                       #:key
 167                                       (imported-modules '())
 168                                       (requirements '()))
 169   "Return a marionetteed variant of OS such that OS can be used as a
 170 marionette in a virtual machine--i.e., controlled from the host system.  The
 171 marionette service in the guest is started after the Shepherd services listed
 172 in REQUIREMENTS."
 173   (operating-system
 174     (inherit os)
 175     (services (cons (service marionette-service-type
 176                              (marionette-configuration
 177                               (requirements requirements)
 178                               (imported-modules imported-modules)))
 179                     (operating-system-user-services os)))))
 180
 181 (define-syntax define-os-with-source
 182   (syntax-rules (use-modules operating-system)
 183     "Define two variables: OS containing the given operating system, and
 184 SOURCE containing the source to define OS as an sexp.
 185
 186 This is convenient when we need both the <operating-system> object so we can
 187 instantiate it, and the source to create it so we can store in in a file in
 188 the system under test."
 189     ((_ (os source)
 190         (use-modules modules ...)
 191         (operating-system fields ...))
 192      (begin
 193        (define os
 194          (operating-system fields ...))
 195        (define source
 196          '(begin
 197             (use-modules modules ...)
 198             (operating-system fields ...)))))))
 199
 200 \f
 201 ;;;
 202 ;;; Simple operating systems.
 203 ;;;
 204
 205 (define %simple-os
 206   (operating-system
 207     (host-name "komputilo")
 208     (timezone "Europe/Berlin")
 209     (locale "en_US.UTF-8")
 210
 211     (bootloader (bootloader-configuration
 212                  (bootloader grub-bootloader)
 213                  (target "/dev/sdX")))
 214     (file-systems (cons (file-system
 215                           (device "my-root")
 216                           (title 'label)
 217                           (mount-point "/")
 218                           (type "ext4"))
 219                         %base-file-systems))
 220     (firmware '())
 221
 222     (users (cons (user-account
 223                   (name "alice")
 224                   (comment "Bob's sister")
 225                   (group "users")
 226                   (supplementary-groups '("wheel" "audio" "video"))
 227                   (home-directory "/home/alice"))
 228                  %base-user-accounts))))
 229
 230 (define-syntax-rule (simple-operating-system user-services ...)
 231   "Return an operating system that includes USER-SERVICES in addition to
 232 %BASE-SERVICES."
 233   (operating-system (inherit %simple-os)
 234                     (services (cons* user-services ... %base-services))))
 235
 236
 237 \f
 238 ;;;
 239 ;;; Tests.
 240 ;;;
 241
 242 (define-record-type* <system-test> system-test make-system-test
 243   system-test?
 244   (name        system-test-name)                  ;string
 245   (value       system-test-value)                 ;%STORE-MONAD value
 246   (description system-test-description)           ;string
 247   (location    system-test-location (innate)      ;<location>
 248                (default (and=> (current-source-location)
 249                                source-properties->location))))
 250
 251 (define (write-system-test test port)
 252   (match test
 253     (($ <system-test> name _ _ ($ <location> file line))
 254      (format port "#<system-test ~a ~a:~a ~a>"
 255              name file line
 256              (number->string (object-address test) 16)))
 257     (($ <system-test> name)
 258      (format port "#<system-test ~a ~a>" name
 259              (number->string (object-address test) 16)))))
 260
 261 (set-record-type-printer! <system-test> write-system-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
 268 (define (fold-system-tests proc seed)
 269   "Invoke PROC on each system test, passing it the test and the previous
 270 result."
 271   (fold-module-public-variables (lambda (obj result)
 272                                   (if (system-test? obj)
 273                                       (cons obj result)
 274                                       result))
 275                                 '()
 276                                 (test-modules)))
 277
 278 (define (all-system-tests)
 279   "Return the list of system tests."
 280   (reverse (fold-system-tests cons '())))
 281
 282 ;;; tests.scm ends here