profiles: Optionally use relative file names for symlink targets.

* 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.

4 files changed, 70 insertions, 6 deletions

diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm
index b4160fba1b..819688a913 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 82d6199d9e..24b366af45 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 95dc9746bd..c17961c987 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 8d3cfe91d3..c668c2b831 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"))