nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

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