Commit | Line | Data |
---|---|---|
957afcae LC |
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 |