ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-12 14:16:55 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
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'.
This commit is contained in:
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

60
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,22 +88,19 @@ (define-syntax-rule (with-imported-modules-and-extensions imported-modules
(with-extensions extensions (with-extensions extensions
gexp))) gexp)))
(define (marionette-shepherd-service config) (define (marionette-program device imported-modules extensions)
"Return the Shepherd service for the marionette REPL" "Return the program that runs the marionette REPL on DEVICE. Ensure
(match config IMPORTED-MODULES and EXTENSIONS are accessible from the REPL."
(($ <marionette-configuration> device imported-modules extensions (define code
requirement) (with-imported-modules-and-extensions
(list (shepherd-service `((guix build utils)
(provision '(marionette)) (guix build syscalls)
,@imported-modules)
extensions
#~(begin
(use-modules (ice-9 match)
(ice-9 binary-ports))
;; Always depend on UDEV so that DEVICE is available.
(requirement `(udev ,@requirement))
(modules '((ice-9 match)
(srfi srfi-9 gnu)))
(start
(with-imported-modules-and-extensions imported-modules extensions
#~(lambda ()
(define (self-quoting? x) (define (self-quoting? x)
(letrec-syntax ((one-of (syntax-rules () (letrec-syntax ((one-of (syntax-rules ()
((_) #f) ((_) #f)
@ -113,11 +110,6 @@ (define (self-quoting? x)
(one-of symbol? string? keyword? pair? null? array? (one-of symbol? string? keyword? pair? null? array?
number? boolean? char?))) number? boolean? char?)))
(match (primitive-fork)
(0
(dynamic-wind
(const #t)
(lambda ()
(let ((repl (open-file #$device "r+0")) (let ((repl (open-file #$device "r+0"))
(console (open-file "/dev/console" "r+0"))) (console (open-file "/dev/console" "r+0")))
;; Redirect output to the console. ;; Redirect output to the console.
@ -147,11 +139,27 @@ (define (self-quoting? x)
(stack-ref (make-stack #t) 1) (stack-ref (make-stack #t) 1)
key args) key args)
(write #f repl))))) (write #f repl)))))
(loop)))) (loop))))))
(lambda ()
(primitive-exit 1)))) (program-file "marionette-repl.scm" code))
(pid
pid))))) (define (marionette-shepherd-service config)
"Return the Shepherd service for the marionette REPL"
(match config
(($ <marionette-configuration> device imported-modules extensions
requirement)
(list (shepherd-service
(provision '(marionette))
;; Always depend on UDEV so that DEVICE is available.
(requirement `(udev ,@requirement))
(modules '((ice-9 match)
(srfi srfi-9 gnu)))
(start #~(make-forkexec-constructor
(list #$(marionette-program device
imported-modules
extensions))))
(stop #~(make-kill-destructor))))))) (stop #~(make-kill-destructor)))))))
(define marionette-service-type (define marionette-service-type