* [bug#31360] [PATCH 2/5] profiles: Optionally use relative file names for symlink targets.
2018-05-03 20:22 ` [bug#31360] [PATCH 1/5] union: Add 'relative-file-name' Ludovic Courtès
@ 2018-05-03 20:22 ` Ludovic Courtès
2018-05-03 20:22 ` [bug#31360] [PATCH 3/5] profiles: Allow lowerable objects other than packages in <manifest-entry> Ludovic Courtès
` (2 subsequent siblings)
3 siblings, 0 replies; 10+ messages in thread
From: Ludovic Courtès @ 2018-05-03 20:22 UTC (permalink / raw)
To: 31360
* 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
^ permalink raw reply related [flat|nested] 10+ messages in thread* [bug#31360] [PATCH 5/5] pack: Add '--relocatable'.
2018-05-03 20:22 ` [bug#31360] [PATCH 1/5] union: Add 'relative-file-name' Ludovic Courtès
` (2 preceding siblings ...)
2018-05-03 20:22 ` [bug#31360] [PATCH 4/5] search-paths: Add 'set-search-paths' Ludovic Courtès
@ 2018-05-03 20:22 ` Ludovic Courtès
3 siblings, 0 replies; 10+ messages in thread
From: Ludovic Courtès @ 2018-05-03 20:22 UTC (permalink / raw)
To: 31360; +Cc: 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
^ permalink raw reply related [flat|nested] 10+ messages in thread