Commit | Line | Data |
---|---|---|
4155e2a9 | 1 | ;;; GNU Guix --- Functional package management for GNU |
76832d34 | 2 | ;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
12129998 | 3 | ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> |
addce19e | 4 | ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> |
c8c88afa | 5 | ;;; |
4155e2a9 | 6 | ;;; This file is part of GNU Guix. |
c8c88afa | 7 | ;;; |
4155e2a9 | 8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
c8c88afa LC |
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 | ;;; | |
4155e2a9 | 13 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
c8c88afa LC |
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 | |
4155e2a9 | 19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
c8c88afa LC |
20 | |
21 | (define-module (guix build union) | |
c8c88afa | 22 | #:use-module (ice-9 match) |
b2d58cd8 | 23 | #:use-module (ice-9 format) |
c8c88afa LC |
24 | #:use-module (srfi srfi-1) |
25 | #:use-module (srfi srfi-26) | |
cdbca518 LC |
26 | #:use-module (rnrs bytevectors) |
27 | #:use-module (rnrs io ports) | |
e40aa54e LC |
28 | #:export (union-build |
29 | ||
dac1c97d LC |
30 | warn-about-collision |
31 | ||
e00ade3f LC |
32 | relative-file-name |
33 | symlink-relative)) | |
c8c88afa LC |
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 | ||
76832d34 LC |
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 | ||
12129998 MW |
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) | |
22ef06b8 LC |
68 | (match (stat file #f) |
69 | (#f #f) ;maybe a dangling symlink | |
70 | (st (eq? 'directory (stat:type st))))) | |
b2d58cd8 | 71 | |
cdbca518 | 72 | (define (file=? file1 file2) |
6ede17ca LC |
73 | "Return #t if FILE1 and FILE2 are regular files and their contents are |
74 | identical, #f otherwise." | |
22ef06b8 LC |
75 | (let ((st1 (stat file1 #f)) |
76 | (st2 (stat file2 #f))) | |
af98798c | 77 | ;; When deduplication is enabled, identical files share the same inode. |
22ef06b8 LC |
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)))))))))))))) | |
cdbca518 | 96 | |
827c5651 LC |
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 | ||
e40aa54e LC |
105 | (define (warn-about-collision files) |
106 | "Handle the collision among FILES by emitting a warning and choosing the | |
107 | first one of THEM." | |
e40aa54e | 108 | (let ((file (first files))) |
827c5651 LC |
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)) | |
e40aa54e LC |
114 | file)) |
115 | ||
12129998 | 116 | (define* (union-build output inputs |
addce19e | 117 | #:key (log-port (current-error-port)) |
59523429 | 118 | (create-all-directories? #f) |
e40aa54e LC |
119 | (symlink symlink) |
120 | (resolve-collision warn-about-collision)) | |
addce19e | 121 | "Build in the OUTPUT directory a symlink tree that is the union of all the |
59523429 LC |
122 | INPUTS, using SYMLINK to create symlinks. As a special case, if |
123 | CREATE-ALL-DIRECTORIES?, creates the subdirectories in the output directory to | |
e40aa54e LC |
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." | |
12129998 MW |
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. | |
e40aa54e LC |
137 | (match (resolve-collision files) |
138 | (#f #f) | |
139 | ((? string? file) | |
140 | (symlink* file output)))) | |
12129998 MW |
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) | |
addce19e HY |
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))) | |
12129998 MW |
155 | (_ |
156 | (call-with-values (lambda () (partition file-is-directory? inputs)) | |
157 | (match-lambda* | |
158 | ((dirs ()) | |
6a0b30f3 MW |
159 | ;; All inputs are directories. |
160 | (union-of-directories output dirs)) | |
12129998 MW |
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))))))) | |
b2d58cd8 | 169 | |
6a0b30f3 MW |
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 | ||
76832d34 LC |
195 | (setvbuf (current-output-port) 'line) |
196 | (setvbuf (current-error-port) 'line) | |
c065c443 | 197 | (when (file-port? log-port) |
76832d34 | 198 | (setvbuf log-port 'line)) |
c8c88afa | 199 | |
6a0b30f3 | 200 | (union-of-directories output (delete-duplicates inputs))) |
c8c88afa | 201 | |
dac1c97d LC |
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 | ||
e00ade3f LC |
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 | ||
c8c88afa | 245 | ;;; union.scm ends here |