From 427c87d0bdc06cc3ee7fc220fd3ad36084412533 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludovic.courtes@inria.fr>
Date: Tue, 19 Mar 2019 11:03:35 +0100
Subject: [PATCH] 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 17a166d9d7..8685ba1d0a 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)