03/13: union: Allow callers to choose the collision resolution policy.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit e40aa54e98aa6329e6196fd29e7e4e34ce3a063c
Author: Ludovic Courtès <address@hidden>
Date:   Sun Apr 8 15:47:11 2018 +0200

    union: Allow callers to choose the collision resolution policy.
    
    * guix/build/union.scm (warn-about-collision): New procedure.
    (union-build): Add #:resolve-collision.
    [resolve-collisions]: Call it.
    * tests/union.scm ("union-build collision first & last"): New test.
---
 guix/build/union.scm | 36 ++++++++++++++++++++++++------------
 tests/union.scm      | 42 +++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 65 insertions(+), 13 deletions(-)

diff --git a/guix/build/union.scm b/guix/build/union.scm
index 5f1cf8e..1179f12 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -25,7 +25,9 @@
   #:use-module (srfi srfi-26)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
-  #:export (union-build))
+  #:export (union-build
+
+            warn-about-collision))
 
 ;;; Commentary:
 ;;;
@@ -76,14 +78,29 @@ identical, #f otherwise."
                                    (or (eof-object? n1)
                                        (loop))))))))))))))
 
+(define (warn-about-collision files)
+  "Handle the collision among FILES by emitting a warning and choosing the
+first one of THEM."
+  (format (current-error-port)
+          "~%warning: collision encountered:~%~{  ~a~%~}"
+          files)
+  (let ((file (first files)))
+    (format (current-error-port) "warning: choosing ~a~%" file)
+    file))
+
 (define* (union-build output inputs
                       #:key (log-port (current-error-port))
                       (create-all-directories? #f)
-                      (symlink symlink))
+                      (symlink symlink)
+                      (resolve-collision warn-about-collision))
   "Build in the OUTPUT directory a symlink tree that is the union of all the
 INPUTS, using SYMLINK to create symlinks.  As a special case, if
 CREATE-ALL-DIRECTORIES?, creates the subdirectories in the output directory to
-make sure the caller can modify them later."
+make sure the caller can modify them later.
+
+When two or more regular files collide, call RESOLVE-COLLISION with the list
+of colliding files and use the one that it returns; or, if RESOLVE-COLLISION
+returns #f, skip the faulty file altogether."
 
   (define (symlink* input output)
     (format log-port "`~a' ~~> `~a'~%" input output)
@@ -92,15 +109,10 @@ make sure the caller can modify them later."
   (define (resolve-collisions output dirs files)
     (cond ((null? dirs)
            ;; The inputs are all files.
-           (format (current-error-port)
-                   "~%warning: collision encountered:~%~{  ~a~%~}"
-                   files)
-
-           (let ((file (first files)))
-             ;; TODO: Implement smarter strategies.
-             (format (current-error-port) "warning: choosing ~a~%" file)
-
-             (symlink* file output)))
+           (match (resolve-collision files)
+             (#f #f)
+             ((? string? file)
+              (symlink* file output))))
 
           (else
            ;; The inputs are a mixture of files and directories
diff --git a/tests/union.scm b/tests/union.scm
index b63edc7..aa95cae 100644
--- a/tests/union.scm
+++ b/tests/union.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2017, 2018 Ludovic Courtès 
<address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -124,6 +124,46 @@
                 ;; new 'bin' sub-directory in the profile.
                 (eq? 'directory (stat:type (lstat "bin"))))))))
 
+(test-assert "union-build collision first & last"
+  (let* ((guile   (package-derivation %store %bootstrap-guile))
+         (fake    (build-expression->derivation
+                   %store "fake-guile"
+                   '(begin
+                      (use-modules (guix build utils))
+                      (let ((out (assoc-ref %outputs "out")))
+                        (mkdir-p (string-append out "/bin"))
+                        (call-with-output-file (string-append out "/bin/guile")
+                          (const #t))))
+                   #:modules '((guix build utils))))
+         (builder (lambda (policy)
+                    `(begin
+                       (use-modules (guix build union)
+                                    (srfi srfi-1))
+                       (union-build (assoc-ref %outputs "out")
+                                    (map cdr %build-inputs)
+                                    #:resolve-collision ,policy))))
+         (drv1
+          (build-expression->derivation %store "union-first"
+                                        (builder 'first)
+                                        #:inputs `(("guile" ,guile)
+                                                   ("fake" ,fake))
+                                        #:modules '((guix build union))))
+         (drv2
+          (build-expression->derivation %store "union-last"
+                                        (builder 'last)
+                                        #:inputs `(("guile" ,guile)
+                                                   ("fake" ,fake))
+                                        #:modules '((guix build union)))))
+    (and (build-derivations %store (list drv1 drv2))
+         (with-directory-excursion (derivation->output-path drv1)
+           (string=? (readlink "bin/guile")
+                     (string-append (derivation->output-path guile)
+                                    "/bin/guile")))
+         (with-directory-excursion (derivation->output-path drv2)
+           (string=? (readlink "bin/guile")
+                     (string-append (derivation->output-path fake)
+                                    "/bin/guile"))))))
+
 (test-assert "union-build #:create-all-directories? #t"
   (let* ((build  `(begin
                     (use-modules (guix build union))