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
To reply to this bug, email your comments to 75595 AT debbugs.gnu.org.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix <at> cbaines.net, dev <at> jpoiret.xyz, ludo <at> gnu.org, othacehe <at> gnu.org, zimon.toutoune <at> gmail.com, me <at> tobias.gr, guix-patches <at> gnu.org:bug#75595; Package guix-patches.
(Wed, 15 Jan 2025 22:14:02 GMT) Full text and rfc822 format available.Ludovic Courtès <ludo <at> gnu.org>:guix <at> cbaines.net, dev <at> jpoiret.xyz, ludo <at> gnu.org, othacehe <at> gnu.org, zimon.toutoune <at> gmail.com, me <at> tobias.gr, guix-patches <at> gnu.org.
(Wed, 15 Jan 2025 22:14:02 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: guix-patches <at> gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org>, Christopher Baines <mail <at> cbaines.net>, Josselin Poiret <dev <at> jpoiret.xyz> Subject: [PATCH 0/4] 'guix container run' and isolated inferiors Date: Wed, 15 Jan 2025 23:13:38 +0100
Hello!
You might remember that back in 2018, I sent a ‘guix run’ command
that would let you run programs in a container with hopefully
exactly the authority it needs:
https://lists.gnu.org/archive/html/help-guix/2018-01/msg00108.html
This patch series adds an improved version of that command
as ‘guix container run’. By default, it figures out what extra
authority to give: for X11 programs, it lets ‘DISPLAY’ through and
bind-mounts /tmp/.X11-unix, for DBus programs it maps /etc/machine-id,
and so on.
Alternatively, you can use ‘--bare’ and you get a bare container in
the style of ‘guix shell -C’. It supports ‘-N’, ‘--expose’, and other
options found in ‘guix shell -C’ and related commands.
~~~
But really, my initial motivation was to run inferiors in a container.
Christopher implemented that years ago, using (gnu build linux-container):
https://issues.guix.gnu.org/34638
There were small issues that needed to be addressed, but the main
problem I would have with it today is the fact that we’d call ‘clone’
directly, making it effectively unusuable in a multi-threaded context
(see horror story in <https://issues.guix.gnu.org/55441>, which led
to the implementation of ‘spawn’ in Guile by Josselin.)
So I thought that by having a command-line interface to
‘call-with-container’ (!), which is essentially what ‘guix container run’
is, we would be able to use ‘posix_spawn’ to run that CLI and spawn
inferiors without risk. Incidentally, it is rather simple to implement
and reason about.
This is what the last patch does. I didn’t add tests: the ‘guix’ binary
needs to be in the store, which makes it hard to test. But here’s an
example session:
--8<---------------cut here---------------start------------->8---
$ ./pre-inst-env guile -q
GNU Guile 3.0.9
Copyright (C) 1995-2023 Free Software Foundation, Inc.
Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
This program is free software, and you are welcome to redistribute it
under certain conditions; type `,show c' for details.
Enter `,help' for help.
scheme@(guile-user)> ,use(guix inferior)
scheme@(guile-user)> (open-inferior "/home/ludo/.config/guix/current" #:isolated? #t)
$1 = #<inferior pipe (0 1 1) 7f0adf5923c0>
scheme@(guile-user)> (inferior-eval '(use-modules (ice-9 ftw)) $1)
$2 = #<inferior-object #<unspecified>>
scheme@(guile-user)> (inferior-eval '(scandir "/home/ludo") $1)
$3 = ("." ".." ".cache")
scheme@(guile-user)> ,use(guix)
scheme@(guile-user)> (define s (open-connection))
scheme@(guile-user)> (inferior-eval-with-store $1 s `(lambda (s) (add-text-to-store s "isolated" "hi from inferior!")))
$4 = "/gnu/store/kvnxfbcwn5sdr02y75v2w4fswns0ql8d-isolated"
--8<---------------cut here---------------end--------------->8---
Thoughts?
Ludo’.
Ludovic Courtès (4):
DRAFT container: Add ‘run’ sub-command.
tests: Make ‘inferior-eval-with-store’ test more robust.
inferior: Store the bridge directory name in <inferior>.
inferior: Allow running inferiors in a container.
Makefile.am | 3 +-
guix/inferior.scm | 184 ++++++++++++++------
guix/scripts/container.scm | 4 +-
guix/scripts/container/run.scm | 301 +++++++++++++++++++++++++++++++++
tests/inferior.scm | 19 ++-
5 files changed, 446 insertions(+), 65 deletions(-)
create mode 100644 guix/scripts/container/run.scm
base-commit: d804997897d2a531e0e3186e64df798a7e2e0d1a
--
2.47.1
guix <at> cbaines.net, dev <at> jpoiret.xyz, ludo <at> gnu.org, othacehe <at> gnu.org, zimon.toutoune <at> gmail.com, me <at> tobias.gr, guix-patches <at> gnu.org:bug#75595; Package guix-patches.
(Wed, 15 Jan 2025 22:16:02 GMT) Full text and rfc822 format available.Message #8 received at 75595 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 75595 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 1/4] DRAFT container: Add ‘run’ sub-command. Date: Wed, 15 Jan 2025 23:14:47 +0100
DRAFT missing doc and tests.
* guix/scripts/container.scm (show-help, %actions): Add “run”.
* guix/scripts/container/run.scm: New file.
* Makefile.am (MODULES): Add it.
Change-Id: I0ca1d085649ac059aab597f48bea6e480004bf4c
---
Makefile.am | 3 +-
guix/scripts/container.scm | 4 +-
guix/scripts/container/run.scm | 301 +++++++++++++++++++++++++++++++++
3 files changed, 306 insertions(+), 2 deletions(-)
create mode 100644 guix/scripts/container/run.scm
diff --git a/Makefile.am b/Makefile.am
index f911d432dd..6a3c14278a 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2012-2024 Ludovic Courtès <ludo <at> gnu.org>
+# Copyright © 2012-2025 Ludovic Courtès <ludo <at> gnu.org>
# Copyright © 2013 Andreas Enge <andreas <at> enge.fr>
# Copyright © 2015, 2017 Alex Kost <alezost <at> gmail.com>
# Copyright © 2016, 2018 Mathieu Lirzin <mthl <at> gnu.org>
@@ -380,6 +380,7 @@ MODULES = \
guix/scripts/weather.scm \
guix/scripts/container.scm \
guix/scripts/container/exec.scm \
+ guix/scripts/container/run.scm \
guix/scripts/deploy.scm \
guix/scripts/time-machine.scm \
guix.scm \
diff --git a/guix/scripts/container.scm b/guix/scripts/container.scm
index 70637bca29..becc096744 100644
--- a/guix/scripts/container.scm
+++ b/guix/scripts/container.scm
@@ -31,6 +31,8 @@ (define (show-help)
(newline)
(display (G_ "\
exec execute a command inside of an existing container\n"))
+ (display (G_ "\
+ run run the given command in a new container\n"))
(newline)
(display (G_ "
-h, --help display this help and exit"))
@@ -39,7 +41,7 @@ (define (show-help)
(newline)
(show-bug-report-information))
-(define %actions '("exec"))
+(define %actions '("exec" "run"))
(define (resolve-action name)
(let ((module (resolve-interface
diff --git a/guix/scripts/container/run.scm b/guix/scripts/container/run.scm
new file mode 100644
index 0000000000..fd4e8a5547
--- /dev/null
+++ b/guix/scripts/container/run.scm
@@ -0,0 +1,301 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018-2020, 2025 Ludovic Courtès <ludo <at> gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts container run)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix scripts)
+ #:use-module (guix store)
+ #:use-module (guix packages)
+ #:use-module (guix derivations)
+ #:use-module ((guix build utils) #:select (which mkdir-p))
+ #:use-module (gnu build linux-container)
+ #:use-module (gnu system file-systems)
+ #:use-module (gnu packages)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-37)
+ #:use-module (srfi srfi-71)
+ #:use-module (ice-9 match)
+ #:export (guix-container-run))
+
+
+;;;
+;;; Strongbox.
+;;;
+
+(define (bind-mount-spec/ro item)
+ (and (file-exists? item)
+ (file-system
+ (device item)
+ (mount-point item)
+ (type "none")
+ (flags '(bind-mount read-only))
+ (check? #f))))
+
+(define (bind-mount-spec/rw item)
+ (and (file-exists? item)
+ (file-system
+ (inherit (bind-mount-spec/ro item))
+ (flags '(bind-mount)))))
+
+;; Safe in which applications run.
+(define-immutable-record-type <safe>
+ (safe namespaces mappings environment)
+ safe?
+ (namespaces safe-namespaces)
+ (mappings safe-mappings)
+ (environment safe-environment-variables))
+
+(define (store-item-features store items)
+ "Return a list of \"features\" for ITEM, where features are symbols such as
+'x11, 'dbus, 'alsa, etc. The feature list is determined as a function of the
+packages presumably among ITEMS."
+ (define packages
+ (map (compose (cut package-name->name+version <> #\-)
+ store-path-package-name)
+ items))
+
+ (letrec-syntax ((features (syntax-rules (->)
+ ((_ (package -> feature) rest ...)
+ (let ((lst (features rest ...)))
+ (if (member package packages)
+ (cons 'feature lst)
+ lst)))
+ ((_)
+ '()))))
+ (features ("libx11" -> x11)
+ ("dbus" -> dbus)
+ ("alsa-lib" -> alsa)
+ ("pulseaudio" -> pulseaudio)
+ ("guix" -> guix))))
+
+(define (features->safe features)
+ "Return a safe for the given FEATURES, a list of symbols."
+ (define x11? (memq 'x11 features))
+ (define network? (memq 'network features))
+ (define dbus? (memq 'dbus features))
+ (define alsa? (memq 'alsa features))
+ (define pulseaudio? (memq 'pulseaudio features))
+ (define guix? (memq 'guix features))
+
+ (define mappings
+ (let-syntax ((if (syntax-rules ()
+ ((_ condition body)
+ (if condition
+ (or (and=> body list) '())
+ '()))))
+ (ro (identifier-syntax bind-mount-spec/ro))
+ (rw (identifier-syntax bind-mount-spec/rw)))
+ `(,@(if network? (ro "/var/run/nscd/socket"))
+ ,@(if network? (ro "/etc/ssl"))
+ ,@(if (and guix? (string-prefix? "/" (%daemon-socket-uri)))
+ (ro (%daemon-socket-uri)))
+ ,@(if (or guix? network?) ;/etc/ssl/certs/* points to the store
+ (ro (%store-prefix))) ;the entire store
+ ,@(if guix?
+ (rw (string-append (getenv "HOME") "/.cache/guix")))
+ ,@(if x11? (rw (string-append (getenv "HOME") "/.Xauthority")))
+ ,@(if x11? (rw "/tmp/.X11-unix"))
+ ,@(if x11? (rw (string-append "/run/user/"
+ (number->string (getuid)))))
+ ,@(if dbus? (ro "/etc/machine-id"))
+ ,@(if alsa? (rw "/dev/snd"))
+ ,@(if pulseaudio? (rw (string-append (getenv "HOME") "/.pulse"))))))
+
+ (define namespaces
+ ;; X11 applications need to run in the same IPC namespace as
+ ;; the server.
+ (let ((withdrawn `(,@(if x11? '(ipc) '())
+ ,@(if network? '(net) '()))))
+ (fold delq %namespaces withdrawn)))
+
+ (define environment-variables
+ `("HOME"
+ ,@(if x11? '("DISPLAY") '())
+ ,@(if (or dbus? x11?) '("XDG_RUNTIME_DIR") '())))
+
+ (safe namespaces mappings environment-variables))
+
+(define (store-mapping? file-system)
+ "Return true if FILE-SYSTEM mounts the store."
+ (string=? (file-system-mount-point file-system)
+ (%store-prefix)))
+
+
+;;;
+;;; Options.
+;;;
+
+(define %options
+ (list (option '("bare") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'bare? #t result)))
+ (option '(#\N "network") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'feature 'network result)))
+ (option '(#\W "nesting") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'feature 'guix result)))
+ (option '(#\g "feature") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'feature (string->symbol arg) result)))
+ (option '("no-cwd") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'no-cwd? #t result)))
+ (option '("share") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'file-system-mapping
+ (specification->file-system-mapping arg #t)
+ result)))
+ (option '("expose") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'file-system-mapping
+ (specification->file-system-mapping arg #f)
+ result)))
+
+ (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix run")))))
+
+(define (show-help)
+ (display (G_ "Usage: guix run COMMAND...
+Run COMMAND from PACKAGE in a container.\n"))
+ (display (G_ "
+ --bare create a bare environment without attempting
+ to guess the features needed by COMMAND"))
+ (display (G_ "
+ -N, --network provide access the network"))
+ (display (G_ "
+ -W, --nesting allow use of Guix within the container"))
+ (display (G_ "
+ -g, --feature=NAME provide access to feature NAME"))
+ (display (G_ "
+ --no-cwd do not share current working directory with an
+ isolated container"))
+
+ (display (G_ "
+ --share=SPEC share writable host file system according to SPEC"))
+ (display (G_ "
+ --expose=SPEC expose read-only host file system according to SPEC"))
+ (newline)
+ (display (G_ "
+ -h, --help display this help and exit"))
+ (display (G_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-container-run . args)
+ (define (parse-options)
+ (args-fold* args %options
+ (lambda (opt name arg result)
+ (leave (G_ "~A: unrecognized option~%") name))
+ (lambda (arg result)
+ (alist-cons 'argument arg result))
+ '()))
+
+ (define %not-colon
+ (char-set-complement (char-set #\:)))
+
+ (with-error-handling
+ (let ((options (parse-options)))
+ (match (reverse (filter-map (match-lambda
+ (('argument . argument) argument)
+ (_ #f))
+ options))
+ ((command args ...)
+ (with-store store
+ (let* ((full (search-path (string-tokenize (getenv "PATH")
+ %not-colon)
+ command))
+ (resolved (and=> full readlink*))
+ (prefix (and=> resolved (lambda (file)
+ (and (store-path? file)
+ (direct-store-path file))))))
+ (unless full
+ (leave (G_ "command '~a' not found~%") command))
+ (unless prefix
+ (leave (G_ "command '~a' is not in '~a'~%")
+ command (%store-prefix)))
+
+ (let* ((items (requisites store (list prefix)))
+ (features (append (filter-map (match-lambda
+ (('feature . feature)
+ feature)
+ (_ #f))
+ options)
+ (if (assoc-ref options 'bare?)
+ '()
+ (store-item-features store items))))
+ (safe (features->safe features))
+ (cwd (getcwd))
+ (environment
+ (filter-map (lambda (variable)
+ (match (getenv variable)
+ (#f #f)
+ (value (string-append variable "="
+ value))))
+ (safe-environment-variables safe)))
+ (mappings
+ (append (safe-mappings safe)
+ (if (find store-mapping? (safe-mappings safe))
+ '() ;the whole store is mapped
+ (map bind-mount-spec/ro items))
+ (filter-map (match-lambda
+ (('file-system-mapping . mapping)
+ (file-system-mapping->bind-mount
+ mapping))
+ (_ #f))
+ options)
+ (if (assoc-ref options 'no-cwd?)
+ '()
+ (list (bind-mount-spec/ro cwd))))))
+
+ (call-with-container mappings
+ (lambda ()
+ ;; Inherit specific environment variables.
+ (environ environment)
+
+ (when (getenv "HOME")
+ (mkdir-p (getenv "HOME")))
+
+ (unless (assoc-ref options 'no-cwd?)
+ (chdir cwd))
+
+ (newline)
+ (catch #t
+ (lambda ()
+ (apply execl resolved command args))
+ (lambda (key . args)
+ (print-exception (current-error-port) #f key args)
+ (exit 1))))
+
+ #:guest-uid 1000
+ #:guest-gid 1000
+ #:namespaces (safe-namespaces safe))))))))))
--
2.47.1
guix-patches <at> gnu.org:bug#75595; Package guix-patches.
(Wed, 15 Jan 2025 22:16:02 GMT) Full text and rfc822 format available.Message #11 received at 75595 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 75595 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [PATCH 2/4] tests: Make ‘inferior-eval-with-store’ test more robust. Date: Wed, 15 Jan 2025 23:14:48 +0100
* tests/inferior.scm ("inferior-eval-with-store"): Use ‘random-text’ for
the store item’s body.
Change-Id: Ia39e276955e1836a0272713ff25c4490273c666f
---
tests/inferior.scm | 19 +++++++++++--------
1 file changed, 11 insertions(+), 8 deletions(-)
diff --git a/tests/inferior.scm b/tests/inferior.scm
index 963d405e33..11a27c0006 100644
--- a/tests/inferior.scm
+++ b/tests/inferior.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018-2022 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2018-2022, 2025 Ludovic Courtès <ludo <at> gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -27,6 +27,8 @@ (define-module (test-inferior)
#:use-module (gnu packages bootstrap)
#:use-module (gnu packages guile)
#:use-module (gnu packages sqlite)
+ #:autoload (gcrypt hash) (sha256)
+ #:autoload (rnrs bytevectors) (string->utf8)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-64)
@@ -220,14 +222,15 @@ (define (manifest-entry->list entry)
(close-inferior inferior)
result))
-(test-equal "inferior-eval-with-store"
- (add-text-to-store %store "foo" "Hello, world!")
+(test-assert "inferior-eval-with-store"
(let* ((inferior (open-inferior %top-builddir
- #:command "scripts/guix")))
- (inferior-eval-with-store inferior %store
- '(lambda (store)
- (add-text-to-store store "foo"
- "Hello, world!")))))
+ #:command "scripts/guix"))
+ (text (random-text)))
+ (string=? (inferior-eval-with-store inferior %store
+ `(lambda (store)
+ (add-text-to-store store "foo"
+ ,text)))
+ (store-path "text" (sha256 (string->utf8 text)) "foo"))))
(test-assert "inferior-eval-with-store, &store-protocol-error"
(let* ((inferior (open-inferior %top-builddir
--
2.47.1
guix <at> cbaines.net, dev <at> jpoiret.xyz, ludo <at> gnu.org, othacehe <at> gnu.org, zimon.toutoune <at> gmail.com, me <at> tobias.gr, guix-patches <at> gnu.org:bug#75595; Package guix-patches.
(Wed, 15 Jan 2025 22:16:03 GMT) Full text and rfc822 format available.Message #14 received at 75595 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 75595 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org>, Christopher Baines <mail <at> cbaines.net> Subject: [PATCH 3/4] inferior: Store the bridge directory name in <inferior>. Date: Wed, 15 Jan 2025 23:14:49 +0100
* guix/inferior.scm (<inferior>)[bridge-directory]: New field.
(port->inferior): Add #:bridge-directory and honor it.
(close-inferior): Delete the bridge directory.
(allocate-temporary-directory, inferior-bridge-directory): New procedures.
(open-store-bridge!): Use it instead of ‘call-with-temporary-directory’.
Co-authored-by: Christopher Baines <mail <at> cbaines.net>
Change-Id: Ie469e3f272f29054cc50b1e1afb2784521c2e2e2
---
guix/inferior.scm | 68 ++++++++++++++++++++++++++++++++---------------
1 file changed, 46 insertions(+), 22 deletions(-)
diff --git a/guix/inferior.scm b/guix/inferior.scm
index 8066cce2fc..ead6148667 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018-2024 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2018-2025 Ludovic Courtès <ludo <at> gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -36,6 +36,7 @@ (define-module (guix inferior)
&store-protocol-error))
#:use-module ((guix derivations)
#:select (read-derivation-from-file))
+ #:autoload (guix build syscalls) (mkdtemp!)
#:use-module (guix gexp)
#:use-module (guix search-paths)
#:use-module (guix profiles)
@@ -113,13 +114,15 @@ (define-module (guix inferior)
;; Inferior Guix process.
(define-record-type <inferior>
- (inferior pid socket close version packages table
- bridge-socket)
+ (inferior pid socket close version bridge-directory
+ packages table bridge-socket)
inferior?
(pid inferior-pid)
(socket inferior-socket)
(close inferior-close-socket) ;procedure
(version inferior-version) ;REPL protocol version
+ (bridge-directory %inferior-bridge-directory ;#f | file name
+ set-inferior-bridge-directory!)
(packages inferior-package-promise) ;promise of inferior packages
(table inferior-package-table) ;promise of vhash
@@ -233,6 +236,7 @@ (define* (port->inferior pipe #:optional (close close-port))
(match (read pipe)
(('repl-version 0 rest ...)
(letrec ((result (inferior 'pipe pipe close (cons 0 rest)
+ #f ;bridge directory
(delay (%inferior-packages result))
(delay (%inferior-package-table result))
#f)))
@@ -318,7 +322,14 @@ (define (close-inferior inferior)
;; Close and delete the store bridge, if any.
(when (inferior-bridge-socket inferior)
- (close-port (inferior-bridge-socket inferior)))))
+ (close-port (inferior-bridge-socket inferior)))
+
+ ;; Delete the store bridge socket directory.
+ (when (%inferior-bridge-directory inferior)
+ (false-if-exception
+ (delete-file (in-vicinity (%inferior-bridge-directory inferior)
+ "inferior")))
+ (rmdir (%inferior-bridge-directory inferior)))))
;; Non-self-quoting object of the inferior.
(define-record-type <inferior-object>
@@ -656,6 +667,20 @@ (define (proxy inferior store) ;adapted from (guix ssh)
(memq response-port reads))
(loop))))))
+(define (allocate-temporary-directory)
+ "Return the name of a fresh temporary directory."
+ (let* ((directory (or (getenv "TMPDIR") "/tmp"))
+ (template (string-append directory "/guix-inferior.XXXXXX")))
+ (mkdtemp! template)))
+
+(define (inferior-bridge-directory inferior)
+ "Return the name of the directory shared between INFERIOR and its host to
+contain the \"store bridge\"."
+ (or (%inferior-bridge-directory inferior)
+ (let ((directory (allocate-temporary-directory)))
+ (set-inferior-bridge-directory! inferior directory)
+ directory)))
+
(define (open-store-bridge! inferior)
"Open a \"store bridge\" for INFERIOR--a named socket in /tmp that will be
used to proxy store RPCs from the inferior to the store of the calling
@@ -664,25 +689,24 @@ (define (open-store-bridge! inferior)
;; its store. This ensures the inferior uses the same store, with the same
;; options, the same per-session GC roots, etc.
;; FIXME: This strategy doesn't work for remote inferiors (SSH).
- (call-with-temporary-directory
- (lambda (directory)
- (chmod directory #o700)
- (let ((name (string-append directory "/inferior"))
- (socket (socket AF_UNIX SOCK_STREAM 0)))
- (bind socket AF_UNIX name)
- (listen socket 2)
+ (let ((directory (inferior-bridge-directory inferior)))
+ (chmod directory #o700)
+ (let ((name (string-append directory "/inferior"))
+ (socket (socket AF_UNIX SOCK_STREAM 0)))
+ (bind socket AF_UNIX name)
+ (listen socket 2)
- (send-inferior-request
- `(define %bridge-socket
- (let ((socket (socket AF_UNIX SOCK_STREAM 0)))
- (connect socket AF_UNIX ,name)
- socket))
- inferior)
- (match (accept socket)
- ((client . address)
- (close-port socket)
- (set-inferior-bridge-socket! inferior client)))
- (read-inferior-response inferior)))))
+ (send-inferior-request
+ `(define %bridge-socket
+ (let ((socket (socket AF_UNIX SOCK_STREAM 0)))
+ (connect socket AF_UNIX ,name)
+ socket))
+ inferior)
+ (match (accept socket)
+ ((client . address)
+ (close-port socket)
+ (set-inferior-bridge-socket! inferior client)))
+ (read-inferior-response inferior))))
(define (ensure-store-bridge! inferior)
"Ensure INFERIOR has a connected bridge."
--
2.47.1
guix <at> cbaines.net, dev <at> jpoiret.xyz, ludo <at> gnu.org, othacehe <at> gnu.org, zimon.toutoune <at> gmail.com, me <at> tobias.gr, guix-patches <at> gnu.org:bug#75595; Package guix-patches.
(Wed, 15 Jan 2025 22:16:03 GMT) Full text and rfc822 format available.Message #17 received at 75595 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 75595 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org> Subject: [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
guix-patches <at> gnu.org:bug#75595; Package guix-patches.
(Sun, 02 Feb 2025 17:23:02 GMT) Full text and rfc822 format available.Message #20 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Christopher Baines <mail <at> cbaines.net> To: Ludovic Courtès <ludo <at> gnu.org> Cc: Josselin Poiret <dev <at> jpoiret.xyz>, guix-patches <at> gnu.org Subject: Re: [PATCH 0/4] 'guix container run' and isolated inferiors Date: Sun, 02 Feb 2025 18:22:01 +0100
[Message part 1 (text/plain, inline)]
Ludovic Courtès <ludo <at> gnu.org> writes:
> You might remember that back in 2018, I sent a ‘guix run’ command
> that would let you run programs in a container with hopefully
> exactly the authority it needs:
>
> https://lists.gnu.org/archive/html/help-guix/2018-01/msg00108.html
>
> This patch series adds an improved version of that command
> as ‘guix container run’. By default, it figures out what extra
> authority to give: for X11 programs, it lets ‘DISPLAY’ through and
> bind-mounts /tmp/.X11-unix, for DBus programs it maps /etc/machine-id,
> and so on.
>
> Alternatively, you can use ‘--bare’ and you get a bare container in
> the style of ‘guix shell -C’. It supports ‘-N’, ‘--expose’, and other
> options found in ‘guix shell -C’ and related commands.
>
> ~~~
>
> But really, my initial motivation was to run inferiors in a container.
> Christopher implemented that years ago, using (gnu build linux-container):
>
> https://issues.guix.gnu.org/34638
>
> There were small issues that needed to be addressed, but the main
> problem I would have with it today is the fact that we’d call ‘clone’
> directly, making it effectively unusuable in a multi-threaded context
> (see horror story in <https://issues.guix.gnu.org/55441>, which led
> to the implementation of ‘spawn’ in Guile by Josselin.)
>
> So I thought that by having a command-line interface to
> ‘call-with-container’ (!), which is essentially what ‘guix container run’
> is, we would be able to use ‘posix_spawn’ to run that CLI and spawn
> inferiors without risk. Incidentally, it is rather simple to implement
> and reason about.
>
> This is what the last patch does. I didn’t add tests: the ‘guix’ binary
> needs to be in the store, which makes it hard to test. But here’s an
> example session:
>
> --8<---------------cut here---------------start------------->8---
> $ ./pre-inst-env guile -q
> GNU Guile 3.0.9
> Copyright (C) 1995-2023 Free Software Foundation, Inc.
>
> Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
> This program is free software, and you are welcome to redistribute it
> under certain conditions; type `,show c' for details.
>
> Enter `,help' for help.
> scheme@(guile-user)> ,use(guix inferior)
> scheme@(guile-user)> (open-inferior "/home/ludo/.config/guix/current" #:isolated? #t)
> $1 = #<inferior pipe (0 1 1) 7f0adf5923c0>
> scheme@(guile-user)> (inferior-eval '(use-modules (ice-9 ftw)) $1)
> $2 = #<inferior-object #<unspecified>>
> scheme@(guile-user)> (inferior-eval '(scandir "/home/ludo") $1)
> $3 = ("." ".." ".cache")
> scheme@(guile-user)> ,use(guix)
> scheme@(guile-user)> (define s (open-connection))
> scheme@(guile-user)> (inferior-eval-with-store $1 s `(lambda (s) (add-text-to-store s "isolated" "hi from inferior!")))
> $4 = "/gnu/store/kvnxfbcwn5sdr02y75v2w4fswns0ql8d-isolated"
> --8<---------------cut here---------------end--------------->8---
>
> Thoughts?
I've had a rough look over the changes and they look good to me.
Thanks,
Chris
[signature.asc (application/pgp-signature, inline)]
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.