me
/
guix
Archived
1
0
Fork 0
Code

tests: Fork and exec a new Guile for the marionette REPL. 

By merely forking PID 1, details from PID 1 (shepherd) would leak into
the marionette process, such as the set of modules in scope and state
inherited from the shepherd process (<service> instances, fibers,
etc.).  Running a fresh Guile instance avoids that.

* gnu/tests.scm (marionette-program): New procedure.
(marionette-shepherd-service): Change 'start' to use
'make-forkexec-constructor', and run the result of 'marionette-program'.
master
Ludovic Courtès 2023-04-21 15:38:06 +02:00
parent fb32e226ce
commit a09c7da8f8
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 60 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

112
gnu/tests.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016-2020, 2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016-2020, 2022-2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
@ -88,6 +88,61 @@
(with-extensions extensions (with-extensions extensions
gexp))) gexp)))
(define (marionette-program device imported-modules extensions)
"Return the program that runs the marionette REPL on DEVICE. Ensure
IMPORTED-MODULES and EXTENSIONS are accessible from the REPL."
(define code
(with-imported-modules-and-extensions
`((guix build utils)
(guix build syscalls)
,@imported-modules)
extensions
#~(begin
(use-modules (ice-9 match)
(ice-9 binary-ports))
(define (self-quoting? x)
(letrec-syntax ((one-of (syntax-rules ()
((_) #f)
((_ pred rest ...)
(or (pred x)
(one-of rest ...))))))
(one-of symbol? string? keyword? pair? null? array?
number? boolean? char?)))
(let ((repl (open-file #$device "r+0"))
(console (open-file "/dev/console" "r+0")))
;; Redirect output to the console.
(close-fdes 1)
(close-fdes 2)
(dup2 (fileno console) 1)
(dup2 (fileno console) 2)
(close-port console)
(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))))))
(program-file "marionette-repl.scm" code))
(define (marionette-shepherd-service config) (define (marionette-shepherd-service config)
"Return the Shepherd service for the marionette REPL" "Return the Shepherd service for the marionette REPL"
(match config (match config
@ -101,57 +156,10 @@
(modules '((ice-9 match) (modules '((ice-9 match)
(srfi srfi-9 gnu))) (srfi srfi-9 gnu)))
(start (start #~(make-forkexec-constructor
(with-imported-modules-and-extensions imported-modules extensions (list #$(marionette-program device
#~(lambda () imported-modules
(define (self-quoting? x) extensions))))
(letrec-syntax ((one-of (syntax-rules ()
((_) #f)
((_ pred rest ...)
(or (pred x)
(one-of rest ...))))))
(one-of symbol? string? keyword? pair? null? array?
number? boolean? char?)))
(match (primitive-fork)
(0
(dynamic-wind
(const #t)
(lambda ()
(let ((repl (open-file #$device "r+0"))
(console (open-file "/dev/console" "r+0")))
;; Redirect output to the console.
(close-fdes 1)
(close-fdes 2)
(dup2 (fileno console) 1)
(dup2 (fileno console) 2)
(close-port console)
(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))))))) (stop #~(make-kill-destructor)))))))
(define marionette-service-type (define marionette-service-type