mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-18 21:46:35 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

tests: 'marionette-service-type' nows takes a <marionette-configuration>.

Browse source 
* gnu/tests.scm (<marionette-configuration>): New record type.
(marionette-shepherd-service): Argument now is a <marionette-configuration>.
(marionette-operating-system): Adjust accordingly.  Add #:requirements
parameter and honor it.
This commit is contained in:
Ludovic Courtès 2016-06-27 21:09:08 +02:00
parent 858d372c98
commit 037f9e07cd
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 98 additions and 73 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

171
gnu/tests.scm
View file

@ -27,7 +27,13 @@ (define-module (gnu tests)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (ice-9 match)
#:export (marionette-service-type
#:export (marionette-configuration
marionette-configuration?
marionette-configuration-device
marionette-configuration-imported-modules
marionette-configuration-requirements
marionette-service-type
marionette-operating-system
define-os-with-source
@ -50,81 +56,93 @@ (define-module (gnu tests)
;;;
;;; Code:
(define (marionette-shepherd-service imported-modules)
(define-record-type* <marionette-configuration>
marionette-configuration make-marionette-configuration
marionette-configuration?
(device marionette-configuration-device ;string
(default "/dev/hvc0"))
(imported-modules marionette-configuration-imported-modules
(default '()))
(requirements marionette-configuration-requirements ;list of symbols
(default '())))
(define (marionette-shepherd-service config)
"Return the Shepherd service for the marionette REPL"
(define device
"/dev/hvc0")
(match config
(($ <marionette-configuration> device imported-modules requirement)
(list (shepherd-service
(provision '(marionette))
(list (shepherd-service
(provision '(marionette))
(requirement '(udev)) ;so that DEVICE is available
(modules '((ice-9 match)
(srfi srfi-9 gnu)
(guix build syscalls)
(rnrs bytevectors)))
(imported-modules `((guix build syscalls)
,@imported-modules))
(start
#~(lambda ()
(define (clear-echo termios)
(set-field termios (termios-local-flags)
(logand (lognot (local-flags ECHO))
(termios-local-flags termios))))
;; Always depend on UDEV so that DEVICE is available.
(requirement `(udev ,@requirement))
(define (self-quoting? x)
(letrec-syntax ((one-of (syntax-rules ()
((_) #f)
((_ pred rest ...)
(or (pred x)
(one-of rest ...))))))
(one-of symbol? string? pair? null? vector?
bytevector? number? boolean?)))
(modules '((ice-9 match)
(srfi srfi-9 gnu)
(guix build syscalls)
(rnrs bytevectors)))
(imported-modules `((guix build syscalls)
,@imported-modules))
(start
#~(lambda ()
(define (clear-echo termios)
(set-field termios (termios-local-flags)
(logand (lognot (local-flags ECHO))
(termios-local-flags termios))))
(match (primitive-fork)
(0
(dynamic-wind
(const #t)
(lambda ()
(let* ((repl (open-file #$device "r+0"))
(termios (tcgetattr (fileno repl)))
(console (open-file "/dev/console" "r+0")))
;; Don't echo input back.
(tcsetattr (fileno repl) (tcsetattr-action TCSANOW)
(clear-echo termios))
(define (self-quoting? x)
(letrec-syntax ((one-of (syntax-rules ()
((_) #f)
((_ pred rest ...)
(or (pred x)
(one-of rest ...))))))
(one-of symbol? string? pair? null? vector?
bytevector? number? boolean?)))
;; Redirect output to the console.
(close-fdes 1)
(close-fdes 2)
(dup2 (fileno console) 1)
(dup2 (fileno console) 2)
(close-port console)
(match (primitive-fork)
(0
(dynamic-wind
(const #t)
(lambda ()
(let* ((repl (open-file #$device "r+0"))
(termios (tcgetattr (fileno repl)))
(console (open-file "/dev/console" "r+0")))
;; Don't echo input back.
(tcsetattr (fileno repl) (tcsetattr-action TCSANOW)
(clear-echo termios))
(display 'ready repl)
(let loop ()
(newline repl)
;; Redirect output to the console.
(close-fdes 1)
(close-fdes 2)
(dup2 (fileno console) 1)
(dup2 (fileno console) 2)
(close-port console)
(match (read repl)
((? eof-object?)
(primitive-exit 0))
(expr
(catch #t
(lambda ()
(let ((result (primitive-eval expr)))
(write (if (self-quoting? result)
result
(object->string result))
repl)))
(lambda (key . args)
(print-exception (current-error-port)
(stack-ref (make-stack #t) 1)
key args)
(write #f repl)))))
(loop))))
(lambda ()
(primitive-exit 1))))
(pid
pid))))
(stop #~(make-kill-destructor)))))
(display 'ready repl)
(let loop ()
(newline repl)
(match (read repl)
((? eof-object?)
(primitive-exit 0))
(expr
(catch #t
(lambda ()
(let ((result (primitive-eval expr)))
(write (if (self-quoting? result)
result
(object->string result))
repl)))
(lambda (key . args)
(print-exception (current-error-port)
(stack-ref (make-stack #t) 1)
key args)
(write #f repl)))))
(loop))))
(lambda ()
(primitive-exit 1))))
(pid
pid))))
(stop #~(make-kill-destructor)))))))
(define marionette-service-type
;; This is the type of the "marionette" service, allowing a guest system to
@ -136,12 +154,19 @@ (define marionette-service-type
marionette-shepherd-service)))))
(define* (marionette-operating-system os
#:key (imported-modules '()))
"Return a marionetteed variant of OS such that OS can be used as a marionette
in a virtual machine--i.e., controlled from the host system."
#:key
(imported-modules '())
(requirements '()))
"Return a marionetteed variant of OS such that OS can be used as a
marionette in a virtual machine--i.e., controlled from the host system. The
marionette service in the guest is started after the Shepherd services listed
in REQUIREMENTS."
(operating-system
(inherit os)
(services (cons (service marionette-service-type imported-modules)
(services (cons (service marionette-service-type
(marionette-configuration
(requirements requirements)
(imported-modules imported-modules)))
(operating-system-user-services os)))))
(define-syntax define-os-with-source