[bug#56677] [PATCH 2/2 v2] environment: Add '--emulate-fhs'.

[John Kehayias via Guix-patches via <guix-patches@gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 913 bytes --]

Here is a tiny update to this patch; I noticed after I sent it originally that there was a formatting typo in the guix.texi changes. Update attached.

Has anyone had a chance to try out the patch or take a look at it?

I do use this in some daily work, for a project that uses Python's poetry shell and the Playwright libraries (uses browser binaries it downloads to do web automation). Here is the command I use, where since I need to use browsers in the container just getting the development inputs for ungoogled-chromium is a nice shortcut. The share/expose is to get all graphical/hardware acceleration working.

~/path/to/guix-source/pre-inst-env guix shell -C -F -N poetry coreutils gcc:lib -D ungoogled-chromium --share=$HOME/temphome=$HOME --preserve='^DISPLAY$' --preserve='^XAUTHORITY$' --share=$XAUTHORITY -- "poetry shell"

All works great and is very handy for doing this on my Guix machine.

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0002-environment-Add-emulate-fhs.patch --]
[-- Type: text/x-patch; name=0002-environment-Add-emulate-fhs.patch, Size: 16470 bytes --]

From 6b5e3931bb83d589ff47263cc3bfd5eb236a3954 Mon Sep 17 00:00:00 2001
From: John Kehayias <john.kehayias@protonmail.com>
Date: Wed, 20 Jul 2022 23:46:45 -0400
Subject: [PATCH] environment: Add '--emulate-fhs'.

* guix/scripts/environment.scm (show-environment-options-help)
(%options): Add '--emulate-fhs'.
* guix/scripts/environment.scm (launch-environment/container): Add
'emulate-fhs?'  key and implement it.  Define and use FHS-MAPPINGS,
FHS-SYMLINKS, and LINK-CONTENTS to set up the container to follow the
Filesystem Hierarchy Standard (FHS) for /bin, /etc, and /usr.  Generate
/etc/ld.so.cache in the container from /etc/ld.so.conf by running the script
/tmp/fhs.sh to launch the container.
(guix-environment*): Add glibc-for-fhs to the container packages when
'emulate-fhs?' key is in OPTS.
* doc/guix.texi (Invoking guix shell): Document '--emulate-fhs'.
(Invoking guix environment): Document '--emulate-fhs'.
---
 doc/guix.texi                |  33 ++++++++
 guix/scripts/environment.scm | 157 ++++++++++++++++++++++++++++++-----
 2 files changed, 168 insertions(+), 22 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 3c5864ec1a..03a65f26f4 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -106,6 +106,7 @@
 Copyright @copyright{} 2022 Karl Hallsby@*
 Copyright @copyright{} 2022 Justin Veilleux@*
 Copyright @copyright{} 2022 Reily Siegel@*
+Copyright @copyright{} 2022 John Kehayias@*
 
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or
@@ -6155,6 +6156,22 @@ Invoking guix shell
 guix shell --container --expose=$HOME=/exchange guile -- guile
 @end example
 
+@item --emulate-fhs
+@item -F
+For containers, emulate a Filesystem Hierarchy Standard (FHS)
+configuration within the container, see
+@uref{https://refspecs.linuxfoundation.org/fhs.shtml, the official
+specification}.  As Guix deviates from the FHS specification, this
+option sets up the container to more closely mimic that of other
+GNU/Linux distributions.  This is useful for reproducing other
+development environments, testing, and using programs which expect the
+FHS specification to be followed.  With this option, the container will
+include a version of @code{glibc} which will read
+@code{/etc/ld.so.cache} within the container for the shared library
+cache (contrary to @code{glibc} in regular Guix usage) and set up the
+expected FHS directories: @code{/bin}, @code{/etc}, @code{/lib}, and
+@code{/usr} from the container's profile.
+
 @item --rebuild-cache
 @cindex caching, of profiles
 @cindex caching, in @command{guix shell}
@@ -6572,6 +6589,22 @@ Invoking guix environment
 guix environment --container --expose=$HOME=/exchange --ad-hoc guile -- guile
 @end example
 
+@item --emulate-fhs
+@item -F
+For containers, emulate a Filesystem Hierarchy Standard (FHS)
+configuration within the container, see
+@uref{https://refspecs.linuxfoundation.org/fhs.shtml, the official
+specification}.  As Guix deviates from the FHS specification, this
+option sets up the container to more closely mimic that of other
+GNU/Linux distributions.  This is useful for reproducing other
+development environments, testing, and using programs which expect the
+FHS specification to be followed.  With this option, the container will
+include a version of @code{glibc} which will read
+@code{/etc/ld.so.cache} within the container for the shared library
+cache (contrary to @code{glibc} in regular Guix usage) and set up the
+expected FHS directories: @code{/bin}, @code{/etc}, @code{/lib}, and
+@code{/usr} from the container's profile.
+
 @end table
 
 @command{guix environment}
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 3216235937..c80f5f28af 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org>
+;;; Copyright © 2022 John Kehayias <john.kehayias@protonmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -120,6 +121,9 @@ (define (show-environment-options-help)
       --expose=SPEC      for containers, expose read-only host file system
                          according to SPEC"))
   (display (G_ "
+  -F, --emulate-fhs      for containers, emulate the Filesystem Hierarchy
+                         Standard (FHS)"))
+  (display (G_ "
   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
   (display (G_ "
       --bootstrap        use bootstrap binaries to build the environment")))
@@ -256,6 +260,9 @@ (define %options
                    (alist-cons 'file-system-mapping
                                (specification->file-system-mapping arg #f)
                                result)))
+         (option '(#\F "emulate-fhs") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'emulate-fhs? #t result)))
          (option '(#\r "root") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'gc-root arg result)))
@@ -608,16 +615,18 @@ (define* (launch-environment/fork command profile manifest
 
 (define* (launch-environment/container #:key command bash user user-mappings
                                        profile manifest link-profile? network?
-                                       map-cwd? (white-list '()))
+                                       map-cwd? emulate-fhs? (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 NETWORK?, access to the host system network is permitted.
-USER-MAPPINGS, a list of file system mappings, contains the user-specified
-host file systems to mount inside the container.  If USER is not #f, each
-target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER
-will be used for the passwd entry.  LINK-PROFILE? creates a symbolic link from
-~/.guix-profile to the environment 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
+NETWORK?, access to the host system network is permitted.  USER-MAPPINGS, a
+list of file system mappings, contains the user-specified host file systems to
+mount inside the container.  If USER is not #f, each target of USER-MAPPINGS
+will be re-written relative to '/home/USER', and USER will be used for the
+passwd entry.  When EMULATE-FHS?, set up the container to follow the
+Filesystem Hierarchy Standard and provide a glibc that reads the cache from
+/etc/ld.so.cache.  LINK-PROFILE? creates a symbolic link from ~/.guix-profile
+to the environment profile.
 
 Preserve environment variables whose name matches the one of the regexps in
 WHILE-LIST."
@@ -625,6 +634,40 @@ (define* (launch-environment/container #:key command bash user user-mappings
     (and (file-exists? (file-system-mapping-source mapping))
          (file-system-mapping->bind-mount mapping)))
 
+  ;; File system mappings for an FHS container, where the entire directory can
+  ;; be mapped.  Others (bin and etc) will already have contents and need to
+  ;; use LINK-CONTENTS to symlink the directory contents.
+  (define fhs-mappings
+    (map (lambda (mapping)
+           (file-system-mapping
+            (source (string-append profile (car mapping)))
+            (target (cdr mapping))))
+         '(("/lib"     . "/lib")
+           ("/include" . "/usr/include")
+           ("/sbin"    . "/sbin")
+           ("/libexec" . "/usr/libexec")
+           ("/share"   . "/usr/share"))))
+
+  ;; Additional symlinks for an FHS container.
+  (define fhs-symlinks
+    `(("/lib" . "/usr/lib")
+      ,(if (target-64bit?)
+           '("/lib" . "/lib64")
+           '("/lib" . "/lib32"))
+      ("/bin" . "/usr/bin")
+      ("/sbin" . "/usr/sbin")))
+
+  ;; A procedure to symlink the contents (at the top level) of a directory,
+  ;; excluding the directory itself and parent, along with any others provided
+  ;; in EXCLUDE.
+  (define* (link-contents dir #:key (exclude '()))
+    (for-each (lambda (file)
+                (symlink (string-append profile dir "/" file)
+                         (string-append dir "/" file)))
+              (scandir (string-append profile dir)
+                       (negate (cut member <>
+                                    (append exclude '("." ".." )))))))
+
   (define (exit/status* status)
     (exit/status (validate-exit-status profile command status)))
 
@@ -682,6 +725,11 @@ (define* (launch-environment/container #:key command bash user user-mappings
                                       (filter-map optional-mapping->fs
                                                   %network-file-mappings)
                                       '())
+                                  ;; Mappings for an FHS container.
+                                  (if emulate-fhs?
+                                      (filter-map optional-mapping->fs
+                                                  fhs-mappings)
+                                      '())
                                   (map file-system-mapping->bind-mount
                                        mappings))))
        (exit/status*
@@ -709,6 +757,54 @@ (define* (launch-environment/container #:key command bash user user-mappings
             (mkdir-p home-dir)
             (setenv "HOME" home-dir)
 
+            ;; Set up an FHS container.
+            (when emulate-fhs?
+              ;; The FHS container sets up the expected filesystem through
+              ;; MAPPINGS with FHS-MAPPINGS above, the symlinks through
+              ;; FHS-SYMLINKS, and linking the contents of profile/bin and
+              ;; profile/etc using LINK-CONTENTS, as these both have or will
+              ;; have contents for a non-FHS container so must be handled
+              ;; separately.
+              (mkdir-p "/usr")
+              (for-each (lambda (link)
+                          (if (file-exists? (car link))
+                              (symlink (car link) (cdr link))))
+                        fhs-symlinks)
+              (link-contents "/bin" #:exclude '("sh"))
+              (mkdir-p "/etc")
+              (link-contents "/etc")
+
+              ;; Provide a frequently expected 'cc' symlink to gcc (in case it
+              ;; is in the container), though this could also be done by the
+              ;; user in the container, e.g. in $HOME/.local/bin and adding
+              ;; that to $PATH.  Note: we do this in /bin since that already
+              ;; has the sh symlink and the other (optional) FHS bin
+              ;; directories will link to /bin.
+              (symlink (string-append profile "/bin/gcc") "/bin/cc")
+
+              ;; Guix's ldconfig doesn't seem to search in FHS default
+              ;; locations, so provide a minimal ld.so.conf.
+              (call-with-output-file "/etc/ld.so.conf"
+                (lambda (port)
+                  (for-each (lambda (directory)
+                              (display directory port)
+                              (newline port))
+                            ;; /lib/nss is needed as Guix's nss puts libraries
+                            ;; there rather than in the lib directory.
+                            '("/lib" "/lib/nss"))))
+
+              ;; Define an entry script to start the container: generate
+              ;; ld.so.cache, supplement $PATH (optional, but to better match
+              ;; FHS expectations), and include COMMAND.
+              (call-with-output-file "/tmp/fhs.sh"
+                (lambda (port)
+                  (display "ldconfig -X" port)
+                  (newline port)
+                  (display "export PATH=/bin:/usr/bin:/sbin:/usr/sbin:$PATH" port)
+                  (newline port)
+                  (display (car command) port)
+                  (newline port))))
+
             ;; If requested, link $GUIX_ENVIRONMENT to $HOME/.guix-profile;
             ;; this allows programs expecting that path to continue working as
             ;; expected within a container.
@@ -746,7 +842,10 @@ (define* (launch-environment/container #:key command bash user user-mappings
             (primitive-exit/status
              ;; A container's environment is already purified, so no need to
              ;; request it be purified again.
-             (launch-environment command
+             (launch-environment (if emulate-fhs?
+                                     ;; Use the FHS start script.
+                                     '("/bin/sh" "/tmp/fhs.sh")
+                                     command)
                                  (if link-profile?
                                      (string-append home-dir "/.guix-profile")
                                      profile)
@@ -874,16 +973,17 @@ (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?))
-           (network?   (assoc-ref opts 'network?))
-           (no-cwd?    (assoc-ref opts 'no-cwd?))
-           (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)
+    (let* ((pure?        (assoc-ref opts 'pure))
+           (container?   (assoc-ref opts 'container?))
+           (link-prof?   (assoc-ref opts 'link-profile?))
+           (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?
@@ -922,12 +1022,24 @@ (define (guix-environment* opts)
         (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~'%")))
 
 
       (with-store/maybe store
         (with-status-verbosity (assoc-ref opts 'verbosity)
           (define manifest-from-opts
-            (options/resolve-packages store opts))
+            (options/resolve-packages store
+                                      ;; For an FHS-container, add the
+                                      ;; (hidden) package glibc-for-fhs which
+                                      ;; uses the global cache at
+                                      ;; /etc/ld.so.cache.
+                                      (if emulate-fhs?
+                                          (alist-cons 'expression
+                                                      '(ad-hoc-package
+                                                        "(@@ (gnu packages base) glibc-for-fhs)")
+                                                      opts)
+                                          opts)))
 
           (define manifest
             (if profile
@@ -1001,7 +1113,8 @@ (define (guix-environment* opts)
                                                     #:white-list white-list
                                                     #:link-profile? link-prof?
                                                     #:network? network?
-                                                    #:map-cwd? (not no-cwd?))))
+                                                    #:map-cwd? (not no-cwd?)
+                                                    #:emulate-fhs? emulate-fhs?)))
 
                    (else
                     (return
-- 
2.37.1