[bug#39807] [PATCH] guix: pack: Only wrap executable files.

[Eric Bavier <bavier@posteo.net>]

[-- Attachment #1: Type: text/plain, Size: 33 bytes --]

Latest patch attached.
-- 
`~Eric

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-wip-guix-pack-Only-wrap-executable-files.patch --]
[-- Type: text/x-diff; name=0001-wip-guix-pack-Only-wrap-executable-files.patch, Size: 5512 bytes --]

From 5b9c0a140837138740b2b4f07338901948f08515 Mon Sep 17 00:00:00 2001
From: Eric Bavier <bavier@member.fsf.org>
Date: Mon, 24 Feb 2020 23:47:02 -0600
Subject: [PATCH] wip: guix: pack: Only wrap executable files.

* guix/scripts/pack.scm (wrapped-package)<build>: Build wrappers for
executable files and symlink others.
* tests/guix-pack-relocatable.sh: Test relocatable git-minimal's
"merge-octopus".
---
 guix/scripts/pack.scm          | 32 ++++++++++++++++++++---------
 tests/guix-pack-relocatable.sh | 37 ++++++++++++++++++++++++++++++++++
 2 files changed, 60 insertions(+), 9 deletions(-)

diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index b6fb73838d..55ed0958ad 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -690,9 +691,11 @@ last resort for relocation."
                               (guix build union)))
       #~(begin
           (use-modules (guix build utils)
-                       ((guix build union) #:select (relative-file-name))
+                       ((guix build union) #:select (symlink-relative))
+                       (srfi srfi-1)
                        (ice-9 ftw)
-                       (ice-9 match))
+                       (ice-9 match)
+                       (ice-9 receive))
 
           (define input
             ;; The OUTPUT* output of PACKAGE.
@@ -743,15 +746,26 @@ last resort for relocation."
           (mkdir target)
           (for-each (lambda (file)
                       (unless (member file '("." ".." "bin" "sbin" "libexec"))
-                        (let ((file* (string-append input "/" file)))
-                          (symlink (relative-file-name target file*)
-                                   (string-append target "/" file)))))
+                        (symlink-relative (string-append input  "/" file)
+                                          (string-append target "/" file))))
                     (scandir input))
 
-          (for-each build-wrapper
-                    (append (find-files (string-append input "/bin"))
-                            (find-files (string-append input "/sbin"))
-                            (find-files (string-append input "/libexec")))))))
+          (receive (executables others)
+              (partition executable-file?
+                         (append (find-files (string-append input "/bin"))
+                                 (find-files (string-append input "/sbin"))
+                                 (find-files (string-append input "/libexec"))))
+            ;; Wrap only executables, since the wrapper will eventually need
+            ;; to execve them.  E.g. git's "libexec" directory contains many
+            ;; shell scripts that are source'd from elsewhere, which fails if
+            ;; they are wrapped.
+            (for-each build-wrapper executables)
+            ;; Link any other non-executable files
+            (for-each (lambda (old)
+                        (let ((new (string-append target (strip-store-prefix old))))
+                          (mkdir-p (dirname new))
+                          (symlink-relative old new)))
+                      others)))))
 
   (computed-file (string-append
                   (cond ((package? package)
diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh
index e93610eedc..a3d9013133 100644
--- a/tests/guix-pack-relocatable.sh
+++ b/tests/guix-pack-relocatable.sh
@@ -1,5 +1,6 @@
 # GNU Guix --- Functional package management for GNU
 # Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2020 Eric Bavier <bavier@posteo.net>
 #
 # This file is part of GNU Guix.
 #
@@ -84,3 +85,39 @@ chmod -Rf +w "$test_directory"; rm -rf "$test_directory"/*
 tarball="`guix pack -R -S /share=share groff:doc`"
 (cd "$test_directory"; tar xvf "$tarball")
 test -d "$test_directory/share/doc/groff/html"
+chmod -Rf +w "$test_directory"; rm -rf "$test_directory"/*
+
+# Check that packages that mix executable and support files (e.g. git) in the
+# "binary" directories still work after wrapped.
+tarball="`guix pack $relocatable_option -S /opt= git-minimal`"
+(cd "$test_directory"; tar xvf "$tarball"
+ mkdir foo; cd foo; touch .gitignore bar.txt bif.txt)
+do_test='
+  export GUIX_PROFILE="$test_directory/opt"
+  . $GUIX_PROFILE/etc/profile
+  cd "$test_directory/foo"
+  git config --global user.email "gnu@example.com"
+  git config --global user.name "Gnu Hacker"
+  git --version >"$test_directory/output"
+  git init; git add .gitignore; git commit -m "Initial"
+  git branch a; git branch b
+  git checkout a
+  git add bar.txt; git commit -m "Add bar"
+  git checkout b
+  git add bif.txt; git commit -m "Add bif"
+  git checkout master
+  # Check merge-octopus script which sources libexec/git-core/git-sh-setup
+  git merge a b -m "merge" >>"$test_directory/output"
+'
+if unshare -r true		# Are user namespaces supported?
+then
+    unshare -mrf \
+	    sh -c 'mount -t tmpfs none "$HOME"; # Forbid git to read user configs
+                   mount -t tmpfs none "$STORE_PARENT"; \
+                  '"$do_test"
+    cd -
+else
+    ( $do_test )
+fi
+grep 'git version' "$test_directory/output"
+grep 'octopus' "$test_directory/output"
-- 
2.25.2