nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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:
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 @@ 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)
(list "-p" ;; Create relative symlinks to work around a bug in
(string-join ;; Singularity 2.x:
;; name s mode uid gid symlink ;; https://bugs.gnu.org/34913
(list source ;; https://github.com/sylabs/singularity/issues/1487
"s" "777" "0" "0" (let ((target (string-append #$profile "/" 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) '#$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)