pack: 'guix pack -S xxx' no longer adds entries twice to the tarball.

* guix/scripts/pack.scm (self-contained-tarball)[build](symlink->directives):
Do not add a 'directory' directive for "/".  Previously, as soon as we
were using '-S /bin=bin' or similar, we would add every entry a second
time in the tarball; this would translate as hard links in the tarball,
which tar < 1.30 sometimes fails to extract.
Pass symlinks defined in DIRECTIVES to 'tar'.
This commit is contained in:
Ludovic Courtès 2018-05-11 16:56:19 +02:00 committed by Ludovic Courtès
parent 30da3173d5
commit 26b8cadf88
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 17 additions and 6 deletions

View File

@ -122,10 +122,17 @@ added to the pack."
;; parent directories.
(match-lambda
((source '-> target)
(let ((target (string-append #$profile "/" target)))
`((directory ,(dirname source))
(let ((target (string-append #$profile "/" target))
(parent (dirname source)))
;; Never add a 'directory' directive for "/" so as to
;; preserve its ownnership when extracting the archive (see
;; below), and also because this would lead to adding the
;; same entries twice in the tarball.
`(,@(if (string=? parent "/")
'()
`((directory ,parent)))
(,source
-> ,(relative-file-name (dirname source) target)))))))
-> ,(relative-file-name parent target)))))))
(define directives
;; Fully-qualified symlinks.
@ -146,9 +153,11 @@ added to the pack."
"")
#$tar "/bin"))
;; Note: there is not much to gain here with deduplication and
;; there is the overhead of the '.links' directory, so turn it
;; off.
;; Note: there is not much to gain here with deduplication and there
;; is the overhead of the '.links' directory, so turn it off.
;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
;; with hard links:
;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
(populate-single-profile-directory %root
#:profile #$profile
#:closure "profile"
@ -195,6 +204,8 @@ added to the pack."
(filter-map (match-lambda
(('directory directory)
(string-append "." directory))
((source '-> _)
(string-append "." source))
(_ #f))
directives)))))))))