pack: Add '--relocatable'.

* gnu/packages/aux-files/run-in-namespace.c: New file.
* Makefile.am (AUX_FILES): Add it.
* guix/scripts/pack.scm (<c-compiler>): New record type.
(c-compiler, bootstrap-c-compiler, c-compiler-compiler): New procedures.
(self-contained-tarball): Use
'relative-file-name' for the SOURCE -> TARGET symlink.
(docker-image): Add 'defmod' to please Geiser.
(wrapped-package, map-manifest-entries): New procedures.
(%options, show-help): Add --relocatable.
(guix-pack): Honor it.

5 files changed, 488 insertions, 13 deletions

diff --git a/Makefile.am b/Makefile.am
index 2110371f7a..38bd54cf4f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -274,7 +274,8 @@ AUX_FILES =						\
   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/linux-libre/4.1-i686.conf	\
-  gnu/packages/aux-files/linux-libre/4.1-x86_64.conf
+  gnu/packages/aux-files/linux-libre/4.1-x86_64.conf	\
+  gnu/packages/aux-files/run-in-namespace.c
 
 # Templates, examples.
 EXAMPLES =					\
diff --git a/doc/guix.texi b/doc/guix.texi
index 8b9f8721ba..6aeb313773 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2834,6 +2834,15 @@ guix pack -S /opt/gnu/bin=bin guile emacs geiser
 @noindent
 That way, users can happily type @file{/opt/gnu/bin/guile} and enjoy.
 
+@cindex relocatable binaries, with @command{guix pack}
+What if the recipient of your pack does not have root privileges on
+their machine, and thus cannot unpack it in the root file system?  In
+that case, you will want to use the @code{--relocatable} option (see
+below).  This option produces @dfn{relocatable binaries}, meaning they
+they can be placed anywhere in the file system hierarchy: in the example
+above, users can unpack your tarball in their home directory and
+directly run @file{./opt/gnu/bin/guile}.
+
 Alternatively, you can produce a pack in the Docker image format using
 the following command:
 
@@ -2867,6 +2876,39 @@ This produces a tarball that follows the
 Docker Image Specification}.
 @end table
 
+@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:
+
+@example
+guix pack -R -S /mybin=bin bash
+@end example
+
+@noindent
+... you can copy that pack to a machine that lacks Guix, and from your
+home directory as a normal user, run:
+
+@example
+tar xf pack.tar.gz
+./mybin/sh
+@end example
+
+@noindent
+In that shell, if you type @code{ls /gnu/store}, you'll notice that
+@file{/gnu/store} shows up and contains all the dependencies of
+@code{bash}, even though the machine actually lacks @file{/gnu/store}
+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.
+
 @item --expression=@var{expr}
 @itemx -e @var{expr}
 Consider the package @var{expr} evaluates to.
diff --git a/gnu/packages/aux-files/run-in-namespace.c b/gnu/packages/aux-files/run-in-namespace.c
new file mode 100644
index 0000000000..d0ab05c5db
--- /dev/null
+++ b/gnu/packages/aux-files/run-in-namespace.c
@@ -0,0 +1,264 @@
+/* GNU Guix --- Functional package management for GNU
+   Copyright (C) 2018 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/>.  */
+
+/* Make the given @WRAPPED_PROGRAM@ relocatable by executing it in a separate
+   mount namespace where the store is mounted in its right place.
+
+   We would happily do that in Scheme using 'call-with-container'.  However,
+   this very program needs to be relocatable, so it needs to be statically
+   linked, which complicates things (Guile's modules can hardly be "linked"
+   into a single executable.)  */
+
+#define _GNU_SOURCE
+#include <stdlib.h>
+#include <stdio.h>
+#include <unistd.h>
+#include <sched.h>
+#include <sys/mount.h>
+#include <errno.h>
+#include <libgen.h>
+#include <limits.h>
+#include <string.h>
+#include <assert.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <sys/wait.h>
+#include <fcntl.h>
+#include <dirent.h>
+
+/* Concatenate DIRECTORY, a slash, and FILE.  Return the result, which the
+   caller must eventually free.  */
+static char *
+concat (const char *directory, const char *file)
+{
+  char *result = malloc (strlen (directory) + 2 + strlen (file));
+  assert (result != NULL);
+
+  strcpy (result, directory);
+  strcat (result, "/");
+  strcat (result, file);
+  return result;
+}
+
+static void
+mkdir_p (const char *directory)
+{
+  if (strcmp (directory, "/") != 0)
+    {
+      char *parent = dirname (strdupa (directory));
+      mkdir_p (parent);
+      int err = mkdir (directory, 0700);
+      if (err < 0 && errno != EEXIST)
+	assert_perror (errno);
+    }
+}
+
+static void
+rm_rf (const char *directory)
+{
+  DIR *stream = opendir (directory);
+
+  for (struct dirent *entry = readdir (stream);
+       entry != NULL;
+       entry = readdir (stream))
+    {
+      if (strcmp (entry->d_name, ".") == 0
+	  || strcmp (entry->d_name, "..") == 0)
+	continue;
+
+      char *full = concat (directory, entry->d_name);
+
+      int err = unlink (full);
+      if (err < 0)
+	{
+	  if (errno == EISDIR)
+	    /* Recurse (we expect a shallow directory structure so there's
+	       little risk of stack overflow.)  */
+	    rm_rf (full);
+	  else
+	    assert_perror (errno);
+	}
+
+      free (full);
+    }
+
+  closedir (stream);
+
+  int err = rmdir (directory);
+  if (err < 0 && errno != ENOENT)
+    assert_perror (errno);
+}
+
+/* Bind mount all the top-level entries in SOURCE to TARGET.  */
+static void
+bind_mount (const char *source, const char *target)
+{
+  DIR *stream = opendir (source);
+
+  for (struct dirent *entry = readdir (stream);
+       entry != NULL;
+       entry = readdir (stream))
+    {
+      /* XXX: Some file systems may not report a useful 'd_type'.  Ignore them
+	 for now.  */
+      assert (entry->d_type != DT_UNKNOWN);
+
+      if (strcmp (entry->d_name, ".") == 0
+	  || strcmp (entry->d_name, "..") == 0)
+	continue;
+
+      char *abs_source = concat (source, entry->d_name);
+      char *new_entry = concat (target, entry->d_name);
+
+      if (entry->d_type == DT_LNK)
+	{
+	  char target[PATH_MAX];
+
+	  ssize_t result = readlink (abs_source, target, sizeof target - 1);
+	  if (result > 0)
+	    {
+	      target[result] = '\0';
+	      int err = symlink (target, new_entry);
+	      if (err < 0)
+		assert_perror (errno);
+	    }
+	}
+      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);
+
+	  /* It used to be that only directories could be bind-mounted.  Thus,
+	     keep going if we fail to bind-mount a non-directory entry.
+	     That's OK because regular files in the root file system are
+	     usually uninteresting.  */
+	  if (err != 0 && entry->d_type != DT_DIR)
+	    assert_perror (errno);
+
+	  free (new_entry);
+	  free (abs_source);
+	}
+    }
+
+  closedir (stream);
+}
+
+
+int
+main (int argc, char *argv[])
+{
+  ssize_t size;
+  char self[PATH_MAX];
+  size = readlink ("/proc/self/exe", self, sizeof self - 1);
+  assert (size > 0);
+
+  /* SELF is something like "/home/ludo/.local/gnu/store/…-foo/bin/ls" and we
+     want to extract "/home/ludo/.local/gnu/store".  */
+  size_t index = strlen (self)
+    - strlen ("@WRAPPED_PROGRAM@")
+    + strlen ("@STORE_DIRECTORY@");
+  char *store = strdup (self);
+  store[index] = '\0';
+
+  struct stat statbuf;
+
+  /* If STORE is already at the "right" place, we can execute
+     @WRAPPED_PROGRAM@ right away.  This is not just an optimization: it's
+     needed when running one of these wrappers from within an unshare'd
+     namespace, because 'unshare' fails with EPERM in that context.  */
+  if (strcmp (store, "@STORE_DIRECTORY@") != 0
+      && lstat ("@WRAPPED_PROGRAM@", &statbuf) != 0)
+    {
+      /* Spawn @WRAPPED_PROGRAM@ in a separate namespace where STORE is
+	 bind-mounted in the right place.  */
+      int err;
+      char *new_root = mkdtemp (strdup ("/tmp/guix-exec-XXXXXX"));
+      char *new_store = concat (new_root, "@STORE_DIRECTORY@");
+      char *cwd = get_current_dir_name ();
+
+      pid_t child = fork ();
+      switch (child)
+	{
+	case 0:
+	  /* Unshare namespaces in the child and set up bind-mounts from
+	     there.  That way, bind-mounts automatically disappear when the
+	     child exits, which simplifies cleanup for the parent.  */
+	  err = unshare (CLONE_NEWNS | CLONE_NEWUSER);
+	  if (err < 0)
+	    {
+	      fprintf (stderr, "%s: error: 'unshare' failed: %m\n", argv[0]);
+	      fprintf (stderr, "\
+This may be because \"user namespaces\" are not supported on this system.\n\
+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");
+	      return EXIT_FAILURE;
+	    }
+
+	  /* 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);
+	  mkdir_p (new_store);
+	  err = mount (store, new_store, "none", MS_BIND | MS_REC | MS_RDONLY,
+		       NULL);
+	  if (err < 0)
+	    assert_perror (errno);
+
+	  chdir (new_root);
+	  err = chroot (new_root);
+	  if (err < 0)
+	    assert_perror (errno);
+
+	  /* Change back to where we were before chroot'ing.  */
+	  chdir (cwd);
+	  break;
+	case -1:
+	  assert_perror (errno);
+	  break;
+	default:
+	  {
+	    int status;
+	    waitpid (child, &status, 0);
+	    chdir ("/");			  /* avoid EBUSY */
+	    rm_rf (new_root);
+	    free (new_root);
+	    exit (status);
+	  }
+	}
+    }
+
+  /* The executable is available under @STORE_DIRECTORY@, so we can now
+     execute it.  */
+  int err = execv ("@WRAPPED_PROGRAM@", argv);
+  if (err < 0)
+    assert_perror (errno);
+
+  return EXIT_FAILURE;
+}
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 0e09a01496..db5609219f 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -32,6 +32,8 @@
   #:use-module (guix packages)
   #:use-module (guix profiles)
   #:use-module (guix derivations)
+  #:use-module (guix search-paths)
+  #:use-module (guix build-system gnu)
   #:use-module (guix scripts build)
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
@@ -100,11 +102,14 @@ with a properly initialized store database.
 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
 added to the pack."
   (define build
-    (with-imported-modules '((guix build utils)
-                             (guix build store-copy)
-                             (gnu build install))
+    (with-imported-modules (source-module-closure
+                            '((guix build utils)
+                              (guix build union)
+                              (guix build store-copy)
+                              (gnu build install)))
       #~(begin
           (use-modules (guix build utils)
+                       ((guix build union) #:select (relative-file-name))
                        (gnu build install)
                        (srfi srfi-1)
                        (srfi srfi-26)
@@ -119,7 +124,8 @@ added to the pack."
               ((source '-> target)
                (let ((target (string-append #$profile "/" target)))
                  `((directory ,(dirname source))
-                   (,source -> ,target))))))
+                   (,source
+                    -> ,(relative-file-name (dirname source) target)))))))
 
           (define directives
             ;; Fully-qualified symlinks.
@@ -217,11 +223,13 @@ the image."
       (('gnu rest ...) #t)
       (rest #f)))
 
+  (define defmod 'define-module)                  ;trick Geiser
+
   (define config
     ;; (guix config) module for consumption by (guix gcrypt).
     (scheme-file "gcrypt-config.scm"
                  #~(begin
-                     (define-module (guix config)
+                     (#$defmod (guix config)
                        #:export (%libgcrypt))
 
                      ;; XXX: Work around <http://bugs.gnu.org/15602>.
@@ -267,6 +275,150 @@ the image."
 
 
 ;;;
+;;; Compiling C programs.
+;;;
+
+;; A C compiler.  That lowers to a single program that can be passed typical C
+;; compiler flags, and it makes sure the whole toolchain is available.
+(define-record-type <c-compiler>
+  (%c-compiler toolchain guile)
+  c-compiler?
+  (toolchain c-compiler-toolchain)
+  (guile     c-compiler-guile))
+
+(define* (c-compiler #:optional inputs
+                     #:key (guile (default-guile)))
+  (%c-compiler inputs guile))
+
+(define (bootstrap-c-compiler)
+  "Return the C compiler that uses the bootstrap toolchain.  This is used only
+by '--bootstrap', for testing purposes."
+  (define bootstrap-toolchain
+    (list (first (assoc-ref %bootstrap-inputs "gcc"))
+          (first (assoc-ref %bootstrap-inputs "binutils"))
+          (first (assoc-ref %bootstrap-inputs "libc"))))
+
+  (c-compiler bootstrap-toolchain
+              #:guile %bootstrap-guile))
+
+(define-gexp-compiler (c-compiler-compiler (compiler <c-compiler>) system target)
+  "Lower COMPILER to a single script that does the right thing."
+  (define toolchain
+    (or (c-compiler-toolchain compiler)
+        (list (first (assoc-ref (standard-packages) "gcc"))
+              (first (assoc-ref (standard-packages) "ld-wrapper"))
+              (first (assoc-ref (standard-packages) "binutils"))
+              (first (assoc-ref (standard-packages) "libc"))
+              (gexp-input (first (assoc-ref (standard-packages) "libc"))
+                          "static"))))
+
+  (define inputs
+    (match (append-map package-propagated-inputs
+                       (filter package? toolchain))
+      (((labels things . _) ...)
+       (append toolchain things))))
+
+  (define search-paths
+    (cons $PATH
+          (append-map package-native-search-paths
+                      (filter package? inputs))))
+
+  (define run
+    (with-imported-modules (source-module-closure
+                            '((guix build utils)
+                              (guix search-paths)))
+      #~(begin
+          (use-modules (guix build utils) (guix search-paths)
+                       (ice-9 match))
+
+          (define (output-file args)
+            (let loop ((args args))
+              (match args
+                (() "a.out")
+                (("-o" file _ ...) file)
+                ((head rest ...) (loop rest)))))
+
+          (set-search-paths (map sexp->search-path-specification
+                                 '#$(map search-path-specification->sexp
+                                         search-paths))
+                            '#$inputs)
+
+          (let ((output (output-file (command-line))))
+            (apply invoke "gcc" (cdr (command-line)))
+            (invoke "strip" output)))))
+
+  (when target
+    ;; TODO: Yep, we'll have to do it someday!
+    (leave (G_ "cross-compilation not implemented here;
+please email '~a'~%")
+           (@ (guix config) %guix-bug-report-address)))
+
+  (gexp->script "c-compiler" run
+                #:guile (c-compiler-guile compiler)))
+
+
+;;;
+;;; Wrapped package.
+;;;
+
+(define* (wrapped-package package
+                          #:optional (compiler (c-compiler)))
+  (define runner
+    (local-file (search-auxiliary-file "run-in-namespace.c")))
+
+  (define build
+    (with-imported-modules '((guix build utils))
+      #~(begin
+          (use-modules (guix build utils)
+                       (ice-9 match))
+
+          (define (strip-store-prefix file)
+            ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return
+            ;; "/bin/foo".
+            (let* ((len  (string-length (%store-directory)))
+                   (base (string-drop file (+ 1 len))))
+              (match (string-index base #\/)
+                (#f    base)
+                (index (string-drop base index)))))
+
+          (define (build-wrapper program)
+            ;; Build a user-namespace wrapper for PROGRAM.
+            (format #t "building wrapper for '~a'...~%" program)
+            (copy-file #$runner "run.c")
+
+            (substitute* "run.c"
+              (("@WRAPPED_PROGRAM@") program)
+              (("@STORE_DIRECTORY@") (%store-directory)))
+
+            (let* ((base   (strip-store-prefix program))
+                   (result (string-append #$output "/" base)))
+              (mkdir-p (dirname result))
+              (invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall"
+                      "run.c" "-o" result)
+              (delete-file "run.c")))
+
+          (setvbuf (current-output-port)
+                   (cond-expand (guile-2.2 'line)
+                                (else      _IOLBF)))
+          (for-each build-wrapper
+                    (append (find-files #$(file-append package "/bin"))
+                            (find-files #$(file-append package "/sbin"))
+                            (find-files #$(file-append package "/libexec")))))))
+
+  (computed-file (string-append (package-full-name package "-") "R")
+                 build))
+
+(define (map-manifest-entries proc manifest)
+  "Apply PROC to all the entries of MANIFEST and return a new manifest."
+  (make-manifest
+   (map (lambda (entry)
+          (manifest-entry
+            (inherit entry)
+            (item (proc (manifest-entry-item entry)))))
+        (manifest-entries manifest))))
+
+
+;;;
 ;;; Command-line options.
 ;;;
 
@@ -302,6 +454,9 @@ the image."
          (option '(#\f "format") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'format (string->symbol arg) result)))
+         (option '(#\R "relocatable") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'relocatable? #t result)))
          (option '(#\e "expression") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'expression arg result)))
@@ -354,6 +509,8 @@ Create a bundle of PACKAGE.\n"))
   (display (G_ "
   -f, --format=FORMAT    build a pack in the given FORMAT"))
   (display (G_ "
+  -R, --relocatable      produce relocatable executables"))
+  (display (G_ "
   -e, --expression=EXPR  consider the package EXPR evaluates to"))
   (display (G_ "
   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
@@ -417,6 +574,9 @@ Create a bundle of PACKAGE.\n"))
 
   (with-error-handling
     (with-store store
+      ;; Set the build options before we do anything else.
+      (set-build-options-from-command-line store opts)
+
       (parameterize ((%graft? (assoc-ref opts 'graft?))
                      (%guile-for-build (package-derivation
                                         store
@@ -425,7 +585,13 @@ Create a bundle of PACKAGE.\n"))
                                             (canonical-package guile-2.2))
                                         #:graft? (assoc-ref opts 'graft?))))
         (let* ((dry-run?    (assoc-ref opts 'dry-run?))
-               (manifest    (manifest-from-args store opts))
+               (relocatable? (assoc-ref opts 'relocatable?))
+               (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)
+                                  manifest)))
                (pack-format (assoc-ref opts 'format))
                (name        (string-append (symbol->string pack-format)
                                            "-pack"))
@@ -444,12 +610,10 @@ Create a bundle of PACKAGE.\n"))
                                (leave (G_ "~a: unknown pack format")
                                       format))))
                (localstatedir? (assoc-ref opts 'localstatedir?)))
-          ;; Set the build options before we do anything else.
-          (set-build-options-from-command-line store opts)
-
           (run-with-store store
             (mlet* %store-monad ((profile (profile-derivation
                                            manifest
+                                           #:relative-symlinks? relocatable?
                                            #:hooks (if bootstrap?
                                                        '()
                                                        %default-profile-hooks)
diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh
index 5584c10e00..130389a7ad 100644
--- a/tests/guix-pack.sh
+++ b/tests/guix-pack.sh
@@ -20,9 +20,9 @@
 # Test the `guix pack' command-line utility.
 #
 
-# A network connection is required to build %bootstrap-coreutils&co,
-# which is required to run these tests with the --bootstrap option.
-if ! guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null; then
+# The bootstrap binaries are needed to run these tests, which usually requires
+# a network connection.
+if ! guix build -q guile-bootstrap; then
     exit 77
 fi
 
@@ -87,6 +87,10 @@ guix pack --dry-run --bootstrap -f docker -S /opt/gnu=/ guile-bootstrap
 # guile-bootstrap is not intended to be cross-compiled.
 guix pack --dry-run --bootstrap --target=arm-unknown-linux-gnueabihf coreutils
 
+# Likewise, 'guix pack -R' requires a full-blown toolchain (because
+# 'glibc-bootstrap' lacks 'libc.a'), hence '--dry-run'.
+guix pack -R --dry-run --bootstrap -S /mybin=bin guile-bootstrap
+
 # Make sure package transformation options are honored.
 mkdir -p "$test_directory"
 drv1="`guix pack -n guile 2>&1 | grep pack.*\.drv`"