246 lines
8.7 KiB
Scheme
246 lines
8.7 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
|
||
;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
|
||
;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com>
|
||
;;;
|
||
;;; This file is part of GNU Guix.
|
||
;;;
|
||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||
;;; under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||
;;; your option) any later version.
|
||
;;;
|
||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (guix build union)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (ice-9 format)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-26)
|
||
#:use-module (rnrs bytevectors)
|
||
#:use-module (rnrs io ports)
|
||
#:export (union-build
|
||
|
||
warn-about-collision
|
||
|
||
relative-file-name
|
||
symlink-relative))
|
||
|
||
;;; Commentary:
|
||
;;;
|
||
;;; Build a directory that is the union of a set of directories, using
|
||
;;; symbolic links.
|
||
;;;
|
||
;;; Code:
|
||
|
||
;; This code can be used with the bootstrap Guile, which is Guile 2.0, so
|
||
;; provide a compatibility layer.
|
||
(cond-expand
|
||
((and guile-2 (not guile-2.2))
|
||
(define (setvbuf port mode . rest)
|
||
(apply (@ (guile) setvbuf) port
|
||
(match mode
|
||
('line _IOLBF)
|
||
('block _IOFBF)
|
||
('none _IONBF))
|
||
rest)))
|
||
(else #f))
|
||
|
||
(define (files-in-directory dirname)
|
||
(let ((dir (opendir dirname)))
|
||
(let loop ((files '()))
|
||
(match (readdir dir)
|
||
((or "." "..")
|
||
(loop files))
|
||
((? eof-object?)
|
||
(closedir dir)
|
||
(sort files string<?))
|
||
(file
|
||
(loop (cons file files)))))))
|
||
|
||
(define (file-is-directory? 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 #f))
|
||
(st2 (stat file2 #f)))
|
||
;; When deduplication is enabled, identical files share the same inode.
|
||
(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 %harmless-collisions
|
||
;; This is a list of files that are known to collide, but for which emitting
|
||
;; a warning doesn't make sense. For example, "icon-theme.cache" is
|
||
;; regenerated by a profile hook which shadows the file provided by
|
||
;; individual packages, and "gschemas.compiled" is made available to
|
||
;; applications via 'glib-or-gtk-build-system'.
|
||
'("icon-theme.cache" "gschemas.compiled"))
|
||
|
||
(define (warn-about-collision files)
|
||
"Handle the collision among FILES by emitting a warning and choosing the
|
||
first one of THEM."
|
||
(let ((file (first files)))
|
||
(unless (member (basename file) %harmless-collisions)
|
||
(format (current-error-port)
|
||
"~%warning: collision encountered:~%~{ ~a~%~}"
|
||
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)
|
||
(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.
|
||
|
||
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)
|
||
(symlink input output))
|
||
|
||
(define (resolve-collisions output dirs files)
|
||
(cond ((null? dirs)
|
||
;; The inputs are all files.
|
||
(match (resolve-collision files)
|
||
(#f #f)
|
||
((? string? file)
|
||
(symlink* file output))))
|
||
|
||
(else
|
||
;; The inputs are a mixture of files and directories
|
||
(error "union-build: collision between file and directories"
|
||
`((files ,files) (dirs ,dirs))))))
|
||
|
||
(define (union output inputs)
|
||
(match inputs
|
||
((input)
|
||
;; There's only one input, so just make a link unless
|
||
;; create-all-directories?.
|
||
(if (and create-all-directories? (file-is-directory? input))
|
||
(union-of-directories output inputs)
|
||
(symlink* input output)))
|
||
(_
|
||
(call-with-values (lambda () (partition file-is-directory? inputs))
|
||
(match-lambda*
|
||
((dirs ())
|
||
;; All inputs are directories.
|
||
(union-of-directories output dirs))
|
||
|
||
((() (file (? (cut file=? <> file)) ...))
|
||
;; There are no directories, and all files have the same contents,
|
||
;; so there's no conflict.
|
||
(symlink* file output))
|
||
|
||
((dirs files)
|
||
(resolve-collisions output dirs files)))))))
|
||
|
||
(define (union-of-directories output dirs)
|
||
;; Create a new directory where we will merge the input directories.
|
||
(mkdir output)
|
||
|
||
;; Build a hash table mapping each file to a list of input
|
||
;; directories containing that file.
|
||
(let ((table (make-hash-table)))
|
||
|
||
(define (add-to-table! file dir)
|
||
(hash-set! table file (cons dir (hash-ref table file '()))))
|
||
|
||
;; Populate the table.
|
||
(for-each (lambda (dir)
|
||
(for-each (cut add-to-table! <> dir)
|
||
(files-in-directory dir)))
|
||
dirs)
|
||
|
||
;; Now iterate over the table and recursively
|
||
;; perform a union for each entry.
|
||
(hash-for-each (lambda (file dirs-with-file)
|
||
(union (string-append output "/" file)
|
||
(map (cut string-append <> "/" file)
|
||
(reverse dirs-with-file))))
|
||
table)))
|
||
|
||
(setvbuf (current-output-port) 'line)
|
||
(setvbuf (current-error-port) 'line)
|
||
(when (file-port? log-port)
|
||
(setvbuf log-port 'line))
|
||
|
||
(union-of-directories output (delete-duplicates inputs)))
|
||
|
||
|
||
;;;
|
||
;;; Relative symlinks.
|
||
;;;
|
||
|
||
(define %not-slash
|
||
(char-set-complement (char-set #\/)))
|
||
|
||
(define (relative-file-name reference file)
|
||
"Given REFERENCE and FILE, both of which are absolute file names, return the
|
||
file name of FILE relative to REFERENCE.
|
||
|
||
(relative-file-name \"/gnu/store/foo\" \"/gnu/store/bin/bar\")
|
||
=> \"../bin/bar\"
|
||
|
||
Note that this is from a purely lexical standpoint; conversely, \"..\" is
|
||
*not* resolved lexically on POSIX in the presence of symlinks."
|
||
(if (and (string-prefix? "/" file) (string-prefix? "/" reference))
|
||
(let loop ((reference (string-tokenize reference %not-slash))
|
||
(file (string-tokenize file %not-slash)))
|
||
(define (finish)
|
||
(string-join (append (make-list (length reference) "..") file)
|
||
"/"))
|
||
|
||
(match reference
|
||
(()
|
||
(finish))
|
||
((head . tail)
|
||
(match file
|
||
(()
|
||
(finish))
|
||
((head* . tail*)
|
||
(if (string=? head head*)
|
||
(loop tail tail*)
|
||
(finish)))))))
|
||
file))
|
||
|
||
(define (symlink-relative old new)
|
||
"Assuming both OLD and NEW are absolute file names, make NEW a symlink to
|
||
OLD, but using a relative file name."
|
||
(symlink (relative-file-name (dirname new) old)
|
||
new))
|
||
|
||
;;; union.scm ends here
|