* [bug#58812] [PATCH 2/5] tests: Add a tests/utils.sh support file.
2022-10-27 3:50 ` [bug#58812] [PATCH 1/5] Makefile.am: Sort EXTRA_DIST entries Maxim Cournoyer
@ 2022-10-27 3:50 ` Maxim Cournoyer
2022-11-09 21:07 ` [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell' Ludovic Courtès
2022-10-27 3:50 ` [bug#58812] [PATCH 3/5] install: Validate symlink target in evaluate-populate-directive Maxim Cournoyer
` (2 subsequent siblings)
3 siblings, 1 reply; 37+ messages in thread
From: Maxim Cournoyer @ 2022-10-27 3:50 UTC (permalink / raw)
To: 58812; +Cc: Maxim Cournoyer
The purpose of this file will be to accumulate support shell functions for the
shell-authored tests.
* tests/shell-utils.scm: New file.
* tests/utils.sh: Likewise.
* Makefile.am (EXTRA_DIST): Register them.
---
Makefile.am | 3 +++
tests/shell-utils.scm | 29 +++++++++++++++++++++++++++++
tests/utils.sh | 33 +++++++++++++++++++++++++++++++++
3 files changed, 65 insertions(+)
create mode 100644 tests/shell-utils.scm
create mode 100644 tests/utils.sh
diff --git a/Makefile.am b/Makefile.am
index 6cc7c0c4a0..14cbdcb011 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -16,6 +16,7 @@
# Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
# Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
# Copyright © 2021 Andrew Tropin <andrew@trop.in>
+# Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
#
# This file is part of GNU Guix.
#
@@ -700,7 +701,9 @@ EXTRA_DIST += \
tests/keys/rsa.pub \
tests/keys/signing-key.pub \
tests/keys/signing-key.sec \
+ tests/shell-utils.scm \
tests/test.drv \
+ tests/utils.sh \
$(TESTS)
if !BUILD_DAEMON_OFFLOAD
diff --git a/tests/shell-utils.scm b/tests/shell-utils.scm
new file mode 100644
index 0000000000..3ae9a414cd
--- /dev/null
+++ b/tests/shell-utils.scm
@@ -0,0 +1,29 @@
+;; GNU Guix --- Functional package management for GNU
+;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;
+;; 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/>.
+;;
+;; Commentary:
+;;
+;; This file contains procedures that support the shell functions defined in
+;; tests/utils.sh.
+(use-modules (gnu build linux-container))
+
+(define (container-support?)
+ (unless (and (user-namespace-supported?)
+ (unprivileged-user-namespace-supported?)
+ (setgroups-supported?))
+ (exit 1)))
diff --git a/tests/utils.sh b/tests/utils.sh
new file mode 100644
index 0000000000..ba17f0de15
--- /dev/null
+++ b/tests/utils.sh
@@ -0,0 +1,33 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+#
+# 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/>.
+#
+# Commentary:
+#
+# This file provides utility shell functions that can be used in the shell
+# test scripts. The file is intended to be sourced as a shell library.
+
+BASEDIR=$(dirname "$0")
+
+HAS_CONTAINER_SUPPORT=
+has_container_support() {
+ if [ -z "$HAS_CONTAINER_SUPPORT" ]; then
+ guile -l "$BASEDIR/shell-utils.scm" -c '(container-support?)'
+ HAS_CONTAINER_SUPPORT=$?
+ fi
+ return "$HAS_CONTAINER_SUPPORT"
+}
--
2.37.3
^ permalink raw reply related [flat|nested] 37+ messages in thread* [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell'.
2022-10-27 3:50 ` [bug#58812] [PATCH 2/5] tests: Add a tests/utils.sh support file Maxim Cournoyer
@ 2022-11-09 21:07 ` Ludovic Courtès
2022-11-10 3:38 ` Maxim Cournoyer
2022-11-10 4:23 ` [bug#59164] [PATCH v2 1/4] Makefile.am: Sort EXTRA_DIST entries Maxim Cournoyer
0 siblings, 2 replies; 37+ messages in thread
From: Ludovic Courtès @ 2022-11-09 21:07 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: 58812
Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
> The purpose of this file will be to accumulate support shell functions for the
> shell-authored tests.
>
> * tests/shell-utils.scm: New file.
> * tests/utils.sh: Likewise.
> * Makefile.am (EXTRA_DIST): Register them.
Maybe we can discuss this one separately since it’s no longer strictly
necessary if we move tests to ‘tests/guix-environment-container.sh’?
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell'.
2022-11-09 21:07 ` [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell' Ludovic Courtès
@ 2022-11-10 3:38 ` Maxim Cournoyer
2022-11-10 4:23 ` [bug#59164] [PATCH v2 1/4] Makefile.am: Sort EXTRA_DIST entries Maxim Cournoyer
1 sibling, 0 replies; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-10 3:38 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 58812
Hi,
Ludovic Courtès <ludo@gnu.org> writes:
> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>
>> The purpose of this file will be to accumulate support shell functions for the
>> shell-authored tests.
>>
>> * tests/shell-utils.scm: New file.
>> * tests/utils.sh: Likewise.
>> * Makefile.am (EXTRA_DIST): Register them.
>
> Maybe we can discuss this one separately since it’s no longer strictly
> necessary if we move tests to ‘tests/guix-environment-container.sh’?
Since it's not immediately necessary, I've dropped the commit for now.
We can resurrect it or something similar if/when the need arises.
--
Thanks,
Maxim
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#59164] [PATCH v2 1/4] Makefile.am: Sort EXTRA_DIST entries.
2022-11-09 21:07 ` [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell' Ludovic Courtès
2022-11-10 3:38 ` Maxim Cournoyer
@ 2022-11-10 4:23 ` Maxim Cournoyer
2022-11-10 4:23 ` [bug#59161] [PATCH v2 2/4] install: Validate symlink target in evaluate-populate-directive Maxim Cournoyer
` (2 more replies)
1 sibling, 3 replies; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-10 4:23 UTC (permalink / raw)
To: 59164; +Cc: Maxim Cournoyer
* Makefile.am (EXTRA_DIST): Sort.
---
Makefile.am | 52 ++++++++++++++++++++++++++--------------------------
1 file changed, 26 insertions(+), 26 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 47886721fa..c3af23b68e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -660,49 +660,49 @@ dist_fishcompletion_DATA = etc/completion/fish/guix.fish
nodist_selinux_policy_DATA = etc/guix-daemon.cil
EXTRA_DIST += \
- HACKING \
- ROADMAP \
- TODO \
- CODE-OF-CONDUCT \
.dir-locals.el \
.guix-authorizations \
.guix-channel \
- scripts/guix.in \
- etc/disarchive-manifest.scm \
- etc/guix-install.sh \
- etc/news.scm \
- etc/release-manifest.scm \
- etc/source-manifest.scm \
- etc/system-tests.scm \
- etc/time-travel-manifest.scm \
- etc/historical-authorizations \
+ CODE-OF-CONDUCT \
+ HACKING \
+ ROADMAP \
+ TODO \
+ bootstrap \
build-aux/build-self.scm \
- build-aux/compile-all.scm \
- build-aux/cuirass/hurd-manifest.scm \
- build-aux/check-final-inputs-self-contained.scm \
build-aux/check-channel-news.scm \
+ build-aux/check-final-inputs-self-contained.scm \
+ build-aux/compile-all.scm \
build-aux/compile-as-derivation.scm \
+ build-aux/config.rpath \
build-aux/convert-xref.scm \
+ build-aux/cuirass/hurd-manifest.scm \
build-aux/generate-authors.scm \
build-aux/test-driver.scm \
- build-aux/update-guix-package.scm \
build-aux/update-NEWS.scm \
- tests/test.drv \
+ build-aux/update-guix-package.scm \
+ doc/build.scm \
+ etc/disarchive-manifest.scm \
+ etc/guix-install.sh \
+ etc/historical-authorizations \
+ etc/news.scm \
+ etc/release-manifest.scm \
+ etc/source-manifest.scm \
+ etc/system-tests.scm \
+ etc/time-travel-manifest.scm \
+ scripts/guix.in \
tests/cve-sample.json \
- tests/keys/signing-key.pub \
- tests/keys/signing-key.sec \
tests/keys/civodul.pub \
- tests/keys/rsa.pub \
tests/keys/dsa.pub \
- tests/keys/ed25519.pub \
- tests/keys/ed25519.sec \
tests/keys/ed25519-2.pub \
tests/keys/ed25519-2.sec \
tests/keys/ed25519-3.pub \
tests/keys/ed25519-3.sec \
- build-aux/config.rpath \
- bootstrap \
- doc/build.scm \
+ tests/keys/ed25519.pub \
+ tests/keys/ed25519.sec \
+ tests/keys/rsa.pub \
+ tests/keys/signing-key.pub \
+ tests/keys/signing-key.sec \
+ tests/test.drv \
$(TESTS)
if !BUILD_DAEMON_OFFLOAD
--
2.37.3
^ permalink raw reply related [flat|nested] 37+ messages in thread* [bug#59161] [PATCH v2 2/4] install: Validate symlink target in evaluate-populate-directive.
2022-11-10 4:23 ` [bug#59164] [PATCH v2 1/4] Makefile.am: Sort EXTRA_DIST entries Maxim Cournoyer
@ 2022-11-10 4:23 ` Maxim Cournoyer
2022-11-10 4:23 ` [bug#59162] [PATCH v2 3/4] guix: shell: Add '--symlink' option Maxim Cournoyer
2022-11-10 4:23 ` [bug#59163] [PATCH v2 4/4] shell: Detect --symlink spec problems early Maxim Cournoyer
2 siblings, 0 replies; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-10 4:23 UTC (permalink / raw)
To: 59161; +Cc: Maxim Cournoyer
* gnu/build/install.scm (evaluate-populate-directive): By default, error when
the target of a symlink doesn't exist. Always ensure TARGET ends with "/".
(populate-root-file-system): Call evaluate-populate-directive with
#:error-on-dangling-symlink #t and add comment.
---
gnu/build/install.scm | 60 ++++++++++++++++++++++++++++---------------
1 file changed, 40 insertions(+), 20 deletions(-)
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index f5c8407b89..33a9616c0d 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -56,19 +57,24 @@ (define (install-boot-config bootcfg bootcfg-location mount-point)
(define* (evaluate-populate-directive directive target
#:key
(default-gid 0)
- (default-uid 0))
+ (default-uid 0)
+ (error-on-dangling-symlink? #t))
"Evaluate DIRECTIVE, an sexp describing a file or directory to create under
directory TARGET. DEFAULT-UID and DEFAULT-GID are the default UID and GID in
the context of the caller. If the directive matches those defaults then,
-'chown' won't be run."
+'chown' won't be run. When ERROR-ON-DANGLING-SYMLINK? is true, abort with an
+error when a dangling symlink would be created."
+ (define target* (if (string-suffix? "/" target)
+ target
+ (string-append target "/")))
(let loop ((directive directive))
(catch 'system-error
(lambda ()
(match directive
(('directory name)
- (mkdir-p (string-append target name)))
+ (mkdir-p (string-append target* name)))
(('directory name uid gid)
- (let ((dir (string-append target name)))
+ (let ((dir (string-append target* name)))
(mkdir-p dir)
;; If called from a context without "root" permissions, "chown"
;; to root will fail. In that case, do not try to run "chown"
@@ -78,27 +84,38 @@ (define* (evaluate-populate-directive directive target
(chown dir uid gid))))
(('directory name uid gid mode)
(loop `(directory ,name ,uid ,gid))
- (chmod (string-append target name) mode))
+ (chmod (string-append target* name) mode))
(('file name)
- (call-with-output-file (string-append target name)
+ (call-with-output-file (string-append target* name)
(const #t)))
(('file name (? string? content))
- (call-with-output-file (string-append target name)
+ (call-with-output-file (string-append target* name)
(lambda (port)
(display content port))))
((new '-> old)
- (let try ()
- (catch 'system-error
- (lambda ()
- (symlink old (string-append target new)))
- (lambda args
- ;; When doing 'guix system init' on the current '/', some
- ;; symlinks may already exists. Override them.
- (if (= EEXIST (system-error-errno args))
- (begin
- (delete-file (string-append target new))
- (try))
- (apply throw args))))))))
+ (let ((new* (string-append target* new)))
+ (let try ()
+ (catch 'system-error
+ (lambda ()
+ (when error-on-dangling-symlink?
+ ;; When the symbolic link points to a relative path,
+ ;; checking if its target exists must be done relatively
+ ;; to the link location.
+ (unless (if (string-prefix? "/" old)
+ (file-exists? old)
+ (with-directory-excursion (dirname new*)
+ (file-exists? old)))
+ (error (format #f "symlink `~a' points to nonexistent \
+file `~a'" new* old))))
+ (symlink old new*))
+ (lambda args
+ ;; When doing 'guix system init' on the current '/', some
+ ;; symlinks may already exists. Override them.
+ (if (= EEXIST (system-error-errno args))
+ (begin
+ (delete-file new*)
+ (try))
+ (apply throw args)))))))))
(lambda args
;; Usually we can only get here when installing to an existing root,
;; as with 'guix system init foo.scm /'.
@@ -142,7 +159,10 @@ (define* (populate-root-file-system system target
includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM.
EXTRAS is a list of directives appended to the built-in directives to populate
TARGET."
- (for-each (cut evaluate-populate-directive <> target)
+ ;; It's expected that some symbolic link targets do not exist yet, so do not
+ ;; error on dangling links.
+ (for-each (cut evaluate-populate-directive <> target
+ #:error-on-dangling-symlink? #f)
(append (directives (%store-directory)) extras))
;; Add system generation 1.
--
2.37.3
^ permalink raw reply related [flat|nested] 37+ messages in thread* [bug#59162] [PATCH v2 3/4] guix: shell: Add '--symlink' option.
2022-11-10 4:23 ` [bug#59164] [PATCH v2 1/4] Makefile.am: Sort EXTRA_DIST entries Maxim Cournoyer
2022-11-10 4:23 ` [bug#59161] [PATCH v2 2/4] install: Validate symlink target in evaluate-populate-directive Maxim Cournoyer
@ 2022-11-10 4:23 ` Maxim Cournoyer
2022-11-10 4:23 ` [bug#59163] [PATCH v2 4/4] shell: Detect --symlink spec problems early Maxim Cournoyer
2 siblings, 0 replies; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-10 4:23 UTC (permalink / raw)
To: 59162; +Cc: Maxim Cournoyer
* 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: Add a --symlink (negative) test.
* tests/guix-environment-container.sh: Add tests.
---
doc/guix.texi | 9 ++++-
gnu/build/install.scm | 18 +++++++++
guix/scripts/environment.scm | 38 ++++++++++++++-----
guix/scripts/pack.scm | 57 ++++++++++++-----------------
tests/guix-environment-container.sh | 12 ++++++
tests/guix-shell.sh | 3 ++
6 files changed, 92 insertions(+), 45 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index 3f76184495..94c3f29790 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@*
@@ -6242,6 +6242,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
@@ -7034,6 +7040,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 33a9616c0d..031a97e91b 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -19,6 +19,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(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..7174dd72d2 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)
+ #:autoload (guix scripts pack) (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))))
+
\f
;;;
;;; 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-environment-container.sh b/tests/guix-environment-container.sh
index fb2c19b193..b509e52e26 100644
--- a/tests/guix-environment-container.sh
+++ b/tests/guix-environment-container.sh
@@ -241,3 +241,15 @@ guix shell -CF --bootstrap guile-bootstrap glibc \
"glibc-for-fhs")
0
1))'
+
+# '--symlink' works.
+echo "TESTING SYMLINK IN CONTAINER"
+guix shell --bootstrap guile-bootstrap --container \
+ --symlink=/usr/bin/guile=bin/guile -- \
+ /usr/bin/guile --version
+
+# An invalid symlink spec causes the command to fail.
+! guix shell --bootstrap -CS bin/guile=/usr/bin/guile guile-bootstrap -- exit
+
+# A dangling symlink causes the command to fail.
+! guix shell --bootstrap -CS /usr/bin/python=bin/python guile-bootstrap -- exit
diff --git a/tests/guix-shell.sh b/tests/guix-shell.sh
index 9a6b055264..cb2b53466d 100644
--- a/tests/guix-shell.sh
+++ b/tests/guix-shell.sh
@@ -32,6 +32,9 @@ 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
+
# '--ad-hoc' is a thing of the past.
! guix shell --ad-hoc guile-bootstrap
--
2.37.3
^ permalink raw reply related [flat|nested] 37+ messages in thread* [bug#59163] [PATCH v2 4/4] shell: Detect --symlink spec problems early.
2022-11-10 4:23 ` [bug#59164] [PATCH v2 1/4] Makefile.am: Sort EXTRA_DIST entries Maxim Cournoyer
2022-11-10 4:23 ` [bug#59161] [PATCH v2 2/4] install: Validate symlink target in evaluate-populate-directive Maxim Cournoyer
2022-11-10 4:23 ` [bug#59162] [PATCH v2 3/4] guix: shell: Add '--symlink' option Maxim Cournoyer
@ 2022-11-10 4:23 ` Maxim Cournoyer
2 siblings, 0 replies; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-10 4:23 UTC (permalink / raw)
To: 59163; +Cc: Maxim Cournoyer
* guix/scripts/pack.scm (symlink-spec-option-parser): Remove extraneous
char-set. Raise an exception when the target is an absolute file name.
(guix-pack): Move with-error-handler earlier.
* guix/scripts/shell.scm (guix-shell): Likewise.
* guix/scripts/environment.scm (guix-environment): Wrap the whole
guix-environment* call with the with-error-handling handler.
* tests/guix-shell.sh: Add test.
* tests/guix-pack.sh: Adjust symlink spec.
---
guix/scripts/environment.scm | 294 +++++++++++++++++------------------
guix/scripts/pack.scm | 155 ++++++++++--------
guix/scripts/shell.scm | 77 ++++-----
tests/guix-pack.sh | 2 +-
4 files changed, 273 insertions(+), 255 deletions(-)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 7174dd72d2..ce299c4533 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -975,158 +975,158 @@ (define-command (guix-environment . args)
(category development)
(synopsis "spawn one-off software environments (deprecated)")
- (guix-environment* (parse-args args)))
+ (with-error-handling
+ (guix-environment* (parse-args args))))
(define (guix-environment* opts)
"Run the 'guix environment' command on OPTS, an alist resulting for
command-line option processing with 'parse-command-line'."
- (with-error-handling
- (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?))
- (user (assoc-ref opts 'user))
- (bootstrap? (assoc-ref opts 'bootstrap?))
- (system (assoc-ref opts 'system))
- (profile (assoc-ref opts 'profile))
- (command (or (assoc-ref opts 'exec)
- ;; Spawn a shell if the user didn't specify
- ;; anything in particular.
- (if container?
- ;; The user's shell is likely not available
- ;; within the container.
- '("/bin/sh")
- (list %default-shell))))
- (mappings (pick-all opts 'file-system-mapping))
- (white-list (pick-all opts 'inherit-regexp)))
-
- (define store-needed?
- ;; Whether connecting to the daemon is needed.
- (or container? (not profile)))
-
- (define-syntax-rule (with-store/maybe store exp ...)
- ;; Evaluate EXP... with STORE bound to a connection, unless
- ;; STORE-NEEDED? is false, in which case STORE is bound to #f.
- (let ((proc (lambda (store) exp ...)))
- (if store-needed?
- (with-store s
- (set-build-options-from-command-line s opts)
- (with-build-handler (build-notifier #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:verbosity
- (assoc-ref opts 'verbosity)
- #:dry-run?
- (assoc-ref opts 'dry-run?))
- (proc s)))
- (proc #f))))
-
- (when container? (assert-container-features))
-
- (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)
- (define manifest-from-opts
- (options/resolve-packages store opts))
-
- (define manifest
- (if profile
- (profile-manifest profile)
- manifest-from-opts))
-
- (when (and profile
- (> (length (manifest-entries manifest-from-opts)) 0))
- (leave (G_ "'--profile' cannot be used with package options~%")))
-
- (when (null? (manifest-entries manifest))
- (warning (G_ "no packages specified; creating an empty environment~%")))
-
- ;; Use the bootstrap Guile when requested.
- (parameterize ((%graft? (assoc-ref opts 'graft?))
- (%guile-for-build
- (and store-needed?
- (package-derivation
- store
- (if bootstrap?
- %bootstrap-guile
- (default-guile))))))
- (run-with-store store
- ;; Containers need a Bourne shell at /bin/sh.
- (mlet* %store-monad ((bash (environment-bash container?
- bootstrap?
- system))
- (prof-drv (if profile
- (return #f)
- (manifest->derivation
- manifest system bootstrap?)))
- (profile -> (if profile
- (readlink* profile)
- (derivation->output-path prof-drv)))
- (gc-root -> (assoc-ref opts 'gc-root)))
-
- ;; First build the inputs. This is necessary even for
- ;; --search-paths. Additionally, we might need to build bash for
- ;; a container.
- (mbegin %store-monad
- (mwhen store-needed?
- (built-derivations (append
- (if prof-drv (list prof-drv) '())
- (if (derivation? bash) (list bash) '()))))
- (mwhen gc-root
- (register-gc-root profile gc-root))
-
- (mwhen (assoc-ref opts 'check?)
- (return
- (if container?
- (warning (G_ "'--check' is unnecessary \
+ (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?))
+ (user (assoc-ref opts 'user))
+ (bootstrap? (assoc-ref opts 'bootstrap?))
+ (system (assoc-ref opts 'system))
+ (profile (assoc-ref opts 'profile))
+ (command (or (assoc-ref opts 'exec)
+ ;; Spawn a shell if the user didn't specify
+ ;; anything in particular.
+ (if container?
+ ;; The user's shell is likely not available
+ ;; within the container.
+ '("/bin/sh")
+ (list %default-shell))))
+ (mappings (pick-all opts 'file-system-mapping))
+ (white-list (pick-all opts 'inherit-regexp)))
+
+ (define store-needed?
+ ;; Whether connecting to the daemon is needed.
+ (or container? (not profile)))
+
+ (define-syntax-rule (with-store/maybe store exp ...)
+ ;; Evaluate EXP... with STORE bound to a connection, unless
+ ;; STORE-NEEDED? is false, in which case STORE is bound to #f.
+ (let ((proc (lambda (store) exp ...)))
+ (if store-needed?
+ (with-store s
+ (set-build-options-from-command-line s opts)
+ (with-build-handler (build-notifier #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:verbosity
+ (assoc-ref opts 'verbosity)
+ #:dry-run?
+ (assoc-ref opts 'dry-run?))
+ (proc s)))
+ (proc #f))))
+
+ (when container? (assert-container-features))
+
+ (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)
+ (define manifest-from-opts
+ (options/resolve-packages store opts))
+
+ (define manifest
+ (if profile
+ (profile-manifest profile)
+ manifest-from-opts))
+
+ (when (and profile
+ (> (length (manifest-entries manifest-from-opts)) 0))
+ (leave (G_ "'--profile' cannot be used with package options~%")))
+
+ (when (null? (manifest-entries manifest))
+ (warning (G_ "no packages specified; creating an empty environment~%")))
+
+ ;; Use the bootstrap Guile when requested.
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%guile-for-build
+ (and store-needed?
+ (package-derivation
+ store
+ (if bootstrap?
+ %bootstrap-guile
+ (default-guile))))))
+ (run-with-store store
+ ;; Containers need a Bourne shell at /bin/sh.
+ (mlet* %store-monad ((bash (environment-bash container?
+ bootstrap?
+ system))
+ (prof-drv (if profile
+ (return #f)
+ (manifest->derivation
+ manifest system bootstrap?)))
+ (profile -> (if profile
+ (readlink* profile)
+ (derivation->output-path prof-drv)))
+ (gc-root -> (assoc-ref opts 'gc-root)))
+
+ ;; First build the inputs. This is necessary even for
+ ;; --search-paths. Additionally, we might need to build bash for
+ ;; a container.
+ (mbegin %store-monad
+ (mwhen store-needed?
+ (built-derivations (append
+ (if prof-drv (list prof-drv) '())
+ (if (derivation? bash) (list bash) '()))))
+ (mwhen gc-root
+ (register-gc-root profile gc-root))
+
+ (mwhen (assoc-ref opts 'check?)
+ (return
+ (if container?
+ (warning (G_ "'--check' is unnecessary \
when using '--container'; doing nothing~%"))
- (validate-child-shell-environment profile manifest))))
-
- (cond
- ((assoc-ref opts 'search-paths)
- (show-search-paths profile manifest #:pure? pure?)
- (return #t))
- (container?
- (let ((bash-binary
- (if bootstrap?
- (derivation->output-path bash)
- (string-append (derivation->output-path bash)
- "/bin/sh"))))
- (launch-environment/container #:command command
- #:bash bash-binary
- #:user user
- #:user-mappings mappings
- #:profile profile
- #:manifest manifest
- #:white-list white-list
- #:link-profile? link-prof?
- #:network? network?
- #:map-cwd? (not no-cwd?)
- #:emulate-fhs? emulate-fhs?
- #:symlinks symlinks
- #:setup-hook
- (and emulate-fhs?
- setup-fhs))))
-
- (else
- (return
- (exit/status
- (launch-environment/fork command profile manifest
- #:white-list white-list
- #:pure? pure?))))))))))))))
+ (validate-child-shell-environment profile manifest))))
+
+ (cond
+ ((assoc-ref opts 'search-paths)
+ (show-search-paths profile manifest #:pure? pure?)
+ (return #t))
+ (container?
+ (let ((bash-binary
+ (if bootstrap?
+ (derivation->output-path bash)
+ (string-append (derivation->output-path bash)
+ "/bin/sh"))))
+ (launch-environment/container #:command command
+ #:bash bash-binary
+ #:user user
+ #:user-mappings mappings
+ #:profile profile
+ #:manifest manifest
+ #:white-list white-list
+ #:link-profile? link-prof?
+ #:network? network?
+ #:map-cwd? (not no-cwd?)
+ #:emulate-fhs? emulate-fhs?
+ #:symlinks symlinks
+ #:setup-hook
+ (and emulate-fhs?
+ setup-fhs))))
+
+ (else
+ (return
+ (exit/status
+ (launch-environment/fork command profile manifest
+ #:white-list white-list
+ #:pure? pure?)))))))))))))
;;; Local Variables:
;;; eval: (put 'with-store/maybe 'scheme-indent-function 1)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index e3bddc4274..a101900736 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -42,6 +42,7 @@ (define-module (guix scripts pack)
#:use-module (guix profiles)
#:use-module (guix describe)
#:use-module (guix derivations)
+ #:use-module (guix diagnostics)
#:use-module (guix search-paths)
#:use-module (guix build-system gnu)
#:use-module (guix scripts build)
@@ -59,6 +60,7 @@ (define-module (guix scripts pack)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
#:export (symlink-spec-option-parser
@@ -163,12 +165,27 @@ (define str (string-join names "-"))
((names ... _) (loop names))))))
(define (symlink-spec-option-parser opt name arg result)
- "A SRFI-37 option parser for the --symlink option."
+ "A SRFI-37 option parser for the --symlink option. The symlink spec accepts
+the link file name as its left-hand side value and its target as its
+right-hand side value. The target must be a relative link."
;; 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 #\=))
+ (match (string-split arg #\=)
((source target)
+ (when (string-prefix? "/" target)
+ (raise-exception
+ (make-compound-condition
+ (formatted-message (G_ "symlink target is absolute: '~a'~%") target)
+ (condition
+ (&fix-hint (hint (format #f (G_ "The target of the symlink must be
+relative rather than absolute, as it is relative to the profile created.
+Perhaps the source and target components of the symlink spec were inverted?
+Below is a valid example, where the @file{/usr/bin/env} symbolic link is to
+target the profile's @file{bin/env} file:
+@example
+--symlink=/usr/bin/env=bin/env
+@end example"))))))))
(let ((symlinks (assoc-ref result 'symlinks)))
(alist-cons 'symlinks
`((,source -> ,target) ,@symlinks)
@@ -1310,74 +1327,74 @@ (define-command (guix-pack . args)
(category development)
(synopsis "create application bundles")
- (define opts
- (parse-command-line args %options (list %default-options)))
-
- (define maybe-package-argument
- ;; Given an option pair, return a package, a package/output tuple, or #f.
- (match-lambda
- (('argument . spec)
- (call-with-values
- (lambda ()
- (specification->package+output spec))
- list))
- (('expression . exp)
- (read/eval-package-expression exp))
- (x #f)))
-
- (define (manifest-from-args store opts)
- (let* ((transform (options->transformation opts))
- (packages (map (match-lambda
- (((? package? package) output)
- (list (transform package) output))
- ((? package? package)
- (list (transform package) "out")))
- (reverse
- (filter-map maybe-package-argument opts))))
- (manifests (filter-map (match-lambda
- (('manifest . file) file)
- (_ #f))
- opts)))
- (define with-provenance
- (if (assoc-ref opts 'save-provenance?)
- (lambda (manifest)
- (map-manifest-entries
- (lambda (entry)
- (let ((entry (manifest-entry-with-provenance entry)))
- (unless (assq 'provenance (manifest-entry-properties entry))
- (warning (G_ "could not determine provenance of package ~a~%")
- (manifest-entry-name entry)))
- entry))
- manifest))
- identity))
-
- (with-provenance
- (cond
- ((and (not (null? manifests)) (not (null? packages)))
- (leave (G_ "both a manifest and a package list were given~%")))
- ((not (null? manifests))
- (concatenate-manifests
- (map (lambda (file)
- (let ((user-module (make-user-module
- '((guix profiles) (gnu)))))
- (load* file user-module)))
- manifests)))
- (else
- (packages->manifest packages))))))
-
- (define (process-file-arg opts name)
- ;; Validate that the file exists and return it as a <local-file> object,
- ;; else #f.
- (let ((value (assoc-ref opts name)))
- (match value
- ((and (? string?) (not (? file-exists?)))
- (leave (G_ "file provided with option ~a does not exist: ~a~%")
- (string-append "--" (symbol->string name)) value))
- ((? string?)
- (local-file value))
- (#f #f))))
-
(with-error-handling
+ (define opts
+ (parse-command-line args %options (list %default-options)))
+
+ (define maybe-package-argument
+ ;; Given an option pair, return a package, a package/output tuple, or #f.
+ (match-lambda
+ (('argument . spec)
+ (call-with-values
+ (lambda ()
+ (specification->package+output spec))
+ list))
+ (('expression . exp)
+ (read/eval-package-expression exp))
+ (x #f)))
+
+ (define (manifest-from-args store opts)
+ (let* ((transform (options->transformation opts))
+ (packages (map (match-lambda
+ (((? package? package) output)
+ (list (transform package) output))
+ ((? package? package)
+ (list (transform package) "out")))
+ (reverse
+ (filter-map maybe-package-argument opts))))
+ (manifests (filter-map (match-lambda
+ (('manifest . file) file)
+ (_ #f))
+ opts)))
+ (define with-provenance
+ (if (assoc-ref opts 'save-provenance?)
+ (lambda (manifest)
+ (map-manifest-entries
+ (lambda (entry)
+ (let ((entry (manifest-entry-with-provenance entry)))
+ (unless (assq 'provenance (manifest-entry-properties entry))
+ (warning (G_ "could not determine provenance of package ~a~%")
+ (manifest-entry-name entry)))
+ entry))
+ manifest))
+ identity))
+
+ (with-provenance
+ (cond
+ ((and (not (null? manifests)) (not (null? packages)))
+ (leave (G_ "both a manifest and a package list were given~%")))
+ ((not (null? manifests))
+ (concatenate-manifests
+ (map (lambda (file)
+ (let ((user-module (make-user-module
+ '((guix profiles) (gnu)))))
+ (load* file user-module)))
+ manifests)))
+ (else
+ (packages->manifest packages))))))
+
+ (define (process-file-arg opts name)
+ ;; Validate that the file exists and return it as a <local-file> object,
+ ;; else #f.
+ (let ((value (assoc-ref opts name)))
+ (match value
+ ((and (? string?) (not (? file-exists?)))
+ (leave (G_ "file provided with option ~a does not exist: ~a~%")
+ (string-append "--" (symbol->string name)) value))
+ ((? string?)
+ (local-file value))
+ (#f #f))))
+
(with-store store
(with-status-verbosity (assoc-ref opts 'verbosity)
;; Set the build options before we do anything else.
diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm
index 7a379122ae..2fc1dc942a 100644
--- a/guix/scripts/shell.scm
+++ b/guix/scripts/shell.scm
@@ -534,43 +534,44 @@ (define-command (guix-shell . args)
(category development)
(synopsis "spawn one-off software environments")
- (define (cache-entries directory)
- (filter-map (match-lambda
- ((or "." "..") #f)
- (file (string-append directory "/" file)))
- (or (scandir directory) '())))
-
- (define* (entry-expiration file)
- ;; Return the time at which FILE, a cached profile, is considered expired.
- (match (false-if-exception (lstat file))
- (#f 0) ;FILE may have been deleted in the meantime
- (st (+ (stat:atime st) (* 60 60 24 7)))))
-
- (define opts
- (parse-args args))
-
- (define interactive?
- (not (assoc-ref opts 'exec)))
-
- (if (assoc-ref opts 'check?)
- (record-hint 'shell-check)
- (when (and interactive?
- (not (hint-given? 'shell-check))
- (not (assoc-ref opts 'container?))
- (not (assoc-ref opts 'search-paths)))
- (display-hint (G_ "Consider passing the @option{--check} option once
+ (with-error-handling
+ (define (cache-entries directory)
+ (filter-map (match-lambda
+ ((or "." "..") #f)
+ (file (string-append directory "/" file)))
+ (or (scandir directory) '())))
+
+ (define* (entry-expiration file)
+ ;; Return the time at which FILE, a cached profile, is considered expired.
+ (match (false-if-exception (lstat file))
+ (#f 0) ;FILE may have been deleted in the meantime
+ (st (+ (stat:atime st) (* 60 60 24 7)))))
+
+ (define opts
+ (parse-args args))
+
+ (define interactive?
+ (not (assoc-ref opts 'exec)))
+
+ (if (assoc-ref opts 'check?)
+ (record-hint 'shell-check)
+ (when (and interactive?
+ (not (hint-given? 'shell-check))
+ (not (assoc-ref opts 'container?))
+ (not (assoc-ref opts 'search-paths)))
+ (display-hint (G_ "Consider passing the @option{--check} option once
to make sure your shell does not clobber environment variables."))) )
- ;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use
- ;; of cached profiles, and (2) cleanup actually happens, even when
- ;; 'guix-environment*' calls 'exit'.
- (add-hook! exit-hook
- (lambda _
- (maybe-remove-expired-cache-entries
- (%profile-cache-directory)
- cache-entries
- #:entry-expiration entry-expiration)))
-
- (if (assoc-ref opts 'export-manifest?)
- (export-manifest opts (current-output-port))
- (guix-environment* opts)))
+ ;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use
+ ;; of cached profiles, and (2) cleanup actually happens, even when
+ ;; 'guix-environment*' calls 'exit'.
+ (add-hook! exit-hook
+ (lambda _
+ (maybe-remove-expired-cache-entries
+ (%profile-cache-directory)
+ cache-entries
+ #:entry-expiration entry-expiration)))
+
+ (if (assoc-ref opts 'export-manifest?)
+ (export-manifest opts (current-output-port))
+ (guix-environment* opts))))
diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh
index f19a0f754e..6fc9e3723b 100644
--- a/tests/guix-pack.sh
+++ b/tests/guix-pack.sh
@@ -103,7 +103,7 @@ fi
guix pack --dry-run --bootstrap -f docker guile-bootstrap
# Build a Docker image with a symlink.
-guix pack --dry-run --bootstrap -f docker -S /opt/gnu=/ guile-bootstrap
+guix pack --dry-run --bootstrap -f docker -S /opt/gnu= guile-bootstrap
# Build a tarball pack of cross-compiled software. Use coreutils because
# guile-bootstrap is not intended to be cross-compiled.
--
2.37.3
^ permalink raw reply related [flat|nested] 37+ messages in thread
* [bug#58812] [PATCH 3/5] install: Validate symlink target in evaluate-populate-directive.
2022-10-27 3:50 ` [bug#58812] [PATCH 1/5] Makefile.am: Sort EXTRA_DIST entries Maxim Cournoyer
2022-10-27 3:50 ` [bug#58812] [PATCH 2/5] tests: Add a tests/utils.sh support file Maxim Cournoyer
@ 2022-10-27 3:50 ` Maxim Cournoyer
2022-11-09 21:06 ` [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell' Ludovic Courtès
2022-10-27 3:50 ` [bug#58812] [PATCH 4/5] guix: shell: Add '--symlink' option Maxim Cournoyer
2022-10-27 3:51 ` [bug#58812] [PATCH 5/5] shell: Detect --symlink spec problems early Maxim Cournoyer
3 siblings, 1 reply; 37+ messages in thread
From: Maxim Cournoyer @ 2022-10-27 3:50 UTC (permalink / raw)
To: 58812; +Cc: Maxim Cournoyer
* gnu/build/install.scm (evaluate-populate-directive): By default, error when
the target of a symlink doesn't exist. Always ensure TARGET ends with "/".
(populate-root-file-system): Call evaluate-populate-directive with
#:error-on-dangling-symlink #t and add comment.
---
gnu/build/install.scm | 60 ++++++++++++++++++++++++++++---------------
1 file changed, 40 insertions(+), 20 deletions(-)
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index f5c8407b89..15cc29b2c8 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -56,19 +57,24 @@ (define (install-boot-config bootcfg bootcfg-location mount-point)
(define* (evaluate-populate-directive directive target
#:key
(default-gid 0)
- (default-uid 0))
+ (default-uid 0)
+ (error-on-dangling-symlink? #t))
"Evaluate DIRECTIVE, an sexp describing a file or directory to create under
directory TARGET. DEFAULT-UID and DEFAULT-GID are the default UID and GID in
the context of the caller. If the directive matches those defaults then,
-'chown' won't be run."
+'chown' won't be run. When ERROR-ON-DANGLING-SYMLINK? is true, abort with an
+error when a dangling symlink would be created."
+ (define target* (if (string-suffix? "/" target)
+ target
+ (string-append target "/")))
(let loop ((directive directive))
(catch 'system-error
(lambda ()
(match directive
(('directory name)
- (mkdir-p (string-append target name)))
+ (mkdir-p (string-append target* name)))
(('directory name uid gid)
- (let ((dir (string-append target name)))
+ (let ((dir (string-append target* name)))
(mkdir-p dir)
;; If called from a context without "root" permissions, "chown"
;; to root will fail. In that case, do not try to run "chown"
@@ -78,27 +84,38 @@ (define* (evaluate-populate-directive directive target
(chown dir uid gid))))
(('directory name uid gid mode)
(loop `(directory ,name ,uid ,gid))
- (chmod (string-append target name) mode))
+ (chmod (string-append target* name) mode))
(('file name)
- (call-with-output-file (string-append target name)
+ (call-with-output-file (string-append target* name)
(const #t)))
(('file name (? string? content))
- (call-with-output-file (string-append target name)
+ (call-with-output-file (string-append target* name)
(lambda (port)
(display content port))))
((new '-> old)
- (let try ()
- (catch 'system-error
- (lambda ()
- (symlink old (string-append target new)))
- (lambda args
- ;; When doing 'guix system init' on the current '/', some
- ;; symlinks may already exists. Override them.
- (if (= EEXIST (system-error-errno args))
- (begin
- (delete-file (string-append target new))
- (try))
- (apply throw args))))))))
+ (let ((new* (string-append target* new)))
+ (let try ()
+ (catch 'system-error
+ (lambda ()
+ (when error-on-dangling-symlink?
+ ;; When the symbolic link points to a relative path,
+ ;; checking if its target exists must be done relative to
+ ;; the link location.
+ (with-directory-excursion (if (string-prefix? "/" old)
+ (getcwd)
+ (dirname new*)) ;relative
+ (unless (file-exists? old)
+ (error (format #f "symlink `~a' points to nonexistent \
+file `~a'" new* old)))))
+ (symlink old new*))
+ (lambda args
+ ;; When doing 'guix system init' on the current '/', some
+ ;; symlinks may already exists. Override them.
+ (if (= EEXIST (system-error-errno args))
+ (begin
+ (delete-file new*)
+ (try))
+ (apply throw args)))))))))
(lambda args
;; Usually we can only get here when installing to an existing root,
;; as with 'guix system init foo.scm /'.
@@ -142,7 +159,10 @@ (define* (populate-root-file-system system target
includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM.
EXTRAS is a list of directives appended to the built-in directives to populate
TARGET."
- (for-each (cut evaluate-populate-directive <> target)
+ ;; It's expected that some symbolic link targets do not exist yet, so do not
+ ;; error on dangling links.
+ (for-each (cut evaluate-populate-directive <> target
+ #:error-on-dangling-symlink? #f)
(append (directives (%store-directory)) extras))
;; Add system generation 1.
--
2.37.3
^ permalink raw reply related [flat|nested] 37+ messages in thread* [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell'.
2022-10-27 3:50 ` [bug#58812] [PATCH 3/5] install: Validate symlink target in evaluate-populate-directive Maxim Cournoyer
@ 2022-11-09 21:06 ` Ludovic Courtès
2022-11-10 3:37 ` Maxim Cournoyer
0 siblings, 1 reply; 37+ messages in thread
From: Ludovic Courtès @ 2022-11-09 21:06 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: 58812
Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
> * gnu/build/install.scm (evaluate-populate-directive): By default, error when
> the target of a symlink doesn't exist. Always ensure TARGET ends with "/".
> (populate-root-file-system): Call evaluate-populate-directive with
> #:error-on-dangling-symlink #t and add comment.
[...]
> + (define target* (if (string-suffix? "/" target)
> + target
> + (string-append target "/")))
Maybe make it:
(let ((target (if …)))
…)
so there’s only one ‘target’ in scope (and no ‘target*’); otherwise it’s
easy to forget the ‘*’ and refer to wrong one.
> + (let ((new* (string-append target* new)))
Likewise.
> + (when error-on-dangling-symlink?
> + ;; When the symbolic link points to a relative path,
> + ;; checking if its target exists must be done relative to
> + ;; the link location.
> + (with-directory-excursion (if (string-prefix? "/" old)
> + (getcwd)
> + (dirname new*)) ;relative
> + (unless (file-exists? old)
> + (error (format #f "symlink `~a' points to nonexistent \
> +file `~a'" new* old)))))
> + (symlink old new*))
I would avoid the directory excursion when unnecessary:
(unless (if (string-prefix? "/" old)
(file-exists? old)
(with-directory-excursion (dirname new)
(file-exists? old)))
…)
(We could use ‘lstat’ instead of ‘file-exists?’ if we want to allow
symlinks to dangling symlinks…)
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread* [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell'.
2022-11-09 21:06 ` [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell' Ludovic Courtès
@ 2022-11-10 3:37 ` Maxim Cournoyer
2022-11-17 17:37 ` [bug#59164] Coding style: similarly-named variables Ludovic Courtès
0 siblings, 1 reply; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-10 3:37 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 58812
Hi again,
Ludovic Courtès <ludo@gnu.org> writes:
> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>
>> * gnu/build/install.scm (evaluate-populate-directive): By default, error when
>> the target of a symlink doesn't exist. Always ensure TARGET ends with "/".
>> (populate-root-file-system): Call evaluate-populate-directive with
>> #:error-on-dangling-symlink #t and add comment.
>
> [...]
>
>> + (define target* (if (string-suffix? "/" target)
>> + target
>> + (string-append target "/")))
>
> Maybe make it:
>
> (let ((target (if …)))
> …)
>
> so there’s only one ‘target’ in scope (and no ‘target*’); otherwise it’s
> easy to forget the ‘*’ and refer to wrong one.
It's a pattern I've used at other places; I find it more hygienic to not
shadow existing variables; it signal to the reader "be careful, this is
not the same as the argument-bound one, though they are closely
related".
>> + (when error-on-dangling-symlink?
>> + ;; When the symbolic link points to a relative path,
>> + ;; checking if its target exists must be done relative to
>> + ;; the link location.
>> + (with-directory-excursion (if (string-prefix? "/" old)
>> + (getcwd)
>> + (dirname new*)) ;relative
>> + (unless (file-exists? old)
>> + (error (format #f "symlink `~a' points to nonexistent \
>> +file `~a'" new* old)))))
>> + (symlink old new*))
>
> I would avoid the directory excursion when unnecessary:
>
> (unless (if (string-prefix? "/" old)
> (file-exists? old)
> (with-directory-excursion (dirname new)
> (file-exists? old)))
> …)
Done:
--8<---------------cut here---------------start------------->8---
modified gnu/build/install.scm
@@ -99,14 +99,14 @@ (define target* (if (string-suffix? "/" target)
(lambda ()
(when error-on-dangling-symlink?
;; When the symbolic link points to a relative path,
- ;; checking if its target exists must be done relative to
- ;; the link location.
- (with-directory-excursion (if (string-prefix? "/" old)
- (getcwd)
- (dirname new*)) ;relative
- (unless (file-exists? old)
- (error (format #f "symlink `~a' points to nonexistent \
-file `~a'" new* old)))))
+ ;; checking if its target exists must be done relatively
+ ;; to the link location.
+ (unless (if (string-prefix? "/" old)
+ (file-exists? old)
+ (with-directory-excursion (dirname new*)
+ (file-exists? old)))
+ (error (format #f "symlink `~a' points to nonexistent \
+file `~a'" new* old))))
(symlink old new*))
--8<---------------cut here---------------end--------------->8---
> (We could use ‘lstat’ instead of ‘file-exists?’ if we want to allow
> symlinks to dangling symlinks…)
It seems better to leave it as-is; the odd use case of symlinking to a
dangling symlink can be accomplished via "#:error-on-dangling-symlink
#f" :-).
--
Thanks,
Maxim
^ permalink raw reply [flat|nested] 37+ messages in thread* [bug#59164] Coding style: similarly-named variables
2022-11-10 3:37 ` Maxim Cournoyer
@ 2022-11-17 17:37 ` Ludovic Courtès
2022-11-17 18:44 ` [bug#58812] " zimoun
2022-11-17 20:34 ` Maxim Cournoyer
0 siblings, 2 replies; 37+ messages in thread
From: Ludovic Courtès @ 2022-11-17 17:37 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: 59164, 58812
Hi,
Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
> Ludovic Courtès <ludo@gnu.org> writes:
>
>> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>>
>>> * gnu/build/install.scm (evaluate-populate-directive): By default, error when
>>> the target of a symlink doesn't exist. Always ensure TARGET ends with "/".
>>> (populate-root-file-system): Call evaluate-populate-directive with
>>> #:error-on-dangling-symlink #t and add comment.
>>
>> [...]
>>
>>> + (define target* (if (string-suffix? "/" target)
>>> + target
>>> + (string-append target "/")))
>>
>> Maybe make it:
>>
>> (let ((target (if …)))
>> …)
>>
>> so there’s only one ‘target’ in scope (and no ‘target*’); otherwise it’s
>> easy to forget the ‘*’ and refer to wrong one.
>
> It's a pattern I've used at other places; I find it more hygienic to not
> shadow existing variables; it signal to the reader "be careful, this is
> not the same as the argument-bound one, though they are closely
> related".
I don’t buy it. :-) The reader might be careful yet end up using the
“wrong” variable. As long as the “wrong” variable has no use, I think
it’s best to shadow it so that mistakes cannot happen.
Of course the details vary depending on context, but I think we should
not start introducing this pattern in different places. Perhaps
something to discuss and codify under “Formatting Code”?
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#58812] [bug#59164] Coding style: similarly-named variables
2022-11-17 17:37 ` [bug#59164] Coding style: similarly-named variables Ludovic Courtès
@ 2022-11-17 18:44 ` zimoun
2022-11-18 17:02 ` Maxim Cournoyer
2022-11-17 20:34 ` Maxim Cournoyer
1 sibling, 1 reply; 37+ messages in thread
From: zimoun @ 2022-11-17 18:44 UTC (permalink / raw)
To: Ludovic Courtès, Maxim Cournoyer; +Cc: 59164, 58812
Hi,
On Thu, 17 Nov 2022 at 18:37, Ludovic Courtès <ludo@gnu.org> wrote:
>> It's a pattern I've used at other places; I find it more hygienic to not
>> shadow existing variables; it signal to the reader "be careful, this is
>> not the same as the argument-bound one, though they are closely
>> related".
>
> I don’t buy it. :-) The reader might be careful yet end up using the
> “wrong” variable. As long as the “wrong” variable has no use, I think
> it’s best to shadow it so that mistakes cannot happen.
>
> Of course the details vary depending on context, but I think we should
> not start introducing this pattern in different places. Perhaps
> something to discuss and codify under “Formatting Code”?
I agree with Ludo. For another instance than target*, the previous was,
--8<---------------cut here---------------start------------->8---
((new '-> old)
[...]
- (symlink old (string-append target new)))
[...]
- (delete-file (string-append target new))
--8<---------------cut here---------------end--------------->8---
then replaced by,
--8<---------------cut here---------------start------------->8---
((new '-> old)
[...]
+ (let ((new* (string-append target* new)))
[...]
+ (error (format #f "symlink `~a' points to nonexistent \
+file `~a'" new* old)))))
+ (symlink old new*))
--8<---------------cut here---------------end--------------->8---
Well, it seems a Star War. ;-) As Ludo, I am not convinced that it is
less error-prone, maybe the contrary.
Cheers,
simon
^ permalink raw reply [flat|nested] 37+ messages in thread* [bug#58812] [bug#59164] Coding style: similarly-named variables
2022-11-17 18:44 ` [bug#58812] " zimoun
@ 2022-11-18 17:02 ` Maxim Cournoyer
2022-11-21 15:02 ` zimoun
0 siblings, 1 reply; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-18 17:02 UTC (permalink / raw)
To: zimoun; +Cc: Ludovic Courtès, 59164, 58812
Hi,
zimoun <zimon.toutoune@gmail.com> writes:
> Hi,
>
> On Thu, 17 Nov 2022 at 18:37, Ludovic Courtès <ludo@gnu.org> wrote:
>
>>> It's a pattern I've used at other places; I find it more hygienic to not
>>> shadow existing variables; it signal to the reader "be careful, this is
>>> not the same as the argument-bound one, though they are closely
>>> related".
>>
>> I don’t buy it. :-) The reader might be careful yet end up using the
>> “wrong” variable. As long as the “wrong” variable has no use, I think
>> it’s best to shadow it so that mistakes cannot happen.
>>
>> Of course the details vary depending on context, but I think we should
>> not start introducing this pattern in different places. Perhaps
>> something to discuss and codify under “Formatting Code”?
>
> I agree with Ludo. For another instance than target*, the previous was,
>
> ((new '-> old)
> [...]
> - (symlink old (string-append target new)))
> [...]
> - (delete-file (string-append target new))
>
>
> then replaced by,
>
> ((new '-> old)
> [...]
> + (let ((new* (string-append target* new)))
> [...]
> + (error (format #f "symlink `~a' points to nonexistent \
> +file `~a'" new* old)))))
> + (symlink old new*))
The intent was to keep away from the following imperative style, which
hurts both readability and debuggability in my opinion:
--8<---------------cut here---------------start------------->8---
(let* ((my-target "something")
(my-target (mutate-once my-target))
(my-target (mutate-twice my-target)))
(do-something-with my-target))
--8<---------------cut here---------------end--------------->8---
Perhaps the problem at hand would benefit being broken down in smaller
chunks, to avoid having a page-full of code sharing the same scope.
--
Thanks,
Maxim
^ permalink raw reply [flat|nested] 37+ messages in thread* [bug#58812] [bug#59164] Coding style: similarly-named variables
2022-11-18 17:02 ` Maxim Cournoyer
@ 2022-11-21 15:02 ` zimoun
2022-11-21 15:52 ` [bug#59164] " zimoun
2022-11-21 20:55 ` Maxim Cournoyer
0 siblings, 2 replies; 37+ messages in thread
From: zimoun @ 2022-11-21 15:02 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: Ludovic Courtès, 59164, 58812
Hi Maxim,
On Fri, 18 Nov 2022 at 12:02, Maxim Cournoyer <maxim.cournoyer@gmail.com> wrote:
> The intent was to keep away from the following imperative style, which
> hurts both readability and debuggability in my opinion:
>
> --8<---------------cut here---------------start------------->8---
> (let* ((my-target "something")
> (my-target (mutate-once my-target))
> (my-target (mutate-twice my-target)))
> (do-something-with my-target))
> --8<---------------cut here---------------end--------------->8---
Well, ’mutate-*’ is not really mutating. Maybe I miss something and
from my understanding, this ’let*’reads,
--8<---------------cut here---------------start------------->8---
(let ((my-target "something"))
(let ((my-target (mutate-once my-target)))
(let ((my-target (mutate-twice my-target)))
(do-something-with my-target))))
--8<---------------cut here---------------end--------------->8---
and not,
--8<---------------cut here---------------start------------->8---
(begin
(define my-target "something")
(set! my-target (mutate-once my-target))
(set! my-target (mutate-twice my-target))
(do-something-with my-target))
--8<---------------cut here---------------end--------------->8---
Well, the former is ’lexical-scope’d so the 3 ’my-target’ are not truly
an imperative style, I guess.
Back to the pattern, you are suggesting to write,
--8<---------------cut here---------------start------------->8---
(let* ((my-target "something")
(my-target* (mutate-once my-target))
(my-target** (mutate-twice my-target*)))
(do-something-with my-target**))
--8<---------------cut here---------------end--------------->8---
well, I am not convinced it helps for readibility. And I think, the
pattern is manually doing what ’let*’ is already doing for you.
Cheers,
simon
^ permalink raw reply [flat|nested] 37+ messages in thread* [bug#59164] [bug#58812] [bug#59164] Coding style: similarly-named variables
2022-11-21 15:02 ` zimoun
@ 2022-11-21 15:52 ` zimoun
2022-11-21 20:55 ` Maxim Cournoyer
1 sibling, 0 replies; 37+ messages in thread
From: zimoun @ 2022-11-21 15:52 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: Ludovic Courtès, 59164, 58812
On Mon, 21 Nov 2022 at 16:02, zimoun <zimon.toutoune@gmail.com> wrote:
> Well, ’mutate-*’ is not really mutating. Maybe I miss something and
> from my understanding, this ’let*’reads,
>
> --8<---------------cut here---------------start------------->8---
> (let ((my-target "something"))
> (let ((my-target (mutate-once my-target)))
> (let ((my-target (mutate-twice my-target)))
> (do-something-with my-target))))
> --8<---------------cut here---------------end--------------->8---
Well, it compiles to something similar…
> And I think, the
> pattern is manually doing what ’let*’ is already doing for you.
…for instance, it reads,
--8<---------------cut here---------------start------------->8---
scheme@(guix-user)> (macroexpand
'(let* ((my-target "something")
(my-target (mutate-once my-target))
(my-target (mutate-twice my-target)))
(do-something-with my-target)))
$1= #<tree-il
(let (my-target) (my-target-11e760207b4c89cb-114)
((const "something"))
(let (my-target) (my-target-11e760207b4c89cb-116)
((call (toplevel mutate-once) (lexical my-target my-target-11e760207b4c89cb-114)))
(let (my-target) (my-target-11e760207b4c89cb-118)
((call (toplevel mutate-twice) (lexical my-target my-target-11e760207b4c89cb-116)))
(call (toplevel do-something-with) (lexical my-target my-target-11e760207b4c89cb-118)))))>
--8<---------------cut here---------------end--------------->8---
Cheers,
simon
^ permalink raw reply [flat|nested] 37+ messages in thread* [bug#58812] [bug#59164] Coding style: similarly-named variables
2022-11-21 15:02 ` zimoun
2022-11-21 15:52 ` [bug#59164] " zimoun
@ 2022-11-21 20:55 ` Maxim Cournoyer
2022-11-22 14:35 ` [bug#59164] " zimoun
1 sibling, 1 reply; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-21 20:55 UTC (permalink / raw)
To: zimoun; +Cc: Ludovic Courtès, 59164, 58812
Hi Simon,
zimoun <zimon.toutoune@gmail.com> writes:
> Hi Maxim,
>
> On Fri, 18 Nov 2022 at 12:02, Maxim Cournoyer <maxim.cournoyer@gmail.com> wrote:
>
>> The intent was to keep away from the following imperative style, which
>> hurts both readability and debuggability in my opinion:
>>
>> --8<---------------cut here---------------start------------->8---
>> (let* ((my-target "something")
>> (my-target (mutate-once my-target))
>> (my-target (mutate-twice my-target)))
>> (do-something-with my-target))
>> --8<---------------cut here---------------end--------------->8---
>
> Well, ’mutate-*’ is not really mutating. Maybe I miss something and
> from my understanding, this ’let*’reads,
>
> (let ((my-target "something"))
> (let ((my-target (mutate-once my-target)))
> (let ((my-target (mutate-twice my-target)))
> (do-something-with my-target))))
>
>
> and not,
>
> (begin
> (define my-target "something")
> (set! my-target (mutate-once my-target))
> (set! my-target (mutate-twice my-target))
> (do-something-with my-target))
Right. I used "mutated" where I should have used "shadowed by lexical
scoping". The outcome for me is the same; the original value of an
argument (target) in the code gets shadowed, thus is theory it becomes
more difficult to inspect its original value, should we have a debugger
that is able to stop at the place to inspect to print ',locals'.
In practice since using breakpoints/a debugger to debug Guile code
rarely works as intended (in my experience hacking on Guix!), we
typically sprinkle the source with 'pk', and that point becomes moot.
> Well, the former is ’lexical-scope’d so the 3 ’my-target’ are not truly
> an imperative style, I guess.
>
> Back to the pattern, you are suggesting to write,
>
> (let* ((my-target "something")
> (my-target* (mutate-once my-target))
> (my-target** (mutate-twice my-target*)))
> (do-something-with my-target**))
> well, I am not convinced it helps for readibility. And I think, the
> pattern is manually doing what ’let*’ is already doing for you.
The value it provides is that it becomes easy to inspect each
intermediary result in a debugger.
I think we're done expressing the arguments to have on both sides, which
aren't too strong either ways :-). I'm happy to restrain myself using
such a pattern and keep moving forward.
--
Thanks,
Maxim
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#59164] [bug#58812] [bug#59164] Coding style: similarly-named variables
2022-11-21 20:55 ` Maxim Cournoyer
@ 2022-11-22 14:35 ` zimoun
2022-11-26 14:47 ` Ludovic Courtès
0 siblings, 1 reply; 37+ messages in thread
From: zimoun @ 2022-11-22 14:35 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: Ludovic Courtès, 59164, 58812
Hi Maxim,
On Mon, 21 Nov 2022 at 15:55, Maxim Cournoyer <maxim.cournoyer@gmail.com> wrote:
> In practice since using breakpoints/a debugger to debug Guile code
> rarely works as intended (in my experience hacking on Guix!), we
> typically sprinkle the source with 'pk', and that point becomes moot.
I totally agree! Preparing some materials for introducing Guile to
GuixHPC folk, I am trying to collect some tips and, if I am honest, the
debugging experience with Guile is really poor; compared to others (as
Python). For example, DrRacket provides an easy and nice user
experience [1] – where it is easy to compare each intermediary result in
the debugger. For what it is worth, I have not been able to have some
similar inspections as in [1]. Maybe, I am missing something…
Well, IMHO, we are somehow suffering from some Guile limitations and
improvements in this area are an hard task.
Cheers,
simon
Short video demoing (link will be dead after 2022-12-07)
1: https://filesender.renater.fr/?s=download&token=92d4312a-91b4-402e-898a-40ce01a5c3ed
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#58812] [bug#59164] Coding style: similarly-named variables
2022-11-22 14:35 ` [bug#59164] " zimoun
@ 2022-11-26 14:47 ` Ludovic Courtès
0 siblings, 0 replies; 37+ messages in thread
From: Ludovic Courtès @ 2022-11-26 14:47 UTC (permalink / raw)
To: zimoun; +Cc: 59164, Maxim Cournoyer, 58812
Hi,
zimoun <zimon.toutoune@gmail.com> skribis:
> I totally agree! Preparing some materials for introducing Guile to
> GuixHPC folk, I am trying to collect some tips and, if I am honest, the
> debugging experience with Guile is really poor; compared to others (as
> Python). For example, DrRacket provides an easy and nice user
> experience [1] – where it is easy to compare each intermediary result in
> the debugger. For what it is worth, I have not been able to have some
> similar inspections as in [1]. Maybe, I am missing something…
Looking at the video you posted, I better understand what debugging
features we’re talking about. DrRacket is the gold standard; here it
does something similar to what we have with in Elisp with EDebug, which
is certainly useful.
It may be more of a limitation of Geiser than of Guile. I find it more
useful in “typical” imperative ELisp code than in functional Scheme
code, but it’d be nice to have either way!
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#59164] Coding style: similarly-named variables
2022-11-17 17:37 ` [bug#59164] Coding style: similarly-named variables Ludovic Courtès
2022-11-17 18:44 ` [bug#58812] " zimoun
@ 2022-11-17 20:34 ` Maxim Cournoyer
2022-11-20 10:46 ` [bug#58812] " Ludovic Courtès
1 sibling, 1 reply; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-17 20:34 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 59164, 58812
Hi,
Ludovic Courtès <ludo@gnu.org> writes:
> Hi,
>
> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>
>> Ludovic Courtès <ludo@gnu.org> writes:
>>
>>> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>>>
>>>> * gnu/build/install.scm (evaluate-populate-directive): By default, error when
>>>> the target of a symlink doesn't exist. Always ensure TARGET ends with "/".
>>>> (populate-root-file-system): Call evaluate-populate-directive with
>>>> #:error-on-dangling-symlink #t and add comment.
>>>
>>> [...]
>>>
>>>> + (define target* (if (string-suffix? "/" target)
>>>> + target
>>>> + (string-append target "/")))
>>>
>>> Maybe make it:
>>>
>>> (let ((target (if …)))
>>> …)
>>>
>>> so there’s only one ‘target’ in scope (and no ‘target*’); otherwise it’s
>>> easy to forget the ‘*’ and refer to wrong one.
>>
>> It's a pattern I've used at other places; I find it more hygienic to not
>> shadow existing variables; it signal to the reader "be careful, this is
>> not the same as the argument-bound one, though they are closely
>> related".
>
> I don’t buy it. :-) The reader might be careful yet end up using the
> “wrong” variable. As long as the “wrong” variable has no use, I think
> it’s best to shadow it so that mistakes cannot happen.
I'm surprised you're not buying it, given we're writing Scheme in a more
functional style, and mutating same-named variables clearly goes against
that style :-).
> Of course the details vary depending on context, but I think we should
> not start introducing this pattern in different places. Perhaps
> something to discuss and codify under “Formatting Code”?
That's more of a coding style guidelines than "formatting" code (when I
read "formatting", I think of a mechanical process like 'guix style' or
'rust-fmt' can do), but yes, that could be nice to have. Better yet,
something basic to share across the whole Guile/Scheme community and
include in the Guile user manual, like Python has PEP 8 they can refer
to, to save every Guile/Scheme project from having to reinvent the
wheel.
--
Thanks,
Maxim
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#58812] Coding style: similarly-named variables
2022-11-17 20:34 ` Maxim Cournoyer
@ 2022-11-20 10:46 ` Ludovic Courtès
0 siblings, 0 replies; 37+ messages in thread
From: Ludovic Courtès @ 2022-11-20 10:46 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: 59164, 58812
Hi,
Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
[...]
>>> It's a pattern I've used at other places; I find it more hygienic to not
>>> shadow existing variables; it signal to the reader "be careful, this is
>>> not the same as the argument-bound one, though they are closely
>>> related".
>>
>> I don’t buy it. :-) The reader might be careful yet end up using the
>> “wrong” variable. As long as the “wrong” variable has no use, I think
>> it’s best to shadow it so that mistakes cannot happen.
>
> I'm surprised you're not buying it, given we're writing Scheme in a more
> functional style, and mutating same-named variables clearly goes against
> that style :-).
There’s no mutation here, only lexical scoping. Anyway, I find it clear
that the risk of typing ‘x’ instead of ‘x*’, especially in relatively
long functions, justifies shadowing in situations like this one. WDYT?
>> Of course the details vary depending on context, but I think we should
>> not start introducing this pattern in different places. Perhaps
>> something to discuss and codify under “Formatting Code”?
>
> That's more of a coding style guidelines than "formatting" code
Sorry I meant “Coding Style”, which is the section that documents the
project’s conventions.
> (when I read "formatting", I think of a mechanical process like 'guix
> style' or 'rust-fmt' can do), but yes, that could be nice to have.
> Better yet, something basic to share across the whole Guile/Scheme
> community and include in the Guile user manual, like Python has PEP 8
> they can refer to, to save every Guile/Scheme project from having to
> reinvent the wheel.
I won’t do it, but sure, why not! My immediate concern is to make sure
we have a shared understanding, within Guix, of some of the conventions
we follow. It’s a minor issue, but minor issues are what our day-to-day
work is made of. :-)
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#58812] [PATCH 4/5] guix: shell: Add '--symlink' option.
2022-10-27 3:50 ` [bug#58812] [PATCH 1/5] Makefile.am: Sort EXTRA_DIST entries Maxim Cournoyer
2022-10-27 3:50 ` [bug#58812] [PATCH 2/5] tests: Add a tests/utils.sh support file Maxim Cournoyer
2022-10-27 3:50 ` [bug#58812] [PATCH 3/5] install: Validate symlink target in evaluate-populate-directive Maxim Cournoyer
@ 2022-10-27 3:50 ` Maxim Cournoyer
2022-11-09 20:58 ` [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell' Ludovic Courtès
2022-10-27 3:51 ` [bug#58812] [PATCH 5/5] shell: Detect --symlink spec problems early Maxim Cournoyer
3 siblings, 1 reply; 37+ messages in thread
From: Maxim Cournoyer @ 2022-10-27 3:50 UTC (permalink / raw)
To: 58812; +Cc: Maxim Cournoyer
* 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 <http://www.gnu.org/licenses/>.
(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))))
+
\f
;;;
;;; 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
--
2.37.3
^ permalink raw reply related [flat|nested] 37+ messages in thread* [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell'.
2022-10-27 3:50 ` [bug#58812] [PATCH 4/5] guix: shell: Add '--symlink' option Maxim Cournoyer
@ 2022-11-09 20:58 ` Ludovic Courtès
2022-11-10 3:10 ` Maxim Cournoyer
2022-11-16 19:03 ` [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell' zimoun
0 siblings, 2 replies; 37+ messages in thread
From: Ludovic Courtès @ 2022-11-09 20:58 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: 58812
Hi,
That looks like a useful improvement! Some comments below.
Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
> +@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}.
We should refrain from using @ref in sentences (info "(texinfo) @ref").
Instead, I’d write:
documented for @command{guix pack} (@pxref{pack-symlink-option}).
> (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)))))))
I think it’s a case where I would refrain from factorizing because this
procedure, as shown by the comments and the use of ‘relative-file-name’,
is specifically tailored for the needs to ‘guix pack -f tarball’.
I’d prefer to have a similar but independently maintained variant of
this procedure in (guix scripts environment) to avoid difficulties down
the road.
> +++ 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))
You can turn this into #:autoload so we don’t pay the price when not
using ‘--symlink’.
> +++ 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
This should go to ‘tests/guix-environment-container.sh’, which has all
the container-related tests.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread* [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell'.
2022-11-09 20:58 ` [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell' Ludovic Courtès
@ 2022-11-10 3:10 ` Maxim Cournoyer
2022-11-10 14:17 ` Ludovic Courtès
2022-11-16 19:03 ` [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell' zimoun
1 sibling, 1 reply; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-10 3:10 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 58812
Hi Ludo!
Ludovic Courtès <ludo@gnu.org> writes:
> Hi,
>
> That looks like a useful improvement! Some comments below.
Thanks!
> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>
>> +@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}.
>
> We should refrain from using @ref in sentences (info "(texinfo) @ref").
> Instead, I’d write:
>
> documented for @command{guix pack} (@pxref{pack-symlink-option}).
I've heard that from you before, but is there a reason against? I like
to know the rationale for doing things a certain way, lest I forget :-).
From info '(texinfo) @ref':
--8<---------------cut here---------------start------------->8---
6.6 '@ref'
==========
'@ref' is nearly the same as '@xref' except that it does not generate a
'See' in the printed output, just the reference itself. This makes it
useful as the last part of a sentence.
For example,
For more information, @pxref{This}, and @ref{That}.
produces in Info:
For more information, *note This::, and *note That::.
--8<---------------cut here---------------end--------------->8---
>> (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)))))))
>
> I think it’s a case where I would refrain from factorizing because this
> procedure, as shown by the comments and the use of ‘relative-file-name’,
> is specifically tailored for the needs to ‘guix pack -f tarball’.
>
> I’d prefer to have a similar but independently maintained variant of
> this procedure in (guix scripts environment) to avoid difficulties down
> the road.
I considered to duplicate it, but I opted to reuse it in the end because
I care that the behavior is exactly the same between the two actions
(guix shell --symlink vs guix pack --symlink). If the way we handle
this is to be changed in the future, I'd want both to be changed at
once, so they remain consistent. Does this make sense?
>> +++ 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))
>
> You can turn this into #:autoload so we don’t pay the price when not
> using ‘--symlink’.
Done! Could Guile simply always use lazy loading (autoload by default)?
Otherwise, when is it OK to use autoload and when is it not?
>> +++ 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
>
> This should go to ‘tests/guix-environment-container.sh’, which has all
> the container-related tests.
Done, for the "has_container_support" conditional tests.
Thanks for taking a peek!
Maxim
^ permalink raw reply [flat|nested] 37+ messages in thread* [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell'.
2022-11-10 3:10 ` Maxim Cournoyer
@ 2022-11-10 14:17 ` Ludovic Courtès
2022-11-10 14:49 ` Maxim Cournoyer
2022-11-10 16:05 ` [bug#58812] [PATCH v3 1/4] Makefile.am: Sort EXTRA_DIST entries Maxim Cournoyer
0 siblings, 2 replies; 37+ messages in thread
From: Ludovic Courtès @ 2022-11-10 14:17 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: 58812
Hi Maxim!
Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>> We should refrain from using @ref in sentences (info "(texinfo) @ref").
>> Instead, I’d write:
>>
>> documented for @command{guix pack} (@pxref{pack-symlink-option}).
>
> I've heard that from you before, but is there a reason against? I like
> to know the rationale for doing things a certain way, lest I forget :-).
> From info '(texinfo) @ref':
It’s right below the bit you quoted:
The '@ref' command can tempt writers to express themselves in a
manner that is suitable for a printed manual but looks awkward in the
Info format. Bear in mind that your audience could be using both the
printed and the Info format. For example: […]
>>> +(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)))))))
>>
>> I think it’s a case where I would refrain from factorizing because this
>> procedure, as shown by the comments and the use of ‘relative-file-name’,
>> is specifically tailored for the needs to ‘guix pack -f tarball’.
>>
>> I’d prefer to have a similar but independently maintained variant of
>> this procedure in (guix scripts environment) to avoid difficulties down
>> the road.
>
> I considered to duplicate it, but I opted to reuse it in the end because
> I care that the behavior is exactly the same between the two actions
> (guix shell --symlink vs guix pack --symlink). If the way we handle
> this is to be changed in the future, I'd want both to be changed at
> once, so they remain consistent. Does this make sense?
They don’t have to be consistent. Use of ‘relative-file-name’ here for
example is dictated by the needs of relocatable packs. It doesn’t have
to be this way here.
I think it’s best to keep separate copies here (they likely won’t be
exactly the same).
>>> +++ 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))
>>
>> You can turn this into #:autoload so we don’t pay the price when not
>> using ‘--symlink’.
>
> Done! Could Guile simply always use lazy loading (autoload by default)?
#:select could be synonymous with #:autoload, if that’s what you mean,
but in general Guile cannot know whether autoloading is semantically
equivalent to eagerly loading: there might be side-effects happening
when the top-level of the module runs.
> Otherwise, when is it OK to use autoload and when is it not?
#:autoload exists as a way to amortize initialization costs and make
sure only necessary functionality gets loaded, thereby reducing CPU and
memory usage.
Only the module user can tell whether #:autoload is appropriate. In
general you’d use it for optional functionality that has a
non-negligible memory footprint or that would noticeably degrade startup
time.
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread* [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell'.
2022-11-10 14:17 ` Ludovic Courtès
@ 2022-11-10 14:49 ` Maxim Cournoyer
2022-11-10 15:16 ` Maxim Cournoyer
2022-11-10 16:05 ` [bug#58812] [PATCH v3 1/4] Makefile.am: Sort EXTRA_DIST entries Maxim Cournoyer
1 sibling, 1 reply; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-10 14:49 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 58812
Hi Ludo!
Ludovic Courtès <ludo@gnu.org> writes:
> Hi Maxim!
>
> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>
>>> We should refrain from using @ref in sentences (info "(texinfo) @ref").
>>> Instead, I’d write:
>>>
>>> documented for @command{guix pack} (@pxref{pack-symlink-option}).
>>
>> I've heard that from you before, but is there a reason against? I like
>> to know the rationale for doing things a certain way, lest I forget :-).
>> From info '(texinfo) @ref':
>
> It’s right below the bit you quoted:
>
> The '@ref' command can tempt writers to express themselves in a
> manner that is suitable for a printed manual but looks awkward in the
> Info format. Bear in mind that your audience could be using both the
> printed and the Info format. For example: […]
Yes, and I don't get it :-)
--8<---------------cut here---------------start------------->8---
The '@ref' command can tempt writers to express themselves in a
manner that is suitable for a printed manual but looks awkward in the
Info format. Bear in mind that your audience could be using both the
printed and the Info format. For example:
Sea surges are described in @ref{Hurricanes}.
looks ok in the printed output:
Sea surges are described in Section 6.7 [Hurricanes], page 72.
but is awkward to read in Info, "note" being a verb:
Sea surges are described in *note Hurricanes::.
--8<---------------cut here---------------end--------------->8---
I don't see a "note" in the final sentence that should make it awkward?
It's lacking a "see " prefix though, which could help to make things a
bit clearer, I guess.
It looks the same in info as in the pxref example given above:
--8<---------------cut here---------------start------------->8---
For example,
For more information, @pxref{This}, and @ref{That}.
produces in Info:
For more information, *note This::, and *note That::.
--8<---------------cut here---------------end--------------->8---
I'm also unsure where the "see" comes before That:: above. Is it a
mistake in the manual?
>>>> +(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)))))))
>>>
>>> I think it’s a case where I would refrain from factorizing because this
>>> procedure, as shown by the comments and the use of ‘relative-file-name’,
>>> is specifically tailored for the needs to ‘guix pack -f tarball’.
>>>
>>> I’d prefer to have a similar but independently maintained variant of
>>> this procedure in (guix scripts environment) to avoid difficulties down
>>> the road.
>>
>> I considered to duplicate it, but I opted to reuse it in the end because
>> I care that the behavior is exactly the same between the two actions
>> (guix shell --symlink vs guix pack --symlink). If the way we handle
>> this is to be changed in the future, I'd want both to be changed at
>> once, so they remain consistent. Does this make sense?
>
> They don’t have to be consistent. Use of ‘relative-file-name’ here for
> example is dictated by the needs of relocatable packs. It doesn’t have
> to be this way here.
>
> I think it’s best to keep separate copies here (they likely won’t be
> exactly the same).
OK, I see you point about relative-file-name not being needed. I'll make
the change.
>>>> +++ 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))
>>>
>>> You can turn this into #:autoload so we don’t pay the price when not
>>> using ‘--symlink’.
>>
>> Done! Could Guile simply always use lazy loading (autoload by default)?
>
> #:select could be synonymous with #:autoload, if that’s what you mean,
> but in general Guile cannot know whether autoloading is semantically
> equivalent to eagerly loading: there might be side-effects happening
> when the top-level of the module runs.
Perhaps there could be a strict execution mode where it is assumed that
side effects are not used when modules run? That seems a seldom used
feature anyway, and could enable making lazy loading of modules the
default.
>> Otherwise, when is it OK to use autoload and when is it not?
>
> #:autoload exists as a way to amortize initialization costs and make
> sure only necessary functionality gets loaded, thereby reducing CPU and
> memory usage.
>
> Only the module user can tell whether #:autoload is appropriate. In
> general you’d use it for optional functionality that has a
> non-negligible memory footprint or that would noticeably degrade startup
> time.
>
> Ludo’.
Thank you for the explanations and review! I'll send a v3 shortly.
--
Maxim
^ permalink raw reply [flat|nested] 37+ messages in thread* [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell'.
2022-11-10 14:49 ` Maxim Cournoyer
@ 2022-11-10 15:16 ` Maxim Cournoyer
2022-11-14 9:18 ` Ludovic Courtès
0 siblings, 1 reply; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-10 15:16 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 58812
Hello,
Maxim Cournoyer <maxim.cournoyer@gmail.com> writes:
> Hi Ludo!
>
> Ludovic Courtès <ludo@gnu.org> writes:
>
>> Hi Maxim!
>>
>> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>>
>>>> We should refrain from using @ref in sentences (info "(texinfo) @ref").
>>>> Instead, I’d write:
>>>>
>>>> documented for @command{guix pack} (@pxref{pack-symlink-option}).
>>>
>>> I've heard that from you before, but is there a reason against? I like
>>> to know the rationale for doing things a certain way, lest I forget :-).
>>> From info '(texinfo) @ref':
>>
>> It’s right below the bit you quoted:
>>
>> The '@ref' command can tempt writers to express themselves in a
>> manner that is suitable for a printed manual but looks awkward in the
>> Info format. Bear in mind that your audience could be using both the
>> printed and the Info format. For example: […]
>
> Yes, and I don't get it :-)
To be more concrete, this is what it looks currently:
--8<---------------cut here---------------start------------->8---
‘--symlink=SPEC’
‘-S SPEC’
For containers, create the symbolic links specified by SPEC, as
documented in *note pack-symlink-option::.
--8<---------------cut here---------------end--------------->8---
This is what it'd look if I use (see: @pxref ...) instead:
--8<---------------cut here---------------start------------->8---
‘--symlink=SPEC’
‘-S SPEC’
For containers, create the symbolic links specified by SPEC (see:
*note pack-symlink-option::).
--8<---------------cut here---------------end--------------->8---
Contrary to what the Texinfo manual says, pxref seems to be the one
introducing the awkward "*note" verb in the resulting info.
--
Thanks,
Maxim
^ permalink raw reply [flat|nested] 37+ messages in thread* [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell'.
2022-11-10 15:16 ` Maxim Cournoyer
@ 2022-11-14 9:18 ` Ludovic Courtès
0 siblings, 0 replies; 37+ messages in thread
From: Ludovic Courtès @ 2022-11-14 9:18 UTC (permalink / raw)
To: Maxim Cournoyer; +Cc: 58812
Hi,
Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
> Contrary to what the Texinfo manual says, pxref seems to be the one
> introducing the awkward "*note" verb in the resulting info.
If you read it in Emacs, it looks a bit different; I think info.el adds
removes “note” and adds “see” in some cases (e.g., see
‘Info-hide-note-references’).
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#58812] [PATCH v3 1/4] Makefile.am: Sort EXTRA_DIST entries.
2022-11-10 14:17 ` Ludovic Courtès
2022-11-10 14:49 ` Maxim Cournoyer
@ 2022-11-10 16:05 ` Maxim Cournoyer
2022-11-10 16:05 ` [bug#58812] [PATCH v3 2/4] install: Validate symlink target in evaluate-populate-directive Maxim Cournoyer
` (2 more replies)
1 sibling, 3 replies; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-10 16:05 UTC (permalink / raw)
To: 58812; +Cc: Maxim Cournoyer
* Makefile.am (EXTRA_DIST): Sort.
---
Makefile.am | 52 ++++++++++++++++++++++++++--------------------------
1 file changed, 26 insertions(+), 26 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 47886721fa..c3af23b68e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -660,49 +660,49 @@ dist_fishcompletion_DATA = etc/completion/fish/guix.fish
nodist_selinux_policy_DATA = etc/guix-daemon.cil
EXTRA_DIST += \
- HACKING \
- ROADMAP \
- TODO \
- CODE-OF-CONDUCT \
.dir-locals.el \
.guix-authorizations \
.guix-channel \
- scripts/guix.in \
- etc/disarchive-manifest.scm \
- etc/guix-install.sh \
- etc/news.scm \
- etc/release-manifest.scm \
- etc/source-manifest.scm \
- etc/system-tests.scm \
- etc/time-travel-manifest.scm \
- etc/historical-authorizations \
+ CODE-OF-CONDUCT \
+ HACKING \
+ ROADMAP \
+ TODO \
+ bootstrap \
build-aux/build-self.scm \
- build-aux/compile-all.scm \
- build-aux/cuirass/hurd-manifest.scm \
- build-aux/check-final-inputs-self-contained.scm \
build-aux/check-channel-news.scm \
+ build-aux/check-final-inputs-self-contained.scm \
+ build-aux/compile-all.scm \
build-aux/compile-as-derivation.scm \
+ build-aux/config.rpath \
build-aux/convert-xref.scm \
+ build-aux/cuirass/hurd-manifest.scm \
build-aux/generate-authors.scm \
build-aux/test-driver.scm \
- build-aux/update-guix-package.scm \
build-aux/update-NEWS.scm \
- tests/test.drv \
+ build-aux/update-guix-package.scm \
+ doc/build.scm \
+ etc/disarchive-manifest.scm \
+ etc/guix-install.sh \
+ etc/historical-authorizations \
+ etc/news.scm \
+ etc/release-manifest.scm \
+ etc/source-manifest.scm \
+ etc/system-tests.scm \
+ etc/time-travel-manifest.scm \
+ scripts/guix.in \
tests/cve-sample.json \
- tests/keys/signing-key.pub \
- tests/keys/signing-key.sec \
tests/keys/civodul.pub \
- tests/keys/rsa.pub \
tests/keys/dsa.pub \
- tests/keys/ed25519.pub \
- tests/keys/ed25519.sec \
tests/keys/ed25519-2.pub \
tests/keys/ed25519-2.sec \
tests/keys/ed25519-3.pub \
tests/keys/ed25519-3.sec \
- build-aux/config.rpath \
- bootstrap \
- doc/build.scm \
+ tests/keys/ed25519.pub \
+ tests/keys/ed25519.sec \
+ tests/keys/rsa.pub \
+ tests/keys/signing-key.pub \
+ tests/keys/signing-key.sec \
+ tests/test.drv \
$(TESTS)
if !BUILD_DAEMON_OFFLOAD
--
2.37.3
^ permalink raw reply related [flat|nested] 37+ messages in thread* [bug#58812] [PATCH v3 2/4] install: Validate symlink target in evaluate-populate-directive.
2022-11-10 16:05 ` [bug#58812] [PATCH v3 1/4] Makefile.am: Sort EXTRA_DIST entries Maxim Cournoyer
@ 2022-11-10 16:05 ` Maxim Cournoyer
2022-11-10 16:05 ` [bug#58812] [PATCH v3 3/4] guix: shell: Add '--symlink' option Maxim Cournoyer
2022-11-10 16:05 ` [bug#58812] [PATCH v3 4/4] shell: Detect --symlink spec problems early Maxim Cournoyer
2 siblings, 0 replies; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-10 16:05 UTC (permalink / raw)
To: 58812; +Cc: Maxim Cournoyer
* gnu/build/install.scm (evaluate-populate-directive): By default, error when
the target of a symlink doesn't exist. Always ensure TARGET ends with "/".
(populate-root-file-system): Call evaluate-populate-directive with
#:error-on-dangling-symlink #t and add comment.
---
gnu/build/install.scm | 60 ++++++++++++++++++++++++++++---------------
1 file changed, 40 insertions(+), 20 deletions(-)
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index f5c8407b89..33a9616c0d 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -56,19 +57,24 @@ (define (install-boot-config bootcfg bootcfg-location mount-point)
(define* (evaluate-populate-directive directive target
#:key
(default-gid 0)
- (default-uid 0))
+ (default-uid 0)
+ (error-on-dangling-symlink? #t))
"Evaluate DIRECTIVE, an sexp describing a file or directory to create under
directory TARGET. DEFAULT-UID and DEFAULT-GID are the default UID and GID in
the context of the caller. If the directive matches those defaults then,
-'chown' won't be run."
+'chown' won't be run. When ERROR-ON-DANGLING-SYMLINK? is true, abort with an
+error when a dangling symlink would be created."
+ (define target* (if (string-suffix? "/" target)
+ target
+ (string-append target "/")))
(let loop ((directive directive))
(catch 'system-error
(lambda ()
(match directive
(('directory name)
- (mkdir-p (string-append target name)))
+ (mkdir-p (string-append target* name)))
(('directory name uid gid)
- (let ((dir (string-append target name)))
+ (let ((dir (string-append target* name)))
(mkdir-p dir)
;; If called from a context without "root" permissions, "chown"
;; to root will fail. In that case, do not try to run "chown"
@@ -78,27 +84,38 @@ (define* (evaluate-populate-directive directive target
(chown dir uid gid))))
(('directory name uid gid mode)
(loop `(directory ,name ,uid ,gid))
- (chmod (string-append target name) mode))
+ (chmod (string-append target* name) mode))
(('file name)
- (call-with-output-file (string-append target name)
+ (call-with-output-file (string-append target* name)
(const #t)))
(('file name (? string? content))
- (call-with-output-file (string-append target name)
+ (call-with-output-file (string-append target* name)
(lambda (port)
(display content port))))
((new '-> old)
- (let try ()
- (catch 'system-error
- (lambda ()
- (symlink old (string-append target new)))
- (lambda args
- ;; When doing 'guix system init' on the current '/', some
- ;; symlinks may already exists. Override them.
- (if (= EEXIST (system-error-errno args))
- (begin
- (delete-file (string-append target new))
- (try))
- (apply throw args))))))))
+ (let ((new* (string-append target* new)))
+ (let try ()
+ (catch 'system-error
+ (lambda ()
+ (when error-on-dangling-symlink?
+ ;; When the symbolic link points to a relative path,
+ ;; checking if its target exists must be done relatively
+ ;; to the link location.
+ (unless (if (string-prefix? "/" old)
+ (file-exists? old)
+ (with-directory-excursion (dirname new*)
+ (file-exists? old)))
+ (error (format #f "symlink `~a' points to nonexistent \
+file `~a'" new* old))))
+ (symlink old new*))
+ (lambda args
+ ;; When doing 'guix system init' on the current '/', some
+ ;; symlinks may already exists. Override them.
+ (if (= EEXIST (system-error-errno args))
+ (begin
+ (delete-file new*)
+ (try))
+ (apply throw args)))))))))
(lambda args
;; Usually we can only get here when installing to an existing root,
;; as with 'guix system init foo.scm /'.
@@ -142,7 +159,10 @@ (define* (populate-root-file-system system target
includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM.
EXTRAS is a list of directives appended to the built-in directives to populate
TARGET."
- (for-each (cut evaluate-populate-directive <> target)
+ ;; It's expected that some symbolic link targets do not exist yet, so do not
+ ;; error on dangling links.
+ (for-each (cut evaluate-populate-directive <> target
+ #:error-on-dangling-symlink? #f)
(append (directives (%store-directory)) extras))
;; Add system generation 1.
--
2.37.3
^ permalink raw reply related [flat|nested] 37+ messages in thread* [bug#58812] [PATCH v3 3/4] guix: shell: Add '--symlink' option.
2022-11-10 16:05 ` [bug#58812] [PATCH v3 1/4] Makefile.am: Sort EXTRA_DIST entries Maxim Cournoyer
2022-11-10 16:05 ` [bug#58812] [PATCH v3 2/4] install: Validate symlink target in evaluate-populate-directive Maxim Cournoyer
@ 2022-11-10 16:05 ` Maxim Cournoyer
2022-11-10 16:05 ` [bug#58812] [PATCH v3 4/4] shell: Detect --symlink spec problems early Maxim Cournoyer
2 siblings, 0 replies; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-10 16:05 UTC (permalink / raw)
To: 58812; +Cc: Maxim Cournoyer
* guix/scripts/pack.scm (%options): Extract symlink parsing logic to...
(symlink-spec-option-parser): ... here.
(self-contained-tarball/builder): 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, and
create symlinks using evaluate-populate-directive.
(guix-environment*): Pass symlinks arguments to launch-environment/container.
* doc/guix.texi (Invoking guix shell): Document it.
* tests/guix-shell.sh: Add a --symlink (negative) test.
* tests/guix-environment-container.sh: Add tests.
---
doc/guix.texi | 9 +++++-
guix/scripts/environment.scm | 43 ++++++++++++++++++++++-------
guix/scripts/pack.scm | 39 ++++++++++++++------------
tests/guix-environment-container.sh | 9 ++++++
tests/guix-shell.sh | 3 ++
5 files changed, 75 insertions(+), 28 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index 3f76184495..94c3f29790 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@*
@@ -6242,6 +6242,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
@@ -7034,6 +7040,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/guix/scripts/environment.scm b/guix/scripts/environment.scm
index de9bc8f98d..13c6f6cb5c 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)
+ #:autoload (guix scripts pack) (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,15 @@ (define fhs-mappings
(mkdir-p home-dir)
(setenv "HOME" home-dir)
+ ;; Create symlinks.
+ (let ((symlink->directives
+ (match-lambda
+ ((source '-> target)
+ `((directory ,(dirname source))
+ (,source -> ,(string-append profile "/" target)))))))
+ (for-each (cut evaluate-populate-directive <> ".")
+ (append-map symlink->directives symlinks)))
+
;; Call an additional setup procedure, if provided.
(when setup-hook
(setup-hook profile))
@@ -970,6 +989,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 +1030,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 +1121,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..a611922db3 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))))
+
\f
;;;
;;; Tarball format.
@@ -226,8 +243,9 @@ (define symlink->directives
`(,@(if (string=? parent "/")
'()
`((directory ,parent)))
- (,source
- -> ,(relative-file-name parent target)))))))
+ ;; Use a relative file name for compatibility with
+ ;; relocatable packs.
+ (,source -> ,(relative-file-name parent target)))))))
(define directives
;; Fully-qualified symlinks.
@@ -1208,20 +1226,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-environment-container.sh b/tests/guix-environment-container.sh
index fb2c19b193..82192375c7 100644
--- a/tests/guix-environment-container.sh
+++ b/tests/guix-environment-container.sh
@@ -241,3 +241,12 @@ guix shell -CF --bootstrap guile-bootstrap glibc \
"glibc-for-fhs")
0
1))'
+
+# '--symlink' works.
+echo "TESTING SYMLINK IN CONTAINER"
+guix shell --bootstrap guile-bootstrap --container \
+ --symlink=/usr/bin/guile=bin/guile -- \
+ /usr/bin/guile --version
+
+# A dangling symlink causes the command to fail.
+! guix shell --bootstrap -CS /usr/bin/python=bin/python guile-bootstrap -- exit
diff --git a/tests/guix-shell.sh b/tests/guix-shell.sh
index 9a6b055264..cb2b53466d 100644
--- a/tests/guix-shell.sh
+++ b/tests/guix-shell.sh
@@ -32,6 +32,9 @@ 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
+
# '--ad-hoc' is a thing of the past.
! guix shell --ad-hoc guile-bootstrap
--
2.37.3
^ permalink raw reply related [flat|nested] 37+ messages in thread* [bug#58812] [PATCH v3 4/4] shell: Detect --symlink spec problems early.
2022-11-10 16:05 ` [bug#58812] [PATCH v3 1/4] Makefile.am: Sort EXTRA_DIST entries Maxim Cournoyer
2022-11-10 16:05 ` [bug#58812] [PATCH v3 2/4] install: Validate symlink target in evaluate-populate-directive Maxim Cournoyer
2022-11-10 16:05 ` [bug#58812] [PATCH v3 3/4] guix: shell: Add '--symlink' option Maxim Cournoyer
@ 2022-11-10 16:05 ` Maxim Cournoyer
2 siblings, 0 replies; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-10 16:05 UTC (permalink / raw)
To: 58812; +Cc: Maxim Cournoyer
* guix/scripts/pack.scm (symlink-spec-option-parser): Remove extraneous
char-set. Raise an exception when the target is an absolute file name.
(guix-pack): Move with-error-handler earlier.
* guix/scripts/shell.scm (guix-shell): Likewise.
* guix/scripts/environment.scm (guix-environment): Wrap the whole
guix-environment* call with the with-error-handling handler.
* tests/guix-environment-container.sh: Add tests.
* tests/guix-pack.sh: Adjust symlink spec.
---
guix/scripts/environment.scm | 294 ++++++++++++++--------------
guix/scripts/pack.scm | 155 ++++++++-------
guix/scripts/shell.scm | 77 ++++----
tests/guix-environment-container.sh | 3 +
tests/guix-pack.sh | 2 +-
5 files changed, 276 insertions(+), 255 deletions(-)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 13c6f6cb5c..64597f6e9f 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -980,158 +980,158 @@ (define-command (guix-environment . args)
(category development)
(synopsis "spawn one-off software environments (deprecated)")
- (guix-environment* (parse-args args)))
+ (with-error-handling
+ (guix-environment* (parse-args args))))
(define (guix-environment* opts)
"Run the 'guix environment' command on OPTS, an alist resulting for
command-line option processing with 'parse-command-line'."
- (with-error-handling
- (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?))
- (user (assoc-ref opts 'user))
- (bootstrap? (assoc-ref opts 'bootstrap?))
- (system (assoc-ref opts 'system))
- (profile (assoc-ref opts 'profile))
- (command (or (assoc-ref opts 'exec)
- ;; Spawn a shell if the user didn't specify
- ;; anything in particular.
- (if container?
- ;; The user's shell is likely not available
- ;; within the container.
- '("/bin/sh")
- (list %default-shell))))
- (mappings (pick-all opts 'file-system-mapping))
- (white-list (pick-all opts 'inherit-regexp)))
-
- (define store-needed?
- ;; Whether connecting to the daemon is needed.
- (or container? (not profile)))
-
- (define-syntax-rule (with-store/maybe store exp ...)
- ;; Evaluate EXP... with STORE bound to a connection, unless
- ;; STORE-NEEDED? is false, in which case STORE is bound to #f.
- (let ((proc (lambda (store) exp ...)))
- (if store-needed?
- (with-store s
- (set-build-options-from-command-line s opts)
- (with-build-handler (build-notifier #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:verbosity
- (assoc-ref opts 'verbosity)
- #:dry-run?
- (assoc-ref opts 'dry-run?))
- (proc s)))
- (proc #f))))
-
- (when container? (assert-container-features))
-
- (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)
- (define manifest-from-opts
- (options/resolve-packages store opts))
-
- (define manifest
- (if profile
- (profile-manifest profile)
- manifest-from-opts))
-
- (when (and profile
- (> (length (manifest-entries manifest-from-opts)) 0))
- (leave (G_ "'--profile' cannot be used with package options~%")))
-
- (when (null? (manifest-entries manifest))
- (warning (G_ "no packages specified; creating an empty environment~%")))
-
- ;; Use the bootstrap Guile when requested.
- (parameterize ((%graft? (assoc-ref opts 'graft?))
- (%guile-for-build
- (and store-needed?
- (package-derivation
- store
- (if bootstrap?
- %bootstrap-guile
- (default-guile))))))
- (run-with-store store
- ;; Containers need a Bourne shell at /bin/sh.
- (mlet* %store-monad ((bash (environment-bash container?
- bootstrap?
- system))
- (prof-drv (if profile
- (return #f)
- (manifest->derivation
- manifest system bootstrap?)))
- (profile -> (if profile
- (readlink* profile)
- (derivation->output-path prof-drv)))
- (gc-root -> (assoc-ref opts 'gc-root)))
-
- ;; First build the inputs. This is necessary even for
- ;; --search-paths. Additionally, we might need to build bash for
- ;; a container.
- (mbegin %store-monad
- (mwhen store-needed?
- (built-derivations (append
- (if prof-drv (list prof-drv) '())
- (if (derivation? bash) (list bash) '()))))
- (mwhen gc-root
- (register-gc-root profile gc-root))
-
- (mwhen (assoc-ref opts 'check?)
- (return
- (if container?
- (warning (G_ "'--check' is unnecessary \
+ (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?))
+ (user (assoc-ref opts 'user))
+ (bootstrap? (assoc-ref opts 'bootstrap?))
+ (system (assoc-ref opts 'system))
+ (profile (assoc-ref opts 'profile))
+ (command (or (assoc-ref opts 'exec)
+ ;; Spawn a shell if the user didn't specify
+ ;; anything in particular.
+ (if container?
+ ;; The user's shell is likely not available
+ ;; within the container.
+ '("/bin/sh")
+ (list %default-shell))))
+ (mappings (pick-all opts 'file-system-mapping))
+ (white-list (pick-all opts 'inherit-regexp)))
+
+ (define store-needed?
+ ;; Whether connecting to the daemon is needed.
+ (or container? (not profile)))
+
+ (define-syntax-rule (with-store/maybe store exp ...)
+ ;; Evaluate EXP... with STORE bound to a connection, unless
+ ;; STORE-NEEDED? is false, in which case STORE is bound to #f.
+ (let ((proc (lambda (store) exp ...)))
+ (if store-needed?
+ (with-store s
+ (set-build-options-from-command-line s opts)
+ (with-build-handler (build-notifier #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:verbosity
+ (assoc-ref opts 'verbosity)
+ #:dry-run?
+ (assoc-ref opts 'dry-run?))
+ (proc s)))
+ (proc #f))))
+
+ (when container? (assert-container-features))
+
+ (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)
+ (define manifest-from-opts
+ (options/resolve-packages store opts))
+
+ (define manifest
+ (if profile
+ (profile-manifest profile)
+ manifest-from-opts))
+
+ (when (and profile
+ (> (length (manifest-entries manifest-from-opts)) 0))
+ (leave (G_ "'--profile' cannot be used with package options~%")))
+
+ (when (null? (manifest-entries manifest))
+ (warning (G_ "no packages specified; creating an empty environment~%")))
+
+ ;; Use the bootstrap Guile when requested.
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%guile-for-build
+ (and store-needed?
+ (package-derivation
+ store
+ (if bootstrap?
+ %bootstrap-guile
+ (default-guile))))))
+ (run-with-store store
+ ;; Containers need a Bourne shell at /bin/sh.
+ (mlet* %store-monad ((bash (environment-bash container?
+ bootstrap?
+ system))
+ (prof-drv (if profile
+ (return #f)
+ (manifest->derivation
+ manifest system bootstrap?)))
+ (profile -> (if profile
+ (readlink* profile)
+ (derivation->output-path prof-drv)))
+ (gc-root -> (assoc-ref opts 'gc-root)))
+
+ ;; First build the inputs. This is necessary even for
+ ;; --search-paths. Additionally, we might need to build bash for
+ ;; a container.
+ (mbegin %store-monad
+ (mwhen store-needed?
+ (built-derivations (append
+ (if prof-drv (list prof-drv) '())
+ (if (derivation? bash) (list bash) '()))))
+ (mwhen gc-root
+ (register-gc-root profile gc-root))
+
+ (mwhen (assoc-ref opts 'check?)
+ (return
+ (if container?
+ (warning (G_ "'--check' is unnecessary \
when using '--container'; doing nothing~%"))
- (validate-child-shell-environment profile manifest))))
-
- (cond
- ((assoc-ref opts 'search-paths)
- (show-search-paths profile manifest #:pure? pure?)
- (return #t))
- (container?
- (let ((bash-binary
- (if bootstrap?
- (derivation->output-path bash)
- (string-append (derivation->output-path bash)
- "/bin/sh"))))
- (launch-environment/container #:command command
- #:bash bash-binary
- #:user user
- #:user-mappings mappings
- #:profile profile
- #:manifest manifest
- #:white-list white-list
- #:link-profile? link-prof?
- #:network? network?
- #:map-cwd? (not no-cwd?)
- #:emulate-fhs? emulate-fhs?
- #:symlinks symlinks
- #:setup-hook
- (and emulate-fhs?
- setup-fhs))))
-
- (else
- (return
- (exit/status
- (launch-environment/fork command profile manifest
- #:white-list white-list
- #:pure? pure?))))))))))))))
+ (validate-child-shell-environment profile manifest))))
+
+ (cond
+ ((assoc-ref opts 'search-paths)
+ (show-search-paths profile manifest #:pure? pure?)
+ (return #t))
+ (container?
+ (let ((bash-binary
+ (if bootstrap?
+ (derivation->output-path bash)
+ (string-append (derivation->output-path bash)
+ "/bin/sh"))))
+ (launch-environment/container #:command command
+ #:bash bash-binary
+ #:user user
+ #:user-mappings mappings
+ #:profile profile
+ #:manifest manifest
+ #:white-list white-list
+ #:link-profile? link-prof?
+ #:network? network?
+ #:map-cwd? (not no-cwd?)
+ #:emulate-fhs? emulate-fhs?
+ #:symlinks symlinks
+ #:setup-hook
+ (and emulate-fhs?
+ setup-fhs))))
+
+ (else
+ (return
+ (exit/status
+ (launch-environment/fork command profile manifest
+ #:white-list white-list
+ #:pure? pure?)))))))))))))
;;; Local Variables:
;;; eval: (put 'with-store/maybe 'scheme-indent-function 1)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index a611922db3..f81b3e6501 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -42,6 +42,7 @@ (define-module (guix scripts pack)
#:use-module (guix profiles)
#:use-module (guix describe)
#:use-module (guix derivations)
+ #:use-module (guix diagnostics)
#:use-module (guix search-paths)
#:use-module (guix build-system gnu)
#:use-module (guix scripts build)
@@ -59,6 +60,7 @@ (define-module (guix scripts pack)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
#:export (symlink-spec-option-parser
@@ -163,12 +165,27 @@ (define str (string-join names "-"))
((names ... _) (loop names))))))
(define (symlink-spec-option-parser opt name arg result)
- "A SRFI-37 option parser for the --symlink option."
+ "A SRFI-37 option parser for the --symlink option. The symlink spec accepts
+the link file name as its left-hand side value and its target as its
+right-hand side value. The target must be a relative link."
;; 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 #\=))
+ (match (string-split arg #\=)
((source target)
+ (when (string-prefix? "/" target)
+ (raise-exception
+ (make-compound-condition
+ (formatted-message (G_ "symlink target is absolute: '~a'~%") target)
+ (condition
+ (&fix-hint (hint (format #f (G_ "The target of the symlink must be
+relative rather than absolute, as it is relative to the profile created.
+Perhaps the source and target components of the symlink spec were inverted?
+Below is a valid example, where the @file{/usr/bin/env} symbolic link is to
+target the profile's @file{bin/env} file:
+@example
+--symlink=/usr/bin/env=bin/env
+@end example"))))))))
(let ((symlinks (assoc-ref result 'symlinks)))
(alist-cons 'symlinks
`((,source -> ,target) ,@symlinks)
@@ -1326,74 +1343,74 @@ (define-command (guix-pack . args)
(category development)
(synopsis "create application bundles")
- (define opts
- (parse-command-line args %options (list %default-options)))
-
- (define maybe-package-argument
- ;; Given an option pair, return a package, a package/output tuple, or #f.
- (match-lambda
- (('argument . spec)
- (call-with-values
- (lambda ()
- (specification->package+output spec))
- list))
- (('expression . exp)
- (read/eval-package-expression exp))
- (x #f)))
-
- (define (manifest-from-args store opts)
- (let* ((transform (options->transformation opts))
- (packages (map (match-lambda
- (((? package? package) output)
- (list (transform package) output))
- ((? package? package)
- (list (transform package) "out")))
- (reverse
- (filter-map maybe-package-argument opts))))
- (manifests (filter-map (match-lambda
- (('manifest . file) file)
- (_ #f))
- opts)))
- (define with-provenance
- (if (assoc-ref opts 'save-provenance?)
- (lambda (manifest)
- (map-manifest-entries
- (lambda (entry)
- (let ((entry (manifest-entry-with-provenance entry)))
- (unless (assq 'provenance (manifest-entry-properties entry))
- (warning (G_ "could not determine provenance of package ~a~%")
- (manifest-entry-name entry)))
- entry))
- manifest))
- identity))
-
- (with-provenance
- (cond
- ((and (not (null? manifests)) (not (null? packages)))
- (leave (G_ "both a manifest and a package list were given~%")))
- ((not (null? manifests))
- (concatenate-manifests
- (map (lambda (file)
- (let ((user-module (make-user-module
- '((guix profiles) (gnu)))))
- (load* file user-module)))
- manifests)))
- (else
- (packages->manifest packages))))))
-
- (define (process-file-arg opts name)
- ;; Validate that the file exists and return it as a <local-file> object,
- ;; else #f.
- (let ((value (assoc-ref opts name)))
- (match value
- ((and (? string?) (not (? file-exists?)))
- (leave (G_ "file provided with option ~a does not exist: ~a~%")
- (string-append "--" (symbol->string name)) value))
- ((? string?)
- (local-file value))
- (#f #f))))
-
(with-error-handling
+ (define opts
+ (parse-command-line args %options (list %default-options)))
+
+ (define maybe-package-argument
+ ;; Given an option pair, return a package, a package/output tuple, or #f.
+ (match-lambda
+ (('argument . spec)
+ (call-with-values
+ (lambda ()
+ (specification->package+output spec))
+ list))
+ (('expression . exp)
+ (read/eval-package-expression exp))
+ (x #f)))
+
+ (define (manifest-from-args store opts)
+ (let* ((transform (options->transformation opts))
+ (packages (map (match-lambda
+ (((? package? package) output)
+ (list (transform package) output))
+ ((? package? package)
+ (list (transform package) "out")))
+ (reverse
+ (filter-map maybe-package-argument opts))))
+ (manifests (filter-map (match-lambda
+ (('manifest . file) file)
+ (_ #f))
+ opts)))
+ (define with-provenance
+ (if (assoc-ref opts 'save-provenance?)
+ (lambda (manifest)
+ (map-manifest-entries
+ (lambda (entry)
+ (let ((entry (manifest-entry-with-provenance entry)))
+ (unless (assq 'provenance (manifest-entry-properties entry))
+ (warning (G_ "could not determine provenance of package ~a~%")
+ (manifest-entry-name entry)))
+ entry))
+ manifest))
+ identity))
+
+ (with-provenance
+ (cond
+ ((and (not (null? manifests)) (not (null? packages)))
+ (leave (G_ "both a manifest and a package list were given~%")))
+ ((not (null? manifests))
+ (concatenate-manifests
+ (map (lambda (file)
+ (let ((user-module (make-user-module
+ '((guix profiles) (gnu)))))
+ (load* file user-module)))
+ manifests)))
+ (else
+ (packages->manifest packages))))))
+
+ (define (process-file-arg opts name)
+ ;; Validate that the file exists and return it as a <local-file> object,
+ ;; else #f.
+ (let ((value (assoc-ref opts name)))
+ (match value
+ ((and (? string?) (not (? file-exists?)))
+ (leave (G_ "file provided with option ~a does not exist: ~a~%")
+ (string-append "--" (symbol->string name)) value))
+ ((? string?)
+ (local-file value))
+ (#f #f))))
+
(with-store store
(with-status-verbosity (assoc-ref opts 'verbosity)
;; Set the build options before we do anything else.
diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm
index 7a379122ae..2fc1dc942a 100644
--- a/guix/scripts/shell.scm
+++ b/guix/scripts/shell.scm
@@ -534,43 +534,44 @@ (define-command (guix-shell . args)
(category development)
(synopsis "spawn one-off software environments")
- (define (cache-entries directory)
- (filter-map (match-lambda
- ((or "." "..") #f)
- (file (string-append directory "/" file)))
- (or (scandir directory) '())))
-
- (define* (entry-expiration file)
- ;; Return the time at which FILE, a cached profile, is considered expired.
- (match (false-if-exception (lstat file))
- (#f 0) ;FILE may have been deleted in the meantime
- (st (+ (stat:atime st) (* 60 60 24 7)))))
-
- (define opts
- (parse-args args))
-
- (define interactive?
- (not (assoc-ref opts 'exec)))
-
- (if (assoc-ref opts 'check?)
- (record-hint 'shell-check)
- (when (and interactive?
- (not (hint-given? 'shell-check))
- (not (assoc-ref opts 'container?))
- (not (assoc-ref opts 'search-paths)))
- (display-hint (G_ "Consider passing the @option{--check} option once
+ (with-error-handling
+ (define (cache-entries directory)
+ (filter-map (match-lambda
+ ((or "." "..") #f)
+ (file (string-append directory "/" file)))
+ (or (scandir directory) '())))
+
+ (define* (entry-expiration file)
+ ;; Return the time at which FILE, a cached profile, is considered expired.
+ (match (false-if-exception (lstat file))
+ (#f 0) ;FILE may have been deleted in the meantime
+ (st (+ (stat:atime st) (* 60 60 24 7)))))
+
+ (define opts
+ (parse-args args))
+
+ (define interactive?
+ (not (assoc-ref opts 'exec)))
+
+ (if (assoc-ref opts 'check?)
+ (record-hint 'shell-check)
+ (when (and interactive?
+ (not (hint-given? 'shell-check))
+ (not (assoc-ref opts 'container?))
+ (not (assoc-ref opts 'search-paths)))
+ (display-hint (G_ "Consider passing the @option{--check} option once
to make sure your shell does not clobber environment variables."))) )
- ;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use
- ;; of cached profiles, and (2) cleanup actually happens, even when
- ;; 'guix-environment*' calls 'exit'.
- (add-hook! exit-hook
- (lambda _
- (maybe-remove-expired-cache-entries
- (%profile-cache-directory)
- cache-entries
- #:entry-expiration entry-expiration)))
-
- (if (assoc-ref opts 'export-manifest?)
- (export-manifest opts (current-output-port))
- (guix-environment* opts)))
+ ;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use
+ ;; of cached profiles, and (2) cleanup actually happens, even when
+ ;; 'guix-environment*' calls 'exit'.
+ (add-hook! exit-hook
+ (lambda _
+ (maybe-remove-expired-cache-entries
+ (%profile-cache-directory)
+ cache-entries
+ #:entry-expiration entry-expiration)))
+
+ (if (assoc-ref opts 'export-manifest?)
+ (export-manifest opts (current-output-port))
+ (guix-environment* opts))))
diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh
index 82192375c7..0306fc1744 100644
--- a/tests/guix-environment-container.sh
+++ b/tests/guix-environment-container.sh
@@ -250,3 +250,6 @@ guix shell --bootstrap guile-bootstrap --container \
# A dangling symlink causes the command to fail.
! guix shell --bootstrap -CS /usr/bin/python=bin/python guile-bootstrap -- exit
+
+# An invalid symlink spec causes the command to fail.
+! guix shell --bootstrap -CS bin/guile=/usr/bin/guile guile-bootstrap -- exit
diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh
index f19a0f754e..6fc9e3723b 100644
--- a/tests/guix-pack.sh
+++ b/tests/guix-pack.sh
@@ -103,7 +103,7 @@ fi
guix pack --dry-run --bootstrap -f docker guile-bootstrap
# Build a Docker image with a symlink.
-guix pack --dry-run --bootstrap -f docker -S /opt/gnu=/ guile-bootstrap
+guix pack --dry-run --bootstrap -f docker -S /opt/gnu= guile-bootstrap
# Build a tarball pack of cross-compiled software. Use coreutils because
# guile-bootstrap is not intended to be cross-compiled.
--
2.37.3
^ permalink raw reply related [flat|nested] 37+ messages in thread
* [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell'.
2022-11-09 20:58 ` [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell' Ludovic Courtès
2022-11-10 3:10 ` Maxim Cournoyer
@ 2022-11-16 19:03 ` zimoun
2022-11-16 19:34 ` Maxim Cournoyer
1 sibling, 1 reply; 37+ messages in thread
From: zimoun @ 2022-11-16 19:03 UTC (permalink / raw)
To: Ludovic Courtès, Maxim Cournoyer; +Cc: 58812
Hi Maxim,
On Wed, 09 Nov 2022 at 21:58, Ludovic Courtès <ludo@gnu.org> wrote:
>> +@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}.
>
> We should refrain from using @ref in sentences (info "(texinfo) @ref").
> Instead, I’d write:
>
> documented for @command{guix pack} (@pxref{pack-symlink-option}).
Well, for what it is worth, I have marked this email [1] by Eli
Zaretskii from Emacs. Somehow, the message provides some rules of thumb
to write Texinfo. :-) Quoting about cross-reference:
5. Cross-references:
As a separate sentence: @xref{Node name}, for the details.
In the middle of a sentence ... see @ref{Node name}, for more.
In parentheses: Some text (@pxref{Some node}) more text.
1: https://lists.gnu.org/archive/html/emacs-devel/2017-11/msg00525.html
Cheers,
simon
^ permalink raw reply [flat|nested] 37+ messages in thread* [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell'.
2022-11-16 19:03 ` [bug#58812] [PATCH 0/5] Add --symlink option to 'guix shell' zimoun
@ 2022-11-16 19:34 ` Maxim Cournoyer
0 siblings, 0 replies; 37+ messages in thread
From: Maxim Cournoyer @ 2022-11-16 19:34 UTC (permalink / raw)
To: zimoun; +Cc: Ludovic Courtès, 58812
Hi Simon,
zimoun <zimon.toutoune@gmail.com> writes:
> Hi Maxim,
>
> On Wed, 09 Nov 2022 at 21:58, Ludovic Courtès <ludo@gnu.org> wrote:
>
>>> +@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}.
>>
>> We should refrain from using @ref in sentences (info "(texinfo) @ref").
>> Instead, I’d write:
>>
>> documented for @command{guix pack} (@pxref{pack-symlink-option}).
>
> Well, for what it is worth, I have marked this email [1] by Eli
> Zaretskii from Emacs. Somehow, the message provides some rules of thumb
> to write Texinfo. :-) Quoting about cross-reference:
>
> 5. Cross-references:
>
> As a separate sentence: @xref{Node name}, for the details.
> In the middle of a sentence ... see @ref{Node name}, for more.
> In parentheses: Some text (@pxref{Some node}) more text.
>
> 1: https://lists.gnu.org/archive/html/emacs-devel/2017-11/msg00525.html
I like it, it takes the occult out of the equation :-).
--
Thanks,
Maxim
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#58812] [PATCH 5/5] shell: Detect --symlink spec problems early.
2022-10-27 3:50 ` [bug#58812] [PATCH 1/5] Makefile.am: Sort EXTRA_DIST entries Maxim Cournoyer
` (2 preceding siblings ...)
2022-10-27 3:50 ` [bug#58812] [PATCH 4/5] guix: shell: Add '--symlink' option Maxim Cournoyer
@ 2022-10-27 3:51 ` Maxim Cournoyer
3 siblings, 0 replies; 37+ messages in thread
From: Maxim Cournoyer @ 2022-10-27 3:51 UTC (permalink / raw)
To: 58812; +Cc: Maxim Cournoyer
* guix/scripts/pack.scm (symlink-spec-option-parser): Remove extraneous
char-set. Raise an exception when the target is an absolute file name.
(guix-pack): Move with-error-handler earlier.
* guix/scripts/shell.scm (guix-shell): Likewise.
* guix/scripts/environment.scm (guix-environment): Wrap the whole
guix-environment* call with the with-error-handling handler.
* tests/guix-shell.sh: Add test.
* tests/guix-pack.sh: Adjust symlink spec.
---
guix/scripts/environment.scm | 294 +++++++++++++++++------------------
guix/scripts/pack.scm | 155 ++++++++++--------
guix/scripts/shell.scm | 77 ++++-----
tests/guix-pack.sh | 2 +-
tests/guix-shell.sh | 6 +-
5 files changed, 278 insertions(+), 256 deletions(-)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index bd95329c5c..0906b48508 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -975,158 +975,158 @@ (define-command (guix-environment . args)
(category development)
(synopsis "spawn one-off software environments (deprecated)")
- (guix-environment* (parse-args args)))
+ (with-error-handling
+ (guix-environment* (parse-args args))))
(define (guix-environment* opts)
"Run the 'guix environment' command on OPTS, an alist resulting for
command-line option processing with 'parse-command-line'."
- (with-error-handling
- (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?))
- (user (assoc-ref opts 'user))
- (bootstrap? (assoc-ref opts 'bootstrap?))
- (system (assoc-ref opts 'system))
- (profile (assoc-ref opts 'profile))
- (command (or (assoc-ref opts 'exec)
- ;; Spawn a shell if the user didn't specify
- ;; anything in particular.
- (if container?
- ;; The user's shell is likely not available
- ;; within the container.
- '("/bin/sh")
- (list %default-shell))))
- (mappings (pick-all opts 'file-system-mapping))
- (white-list (pick-all opts 'inherit-regexp)))
-
- (define store-needed?
- ;; Whether connecting to the daemon is needed.
- (or container? (not profile)))
-
- (define-syntax-rule (with-store/maybe store exp ...)
- ;; Evaluate EXP... with STORE bound to a connection, unless
- ;; STORE-NEEDED? is false, in which case STORE is bound to #f.
- (let ((proc (lambda (store) exp ...)))
- (if store-needed?
- (with-store s
- (set-build-options-from-command-line s opts)
- (with-build-handler (build-notifier #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:verbosity
- (assoc-ref opts 'verbosity)
- #:dry-run?
- (assoc-ref opts 'dry-run?))
- (proc s)))
- (proc #f))))
-
- (when container? (assert-container-features))
-
- (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)
- (define manifest-from-opts
- (options/resolve-packages store opts))
-
- (define manifest
- (if profile
- (profile-manifest profile)
- manifest-from-opts))
-
- (when (and profile
- (> (length (manifest-entries manifest-from-opts)) 0))
- (leave (G_ "'--profile' cannot be used with package options~%")))
-
- (when (null? (manifest-entries manifest))
- (warning (G_ "no packages specified; creating an empty environment~%")))
-
- ;; Use the bootstrap Guile when requested.
- (parameterize ((%graft? (assoc-ref opts 'graft?))
- (%guile-for-build
- (and store-needed?
- (package-derivation
- store
- (if bootstrap?
- %bootstrap-guile
- (default-guile))))))
- (run-with-store store
- ;; Containers need a Bourne shell at /bin/sh.
- (mlet* %store-monad ((bash (environment-bash container?
- bootstrap?
- system))
- (prof-drv (if profile
- (return #f)
- (manifest->derivation
- manifest system bootstrap?)))
- (profile -> (if profile
- (readlink* profile)
- (derivation->output-path prof-drv)))
- (gc-root -> (assoc-ref opts 'gc-root)))
-
- ;; First build the inputs. This is necessary even for
- ;; --search-paths. Additionally, we might need to build bash for
- ;; a container.
- (mbegin %store-monad
- (mwhen store-needed?
- (built-derivations (append
- (if prof-drv (list prof-drv) '())
- (if (derivation? bash) (list bash) '()))))
- (mwhen gc-root
- (register-gc-root profile gc-root))
-
- (mwhen (assoc-ref opts 'check?)
- (return
- (if container?
- (warning (G_ "'--check' is unnecessary \
+ (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?))
+ (user (assoc-ref opts 'user))
+ (bootstrap? (assoc-ref opts 'bootstrap?))
+ (system (assoc-ref opts 'system))
+ (profile (assoc-ref opts 'profile))
+ (command (or (assoc-ref opts 'exec)
+ ;; Spawn a shell if the user didn't specify
+ ;; anything in particular.
+ (if container?
+ ;; The user's shell is likely not available
+ ;; within the container.
+ '("/bin/sh")
+ (list %default-shell))))
+ (mappings (pick-all opts 'file-system-mapping))
+ (white-list (pick-all opts 'inherit-regexp)))
+
+ (define store-needed?
+ ;; Whether connecting to the daemon is needed.
+ (or container? (not profile)))
+
+ (define-syntax-rule (with-store/maybe store exp ...)
+ ;; Evaluate EXP... with STORE bound to a connection, unless
+ ;; STORE-NEEDED? is false, in which case STORE is bound to #f.
+ (let ((proc (lambda (store) exp ...)))
+ (if store-needed?
+ (with-store s
+ (set-build-options-from-command-line s opts)
+ (with-build-handler (build-notifier #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:verbosity
+ (assoc-ref opts 'verbosity)
+ #:dry-run?
+ (assoc-ref opts 'dry-run?))
+ (proc s)))
+ (proc #f))))
+
+ (when container? (assert-container-features))
+
+ (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)
+ (define manifest-from-opts
+ (options/resolve-packages store opts))
+
+ (define manifest
+ (if profile
+ (profile-manifest profile)
+ manifest-from-opts))
+
+ (when (and profile
+ (> (length (manifest-entries manifest-from-opts)) 0))
+ (leave (G_ "'--profile' cannot be used with package options~%")))
+
+ (when (null? (manifest-entries manifest))
+ (warning (G_ "no packages specified; creating an empty environment~%")))
+
+ ;; Use the bootstrap Guile when requested.
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%guile-for-build
+ (and store-needed?
+ (package-derivation
+ store
+ (if bootstrap?
+ %bootstrap-guile
+ (default-guile))))))
+ (run-with-store store
+ ;; Containers need a Bourne shell at /bin/sh.
+ (mlet* %store-monad ((bash (environment-bash container?
+ bootstrap?
+ system))
+ (prof-drv (if profile
+ (return #f)
+ (manifest->derivation
+ manifest system bootstrap?)))
+ (profile -> (if profile
+ (readlink* profile)
+ (derivation->output-path prof-drv)))
+ (gc-root -> (assoc-ref opts 'gc-root)))
+
+ ;; First build the inputs. This is necessary even for
+ ;; --search-paths. Additionally, we might need to build bash for
+ ;; a container.
+ (mbegin %store-monad
+ (mwhen store-needed?
+ (built-derivations (append
+ (if prof-drv (list prof-drv) '())
+ (if (derivation? bash) (list bash) '()))))
+ (mwhen gc-root
+ (register-gc-root profile gc-root))
+
+ (mwhen (assoc-ref opts 'check?)
+ (return
+ (if container?
+ (warning (G_ "'--check' is unnecessary \
when using '--container'; doing nothing~%"))
- (validate-child-shell-environment profile manifest))))
-
- (cond
- ((assoc-ref opts 'search-paths)
- (show-search-paths profile manifest #:pure? pure?)
- (return #t))
- (container?
- (let ((bash-binary
- (if bootstrap?
- (derivation->output-path bash)
- (string-append (derivation->output-path bash)
- "/bin/sh"))))
- (launch-environment/container #:command command
- #:bash bash-binary
- #:user user
- #:user-mappings mappings
- #:profile profile
- #:manifest manifest
- #:white-list white-list
- #:link-profile? link-prof?
- #:network? network?
- #:map-cwd? (not no-cwd?)
- #:emulate-fhs? emulate-fhs?
- #:symlinks symlinks
- #:setup-hook
- (and emulate-fhs?
- setup-fhs))))
-
- (else
- (return
- (exit/status
- (launch-environment/fork command profile manifest
- #:white-list white-list
- #:pure? pure?))))))))))))))
+ (validate-child-shell-environment profile manifest))))
+
+ (cond
+ ((assoc-ref opts 'search-paths)
+ (show-search-paths profile manifest #:pure? pure?)
+ (return #t))
+ (container?
+ (let ((bash-binary
+ (if bootstrap?
+ (derivation->output-path bash)
+ (string-append (derivation->output-path bash)
+ "/bin/sh"))))
+ (launch-environment/container #:command command
+ #:bash bash-binary
+ #:user user
+ #:user-mappings mappings
+ #:profile profile
+ #:manifest manifest
+ #:white-list white-list
+ #:link-profile? link-prof?
+ #:network? network?
+ #:map-cwd? (not no-cwd?)
+ #:emulate-fhs? emulate-fhs?
+ #:symlinks symlinks
+ #:setup-hook
+ (and emulate-fhs?
+ setup-fhs))))
+
+ (else
+ (return
+ (exit/status
+ (launch-environment/fork command profile manifest
+ #:white-list white-list
+ #:pure? pure?)))))))))))))
;;; Local Variables:
;;; eval: (put 'with-store/maybe 'scheme-indent-function 1)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index e3bddc4274..a101900736 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -42,6 +42,7 @@ (define-module (guix scripts pack)
#:use-module (guix profiles)
#:use-module (guix describe)
#:use-module (guix derivations)
+ #:use-module (guix diagnostics)
#:use-module (guix search-paths)
#:use-module (guix build-system gnu)
#:use-module (guix scripts build)
@@ -59,6 +60,7 @@ (define-module (guix scripts pack)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
#:export (symlink-spec-option-parser
@@ -163,12 +165,27 @@ (define str (string-join names "-"))
((names ... _) (loop names))))))
(define (symlink-spec-option-parser opt name arg result)
- "A SRFI-37 option parser for the --symlink option."
+ "A SRFI-37 option parser for the --symlink option. The symlink spec accepts
+the link file name as its left-hand side value and its target as its
+right-hand side value. The target must be a relative link."
;; 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 #\=))
+ (match (string-split arg #\=)
((source target)
+ (when (string-prefix? "/" target)
+ (raise-exception
+ (make-compound-condition
+ (formatted-message (G_ "symlink target is absolute: '~a'~%") target)
+ (condition
+ (&fix-hint (hint (format #f (G_ "The target of the symlink must be
+relative rather than absolute, as it is relative to the profile created.
+Perhaps the source and target components of the symlink spec were inverted?
+Below is a valid example, where the @file{/usr/bin/env} symbolic link is to
+target the profile's @file{bin/env} file:
+@example
+--symlink=/usr/bin/env=bin/env
+@end example"))))))))
(let ((symlinks (assoc-ref result 'symlinks)))
(alist-cons 'symlinks
`((,source -> ,target) ,@symlinks)
@@ -1310,74 +1327,74 @@ (define-command (guix-pack . args)
(category development)
(synopsis "create application bundles")
- (define opts
- (parse-command-line args %options (list %default-options)))
-
- (define maybe-package-argument
- ;; Given an option pair, return a package, a package/output tuple, or #f.
- (match-lambda
- (('argument . spec)
- (call-with-values
- (lambda ()
- (specification->package+output spec))
- list))
- (('expression . exp)
- (read/eval-package-expression exp))
- (x #f)))
-
- (define (manifest-from-args store opts)
- (let* ((transform (options->transformation opts))
- (packages (map (match-lambda
- (((? package? package) output)
- (list (transform package) output))
- ((? package? package)
- (list (transform package) "out")))
- (reverse
- (filter-map maybe-package-argument opts))))
- (manifests (filter-map (match-lambda
- (('manifest . file) file)
- (_ #f))
- opts)))
- (define with-provenance
- (if (assoc-ref opts 'save-provenance?)
- (lambda (manifest)
- (map-manifest-entries
- (lambda (entry)
- (let ((entry (manifest-entry-with-provenance entry)))
- (unless (assq 'provenance (manifest-entry-properties entry))
- (warning (G_ "could not determine provenance of package ~a~%")
- (manifest-entry-name entry)))
- entry))
- manifest))
- identity))
-
- (with-provenance
- (cond
- ((and (not (null? manifests)) (not (null? packages)))
- (leave (G_ "both a manifest and a package list were given~%")))
- ((not (null? manifests))
- (concatenate-manifests
- (map (lambda (file)
- (let ((user-module (make-user-module
- '((guix profiles) (gnu)))))
- (load* file user-module)))
- manifests)))
- (else
- (packages->manifest packages))))))
-
- (define (process-file-arg opts name)
- ;; Validate that the file exists and return it as a <local-file> object,
- ;; else #f.
- (let ((value (assoc-ref opts name)))
- (match value
- ((and (? string?) (not (? file-exists?)))
- (leave (G_ "file provided with option ~a does not exist: ~a~%")
- (string-append "--" (symbol->string name)) value))
- ((? string?)
- (local-file value))
- (#f #f))))
-
(with-error-handling
+ (define opts
+ (parse-command-line args %options (list %default-options)))
+
+ (define maybe-package-argument
+ ;; Given an option pair, return a package, a package/output tuple, or #f.
+ (match-lambda
+ (('argument . spec)
+ (call-with-values
+ (lambda ()
+ (specification->package+output spec))
+ list))
+ (('expression . exp)
+ (read/eval-package-expression exp))
+ (x #f)))
+
+ (define (manifest-from-args store opts)
+ (let* ((transform (options->transformation opts))
+ (packages (map (match-lambda
+ (((? package? package) output)
+ (list (transform package) output))
+ ((? package? package)
+ (list (transform package) "out")))
+ (reverse
+ (filter-map maybe-package-argument opts))))
+ (manifests (filter-map (match-lambda
+ (('manifest . file) file)
+ (_ #f))
+ opts)))
+ (define with-provenance
+ (if (assoc-ref opts 'save-provenance?)
+ (lambda (manifest)
+ (map-manifest-entries
+ (lambda (entry)
+ (let ((entry (manifest-entry-with-provenance entry)))
+ (unless (assq 'provenance (manifest-entry-properties entry))
+ (warning (G_ "could not determine provenance of package ~a~%")
+ (manifest-entry-name entry)))
+ entry))
+ manifest))
+ identity))
+
+ (with-provenance
+ (cond
+ ((and (not (null? manifests)) (not (null? packages)))
+ (leave (G_ "both a manifest and a package list were given~%")))
+ ((not (null? manifests))
+ (concatenate-manifests
+ (map (lambda (file)
+ (let ((user-module (make-user-module
+ '((guix profiles) (gnu)))))
+ (load* file user-module)))
+ manifests)))
+ (else
+ (packages->manifest packages))))))
+
+ (define (process-file-arg opts name)
+ ;; Validate that the file exists and return it as a <local-file> object,
+ ;; else #f.
+ (let ((value (assoc-ref opts name)))
+ (match value
+ ((and (? string?) (not (? file-exists?)))
+ (leave (G_ "file provided with option ~a does not exist: ~a~%")
+ (string-append "--" (symbol->string name)) value))
+ ((? string?)
+ (local-file value))
+ (#f #f))))
+
(with-store store
(with-status-verbosity (assoc-ref opts 'verbosity)
;; Set the build options before we do anything else.
diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm
index a2836629ad..7708ce62a9 100644
--- a/guix/scripts/shell.scm
+++ b/guix/scripts/shell.scm
@@ -533,43 +533,44 @@ (define-command (guix-shell . args)
(category development)
(synopsis "spawn one-off software environments")
- (define (cache-entries directory)
- (filter-map (match-lambda
- ((or "." "..") #f)
- (file (string-append directory "/" file)))
- (or (scandir directory) '())))
-
- (define* (entry-expiration file)
- ;; Return the time at which FILE, a cached profile, is considered expired.
- (match (false-if-exception (lstat file))
- (#f 0) ;FILE may have been deleted in the meantime
- (st (+ (stat:atime st) (* 60 60 24 7)))))
-
- (define opts
- (parse-args args))
-
- (define interactive?
- (not (assoc-ref opts 'exec)))
-
- (if (assoc-ref opts 'check?)
- (record-hint 'shell-check)
- (when (and interactive?
- (not (hint-given? 'shell-check))
- (not (assoc-ref opts 'container?))
- (not (assoc-ref opts 'search-paths)))
- (display-hint (G_ "Consider passing the @option{--check} option once
+ (with-error-handling
+ (define (cache-entries directory)
+ (filter-map (match-lambda
+ ((or "." "..") #f)
+ (file (string-append directory "/" file)))
+ (or (scandir directory) '())))
+
+ (define* (entry-expiration file)
+ ;; Return the time at which FILE, a cached profile, is considered expired.
+ (match (false-if-exception (lstat file))
+ (#f 0) ;FILE may have been deleted in the meantime
+ (st (+ (stat:atime st) (* 60 60 24 7)))))
+
+ (define opts
+ (parse-args args))
+
+ (define interactive?
+ (not (assoc-ref opts 'exec)))
+
+ (if (assoc-ref opts 'check?)
+ (record-hint 'shell-check)
+ (when (and interactive?
+ (not (hint-given? 'shell-check))
+ (not (assoc-ref opts 'container?))
+ (not (assoc-ref opts 'search-paths)))
+ (display-hint (G_ "Consider passing the @option{--check} option once
to make sure your shell does not clobber environment variables."))) )
- ;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use
- ;; of cached profiles, and (2) cleanup actually happens, even when
- ;; 'guix-environment*' calls 'exit'.
- (add-hook! exit-hook
- (lambda _
- (maybe-remove-expired-cache-entries
- (%profile-cache-directory)
- cache-entries
- #:entry-expiration entry-expiration)))
-
- (if (assoc-ref opts 'export-manifest?)
- (export-manifest opts (current-output-port))
- (guix-environment* opts)))
+ ;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use
+ ;; of cached profiles, and (2) cleanup actually happens, even when
+ ;; 'guix-environment*' calls 'exit'.
+ (add-hook! exit-hook
+ (lambda _
+ (maybe-remove-expired-cache-entries
+ (%profile-cache-directory)
+ cache-entries
+ #:entry-expiration entry-expiration)))
+
+ (if (assoc-ref opts 'export-manifest?)
+ (export-manifest opts (current-output-port))
+ (guix-environment* opts))))
diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh
index f19a0f754e..6fc9e3723b 100644
--- a/tests/guix-pack.sh
+++ b/tests/guix-pack.sh
@@ -103,7 +103,7 @@ fi
guix pack --dry-run --bootstrap -f docker guile-bootstrap
# Build a Docker image with a symlink.
-guix pack --dry-run --bootstrap -f docker -S /opt/gnu=/ guile-bootstrap
+guix pack --dry-run --bootstrap -f docker -S /opt/gnu= guile-bootstrap
# Build a tarball pack of cross-compiled software. Use coreutils because
# guile-bootstrap is not intended to be cross-compiled.
diff --git a/tests/guix-shell.sh b/tests/guix-shell.sh
index 32dd997fe7..70dd852009 100644
--- a/tests/guix-shell.sh
+++ b/tests/guix-shell.sh
@@ -44,9 +44,13 @@ if has_container_support; then
--symlink=/usr/bin/guile=bin/guile -- \
/usr/bin/guile --version
- # A bad symlink spec causes the command to fail.
+ # An invalid symlink spec causes the command to fail.
! guix shell --bootstrap -CS bin/guile=/usr/bin/guile guile-bootstrap \
-- exit
+
+ # A dangling symlink causes the command to fail.
+ ! guix shell --bootstrap -CS /usr/bin/python=bin/python guile-bootstrap \
+ -- exit
fi
# '--ad-hoc' is a thing of the past.
--
2.37.3
^ permalink raw reply related [flat|nested] 37+ messages in thread