01/01: union: Gracefully handle dangling symlinks in the input.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 22ef06b801b284760b4ffd9587ea1a3dffd31baa
Author: Ludovic Courtès <address@hidden>
Date:   Thu May 18 11:35:45 2017 +0200

    union: Gracefully handle dangling symlinks in the input.
    
    Fixes <http://bugs.gnu.org/26949>.
    Reported by Pjotr Prins <address@hidden>.
    
    * 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.
---
 .dir-locals.el       |  1 +
 guix/build/union.scm | 43 +++++++++++++++++++++++--------------------
 tests/profiles.scm   | 29 +++++++++++++++++++++++++++++
 3 files changed, 53 insertions(+), 20 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 4aaeae9..04b58d2 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -17,6 +17,7 @@
    (eval . (put 'call-with-prompt 'scheme-indent-function 1))
    (eval . (put 'test-assert 'scheme-indent-function 1))
    (eval . (put 'test-assertm 'scheme-indent-function 1))
+   (eval . (put 'test-equalm 'scheme-indent-function 1))
    (eval . (put 'test-equal 'scheme-indent-function 1))
    (eval . (put 'test-eq 'scheme-indent-function 1))
    (eval . (put 'call-with-input-string 'scheme-indent-function 1))
diff --git a/guix/build/union.scm b/guix/build/union.scm
index a2ea72e..18167fa 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -47,31 +47,34 @@
          (loop (cons file files)))))))
 
 (define (file-is-directory? file)
-  (eq? 'directory (stat:type (stat file))))
+  (match (stat file #f)
+    (#f #f)                                       ;maybe a dangling symlink
+    (st (eq? 'directory (stat:type st)))))
 
 (define (file=? file1 file2)
   "Return #t if FILE1 and FILE2 are regular files and their contents are
 identical, #f otherwise."
-  (let ((st1 (stat file1))
-        (st2 (stat file2)))
+  (let ((st1 (stat file1 #f))
+        (st2 (stat file2 #f)))
     ;; When deduplication is enabled, identical files share the same inode.
-    (or (= (stat:ino st1) (stat:ino st2))
-        (and (eq? (stat:type st1) 'regular)
-             (eq? (stat:type st2) 'regular)
-             (= (stat:size st1) (stat:size st2))
-             (call-with-input-file file1
-               (lambda (port1)
-                 (call-with-input-file file2
-                   (lambda (port2)
-                     (define len 8192)
-                     (define buf1 (make-bytevector len))
-                     (define buf2 (make-bytevector len))
-                     (let loop ()
-                       (let ((n1 (get-bytevector-n! port1 buf1 0 len))
-                             (n2 (get-bytevector-n! port2 buf2 0 len)))
-                         (and (equal? n1 n2)
-                              (or (eof-object? n1)
-                                  (loop)))))))))))))
+    (and st1 st2
+         (or (= (stat:ino st1) (stat:ino st2))
+             (and (eq? (stat:type st1) 'regular)
+                  (eq? (stat:type st2) 'regular)
+                  (= (stat:size st1) (stat:size st2))
+                  (call-with-input-file file1
+                    (lambda (port1)
+                      (call-with-input-file file2
+                        (lambda (port2)
+                          (define len 8192)
+                          (define buf1 (make-bytevector len))
+                          (define buf2 (make-bytevector len))
+                          (let loop ()
+                            (let ((n1 (get-bytevector-n! port1 buf1 0 len))
+                                  (n2 (get-bytevector-n! port2 buf2 0 len)))
+                              (and (equal? n1 n2)
+                                   (or (eof-object? n1)
+                                       (loop))))))))))))))
 
 (define* (union-build output inputs
                       #:key (log-port (current-error-port))
diff --git a/tests/profiles.scm b/tests/profiles.scm
index d0b1e14..0934227 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -50,6 +50,12 @@
     (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 @@
                                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: