From patchwork Thu Oct 27 03:50:59 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Maxim Cournoyer X-Patchwork-Id: 44146 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 C2C1027BBE9; Thu, 27 Oct 2022 04:52:39 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-3.7 required=5.0 tests=BAYES_00,DKIM_ADSP_CUSTOM_MED, DKIM_INVALID,DKIM_SIGNED,FREEMAIL_FROM,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H2,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 DEAD127BBEA for ; Thu, 27 Oct 2022 04:52:34 +0100 (BST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1ontwH-00032m-4D; Wed, 26 Oct 2022 23:52:17 -0400 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 1ontw6-0002it-0Y for guix-patches@gnu.org; Wed, 26 Oct 2022 23:52:08 -0400 Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1ontw3-0001Qc-5q for guix-patches@gnu.org; Wed, 26 Oct 2022 23:52:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ontw3-00029p-1m for guix-patches@gnu.org; Wed, 26 Oct 2022 23:52:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#58812] [PATCH 4/5] guix: shell: Add '--symlink' option. Resent-From: Maxim Cournoyer Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 27 Oct 2022 03:52:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58812 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 58812@debbugs.gnu.org Cc: Maxim Cournoyer Received: via spool by 58812-submit@debbugs.gnu.org id=B58812.16668426988232 (code B ref 58812); Thu, 27 Oct 2022 03:52:03 +0000 Received: (at 58812) by debbugs.gnu.org; 27 Oct 2022 03:51:38 +0000 Received: from localhost ([127.0.0.1]:55709 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ontvd-00028h-Cz for submit@debbugs.gnu.org; Wed, 26 Oct 2022 23:51:38 -0400 Received: from mail-qk1-f180.google.com ([209.85.222.180]:35464) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ontva-000289-0q for 58812@debbugs.gnu.org; Wed, 26 Oct 2022 23:51:34 -0400 Received: by mail-qk1-f180.google.com with SMTP id t25so59069qkm.2 for <58812@debbugs.gnu.org>; Wed, 26 Oct 2022 20:51:33 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=29aVTpeUdjJsL8lVL89s8hfCGp0QFSMpucAGwZp64Yg=; b=VtKk0+vPD9AXP47OBxX8BXnoCANd2enXxUKyMGpvvcX2itpLVbKiOciiQjb2PtK6+C WHwWmqQMeXspfvrdpwrXI6hGQYNUTK1cllEmr4JipHbUW1uiMjUAFiJTcBmXhVNd5rho /VTb2T+v8K/dwQmx07zHOw7SGhwSsZ9ckcnbiR6gKWfbvZ/DuSfPKXYVuKzX+DM7kEPH GEZYnehQphjR8H2rQxG2jNl3SJNv0LBiPoJiGUJ3KD1uD3i6gk9A/+s748mdYIdv/Go0 Bm6CAnufo8fubUFpYH1LxtMQ80F3zDA+057lQyUlS3/Fh73e8BXqRMBKRebIXf2S9LDV ggsA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=29aVTpeUdjJsL8lVL89s8hfCGp0QFSMpucAGwZp64Yg=; b=SkExV2tOeTfzprKKd6di4mFZY3pB/44jgae0yuyqXE3iKHnnLQ2ojDMEfrqXG27ch4 Ei1CDIWlx1ejxgzZyAPTnT8zBgJs6T5Uq09sM7TM37kTsTFwWt4cF9siIgZAaaLeKFl/ twFHiS456oqRUsTp7Dtvf7Vf8f7nECZdfptV19GhlKb5ky9Dd2IO4HhxwrMy7Ur4FJMX NpxmNWOdp20QLeeVbzV3QxKADnxKONCX8N5LbXxU+UGHO1NEj+K81ctGHIqYi1wneVkc PjjHOHW9O4wjLPnTZioLbW9gFQ/sDG9U4lkC7qHNToe3JIUxKHDDCHU+h68wCLnLjaEH 8Pwg== X-Gm-Message-State: ACrzQf3zugw4Y29VNq6LGO40zf/JFJebqkrb4AAfEaNPk1HemaE2qvom vc15t2r7yDmYJcXfqPlXFPtFN98pnUA= X-Google-Smtp-Source: AMsMyM6epFMwJjqBJnoA3oBCvzoSEYCSodz4hhWzRflMmhD40N8I5nICZpMlgs9R6r9hOlyRDVP5xg== X-Received: by 2002:a05:620a:6c5:b0:6f1:99b:a2b6 with SMTP id 5-20020a05620a06c500b006f1099ba2b6mr19626036qky.299.1666842688127; Wed, 26 Oct 2022 20:51:28 -0700 (PDT) Received: from localhost.localdomain (dsl-152-21.b2b2c.ca. [66.158.152.21]) by smtp.gmail.com with ESMTPSA id x1-20020a05620a448100b006ec771d8f89sm255488qkp.112.2022.10.26.20.51.27 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 26 Oct 2022 20:51:27 -0700 (PDT) From: Maxim Cournoyer Date: Wed, 26 Oct 2022 23:50:59 -0400 Message-Id: <20221027035100.28852-4-maxim.cournoyer@gmail.com> X-Mailer: git-send-email 2.37.3 In-Reply-To: <20221027035100.28852-1-maxim.cournoyer@gmail.com> References: <20221027035100.28852-1-maxim.cournoyer@gmail.com> 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: , Sender: "Guix-patches" Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * guix/scripts/pack.scm (%options): Extract symlink parsing logic to... (symlink-spec-option-parser): ... here. (self-contained-tarball/builder): Extract symlink->directives logic to... * gnu/build/install.scm (make-symlink->directives): ... here. Add a comment mentioning why a relative file name is used for the link target. * guix/scripts/environment.scm (show-environment-options-help): Document new --symlink option. (%default-options): Add default value for symlinks. (%options): Register new symlink option. (launch-environment/container): Add #:symlinks argument and extend doc. Create symlinks using evaluate-populate-directive and make-symlink->directives. (guix-environment*): Pass symlinks arguments to launch-environment/container. * doc/guix.texi (Invoking guix shell): Document it. * tests/guix-shell.sh: Test it. --- doc/guix.texi | 9 +++++- gnu/build/install.scm | 18 ++++++++++++ guix/scripts/environment.scm | 38 +++++++++++++++++------- guix/scripts/pack.scm | 57 +++++++++++++++--------------------- tests/guix-shell.sh | 17 +++++++++++ 5 files changed, 94 insertions(+), 45 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 2f7ab61aec..4bd3c18223 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -49,7 +49,7 @@ Copyright @copyright{} 2017 humanitiesNerd@* Copyright @copyright{} 2017, 2021 Christine Lemmer-Webber@* Copyright @copyright{} 2017, 2018, 2019, 2020, 2021, 2022 Marius Bakke@* Copyright @copyright{} 2017, 2019, 2020, 2022 Hartmut Goebel@* -Copyright @copyright{} 2017, 2019, 2020, 2021 Maxim Cournoyer@* +Copyright @copyright{} 2017, 2019, 2020, 2021, 2022 Maxim Cournoyer@* Copyright @copyright{} 2017–2022 Tobias Geerinckx-Rice@* Copyright @copyright{} 2017 George Clemmer@* Copyright @copyright{} 2017 Andy Wingo@* @@ -6230,6 +6230,12 @@ directory: guix shell --container --expose=$HOME=/exchange guile -- guile @end example +@cindex symbolic links, guix shell +@item --symlink=@var{spec} +@itemx -S @var{spec} +For containers, create the symbolic links specified by @var{spec}, as +documented in @ref{pack-symlink-option}. + @cindex file system hierarchy standard (FHS) @cindex FHS (file system hierarchy standard) @item --emulate-fhs @@ -7022,6 +7028,7 @@ Compress the resulting tarball using @var{tool}---one of @code{gzip}, @code{zstd}, @code{bzip2}, @code{xz}, @code{lzip}, or @code{none} for no compression. +@anchor{pack-symlink-option} @item --symlink=@var{spec} @itemx -S @var{spec} Add the symlinks specified by @var{spec} to the pack. This option can diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 15cc29b2c8..8cf772f3ea 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -19,6 +19,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu build install) + #:use-module ((guix build union) #:select (relative-file-name)) #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (guix build store-copy) @@ -26,6 +27,7 @@ (define-module (gnu build install) #:use-module (ice-9 match) #:export (install-boot-config evaluate-populate-directive + make-symlink->directives populate-root-file-system install-database-and-gc-roots populate-single-profile-directory @@ -124,6 +126,22 @@ (define target* (if (string-suffix? "/" target) directive) (apply throw args))))) +(define (make-symlink->directives directory) + "Return a procedure that turn symlinks specs into directives that target +DIRECTORY." + (match-lambda + ((source '-> target) + (let ((target (string-append directory "/" target)) + (parent (dirname source))) + ;; Never add a 'directory' directive for "/" so as to preserve its + ;; ownership and avoid adding the same entries multiple times. + `(,@(if (string=? parent "/") + '() + `((directory ,parent))) + ;; Note: a relative file name is used for compatibility with + ;; relocatable packs. + (,source -> ,(relative-file-name parent target))))))) + (define (directives store) "Return a list of directives to populate the root file system that will host STORE." diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index de9bc8f98d..bd95329c5c 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -33,8 +33,10 @@ (define-module (guix scripts environment) #:use-module ((guix gexp) #:select (lower-object)) #:use-module (guix scripts) #:use-module (guix scripts build) + #:use-module ((guix scripts pack) #:select (symlink-spec-option-parser)) #:use-module (guix transformations) #:autoload (ice-9 ftw) (scandir) + #:use-module (gnu build install) #:autoload (gnu build linux-container) (call-with-container %namespaces user-namespace-supported? unprivileged-user-namespace-supported? @@ -120,6 +122,9 @@ (define (show-environment-options-help) --expose=SPEC for containers, expose read-only host file system according to SPEC")) (display (G_ " + -S, --symlink=SPEC for containers, add symlinks to the profile according + to SPEC, e.g. \"/usr/bin/env=bin/env\".")) + (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (display (G_ " --bootstrap use bootstrap binaries to build the environment"))) @@ -157,6 +162,7 @@ (define (show-help) (define %default-options `((system . ,(%current-system)) (substitutes? . #t) + (symlinks . ()) (offload? . #t) (graft? . #t) (print-build-trace? . #t) @@ -256,6 +262,7 @@ (define %options (alist-cons 'file-system-mapping (specification->file-system-mapping arg #f) result))) + (option '(#\S "symlink") #t #f symlink-spec-option-parser) (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) @@ -672,7 +679,7 @@ (define* (launch-environment/fork command profile manifest (define* (launch-environment/container #:key command bash user user-mappings profile manifest link-profile? network? map-cwd? emulate-fhs? (setup-hook #f) - (white-list '())) + (symlinks '()) (white-list '())) "Run COMMAND within a container that features the software in PROFILE. Environment variables are set according to the search paths of MANIFEST. The global shell is BASH, a file name for a GNU Bash binary in the store. When @@ -690,6 +697,9 @@ (define* (launch-environment/container #:key command bash user user-mappings LINK-PROFILE? creates a symbolic link from ~/.guix-profile to the environment profile. +SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be +added to the container. + Preserve environment variables whose name matches the one of the regexps in WHILE-LIST." (define (optional-mapping->fs mapping) @@ -797,6 +807,10 @@ (define fhs-mappings (mkdir-p home-dir) (setenv "HOME" home-dir) + ;; Create symlinks. + (for-each (cut evaluate-populate-directive <> ".") + (append-map (make-symlink->directives profile) symlinks)) + ;; Call an additional setup procedure, if provided. (when setup-hook (setup-hook profile)) @@ -970,6 +984,7 @@ (define (guix-environment* opts) (let* ((pure? (assoc-ref opts 'pure)) (container? (assoc-ref opts 'container?)) (link-prof? (assoc-ref opts 'link-profile?)) + (symlinks (assoc-ref opts 'symlinks)) (network? (assoc-ref opts 'network?)) (no-cwd? (assoc-ref opts 'no-cwd?)) (emulate-fhs? (assoc-ref opts 'emulate-fhs?)) @@ -1010,15 +1025,17 @@ (define-syntax-rule (with-store/maybe store exp ...) (when container? (assert-container-features)) - (when (and (not container?) link-prof?) - (leave (G_ "'--link-profile' cannot be used without '--container'~%"))) - (when (and (not container?) user) - (leave (G_ "'--user' cannot be used without '--container'~%"))) - (when (and (not container?) no-cwd?) - (leave (G_ "--no-cwd cannot be used without '--container'~%"))) - (when (and (not container?) emulate-fhs?) - (leave (G_ "'--emulate-fhs' cannot be used without '--container~%'"))) - + (when (not container?) + (when link-prof? + (leave (G_ "'--link-profile' cannot be used without '--container'~%"))) + (when user + (leave (G_ "'--user' cannot be used without '--container'~%"))) + (when no-cwd? + (leave (G_ "--no-cwd cannot be used without '--container'~%"))) + (when emulate-fhs? + (leave (G_ "'--emulate-fhs' cannot be used without '--container~%'"))) + (when (pair? symlinks) + (leave (G_ "'--symlink' cannot be used without '--container~%'")))) (with-store/maybe store (with-status-verbosity (assoc-ref opts 'verbosity) @@ -1099,6 +1116,7 @@ (define manifest #:network? network? #:map-cwd? (not no-cwd?) #:emulate-fhs? emulate-fhs? + #:symlinks symlinks #:setup-hook (and emulate-fhs? setup-fhs)))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 06849e4761..e3bddc4274 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -61,7 +61,9 @@ (define-module (guix scripts pack) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 match) - #:export (self-contained-tarball + #:export (symlink-spec-option-parser + + self-contained-tarball debian-archive docker-image squashfs-image @@ -160,6 +162,21 @@ (define str (string-join names "-")) ((_) str) ((names ... _) (loop names)))))) +(define (symlink-spec-option-parser opt name arg result) + "A SRFI-37 option parser for the --symlink option." + ;; Note: Using 'string-split' allows us to handle empty + ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is + ;; a symlink to the profile) correctly. + (match (string-split arg (char-set #\=)) + ((source target) + (let ((symlinks (assoc-ref result 'symlinks))) + (alist-cons 'symlinks + `((,source -> ,target) ,@symlinks) + (alist-delete 'symlinks result eq?)))) + (x + (leave (G_ "~a: invalid symlink specification~%") + arg)))) + ;;; ;;; Tarball format. @@ -204,30 +221,15 @@ (define (import-module? module) (use-modules (guix build pack) (guix build store-copy) (guix build utils) - ((guix build union) #:select (relative-file-name)) (gnu build install) (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) + (srfi srfi-26)) (define %root "root") - (define symlink->directives - ;; Return "populate directives" to make the given symlink and its - ;; parent directories. - (match-lambda - ((source '-> target) - (let ((target (string-append #$profile "/" target)) - (parent (dirname source))) - ;; Never add a 'directory' directive for "/" so as to - ;; preserve its ownership when extracting the archive (see - ;; below), and also because this would lead to adding the - ;; same entries twice in the tarball. - `(,@(if (string=? parent "/") - '() - `((directory ,parent))) - (,source - -> ,(relative-file-name parent target))))))) + ;; Return "populate directives" to make the given symlink and its + ;; parent directories. + (define symlink->directives (make-symlink->directives #$profile)) (define directives ;; Fully-qualified symlinks. @@ -1208,20 +1210,7 @@ (define %options (lambda (opt name arg result) (alist-cons 'compressor (lookup-compressor arg) result))) - (option '(#\S "symlink") #t #f - (lambda (opt name arg result) - ;; Note: Using 'string-split' allows us to handle empty - ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is - ;; a symlink to the profile) correctly. - (match (string-split arg (char-set #\=)) - ((source target) - (let ((symlinks (assoc-ref result 'symlinks))) - (alist-cons 'symlinks - `((,source -> ,target) ,@symlinks) - (alist-delete 'symlinks result eq?)))) - (x - (leave (G_ "~a: invalid symlink specification~%") - arg))))) + (option '(#\S "symlink") #t #f symlink-spec-option-parser) (option '("save-provenance") #f #f (lambda (opt name arg result) (alist-cons 'save-provenance? #t result))) diff --git a/tests/guix-shell.sh b/tests/guix-shell.sh index 9a6b055264..32dd997fe7 100644 --- a/tests/guix-shell.sh +++ b/tests/guix-shell.sh @@ -20,6 +20,8 @@ # Test the 'guix shell' alias. # +. tests/utils.sh + guix shell --version configdir="t-guix-shell-config-$$" @@ -32,6 +34,21 @@ export XDG_CONFIG_HOME guix shell --bootstrap --pure guile-bootstrap -- guile --version +# '--symlink' can only be used with --container. +! guix shell --bootstrap guile-bootstrap -S /dummy=bin/guile + +if has_container_support; then + # '--symlink' works. + echo "TESTING SYMLINK IN CONTAINER" + guix shell --bootstrap guile-bootstrap --container \ + --symlink=/usr/bin/guile=bin/guile -- \ + /usr/bin/guile --version + + # A bad symlink spec causes the command to fail. + ! guix shell --bootstrap -CS bin/guile=/usr/bin/guile guile-bootstrap \ + -- exit +fi + # '--ad-hoc' is a thing of the past. ! guix shell --ad-hoc guile-bootstrap