gnu/tests.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu tests)
  20   #:use-module (guix gexp)
  21   #:use-module (gnu system)
  22   #:use-module (gnu services)
  23   #:use-module (gnu services shepherd)
  24   #:export (marionette-service-type
  25             marionette-operating-system
  26             define-os-with-source))
  27
  28 ;;; Commentary:
  29 ;;;
  30 ;;; This module provides the infrastructure to run operating system tests.
  31 ;;; The most important part of that is tools to instrument the OS under test,
  32 ;;; essentially allowing to run in a virtual machine controlled by the host
  33 ;;; system--hence the name "marionette".
  34 ;;;
  35 ;;; Code:
  36
  37 (define (marionette-shepherd-service imported-modules)
  38   "Return the Shepherd service for the marionette REPL"
  39   (define device
  40     "/dev/hvc0")
  41
  42   (list (shepherd-service
  43          (provision '(marionette))
  44          (requirement '(udev))                    ;so that DEVICE is available
  45          (modules '((ice-9 match)
  46                     (srfi srfi-9 gnu)
  47                     (guix build syscalls)
  48                     (rnrs bytevectors)))
  49          (imported-modules `((guix build syscalls)
  50                              ,@imported-modules))
  51          (start
  52           #~(lambda ()
  53               (define (clear-echo termios)
  54                 (set-field termios (termios-local-flags)
  55                            (logand (lognot (local-flags ECHO))
  56                                    (termios-local-flags termios))))
  57
  58               (define (self-quoting? x)
  59                 (letrec-syntax ((one-of (syntax-rules ()
  60                                           ((_) #f)
  61                                           ((_ pred rest ...)
  62                                            (or (pred x)
  63                                                (one-of rest ...))))))
  64                   (one-of symbol? string? pair? null? vector?
  65                           bytevector? number? boolean?)))
  66
  67               (match (primitive-fork)
  68                 (0
  69                  (dynamic-wind
  70                    (const #t)
  71                    (lambda ()
  72                      (let* ((repl    (open-file #$device "r+0"))
  73                             (termios (tcgetattr (fileno repl)))
  74                             (console (open-file "/dev/console" "r+0")))
  75                        ;; Don't echo input back.
  76                        (tcsetattr (fileno repl) (tcsetattr-action TCSANOW)
  77                                   (clear-echo termios))
  78
  79                        ;; Redirect output to the console.
  80                        (close-fdes 1)
  81                        (close-fdes 2)
  82                        (dup2 (fileno console) 1)
  83                        (dup2 (fileno console) 2)
  84                        (close-port console)
  85
  86                        (display 'ready repl)
  87                        (let loop ()
  88                          (newline repl)
  89
  90                          (match (read repl)
  91                            ((? eof-object?)
  92                             (primitive-exit 0))
  93                            (expr
  94                             (catch #t
  95                               (lambda ()
  96                                 (let ((result (primitive-eval expr)))
  97                                   (write (if (self-quoting? result)
  98                                              result
  99                                              (object->string result))
 100                                          repl)))
 101                               (lambda (key . args)
 102                                 (print-exception (current-error-port)
 103                                                  (stack-ref (make-stack #t) 1)
 104                                                  key args)
 105                                 (write #f repl)))))
 106                          (loop))))
 107                    (lambda ()
 108                      (primitive-exit 1))))
 109                 (pid
 110                  pid))))
 111          (stop #~(make-kill-destructor)))))
 112
 113 (define marionette-service-type
 114   ;; This is the type of the "marionette" service, allowing a guest system to
 115   ;; be manipulated from the host.  This marionette REPL is essentially a
 116   ;; universal backdoor.
 117   (service-type (name 'marionette-repl)
 118                 (extensions
 119                  (list (service-extension shepherd-root-service-type
 120                                           marionette-shepherd-service)))))
 121
 122 (define* (marionette-operating-system os
 123                                       #:key (imported-modules '()))
 124   "Return a marionetteed variant of OS such that OS can be used as a marionette
 125 in a virtual machine--i.e., controlled from the host system."
 126   (operating-system
 127     (inherit os)
 128     (services (cons (service marionette-service-type imported-modules)
 129                     (operating-system-user-services os)))))
 130
 131 (define-syntax define-os-with-source
 132   (syntax-rules (use-modules operating-system)
 133     "Define two variables: OS containing the given operating system, and
 134 SOURCE containing the source to define OS as an sexp.
 135
 136 This is convenient when we need both the <operating-system> object so we can
 137 instantiate it, and the source to create it so we can store in in a file in
 138 the system under test."
 139     ((_ (os source)
 140         (use-modules modules ...)
 141         (operating-system fields ...))
 142      (begin
 143        (define os
 144          (operating-system fields ...))
 145        (define source
 146          '(begin
 147             (use-modules modules ...)
 148             (operating-system fields ...)))))))
 149
 150 ;;; tests.scm ends here