Commit | Line | Data |
---|---|---|
fb59e275 | 1 | ;;; GNU Guix --- Functional package management for GNU |
e4297aa8 | 2 | ;;; Copyright © 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org> |
5a1add37 | 3 | ;;; Copyright © 2016 Mark H Weaver <mhw@netris.org> |
fb59e275 LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix build graft) | |
21 | #:use-module (guix build utils) | |
93c33389 | 22 | #:use-module (guix build debug-link) |
fb59e275 | 23 | #:use-module (rnrs bytevectors) |
5a1add37 | 24 | #:use-module (ice-9 vlist) |
fb59e275 | 25 | #:use-module (ice-9 match) |
333c376c | 26 | #:use-module (ice-9 threads) |
5a1add37 MW |
27 | #:use-module (ice-9 binary-ports) |
28 | #:use-module (srfi srfi-1) ; list library | |
29 | #:use-module (srfi srfi-26) ; cut and cute | |
fb59e275 | 30 | #:export (replace-store-references |
e4297aa8 LC |
31 | rewrite-directory |
32 | graft)) | |
fb59e275 LC |
33 | |
34 | ;;; Commentary: | |
35 | ;;; | |
36 | ;;; This module supports "grafts". Grafting a directory means rewriting it, | |
37 | ;;; with references to some specific items replaced by references to other | |
38 | ;;; store items---the grafts. | |
39 | ;;; | |
40 | ;;; This method is used to provide fast security updates as only the leaves of | |
41 | ;;; the dependency graph need to be grafted, even when the security updates | |
42 | ;;; affect a core component such as Bash or libc. It is based on the idea of | |
43 | ;;; 'replace-dependency' implemented by Shea Levy in Nixpkgs. | |
44 | ;;; | |
45 | ;;; Code: | |
46 | ||
5a1add37 MW |
47 | (define-syntax-rule (define-inline name val) |
48 | (define-syntax name (identifier-syntax val))) | |
49 | ||
50 | (define-inline hash-length 32) | |
51 | ||
52 | (define nix-base32-char? | |
53 | (cute char-set-contains? | |
54 | ;; ASCII digits and lower case letters except e o t u | |
55 | (string->char-set "0123456789abcdfghijklmnpqrsvwxyz") | |
56 | <>)) | |
57 | ||
58 | (define* (replace-store-references input output replacement-table | |
fb59e275 | 59 | #:optional (store (%store-directory))) |
5a1add37 MW |
60 | "Read data from INPUT, replacing store references according to |
61 | REPLACEMENT-TABLE, and writing the result to OUTPUT. REPLACEMENT-TABLE is a | |
57bdd79e LC |
62 | vhash that maps strings (original hashes) to bytevectors (replacement strings |
63 | comprising the replacement hash, a dash, and a string). | |
64 | ||
5a1add37 MW |
65 | Note: We use string keys to work around the fact that guile-2.0 hashes all |
66 | bytevectors to the same value." | |
67 | ||
68 | (define (lookup-replacement s) | |
69 | (match (vhash-assoc s replacement-table) | |
70 | ((origin . replacement) | |
71 | replacement) | |
72 | (#f #f))) | |
73 | ||
74 | (define (optimize-u8-predicate pred) | |
75 | (cute vector-ref | |
76 | (list->vector (map pred (iota 256))) | |
77 | <>)) | |
78 | ||
79 | (define nix-base32-byte? | |
80 | (optimize-u8-predicate | |
81 | (compose nix-base32-char? | |
82 | integer->char))) | |
83 | ||
84 | (define (dash? byte) (= byte 45)) | |
85 | ||
86 | (define request-size (expt 2 20)) ; 1 MiB | |
87 | ||
88 | ;; We scan the file for the following 33-byte pattern: 32 bytes of | |
89 | ;; nix-base32 characters followed by a dash. To accommodate large files, | |
90 | ;; we do not read the entire file, but instead work on buffers of up to | |
91 | ;; 'request-size' bytes. To ensure that every 33-byte sequence appears | |
92 | ;; entirely within exactly one buffer, adjacent buffers must overlap, | |
93 | ;; i.e. they must share 32 byte positions. We accomplish this by | |
94 | ;; "ungetting" the last 32 bytes of each buffer before reading the next | |
95 | ;; buffer, unless we know that we've reached the end-of-file. | |
96 | (let ((buffer (make-bytevector request-size))) | |
97 | (let loop () | |
98 | ;; Note: We avoid 'get-bytevector-n' to work around | |
99 | ;; <http://bugs.gnu.org/17466>. | |
100 | (match (get-bytevector-n! input buffer 0 request-size) | |
101 | ((? eof-object?) 'done) | |
102 | (end | |
103 | ;; We scan the buffer for dashes that might be preceded by a | |
104 | ;; nix-base32 hash. The key optimization here is that whenever we | |
105 | ;; find a NON-nix-base32 character at position 'i', we know that it | |
106 | ;; cannot be part of a hash, so the earliest position where the next | |
107 | ;; hash could start is i+1 with the following dash at position i+33. | |
108 | ;; | |
109 | ;; Since nix-base32 characters comprise only 1/8 of the 256 possible | |
110 | ;; byte values, and exclude some of the most common letters in | |
111 | ;; English text (e t o u), in practice we can advance by 33 positions | |
112 | ;; most of the time. | |
113 | (let scan-from ((i hash-length) (written 0)) | |
114 | ;; 'i' is the first position where we look for a dash. 'written' | |
115 | ;; is the number of bytes in the buffer that have already been | |
116 | ;; written. | |
117 | (if (< i end) | |
118 | (let ((byte (bytevector-u8-ref buffer i))) | |
119 | (cond ((and (dash? byte) | |
120 | ;; We've found a dash. Note that we do not know | |
121 | ;; whether the preceeding 32 bytes are nix-base32 | |
122 | ;; characters, but we do not need to know. If | |
123 | ;; they are not, the following lookup will fail. | |
124 | (lookup-replacement | |
125 | (string-tabulate (lambda (j) | |
126 | (integer->char | |
127 | (bytevector-u8-ref buffer | |
128 | (+ j (- i hash-length))))) | |
129 | hash-length))) | |
130 | => (lambda (replacement) | |
131 | ;; We've found a hash that needs to be replaced. | |
132 | ;; First, write out all bytes preceding the hash | |
133 | ;; that have not yet been written. | |
134 | (put-bytevector output buffer written | |
135 | (- i hash-length written)) | |
57bdd79e | 136 | ;; Now write the replacement string. |
5a1add37 MW |
137 | (put-bytevector output replacement) |
138 | ;; Since the byte at position 'i' is a dash, | |
139 | ;; which is not a nix-base32 char, the earliest | |
140 | ;; position where the next hash might start is | |
141 | ;; i+1, and the earliest position where the | |
142 | ;; following dash might start is (+ i 1 | |
57bdd79e LC |
143 | ;; hash-length). Also, increase the write |
144 | ;; position to account for REPLACEMENT. | |
145 | (let ((len (bytevector-length replacement))) | |
146 | (scan-from (+ i 1 len) | |
147 | (+ i (- len hash-length)))))) | |
5a1add37 MW |
148 | ;; If the byte at position 'i' is a nix-base32 char, |
149 | ;; then the dash we're looking for might be as early as | |
150 | ;; the following byte, so we can only advance by 1. | |
151 | ((nix-base32-byte? byte) | |
152 | (scan-from (+ i 1) written)) | |
153 | ;; If the byte at position 'i' is NOT a nix-base32 | |
154 | ;; char, then the earliest position where the next hash | |
155 | ;; might start is i+1, with the following dash at | |
156 | ;; position (+ i 1 hash-length). | |
157 | (else | |
158 | (scan-from (+ i 1 hash-length) written)))) | |
159 | ||
160 | ;; We have finished scanning the buffer. Now we determine how | |
161 | ;; many bytes have not yet been written, and how many bytes to | |
162 | ;; "unget". If 'end' is less than 'request-size' then we read | |
163 | ;; less than we asked for, which indicates that we are at EOF, | |
164 | ;; so we needn't unget anything. Otherwise, we unget up to | |
165 | ;; 'hash-length' bytes (32 bytes). However, we must be careful | |
166 | ;; not to unget bytes that have already been written, because | |
167 | ;; that would cause them to be written again from the next | |
168 | ;; buffer. In practice, this case occurs when a replacement is | |
94e86a6b LC |
169 | ;; made near or beyond the end of the buffer. When REPLACEMENT |
170 | ;; went beyond END, we consume the extra bytes from INPUT. | |
171 | (begin | |
172 | (if (> written end) | |
173 | (get-bytevector-n! input buffer 0 (- written end)) | |
174 | (let* ((unwritten (- end written)) | |
175 | (unget-size (if (= end request-size) | |
176 | (min hash-length unwritten) | |
177 | 0)) | |
178 | (write-size (- unwritten unget-size))) | |
179 | (put-bytevector output buffer written write-size) | |
180 | (unget-bytevector input buffer (+ written write-size) | |
181 | unget-size))) | |
5a1add37 | 182 | (loop))))))))) |
fb59e275 | 183 | |
ece6864b LC |
184 | (define (rename-matching-files directory mapping) |
185 | "Apply MAPPING to the names of all the files in DIRECTORY, where MAPPING is | |
186 | a list of store file name pairs." | |
187 | (let* ((mapping (map (match-lambda | |
188 | ((source . target) | |
189 | (cons (basename source) (basename target)))) | |
190 | mapping)) | |
191 | (matches (find-files directory | |
192 | (lambda (file stat) | |
193 | (assoc-ref mapping (basename file))) | |
194 | #:directories? #t))) | |
195 | ||
196 | ;; XXX: This is not quite correct: if MAPPING contains "foo", and | |
197 | ;; DIRECTORY contains "bar/foo/foo", we first rename "bar/foo" and then | |
198 | ;; "bar/foo/foo" no longer exists so we fail. Oh well, surely that's good | |
199 | ;; enough! | |
200 | (for-each (lambda (file) | |
201 | (let ((target (assoc-ref mapping (basename file)))) | |
202 | (rename-file file | |
203 | (string-append (dirname file) "/" target)))) | |
204 | matches))) | |
205 | ||
007c20b6 LC |
206 | (define (exit-on-exception proc) |
207 | "Return a procedure that wraps PROC so that 'primitive-exit' is called when | |
208 | an exception is caught." | |
209 | (lambda (arg) | |
210 | (catch #t | |
211 | (lambda () | |
212 | (proc arg)) | |
213 | (lambda (key . args) | |
214 | ;; Since ports are not thread-safe as of Guile 2.0, reopen stderr. | |
215 | (let ((port (fdopen 2 "w0"))) | |
216 | (print-exception port #f key args) | |
217 | (primitive-exit 1)))))) | |
218 | ||
412716ef | 219 | ;; We need this as long as we support Guile < 2.0.13. |
d7226786 LC |
220 | (define* (mkdir-p* dir #:optional (mode #o755)) |
221 | "This is a variant of 'mkdir-p' that works around | |
222 | <http://bugs.gnu.org/24659> by passing MODE explicitly in each 'mkdir' call." | |
223 | (define absolute? | |
224 | (string-prefix? "/" dir)) | |
225 | ||
226 | (define not-slash | |
227 | (char-set-complement (char-set #\/))) | |
228 | ||
229 | (let loop ((components (string-tokenize dir not-slash)) | |
230 | (root (if absolute? | |
231 | "" | |
232 | "."))) | |
233 | (match components | |
234 | ((head tail ...) | |
235 | (let ((path (string-append root "/" head))) | |
236 | (catch 'system-error | |
237 | (lambda () | |
238 | (mkdir path mode) | |
239 | (loop tail path)) | |
240 | (lambda args | |
241 | (if (= EEXIST (system-error-errno args)) | |
242 | (loop tail path) | |
243 | (apply throw args)))))) | |
244 | (() #t)))) | |
245 | ||
fb59e275 LC |
246 | (define* (rewrite-directory directory output mapping |
247 | #:optional (store (%store-directory))) | |
248 | "Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of | |
249 | file name pairs." | |
5a1add37 MW |
250 | |
251 | (define hash-mapping | |
57bdd79e LC |
252 | ;; List of hash/replacement pairs, where the hash is a nix-base32 string |
253 | ;; and the replacement is a string that includes the replacement's name, | |
254 | ;; like "r837zajjc1q8z9hph4b6860a9c05blyy-openssl-1.0.2j". | |
5a1add37 MW |
255 | (let* ((prefix (string-append store "/")) |
256 | (start (string-length prefix)) | |
257 | (end (+ start hash-length))) | |
258 | (define (valid-hash? h) | |
259 | (every nix-base32-char? (string->list h))) | |
57bdd79e | 260 | (define (hash+rest s) |
5a1add37 | 261 | (and (< end (string-length s)) |
57bdd79e LC |
262 | (let ((hash (substring s start end)) |
263 | (all (substring s start))) | |
5a1add37 | 264 | (and (string-prefix? prefix s) |
57bdd79e LC |
265 | (valid-hash? hash) |
266 | (eqv? #\- (string-ref s end)) | |
267 | (list hash all))))) | |
268 | ||
5a1add37 | 269 | (map (match-lambda |
57bdd79e | 270 | (((= hash+rest (origin-hash origin-string)) |
5a1add37 | 271 | . |
57bdd79e LC |
272 | (= hash+rest (replacement-hash replacement-string))) |
273 | (unless (= (string-length origin-string) | |
274 | (string-length replacement-string)) | |
275 | (error "replacement length differs from the original length" | |
276 | origin-string replacement-string)) | |
277 | (cons origin-hash (string->utf8 replacement-string))) | |
5a1add37 MW |
278 | ((origin . replacement) |
279 | (error "invalid replacement" origin replacement))) | |
280 | mapping))) | |
281 | ||
282 | (define replacement-table | |
283 | (alist->vhash hash-mapping)) | |
284 | ||
fb59e275 LC |
285 | (define prefix-len |
286 | (string-length directory)) | |
287 | ||
288 | (define (destination file) | |
289 | (string-append output (string-drop file prefix-len))) | |
290 | ||
9c88f655 LC |
291 | (define (rewrite-leaf file) |
292 | (let ((stat (lstat file)) | |
293 | (dest (destination file))) | |
d7226786 | 294 | (mkdir-p* (dirname dest)) |
9c88f655 LC |
295 | (case (stat:type stat) |
296 | ((symlink) | |
297 | (let ((target (readlink file))) | |
298 | (symlink (call-with-output-string | |
299 | (lambda (output) | |
300 | (replace-store-references (open-input-string target) | |
5a1add37 | 301 | output replacement-table |
9c88f655 LC |
302 | store))) |
303 | dest))) | |
304 | ((regular) | |
5a1add37 MW |
305 | (call-with-input-file file |
306 | (lambda (input) | |
307 | (call-with-output-file dest | |
308 | (lambda (output) | |
309 | (replace-store-references input output replacement-table | |
310 | store) | |
311 | (chmod output (stat:perms stat))))))) | |
cf8b312d | 312 | ((directory) |
d7226786 | 313 | (mkdir-p* dest)) |
9c88f655 LC |
314 | (else |
315 | (error "unsupported file type" stat))))) | |
fb59e275 | 316 | |
007c20b6 LC |
317 | ;; Use 'exit-on-exception' to force an exit upon I/O errors, given that |
318 | ;; 'n-par-for-each' silently swallows exceptions. | |
319 | ;; See <http://bugs.gnu.org/23581>. | |
333c376c | 320 | (n-par-for-each (parallel-job-count) |
007c20b6 LC |
321 | (exit-on-exception rewrite-leaf) |
322 | (find-files directory (const #t) | |
323 | #:directories? #t)) | |
ece6864b | 324 | (rename-matching-files output mapping)) |
fb59e275 | 325 | |
93c33389 LC |
326 | (define %graft-hooks |
327 | ;; Default list of hooks run after grafting. | |
328 | (list graft-debug-links)) | |
329 | ||
e4297aa8 | 330 | (define* (graft old-outputs new-outputs mapping |
93c33389 LC |
331 | #:key (log-port (current-output-port)) |
332 | (hooks %graft-hooks)) | |
e4297aa8 LC |
333 | "Apply the grafts described by MAPPING on OLD-OUTPUTS, leading to |
334 | NEW-OUTPUTS. MAPPING must be a list of file name pairs; OLD-OUTPUTS and | |
335 | NEW-OUTPUTS are lists of output name/file name pairs." | |
336 | (for-each (lambda (input output) | |
337 | (format log-port "grafting '~a' -> '~a'...~%" input output) | |
338 | (force-output) | |
339 | (rewrite-directory input output mapping)) | |
340 | (match old-outputs | |
341 | (((names . files) ...) | |
342 | files)) | |
343 | (match new-outputs | |
344 | (((names . files) ...) | |
93c33389 LC |
345 | files))) |
346 | (for-each (lambda (hook) | |
347 | (hook old-outputs new-outputs mapping | |
348 | #:log-port log-port)) | |
349 | hooks)) | |
e4297aa8 | 350 | |
fb59e275 | 351 | ;;; graft.scm ends here |