[bug#62411] [PATCH] environment: Add '--nesting'.

[Ludovic Courtès]

From: Ludovic Courtès <ludovic.courtes@inria.fr>

* guix/scripts/environment.scm (show-environment-options-help)
(%options): Add '--nesting'.
(options/resolve-packages): Handle it.
(launch-environment/container): Add #:nesting? and honor it.
[nesting-mappings]: New procedure.
(guix-environment*): Add support for '--nesting'.
* guix/scripts/shell.scm (profile-cached-gc-root): Special-case
'nesting?'.
* tests/guix-environment-container.sh: Test it.
* doc/guix.texi (Invoking guix shell): Document it.
---
 doc/guix.texi                       | 41 ++++++++++++++++++
 guix/scripts/environment.scm        | 66 +++++++++++++++++++++++++++--
 guix/scripts/shell.scm              |  2 +
 tests/guix-environment-container.sh |  9 ++++
 4 files changed, 114 insertions(+), 4 deletions(-)

Hi there!

Recently, Konrad came up with a concrete use case for “nested”
‘guix shell’ containers:

  https://lists.gnu.org/archive/html/guix-devel/2023-02/msg00027.html

Setting up nested containers was doable but tedious and brittle,
so a better option seemed to offer support for that:

  https://lists.gnu.org/archive/html/guix-devel/2023-02/msg00275.html

This is what this patch does with the new ‘--nesting’ or ‘-W’ option.
Here’s a somewhat extreme example using ‘guix shell’ with this patch
to create a container, inside which we run ‘guix time-machine’:

--8<---------------cut here---------------start------------->8---
$ guix time-machine --url=$HOME/src/guix --branch=wip-shell-nested-containers \
    -- shell -CWN coreutils nss-certs \
    -- guix time-machine -- describe
  guix 086f27c
    repository URL: https://git.savannah.gnu.org/git/guix.git
    branch: master
    commit: 086f27cf8cb4198d15d7d65c8703d50b58ab3c03
--8<---------------cut here---------------end--------------->8---

Creating a container with only ‘coreutils’ and ‘guix’, and within which
we create another container with nothing but ‘coreutils-minimal’:

--8<---------------cut here---------------start------------->8---
$ guix time-machine --url=$HOME/src/guix --branch=wip-shell-nested-containers \
     -- shell -CW coreutils \
     -- guix shell -C coreutils-minimal \
     -- ls -l /gnu/store
total 40
dr-xr-xr-x  5 65534 overflow 4096 Jan  1  1970 
094bbaq6glba86h1d4cj16xhdi6fk2jl-gcc-10.3.0-lib
dr-xr-xr-x 10 65534 overflow 4096 Jan  1  1970 
5h2w4qi9hk1qzzgi1w83220ydslinr4s-glibc-2.33
dr-xr-xr-x  4 65534 overflow 4096 Jan  1  1970 
720rj90bch716isd8z7lcwrnvz28ap4y-bash-static-5.1.8
dr-xr-xr-x  7 65534 overflow 4096 Jan  1  1970 
9rrnm5hdjw7cy96a2a9rfgh6y08wsbmf-ncurses-6.2.20210619
dr-xr-xr-x  6 65534 overflow 4096 Jan  1  1970 
d99ykvj3axzzidygsmdmzxah4lvxd6hw-bash-5.1.8
dr-xr-xr-x  3 65534 overflow 4096 Jan  1  1970 
ifscrw9mbn79lyq4ac91yb973n7v94ww-emacs-subdirs
dr-xr-xr-x  4 65534 overflow 4096 Jan  1  1970 
lk9ihkbmbl372nq5xya691qfmgmyy7l5-profile
dr-xr-xr-x  3 65534 overflow 4096 Jan  1  1970 
phkd1186xafw1yy7s3jv353p4vbinmmq-info-dir
dr-xr-xr-x  6 65534 overflow 4096 Jan  1  1970 
vqdsrvs9jbn0ix2a58s99jwkh74124y5-coreutils-minimal-8.32
dr-xr-xr-x  6 65534 overflow 4096 Jan  1  1970 
wcwls45278gzpjvwlvrrs1y7h30g44xh-readline-8.1.1
--8<---------------cut here---------------end--------------->8---

Well, you get the idea.

Notice that the current Guix is automatically added to the container:

--8<---------------cut here---------------start------------->8---
$ guix time-machine --url=$HOME/src/guix --branch=wip-shell-nested-containers \
     -- describe
  guix a67dda7
    repository URL: /home/ludo/src/guix
    branch: wip-shell-nested-containers
    commit: a67dda77290b6fdca53fcfa50ab7382e62090932
$ guix time-machine --url=$HOME/src/guix --branch=wip-shell-nested-containers \
     -- shell -CW coreutils \
     -- guix describe
  guix a67dda7
    repository URL: /home/ludo/src/guix
    branch: wip-shell-nested-containers
    commit: a67dda77290b6fdca53fcfa50ab7382e62090932
--8<---------------cut here---------------end--------------->8---

Furthermore, ~/.cache/guix is shared with the host as noted in
the manual.

Thoughts?

Ludo’.

diff --git a/doc/guix.texi b/doc/guix.texi
index fa1f46c2b1..739ab45570 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6337,6 +6337,47 @@ cache (contrary to glibc in regular Guix usage) and set 
up the
 expected FHS directories: @file{/bin}, @file{/etc}, @file{/lib}, and
 @file{/usr} from the container's profile.
 
+@cindex nested containers, for @command{guix shell}
+@cindex container nesting, for @command{guix shell}
+@item --nesting
+@itemx -W
+When used with @option{--container}, provide Guix @emph{inside} the
+container and arrange so that it can interact with the build daemon that
+runs outside the container.  This is useful if you want, within your
+isolated container, to create other containers, as in this sample
+session:
+
+@example
+$ guix shell -CW coreutils
+[env]$ guix shell -C guile -- guile -c '(display "hello!\n")'
+hello!
+[env]$ exit
+@end example
+
+The session above starts a container with @code{coreutils} programs
+available in @env{PATH}.  From there, we spawn @command{guix shell} to
+create a @emph{nested} container that provides nothing but Guile.
+
+Under the hood, this option does several things:
+
+@itemize
+@item
+map the daemon's socket (by default
+@file{/var/guix/daemon-socket/socket}) inside the container;
+@item
+map the whole store (by default @file{/gnu/store}) inside the container
+such that store items made available by nested @command{guix}
+invocations are visible;
+@item
+add the currently-used @command{guix} command to the profile in the
+container, such that @command{guix describe} returns the same state
+inside and outside the container;
+@item
+share the cache (by default @file{~/.cache/guix}) with the host, to
+speed up operations such as @command{guix time-machine} and
+@command{guix shell}.
+@end itemize
+
 @item --rebuild-cache
 @cindex caching, of profiles
 @cindex caching, in @command{guix shell}
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index a4939ea63c..ebfc05731c 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -31,6 +31,8 @@ (define-module (guix scripts environment)
   #:use-module (guix build utils)
   #:use-module (guix monads)
   #:use-module ((guix gexp) #:select (lower-object))
+  #:autoload   (guix describe) (current-profile current-channels)
+  #:autoload   (guix channels) (guix-channel? channel-commit)
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
   #:autoload   (guix scripts pack) (symlink-spec-option-parser)
@@ -49,9 +51,11 @@ (define-module (guix scripts environment)
   #:autoload   (gnu packages) (specification->package+output)
   #:autoload   (gnu packages bash) (bash)
   #:autoload   (gnu packages bootstrap) (bootstrap-executable %bootstrap-guile)
+  #:autoload   (gnu packages package-management) (guix)
   #:use-module (ice-9 match)
   #:autoload   (ice-9 rdelim) (read-line)
   #:use-module (ice-9 vlist)
+  #:autoload   (web uri) (string->uri uri-scheme)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -108,6 +112,8 @@ (define (show-environment-options-help)
   -P, --link-profile     link environment profile to ~/.guix-profile within
                          an isolated container"))
   (display (G_ "
+  -W, --nesting          make Guix available within the container"))
+  (display (G_ "
   -u, --user=USER        instead of copying the name and home of the current
                          user into an isolated container, use the name USER
                          with home directory /home/USER"))
@@ -238,6 +244,9 @@ (define %options
          (option '(#\N "network") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'network? #t result)))
+         (option '(#\W "nesting") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'nesting? #t result)))
          (option '(#\P "link-profile") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'link-profile? #t result)))
@@ -342,6 +351,26 @@ (define (packages->outputs packages mode)
                      (packages->outputs (load* file module) mode)))
                   (('manifest . file)
                    (manifest-entries (load-manifest file)))
+                  (('nesting? . #t)
+                   (if (assoc-ref opts 'profile)
+                       '()
+                       (let ((profile (and=> (current-profile) readlink*)))
+                         (if (or (not profile) (not (store-path? profile)))
+                             (begin
+                               (warning (G_ "\
+could not add current Guix to the profile~%"))
+                               '())
+                             (list (manifest-entry
+                                     (name "guix")
+                                     (version
+                                      (or (any (lambda (channel)
+                                                 (and (guix-channel? channel)
+                                                      (channel-commit 
channel)))
+                                               (current-channels))
+                                          "0"))
+                                     (item profile)
+                                     (search-paths
+                                      (package-native-search-paths guix))))))))
                   (_ '()))
                 opts)
     manifest-entry=?)))
@@ -688,7 +717,8 @@ (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)
+                                       map-cwd? emulate-fhs? nesting?
+                                       (setup-hook #f)
                                        (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
@@ -704,6 +734,9 @@ (define* (launch-environment/container #:key command bash 
user user-mappings
 SETUP-HOOK is an additional setup procedure to be called, currently only used
 with the EMULATE-FHS? option.
 
+When NESTING? is true, share all the store with the container and add Guix to
+its profile, allowing its use from within the container.
+
 LINK-PROFILE? creates a symbolic link from ~/.guix-profile to the
 environment profile.
 
@@ -731,8 +764,26 @@ (define fhs-mappings
            ("/libexec" . "/usr/libexec")
            ("/share"   . "/usr/share"))))
 
-  (mlet %store-monad ((reqs (inputs->requisites
-                             (list (direct-store-path bash) profile))))
+  (define (nesting-mappings)
+    ;; Files shared with the host when enabling nesting.
+    (cons* (file-system-mapping
+            (source (%store-prefix))
+            (target source))
+           (file-system-mapping
+            (source (cache-directory))
+            (target source)
+            (writable? #t))
+           (let ((uri (string->uri (%daemon-socket-uri))))
+             (if (or (not uri) (eq? 'file (uri-scheme uri)))
+                 (list (file-system-mapping
+                        (source (%daemon-socket-uri))
+                        (target source)))
+                 '()))))
+
+  (mlet %store-monad ((reqs (if nesting?
+                                (return '())
+                                (inputs->requisites
+                                 (list (direct-store-path bash) profile)))))
     (return
      (let* ((cwd      (getcwd))
             (home     (getenv "HOME"))
@@ -795,11 +846,14 @@ (define fhs-mappings
                                       (filter-map optional-mapping->fs
                                                   %network-file-mappings)
                                       '())
-                                  ;; Mappings for an FHS container.
                                   (if emulate-fhs?
                                       (filter-map optional-mapping->fs
                                                   fhs-mappings)
                                       '())
+                                  (if nesting?
+                                      (filter-map optional-mapping->fs
+                                                  (nesting-mappings))
+                                      '())
                                   (map file-system-mapping->bind-mount
                                        mappings))))
        (exit/status
@@ -1013,6 +1067,7 @@ (define (guix-environment* opts)
          (network?     (assoc-ref opts 'network?))
          (no-cwd?      (assoc-ref opts 'no-cwd?))
          (emulate-fhs? (assoc-ref opts 'emulate-fhs?))
+         (nesting?     (assoc-ref opts 'nesting?))
          (user         (assoc-ref opts 'user))
          (bootstrap?   (assoc-ref opts 'bootstrap?))
          (system       (assoc-ref opts 'system))
@@ -1059,6 +1114,8 @@ (define-syntax-rule (with-store/maybe store exp ...)
         (leave (G_ "--no-cwd cannot be used without '--container'~%")))
       (when emulate-fhs?
         (leave (G_ "'--emulate-fhs' cannot be used without '--container~%'")))
+      (when nesting?
+        (leave (G_ "'--nesting' cannot be used without '--container~%'")))
       (when (pair? symlinks)
         (leave (G_ "'--symlink' cannot be used without '--container~%'"))))
 
@@ -1141,6 +1198,7 @@ (define manifest
                                                   #:network? network?
                                                   #:map-cwd? (not no-cwd?)
                                                   #:emulate-fhs? emulate-fhs?
+                                                  #:nesting? nesting?
                                                   #:symlinks symlinks
                                                   #:setup-hook
                                                   (and emulate-fhs?
diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm
index 92bbfb04d0..1b42cc2af0 100644
--- a/guix/scripts/shell.scm
+++ b/guix/scripts/shell.scm
@@ -389,6 +389,8 @@ (define (key->file key)
        (if (not file)
            (loop rest system file (cons spec specs))
            (values #f #f)))
+      ((('nesting? . #t) . rest)
+       (loop rest system file (append specs '("nested guix"))))
       ((('load . ('package candidate)) . rest)
        (if (and (not file) (null? specs))
            (loop rest system candidate specs)
diff --git a/tests/guix-environment-container.sh 
b/tests/guix-environment-container.sh
index 0475405a89..a30d6b7fb2 100644
--- a/tests/guix-environment-container.sh
+++ b/tests/guix-environment-container.sh
@@ -264,3 +264,12 @@ guix shell --bootstrap guile-bootstrap --container \
 
 # An invalid symlink spec causes the command to fail.
 ! guix shell --bootstrap -CS bin/guile=/usr/bin/guile guile-bootstrap -- exit
+
+# Check whether '--nesting' works.
+guix build hello -d
+env="$(type -P pre-inst-env)"
+if guix shell -C -D guix -- "$env" guix build hello -d # cannot work
+then false; else true; fi
+hello_drv="$(guix build hello -d)"
+hello_drv_nested="$(cd "$(dirname env)" && guix shell --bootstrap -CW -D guix 
-- "$env" guix build hello -d)"
+test "$hello_drv" = "$hello_drv_nested"

base-commit: 2120c768f2366c92d72d15e4044a81c31e57688b
-- 
2.39.2