[bug#54377] [PATCH 3/3] guix home: Add 'container' command.

[Ludovic Courtès]

* guix/scripts/home.scm (show-help, %options): Add '--network',
'--share', and '--expose'.
(not-config?, user-shell, spawn-home-container): New procedures.
(%default-system-profile): New variable.
(perform-action): Add #:file-system-mappings, #:container-command,
and #:network?; honor them.
(process-action): Adjust accordingly.
(guix-home)[parse-sub-command]: Add "container".
[parse-args]: New procedure.
Use it instead of 'parse-command-line'.
* tests/guix-home.sh: Add tests.
* doc/guix.texi (Declaring the Home Environment): Mention 'guix home
container' as a way to test configuration.
(Invoking guix home): Document it.
---
 doc/guix.texi         |  58 +++++++++
 guix/scripts/home.scm | 271 ++++++++++++++++++++++++++++++++++++++----
 tests/guix-home.sh    |  58 ++++++---
 3 files changed, 349 insertions(+), 38 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 4b71fb7010..ba9199f336 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -38071,6 +38071,21 @@ be confused with Shepherd services (@pxref{Shepherd 
Services}).  Using this exte
 mechanism and some Scheme code that glues things together gives the user
 the freedom to declare their own, very custom, home environments.
 
+@cindex container, for @command{guix home}
+Once the configuration looks good, you can first test it in a throw-away
+``container'':
+
+@example
+guix home container config.scm
+@end example
+
+The command above spawns a shell where your home environment is running.
+The shell runs in a container, meaning it's isolated from the rest of
+the system, so it's a good way to try out your configuration---you can
+see if configuration bits are missing or misbehaving, if daemons get
+started, and so on.  Once you exit that shell, you're back to the prompt
+of your original shell ``in the real world''.
+
 Once you have a configuration file that suits your needs, you can
 reconfigure your home by running:
 
@@ -38699,6 +38714,49 @@ As for @command{guix search}, the result is written in
 @code{recutils} format, which makes it easy to filter the output
 (@pxref{Top, GNU recutils databases,, recutils, GNU recutils manual}).
 
+@cindex container, for @command{guix home}
+@item container
+Spawn a shell in an isolated environment---a
+@dfn{container}---containing your home as specified by @var{file}.
+
+For example, this is how you would start an interactive shell in a
+container with your home:
+
+@example
+guix home container config.scm
+@end example
+
+This is a throw-away container where you can lightheartedly fiddle with
+files; any changes made within the container, any process started---all
+this disappears as soon as you exit that shell.
+
+As with @command{guix shell}, several options control that container:
+
+@table @option
+@item --network
+@itemx -N
+Enable networking within the container (it is disabled by default).
+
+@item --expose=@var{source}[=@var{target}]
+@itemx --share=@var{source}[=@var{target}]
+As with @command{guix shell}, make directory @var{source} of the host
+system available as @var{target} inside the container---read-only if you
+pass @option{--expose}, and writable if you pass @option{--share}
+(@pxref{Invoking guix shell, @option{--expose} and @option{--share}}).
+@end table
+
+Additionally, you can run a command in that container, instead of
+spawning an interactive shell.  For instance, here is how you would
+check which Shepherd services are started in a throw-away home
+container:
+
+@example
+guix home container config.scm -- herd status
+@end example
+
+The command to run in the container must come after @code{--} (double
+hyphen).
+
 @item reconfigure
 Build the home environment described in @var{file}, and switch to it.
 Switching means that the activation script will be evaluated and (in
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index 837fd96361..b422cd36e2 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -23,8 +23,21 @@ (define-module (guix scripts home)
   #:use-module (gnu packages admin)
   #:use-module ((gnu services) #:hide (delete))
   #:use-module (gnu packages)
+  #:autoload   (gnu packages base) (coreutils)
+  #:autoload   (gnu packages bash) (bash)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
+  #:autoload   (gnu packages shells) (fish gash zsh)
   #:use-module (gnu home)
   #:use-module (gnu home services)
+  #:autoload   (guix modules) (source-module-closure)
+  #:autoload   (gnu build linux-container) (call-with-container %namespaces)
+  #:autoload   (gnu system linux-container) (eval/container)
+  #:autoload   (gnu system file-systems) (file-system-mapping
+                                          file-system-mapping-source
+                                          file-system-mapping->bind-mount
+                                          specification->file-system-mapping
+                                          %network-file-mappings)
+  #:autoload   (guix self) (make-config.scm)
   #:use-module (guix channels)
   #:use-module (guix derivations)
   #:use-module (guix ui)
@@ -48,6 +61,7 @@ (define-module (guix scripts home)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
+  #:use-module (srfi srfi-71)
   #:use-module (ice-9 match)
   #:export (guix-home))
 
@@ -95,6 +109,16 @@ (define (show-help)
   (display (G_ "
       --allow-downgrades for 'reconfigure', allow downgrades to earlier
                          channel revisions"))
+  (newline)
+  (display (G_ "
+  -N, --network          allow containers to access the network"))
+  (display (G_ "
+      --share=SPEC       for containers, share writable host file system
+                         according to SPEC"))
+  (display (G_ "
+      --expose=SPEC      for containers, expose read-only host file system
+                         according to SPEC"))
+  (newline)
   (display (G_ "
   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
   (newline)
@@ -136,6 +160,22 @@ (define %options
                    (alist-cons 'validate-reconfigure
                                warn-about-backward-reconfigure
                                result)))
+
+         ;; Container options.
+         (option '(#\N "network") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'network? #t result)))
+         (option '("share") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'file-system-mapping
+                               (specification->file-system-mapping arg #t)
+                               result)))
+         (option '("expose") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'file-system-mapping
+                               (specification->file-system-mapping arg #f)
+                               result)))
+
          %standard-build-options))
 
 (define %default-options
@@ -149,6 +189,146 @@ (define %default-options
     (debug . 0)
     (validate-reconfigure . ,ensure-forward-reconfigure)))
 
+
+;;;
+;;; Container.
+;;;
+
+(define not-config?
+  ;; Select (guix …) and (gnu …) modules, except (guix config).
+  (match-lambda
+    (('guix 'config) #f)
+    (('guix _ ...) #t)
+    (('gnu _ ...) #t)
+    (_ #f)))
+
+(define (user-shell)
+  (match (and=> (or (getenv "SHELL")
+                    (passwd:shell (getpwuid (getuid))))
+                basename)
+    ("zsh"  (file-append zsh "/bin/zsh"))
+    ("fish" (file-append fish "/bin/fish"))
+    ("gash" (file-append gash "/bin/gash"))
+    (_      (file-append bash "/bin/bash"))))
+
+(define %default-system-profile
+  ;; The "system" profile available when running 'guix home container'.  The
+  ;; activation script currently expects to run "env -0" (XXX), so provide
+  ;; Coreutils by default.
+  (delay (profile
+          (name "home-system-profile")
+          (content (packages->manifest (list coreutils))))))
+
+(define* (spawn-home-container home
+                               #:key
+                               network?
+                               (command '())
+                               (mappings '())
+                               (system-profile
+                                (force %default-system-profile)))
+  "Spawn a login shell within a container running HOME, a home environment.
+When COMMAND is a non-empty list, execute it in the container and exit
+immediately.  Return the exit status of the process in the container."
+  (define passwd (getpwuid (getuid)))
+  (define home-directory (or (getenv "HOME") (passwd:dir passwd)))
+  (define host (gethostname))
+  (define uid 1000)
+  (define gid 1000)
+  (define user-name (passwd:name passwd))
+  (define user-real-name (passwd:gecos passwd))
+
+  (define (optional-mapping mapping)
+    (and (file-exists? (file-system-mapping-source mapping))
+         mapping))
+
+  (define network-mappings
+    (if network?
+        (filter-map optional-mapping %network-file-mappings)
+        '()))
+
+  (eval/container
+   (with-extensions (list guile-gcrypt)
+     (with-imported-modules `(((guix config) => ,(make-config.scm))
+                              ,@(source-module-closure
+                                 '((gnu build accounts)
+                                   (guix profiles)
+                                   (guix build utils)
+                                   (guix build syscalls))
+                                 #:select? not-config?))
+       #~(begin
+           (use-modules (guix build utils)
+                        (gnu build accounts)
+                        ((guix build syscalls)
+                         #:select (set-network-interface-up)))
+
+           (define shell
+             #$(user-shell))
+
+           (define term
+             #$(getenv "TERM"))
+
+           (define passwd
+             (password-entry
+              (name #$user-name)
+              (real-name #$user-real-name)
+              (uid #$uid) (gid #$gid) (shell shell)
+              (directory #$home-directory)))
+
+           (define groups
+             (list (group-entry (name "users") (gid #$gid))
+                   (group-entry (gid 65534)       ;the overflow GID
+                                (name "overflow"))))
+
+           ;; (guix profiles) loads (guix utils), which calls 'getpw' from the
+           ;; top level.  Thus, arrange so that it's loaded after /etc/passwd
+           ;; has been created.
+           (module-autoload! (current-module)
+                             '(guix profiles) '(load-profile))
+
+           ;; Create /etc/passwd for applications that need it, such as mcron.
+           (mkdir-p "/etc")
+           (write-passwd (list passwd))
+           (write-group groups)
+
+           (unless #$network?
+             ;; When isolated from the network, provide a minimal /etc/hosts
+             ;; to resolve "localhost".
+             (call-with-output-file "/etc/hosts"
+               (lambda (port)
+                 (display "127.0.0.1 localhost\n" port)
+                 (chmod port #o444))))
+
+           ;; Set PATH for things that the activation script might expect, such
+           ;; as "env".
+           (load-profile #$system-profile)
+
+           (mkdir-p #$home-directory)
+           (setenv "HOME" #$home-directory)
+           (setenv "GUIX_NEW_HOME" #$home)
+           (primitive-load (string-append #$home "/activate"))
+           (setenv "GUIX_NEW_HOME" #f)
+
+           (when term
+             ;; Preserve TERM for proper interactive use.
+             (setenv "TERM" term))
+
+           (chdir #$home-directory)
+
+           ;; Invoke SHELL with argv[0] starting with "-": that's how shells
+           ;; figure out that they are login shells!
+           (execl shell (string-append "-" (basename shell))
+                  #$@(match command
+                       (() #~())
+                       ((_ ...)
+                        #~("-c" #$(string-join command))))))))
+
+   #:namespaces (if network?
+                    (delq 'net %namespaces)       ; share host network
+                    %namespaces)
+   #:mappings (append network-mappings mappings)
+   #:guest-uid uid
+   #:guest-gid gid))
+
 
 ;;;
 ;;; Actions.
@@ -159,7 +339,12 @@ (define* (perform-action action he
                          dry-run?
                          derivations-only?
                          use-substitutes?
-                         (validate-reconfigure ensure-forward-reconfigure))
+                         (validate-reconfigure ensure-forward-reconfigure)
+
+                         ;; Container options.
+                         (file-system-mappings '())
+                         (container-command '())
+                         network?)
   "Perform ACTION for home environment. "
 
   (define println
@@ -180,24 +365,37 @@ (define println
        (he-out-path -> (derivation->output-path he-drv)))
     (if (or dry-run? derivations-only?)
         (return #f)
-        (begin
-          (for-each (compose println derivation->output-path) drvs)
+        (case action
+          ((reconfigure)
+           (let* ((number (generation-number %guix-home))
+                  (generation (generation-file-name
+                               %guix-home (+ 1 number))))
 
-          (case action
-            ((reconfigure)
-             (let* ((number (generation-number %guix-home))
-                    (generation (generation-file-name
-                                 %guix-home (+ 1 number))))
-
-               (switch-symlinks generation he-out-path)
-               (switch-symlinks %guix-home generation)
-               (setenv "GUIX_NEW_HOME" he-out-path)
-               (primitive-load (string-append he-out-path "/activate"))
-               (setenv "GUIX_NEW_HOME" #f)
-               (return he-out-path)))
-            (else
-             (newline)
-             (return he-out-path)))))))
+             (switch-symlinks generation he-out-path)
+             (switch-symlinks %guix-home generation)
+             (setenv "GUIX_NEW_HOME" he-out-path)
+             (primitive-load (string-append he-out-path "/activate"))
+             (setenv "GUIX_NEW_HOME" #f)
+             (return he-out-path)))
+          ((container)
+           (mlet %store-monad ((status (spawn-home-container
+                                        he
+                                        #:network? network?
+                                        #:mappings file-system-mappings
+                                        #:command
+                                        container-command)))
+             (match (status:exit-val status)
+               (0 (return #t))
+               ((? integer? n) (return (exit n)))
+               (#f
+                (if (status:term-sig status)
+                    (leave (G_ "process terminated with signal ~a~%")
+                           (status:term-sig status))
+                    (leave (G_ "process stopped with signal ~a~%")
+                           (status:stop-sig status)))))))
+          (else
+           (for-each (compose println derivation->output-path) drvs)
+           (return he-out-path))))))
 
 (define (process-action action args opts)
   "Process ACTION, a sub-command, with the arguments are listed in ARGS.
@@ -236,6 +434,10 @@ (define (ensure-home-environment file-or-exp obj)
              (else
               (leave (G_ "no configuration specified~%")))))))
 
+         (mappings    (filter-map (match-lambda
+                                    (('file-system-mapping . mapping) mapping)
+                                    (_ #f))
+                                  opts))
          (dry?        (assoc-ref opts 'dry-run?)))
 
     (with-store store
@@ -256,7 +458,11 @@ (define (ensure-home-environment file-or-exp obj)
                             #:derivations-only? (assoc-ref opts 
'derivations-only?)
                             #:use-substitutes? (assoc-ref opts 'substitutes?)
                             #:validate-reconfigure
-                            (assoc-ref opts 'validate-reconfigure))))))
+                            (assoc-ref opts 'validate-reconfigure)
+                            #:network? (assoc-ref opts 'network?)
+                            #:file-system-mappings mappings
+                            #:container-command
+                            (or (assoc-ref opts 'container-command) '()))))))
     (warn-about-disk-space)))
 
 
@@ -345,7 +551,7 @@ (define (parse-sub-command arg result)
               list-generations describe
               delete-generations roll-back
               switch-generation search
-              import)
+              import container)
              (alist-cons 'action action result))
             (else (leave (G_ "~a: unknown action~%") action))))))
 
@@ -383,11 +589,28 @@ (define (fail)
            (fail))))
       args))
 
+  (define (parse-args args)
+    ;; Parse the list of command line arguments ARGS.
+
+    ;; The '--' token is used to separate the command to run from the rest of
+    ;; the operands.
+    (let* ((args rest (break (cut string=? "--" <>) args))
+           (opts (parse-command-line args %options (list %default-options)
+                                     #:argument-handler
+                                     parse-sub-command)))
+      (match rest
+        (() opts)
+        (("--") opts)
+        (("--" command ...)
+         (match (assoc-ref opts 'action)
+           ('container
+            (alist-cons 'container-command command opts))
+           (_
+            (leave (G_ "~a: extraneous command~%")
+                   (string-join command))))))))
+
   (with-error-handling
-    (let* ((opts     (parse-command-line args %options
-                                         (list %default-options)
-                                         #:argument-handler
-                                         parse-sub-command))
+    (let* ((opts     (parse-args args))
            (args     (option-arguments opts))
            (command  (assoc-ref opts 'action)))
       (parameterize ((%graft? (assoc-ref opts 'graft?)))
diff --git a/tests/guix-home.sh b/tests/guix-home.sh
index f054d15172..13c02d6269 100644
--- a/tests/guix-home.sh
+++ b/tests/guix-home.sh
@@ -26,6 +26,16 @@ set -e
 
 guix home --version
 
+container_supported ()
+{
+    if guile -c '((@ (guix scripts environment) assert-container-features))'
+    then
+       return 0
+    else
+       return 1
+    fi
+}
+
 NIX_STORE_DIR="$(guile -c '(use-modules (guix config))(display %storedir)')"
 localstatedir="$(guile -c '(use-modules (guix config))(display 
%localstatedir)')"
 GUIX_DAEMON_SOCKET="$localstatedir/guix/daemon-socket/socket"
@@ -47,20 +57,6 @@ trap 'chmod -Rf +w "$test_directory"; rm -rf 
"$test_directory"' EXIT
 (
     cd "$test_directory" || exit 77
 
-    HOME="$test_directory"
-    export HOME
-
-    #
-    # Test 'guix home reconfigure'.
-    #
-
-    echo "# This file will be overridden and backed up." > "$HOME/.bashrc"
-    mkdir "$HOME/.config"
-    echo "This file will be overridden too." > "$HOME/.config/test.conf"
-    echo "This file will stay around." > "$HOME/.config/random-file"
-
-    echo -n "# dot-bashrc test file for guix home" > "dot-bashrc"
-
     cat > "home.scm" <<'EOF'
 (use-modules (guix gexp)
              (gnu home)
@@ -93,6 +89,40 @@ trap 'chmod -Rf +w "$test_directory"; rm -rf 
"$test_directory"' EXIT
                        "# the content of bashrc-test-config.sh"))))))))
 EOF
 
+    echo -n "# dot-bashrc test file for guix home" > "dot-bashrc"
+
+
+    if container_supported
+    then
+       # Run the home in a container.
+       guix home container home.scm -- true
+       ! guix home container home.scm -- false
+       test "$(guix home container home.scm -- echo '$HOME')" = "$HOME"
+       guix home container home.scm -- cat '~/.config/test.conf' | \
+           grep "the content of"
+       guix home container home.scm -- test -h '~/.bashrc'
+       test "$(guix home container home.scm -- id -u)" = 1000
+       ! guix home container home.scm -- test -f '$HOME/sample/home.scm'
+       guix home container home.scm --expose="$PWD=$HOME/sample" -- \
+            test -f '$HOME/sample/home.scm'
+       ! guix home container home.scm --expose="$PWD=$HOME/sample" -- \
+            rm -v '$HOME/sample/home.scm'
+    else
+       echo "'guix home container' test SKIPPED" >&2
+    fi
+
+    HOME="$test_directory"
+    export HOME
+
+    #
+    # Test 'guix home reconfigure'.
+    #
+
+    echo "# This file will be overridden and backed up." > "$HOME/.bashrc"
+    mkdir "$HOME/.config"
+    echo "This file will be overridden too." > "$HOME/.config/test.conf"
+    echo "This file will stay around." > "$HOME/.config/random-file"
+
     guix home reconfigure "${test_directory}/home.scm"
     test -d "${HOME}/.guix-home"
     test -h "${HOME}/.bash_profile"
-- 
2.34.0