From patchwork Wed Jan 15 22:14:47 2025 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 37083 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 162FA27BBEA; Wed, 15 Jan 2025 22:16:37 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-7.6 required=5.0 tests=BAYES_00,DKIMWL_WL_HIGH, DKIM_SIGNED,DKIM_VALID,MAILING_LIST_MULTI,RCVD_IN_DNSWL_BLOCKED, RCVD_IN_VALIDITY_CERTIFIED,RCVD_IN_VALIDITY_RPBL,RCVD_IN_VALIDITY_SAFE, SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 2CD0027BBE2 for ; Wed, 15 Jan 2025 22:16:36 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1tYBgE-0003g2-W5; Wed, 15 Jan 2025 17:16:07 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1tYBgD-0003ec-AU for guix-patches@gnu.org; Wed, 15 Jan 2025 17:16:05 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1tYBgC-0004Ik-O3; Wed, 15 Jan 2025 17:16:04 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:References:In-Reply-To:Date:From:To:Subject; bh=13u6fOIDbADLF4w9/BD9fWokUtcwkgJVmoylI1L/8Do=; b=SGxF2nEKAu6qFXl7YsZn8ZoJpdWi5d1bz47LAPFE/1WD/Yev1N2YUKv5fPl/AkFuRsSPbMpFvauh8yjKl8BwiYJpM2Jwb2vtdW/kjaH5GjLCpeTgri/wWKp6Tlolwe6m7k1LtWIB0be5oXUPdDGfk4zFDHAkMdEwx3GRaqZsXEdNK8CF2Jc8sX42DmUOkKvH0TyaDL4qMgV6XaG57KspqvBwdJxMYLGvzMQO3O7+kTaC0OUkK5CqyEQekeRjsGJdGf6A5SD3SnAtRZAq+cyg1ngli+tV57ww9Y1kl0Buy0tJwT7veKj2TY6ysp8x1A8QkD3rIg//U9ConErvowZxWg==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1tYBgA-0002td-4J; Wed, 15 Jan 2025 17:16:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#75595] [PATCH 1/4] DRAFT container: Add =?utf-8?b?4oCYcnVu4oCZ?= sub-command. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix@cbaines.net, dev@jpoiret.xyz, ludo@gnu.org, othacehe@gnu.org, zimon.toutoune@gmail.com, me@tobias.gr, guix-patches@gnu.org Resent-Date: Wed, 15 Jan 2025 22:16:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 75595 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 75595@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= , Christopher Baines , Josselin Poiret , Ludovic =?utf-8?q?Court=C3=A8s?= , Mathieu Othacehe , Simon Tournier , Tobias Geerinckx-Rice X-Debbugs-Original-Xcc: Christopher Baines , Josselin Poiret , Ludovic =?utf-8?q?Court=C3=A8s?= , Mathieu Othacehe , Simon Tournier , Tobias Geerinckx-Rice Received: via spool by 75595-submit@debbugs.gnu.org id=B75595.173697930710897 (code B ref 75595); Wed, 15 Jan 2025 22:16:02 +0000 Received: (at 75595) by debbugs.gnu.org; 15 Jan 2025 22:15:07 +0000 Received: from localhost ([127.0.0.1]:59072 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tYBfG-0002pR-4O for submit@debbugs.gnu.org; Wed, 15 Jan 2025 17:15:07 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:60064) by debbugs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.84_2) (envelope-from ) id 1tYBfD-0002lB-Nm for 75595@debbugs.gnu.org; Wed, 15 Jan 2025 17:15:04 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1tYBf8-00041w-EE; Wed, 15 Jan 2025 17:14:58 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=13u6fOIDbADLF4w9/BD9fWokUtcwkgJVmoylI1L/8Do=; b=Mo1SVjOaS1G2WEj1KVwc skibGYrMuU6joTHFCRGUkqd5sNzVMlixb9NJouMduu/NgyDeLXllF/Ik7Y3pJSsKw7ipDKytiWKuX oKMvvjNE9tticytHqr3bzzSNslxTQD2XRAyf9Lrp40ER0VxMvtVCEB2PeJn/mrf/hOLbHbtCqxVQQ 0oW/Vnk6cu+jwVuizLqhQtBX6kvdWmgzLFnFave3XufNSpiFyCNZjqql8EbWB3lOhLGK5VUtmx8si OZsYvvo3cttN1GFia0jgAyqC+JqwGSPB5MT6E2xvMHK2vPgY9uDP1ImWXFv1X3bSabYjvAUeYxF2C 5RZcZBOgIavBxg==; From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Wed, 15 Jan 2025 23:14:47 +0100 Message-ID: X-Mailer: git-send-email 2.47.1 In-Reply-To: References: MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches 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 +# Copyright © 2012-2025 Ludovic Courtès # Copyright © 2013 Andreas Enge # Copyright © 2015, 2017 Alex Kost # Copyright © 2016, 2018 Mathieu Lirzin @@ -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 +;;; +;;; 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 . + +(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 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))))))))))