Package: guix-patches;
Reported by: Ludovic Courtès <ludo <at> gnu.org>
Date: Wed, 15 Jan 2025 22:14:02 UTC
Severity: normal
Tags: patch
View this message in rfc822 format
From: Ludovic Courtès <ludo <at> gnu.org> To: 75595 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org>, Christopher Baines <guix <at> cbaines.net>, Josselin Poiret <dev <at> jpoiret.xyz>, Ludovic Courtès <ludo <at> gnu.org>, Mathieu Othacehe <othacehe <at> gnu.org>, Simon Tournier <zimon.toutoune <at> gmail.com>, Tobias Geerinckx-Rice <me <at> tobias.gr> Subject: [bug#75595] [PATCH 4/4] inferior: Allow running inferiors in a container. Date: Wed, 15 Jan 2025 23:14:50 +0100
* guix/inferior.scm (container-command-wrapper): New procedures.
(open-bidirectional-pipe): Add #:isolated? and #:bridge-directory.
Call ‘container-command-wrapper’ when #:isolated? is true. Adjust the
argument to ‘spawn’ and ‘execlp’ accordingly.
(inferior-pipe): Add #:isolated? and #:bridge-directory; pass them on
to ‘open-bidirectional-pipe’.
(port->inferior): Add #:bridge-directory and honor it.
(open-inferior): Add #:isolated? and honor it. Call
‘allocate-temporary-directory’ when #:isolated? is true.
Change-Id: Ie0a56de59aac0611d478bda858ab75f48a0853ff
---
guix/inferior.scm | 118 +++++++++++++++++++++++++++++++++-------------
1 file changed, 84 insertions(+), 34 deletions(-)
diff --git a/guix/inferior.scm b/guix/inferior.scm
index ead6148667..a74e9d8665 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -36,6 +36,7 @@ (define-module (guix inferior)
&store-protocol-error))
#:use-module ((guix derivations)
#:select (read-derivation-from-file))
+ #:autoload (guix describe) (current-profile)
#:autoload (guix build syscalls) (mkdtemp!)
#:use-module (guix gexp)
#:use-module (guix search-paths)
@@ -139,13 +140,37 @@ (define (write-inferior inferior port)
(set-record-type-printer! <inferior> write-inferior)
-(define (open-bidirectional-pipe command . args)
+(define (container-command-wrapper command bridge-directory)
+ "Return a command (list of strings) wrapping COMMAND such that it is spawned
+in a new container that shared BRIDGE-DIRECTORY with the host."
+ (let ((guix (or (and=> (current-profile)
+ (cut string-append <> "/bin/guix"))
+ "guix")))
+ `(,guix "container" "run" "--bare" "--feature=guix" "--no-cwd"
+ ,(string-append "--expose=" bridge-directory)
+ "--"
+ ,@command)))
+
+(define* (open-bidirectional-pipe command args
+ #:key isolated? bridge-directory)
"Open a bidirectional pipe to COMMAND invoked with ARGS and return it, as a
regular file port (socket).
+When ISOLATED? is true, run COMMAND in a container that only shares
+BRIDGE-DIRECTORY with the host.
+
This is equivalent to (open-pipe* OPEN_BOTH ...) except that the result is a
regular file port that can be passed to 'select' ('open-pipe*' returns a
custom binary port)."
+ (define wrap
+ ;; Optionally wrap the command so it is spawned via 'guix container run'.
+ ;; This is not as elegant as using 'call-with-container' directly, but the
+ ;; advantage is that it allows us to use 'posix_spawn' below, thus making
+ ;; it reliable in a multi-threaded context.
+ (if isolated?
+ (cut container-command-wrapper <> bridge-directory)
+ identity))
+
;; Make sure the sockets are close-on-exec; failing to do that, a second
;; inferior (for instance) would inherit the underlying file descriptor, and
;; thus (close-port PARENT) in the original process would have no effect:
@@ -156,12 +181,14 @@ (define (open-bidirectional-pipe command . args)
(let* ((void (open-fdes "/dev/null" O_WRONLY))
(pid (catch 'system-error
(lambda ()
- (spawn command (cons command args)
- #:input child
- #:output child
- #:error (if (file-port? (current-error-port))
- (current-error-port)
- void)))
+ (match (wrap (cons command args))
+ ((and (command . _) args)
+ (spawn command args
+ #:input child
+ #:output child
+ #:error (if (file-port? (current-error-port))
+ (current-error-port)
+ void)))))
(const #f)))) ;can't exec, for instance ENOENT
(close-fdes void)
(close-port child)
@@ -187,22 +214,31 @@ (define (open-bidirectional-pipe command . args)
2)))
(dup2 (open-fdes "/dev/null" O_WRONLY)
2))
- (apply execlp command command args))
+ (match (wrap (cons command args))
+ ((and (command . _) args)
+ (apply execlp command args))))
(lambda ()
(primitive-_exit 127))))
(pid
(close-port child)
(values parent pid)))))))
-(define* (inferior-pipe directory command error-port)
+(define* (inferior-pipe directory command error-port
+ #:key isolated? bridge-directory)
"Return two values: an input/output pipe on the Guix instance in DIRECTORY
and its PID. This runs 'DIRECTORY/COMMAND repl' if it exists, or falls back
-to some other method if it's an old Guix."
- (let ((pipe pid (with-error-to-port error-port
- (lambda ()
- (open-bidirectional-pipe
- (string-append directory "/" command)
- "repl" "-t" "machine")))))
+to some other method if it's an old Guix.
+
+When ISOLATED? is true, run COMMAND in a container that only shares
+BRIDGE-DIRECTORY with the host."
+ (let* ((bridge-directory (and isolated? bridge-directory))
+ (pipe pid (with-error-to-port error-port
+ (lambda ()
+ (open-bidirectional-pipe
+ (string-append directory "/" command)
+ '("repl" "-t" "machine")
+ #:isolated? isolated?
+ #:bridge-directory bridge-directory)))))
(if (eof-object? (peek-char pipe))
(begin
(close-port pipe)
@@ -213,30 +249,33 @@ (define* (inferior-pipe directory command error-port)
(lambda ()
(open-bidirectional-pipe
"guile"
- "-L" (string-append directory "/share/guile/site/"
- (effective-version))
- "-C" (string-append directory "/share/guile/site/"
- (effective-version))
- "-C" (string-append directory "/lib/guile/"
- (effective-version) "/site-ccache")
- "-c"
- (object->string
- `(begin
- (primitive-load ,(search-path %load-path
- "guix/repl.scm"))
- ((@ (guix repl) machine-repl))))))))
+ (list "-L" (string-append directory "/share/guile/site/"
+ (effective-version))
+ "-C" (string-append directory "/share/guile/site/"
+ (effective-version))
+ "-C" (string-append directory "/lib/guile/"
+ (effective-version) "/site-ccache")
+ "-c"
+ (object->string
+ `(begin
+ (primitive-load ,(search-path %load-path
+ "guix/repl.scm"))
+ ((@ (guix repl) machine-repl)))))
+ #:isolated? isolated?
+ #:bridge-directory bridge-directory))))
(values pipe pid))))
-(define* (port->inferior pipe #:optional (close close-port))
+(define* (port->inferior pipe #:optional (close close-port)
+ #:key bridge-directory)
"Given PIPE, an input/output port, return an inferior that talks over PIPE.
PIPE is closed with CLOSE when 'close-inferior' is called on the returned
-inferior."
+inferior. Associate the new inferior with BRIDGE-DIRECTORY."
(setvbuf pipe 'line)
(match (read pipe)
(('repl-version 0 rest ...)
(letrec ((result (inferior 'pipe pipe close (cons 0 rest)
- #f ;bridge directory
+ bridge-directory
(delay (%inferior-packages result))
(delay (%inferior-package-table result))
#f)))
@@ -306,14 +345,25 @@ (define* (port->inferior pipe #:optional (close close-port))
(define* (open-inferior directory
#:key (command "bin/guix")
- (error-port (%make-void-port "w")))
+ (error-port (%make-void-port "w"))
+ isolated?)
"Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or
-equivalent. Return #f if the inferior could not be launched."
- (let ((pipe pid (inferior-pipe directory command error-port)))
+equivalent. Return #f if the inferior could not be launched.
+
+When ISOLATED? is true, run COMMAND in a container isolated from the host."
+ ;; When running the command in a container, allocate the directory that will
+ ;; contain the "bridge socket" upfront so it can be bind-mounted in the
+ ;; container.
+ (let* ((bridge-directory (and isolated?
+ (allocate-temporary-directory)))
+ (pipe pid (inferior-pipe directory command error-port
+ #:isolated? isolated?
+ #:bridge-directory bridge-directory)))
(port->inferior pipe
(lambda (port)
(close-port port)
- (waitpid pid)))))
+ (waitpid pid))
+ #:bridge-directory bridge-directory)))
(define (close-inferior inferior)
"Close INFERIOR."
--
2.47.1
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.