pack: Produce relative symlinks when using '-f squashfs'.
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:
parent
1d6589db81
commit
427c87d0bd
|
@ -306,11 +306,13 @@ added to the pack."
|
||||||
(with-imported-modules (source-module-closure
|
(with-imported-modules (source-module-closure
|
||||||
'((guix build utils)
|
'((guix build utils)
|
||||||
(guix build store-copy)
|
(guix build store-copy)
|
||||||
|
(guix build union)
|
||||||
(gnu build install))
|
(gnu build install))
|
||||||
#:select? not-config?)
|
#:select? not-config?)
|
||||||
#~(begin
|
#~(begin
|
||||||
(use-modules (guix build utils)
|
(use-modules (guix build utils)
|
||||||
(guix build store-copy)
|
(guix build store-copy)
|
||||||
|
((guix build union) #:select (relative-file-name))
|
||||||
(gnu build install)
|
(gnu build install)
|
||||||
(srfi srfi-1)
|
(srfi srfi-1)
|
||||||
(srfi srfi-26)
|
(srfi srfi-26)
|
||||||
|
@ -359,12 +361,18 @@ added to the pack."
|
||||||
,@(append-map
|
,@(append-map
|
||||||
(match-lambda
|
(match-lambda
|
||||||
((source '-> target)
|
((source '-> 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"
|
(list "-p"
|
||||||
(string-join
|
(string-join
|
||||||
;; name s mode uid gid symlink
|
;; name s mode uid gid symlink
|
||||||
(list source
|
(list source
|
||||||
"s" "777" "0" "0"
|
"s" "777" "0" "0"
|
||||||
(string-append #$profile "/" target))))))
|
(relative-file-name (dirname source)
|
||||||
|
target)))))))
|
||||||
'#$symlinks)
|
'#$symlinks)
|
||||||
|
|
||||||
;; Create empty mount points.
|
;; Create empty mount points.
|
||||||
|
@ -881,7 +889,14 @@ Create a bundle of PACKAGE.\n"))
|
||||||
(run-with-store store
|
(run-with-store store
|
||||||
(mlet* %store-monad ((profile (profile-derivation
|
(mlet* %store-monad ((profile (profile-derivation
|
||||||
manifest
|
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?
|
#:hooks (if bootstrap?
|
||||||
'()
|
'()
|
||||||
%default-profile-hooks)
|
%default-profile-hooks)
|
||||||
|
|
Loading…
Reference in New Issue