guix/build/union.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018 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             warn-about-collision
  31
  32             relative-file-name))
  33
  34 ;;; Commentary:
  35 ;;;
  36 ;;; Build a directory that is the union of a set of directories, using
  37 ;;; symbolic links.
  38 ;;;
  39 ;;; Code:
  40
  41 (define (files-in-directory dirname)
  42   (let ((dir (opendir dirname)))
  43     (let loop ((files '()))
  44       (match (readdir dir)
  45         ((or "." "..")
  46          (loop files))
  47         ((? eof-object?)
  48          (closedir dir)
  49          (sort files string<?))
  50         (file
  51          (loop (cons file files)))))))
  52
  53 (define (file-is-directory? file)
  54   (match (stat file #f)
  55     (#f #f)                                       ;maybe a dangling symlink
  56     (st (eq? 'directory (stat:type st)))))
  57
  58 (define (file=? file1 file2)
  59   "Return #t if FILE1 and FILE2 are regular files and their contents are
  60 identical, #f otherwise."
  61   (let ((st1 (stat file1 #f))
  62         (st2 (stat file2 #f)))
  63     ;; When deduplication is enabled, identical files share the same inode.
  64     (and st1 st2
  65          (or (= (stat:ino st1) (stat:ino st2))
  66              (and (eq? (stat:type st1) 'regular)
  67                   (eq? (stat:type st2) 'regular)
  68                   (= (stat:size st1) (stat:size st2))
  69                   (call-with-input-file file1
  70                     (lambda (port1)
  71                       (call-with-input-file file2
  72                         (lambda (port2)
  73                           (define len 8192)
  74                           (define buf1 (make-bytevector len))
  75                           (define buf2 (make-bytevector len))
  76                           (let loop ()
  77                             (let ((n1 (get-bytevector-n! port1 buf1 0 len))
  78                                   (n2 (get-bytevector-n! port2 buf2 0 len)))
  79                               (and (equal? n1 n2)
  80                                    (or (eof-object? n1)
  81                                        (loop))))))))))))))
  82
  83 (define (warn-about-collision files)
  84   "Handle the collision among FILES by emitting a warning and choosing the
  85 first one of THEM."
  86   (format (current-error-port)
  87           "~%warning: collision encountered:~%~{  ~a~%~}"
  88           files)
  89   (let ((file (first files)))
  90     (format (current-error-port) "warning: choosing ~a~%" file)
  91     file))
  92
  93 (define* (union-build output inputs
  94                       #:key (log-port (current-error-port))
  95                       (create-all-directories? #f)
  96                       (symlink symlink)
  97                       (resolve-collision warn-about-collision))
  98   "Build in the OUTPUT directory a symlink tree that is the union of all the
  99 INPUTS, using SYMLINK to create symlinks.  As a special case, if
 100 CREATE-ALL-DIRECTORIES?, creates the subdirectories in the output directory to
 101 make sure the caller can modify them later.
 102
 103 When two or more regular files collide, call RESOLVE-COLLISION with the list
 104 of colliding files and use the one that it returns; or, if RESOLVE-COLLISION
 105 returns #f, skip the faulty file altogether."
 106
 107   (define (symlink* input output)
 108     (format log-port "`~a' ~~> `~a'~%" input output)
 109     (symlink input output))
 110
 111   (define (resolve-collisions output dirs files)
 112     (cond ((null? dirs)
 113            ;; The inputs are all files.
 114            (match (resolve-collision files)
 115              (#f #f)
 116              ((? string? file)
 117               (symlink* file output))))
 118
 119           (else
 120            ;; The inputs are a mixture of files and directories
 121            (error "union-build: collision between file and directories"
 122                   `((files ,files) (dirs ,dirs))))))
 123
 124   (define (union output inputs)
 125     (match inputs
 126       ((input)
 127        ;; There's only one input, so just make a link unless
 128        ;; create-all-directories?.
 129        (if (and create-all-directories? (file-is-directory? input))
 130            (union-of-directories output inputs)
 131            (symlink* input output)))
 132       (_
 133        (call-with-values (lambda () (partition file-is-directory? inputs))
 134          (match-lambda*
 135            ((dirs ())
 136             ;; All inputs are directories.
 137             (union-of-directories output dirs))
 138
 139            ((() (file (? (cut file=? <> file)) ...))
 140             ;; There are no directories, and all files have the same contents,
 141             ;; so there's no conflict.
 142             (symlink* file output))
 143
 144            ((dirs files)
 145             (resolve-collisions output dirs files)))))))
 146
 147   (define (union-of-directories output dirs)
 148     ;; Create a new directory where we will merge the input directories.
 149     (mkdir output)
 150
 151     ;; Build a hash table mapping each file to a list of input
 152     ;; directories containing that file.
 153     (let ((table (make-hash-table)))
 154
 155       (define (add-to-table! file dir)
 156         (hash-set! table file (cons dir (hash-ref table file '()))))
 157
 158       ;; Populate the table.
 159       (for-each (lambda (dir)
 160                   (for-each (cut add-to-table! <> dir)
 161                             (files-in-directory dir)))
 162                 dirs)
 163
 164       ;; Now iterate over the table and recursively
 165       ;; perform a union for each entry.
 166       (hash-for-each (lambda (file dirs-with-file)
 167                        (union (string-append output "/" file)
 168                               (map (cut string-append <> "/" file)
 169                                    (reverse dirs-with-file))))
 170                      table)))
 171
 172   (setvbuf (current-output-port) _IOLBF)
 173   (setvbuf (current-error-port) _IOLBF)
 174   (when (file-port? log-port)
 175     (setvbuf log-port _IOLBF))
 176
 177   (union-of-directories output (delete-duplicates inputs)))
 178
 179 \f
 180 ;;;
 181 ;;; Relative symlinks.
 182 ;;;
 183
 184 (define %not-slash
 185   (char-set-complement (char-set #\/)))
 186
 187 (define (relative-file-name reference file)
 188   "Given REFERENCE and FILE, both of which are absolute file names, return the
 189 file name of FILE relative to REFERENCE.
 190
 191   (relative-file-name \"/gnu/store/foo\" \"/gnu/store/bin/bar\")
 192   => \"../bin/bar\"
 193
 194 Note that this is from a purely lexical standpoint; conversely, \"..\" is
 195 *not* resolved lexically on POSIX in the presence of symlinks."
 196   (if (and (string-prefix? "/" file) (string-prefix? "/" reference))
 197       (let loop ((reference (string-tokenize reference %not-slash))
 198                  (file      (string-tokenize file %not-slash)))
 199         (define (finish)
 200           (string-join (append (make-list (length reference) "..") file)
 201                        "/"))
 202
 203         (match reference
 204           (()
 205            (finish))
 206           ((head . tail)
 207            (match file
 208              (()
 209               (finish))
 210              ((head* . tail*)
 211               (if (string=? head head*)
 212                   (loop tail tail*)
 213                   (finish)))))))
 214       file))
 215
 216 ;;; union.scm ends here