ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-23 21:17:11 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

pack: Produce relative symlinks when using '-f squashfs'.

Browse source 
Fixes <https://bugs.gnu.org/34913>.

* guix/scripts/pack.scm (squashfs-image)[build]: Use
'relative-file-name' when creating SYMLINKS.
* guix/scripts/pack.scm (guix-pack): Pass #:relative-symlinks? #t when
PACK-FORMAT is 'squashfs.
This commit is contained in:
Ludovic Courtès 2019-03-19 11:03:35 +01:00 committed by Ludovic Courtès
parent 1d6589db81
commit 427c87d0bd
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 22 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

29
guix/scripts/pack.scm
View file

@ -306,11 +306,13 @@ (define build
(with-imported-modules (source-module-closure
'((guix build utils)
(guix build store-copy)
(guix build union)
(gnu build install))
#:select? not-config?)
#~(begin
(use-modules (guix build utils)
(guix build store-copy)
((guix build union) #:select (relative-file-name))
(gnu build install)
(srfi srfi-1)
(srfi srfi-26)
@ -359,12 +361,18 @@ (define database #+database)
,@(append-map
(match-lambda
((source '-> target)
(list "-p"
(string-join
;; name s mode uid gid symlink
(list source
"s" "777" "0" "0"
(string-append #$profile "/" target))))))
;; Create relative symlinks to work around a bug in
;; Singularity 2.x:
;; https://bugs.gnu.org/34913
;; https://github.com/sylabs/singularity/issues/1487
(let ((target (string-append #$profile "/" target)))
(list "-p"
(string-join
;; name s mode uid gid symlink
(list source
"s" "777" "0" "0"
(relative-file-name (dirname source)
target)))))))
'#$symlinks)
;; Create empty mount points.
@ -881,7 +889,14 @@ (define properties
(run-with-store store
(mlet* %store-monad ((profile (profile-derivation
manifest
#:relative-symlinks? relocatable?
;; Always produce relative
;; symlinks for Singularity (see
;; <https://bugs.gnu.org/34913>).
#:relative-symlinks?
(or relocatable?
(eq? 'squashfs pack-format))
#:hooks (if bootstrap?
'()
%default-profile-hooks)