guix/build/union.scm

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