environment: Add ‘--writable-root’ and default to read-only root.

This is an incompatible change where the root file system in
‘guix shell -C’ is now read-only by default.

* guix/scripts/environment.scm (show-environment-options-help)
(%options): Add ‘--writable-root’.
* guix/scripts/environment.scm (setup-fhs): Invoke /sbin/ldconfig; moved
from…
(launch-environment): … here.
(launch-environment/container): Add #:writable-root? and pass it to
‘call-with-container’.  Move root file system setup to #:populate-file-system.
(guix-environment*): Honor ‘--writable-root’.
* tests/guix-environment-container.sh: Test it.
* doc/guix.texi (Invoking guix shell): Document ‘--writable-root’.
(Debugging Build Failures): Mention it before “rm /bin/sh”.

Change-Id: I2e8517d6f01eb8093160bffc0f9f56071ad6fee6
Reviewed-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>

3 files changed, 73 insertions, 43 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index c4207f91bc..889eab2ab3 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6481,6 +6481,10 @@ directory within the container.  If this is undesirable,
 be automatically shared and will change to the user's home directory
 within the container instead.  See also @option{--user}.
 
+@item --writable-root
+When using @option{--container}, this option makes the root file system
+writable (it is read-only by default).
+
 @item --expose=@var{source}[=@var{target}]
 @itemx --share=@var{source}[=@var{target}]
 For containers, @option{--expose} (resp. @option{--share}) exposes the
@@ -14125,7 +14129,8 @@ environment, with ungrafted packages (@pxref{Security Updates}, for more
 info on grafts).
 
 To get closer to a container like that used by the build daemon, we can
-remove @file{/bin/sh}:
+remove @file{/bin/sh} (you'll first need to pass the
+@option{--writable-root} option to @command{guix shell}):
 
 @example
 [env]# rm /bin/sh
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 5e86c52bae..e14bc95df7 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org>
-;;; Copyright © 2015-2024 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015-2025 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org>
 ;;; Copyright © 2022, 2023 John Kehayias <john.kehayias@protonmail.com>
 ;;;
@@ -120,6 +120,8 @@ shell'."
   (display (G_ "
       --no-cwd           do not share current working directory with an
                          isolated container"))
+  (display (G_ "
+      --writable-root    make the container's root file system writable"))
 
   (display (G_ "
       --share=SPEC       for containers, share writable host file system
@@ -261,6 +263,9 @@ use '--preserve' instead~%"))
          (option '("no-cwd") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'no-cwd? #t result)))
+         (option '("writable-root") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'writable-root? #t result)))
          (option '("share") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'file-system-mapping
@@ -483,7 +488,10 @@ providing a symlink for CC if GCC is in the container PROFILE, and writing
                   (newline port))
                 ;; /lib/nss is needed as Guix's nss puts libraries
                 ;; there rather than in the lib directory.
-                '("/lib" "/lib/nss")))))
+                '("/lib" "/lib/nss"))))
+
+  ;; Create /etc/ld.so.cache.
+  (invoke "/sbin/ldconfig" "-X"))
 
 (define (status->exit-code status)
   "Compute the exit code made from STATUS, a value as returned by 'waitpid',
@@ -527,8 +535,7 @@ cache."
            (setenv "PATH" (string-append "/bin:/usr/bin:/sbin:/usr/sbin"
                                          (if (getenv "PATH")
                                              (string-append ":" (getenv "PATH"))
-                                             "")))
-           (invoke "ldconfig" "-X"))
+                                             ""))))
          (apply execlp program program args))
        (lambda _
          ;; Report the error from here because the parent process cannot
@@ -735,6 +742,7 @@ regexps in WHITE-LIST."
 (define* (launch-environment/container #:key command bash user user-mappings
                                        profile manifest link-profile? network?
                                        map-cwd? emulate-fhs? nesting?
+                                       writable-root?
                                        (setup-hook #f)
                                        (symlinks '()) (white-list '()))
   "Run COMMAND within a container that features the software in PROFILE.
@@ -881,15 +889,9 @@ WHILE-LIST."
        (exit/status
         (call-with-container file-systems
           (lambda ()
-            ;; Setup global shell.
-            (mkdir-p "/bin")
-            (symlink bash "/bin/sh")
-
             ;; Set a reasonable default PS1.
             (setenv "PS1" "\\u@\\h \\w [env]\\$ ")
 
-            ;; Setup directory for temporary files.
-            (mkdir-p "/tmp")
             (for-each (lambda (var)
                         (setenv var "/tmp"))
                       ;; The same variables as in Nix's 'build.cc'.
@@ -899,9 +901,44 @@ WHILE-LIST."
             (setenv "LOGNAME" logname)
             (setenv "USER" logname)
 
+            (setenv "HOME" home-dir)
+
+            (unless network?
+              ;; Allow local AF_INET communications.
+              (set-network-interface-up "lo"))
+
+            ;; For convenience, start in the user's current working
+            ;; directory or, if unmapped, the home directory.
+            (chdir (if map-cwd?
+                       (override-user-dir user home cwd)
+                       home-dir))
+
+            ;; Set environment variables that match WHITE-LIST.
+            (for-each (match-lambda
+                        ((variable . value)
+                         (setenv variable value)))
+                      environ)
+
+            (primitive-exit/status
+             ;; A container's environment is already purified, so no need to
+             ;; request it be purified again.
+             (launch-environment command
+                                 (if link-profile?
+                                     (string-append home-dir "/.guix-profile")
+                                     profile)
+                                 manifest #:pure? #f
+                                 #:emulate-fhs? emulate-fhs?)))
+          #:populate-file-system
+          (lambda ()
+            ;; Setup global shell.
+            (mkdir-p "/bin")
+            (symlink bash "/bin/sh")
+
+            ;; Setup directory for temporary files.
+            (mkdir-p "/tmp")
+
             ;; Create a dummy home directory.
             (mkdir-p home-dir)
-            (setenv "HOME" home-dir)
 
             ;; Create symlinks.
             (let ((symlink->directives
@@ -912,10 +949,6 @@ WHILE-LIST."
               (for-each (cut evaluate-populate-directive <> ".")
                         (append-map symlink->directives symlinks)))
 
-            ;; Call an additional setup procedure, if provided.
-            (when setup-hook
-              (setup-hook profile))
-
             ;; If requested, link $GUIX_ENVIRONMENT to $HOME/.guix-profile;
             ;; this allows programs expecting that path to continue working as
             ;; expected within a container.
@@ -933,35 +966,14 @@ WHILE-LIST."
               ;; to resolve "localhost".
               (call-with-output-file "/etc/hosts"
                 (lambda (port)
-                  (display "127.0.0.1 localhost\n" port)))
+                  (display "127.0.0.1 localhost\n" port))))
 
-              ;; Allow local AF_INET communications.
-              (set-network-interface-up "lo"))
-
-            ;; For convenience, start in the user's current working
-            ;; directory or, if unmapped, the home directory.
-            (chdir (if map-cwd?
-                       (override-user-dir user home cwd)
-                       home-dir))
-
-            ;; Set environment variables that match WHITE-LIST.
-            (for-each (match-lambda
-                        ((variable . value)
-                         (setenv variable value)))
-                      environ)
-
-            (primitive-exit/status
-             ;; A container's environment is already purified, so no need to
-             ;; request it be purified again.
-             (launch-environment command
-                                 (if link-profile?
-                                     (string-append home-dir "/.guix-profile")
-                                     profile)
-                                 manifest #:pure? #f
-                                 #:emulate-fhs? emulate-fhs?)))
+            ;; Call an additional setup procedure, if provided.
+            (when setup-hook
+              (setup-hook profile)))
           #:guest-uid uid
           #:guest-gid gid
-          #:writable-root? #t                     ;for backward compatibility
+          #:writable-root? writable-root?
           #:namespaces (if network?
                            (delq 'net %namespaces) ; share host network
                            %namespaces)))))))
@@ -1089,6 +1101,7 @@ command-line option processing with 'parse-command-line'."
          (symlinks     (assoc-ref opts 'symlinks))
          (network?     (assoc-ref opts 'network?))
          (no-cwd?      (assoc-ref opts 'no-cwd?))
+         (writable-root? (assoc-ref opts 'writable-root?))
          (emulate-fhs? (assoc-ref opts 'emulate-fhs?))
          (nesting?     (assoc-ref opts 'nesting?))
          (user         (assoc-ref opts 'user))
@@ -1136,6 +1149,8 @@ command-line option processing with 'parse-command-line'."
         (leave (G_ "'--user' cannot be used without '--container'~%")))
       (when no-cwd?
         (leave (G_ "--no-cwd cannot be used without '--container'~%")))
+      (when writable-root?
+        (leave (G_ "'--writable-root' cannot be used without '--container'~%")))
       (when emulate-fhs?
         (leave (G_ "'--emulate-fhs' cannot be used without '--container'~%")))
       (when nesting?
@@ -1221,6 +1236,7 @@ when using '--container'; doing nothing~%"))
                                                   #:link-profile? link-prof?
                                                   #:network? network?
                                                   #:map-cwd? (not no-cwd?)
+                                                  #:writable-root? writable-root?
                                                   #:emulate-fhs? emulate-fhs?
                                                   #:nesting? nesting?
                                                   #:symlinks symlinks
diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh
index 09704f751c..d6cb382de9 100644
--- a/tests/guix-environment-container.sh
+++ b/tests/guix-environment-container.sh
@@ -1,7 +1,7 @@
 # GNU Guix --- Functional package management for GNU
 # Copyright © 2015 David Thompson <davet@gnu.org>
 # Copyright © 2022, 2023 John Kehayias <john.kehayias@protonmail.com>
-# Copyright © 2023 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2023, 2025 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -186,6 +186,15 @@ HOME="$tmpdir" guix environment --bootstrap --container --user=foognu \
             -- /bin/sh -c 'test $(pwd) == "/home/foo" -a ! -d '"$tmpdir"
 )
 
+# Check that the root file system is read-only by default...
+guix environment --bootstrap --container --ad-hoc guile-bootstrap \
+     -- guile -c '(mkdir "/whatever")' && false
+
+# ... and can be made writable.
+guix environment --bootstrap --container --ad-hoc guile-bootstrap	\
+     --writable-root							\
+     -- guile -c '(mkdir "/whatever")'
+
 # Check the exit code.
 
 abnormal_exit_code="