[bug#75595,1/4] DRAFT container: Add ‘run’ sub-command.

Message ID afb6b3864b2cb36f50f2aa92661a5db2f549d61b.1736977759.git.ludo@gnu.org
State New
Headers
Series 'guix container run' and isolated inferiors |

Commit Message

Ludovic Courtès Jan. 15, 2025, 10:14 p.m. UTC
  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
  

Patch

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))))))))))