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

Previous Next

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 31360 in the body.
You can then email your comments to 31360 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: guix-patches <at> gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 0/5] 'guix pack --relocatable'
Date: Thu,  3 May 2018 22:15:31 +0200

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

Message #8 received at 31360 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 31360 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 1/5] union: Add 'relative-file-name'.
Date: Thu,  3 May 2018 22:22:23 +0200

* 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)))
 
+
+;;;
+;;; 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 <at> gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2014 Eric Bavier <bavier <at> member.fsf.org>
 ;;; Copyright © 2016 Mathieu Lirzin <mthl <at> gnu.org>
 ;;;
-- 
2.17.0

Message #11 received at 31360 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 31360 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 3/5] profiles: Allow lowerable objects other than packages in
 <manifest-entry>.
Date: Thu,  3 May 2018 22:22:25 +0200

* 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

Message #14 received at 31360 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 31360 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 2/5] profiles: Optionally use relative file names for symlink
 targets.
Date: Thu,  3 May 2018 22:22:24 +0200

* 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 <at> gnu.org>
+;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo <at> 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

Message #17 received at 31360 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 31360 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 4/5] search-paths: Add 'set-search-paths'.
Date: Thu,  3 May 2018 22:22:26 +0200

* 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 <at> gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo <at> 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

Message #20 received at 31360 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 31360 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludovic.courtes <at> inria.fr>
Subject: [PATCH 5/5] pack: Add '--relocatable'.
Date: Thu,  3 May 2018 22:22:27 +0200

From: Ludovic Courtès <ludovic.courtes <at> 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 <at> 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 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 <at> gnu.org>
+;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2017 Efraim Flashner <efraim <at> flashner.co.il>
 ;;; Copyright © 2017 Ricardo Wurmus <rekado <at> elephly.net>
 ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen <at> 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))))
 
 
+;;;
+;;; 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 (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))))
+
+
 ;;;
 ;;; 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

Message #23 received at 31360 <at> debbugs.gnu.org (full text, mbox):

From: "Thompson, David" <dthompson2 <at> worcester.edu>
To: Ludovic Courtès <ludo <at> gnu.org>
Cc: 31360 <at> debbugs.gnu.org
Subject: Re: [bug#31360] [PATCH 0/5] 'guix pack --relocatable'
Date: Thu, 3 May 2018 22:45:20 -0400

Hey Ludo,

On Thu, May 3, 2018 at 4:15 PM, Ludovic Courtès <ludo <at> 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

Message #26 received at 31360 <at> debbugs.gnu.org (full text, mbox):

From: ludo <at> gnu.org (Ludovic Courtès)
To: "Thompson\, David" <dthompson2 <at> worcester.edu>
Cc: 31360 <at> debbugs.gnu.org
Subject: Re: [bug#31360] [PATCH 0/5] 'guix pack --relocatable'
Date: Fri, 04 May 2018 11:27:31 +0200

Hello!

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

> On Thu, May 3, 2018 at 4:15 PM, Ludovic Courtès <ludo <at> 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’.

Message #29 received at 31360 <at> debbugs.gnu.org (full text, mbox):

From: "Thompson, David" <dthompson2 <at> worcester.edu>
To: Ludovic Courtès <ludo <at> gnu.org>
Cc: 31360 <at> debbugs.gnu.org
Subject: Re: [bug#31360] [PATCH 0/5] 'guix pack --relocatable'
Date: Fri, 4 May 2018 09:01:49 -0400

On Fri, May 4, 2018 at 5:27 AM, Ludovic Courtès <ludo <at> gnu.org> wrote:
> Hello!
>
> "Thompson, David" <dthompson2 <at> worcester.edu> skribis:
>
>> On Thu, May 3, 2018 at 4:15 PM, Ludovic Courtès <ludo <at> 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

Message #34 received at 31360-done <at> debbugs.gnu.org (full text, mbox):

From: ludo <at> gnu.org (Ludovic Courtès)
To: 31360-done <at> debbugs.gnu.org
Subject: Re: [bug#31360] [PATCH 0/5] 'guix pack --relocatable'
Date: Thu, 10 May 2018 14:55:12 +0200

Ludovic Courtès <ludo <at> 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’.

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.