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 (backdoor-service-type
  25             marionette-operating-system))
  26
  27 ;;; Commentary:
  28 ;;;
  29 ;;; This module provides the infrastructure to run operating system tests.
  30 ;;; The most important part of that is tools to instrument the OS under test,
  31 ;;; essentially allowing to run in a virtual machine controlled by the host
  32 ;;; system--hence the name "marionette".
  33 ;;;
  34 ;;; Code:
  35
  36 (define (marionette-shepherd-service imported-modules)
  37   "Return the Shepherd service for the marionette REPL"
  38   (define device
  39     "/dev/hvc0")
  40
  41   (list (shepherd-service
  42          (provision '(marionette))
  43          (requirement '(udev))                    ;so that DEVICE is available
  44          (modules '((ice-9 match)
  45                     (srfi srfi-9 gnu)
  46                     (guix build syscalls)
  47                     (rnrs bytevectors)))
  48          (imported-modules `((guix build syscalls)
  49                              ,@imported-modules))
  50          (start
  51           #~(lambda ()
  52               (define (clear-echo termios)
  53                 (set-field termios (termios-local-flags)
  54                            (logand (lognot (local-flags ECHO))
  55                                    (termios-local-flags termios))))
  56
  57               (define (self-quoting? x)
  58                 (letrec-syntax ((one-of (syntax-rules ()
  59                                           ((_) #f)
  60                                           ((_ pred rest ...)
  61                                            (or (pred x)
  62                                                (one-of rest ...))))))
  63                   (one-of symbol? string? pair? null? vector?
  64                           bytevector? number? boolean?)))
  65
  66               (match (primitive-fork)
  67                 (0
  68                  (dynamic-wind
  69                    (const #t)
  70                    (lambda ()
  71                      (let* ((repl    (open-file #$device "r+0"))
  72                             (termios (tcgetattr (fileno repl)))
  73                             (console (open-file "/dev/console" "r+0")))
  74                        ;; Don't echo input back.
  75                        (tcsetattr (fileno repl) (tcsetattr-action TCSANOW)
  76                                   (clear-echo termios))
  77
  78                        ;; Redirect output to the console.
  79                        (close-fdes 1)
  80                        (close-fdes 2)
  81                        (dup2 (fileno console) 1)
  82                        (dup2 (fileno console) 2)
  83                        (close-port console)
  84
  85                        (display 'ready repl)
  86                        (let loop ()
  87                          (newline repl)
  88
  89                          (match (read repl)
  90                            ((? eof-object?)
  91                             (primitive-exit 0))
  92                            (expr
  93                             (catch #t
  94                               (lambda ()
  95                                 (let ((result (primitive-eval expr)))
  96                                   (write (if (self-quoting? result)
  97                                              result
  98                                              (object->string result))
  99                                          repl)))
 100                               (lambda (key . args)
 101                                 (print-exception (current-error-port)
 102                                                  (stack-ref (make-stack #t) 1)
 103                                                  key args)
 104                                 (write #f repl)))))
 105                          (loop))))
 106                    (lambda ()
 107                      (primitive-exit 1))))
 108                 (pid
 109                  pid))))
 110          (stop #~(make-kill-destructor)))))
 111
 112 (define marionette-service-type
 113   ;; This is the type of the "marionette" service, allowing a guest system to
 114   ;; be manipulated from the host.  This marionette REPL is essentially a
 115   ;; universal marionette.
 116   (service-type (name 'marionette-repl)
 117                 (extensions
 118                  (list (service-extension shepherd-root-service-type
 119                                           marionette-shepherd-service)))))
 120
 121 (define* (marionette-operating-system os
 122                                       #:key (imported-modules '()))
 123   "Return a marionetteed variant of OS such that OS can be used as a marionette
 124 in a virtual machine--i.e., controlled from the host system."
 125   (operating-system
 126     (inherit os)
 127     (services (cons (service marionette-service-type imported-modules)
 128                     (operating-system-user-services os)))))
 129
 130 ;;; tests.scm ends here