pack: "-RR" produces PRoot-enabled relocatable binaries.

* gnu/packages/aux-files/run-in-namespace.c (exec_with_proot): New
function.
(main): When 'clone' fails, call 'rm_rf'.
[PROOT_PROGRAM]: When 'clone' fails, call 'exec_with_proot'.
* guix/scripts/pack.scm (wrapped-package): Add #:proot?.
[proot]: New procedure.
[build]: Compile with -DPROOT_PROGRAM when PROOT? is true.
* guix/scripts/pack.scm (%options): Set the 'relocatable?' value to
'proot when "-R" is passed several times.
(guix-pack): Pass #:proot? to 'wrapped-package'.
* tests/guix-pack-relocatable.sh: Use "-RR" on Intel systems that lack
user namespace support.
* doc/guix.texi (Invoking guix pack): Document -RR.

4 files changed, 119 insertions, 21 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index a720f3f3bb..8d51bdf7f4 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4760,14 +4760,24 @@ symlinks, as well as empty mount points for virtual file systems like
 procfs.
 @end table
 
+@cindex relocatable binaries
 @item --relocatable
 @itemx -R
 Produce @dfn{relocatable binaries}---i.e., binaries that can be placed
-anywhere in the file system hierarchy and run from there.  For example,
-if you create a pack containing Bash with:
+anywhere in the file system hierarchy and run from there.
+
+When this option is passed once, the resulting binaries require support for
+@dfn{user namespaces} in the kernel Linux; when passed
+@emph{twice}@footnote{Here's a trick to memorize it: @code{-RR}, which adds
+PRoot support, can be thought of as the abbreviation of ``Really
+Relocatable''.  Neat, isn't it?}, relocatable binaries fall to back to PRoot
+if user namespaces are unavailable, and essentially work anywhere---see below
+for the implications.
+
+For example, if you create a pack containing Bash with:
 
 @example
-guix pack -R -S /mybin=bin bash
+guix pack -RR -S /mybin=bin bash
 @end example
 
 @noindent
@@ -4786,12 +4796,23 @@ In that shell, if you type @code{ls /gnu/store}, you'll notice that
 altogether!  That is probably the simplest way to deploy Guix-built
 software on a non-Guix machine.
 
-There's a gotcha though: this technique relies on the @dfn{user
-namespace} feature of the kernel Linux, which allows unprivileged users
-to mount or change root.  Old versions of Linux did not support it, and
-some GNU/Linux distributions turn it off; on these systems, programs
-from the pack @emph{will fail to run}, unless they are unpacked in the
-root file system.
+@quotation Note
+By default, relocatable binaries rely on the @dfn{user namespace} feature of
+the kernel Linux, which allows unprivileged users to mount or change root.
+Old versions of Linux did not support it, and some GNU/Linux distributions
+turn it off.
+
+To produce relocatable binaries that work even in the absence of user
+namespaces, pass @option{--relocatable} or @option{-R} @emph{twice}.  In that
+case, binaries will try user namespace support and fall back to PRoot if user
+namespaces are not supported.
+
+The @uref{https://proot-me.github.io/, PRoot} program provides the necessary
+support for file system virtualization.  It achieves that by using the
+@code{ptrace} system call on the running program.  This approach has the
+advantage to work without requiring special kernel support, but it incurs
+run-time overhead every time a system call is made.
+@end quotation
 
 @item --expression=@var{expr}
 @itemx -e @var{expr}
diff --git a/gnu/packages/aux-files/run-in-namespace.c b/gnu/packages/aux-files/run-in-namespace.c
index f0cff88552..551f4db88a 100644
--- a/gnu/packages/aux-files/run-in-namespace.c
+++ b/gnu/packages/aux-files/run-in-namespace.c
@@ -1,5 +1,5 @@
 /* GNU Guix --- Functional package management for GNU
-   Copyright (C) 2018 Ludovic Courtès <ludo@gnu.org>
+   Copyright (C) 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 
    This file is part of GNU Guix.
 
@@ -212,6 +212,46 @@ disallow_setgroups (pid_t pid)
 }
 
 
+#ifdef PROOT_PROGRAM
+
+/* Execute the wrapped program with PRoot, passing it ARGC and ARGV, and
+   "bind-mounting" STORE in the right place.  */
+static void
+exec_with_proot (const char *store, int argc, char *argv[])
+{
+  int proot_specific_argc = 4;
+  int proot_argc = argc + proot_specific_argc;
+  char *proot_argv[proot_argc], *proot;
+  char bind_spec[strlen (store) + 1 + sizeof "@STORE_DIRECTORY@"];
+
+  strcpy (bind_spec, store);
+  strcat (bind_spec, ":");
+  strcat (bind_spec, "@STORE_DIRECTORY@");
+
+  proot = concat (store, PROOT_PROGRAM);
+
+  proot_argv[0] = proot;
+  proot_argv[1] = "-b";
+  proot_argv[2] = bind_spec;
+  proot_argv[3] = "@WRAPPED_PROGRAM@";
+
+  for (int i = 0; i < argc; i++)
+    proot_argv[i + proot_specific_argc] = argv[i + 1];
+
+  proot_argv[proot_argc] = NULL;
+
+  /* Seccomp support seems to invariably lead to segfaults; disable it by
+     default.  */
+  setenv ("PROOT_NO_SECCOMP", "1", 0);
+
+  int err = execv (proot, proot_argv);
+  if (err < 0)
+    assert_perror (errno);
+}
+
+#endif
+
+
 int
 main (int argc, char *argv[])
 {
@@ -274,6 +314,10 @@ main (int argc, char *argv[])
 	  break;
 
 	case -1:
+	  rm_rf (new_root);
+#ifdef PROOT_PROGRAM
+	  exec_with_proot (store, argc, argv);
+#else
 	  fprintf (stderr, "%s: error: 'clone' failed: %m\n", argv[0]);
 	  fprintf (stderr, "\
 This may be because \"user namespaces\" are not supported on this system.\n\
@@ -281,6 +325,7 @@ Consequently, we cannot run '@WRAPPED_PROGRAM@',\n\
 unless you move it to the '@STORE_DIRECTORY@' directory.\n\
 \n\
 Please refer to the 'guix pack' documentation for more information.\n");
+#endif
 	  return EXIT_FAILURE;
 
 	default:
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index e2ecddfbfc..bfb8b85356 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -517,10 +517,14 @@ please email '~a'~%")
 ;;;
 
 (define* (wrapped-package package
-                          #:optional (compiler (c-compiler)))
+                          #:optional (compiler (c-compiler))
+                          #:key proot?)
   (define runner
     (local-file (search-auxiliary-file "run-in-namespace.c")))
 
+  (define (proot)
+    (specification->package "proot-static"))
+
   (define build
     (with-imported-modules (source-module-closure
                             '((guix build utils)
@@ -550,10 +554,19 @@ please email '~a'~%")
               (("@STORE_DIRECTORY@") (%store-directory)))
 
             (let* ((base   (strip-store-prefix program))
-                   (result (string-append #$output "/" base)))
+                   (result (string-append #$output "/" base))
+                   (proot  #$(and proot?
+                                  #~(string-drop
+                                     #$(file-append (proot) "/bin/proot")
+                                     (+ (string-length (%store-directory))
+                                        1)))))
               (mkdir-p (dirname result))
-              (invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
-                      "run.c" "-o" result)
+              (apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
+                     "run.c" "-o" result
+                     (if proot
+                         (list (string-append "-DPROOT_PROGRAM=\""
+                                              proot "\""))
+                         '()))
               (delete-file "run.c")))
 
           (setvbuf (current-output-port) 'line)
@@ -646,7 +659,12 @@ please email '~a'~%")
                    (exit 0)))
          (option '(#\R "relocatable") #f #f
                  (lambda (opt name arg result)
-                   (alist-cons 'relocatable? #t result)))
+                   (match (assq-ref result 'relocatable?)
+                     (#f
+                      (alist-cons 'relocatable? #t result))
+                     (_
+                      (alist-cons 'relocatable? 'proot
+                                  (alist-delete 'relocatable? result))))))
          (option '(#\e "expression") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'expression arg result)))
@@ -821,11 +839,14 @@ Create a bundle of PACKAGE.\n"))
                                           #:graft? (assoc-ref opts 'graft?))))
           (let* ((dry-run?    (assoc-ref opts 'dry-run?))
                  (relocatable? (assoc-ref opts 'relocatable?))
+                 (proot?      (eq? relocatable? 'proot))
                  (manifest    (let ((manifest (manifest-from-args store opts)))
                                 ;; Note: We cannot honor '--bootstrap' here because
                                 ;; 'glibc-bootstrap' lacks 'libc.a'.
                                 (if relocatable?
-                                    (map-manifest-entries wrapped-package manifest)
+                                    (map-manifest-entries
+                                     (cut wrapped-package <> #:proot? proot?)
+                                     manifest)
                                     manifest)))
                  (pack-format (assoc-ref opts 'format))
                  (name        (string-append (symbol->string pack-format)
diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh
index 554416627b..38dcf1e485 100644
--- a/tests/guix-pack-relocatable.sh
+++ b/tests/guix-pack-relocatable.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -41,17 +41,28 @@ STORE_PARENT="`dirname $NIX_STORE_DIR`"
 export STORE_PARENT
 if test "$STORE_PARENT" = "/"; then exit 77; fi
 
-# This test requires user namespaces and associated command-line tools.
-if ! unshare -mrf sh -c 'mount -t tmpfs none "$STORE_PARENT"'
+if unshare -mrf sh -c 'mount -t tmpfs none "$STORE_PARENT"'
 then
-    exit 77
+    # Test the wrapper that relies on user namespaces.
+    relocatable_option="-R"
+else
+    case "`uname -m`" in
+	x86_64|i?86)
+	    # Test the wrapper that falls back to PRoot.
+	    relocatable_option="-RR";;
+	*)
+	    # XXX: Our 'proot' package currently fails tests on non-Intel
+	    # architectures, so skip this by default.
+	    exit 77;;
+    esac
 fi
 
 test_directory="`mktemp -d`"
 export test_directory
 trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT
 
-tarball="`guix pack -R -S /Bin=bin sed`"
+export relocatable_option
+tarball="`guix pack $relocatable_option -S /Bin=bin sed`"
 (cd "$test_directory"; tar xvf "$tarball")
 
 # Run that relocatable 'sed' in a user namespace where we "erase" the store by