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

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 427c87d0bdc06cc3ee7fc220fd3ad36084412533
Author: Ludovic Courtès <address@hidden>
Date:   Tue Mar 19 11:03:35 2019 +0100

    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.
---
 guix/scripts/pack.scm | 29 ++++++++++++++++++++++-------
 1 file changed, 22 insertions(+), 7 deletions(-)

diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 17a166d..8685ba1 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -306,11 +306,13 @@ added to the pack."
     (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 @@ added to the pack."
                    ,@(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 @@ Create a bundle of PACKAGE.\n"))
             (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)