[bug#31360] [PATCH 0/5] 'guix pack --relocatable'

[bug#31360] [PATCH 0/5] 'guix pack --relocatable'

[Ludovic Courtès]

Hello Guix!

This is the cleaned up version of what we discussed at:

  https://lists.gnu.org/archive/html/guix-devel/2018-04/msg00252.html

Part of the work here is to use relative symlinks in profiles and in
links created with ‘guix pack -S’ such that, if you run:

  guix pack -R -S /mybin=bin bash-static

you can then unpack the result and run:

  ./mybin/sh

For ‘guix pack -R’ I started providing the framework so that ‘guix pack
--bootstrap’ would use the bootstrap C compiler, which in turn would
allow us to add a unit test.  Unfortunately, since ‘glibc-bootstrap’
lacks ‘libc.a’, we cannot do that.

Anyway feedback welcome!  I invite you to give it a try if you have a
non-Guix machine at hand, it’s pretty fun.  :-)

What remains to be seen is the implications for the binary installation
tarball: what if we created it with -R?  Would it be of any use?  I
guess ‘guix-daemon’ would still need to run with --disable-chroot
because build users would be missing.  Maybe we should change
‘guix-daemon’ to do something sensible in that case?

Ludo’.

Ludovic Courtès (5):
  union: Add 'relative-file-name'.
  profiles: Optionally use relative file names for symlink targets.
  profiles: Allow lowerable objects other than packages in
    <manifest-entry>.
  search-paths: Add 'set-search-paths'.
  pack: Add '--relocatable'.

 Makefile.am                               |   3 +-
 doc/guix.texi                             |  42 ++++
 gnu/packages/aux-files/run-in-namespace.c | 264 ++++++++++++++++++++++
 guix/build/profiles.scm                   |  14 +-
 guix/build/union.scm                      |  48 +++-
 guix/profiles.scm                         |  19 +-
 guix/scripts/pack.scm                     | 177 ++++++++++++++-
 guix/search-paths.scm                     |  15 +-
 tests/guix-pack.sh                        |  10 +-
 tests/profiles.scm                        |  46 ++++
 tests/union.scm                           |  18 ++
 tests/utils.scm                           |   2 +-
 12 files changed, 635 insertions(+), 23 deletions(-)
 create mode 100644 gnu/packages/aux-files/run-in-namespace.c

-- 
2.17.0

[bug#31360] [PATCH 1/5] union: Add 'relative-file-name'.

[Ludovic Courtès]

* guix/build/union.scm (%not-slash): New variable.
(relative-file-name): New procedure.
* tests/union.scm (test-relative-file-name): New macro and tests.
---
 guix/build/union.scm | 41 ++++++++++++++++++++++++++++++++++++++++-
 tests/union.scm      | 18 ++++++++++++++++++
 tests/utils.scm      |  2 +-
 3 files changed, 59 insertions(+), 2 deletions(-)

diff --git a/guix/build/union.scm b/guix/build/union.scm
index 1179f1234..82d6199d9 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -27,7 +27,9 @@
   #:use-module (rnrs io ports)
   #:export (union-build
 
-            warn-about-collision))
+            warn-about-collision
+
+            relative-file-name))
 
 ;;; Commentary:
 ;;;
@@ -174,4 +176,41 @@ returns #f, skip the faulty file altogether."
 
   (union-of-directories output (delete-duplicates inputs)))
 
+\f
+;;;
+;;; Relative symlinks.
+;;;
+
+(define %not-slash
+  (char-set-complement (char-set #\/)))
+
+(define (relative-file-name reference file)
+  "Given REFERENCE and FILE, both of which are absolute file names, return the
+file name of FILE relative to REFERENCE.
+
+  (relative-file-name \"/gnu/store/foo\" \"/gnu/store/bin/bar\")
+  => \"../bin/bar\"
+
+Note that this is from a purely lexical standpoint; conversely, \"..\" is
+*not* resolved lexically on POSIX in the presence of symlinks."
+  (if (and (string-prefix? "/" file) (string-prefix? "/" reference))
+      (let loop ((reference (string-tokenize reference %not-slash))
+                 (file      (string-tokenize file %not-slash)))
+        (define (finish)
+          (string-join (append (make-list (length reference) "..") file)
+                       "/"))
+
+        (match reference
+          (()
+           (finish))
+          ((head . tail)
+           (match file
+             (()
+              (finish))
+             ((head* . tail*)
+              (if (string=? head head*)
+                  (loop tail tail*)
+                  (finish)))))))
+      file))
+
 ;;; union.scm ends here
diff --git a/tests/union.scm b/tests/union.scm
index aa95cae00..5a6a4033f 100644
--- a/tests/union.scm
+++ b/tests/union.scm
@@ -184,4 +184,22 @@
                 (file-is-directory? "bin")
                 (eq? 'symlink (stat:type (lstat "bin/guile"))))))))
 
+(letrec-syntax ((test-relative-file-name
+                 (syntax-rules (=>)
+                   ((_ (reference file => expected) rest ...)
+                    (begin
+                      (test-equal (string-append "relative-file-name "
+                                                 reference " " file)
+                        expected
+                        (relative-file-name reference file))
+                      (test-relative-file-name rest ...)))
+                   ((_)
+                    #t))))
+  (test-relative-file-name
+   ("/a/b" "/a/c/d"     => "../c/d")
+   ("/a/b" "/a/b"       => "")
+   ("/a/b" "/a"         => "..")
+   ("/a/b" "/a/b/c/d"   => "c/d")
+   ("/a/b/c" "/a/d/e/f" => "../../d/e/f")))
+
 (test-end)
diff --git a/tests/utils.scm b/tests/utils.scm
index 035886dd1..197182acf 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;;
-- 
2.17.0

[bug#31360] [PATCH 2/5] profiles: Optionally use relative file names for symlink targets.

[Ludovic Courtès]

* guix/build/union.scm (symlink-relative): New procedure.
* guix/build/profiles.scm: Re-export it.
(build-profile): Add #:symlink and pass it to 'union-build'.
* guix/profiles.scm (profile-derivation): Add #:relative-symlinks?.
Pass #:symlink to 'build-profile'.
* tests/profiles.scm ("profile-derivation relative symlinks, one entry")
("profile-derivation relative symlinks, two entries"): New tests.
---
 guix/build/profiles.scm | 14 ++++++++-----
 guix/build/union.scm    |  9 +++++++-
 guix/profiles.scm       |  7 +++++++
 tests/profiles.scm      | 46 +++++++++++++++++++++++++++++++++++++++++
 4 files changed, 70 insertions(+), 6 deletions(-)

diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm
index b4160fba1..819688a91 100644
--- a/guix/build/profiles.scm
+++ b/guix/build/profiles.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,6 +24,7 @@
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (ice-9 pretty-print)
+  #:re-export (symlink-relative)                  ;for convenience
   #:export (ensure-writable-directory
             build-profile))
 
@@ -129,12 +130,15 @@ instead make DIRECTORY a \"real\" directory containing symlinks."
             (apply throw args))))))
 
 (define* (build-profile output inputs
-                        #:key manifest search-paths)
-  "Build a user profile from INPUTS in directory OUTPUT.  Write MANIFEST, an
-sexp, to OUTPUT/manifest.  Create OUTPUT/etc/profile with Bash definitions for
--all the variables listed in SEARCH-PATHS."
+                        #:key manifest search-paths
+                        (symlink symlink))
+  "Build a user profile from INPUTS in directory OUTPUT, using SYMLINK to
+create symlinks.  Write MANIFEST, an sexp, to OUTPUT/manifest.  Create
+OUTPUT/etc/profile with Bash definitions for -all the variables listed in
+SEARCH-PATHS."
   ;; Make the symlinks.
   (union-build output inputs
+               #:symlink symlink
                #:log-port (%make-void-port "w"))
 
   ;; Store meta-data.
diff --git a/guix/build/union.scm b/guix/build/union.scm
index 82d6199d9..24b366af4 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -29,7 +29,8 @@
 
             warn-about-collision
 
-            relative-file-name))
+            relative-file-name
+            symlink-relative))
 
 ;;; Commentary:
 ;;;
@@ -213,4 +214,10 @@ Note that this is from a purely lexical standpoint; conversely, \"..\" is
                   (finish)))))))
       file))
 
+(define (symlink-relative old new)
+  "Assuming both OLD and NEW are absolute file names, make NEW a symlink to
+OLD, but using a relative file name."
+  (symlink (relative-file-name (dirname new) old)
+           new))
+
 ;;; union.scm ends here
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 95dc9746b..c17961c98 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1202,6 +1202,7 @@ the entries in MANIFEST."
                              (hooks %default-profile-hooks)
                              (locales? #t)
                              (allow-collisions? #f)
+                             (relative-symlinks? #f)
                              system target)
   "Return a derivation that builds a profile (aka. 'user environment') with
 the given MANIFEST.  The profile includes additional derivations returned by
@@ -1213,6 +1214,9 @@ with a different version number.)
 When LOCALES? is true, the build is performed under a UTF-8 locale; this adds
 a dependency on the 'glibc-utf8-locales' package.
 
+When RELATIVE-SYMLINKS? is true, use relative file names for symlink targets.
+This is one of the things to do for the result to be relocatable.
+
 When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST
 are cross-built for TARGET."
   (mlet* %store-monad ((system (if system
@@ -1275,6 +1279,9 @@ are cross-built for TARGET."
                                         (manifest-entries manifest))))))
 
             (build-profile #$output '#$inputs
+                           #:symlink #$(if relative-symlinks?
+                                           #~symlink-relative
+                                           #~symlink)
                            #:manifest '#$(manifest->gexp manifest)
                            #:search-paths search-paths))))
 
diff --git a/tests/profiles.scm b/tests/profiles.scm
index 92eb08cb9..c268591c5 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -223,6 +223,52 @@
                  (string=? (dirname (readlink bindir))
                            (derivation->output-path guile))))))
 
+(test-assertm "profile-derivation relative symlinks, one entry"
+  (mlet* %store-monad
+      ((entry ->   (package->manifest-entry %bootstrap-guile))
+       (guile      (package->derivation %bootstrap-guile))
+       (drv        (profile-derivation (manifest (list entry))
+                                       #:relative-symlinks? #t
+                                       #:hooks '()
+                                       #:locales? #f))
+       (profile -> (derivation->output-path drv))
+       (bindir ->  (string-append profile "/bin"))
+       (_          (built-derivations (list drv))))
+    (return (and (file-exists? (string-append bindir "/guile"))
+                 (string=? (readlink bindir)
+                           (string-append "../"
+                                          (basename
+                                           (derivation->output-path guile))
+                                          "/bin"))))))
+
+(unless (network-reachable?) (test-skip 1))
+(test-assertm "profile-derivation relative symlinks, two entries"
+  (mlet* %store-monad
+      ((gnu-make-boot0 -> (@@ (gnu packages commencement) gnu-make-boot0))
+       (manifest -> (packages->manifest
+                     (list %bootstrap-guile gnu-make-boot0)))
+       (guile       (package->derivation %bootstrap-guile))
+       (make        (package->derivation gnu-make-boot0))
+       (drv         (profile-derivation manifest
+                                        #:relative-symlinks? #t
+                                        #:hooks '()
+                                        #:locales? #f))
+       (profile ->  (derivation->output-path drv))
+       (bindir ->   (string-append profile "/bin"))
+       (_           (built-derivations (list drv))))
+    (return (and (file-exists? (string-append bindir "/guile"))
+                 (file-exists? (string-append bindir "/make"))
+                 (string=? (readlink (string-append bindir "/guile"))
+                           (string-append "../../"
+                                          (basename
+                                           (derivation->output-path guile))
+                                          "/bin/guile"))
+                 (string=? (readlink (string-append bindir "/make"))
+                           (string-append "../../"
+                                          (basename
+                                           (derivation->output-path make))
+                                          "/bin/make"))))))
+
 (test-assertm "profile-derivation, inputs"
   (mlet* %store-monad
       ((entry ->   (package->manifest-entry packages:glibc "debug"))
-- 
2.17.0

[bug#31360] [PATCH 3/5] profiles: Allow lowerable objects other than packages in <manifest-entry>.

[Ludovic Courtès]

* guix/profiles.scm (manifest-lookup-package)[entry-lookup-package]: Add
case where 'manifest-entry-item' returns something that's neither a
string nor a package.
---
 guix/profiles.scm | 12 +++++++++---
 1 file changed, 9 insertions(+), 3 deletions(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index c17961c98..dca247976 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -168,7 +168,7 @@
   (version      manifest-entry-version)           ; string
   (output       manifest-entry-output             ; string
                 (default "out"))
-  (item         manifest-entry-item)              ; package | store path
+  (item         manifest-entry-item)              ; package | file-like | store path
   (dependencies manifest-entry-dependencies       ; <manifest-entry>*
                 (default '()))
   (search-paths manifest-entry-search-paths       ; search-path-specification*
@@ -318,7 +318,7 @@ denoting a specific output of a package."
                  (propagated-inputs #$(map entry->gexp deps))
                  (search-paths #$(map search-path-specification->sexp
                                       search-paths))))
-      (($ <manifest-entry> name version output (? package? package)
+      (($ <manifest-entry> name version output package
                            (deps ...) (search-paths ...))
        #~(#$name #$version #$output
                  (ungexp package (or output "out"))
@@ -671,7 +671,13 @@ if not found."
             (return (find-among-inputs inputs)))))
         ((? string? item)
          (mlet %store-monad ((refs (references* item)))
-           (return (find-among-store-items refs)))))))
+           (return (find-among-store-items refs))))
+        (item
+         ;; XXX: ITEM might be a 'computed-file' or anything like that, in
+         ;; which case we don't know what to do.  The fix may be to check
+         ;; references once ITEM is compiled, as proposed at
+         ;; <https://bugs.gnu.org/29927>.
+         (return #f)))))
 
   (anym %store-monad
         entry-lookup-package (manifest-entries manifest)))
-- 
2.17.0

[bug#31360] [PATCH 4/5] search-paths: Add 'set-search-paths'.

[Ludovic Courtès]

* guix/search-paths.scm (set-search-paths): New procedure.
---
 guix/search-paths.scm | 15 +++++++++++++--
 1 file changed, 13 insertions(+), 2 deletions(-)

diff --git a/guix/search-paths.scm b/guix/search-paths.scm
index 4bf0e4438..002e6342b 100644
--- a/guix/search-paths.scm
+++ b/guix/search-paths.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -38,7 +38,8 @@
             string-tokenize*
             evaluate-search-paths
             environment-variable-definition
-            search-path-definition))
+            search-path-definition
+            set-search-paths))
 
 ;;; Commentary:
 ;;;
@@ -196,4 +197,14 @@ prefix/suffix."
                                       #:kind kind
                                       #:separator separator))))
 
+(define* (set-search-paths search-paths directories
+                           #:key (setenv setenv))
+  "Set the search path environment variables specified by SEARCH-PATHS for the
+given directories."
+  (for-each (match-lambda
+              ((spec . value)
+               (setenv (search-path-specification-variable spec)
+                       value)))
+            (evaluate-search-paths search-paths directories)))
+
 ;;; search-paths.scm ends here
-- 
2.17.0

[bug#31360] [PATCH 5/5] pack: Add '--relocatable'.

[Ludovic Courtès]

From: Ludovic Courtès <ludovic.courtes@inria.fr>

* 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.
---
 Makefile.am                               |   3 +-
 doc/guix.texi                             |  42 ++++
 gnu/packages/aux-files/run-in-namespace.c | 264 ++++++++++++++++++++++
 guix/scripts/pack.scm                     | 177 ++++++++++++++-
 tests/guix-pack.sh                        |  10 +-
 5 files changed, 485 insertions(+), 11 deletions(-)
 create mode 100644 gnu/packages/aux-files/run-in-namespace.c

diff --git a/Makefile.am b/Makefile.am
index 7ea922888..fc082b4fb 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -272,7 +272,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 87892fc89..90348e853 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2833,6 +2833,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:
 
@@ -2866,6 +2875,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 000000000..d0ab05c5d
--- /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);
+}
+
+\f
+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 488638adc..53b89ab33 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net>
@@ -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)
@@ -99,11 +101,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)
@@ -118,7 +123,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.
@@ -216,11 +222,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>.
@@ -265,6 +273,149 @@ the image."
                     #:references-graphs `(("profile" ,profile))))
 
 \f
+;;;
+;;; 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)))
+
+\f
+;;;
+;;; 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 (package-full-name package) 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))))
+
+\f
 ;;;
 ;;; Command-line options.
 ;;;
@@ -301,6 +452,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)))
@@ -353,6 +507,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\""))
@@ -410,7 +566,13 @@ Create a bundle of PACKAGE.\n"))
 
   (with-error-handling
     (let* ((dry-run?    (assoc-ref opts 'dry-run?))
-           (manifest    (manifest-from-args opts))
+           (relocatable? (assoc-ref opts 'relocatable?))
+           (manifest    (let ((manifest (manifest-from-args 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"))
@@ -442,6 +604,7 @@ Create a bundle of PACKAGE.\n"))
           (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 1b63b957b..9031a9a22 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
 
@@ -81,3 +81,7 @@ guix pack --dry-run --bootstrap -f docker -S /opt/gnu=/ guile-bootstrap
 # Build a tarball pack of cross-compiled software.  Use coreutils because
 # 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
-- 
2.17.0

[bug#31360] [PATCH 0/5] 'guix pack --relocatable'

[Thompson, David]

Hey Ludo,

On Thu, May 3, 2018 at 4:15 PM, Ludovic Courtès <ludo@gnu.org> wrote:
> Hello Guix!
>
> This is the cleaned up version of what we discussed at:
>
>   https://lists.gnu.org/archive/html/guix-devel/2018-04/msg00252.html
>
> Part of the work here is to use relative symlinks in profiles and in
> links created with ‘guix pack -S’ such that, if you run:
>
>   guix pack -R -S /mybin=bin bash-static
>
> you can then unpack the result and run:
>
>   ./mybin/sh

Just wanted to say that this is awesome! Is there a way to share host
system resources? I would like a relocatable pack that could connect
to the host's X server and do graphical things.

- Dave

[bug#31360] [PATCH 0/5] 'guix pack --relocatable'

[Ludovic Courtès]

Hello!

"Thompson, David" <dthompson2@worcester.edu> skribis:

> On Thu, May 3, 2018 at 4:15 PM, Ludovic Courtès <ludo@gnu.org> wrote:
>> Hello Guix!
>>
>> This is the cleaned up version of what we discussed at:
>>
>>   https://lists.gnu.org/archive/html/guix-devel/2018-04/msg00252.html
>>
>> Part of the work here is to use relative symlinks in profiles and in
>> links created with ‘guix pack -S’ such that, if you run:
>>
>>   guix pack -R -S /mybin=bin bash-static
>>
>> you can then unpack the result and run:
>>
>>   ./mybin/sh
>
> Just wanted to say that this is awesome! Is there a way to share host
> system resources? I would like a relocatable pack that could connect
> to the host's X server and do graphical things.

Yes: the C wrapper, ‘run-in-namespace.c’, shares everything.  That is,
it creates a separate mount namespace but the only difference compared
to the host is /gnu/store.

Ludo’.

[bug#31360] [PATCH 0/5] 'guix pack --relocatable'

[Thompson, David]

On Fri, May 4, 2018 at 5:27 AM, Ludovic Courtès <ludo@gnu.org> wrote:
> Hello!
>
> "Thompson, David" <dthompson2@worcester.edu> skribis:
>
>> On Thu, May 3, 2018 at 4:15 PM, Ludovic Courtès <ludo@gnu.org> wrote:
>>> Hello Guix!
>>>
>>> This is the cleaned up version of what we discussed at:
>>>
>>>   https://lists.gnu.org/archive/html/guix-devel/2018-04/msg00252.html
>>>
>>> Part of the work here is to use relative symlinks in profiles and in
>>> links created with ‘guix pack -S’ such that, if you run:
>>>
>>>   guix pack -R -S /mybin=bin bash-static
>>>
>>> you can then unpack the result and run:
>>>
>>>   ./mybin/sh
>>
>> Just wanted to say that this is awesome! Is there a way to share host
>> system resources? I would like a relocatable pack that could connect
>> to the host's X server and do graphical things.
>
> Yes: the C wrapper, ‘run-in-namespace.c’, shares everything.  That is,
> it creates a separate mount namespace but the only difference compared
> to the host is /gnu/store.

Ah, yes, that makes perfect sense. Thanks!

- Dave

bug#31360: [PATCH 0/5] 'guix pack --relocatable'

[Ludovic Courtès]

Ludovic Courtès <ludo@gnu.org> skribis:

> This is the cleaned up version of what we discussed at:
>
>   https://lists.gnu.org/archive/html/guix-devel/2018-04/msg00252.html
>
> Part of the work here is to use relative symlinks in profiles and in
> links created with ‘guix pack -S’ such that, if you run:
>
>   guix pack -R -S /mybin=bin bash-static
>
> you can then unpack the result and run:
>
>   ./mybin/sh

Pushed as 47a60325ca650e8fc1a291c8655b4297f4de8deb!

Ludo’.