daemon: Substitute queries return immediately when substitutes are disabled.
[jackhill/guix/guix.git] / tests / store.scm
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
3 ;;;
4 ;;; This file is part of GNU Guix.
5 ;;;
6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
10 ;;;
11 ;;; GNU Guix is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
18
19 (define-module (test-store)
20 #:use-module (guix tests)
21 #:use-module (guix store)
22 #:use-module (guix utils)
23 #:use-module (guix monads)
24 #:use-module (guix hash)
25 #:use-module (guix base32)
26 #:use-module (guix packages)
27 #:use-module (guix derivations)
28 #:use-module (guix serialization)
29 #:use-module (guix build utils)
30 #:use-module (guix gexp)
31 #:use-module (gnu packages)
32 #:use-module (gnu packages bootstrap)
33 #:use-module (ice-9 match)
34 #:use-module (rnrs bytevectors)
35 #:use-module (rnrs io ports)
36 #:use-module (web uri)
37 #:use-module (srfi srfi-1)
38 #:use-module (srfi srfi-11)
39 #:use-module (srfi srfi-26)
40 #:use-module (srfi srfi-34)
41 #:use-module (srfi srfi-64))
42
43 ;; Test the (guix store) module.
44
45 (define %store
46 (open-connection-for-tests))
47
48 \f
49 (test-begin "store")
50
51 (test-equal "store-path-hash-part"
52 "283gqy39v3g9dxjy26rynl0zls82fmcg"
53 (store-path-hash-part
54 (string-append (%store-prefix)
55 "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
56
57 (test-equal "store-path-hash-part #f"
58 #f
59 (store-path-hash-part
60 (string-append (%store-prefix)
61 "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
62
63 (test-equal "store-path-package-name"
64 "guile-2.0.7"
65 (store-path-package-name
66 (string-append (%store-prefix)
67 "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
68
69 (test-equal "store-path-package-name #f"
70 #f
71 (store-path-package-name
72 "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))
73
74 (test-assert "direct-store-path?"
75 (and (direct-store-path?
76 (string-append (%store-prefix)
77 "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))
78 (not (direct-store-path?
79 (string-append
80 (%store-prefix)
81 "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile")))
82 (not (direct-store-path? (%store-prefix)))))
83
84 (test-skip (if %store 0 13))
85
86 (test-assert "valid-path? live"
87 (let ((p (add-text-to-store %store "hello" "hello, world")))
88 (valid-path? %store p)))
89
90 (test-assert "valid-path? false"
91 (not (valid-path? %store
92 (string-append (%store-prefix) "/"
93 (make-string 32 #\e) "-foobar"))))
94
95 (test-assert "valid-path? error"
96 (with-store s
97 (guard (c ((nix-protocol-error? c) #t))
98 (valid-path? s "foo")
99 #f)))
100
101 (test-assert "valid-path? recovery"
102 ;; Prior to Nix commit 51800e0 (18 Mar. 2014), the daemon would immediately
103 ;; close the connection after receiving a 'valid-path?' RPC with a non-store
104 ;; file name. See
105 ;; <http://article.gmane.org/gmane.linux.distributions.nixos/12411> for
106 ;; details.
107 (with-store s
108 (let-syntax ((true-if-error (syntax-rules ()
109 ((_ exp)
110 (guard (c ((nix-protocol-error? c) #t))
111 exp #f)))))
112 (and (true-if-error (valid-path? s "foo"))
113 (true-if-error (valid-path? s "bar"))
114 (true-if-error (valid-path? s "baz"))
115 (true-if-error (valid-path? s "chbouib"))
116 (valid-path? s (add-text-to-store s "valid" "yeah"))))))
117
118 (test-assert "hash-part->path"
119 (let ((p (add-text-to-store %store "hello" "hello, world")))
120 (equal? (hash-part->path %store (store-path-hash-part p))
121 p)))
122
123 (test-assert "dead-paths"
124 (let ((p (add-text-to-store %store "random-text" (random-text))))
125 (->bool (member p (dead-paths %store)))))
126
127 ;; FIXME: Find a test for `live-paths'.
128 ;;
129 ;; (test-assert "temporary root is in live-paths"
130 ;; (let* ((p1 (add-text-to-store %store "random-text"
131 ;; (random-text) '()))
132 ;; (b (add-text-to-store %store "link-builder"
133 ;; (format #f "echo ~a > $out" p1)
134 ;; '()))
135 ;; (d1 (derivation %store "link"
136 ;; "/bin/sh" `("-e" ,b)
137 ;; #:inputs `((,b) (,p1))))
138 ;; (p2 (derivation->output-path d1)))
139 ;; (and (add-temp-root %store p2)
140 ;; (build-derivations %store (list d1))
141 ;; (valid-path? %store p1)
142 ;; (member (pk p2) (live-paths %store)))))
143
144 (test-assert "permanent root"
145 (let* ((p (with-store store
146 (let ((p (add-text-to-store store "random-text"
147 (random-text))))
148 (add-permanent-root p)
149 (add-permanent-root p) ; should not throw
150 p))))
151 (and (member p (live-paths %store))
152 (begin
153 (remove-permanent-root p)
154 (->bool (member p (dead-paths %store)))))))
155
156 (test-assert "dead path can be explicitly collected"
157 (let ((p (add-text-to-store %store "random-text"
158 (random-text) '())))
159 (let-values (((paths freed) (delete-paths %store (list p))))
160 (and (equal? paths (list p))
161 (> freed 0)
162 (not (file-exists? p))))))
163
164 (test-assert "add-text-to-store vs. delete-paths"
165 ;; Before, 'add-text-to-store' would return PATH2 without noticing that it
166 ;; is no longer valid.
167 (with-store store
168 (let* ((text (random-text))
169 (path (add-text-to-store store "delete-me" text))
170 (deleted (delete-paths store (list path)))
171 (path2 (add-text-to-store store "delete-me" text)))
172 (and (string=? path path2)
173 (equal? deleted (list path))
174 (valid-path? store path)
175 (file-exists? path)))))
176
177 (test-assert "add-to-store vs. delete-paths"
178 ;; Same as above.
179 (with-store store
180 (let* ((file (search-path %load-path "guix.scm"))
181 (path (add-to-store store "delete-me" #t "sha256" file))
182 (deleted (delete-paths store (list path)))
183 (path2 (add-to-store store "delete-me" #t "sha256" file)))
184 (and (string=? path path2)
185 (equal? deleted (list path))
186 (valid-path? store path)
187 (file-exists? path)))))
188
189 (test-assert "references"
190 (let* ((t1 (add-text-to-store %store "random1"
191 (random-text)))
192 (t2 (add-text-to-store %store "random2"
193 (random-text) (list t1))))
194 (and (equal? (list t1) (references %store t2))
195 (equal? (list t2) (referrers %store t1))
196 (null? (references %store t1))
197 (null? (referrers %store t2)))))
198
199 (test-assert "references/substitutes missing reference info"
200 (with-store s
201 (set-build-options s #:use-substitutes? #f)
202 (guard (c ((nix-protocol-error? c) #t))
203 (let* ((b (add-to-store s "bash" #t "sha256"
204 (search-bootstrap-binary "bash"
205 (%current-system))))
206 (d (derivation s "the-thing" b '("--help")
207 #:inputs `((,b)))))
208 (references/substitutes s (list (derivation->output-path d) b))
209 #f))))
210
211 (test-assert "references/substitutes with substitute info"
212 (with-store s
213 (set-build-options s #:use-substitutes? #t)
214 (let* ((t1 (add-text-to-store s "random1" (random-text)))
215 (t2 (add-text-to-store s "random2" (random-text)
216 (list t1)))
217 (t3 (add-text-to-store s "build" "echo -n $t2 > $out"))
218 (b (add-to-store s "bash" #t "sha256"
219 (search-bootstrap-binary "bash"
220 (%current-system))))
221 (d (derivation s "the-thing" b `("-e" ,t3)
222 #:inputs `((,b) (,t3) (,t2))
223 #:env-vars `(("t2" . ,t2))))
224 (o (derivation->output-path d)))
225 (with-derivation-narinfo d
226 (sha256 => (sha256 (string->utf8 t2)))
227 (references => (list t2))
228
229 (equal? (references/substitutes s (list o t3 t2 t1))
230 `((,t2) ;refs of O
231 () ;refs of T3
232 (,t1) ;refs of T2
233 ())))))) ;refs of T1
234
235 (test-equal "substitutable-path-info when substitutes are turned off"
236 '()
237 (with-store s
238 (set-build-options s #:use-substitutes? #f)
239 (let* ((b (add-to-store s "bash" #t "sha256"
240 (search-bootstrap-binary "bash"
241 (%current-system))))
242 (d (derivation s "the-thing" b '("--version")
243 #:inputs `((,b))))
244 (o (derivation->output-path d)))
245 (with-derivation-narinfo d
246 (substitutable-path-info s (list o))))))
247
248 (test-equal "substitutable-paths when substitutes are turned off"
249 '()
250 (with-store s
251 (set-build-options s #:use-substitutes? #f)
252 (let* ((b (add-to-store s "bash" #t "sha256"
253 (search-bootstrap-binary "bash"
254 (%current-system))))
255 (d (derivation s "the-thing" b '("--version")
256 #:inputs `((,b))))
257 (o (derivation->output-path d)))
258 (with-derivation-narinfo d
259 (substitutable-paths s (list o))))))
260
261 (test-assert "requisites"
262 (let* ((t1 (add-text-to-store %store "random1"
263 (random-text) '()))
264 (t2 (add-text-to-store %store "random2"
265 (random-text) (list t1)))
266 (t3 (add-text-to-store %store "random3"
267 (random-text) (list t2)))
268 (t4 (add-text-to-store %store "random4"
269 (random-text) (list t1 t3))))
270 (define (same? x y)
271 (and (= (length x) (length y))
272 (lset= equal? x y)))
273
274 (and (same? (requisites %store (list t1)) (list t1))
275 (same? (requisites %store (list t2)) (list t1 t2))
276 (same? (requisites %store (list t3)) (list t1 t2 t3))
277 (same? (requisites %store (list t4)) (list t1 t2 t3 t4))
278 (same? (requisites %store (list t1 t2 t3 t4))
279 (list t1 t2 t3 t4)))))
280
281 (test-assert "derivers"
282 (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
283 (s (add-to-store %store "bash" #t "sha256"
284 (search-bootstrap-binary "bash"
285 (%current-system))))
286 (d (derivation %store "the-thing"
287 s `("-e" ,b)
288 #:env-vars `(("foo" . ,(random-text)))
289 #:inputs `((,b) (,s))))
290 (o (derivation->output-path d)))
291 (and (build-derivations %store (list d))
292 (equal? (query-derivation-outputs %store (derivation-file-name d))
293 (list o))
294 (equal? (valid-derivers %store o)
295 (list (derivation-file-name d))))))
296
297 (test-assert "topologically-sorted, one item"
298 (let* ((a (add-text-to-store %store "a" "a"))
299 (b (add-text-to-store %store "b" "b" (list a)))
300 (c (add-text-to-store %store "c" "c" (list b)))
301 (d (add-text-to-store %store "d" "d" (list c)))
302 (s (topologically-sorted %store (list d))))
303 (equal? s (list a b c d))))
304
305 (test-assert "topologically-sorted, several items"
306 (let* ((a (add-text-to-store %store "a" "a"))
307 (b (add-text-to-store %store "b" "b" (list a)))
308 (c (add-text-to-store %store "c" "c" (list b)))
309 (d (add-text-to-store %store "d" "d" (list c)))
310 (s1 (topologically-sorted %store (list d a c b)))
311 (s2 (topologically-sorted %store (list b d c a b d))))
312 (equal? s1 s2 (list a b c d))))
313
314 (test-assert "topologically-sorted, more difficult"
315 (let* ((a (add-text-to-store %store "a" "a"))
316 (b (add-text-to-store %store "b" "b" (list a)))
317 (c (add-text-to-store %store "c" "c" (list b)))
318 (d (add-text-to-store %store "d" "d" (list c)))
319 (w (add-text-to-store %store "w" "w"))
320 (x (add-text-to-store %store "x" "x" (list w)))
321 (y (add-text-to-store %store "y" "y" (list x d)))
322 (s1 (topologically-sorted %store (list y)))
323 (s2 (topologically-sorted %store (list c y)))
324 (s3 (topologically-sorted %store (cons y (references %store y)))))
325 ;; The order in which 'references' returns the references of Y is
326 ;; unspecified, so accommodate.
327 (let* ((x-then-d? (equal? (references %store y) (list x d))))
328 (and (equal? s1
329 (if x-then-d?
330 (list w x a b c d y)
331 (list a b c d w x y)))
332 (equal? s2
333 (if x-then-d?
334 (list a b c w x d y)
335 (list a b c d w x y)))
336 (lset= string=? s1 s3)))))
337
338 (test-assert "current-build-output-port, UTF-8"
339 ;; Are UTF-8 strings in the build log properly interpreted?
340 (string-contains
341 (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
342 (call-with-output-string
343 (lambda (port)
344 (parameterize ((current-build-output-port port))
345 (let* ((s "Here’s a Greek letter: λ.")
346 (d (build-expression->derivation
347 %store "foo" `(display ,s)
348 #:guile-for-build
349 (package-derivation s %bootstrap-guile (%current-system)))))
350 (guard (c ((nix-protocol-error? c) #t))
351 (build-derivations %store (list d))))))))
352 "Here’s a Greek letter: λ."))
353
354 (test-assert "current-build-output-port, UTF-8 + garbage"
355 ;; What about a mixture of UTF-8 + garbage?
356 (string-contains
357 (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
358 (call-with-output-string
359 (lambda (port)
360 (parameterize ((current-build-output-port port))
361 (let ((d (build-expression->derivation
362 %store "foo"
363 `(begin
364 (use-modules (rnrs io ports))
365 (display "garbage: ")
366 (put-bytevector (current-output-port) #vu8(128))
367 (display "lambda: λ\n"))
368 #:guile-for-build
369 (package-derivation %store %bootstrap-guile))))
370 (guard (c ((nix-protocol-error? c) #t))
371 (build-derivations %store (list d))))))))
372 "garbage: ?lambda: λ"))
373
374 (test-assert "log-file, derivation"
375 (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
376 (s (add-to-store %store "bash" #t "sha256"
377 (search-bootstrap-binary "bash"
378 (%current-system))))
379 (d (derivation %store "the-thing"
380 s `("-e" ,b)
381 #:env-vars `(("foo" . ,(random-text)))
382 #:inputs `((,b) (,s)))))
383 (and (build-derivations %store (list d))
384 (file-exists? (pk (log-file %store (derivation-file-name d)))))))
385
386 (test-assert "log-file, output file name"
387 (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
388 (s (add-to-store %store "bash" #t "sha256"
389 (search-bootstrap-binary "bash"
390 (%current-system))))
391 (d (derivation %store "the-thing"
392 s `("-e" ,b)
393 #:env-vars `(("foo" . ,(random-text)))
394 #:inputs `((,b) (,s))))
395 (o (derivation->output-path d)))
396 (and (build-derivations %store (list d))
397 (file-exists? (pk (log-file %store o)))
398 (string=? (log-file %store (derivation-file-name d))
399 (log-file %store o)))))
400
401 (test-assert "no substitutes"
402 (with-store s
403 (let* ((d1 (package-derivation s %bootstrap-guile (%current-system)))
404 (d2 (package-derivation s %bootstrap-glibc (%current-system)))
405 (o (map derivation->output-path (list d1 d2))))
406 (set-build-options s #:use-substitutes? #f)
407 (and (not (has-substitutes? s (derivation-file-name d1)))
408 (not (has-substitutes? s (derivation-file-name d2)))
409 (null? (substitutable-paths s o))
410 (null? (substitutable-path-info s o))))))
411
412 (test-assert "build-things with output path"
413 (with-store s
414 (let* ((c (random-text)) ;contents of the output
415 (d (build-expression->derivation
416 s "substitute-me"
417 `(call-with-output-file %output
418 (lambda (p)
419 (display ,c p)))
420 #:guile-for-build
421 (package-derivation s %bootstrap-guile (%current-system))))
422 (o (derivation->output-path d)))
423 (set-build-options s #:use-substitutes? #f)
424
425 ;; Pass 'build-things' the output file name, O. However, since there
426 ;; are no substitutes for O, it will just do nothing.
427 (build-things s (list o))
428 (not (valid-path? s o)))))
429
430 (test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
431
432 (test-assert "substitute query"
433 (with-store s
434 (let* ((d (package-derivation s %bootstrap-guile (%current-system)))
435 (o (derivation->output-path d)))
436 ;; Create fake substituter data, to be read by 'guix substitute'.
437 (with-derivation-narinfo d
438 ;; Remove entry from the local cache.
439 (false-if-exception
440 (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
441 "/guix/substitute")))
442
443 ;; Make sure 'guix substitute' correctly communicates the above
444 ;; data.
445 (set-build-options s #:use-substitutes? #t
446 #:substitute-urls (%test-substitute-urls))
447 (and (has-substitutes? s o)
448 (equal? (list o) (substitutable-paths s (list o)))
449 (match (pk 'spi (substitutable-path-info s (list o)))
450 (((? substitutable? s))
451 (and (string=? (substitutable-deriver s)
452 (derivation-file-name d))
453 (null? (substitutable-references s))
454 (equal? (substitutable-nar-size s) 1234)))))))))
455
456 (test-assert "substitute query, alternating URLs"
457 (let* ((d (with-store s
458 (package-derivation s %bootstrap-guile (%current-system))))
459 (o (derivation->output-path d)))
460 (with-derivation-narinfo d
461 ;; Remove entry from the local cache.
462 (false-if-exception
463 (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
464 "/guix/substitute")))
465
466 ;; Note: We reconnect to the daemon to force a new instance of 'guix
467 ;; substitute' to be used; otherwise the #:substitute-urls of
468 ;; 'set-build-options' would have no effect.
469
470 (and (with-store s ;the right substitute URL
471 (set-build-options s #:use-substitutes? #t
472 #:substitute-urls (%test-substitute-urls))
473 (has-substitutes? s o))
474 (with-store s ;the wrong one
475 (set-build-options s #:use-substitutes? #t
476 #:substitute-urls (list
477 "http://does-not-exist"))
478 (not (has-substitutes? s o)))
479 (with-store s ;the right one again
480 (set-build-options s #:use-substitutes? #t
481 #:substitute-urls (%test-substitute-urls))
482 (has-substitutes? s o))
483 (with-store s ;empty list of URLs
484 (set-build-options s #:use-substitutes? #t
485 #:substitute-urls '())
486 (not (has-substitutes? s o)))))))
487
488 (test-assert "substitute"
489 (with-store s
490 (let* ((c (random-text)) ; contents of the output
491 (d (build-expression->derivation
492 s "substitute-me"
493 `(call-with-output-file %output
494 (lambda (p)
495 (exit 1) ; would actually fail
496 (display ,c p)))
497 #:guile-for-build
498 (package-derivation s %bootstrap-guile (%current-system))))
499 (o (derivation->output-path d)))
500 (with-derivation-substitute d c
501 (set-build-options s #:use-substitutes? #t
502 #:substitute-urls (%test-substitute-urls))
503 (and (has-substitutes? s o)
504 (build-derivations s (list d))
505 (equal? c (call-with-input-file o get-string-all)))))))
506
507 (test-assert "substitute + build-things with output path"
508 (with-store s
509 (let* ((c (random-text)) ;contents of the output
510 (d (build-expression->derivation
511 s "substitute-me"
512 `(call-with-output-file %output
513 (lambda (p)
514 (exit 1) ;would actually fail
515 (display ,c p)))
516 #:guile-for-build
517 (package-derivation s %bootstrap-guile (%current-system))))
518 (o (derivation->output-path d)))
519 (with-derivation-substitute d c
520 (set-build-options s #:use-substitutes? #t
521 #:substitute-urls (%test-substitute-urls))
522 (and (has-substitutes? s o)
523 (build-things s (list o)) ;give the output path
524 (valid-path? s o)
525 (equal? c (call-with-input-file o get-string-all)))))))
526
527 (test-assert "substitute, corrupt output hash"
528 ;; Tweak the substituter into installing a substitute whose hash doesn't
529 ;; match the one announced in the narinfo. The daemon must notice this and
530 ;; raise an error.
531 (with-store s
532 (let* ((c "hello, world") ; contents of the output
533 (d (build-expression->derivation
534 s "corrupt-substitute"
535 `(mkdir %output)
536 #:guile-for-build
537 (package-derivation s %bootstrap-guile (%current-system))))
538 (o (derivation->output-path d)))
539 (with-derivation-substitute d c
540 (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C
541
542 ;; Make sure we use 'guix substitute'.
543 (set-build-options s
544 #:use-substitutes? #t
545 #:fallback? #f
546 #:substitute-urls (%test-substitute-urls))
547 (and (has-substitutes? s o)
548 (guard (c ((nix-protocol-error? c)
549 ;; XXX: the daemon writes "hash mismatch in downloaded
550 ;; path", but the actual error returned to the client
551 ;; doesn't mention that.
552 (pk 'corrupt c)
553 (not (zero? (nix-protocol-error-status c)))))
554 (build-derivations s (list d))
555 #f))))))
556
557 (test-assert "substitute --fallback"
558 (with-store s
559 (let* ((t (random-text)) ; contents of the output
560 (d (build-expression->derivation
561 s "substitute-me-not"
562 `(call-with-output-file %output
563 (lambda (p)
564 (display ,t p)))
565 #:guile-for-build
566 (package-derivation s %bootstrap-guile (%current-system))))
567 (o (derivation->output-path d)))
568 ;; Create fake substituter data, to be read by 'guix substitute'.
569 (with-derivation-narinfo d
570 ;; Make sure we use 'guix substitute'.
571 (set-build-options s #:use-substitutes? #t
572 #:substitute-urls (%test-substitute-urls))
573 (and (has-substitutes? s o)
574 (guard (c ((nix-protocol-error? c)
575 ;; The substituter failed as expected. Now make
576 ;; sure that #:fallback? #t works correctly.
577 (set-build-options s
578 #:use-substitutes? #t
579 #:substitute-urls
580 (%test-substitute-urls)
581 #:fallback? #t)
582 (and (build-derivations s (list d))
583 (equal? t (call-with-input-file o
584 get-string-all)))))
585 ;; Should fail.
586 (build-derivations s (list d))
587 #f))))))
588
589 (test-assert "export/import several paths"
590 (let* ((texts (unfold (cut >= <> 10)
591 (lambda _ (random-text))
592 1+
593 0))
594 (files (map (cut add-text-to-store %store "text" <>) texts))
595 (dump (call-with-bytevector-output-port
596 (cut export-paths %store files <>))))
597 (delete-paths %store files)
598 (and (every (negate file-exists?) files)
599 (let* ((source (open-bytevector-input-port dump))
600 (imported (import-paths %store source)))
601 (and (equal? imported files)
602 (every file-exists? files)
603 (equal? texts
604 (map (lambda (file)
605 (call-with-input-file file
606 get-string-all))
607 files)))))))
608
609 (test-assert "export/import paths, ensure topological order"
610 (let* ((file0 (add-text-to-store %store "baz" (random-text)))
611 (file1 (add-text-to-store %store "foo" (random-text)
612 (list file0)))
613 (file2 (add-text-to-store %store "bar" (random-text)
614 (list file1)))
615 (files (list file1 file2))
616 (dump1 (call-with-bytevector-output-port
617 (cute export-paths %store (list file1 file2) <>)))
618 (dump2 (call-with-bytevector-output-port
619 (cute export-paths %store (list file2 file1) <>))))
620 (delete-paths %store files)
621 (and (every (negate file-exists?) files)
622 (bytevector=? dump1 dump2)
623 (let* ((source (open-bytevector-input-port dump1))
624 (imported (import-paths %store source)))
625 ;; DUMP1 should contain exactly FILE1 and FILE2, not FILE0.
626 (and (equal? imported (list file1 file2))
627 (every file-exists? files)
628 (equal? (list file0) (references %store file1))
629 (equal? (list file1) (references %store file2)))))))
630
631 (test-assert "export/import incomplete"
632 (let* ((file0 (add-text-to-store %store "baz" (random-text)))
633 (file1 (add-text-to-store %store "foo" (random-text)
634 (list file0)))
635 (file2 (add-text-to-store %store "bar" (random-text)
636 (list file1)))
637 (dump (call-with-bytevector-output-port
638 (cute export-paths %store (list file2) <>))))
639 (delete-paths %store (list file0 file1 file2))
640 (guard (c ((nix-protocol-error? c)
641 (and (not (zero? (nix-protocol-error-status c)))
642 (string-contains (nix-protocol-error-message c)
643 "not valid"))))
644 ;; Here we get an exception because DUMP does not include FILE0 and
645 ;; FILE1, which are dependencies of FILE2.
646 (import-paths %store (open-bytevector-input-port dump)))))
647
648 (test-assert "export/import recursive"
649 (let* ((file0 (add-text-to-store %store "baz" (random-text)))
650 (file1 (add-text-to-store %store "foo" (random-text)
651 (list file0)))
652 (file2 (add-text-to-store %store "bar" (random-text)
653 (list file1)))
654 (dump (call-with-bytevector-output-port
655 (cute export-paths %store (list file2) <>
656 #:recursive? #t))))
657 (delete-paths %store (list file0 file1 file2))
658 (let ((imported (import-paths %store (open-bytevector-input-port dump))))
659 (and (equal? imported (list file0 file1 file2))
660 (every file-exists? (list file0 file1 file2))
661 (equal? (list file0) (references %store file1))
662 (equal? (list file1) (references %store file2))))))
663
664 (test-assert "write-file & export-path yield the same result"
665 ;; Here we compare 'write-file' and the daemon's own implementation.
666 ;; 'write-file' is the reference because we know it sorts file
667 ;; deterministically. Conversely, the daemon uses 'readdir' and the entries
668 ;; currently happen to be sorted as a side-effect of some unrelated
669 ;; operation (search for 'unhacked' in archive.cc.) Make sure we detect any
670 ;; changes there.
671 (run-with-store %store
672 (mlet* %store-monad ((drv1 (package->derivation %bootstrap-guile))
673 (out1 -> (derivation->output-path drv1))
674 (data -> (unfold (cut >= <> 26)
675 (lambda (i)
676 (random-bytevector 128))
677 1+ 0))
678 (build
679 -> #~(begin
680 (use-modules (rnrs io ports) (srfi srfi-1))
681 (let ()
682 (define letters
683 (map (lambda (i)
684 (string
685 (integer->char
686 (+ i (char->integer #\a)))))
687 (iota 26)))
688 (define (touch file data)
689 (call-with-output-file file
690 (lambda (port)
691 (put-bytevector port data))))
692
693 (mkdir #$output)
694 (chdir #$output)
695
696 ;; The files must be different so they have
697 ;; different inode numbers, and the inode
698 ;; order must differ from the lexicographic
699 ;; order.
700 (for-each touch
701 (append (drop letters 10)
702 (take letters 10))
703 (list #$@data))
704 #t)))
705 (drv2 (gexp->derivation "bunch" build))
706 (out2 -> (derivation->output-path drv2))
707 (item-info -> (store-lift query-path-info)))
708 (mbegin %store-monad
709 (built-derivations (list drv1 drv2))
710 (foldm %store-monad
711 (lambda (item result)
712 (define ref-hash
713 (let-values (((port get) (open-sha256-port)))
714 (write-file item port)
715 (close-port port)
716 (get)))
717
718 ;; 'query-path-info' returns a hash produced by using the
719 ;; daemon's C++ 'dump' function, which is the implementation
720 ;; under test.
721 (>>= (item-info item)
722 (lambda (info)
723 (return
724 (and result
725 (bytevector=? (path-info-hash info) ref-hash))))))
726 #t
727 (list out1 out2))))
728 #:guile-for-build (%guile-for-build)))
729
730 (test-assert "import corrupt path"
731 (let* ((text (random-text))
732 (file (add-text-to-store %store "text" text))
733 (dump (call-with-bytevector-output-port
734 (cut export-paths %store (list file) <>))))
735 (delete-paths %store (list file))
736
737 ;; Flip a bit in the stream's payload.
738 (let* ((index (quotient (bytevector-length dump) 4))
739 (byte (bytevector-u8-ref dump index)))
740 (bytevector-u8-set! dump index (logxor #xff byte)))
741
742 (and (not (file-exists? file))
743 (guard (c ((nix-protocol-error? c)
744 (pk 'c c)
745 (and (not (zero? (nix-protocol-error-status c)))
746 (string-contains (nix-protocol-error-message c)
747 "corrupt"))))
748 (let* ((source (open-bytevector-input-port dump))
749 (imported (import-paths %store source)))
750 (pk 'corrupt-imported imported)
751 #f)))))
752
753 (test-assert "register-path"
754 (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f)
755 "-fake")))
756 (when (valid-path? %store file)
757 (delete-paths %store (list file)))
758 (false-if-exception (delete-file file))
759
760 (let ((ref (add-text-to-store %store "ref-of-fake" (random-text)))
761 (drv (string-append file ".drv")))
762 (call-with-output-file file
763 (cut display "This is a fake store item.\n" <>))
764 (register-path file
765 #:references (list ref)
766 #:deriver drv)
767
768 (and (valid-path? %store file)
769 (equal? (references %store file) (list ref))
770 (null? (valid-derivers %store file))
771 (null? (referrers %store file))))))
772
773 (test-assert "verify-store"
774 (let* ((text (random-text))
775 (file1 (add-text-to-store %store "foo" text))
776 (file2 (add-text-to-store %store "bar" (random-text)
777 (list file1))))
778 (and (pk 'verify1 (verify-store %store)) ;hopefully OK ;
779 (begin
780 (delete-file file1)
781 (not (pk 'verify2 (verify-store %store)))) ;bad! ;
782 (begin
783 ;; Using 'add-text-to-store' here wouldn't work: It would succeed ;
784 ;; without actually creating the file. ;
785 (call-with-output-file file1
786 (lambda (port)
787 (display text port)))
788 (pk 'verify3 (verify-store %store)))))) ;OK again
789
790 (test-assert "verify-store + check-contents"
791 ;; XXX: This test is I/O intensive.
792 (with-store s
793 (let* ((text (random-text))
794 (drv (build-expression->derivation
795 s "corrupt"
796 `(let ((out (assoc-ref %outputs "out")))
797 (call-with-output-file out
798 (lambda (port)
799 (display ,text port)))
800 #t)
801 #:guile-for-build
802 (package-derivation s %bootstrap-guile (%current-system))))
803 (file (derivation->output-path drv)))
804 (with-derivation-substitute drv text
805 (and (build-derivations s (list drv))
806 (verify-store s #:check-contents? #t) ;should be OK
807 (begin
808 (chmod file #o644)
809 (call-with-output-file file
810 (lambda (port)
811 (display "corrupt!" port)))
812 #t)
813
814 ;; Make sure the corruption is detected. We don't test repairing
815 ;; because only "trusted" users are allowed to do it, but we
816 ;; don't expose that notion of trusted users that nix-daemon
817 ;; supports because it seems dubious and redundant with what the
818 ;; OS provides (in Nix "trusted" users have additional
819 ;; privileges, such as overriding the set of substitute URLs, but
820 ;; we instead want to allow anyone to modify them, provided
821 ;; substitutes are signed by a root-approved key.)
822 (not (verify-store s #:check-contents? #t))
823
824 ;; Delete the corrupt item to leave the store in a clean state.
825 (delete-paths s (list file)))))))
826
827 (test-assert "build-things, check mode"
828 (with-store store
829 (call-with-temporary-output-file
830 (lambda (entropy entropy-port)
831 (write (random-text) entropy-port)
832 (force-output entropy-port)
833 (let* ((drv (build-expression->derivation
834 store "non-deterministic"
835 `(begin
836 (use-modules (rnrs io ports))
837 (let ((out (assoc-ref %outputs "out")))
838 (call-with-output-file out
839 (lambda (port)
840 ;; Rely on the fact that tests do not use the
841 ;; chroot, and thus ENTROPY is readable.
842 (display (call-with-input-file ,entropy
843 get-string-all)
844 port)))
845 #t))
846 #:guile-for-build
847 (package-derivation store %bootstrap-guile (%current-system))))
848 (file (derivation->output-path drv)))
849 (and (build-things store (list (derivation-file-name drv)))
850 (begin
851 (write (random-text) entropy-port)
852 (force-output entropy-port)
853 (guard (c ((nix-protocol-error? c)
854 (pk 'determinism-exception c)
855 (and (not (zero? (nix-protocol-error-status c)))
856 (string-contains (nix-protocol-error-message c)
857 "deterministic"))))
858 ;; This one will produce a different result. Since we're in
859 ;; 'check' mode, this must fail.
860 (build-things store (list (derivation-file-name drv))
861 (build-mode check))
862 #f))))))))
863
864 (test-assert "build multiple times"
865 (with-store store
866 ;; Ask to build twice.
867 (set-build-options store #:rounds 2 #:use-substitutes? #f)
868
869 (call-with-temporary-output-file
870 (lambda (entropy entropy-port)
871 (write (random-text) entropy-port)
872 (force-output entropy-port)
873 (let* ((drv (build-expression->derivation
874 store "non-deterministic"
875 `(begin
876 (use-modules (rnrs io ports))
877 (let ((out (assoc-ref %outputs "out")))
878 (call-with-output-file out
879 (lambda (port)
880 ;; Rely on the fact that tests do not use the
881 ;; chroot, and thus ENTROPY is accessible.
882 (display (call-with-input-file ,entropy
883 get-string-all)
884 port)
885 (call-with-output-file ,entropy
886 (lambda (port)
887 (write 'foobar port)))))
888 #t))
889 #:guile-for-build
890 (package-derivation store %bootstrap-guile (%current-system))))
891 (file (derivation->output-path drv)))
892 (guard (c ((nix-protocol-error? c)
893 (pk 'multiple-build c)
894 (and (not (zero? (nix-protocol-error-status c)))
895 (string-contains (nix-protocol-error-message c)
896 "deterministic"))))
897 ;; This one will produce a different result on the second run.
898 (current-build-output-port (current-error-port))
899 (build-things store (list (derivation-file-name drv)))
900 #f))))))
901
902 (test-equal "store-lower"
903 "Lowered."
904 (let* ((add (store-lower text-file))
905 (file (add %store "foo" "Lowered.")))
906 (call-with-input-file file get-string-all)))
907
908 (test-equal "current-system"
909 "bar"
910 (parameterize ((%current-system "frob"))
911 (run-with-store %store
912 (mbegin %store-monad
913 (set-current-system "bar")
914 (current-system))
915 #:system "foo")))
916
917 (test-assert "query-path-info"
918 (let* ((ref (add-text-to-store %store "ref" "foo"))
919 (item (add-text-to-store %store "item" "bar" (list ref)))
920 (info (query-path-info %store item)))
921 (and (equal? (path-info-references info) (list ref))
922 (equal? (path-info-hash info)
923 (sha256
924 (string->utf8
925 (call-with-output-string (cut write-file item <>))))))))
926
927 (test-assert "path-info-deriver"
928 (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
929 (s (add-to-store %store "bash" #t "sha256"
930 (search-bootstrap-binary "bash"
931 (%current-system))))
932 (d (derivation %store "the-thing"
933 s `("-e" ,b)
934 #:env-vars `(("foo" . ,(random-text)))
935 #:inputs `((,b) (,s))))
936 (o (derivation->output-path d)))
937 (and (build-derivations %store (list d))
938 (not (path-info-deriver (query-path-info %store b)))
939 (string=? (derivation-file-name d)
940 (path-info-deriver (query-path-info %store o))))))
941
942 (test-end "store")