summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2018-04-08 15:47:11 +0200
committerLudovic Courtès <ludo@gnu.org>2018-04-08 17:41:08 +0200
commite40aa54e98aa6329e6196fd29e7e4e34ce3a063c (patch)
tree5870bf79fd29d882c371c0dfcb11626a617584e4
parent1b92d65a40a2cf6028bfc0efb7d7d007d76d008a (diff)
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.
-rw-r--r--guix/build/union.scm36
-rw-r--r--tests/union.scm42
2 files changed, 65 insertions, 13 deletions
diff --git a/guix/build/union.scm b/guix/build/union.scm
index 5f1cf8e450..1179f1234b 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 b63edc757b..aa95cae001 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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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))