pack: Add relocation via ld.so and fakechroot.

* gnu/packages/aux-files/run-in-namespace.c (HAVE_EXEC_WITH_LOADER): New
macro.
(bind_mount): Rename to...
(mirror_directory): ... this.  Add 'firmlink' argument and use it
instead of calling mkdir/open/close/mount directly.
(bind_mount, make_symlink): New functions.
(exec_in_user_namespace): Adjust accordingly.
(exec_with_loader) [HAVE_EXEC_WITH_LOADER]: New function.
(exec_performance): New function.
(engines): Add them.
* guix/scripts/pack.scm (wrapped-package)[fakechroot-library]
[audit-module]: New procedures.
[audit-source]: New variable.
[build](elf-interpreter, elf-loader-compile-flags): New procedures.
(build-wrapper): Use them.
* tests/guix-pack-relocatable.sh: Test with
'GUIX_EXECUTION_ENGINE=fakechroot'.
* doc/guix.texi (Invoking guix pack): Document the 'performance' and
'fakechroot' engines.
* gnu/packages/aux-files/pack-audit.c: New file.
* Makefile.am (AUX_FILES): Add it.

6 files changed, 331 insertions, 21 deletions

diff --git a/Makefile.am b/Makefile.am
index 752445afcb..6a5dd64fed 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -338,6 +338,7 @@ AUX_FILES =						\
   gnu/packages/aux-files/linux-libre/4.9-x86_64.conf	\
   gnu/packages/aux-files/linux-libre/4.4-i686.conf	\
   gnu/packages/aux-files/linux-libre/4.4-x86_64.conf	\
+  gnu/packages/aux-files/pack-audit.c			\
   gnu/packages/aux-files/run-in-namespace.c
 
 # Templates, examples.
diff --git a/doc/guix.texi b/doc/guix.texi
index 906ebff555..a36b9691fb 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5230,6 +5230,10 @@ following execution engines are supported:
 Try user namespaces and fall back to PRoot if user namespaces are not
 supported (see below).
 
+@item performance
+Try user namespaces and fall back to Fakechroot if user namespaces are
+not supported (see below).
+
 @item userns
 Run the program through user namespaces and abort if they are not
 supported.
@@ -5241,6 +5245,15 @@ 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.
+
+@item fakechroot
+Run through Fakechroot.  @uref{https://github.com/dex4er/fakechroot/,
+Fakechroot} virtualizes file system accesses by intercepting calls to C
+library functions such as @code{open}, @code{stat}, @code{exec}, and so
+on.  Unlike PRoot, it incurs very little overhead.  However, it does not
+always work: for example, some file system accesses made from within the
+C library are not intercepted, and file system accesses made @i{via}
+direct syscalls are not intercepted either, leading to erratic behavior.
 @end table
 
 @vindex GUIX_EXECUTION_ENGINE
diff --git a/gnu/packages/aux-files/pack-audit.c b/gnu/packages/aux-files/pack-audit.c
new file mode 100644
index 0000000000..374787e8b9
--- /dev/null
+++ b/gnu/packages/aux-files/pack-audit.c
@@ -0,0 +1,85 @@
+/* GNU Guix --- Functional package management for GNU
+   Copyright (C) 2020 Ludovic Courtès <ludo@gnu.org>
+
+   This file is part of GNU Guix.
+
+   GNU Guix is free software; you can redistribute it and/or modify it
+   under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 3 of the License, or (at
+   your option) any later version.
+
+   GNU Guix is distributed in the hope that it will be useful, but
+   WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.  */
+
+/* This file implements part of the GNU ld.so audit interface.  It is used by
+   the "fakechroot" engine of the 'guix pack -RR' wrappers to make sure the
+   loader looks for shared objects under the "fake" root directory.  */
+
+#define _GNU_SOURCE 1
+
+#include <link.h>
+
+#include <error.h>
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+
+/* The pseudo root directory and store that we are relocating to.  */
+static const char *root_directory;
+static char *store;
+
+/* The original store, "/gnu/store" by default.  */
+static const char original_store[] = "@STORE_DIRECTORY@";
+
+/* Like 'malloc', but abort if 'malloc' returns NULL.  */
+static void *
+xmalloc (size_t size)
+{
+  void *result = malloc (size);
+  assert (result != NULL);
+  return result;
+}
+
+unsigned int
+la_version (unsigned int v)
+{
+  if (v != LAV_CURRENT)
+    error (1, 0, "cannot handle interface version %u", v);
+
+  root_directory = getenv ("FAKECHROOT_BASE");
+  if (root_directory == NULL)
+    error (1, 0, "'FAKECHROOT_BASE' is not set");
+
+  store = xmalloc (strlen (root_directory) + sizeof original_store);
+  strcpy (store, root_directory);
+  strcat (store, original_store);
+
+  return v;
+}
+
+/* Return NAME, a shared object file name, relocated under STORE.  This
+   function is called by the loader whenever it looks for a shared object.  */
+char *
+la_objsearch (const char *name, uintptr_t *cookie, unsigned int flag)
+{
+  char *result;
+
+  if (strncmp (name, original_store,
+	       sizeof original_store - 1) == 0)
+    {
+      size_t len = strlen (name) - sizeof original_store
+	+ strlen (store) + 1;
+      result = xmalloc (len);
+      strcpy (result, store);
+      strcat (result, name + sizeof original_store - 1);
+    }
+  else
+    result = strdup (name);
+
+  return result;
+}
diff --git a/gnu/packages/aux-files/run-in-namespace.c b/gnu/packages/aux-files/run-in-namespace.c
index 6e97359078..5a6b932b87 100644
--- a/gnu/packages/aux-files/run-in-namespace.c
+++ b/gnu/packages/aux-files/run-in-namespace.c
@@ -42,6 +42,11 @@
 #include <dirent.h>
 #include <sys/syscall.h>
 
+/* Whether we're building the ld.so/libfakechroot wrapper.  */
+#define HAVE_EXEC_WITH_LOADER						\
+  (defined PROGRAM_INTERPRETER) && (defined LOADER_AUDIT_MODULE)	\
+  && (defined FAKECHROOT_LIBRARY)
+
 /* The original store, "/gnu/store" by default.  */
 static const char original_store[] = "@STORE_DIRECTORY@";
 
@@ -117,9 +122,42 @@ rm_rf (const char *directory)
     assert_perror (errno);
 }
 
-/* Bind mount all the top-level entries in SOURCE to TARGET.  */
+/* Make TARGET a bind-mount of SOURCE.  Take into account ENTRY's type, which
+   corresponds to SOURCE.  */
+static int
+bind_mount (const char *source, const struct dirent *entry,
+	    const char *target)
+{
+  if (entry->d_type == DT_DIR)
+    {
+      int err = mkdir (target, 0700);
+      if (err != 0)
+	return err;
+    }
+  else
+    close (open (target, O_WRONLY | O_CREAT));
+
+  return mount (source, target, "none",
+		MS_BIND | MS_REC | MS_RDONLY, NULL);
+}
+
+#if HAVE_EXEC_WITH_LOADER
+
+/* Make TARGET a symlink to SOURCE.  */
+static int
+make_symlink (const char *source, const struct dirent *entry,
+	      const char *target)
+{
+  return symlink (source, target);
+}
+
+#endif
+
+/* Mirror with FIRMLINK all the top-level entries in SOURCE to TARGET.  */
 static void
-bind_mount (const char *source, const char *target)
+mirror_directory (const char *source, const char *target,
+		  int (* firmlink) (const char *, const struct dirent *,
+				    const char *))
 {
   DIR *stream = opendir (source);
 
@@ -154,17 +192,7 @@ bind_mount (const char *source, const char *target)
       else
 	{
 	  /* Create the mount point.  */
-	  if (entry->d_type == DT_DIR)
-	    {
-	      int err = mkdir (new_entry, 0700);
-	      if (err != 0)
-		assert_perror (errno);
-	    }
-	  else
-	    close (open (new_entry, O_WRONLY | O_CREAT));
-
-	  int err = mount (abs_source, new_entry, "none",
-			   MS_BIND | MS_REC | MS_RDONLY, NULL);
+	  int err = firmlink (abs_source, entry, new_entry);
 
 	  /* It used to be that only directories could be bind-mounted.  Thus,
 	     keep going if we fail to bind-mount a non-directory entry.
@@ -248,7 +276,7 @@ exec_in_user_namespace (const char *store, int argc, char *argv[])
       /* Note: Due to <https://bugzilla.kernel.org/show_bug.cgi?id=183461>
 	 we cannot make NEW_ROOT a tmpfs (which would have saved the need
 	 for 'rm_rf'.)  */
-      bind_mount ("/", new_root);
+      mirror_directory ("/", new_root, bind_mount);
       mkdir_p (new_store);
       err = mount (store, new_store, "none", MS_BIND | MS_REC | MS_RDONLY,
 		   NULL);
@@ -341,6 +369,92 @@ exec_with_proot (const char *store, int argc, char *argv[])
 #endif
 
 
+#if HAVE_EXEC_WITH_LOADER
+
+/* Execute the wrapped program by invoking the loader (ld.so) directly,
+   passing it the audit module and preloading libfakechroot.so.  */
+static void
+exec_with_loader (const char *store, int argc, char *argv[])
+{
+  char *loader = concat (store,
+			 PROGRAM_INTERPRETER + sizeof original_store);
+  size_t loader_specific_argc = 6;
+  size_t loader_argc = argc + loader_specific_argc;
+  char *loader_argv[loader_argc + 1];
+  loader_argv[0] = argv[0];
+  loader_argv[1] = "--audit";
+  loader_argv[2] = concat (store,
+			   LOADER_AUDIT_MODULE + sizeof original_store);
+  loader_argv[3] = "--preload";
+  loader_argv[4] = concat (store,
+			   FAKECHROOT_LIBRARY + sizeof original_store);
+  loader_argv[5] = concat (store,
+			   "@WRAPPED_PROGRAM@" + sizeof original_store);
+
+  for (size_t i = 0; i < argc; i++)
+    loader_argv[i + loader_specific_argc] = argv[i + 1];
+
+  loader_argv[loader_argc] = NULL;
+
+  /* Set up the root directory.  */
+  int err;
+  char *new_root = mkdtemp (strdup ("/tmp/guix-exec-XXXXXX"));
+  mirror_directory ("/", new_root, make_symlink);
+
+  char *new_store = concat (new_root, original_store);
+  char *new_store_parent = dirname (strdup (new_store));
+  mkdir_p (new_store_parent);
+  symlink (store, new_store);
+
+#ifdef GCONV_DIRECTORY
+  /* Tell libc where to find its gconv modules.  This is necessary because
+     gconv uses non-interposable 'open' calls.  */
+  char *gconv_path = concat (store,
+			     GCONV_DIRECTORY + sizeof original_store);
+  setenv ("GCONV_PATH", gconv_path, 1);
+  free (gconv_path);
+#endif
+
+  setenv ("FAKECHROOT_BASE", new_root, 1);
+
+  pid_t child = fork ();
+  switch (child)
+    {
+    case 0:
+      err = execv (loader, loader_argv);
+      if (err < 0)
+	assert_perror (errno);
+      exit (EXIT_FAILURE);
+      break;
+
+    case -1:
+      assert_perror (errno);
+      exit (EXIT_FAILURE);
+      break;
+
+    default:
+      {
+  	int status;
+	waitpid (child, &status, 0);
+	chdir ("/");			  /* avoid EBUSY */
+	rm_rf (new_root);
+	free (new_root);
+
+	close (2);			/* flushing stderr should be silent */
+
+	if (WIFEXITED (status))
+	  exit (WEXITSTATUS (status));
+	else
+	  /* Abnormal termination cannot really be reproduced, so exit
+	     with 255.  */
+	  exit (255);
+      }
+    }
+}
+
+#endif
+
+
 /* Execution engines.  */
 
 struct engine
@@ -356,7 +470,7 @@ buffer_stderr (void)
   setvbuf (stderr, stderr_buffer, _IOFBF, sizeof stderr_buffer);
 }
 
-/* The default engine.  */
+/* The default engine: choose a robust method.  */
 static void
 exec_default (const char *store, int argc, char *argv[])
 {
@@ -370,14 +484,30 @@ exec_default (const char *store, int argc, char *argv[])
 #endif
 }
 
+/* The "performance" engine: choose performance over robustness.  */
+static void
+exec_performance (const char *store, int argc, char *argv[])
+{
+  buffer_stderr ();
+
+  exec_in_user_namespace (store, argc, argv);
+#if HAVE_EXEC_WITH_LOADER
+  exec_with_loader (store, argc, argv);
+#endif
+}
+
 /* List of supported engines.  */
 static const struct engine engines[] =
   {
    { "default", exec_default },
+   { "performance", exec_performance },
    { "userns", exec_in_user_namespace },
 #ifdef PROOT_PROGRAM
    { "proot", exec_with_proot },
 #endif
+#if HAVE_EXEC_WITH_LOADER
+   { "fakechroot", exec_with_loader },
+#endif
    { NULL, NULL }
   };
 
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 11d0653d9a..518bf6e7e3 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -684,18 +684,50 @@ last resort for relocation."
   (define runner
     (local-file (search-auxiliary-file "run-in-namespace.c")))
 
+  (define audit-source
+    (local-file (search-auxiliary-file "pack-audit.c")))
+
   (define (proot)
     (specification->package "proot-static"))
 
+  (define (fakechroot-library)
+    (computed-file "libfakechroot.so"
+                   #~(copy-file #$(file-append
+                                   (specification->package "fakechroot")
+                                   "/lib/fakechroot/libfakechroot.so")
+                                #$output)))
+
+  (define (audit-module)
+    ;; Return an ld.so audit module for use by the 'fakechroot' execution
+    ;; engine that translates file names of all the files ld.so loads.
+    (computed-file "pack-audit.so"
+                   (with-imported-modules '((guix build utils))
+                     #~(begin
+                         (use-modules (guix build utils))
+
+                         (copy-file #$audit-source "audit.c")
+                         (substitute* "audit.c"
+                           (("@STORE_DIRECTORY@")
+                            (%store-directory)))
+
+                         (invoke #$compiler "-std=gnu99"
+                                 "-shared" "-fPIC" "-Os" "-g0"
+                                 "-Wall" "audit.c" "-o" #$output)))))
+
   (define build
     (with-imported-modules (source-module-closure
                             '((guix build utils)
-                              (guix build union)))
+                              (guix build union)
+                              (guix elf)))
       #~(begin
           (use-modules (guix build utils)
                        ((guix build union) #:select (relative-file-name))
+                       (guix elf)
+                       (ice-9 binary-ports)
                        (ice-9 ftw)
-                       (ice-9 match))
+                       (ice-9 match)
+                       (srfi srfi-1)
+                       (rnrs bytevectors))
 
           (define input
             ;; The OUTPUT* output of PACKAGE.
@@ -714,6 +746,48 @@ last resort for relocation."
                 (#f    base)
                 (index (string-drop base index)))))
 
+          (define (elf-interpreter elf)
+            ;; Return the interpreter of ELF as a string, or #f if ELF has no
+            ;; interpreter segment.
+            (match (find (lambda (segment)
+                           (= (elf-segment-type segment) PT_INTERP))
+                         (elf-segments elf))
+              (#f #f)                             ;maybe a .so
+              (segment
+               (let ((bv (make-bytevector (- (elf-segment-memsz segment) 1))))
+                 (bytevector-copy! (elf-bytes elf)
+                                   (elf-segment-offset segment)
+                                   bv 0 (bytevector-length bv))
+                 (utf8->string bv)))))
+
+          (define (elf-loader-compile-flags program)
+            ;; Return the cpp flags defining macros for the ld.so/fakechroot
+            ;; wrapper of PROGRAM.
+
+            ;; TODO: Handle scripts by wrapping their interpreter.
+            (if (elf-file? program)
+                (let* ((bv      (call-with-input-file program
+                                  get-bytevector-all))
+                       (elf     (parse-elf bv))
+                       (interp  (elf-interpreter elf))
+                       (gconv   (and interp
+                                     (string-append (dirname interp)
+                                                    "/gconv"))))
+                  (if interp
+                      (list (string-append "-DPROGRAM_INTERPRETER=\""
+                                           interp "\"")
+                            (string-append "-DFAKECHROOT_LIBRARY=\""
+                                           #$(fakechroot-library) "\"")
+
+                            (string-append "-DLOADER_AUDIT_MODULE=\""
+                                           #$(audit-module) "\"")
+                            (if gconv
+                                (string-append "-DGCONV_DIRECTORY=\""
+                                               gconv "\"")
+                                "-UGCONV_DIRECTORY"))
+                      '()))
+                '()))
+
           (define (build-wrapper program)
             ;; Build a user-namespace wrapper for PROGRAM.
             (format #t "building wrapper for '~a'...~%" program)
@@ -733,10 +807,11 @@ last resort for relocation."
               (mkdir-p (dirname result))
               (apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
                      "run.c" "-o" result
-                     (if proot
-                         (list (string-append "-DPROOT_PROGRAM=\""
-                                              proot "\""))
-                         '()))
+                     (append (if proot
+                                 (list (string-append "-DPROOT_PROGRAM=\""
+                                                      proot "\""))
+                                 '())
+                             (elf-loader-compile-flags program)))
               (delete-file "run.c")))
 
           (setvbuf (current-output-port) 'line)
diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh
index cb56815fed..358cac5b26 100644
--- a/tests/guix-pack-relocatable.sh
+++ b/tests/guix-pack-relocatable.sh
@@ -94,6 +94,12 @@ case "`uname -m`" in
 	export GUIX_EXECUTION_ENGINE
 	"$test_directory/Bin/sed" --version > "$test_directory/output"
 	grep 'GNU sed' "$test_directory/output"
+
+	# Now with fakechroot.
+	GUIX_EXECUTION_ENGINE="fakechroot"
+	"$test_directory/Bin/sed" --version > "$test_directory/output"
+	grep 'GNU sed' "$test_directory/output"
+
 	chmod -Rf +w "$test_directory"; rm -rf "$test_directory"/*
 	;;
     *)