From 22ef06b801b284760b4ffd9587ea1a3dffd31baa Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 18 May 2017 11:35:45 +0200
Subject: union: Gracefully handle dangling symlinks in the input.

Fixes <http://bugs.gnu.org/26949>.
Reported by Pjotr Prins <pjotr.public12@thebird.nl>.

* guix/build/union.scm (file-is-directory?): Return #f when FILE does
not exist or is a dangling symlink.
(file=?): Pass #f as a second argument to 'stat'; return #f when both
ST1 or ST2 is #f.
* tests/profiles.scm (test-equalm): New macro.
("union vs. dangling symlink"): New test.
---
 tests/profiles.scm | 29 +++++++++++++++++++++++++++++
 1 file changed, 29 insertions(+)

(limited to 'tests')

diff --git a/tests/profiles.scm b/tests/profiles.scm
index d0b1e14a86..093422792f 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -50,6 +50,12 @@ (define-syntax-rule (test-assertm name exp)
     (run-with-store %store exp
                     #:guile-for-build (%guile-for-build))))
 
+(define-syntax-rule (test-equalm name value exp)
+  (test-equal name
+    value
+    (run-with-store %store exp
+                    #:guile-for-build (%guile-for-build))))
+
 ;; Example manifest entries.
 
 (define guile-1.8.8
@@ -366,6 +372,29 @@ (define (find-input name)
                                get-string-all)
                              "foo!"))))))
 
+(test-equalm "union vs. dangling symlink"        ;<https://bugs.gnu.org/26949>
+  "does-not-exist"
+  (mlet* %store-monad
+      ((thing1 ->  (dummy-package "dummy"
+                     (build-system trivial-build-system)
+                     (arguments
+                      `(#:guile ,%bootstrap-guile
+                        #:builder
+                        (let ((out (assoc-ref %outputs "out")))
+                          (mkdir out)
+                          (symlink "does-not-exist"
+                                   (string-append out "/dangling"))
+                          #t)))))
+       (thing2 ->  (package (inherit thing1) (name "dummy2")))
+       (drv        (profile-derivation (packages->manifest
+                                        (list thing1 thing2))
+                                       #:hooks '()
+                                       #:locales? #f))
+       (profile -> (derivation->output-path drv)))
+    (mbegin %store-monad
+      (built-derivations (list drv))
+      (return (readlink (readlink (string-append profile "/dangling")))))))
+
 (test-end "profiles")
 
 ;;; Local Variables:
-- 
cgit v1.2.3