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.
This commit is contained in:
Ludovic Courtès 2018-04-08 15:47:11 +02:00
parent 1b92d65a40
commit e40aa54e98
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 65 additions and 13 deletions

@ -25,7 +25,9 @@
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:export (union-build)) #:export (union-build
warn-about-collision))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -76,14 +78,29 @@ identical, #f otherwise."
(or (eof-object? n1) (or (eof-object? n1)
(loop)))))))))))))) (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 (define* (union-build output inputs
#:key (log-port (current-error-port)) #:key (log-port (current-error-port))
(create-all-directories? #f) (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 "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 INPUTS, using SYMLINK to create symlinks. As a special case, if
CREATE-ALL-DIRECTORIES?, creates the subdirectories in the output directory to 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) (define (symlink* input output)
(format log-port "`~a' ~~> `~a'~%" 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) (define (resolve-collisions output dirs files)
(cond ((null? dirs) (cond ((null? dirs)
;; The inputs are all files. ;; The inputs are all files.
(format (current-error-port) (match (resolve-collision files)
"~%warning: collision encountered:~%~{ ~a~%~}" (#f #f)
files) ((? string? file)
(symlink* file output))))
(let ((file (first files)))
;; TODO: Implement smarter strategies.
(format (current-error-port) "warning: choosing ~a~%" file)
(symlink* file output)))
(else (else
;; The inputs are a mixture of files and directories ;; The inputs are a mixture of files and directories

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -124,6 +124,46 @@
;; new 'bin' sub-directory in the profile. ;; new 'bin' sub-directory in the profile.
(eq? 'directory (stat:type (lstat "bin")))))))) (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" (test-assert "union-build #:create-all-directories? #t"
(let* ((build `(begin (let* ((build `(begin
(use-modules (guix build union)) (use-modules (guix build union))