Toggle diff (350 lines)
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@gnu.org>
+# Copyright © 2012-2025 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2013 Andreas Enge <andreas@enge.fr>
# Copyright © 2015, 2017 Alex Kost <alezost@gmail.com>
# Copyright © 2016, 2018 Mathieu Lirzin <mthl@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@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
