From: "Ludovic Courtès" <ludo@gnu.org>
To: 31360@debbugs.gnu.org
Subject: [bug#31360] [PATCH 2/5] profiles: Optionally use relative file names for symlink targets.
Date: Thu, 3 May 2018 22:22:24 +0200 [thread overview]
Message-ID: <20180503202227.22485-2-ludo@gnu.org> (raw)
In-Reply-To: <20180503202227.22485-1-ludo@gnu.org>
* 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
next prev parent reply other threads:[~2018-05-03 20:23 UTC|newest]
Thread overview: 10+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-05-03 20:15 [bug#31360] [PATCH 0/5] 'guix pack --relocatable' Ludovic Courtès
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 [this message]
2018-05-03 20:22 ` [bug#31360] [PATCH 3/5] profiles: Allow lowerable objects other than packages in <manifest-entry> Ludovic Courtès
2018-05-03 20:22 ` [bug#31360] [PATCH 4/5] search-paths: Add 'set-search-paths' Ludovic Courtès
2018-05-03 20:22 ` [bug#31360] [PATCH 5/5] pack: Add '--relocatable' Ludovic Courtès
2018-05-04 2:45 ` [bug#31360] [PATCH 0/5] 'guix pack --relocatable' Thompson, David
2018-05-04 9:27 ` Ludovic Courtès
2018-05-04 13:01 ` Thompson, David
2018-05-10 12:55 ` bug#31360: " Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20180503202227.22485-2-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=31360@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).