guix/build/union.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix build union)
  22   #:use-module (ice-9 match)
  23   #:use-module (ice-9 format)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-26)
  26   #:use-module (rnrs bytevectors)
  27   #:use-module (rnrs io ports)
  28   #:export (union-build))
  29
  30 ;;; Commentary:
  31 ;;;
  32 ;;; Build a directory that is the union of a set of directories, using
  33 ;;; symbolic links.
  34 ;;;
  35 ;;; Code:
  36
  37 (define (files-in-directory dirname)
  38   (let ((dir (opendir dirname)))
  39     (let loop ((files '()))
  40       (match (readdir dir)
  41         ((or "." "..")
  42          (loop files))
  43         ((? eof-object?)
  44          (closedir dir)
  45          (sort files string<?))
  46         (file
  47          (loop (cons file files)))))))
  48
  49 (define (file-is-directory? file)
  50   (match (stat file #f)
  51     (#f #f)                                       ;maybe a dangling symlink
  52     (st (eq? 'directory (stat:type st)))))
  53
  54 (define (file=? file1 file2)
  55   "Return #t if FILE1 and FILE2 are regular files and their contents are
  56 identical, #f otherwise."
  57   (let ((st1 (stat file1 #f))
  58         (st2 (stat file2 #f)))
  59     ;; When deduplication is enabled, identical files share the same inode.
  60     (and st1 st2
  61          (or (= (stat:ino st1) (stat:ino st2))
  62              (and (eq? (stat:type st1) 'regular)
  63                   (eq? (stat:type st2) 'regular)
  64                   (= (stat:size st1) (stat:size st2))
  65                   (call-with-input-file file1
  66                     (lambda (port1)
  67                       (call-with-input-file file2
  68                         (lambda (port2)
  69                           (define len 8192)
  70                           (define buf1 (make-bytevector len))
  71                           (define buf2 (make-bytevector len))
  72                           (let loop ()
  73                             (let ((n1 (get-bytevector-n! port1 buf1 0 len))
  74                                   (n2 (get-bytevector-n! port2 buf2 0 len)))
  75                               (and (equal? n1 n2)
  76                                    (or (eof-object? n1)
  77                                        (loop))))))))))))))
  78
  79 (define* (union-build output inputs
  80                       #:key (log-port (current-error-port))
  81                       (create-all-directories? #f))
  82   "Build in the OUTPUT directory a symlink tree that is the union of all the
  83 INPUTS.  As a special case, if CREATE-ALL-DIRECTORIES?, creates the
  84 subdirectories in the output directory to make sure the caller can modify them
  85 later."
  86
  87   (define (symlink* input output)
  88     (format log-port "`~a' ~~> `~a'~%" input output)
  89     (symlink input output))
  90
  91   (define (resolve-collisions output dirs files)
  92     (cond ((null? dirs)
  93            ;; The inputs are all files.
  94            (format (current-error-port)
  95                    "warning: collision encountered: ~{~a ~}~%"
  96                    files)
  97
  98            (let ((file (first files)))
  99              ;; TODO: Implement smarter strategies.
 100              (format (current-error-port)
 101                      "warning: arbitrarily choosing ~a~%"
 102                      file)
 103
 104              (symlink* file output)))
 105
 106           (else
 107            ;; The inputs are a mixture of files and directories
 108            (error "union-build: collision between file and directories"
 109                   `((files ,files) (dirs ,dirs))))))
 110
 111   (define (union output inputs)
 112     (match inputs
 113       ((input)
 114        ;; There's only one input, so just make a link unless
 115        ;; create-all-directories?.
 116        (if (and create-all-directories? (file-is-directory? input))
 117            (union-of-directories output inputs)
 118            (symlink* input output)))
 119       (_
 120        (call-with-values (lambda () (partition file-is-directory? inputs))
 121          (match-lambda*
 122            ((dirs ())
 123             ;; All inputs are directories.
 124             (union-of-directories output dirs))
 125
 126            ((() (file (? (cut file=? <> file)) ...))
 127             ;; There are no directories, and all files have the same contents,
 128             ;; so there's no conflict.
 129             (symlink* file output))
 130
 131            ((dirs files)
 132             (resolve-collisions output dirs files)))))))
 133
 134   (define (union-of-directories output dirs)
 135     ;; Create a new directory where we will merge the input directories.
 136     (mkdir output)
 137
 138     ;; Build a hash table mapping each file to a list of input
 139     ;; directories containing that file.
 140     (let ((table (make-hash-table)))
 141
 142       (define (add-to-table! file dir)
 143         (hash-set! table file (cons dir (hash-ref table file '()))))
 144
 145       ;; Populate the table.
 146       (for-each (lambda (dir)
 147                   (for-each (cut add-to-table! <> dir)
 148                             (files-in-directory dir)))
 149                 dirs)
 150
 151       ;; Now iterate over the table and recursively
 152       ;; perform a union for each entry.
 153       (hash-for-each (lambda (file dirs-with-file)
 154                        (union (string-append output "/" file)
 155                               (map (cut string-append <> "/" file)
 156                                    (reverse dirs-with-file))))
 157                      table)))
 158
 159   (setvbuf (current-output-port) _IOLBF)
 160   (setvbuf (current-error-port) _IOLBF)
 161   (when (file-port? log-port)
 162     (setvbuf log-port _IOLBF))
 163
 164   (union-of-directories output (delete-duplicates inputs)))
 165
 166 ;;; union.scm ends here