projects/guix·blob javascript-team · refs

2210 lines · 97.5 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012-2021, 2023, 2025-2026 Ludovic Courtès <[email protected]>
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 config)
22 #:use-module (guix store)
23 #:use-module (guix utils)
24 #:use-module (guix monads)
25 #:use-module ((gcrypt hash) #:prefix gcrypt:)
26 #:use-module ((gcrypt pk-crypto) #:prefix gcrypt:)
27 #:use-module (guix pki)
28 #:use-module (guix base32)
29 #:use-module (guix packages)
30 #:use-module (guix derivations)
31 #:use-module ((guix modules)
32 #:select (source-module-closure))
33 #:use-module ((guix serialization)
34 #:hide (store-path read-string))
35 #:use-module (guix build utils)
36 #:use-module ((gnu build linux-container)
37 #:select (unprivileged-user-namespace-supported?))
38 #:use-module (guix gexp)
39 #:use-module (gnu packages)
40 #:use-module (gnu packages bootstrap)
41 #:use-module (ice-9 binary-ports)
42 #:use-module (ice-9 match)
43 #:use-module (ice-9 rdelim)
44 #:use-module (ice-9 regex)
45 #:use-module (rnrs bytevectors)
46 #:use-module (rnrs io ports)
47 #:use-module (web uri)
48 #:use-module (srfi srfi-1)
49 #:use-module (srfi srfi-11)
50 #:use-module (srfi srfi-26)
51 #:use-module (srfi srfi-34)
52 #:use-module (srfi srfi-64))
53
54;; Test the (guix store) module.
55
56(define %store
57 (open-connection-for-tests))
58
59(define %shell
60 (or (getenv "SHELL") (getenv "CONFIG_SHELL") "/bin/sh"))
61
62
63(test-begin "store")
64
65(test-assert "open-connection with file:// URI"
66 (let ((store (open-connection (string-append "file://"
67 (%daemon-socket-uri)))))
68 (and (add-text-to-store store "foo" "bar")
69 (begin
70 (close-connection store)
71 #t))))
72
73(test-equal "connection handshake error"
74 EPROTO
75 (let ((port (%make-void-port "rw")))
76 (guard (c ((store-connection-error? c)
77 (and (eq? port (store-connection-error-file c))
78 (store-connection-error-code c))))
79 (open-connection #f #:port port)
80 'broken)))
81
82(test-assert "valid-path-syntax?"
83 (valid-path-syntax? (string-append (%store-prefix)
84 "/yp8mg1rwaw3y1p09bc8dx4l6rx4qx961-coreutils-9.1")))
85
86(test-assert "valid-path-syntax? truncated hash"
87 (not (valid-path-syntax?
88 (string-append (%store-prefix)
89 "/p8mg1rwaw3y1p09bc8dx4l6rx4qx961-coreutils-9.1"))))
90
91(test-assert "valid-path-syntax? slash"
92 (not (valid-path-syntax?
93 (string-append (%store-prefix)
94 "/yp8mg1rwaw3y1p09bc8dx4l6rx4qx961-coreutils-9.1/../../../etc/passwd"))))
95
96(test-assert "valid-path-syntax? leading dot"
97 (not (valid-path-syntax? (string-append (%store-prefix)
98 "/yp8mg1rwaw3y1p09bc8dx4l6rx4qx961-.leading-dot"))))
99
100(test-assert "valid-path-syntax? prefix"
101 (not (valid-path-syntax? (%store-prefix))))
102
103(test-assert "valid-path-syntax? truncated"
104 (not (valid-path-syntax? (string-append (%store-prefix) "/aaaaaaaaaaa"))))
105
106(test-equal "store-path-hash-part"
107 "283gqy39v3g9dxjy26rynl0zls82fmcg"
108 (store-path-hash-part
109 (string-append (%store-prefix)
110 "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
111
112(test-equal "store-path-hash-part #f"
113 #f
114 (store-path-hash-part
115 (string-append (%store-prefix)
116 "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
117
118(test-equal "store-path-package-name"
119 "guile-2.0.7"
120 (store-path-package-name
121 (string-append (%store-prefix)
122 "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
123
124(test-error "store-path-package-name #f"
125 #t ;any exception
126 (store-path-package-name
127 "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))
128
129(test-assert "direct-store-path?"
130 (and (direct-store-path?
131 (string-append (%store-prefix)
132 "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))
133 (not (direct-store-path?
134 (string-append
135 (%store-prefix)
136 "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile")))
137 (not (direct-store-path? (%store-prefix)))))
138
139(test-assert "derivation-path?"
140 (and (derivation-path?
141 (string-append (%store-prefix)
142 "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7.drv"))
143 (not (derivation-path?
144 (string-append (%store-prefix)
145 "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
146 (not (derivation-path?
147 (string-append
148 (%store-prefix)
149 "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/guile.drv")))))
150
151(test-skip (if %store 0 18))
152
153(test-equal "substitute-urls, default"
154 (list (getenv "GUIX_BINARY_SUBSTITUTE_URL"))
155 (with-store store
156 (set-build-options store #:use-substitutes? #t)
157 (substitute-urls store)))
158
159(test-equal "substitute-urls, client-specified URLs"
160 '("http://substitutes.example.org"
161 "http://other.example.org")
162 (with-store store
163 (set-build-options store #:use-substitutes? #t
164 #:substitute-urls '("http://substitutes.example.org"
165 "http://other.example.org"))
166 (substitute-urls store)))
167
168(test-equal "substitute-urls, disabled"
169 '()
170 (with-store store
171 (set-build-options store #:use-substitutes? #f)
172 (substitute-urls store)))
173
174(test-equal "profiles/per-user exists and is not writable"
175 #o755
176 (stat:perms (stat (string-append %state-directory "/profiles/per-user"))))
177
178(test-equal "profiles/per-user/$USER exists"
179 (list (getuid) #o755)
180 (let ((s (stat (string-append %state-directory "/profiles/per-user/"
181 (passwd:name (getpwuid (getuid)))))))
182 (list (stat:uid s) (stat:perms s))))
183
184(test-equal "add-to-store"
185 '("sha1" "sha256" "sha512" "sha3-256" "sha3-512" "blake2s-256")
186 (let* ((file (search-path %load-path "guix.scm"))
187 (content (call-with-input-file file get-bytevector-all)))
188 (map (lambda (hash-algo)
189 (let ((file (add-to-store %store "guix.scm" #f hash-algo file)))
190 (and (direct-store-path? file)
191 (bytevector=? (call-with-input-file file get-bytevector-all)
192 content)
193 hash-algo)))
194 '("sha1" "sha256" "sha512" "sha3-256" "sha3-512" "blake2s-256"))))
195
196(test-equal "add-data-to-store"
197 #vu8(1 2 3 4 5)
198 (call-with-input-file (add-data-to-store %store "data" #vu8(1 2 3 4 5))
199 get-bytevector-all))
200
201(test-assert "valid-path? live"
202 (let ((p (add-text-to-store %store "hello" "hello, world")))
203 (valid-path? %store p)))
204
205(test-assert "valid-path? false"
206 (not (valid-path? %store
207 (string-append (%store-prefix) "/"
208 (make-string 32 #\e) "-foobar"))))
209
210(test-equal "with-store, multiple values" ;<https://bugs.gnu.org/42912>
211 '(1 2 3)
212 (call-with-values
213 (lambda ()
214 (with-store s
215 (add-text-to-store s "foo" "bar")
216 (values 1 2 3)))
217 list))
218
219(test-assert "valid-path? error"
220 (with-store s
221 (guard (c ((store-protocol-error? c) #t))
222 (valid-path? s "foo")
223 #f)))
224
225(test-assert "valid-path? recovery"
226 ;; Prior to Nix commit 51800e0 (18 Mar. 2014), the daemon would immediately
227 ;; close the connection after receiving a 'valid-path?' RPC with a non-store
228 ;; file name. See
229 ;; <http://article.gmane.org/gmane.linux.distributions.nixos/12411> for
230 ;; details.
231 (with-store s
232 (let-syntax ((true-if-error (syntax-rules ()
233 ((_ exp)
234 (guard (c ((store-protocol-error? c) #t))
235 exp #f)))))
236 (and (true-if-error (valid-path? s "foo"))
237 (true-if-error (valid-path? s "bar"))
238 (true-if-error (valid-path? s "baz"))
239 (true-if-error (valid-path? s "chbouib"))
240 (valid-path? s (add-text-to-store s "valid" "yeah"))))))
241
242(test-assert "hash-part->path"
243 (let ((p (add-text-to-store %store "hello" "hello, world")))
244 (equal? (hash-part->path %store (store-path-hash-part p))
245 p)))
246
247(test-assert "dead-paths"
248 (let ((p (add-text-to-store %store "random-text" (random-text))))
249 (->bool (member p (dead-paths %store)))))
250
251;; FIXME: Find a test for `live-paths'.
252;;
253;; (test-assert "temporary root is in live-paths"
254;; (let* ((p1 (add-text-to-store %store "random-text"
255;; (random-text) '()))
256;; (b (add-text-to-store %store "link-builder"
257;; (format #f "echo ~a > $out" p1)
258;; '()))
259;; (d1 (derivation %store "link"
260;; "/bin/sh" `("-e" ,b)
261;; #:inputs `((,b) (,p1))))
262;; (p2 (derivation->output-path d1)))
263;; (and (add-temp-root %store p2)
264;; (build-derivations %store (list d1))
265;; (valid-path? %store p1)
266;; (member (pk p2) (live-paths %store)))))
267
268(test-assert "add-indirect-root and find-roots"
269 (call-with-temporary-directory
270 (lambda (directory)
271 (let* ((item (add-text-to-store %store "something" (random-text)))
272 (root (string-append directory "/gc-root")))
273 (symlink item root)
274 (add-indirect-root %store root)
275 (let ((result (member (cons root item) (find-roots %store))))
276 (delete-file root)
277 result)))))
278
279(test-assert "permanent root"
280 (let* ((p (with-store store
281 (let ((p (add-text-to-store store "random-text"
282 (random-text))))
283 (add-permanent-root p)
284 (add-permanent-root p) ; should not throw
285 p))))
286 (and (member p (live-paths %store))
287 (begin
288 (remove-permanent-root p)
289 (->bool (member p (dead-paths %store)))))))
290
291(test-assert "dead path can be explicitly collected"
292 (let ((p (add-text-to-store %store "random-text"
293 (random-text) '())))
294 (let-values (((paths freed) (delete-paths %store (list p))))
295 (and (equal? paths (list p))
296 ;; XXX: On some file systems (notably Btrfs), freed
297 ;; may return 0. See <https://bugs.gnu.org/29363>.
298 ;;(> freed 0)
299 (not (file-exists? p))))))
300
301(test-assert "add-text-to-store/add-to-store vs. delete-paths"
302 ;; Before, 'add-text-to-store' and 'add-to-store' would return the same
303 ;; store item without noticing that it is no longer valid.
304 (with-store store
305 (let* ((text (random-text))
306 (file (search-path %load-path "guix.scm"))
307 (path1 (add-text-to-store store "delete-me" text))
308 (path2 (add-to-store store "delete-me" #t "sha256" file))
309 (deleted (delete-paths store (list path1 path2))))
310 (and (string=? path1 (add-text-to-store store "delete-me" text))
311 (string=? path2 (add-to-store store "delete-me" #t "sha256" file))
312 (lset= string=? deleted (list path1 path2))
313 (valid-path? store path1)
314 (valid-path? store path2)
315 (file-exists? path1)
316 (file-exists? path2)))))
317
318(test-equal "add-file-tree-to-store"
319 `(42
320 ("." directory #t)
321 ("./bar" directory #t)
322 ("./foo" directory #t)
323 ("./foo/a" regular "file a")
324 ("./foo/b" symlink "a")
325 ("./foo/c" directory #t)
326 ("./foo/c/p" regular "file p")
327 ("./foo/c/q" directory #t)
328 ("./foo/c/q/x" regular
329 ,(string-append "#!" %shell "\nexit 42"))
330 ("./foo/c/q/y" symlink "..")
331 ("./foo/c/q/z" directory #t))
332 (let* ((tree `("file-tree" directory
333 ("foo" directory
334 ("a" regular (data "file a"))
335 ("b" symlink "a")
336 ("c" directory
337 ("p" regular (data ,(string->utf8 "file p")))
338 ("q" directory
339 ("x" executable
340 (data ,(string-append "#!" %shell "\nexit 42")))
341 ("y" symlink "..")
342 ("z" directory))))
343 ("bar" directory)))
344 (result (add-file-tree-to-store %store tree)))
345 (cons (status:exit-val (system* (string-append result "/foo/c/q/x")))
346 (with-directory-excursion result
347 (map (lambda (file)
348 (let ((type (stat:type (lstat file))))
349 `(,file ,type
350 ,(match type
351 ((or 'regular 'executable)
352 (call-with-input-file file
353 get-string-all))
354 ('symlink (readlink file))
355 ('directory #t)))))
356 (find-files "." #:directories? #t))))))
357
358(test-equal "add-file-tree-to-store, flat"
359 "Hello, world!"
360 (let* ((tree `("flat-file" regular (data "Hello, world!")))
361 (result (add-file-tree-to-store %store tree)))
362 (and (file-exists? result)
363 (call-with-input-file result get-string-all))))
364
365(test-assert "references"
366 (let* ((t1 (add-text-to-store %store "random1"
367 (random-text)))
368 (t2 (add-text-to-store %store "random2"
369 (random-text) (list t1))))
370 (and (equal? (list t1) (references %store t2))
371 (equal? (list t2) (referrers %store t1))
372 (null? (references %store t1))
373 (null? (referrers %store t2)))))
374
375(test-equal "substitutable-path-info when substitutes are turned off"
376 '()
377 (with-store s
378 (set-build-options s #:use-substitutes? #f)
379 (let* ((b (add-to-store s "bash" #t "sha256"
380 (search-bootstrap-binary "bash"
381 (%current-system))))
382 (d (derivation s "the-thing" b '("--version")
383 #:inputs `((,b))))
384 (o (derivation->output-path d)))
385 (with-derivation-narinfo d
386 (substitutable-path-info s (list o))))))
387
388(test-equal "substitutable-paths when substitutes are turned off"
389 '()
390 (with-store s
391 (set-build-options s #:use-substitutes? #f)
392 (let* ((b (add-to-store s "bash" #t "sha256"
393 (search-bootstrap-binary "bash"
394 (%current-system))))
395 (d (derivation s "the-thing" b '("--version")
396 #:inputs `((,b))))
397 (o (derivation->output-path d)))
398 (with-derivation-narinfo d
399 (substitutable-paths s (list o))))))
400
401(test-assert "requisites"
402 (let* ((t1 (add-text-to-store %store "random1"
403 (random-text) '()))
404 (t2 (add-text-to-store %store "random2"
405 (random-text) (list t1)))
406 (t3 (add-text-to-store %store "random3"
407 (random-text) (list t2)))
408 (t4 (add-text-to-store %store "random4"
409 (random-text) (list t1 t3))))
410 (define (same? x y)
411 (and (= (length x) (length y))
412 (lset= equal? x y)))
413
414 (and (same? (requisites %store (list t1)) (list t1))
415 (same? (requisites %store (list t2)) (list t1 t2))
416 (same? (requisites %store (list t3)) (list t1 t2 t3))
417 (same? (requisites %store (list t4)) (list t1 t2 t3 t4))
418 (same? (requisites %store (list t1 t2 t3 t4))
419 (list t1 t2 t3 t4)))))
420
421(test-assert "derivers"
422 (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
423 (s (add-to-store %store "bash" #t "sha256"
424 (search-bootstrap-binary "bash"
425 (%current-system))))
426 (d (derivation %store "the-thing"
427 s `("-e" ,b)
428 #:env-vars `(("foo" . ,(random-text)))
429 #:inputs `((,b) (,s))))
430 (o (derivation->output-path d)))
431 (and (build-derivations %store (list d))
432 (equal? (query-derivation-outputs %store (derivation-file-name d))
433 (list o))
434 (equal? (valid-derivers %store o)
435 (list (derivation-file-name d))))))
436
437(test-assert "symlink is symlink"
438 (let* ((a (add-text-to-store %store "hello.txt" (random-text)))
439 (b (build-expression->derivation
440 %store "symlink"
441 '(symlink (assoc-ref %build-inputs "a") %output)
442 #:inputs `(("a" ,a))))
443 (c (build-expression->derivation
444 %store "symlink-reference"
445 `(call-with-output-file %output
446 (lambda (port)
447 ;; Check that B is indeed visible as a symlink. This should
448 ;; always be the case, both in the '--disable-chroot' and in
449 ;; the user namespace setups.
450 (pk 'stat (lstat (assoc-ref %build-inputs "b")))
451 (display (readlink (assoc-ref %build-inputs "b"))
452 port)))
453 #:inputs `(("b" ,b)))))
454 (and (build-derivations %store (list c))
455 (string=? (call-with-input-file (derivation->output-path c)
456 get-string-all)
457 a))))
458
459;; https://codeberg.org/guix/guix/issues/1104
460(test-equal "build outputs aren't writable"
461 #o555
462 (let ((drv (build-expression->derivation %store "writable-output"
463 `(begin
464 ,(random-text)
465 (mkdir %output)
466 (chmod %output #o755)))))
467 (build-derivations %store (list drv))
468 (stat:perms (stat (derivation->output-path drv "out")))))
469
470(unless (unprivileged-user-namespace-supported?)
471 (test-skip 1))
472(test-equal "isolated environment"
473 (string-join (append
474 '("PID: 1" "UID: 30001")
475 (delete-duplicates
476 (sort (list "/dev" "/tmp" "/proc" "/etc"
477 (match (string-tokenize (%store-prefix)
478 (char-set-complement
479 (char-set #\/)))
480 ((top _ ...) (string-append "/" top))))
481 string<?))
482 '("/etc/group" "/etc/hosts" "/etc/passwd")))
483 (let* ((b (add-text-to-store %store "build.sh"
484 "echo -n PID: $$ UID: $UID /* /etc/* > $out"))
485 (s (add-to-store %store "bash" #t "sha256"
486 (search-bootstrap-binary "bash"
487 (%current-system))))
488 (d (derivation %store "the-thing"
489 s `("-e" ,b)
490 #:env-vars `(("foo" . ,(random-text)))
491 #:sources (list b s)))
492 (o (derivation->output-path d)))
493 (and (build-derivations %store (list d))
494 (call-with-input-file o get-string-all))))
495
496(unless (unprivileged-user-namespace-supported?)
497 (test-skip 1))
498(test-equal "/etc/passwd and /etc/group"
499 '((name "nixbld")
500 (uid 30001)
501 (gid 30000)
502 (group-name "nixbld"))
503 (let ((d (build-expression->derivation
504 %store "passwd-group-check"
505 `(call-with-output-file %output
506 (lambda (port)
507 ',(gettimeofday)
508 (let ((pw (getpwuid (getuid)))
509 (gr (getgrgid (getgid))))
510 (write `((name ,(passwd:name pw))
511 (uid ,(passwd:uid pw))
512 (gid ,(passwd:gid pw))
513 (group-name ,(group:name gr)))
514 port)))))))
515 (build-derivations %store (list d))
516 (call-with-input-file (derivation->output-path d) read)))
517
518(unless (and (unprivileged-user-namespace-supported?)
519 (false-if-exception
520 (= (stat:gid (stat "/dev/kvm"))
521 (group:gid (getgrnam "kvm"))))
522 (= 1 (status:exit-val (system* "newgidmap"))))
523 (test-skip 1))
524(test-assert "kvm GID is mapped"
525 ;; Ensure that the "kvm" GID is mapped into the build user namespace such
526 ;; that chown'ing a file to that GID works as expected. See
527 ;; <https://issues.guix.gnu.org/77862>.
528 (let ((d (build-expression->derivation
529 %store "chown-to-supplementary-group"
530 `(let ((st (stat "/dev/kvm")))
531 ',(gettimeofday)
532 (pk 'supplementary-groups (getgroups))
533 (pk 'kvm-group (stat:gid st))
534 (unless (member (stat:gid st) (vector->list (getgroups)))
535 (error "supplementary groups lack 'kvm' GID"))
536 (mkdir "test")
537 (chown "test" (getuid) (stat:gid st))
538 (mkdir %output)))))
539 (build-derivations %store (list d))))
540
541(unless (unprivileged-user-namespace-supported?)
542 (test-skip 1))
543(test-equal "inputs are read-only"
544 "All good!"
545 (let* ((input (plain-file (string-append "might-be-tampered-with-"
546 (number->string
547 (car (gettimeofday))
548 16))
549 "All good!"))
550 (drv
551 (run-with-store %store
552 (gexp->derivation
553 "attempt-to-write-to-input"
554 (with-imported-modules (source-module-closure
555 '((guix build syscalls)))
556 #~(begin
557 (use-modules (guix build syscalls))
558
559 (let ((input #$input))
560 (chmod input #o666)
561 (call-with-output-file input
562 (lambda (port)
563 (display "BAD!" port)))
564 (mkdir #$output))))))))
565 (and (guard (c ((store-protocol-error? c) #t))
566 (build-derivations %store (list drv)))
567 (call-with-input-file (run-with-store %store
568 (lower-object input))
569 get-string-all))))
570
571(unless (unprivileged-user-namespace-supported?)
572 (test-skip 1))
573(test-assert "inputs cannot be remounted read-write"
574 (let ((drv
575 (run-with-store %store
576 (gexp->derivation
577 "attempt-to-remount-input-read-write"
578 (with-imported-modules (source-module-closure
579 '((guix build syscalls)))
580 #~(begin
581 (use-modules (guix build syscalls))
582
583 (let ((input #$(plain-file "input-that-might-be-tampered-with"
584 "All good!")))
585 (mount "none" input "none" (logior MS_BIND MS_REMOUNT))
586 (call-with-output-file input
587 (lambda (port)
588 (display "BAD!" port)))
589 (mkdir #$output))))))))
590 (guard (c ((store-protocol-error? c) #t))
591 (build-derivations %store (list drv))
592 #f)))
593
594(unless (unprivileged-user-namespace-supported?)
595 (test-skip 1))
596(test-assert "writing to build root leads to EACCES"
597 (let ((drv
598 (run-with-store %store
599 (gexp->derivation
600 "write-to-root"
601 #~(begin
602 (catch 'system-error
603 (lambda ()
604 (mkdir "/whatever"))
605 (lambda args
606 (format #t "mkdir failed, which is good: ~a~%"
607 (strerror (system-error-errno args)))
608 (when (= EACCES (system-error-errno args))
609 (exit 1))))
610
611 (mkdir #$output))))))
612 (guard (c ((store-protocol-error? c) c))
613 (build-derivations %store (list drv))
614 #f)))
615
616(unless (unprivileged-user-namespace-supported?)
617 (test-skip 1))
618(test-assert "/tmp, store, and /dev/{null,full} are writable"
619 ;; All of /tmp and all of the store must be writable (the store is writable
620 ;; so that derivation outputs can be written to it, but in practice it's
621 ;; always been wide open). Things like /dev/null must be writable too.
622 (let ((drv (run-with-store %store
623 (gexp->derivation
624 "check-tmp-and-store-are-writable"
625 #~(begin
626 (mkdir "/tmp/something")
627 (mkdir (in-vicinity (getenv "NIX_STORE")
628 "some-other-thing"))
629 (call-with-output-file "/dev/null"
630 (lambda (port)
631 (display "Welcome to the void." port)))
632 (catch 'system-error
633 (lambda ()
634 (call-with-output-file "/dev/full"
635 (lambda (port)
636 (display "No space left!" port)))
637 (error "Should have thrown!"))
638 (lambda args
639 (unless (= ENOSPC (system-error-errno args))
640 (apply throw args))))
641 (mkdir #$output))))))
642 (build-derivations %store (list drv))))
643
644(unless (unprivileged-user-namespace-supported?)
645 (test-skip 1))
646(test-assert "network is unreachable"
647 (let ((drv (run-with-store %store
648 (gexp->derivation
649 "check-network-unreachable"
650 #~(let ((check-connection-failure
651 (lambda (address expected-code)
652 (let ((s (socket AF_INET SOCK_STREAM 0)))
653 (catch 'system-error
654 (lambda ()
655 (connect s AF_INET (inet-pton AF_INET address) 80))
656 (lambda args
657 (let ((errno (system-error-errno args)))
658 (unless (= expected-code errno)
659 (error "wrong error code"
660 errno (strerror errno))))))))))
661 (check-connection-failure "127.0.0.1" ECONNREFUSED)
662 (check-connection-failure "9.9.9.9" ENETUNREACH)
663 (mkdir #$output))))))
664 (build-derivations %store (list drv))))
665
666(test-equal "with-build-handler"
667 'success
668 (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
669 (s (add-to-store %store "bash" #t "sha256"
670 (search-bootstrap-binary "bash"
671 (%current-system))))
672 (d1 (derivation %store "the-thing"
673 s `("-e" ,b)
674 #:env-vars `(("foo" . ,(random-text)))
675 #:sources (list b s)))
676 (d2 (derivation %store "the-thing"
677 s `("-e" ,b)
678 #:env-vars `(("foo" . ,(random-text))
679 ("bar" . "baz"))
680 #:sources (list b s)))
681 (o1 (derivation->output-path d1))
682 (o2 (derivation->output-path d2)))
683 (with-build-handler
684 (let ((counter 0))
685 (lambda (continue store things mode)
686 (match things
687 ((drv)
688 (set! counter (+ 1 counter))
689 (if (string=? drv (derivation-file-name d1))
690 (continue #t)
691 (and (string=? drv (derivation-file-name d2))
692 (= counter 2)
693 'success))))))
694 (build-derivations %store (list d1))
695 (build-derivations %store (list d2))
696 'fail)))
697
698(test-equal "with-build-handler + with-store"
699 'success
700 ;; Check that STORE remains valid when the build handler invokes CONTINUE,
701 ;; even though 'with-build-handler' is outside the dynamic extent of
702 ;; 'with-store'.
703 (with-build-handler (lambda (continue store things mode)
704 (match things
705 ((drv)
706 (and (string-suffix? "thingie.drv" drv)
707 (not (port-closed?
708 (store-connection-socket store)))
709 (continue #t)))))
710 (with-store store
711 (let* ((b (add-text-to-store store "build" "echo $foo > $out" '()))
712 (s (add-to-store store "bash" #t "sha256"
713 (search-bootstrap-binary "bash"
714 (%current-system))))
715 (d (derivation store "thingie"
716 s `("-e" ,b)
717 #:env-vars `(("foo" . ,(random-text)))
718 #:sources (list b s))))
719 (build-derivations store (list d))
720
721 ;; Here STORE's socket should still be open.
722 (and (valid-path? store (derivation->output-path d))
723 'success)))))
724
725(test-assert "map/accumulate-builds"
726 (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
727 (s (add-to-store %store "bash" #t "sha256"
728 (search-bootstrap-binary "bash"
729 (%current-system))))
730 (d1 (derivation %store "the-thing"
731 s `("-e" ,b)
732 #:env-vars `(("foo" . ,(random-text)))
733 #:sources (list b s)))
734 (d2 (derivation %store "the-thing"
735 s `("-e" ,b)
736 #:env-vars `(("foo" . ,(random-text))
737 ("bar" . "baz"))
738 #:sources (list b s))))
739 (with-build-handler (lambda (continue store things mode)
740 (equal? (map derivation-file-name (list d1 d2))
741 things))
742 (map/accumulate-builds %store
743 (lambda (drv)
744 (build-derivations %store (list drv))
745 (add-to-store %store "content-addressed"
746 #t "sha256"
747 (derivation->output-path drv)))
748 (list d1 d2)))))
749
750(test-equal "map/accumulate-builds cutoff" ;https://issues.guix.gnu.org/50264
751 (iota 20)
752
753 ;; Make sure that, when the cutoff is reached, 'map/accumulate-builds' still
754 ;; returns the right result and calls the build handler by batches.
755 (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
756 (s (add-to-store %store "bash" #t "sha256"
757 (search-bootstrap-binary "bash"
758 (%current-system))))
759 (d (map (lambda (i)
760 (derivation %store (string-append "the-thing-"
761 (number->string i))
762 s `("-e" ,b)
763 #:env-vars `(("foo" . ,(random-text)))
764 #:sources (list b s)
765 #:properties `((n . ,i))))
766 (iota 20)))
767 (calls '()))
768 (define lst
769 (with-build-handler (lambda (continue store things mode)
770 (set! calls (cons things calls))
771 (continue #f))
772 (map/accumulate-builds %store
773 (lambda (d)
774 (build-derivations %store (list d))
775 (assq-ref (derivation-properties d) 'n))
776 d
777 #:cutoff 7)))
778
779 (match (reverse calls)
780 (((batch1 ...) (batch2 ...) (batch3 ...))
781 (and (equal? (map derivation-file-name (take d 8)) batch1)
782 (equal? (map derivation-file-name (take (drop d 8) 8)) batch2)
783 (equal? (map derivation-file-name (drop d 16)) batch3)
784 lst)))))
785
786(test-equal "map/accumulate-builds and different store"
787 '(d2) ;see <https://issues.guix.gnu.org/46756>
788 (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
789 (s (add-to-store %store "bash" #t "sha256"
790 (search-bootstrap-binary "bash"
791 (%current-system))))
792 (d1 (derivation %store "first"
793 s `("-e" ,b)
794 #:env-vars `(("foo" . ,(random-text)))
795 #:sources (list b s)))
796 (d2 (derivation %store "second"
797 s `("-e" ,b)
798 #:env-vars `(("foo" . ,(random-text))
799 ("bar" . "baz"))
800 #:sources (list b s))))
801 (with-store alternate-store
802 (with-build-handler (lambda (continue store things mode)
803 ;; If this handler is called, it means that
804 ;; 'map/accumulate-builds' triggered a build,
805 ;; which it shouldn't since the inner
806 ;; 'build-derivations' call is for another store.
807 'failed)
808 (map/accumulate-builds %store
809 (lambda (drv)
810 (build-derivations alternate-store (list d2))
811 'd2)
812 (list d1))))))
813
814(test-assert "mapm/accumulate-builds"
815 (let* ((d1 (run-with-store %store
816 (gexp->derivation "foo" #~(mkdir #$output))))
817 (d2 (run-with-store %store
818 (gexp->derivation "bar" #~(mkdir #$output)))))
819 (with-build-handler (lambda (continue store things mode)
820 (equal? (map derivation-file-name (pk 'zz (list d1 d2)))
821 (pk 'XX things)))
822 (run-with-store %store
823 (mapm/accumulate-builds built-derivations `((,d1) (,d2)))))))
824
825(test-equal "mapm/accumulate-builds, %current-target-system"
826 (make-list 2 '("i586-pc-gnu" "i586-pc-gnu"))
827 ;; Both the 'mapm' and 'mapm/accumulate-builds' procedures should see the
828 ;; right #:target.
829 (run-with-store %store
830 (mlet %store-monad ((lst1 (mapm %store-monad
831 (lambda _
832 (current-target-system))
833 '(a b)))
834 (lst2 (mapm/accumulate-builds
835 (lambda _
836 (current-target-system))
837 '(a b))))
838 (return (list lst1 lst2)))
839 #:system system
840 #:target "i586-pc-gnu"))
841
842(test-assert "topologically-sorted, one item"
843 (let* ((a (add-text-to-store %store "a" "a"))
844 (b (add-text-to-store %store "b" "b" (list a)))
845 (c (add-text-to-store %store "c" "c" (list b)))
846 (d (add-text-to-store %store "d" "d" (list c)))
847 (s (topologically-sorted %store (list d))))
848 (equal? s (list a b c d))))
849
850(test-assert "topologically-sorted, several items"
851 (let* ((a (add-text-to-store %store "a" "a"))
852 (b (add-text-to-store %store "b" "b" (list a)))
853 (c (add-text-to-store %store "c" "c" (list b)))
854 (d (add-text-to-store %store "d" "d" (list c)))
855 (s1 (topologically-sorted %store (list d a c b)))
856 (s2 (topologically-sorted %store (list b d c a b d))))
857 (equal? s1 s2 (list a b c d))))
858
859(test-assert "topologically-sorted, more difficult"
860 (let* ((a (add-text-to-store %store "a" "a"))
861 (b (add-text-to-store %store "b" "b" (list a)))
862 (c (add-text-to-store %store "c" "c" (list b)))
863 (d (add-text-to-store %store "d" "d" (list c)))
864 (w (add-text-to-store %store "w" "w"))
865 (x (add-text-to-store %store "x" "x" (list w)))
866 (y (add-text-to-store %store "y" "y" (list x d)))
867 (s1 (topologically-sorted %store (list y)))
868 (s2 (topologically-sorted %store (list c y)))
869 (s3 (topologically-sorted %store (cons y (references %store y)))))
870 ;; The order in which 'references' returns the references of Y is
871 ;; unspecified, so accommodate.
872 (let* ((x-then-d? (equal? (references %store y) (list x d))))
873 (and (equal? s1
874 (if x-then-d?
875 (list w x a b c d y)
876 (list a b c d w x y)))
877 (equal? s2
878 (if x-then-d?
879 (list a b c w x d y)
880 (list a b c d w x y)))
881 (lset= string=? s1 s3)))))
882
883(test-assert "current-build-output-port, UTF-8"
884 ;; Are UTF-8 strings in the build log properly interpreted?
885 (string-contains
886 (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
887 (call-with-output-string
888 (lambda (port)
889 (parameterize ((current-build-output-port port))
890 (let* ((s "Here’s a Greek letter: λ.")
891 (d (build-expression->derivation
892 %store "foo" `(display ,s)
893 #:guile-for-build
894 (package-derivation %store %bootstrap-guile
895 (%current-system)))))
896 (guard (c ((store-protocol-error? c) #t))
897 (build-derivations %store (list d))))))))
898 "Here’s a Greek letter: λ."))
899
900(test-assert "current-build-output-port, UTF-8 + garbage"
901 ;; What about a mixture of UTF-8 + garbage?
902 (string-contains
903 (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
904 (call-with-output-string
905 (lambda (port)
906 (parameterize ((current-build-output-port port))
907 (let ((d (build-expression->derivation
908 %store "foo"
909 `(begin
910 (use-modules (rnrs io ports))
911 (display "garbage: ")
912 (put-bytevector (current-output-port) #vu8(128))
913 (display "lambda: λ\n"))
914 #:guile-for-build
915 (package-derivation %store %bootstrap-guile))))
916 (guard (c ((store-protocol-error? c) #t))
917 (build-derivations %store (list d))))))))
918 "garbage: �lambda: λ"))
919
920(test-assert "log-file, derivation"
921 (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
922 (s (add-to-store %store "bash" #t "sha256"
923 (search-bootstrap-binary "bash"
924 (%current-system))))
925 (d (derivation %store "the-thing"
926 s `("-e" ,b)
927 #:env-vars `(("foo" . ,(random-text)))
928 #:inputs `((,b) (,s)))))
929 (and (build-derivations %store (list d))
930 (file-exists? (pk (log-file %store (derivation-file-name d)))))))
931
932(test-assert "log-file, output file name"
933 (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
934 (s (add-to-store %store "bash" #t "sha256"
935 (search-bootstrap-binary "bash"
936 (%current-system))))
937 (d (derivation %store "the-thing"
938 s `("-e" ,b)
939 #:env-vars `(("foo" . ,(random-text)))
940 #:inputs `((,b) (,s))))
941 (o (derivation->output-path d)))
942 (and (build-derivations %store (list d))
943 (file-exists? (pk (log-file %store o)))
944 (string=? (log-file %store (derivation-file-name d))
945 (log-file %store o)))))
946
947(test-assert "no substitutes"
948 (with-store s
949 (let* ((d1 (package-derivation s %bootstrap-guile (%current-system)))
950 (d2 (package-derivation s %bootstrap-glibc (%current-system)))
951 (o (map derivation->output-path (list d1 d2))))
952 (set-build-options s #:use-substitutes? #f)
953 (and (not (has-substitutes? s (derivation-file-name d1)))
954 (not (has-substitutes? s (derivation-file-name d2)))
955 (null? (substitutable-paths s o))
956 (null? (substitutable-path-info s o))))))
957
958(test-assert "build-things with output path"
959 (with-store s
960 (let* ((c (random-text)) ;contents of the output
961 (d (build-expression->derivation
962 s "substitute-me"
963 `(call-with-output-file %output
964 (lambda (p)
965 (display ,c p)))
966 #:guile-for-build
967 (package-derivation s %bootstrap-guile (%current-system))))
968 (o (derivation->output-path d)))
969 (set-build-options s #:use-substitutes? #f)
970
971 ;; Pass 'build-things' the output file name, O. However, since there
972 ;; are no substitutes for O, it will just do nothing.
973 (build-things s (list o))
974 (not (valid-path? s o)))))
975
976(test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
977
978(test-assert "substitute query"
979 (with-store s
980 (let* ((d (package-derivation s %bootstrap-guile (%current-system)))
981 (o (derivation->output-path d)))
982 ;; Create fake substituter data, to be read by 'guix substitute'.
983 (with-derivation-narinfo d
984 ;; Remove entry from the local cache.
985 (false-if-exception
986 (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
987 "/guix/substitute")))
988
989 ;; Make sure 'guix substitute' correctly communicates the above
990 ;; data.
991 (set-build-options s #:use-substitutes? #t
992 #:substitute-urls (%test-substitute-urls))
993 (and (has-substitutes? s o)
994 (equal? (list o) (substitutable-paths s (list o)))
995 (match (pk 'spi (substitutable-path-info s (list o)))
996 (((? substitutable? s))
997 (and (string=? (substitutable-deriver s)
998 (derivation-file-name d))
999 (null? (substitutable-references s))
1000 (equal? (substitutable-nar-size s) 1234)))))))))
1001
1002(test-assert "substitute query, alternating URLs"
1003 (let* ((d (with-store s
1004 (package-derivation s %bootstrap-guile (%current-system))))
1005 (o (derivation->output-path d)))
1006 (with-derivation-narinfo d
1007 ;; Remove entry from the local cache.
1008 (false-if-exception
1009 (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
1010 "/guix/substitute")))
1011
1012 ;; Note: We reconnect to the daemon to force a new instance of 'guix
1013 ;; substitute' to be used; otherwise the #:substitute-urls of
1014 ;; 'set-build-options' would have no effect.
1015
1016 (and (with-store s ;the right substitute URL
1017 (set-build-options s #:use-substitutes? #t
1018 #:substitute-urls (%test-substitute-urls))
1019 (has-substitutes? s o))
1020 (with-store s ;the wrong one
1021 (set-build-options s #:use-substitutes? #t
1022 #:substitute-urls (list
1023 "http://does-not-exist"))
1024 (not (has-substitutes? s o)))
1025 (with-store s ;the right one again
1026 (set-build-options s #:use-substitutes? #t
1027 #:substitute-urls (%test-substitute-urls))
1028 (has-substitutes? s o))
1029 (with-store s ;empty list of URLs
1030 (set-build-options s #:use-substitutes? #t
1031 #:substitute-urls '())
1032 (not (has-substitutes? s o)))))))
1033
1034(test-assert "substitute"
1035 (with-store s
1036 (let* ((c (random-text)) ; contents of the output
1037 (d (build-expression->derivation
1038 s "substitute-me"
1039 `(call-with-output-file %output
1040 (lambda (p)
1041 (exit 1) ; would actually fail
1042 (display ,c p)))
1043 #:guile-for-build
1044 (package-derivation s %bootstrap-guile (%current-system))))
1045 (o (derivation->output-path d)))
1046 (with-derivation-substitute d c
1047 (set-build-options s #:use-substitutes? #t
1048 #:substitute-urls (%test-substitute-urls))
1049 (and (has-substitutes? s o)
1050 (build-derivations s (list d))
1051 (canonical-file? o)
1052 (equal? c (call-with-input-file o get-string-all)))))))
1053
1054(test-assert "substitute, deduplication"
1055 (with-store s
1056 ;; Note: C must be longer than %DEDUPLICATION-MINIMUM-SIZE.
1057 (let* ((c (string-concatenate
1058 (make-list 200 (random-text)))) ; contents of the output
1059 (g (package-derivation s %bootstrap-guile))
1060 (d1 (build-expression->derivation s "substitute-me"
1061 `(begin ,c (exit 1))
1062 #:guile-for-build g))
1063 (d2 (build-expression->derivation s "build-me"
1064 `(call-with-output-file %output
1065 (lambda (p)
1066 (display ,c p)))
1067 #:guile-for-build g))
1068 (o1 (derivation->output-path d1))
1069 (o2 (derivation->output-path d2)))
1070 (with-derivation-substitute d1 c
1071 (set-build-options s #:use-substitutes? #t
1072 #:substitute-urls (%test-substitute-urls))
1073 (and (has-substitutes? s o1)
1074 (build-derivations s (list d2)) ;build
1075 (build-derivations s (list d1)) ;substitute
1076 (canonical-file? o1)
1077 (equal? c (call-with-input-file o1 get-string-all))
1078 (= (stat:ino (stat o1)) (stat:ino (stat o2))))))))
1079
1080(test-assert "substitute + build-things with output path"
1081 (with-store s
1082 (let* ((c (random-text)) ;contents of the output
1083 (d (build-expression->derivation
1084 s "substitute-me"
1085 `(call-with-output-file %output
1086 (lambda (p)
1087 (exit 1) ;would actually fail
1088 (display ,c p)))
1089 #:guile-for-build
1090 (package-derivation s %bootstrap-guile (%current-system))))
1091 (o (derivation->output-path d)))
1092 (with-derivation-substitute d c
1093 (set-build-options s #:use-substitutes? #t
1094 #:substitute-urls (%test-substitute-urls))
1095 (and (has-substitutes? s o)
1096 (build-things s (list o)) ;give the output path
1097 (valid-path? s o)
1098 (canonical-file? o)
1099 (equal? c (call-with-input-file o get-string-all)))))))
1100
1101(test-assert "substitute + build-things with specific output"
1102 (with-store s
1103 (let* ((c (random-text)) ;contents of the output
1104 (d (build-expression->derivation
1105 s "substitute-me" `(begin ,c (exit 1)) ;would fail
1106 #:outputs '("out" "one" "two")
1107 #:guile-for-build
1108 (package-derivation s %bootstrap-guile (%current-system))))
1109 (o (derivation->output-path d)))
1110 (with-derivation-substitute d c
1111 (set-build-options s #:use-substitutes? #t
1112 #:substitute-urls (%test-substitute-urls))
1113 (and (has-substitutes? s o)
1114
1115 ;; Ask for nothing but the "out" output of D.
1116 (build-things s `((,(derivation-file-name d) . "out")))
1117
1118 (valid-path? s o)
1119 (canonical-file? o)
1120 (equal? c (call-with-input-file o get-string-all)))))))
1121
1122(test-assert "substitute, corrupt output hash"
1123 ;; Tweak the substituter into installing a substitute whose hash doesn't
1124 ;; match the one announced in the narinfo. The daemon must notice this and
1125 ;; raise an error.
1126 (with-store s
1127 (let* ((c "hello, world") ; contents of the output
1128 (d (build-expression->derivation
1129 s "corrupt-substitute"
1130 `(mkdir %output)
1131 #:guile-for-build
1132 (package-derivation s %bootstrap-guile (%current-system))))
1133 (o (derivation->output-path d)))
1134 (with-derivation-substitute d c
1135 (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C
1136
1137 ;; Make sure we use 'guix substitute'.
1138 (set-build-options s
1139 #:use-substitutes? #t
1140 #:fallback? #f
1141 #:substitute-urls (%test-substitute-urls))
1142 (and (has-substitutes? s o)
1143 (guard (c ((store-protocol-error? c)
1144 ;; XXX: the daemon writes "hash mismatch in downloaded
1145 ;; path", but the actual error returned to the client
1146 ;; doesn't mention that.
1147 (pk 'corrupt c)
1148 (not (zero? (store-protocol-error-status c)))))
1149 (build-derivations s (list d))
1150 #f))))))
1151
1152(test-assert "substitute, corrupt output hash, build trace"
1153 ;; Likewise, and check the build trace.
1154 (with-store s
1155 (let* ((c "hello, world") ; contents of the output
1156 (d (build-expression->derivation
1157 s "corrupt-substitute"
1158 `(mkdir %output)
1159 #:guile-for-build
1160 (package-derivation s %bootstrap-guile (%current-system))))
1161 (o (derivation->output-path d)))
1162 ;; Make sure we use 'guix substitute'.
1163 (set-build-options s
1164 #:print-build-trace #t
1165 #:use-substitutes? #t
1166 #:fallback? #f
1167 #:substitute-urls (%test-substitute-urls))
1168
1169 (with-derivation-substitute d c
1170 (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C
1171
1172 (define output
1173 (call-with-output-string
1174 (lambda (port)
1175 (parameterize ((current-build-output-port port))
1176 (guard (c ((store-protocol-error? c) #t))
1177 (build-derivations s (list d))
1178 #f)))))
1179
1180 (define actual-hash
1181 (let-values (((port get-hash)
1182 (gcrypt:open-hash-port
1183 (gcrypt:hash-algorithm gcrypt:sha256))))
1184 (write-file-tree "foo" port
1185 #:file-type+size
1186 (lambda _
1187 (values 'regular (string-length c)))
1188 #:file-port
1189 (lambda _
1190 (open-input-string c)))
1191 (close-port port)
1192 (bytevector->nix-base32-string (get-hash))))
1193
1194 (define expected-hash
1195 (bytevector->nix-base32-string (make-bytevector 32 0)))
1196
1197 (define mismatch
1198 (string-append "@ hash-mismatch " o " sha256 "
1199 expected-hash " " actual-hash "\n"))
1200
1201 (define failure
1202 (string-append "@ substituter-failed " o))
1203
1204 (and (string-contains output mismatch)
1205 (string-contains output failure))))))
1206
1207(test-assert "substitute --fallback"
1208 (with-store s
1209 (let* ((t (random-text)) ; contents of the output
1210 (d (build-expression->derivation
1211 s "substitute-me-not"
1212 `(call-with-output-file %output
1213 (lambda (p)
1214 (display ,t p)))
1215 #:guile-for-build
1216 (package-derivation s %bootstrap-guile (%current-system))))
1217 (o (derivation->output-path d)))
1218 ;; Create fake substituter data, to be read by 'guix substitute'.
1219 (with-derivation-narinfo d
1220 ;; Make sure we use 'guix substitute'.
1221 (set-build-options s #:use-substitutes? #t
1222 #:substitute-urls (%test-substitute-urls))
1223 (and (has-substitutes? s o)
1224 (guard (c ((store-protocol-error? c)
1225 ;; The substituter failed as expected. Now make
1226 ;; sure that #:fallback? #t works correctly.
1227 (set-build-options s
1228 #:use-substitutes? #t
1229 #:substitute-urls
1230 (%test-substitute-urls)
1231 #:fallback? #t)
1232 (and (build-derivations s (list d))
1233 (equal? t (call-with-input-file o
1234 get-string-all)))))
1235 ;; Should fail.
1236 (build-derivations s (list d))
1237 #f))))))
1238
1239(test-equal "substitute query and large size"
1240 (+ 100 (expt 2 63)) ;<https://issues.guix.gnu.org/51983>
1241 (with-store s
1242 (let* ((size (+ 100 (expt 2 63))) ;does not fit in signed 'long long'
1243 (item (string-append (%store-prefix)
1244 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bad-size")))
1245 ;; Create fake substituter data, to be read by 'guix substitute'.
1246 (call-with-output-file (string-append (%substitute-directory)
1247 "/" (store-path-hash-part item)
1248 ".narinfo")
1249 (lambda (port)
1250 (format port "StorePath: ~a
1251URL: http://example.org
1252Compression: none
1253NarSize: ~a
1254NarHash: sha256:0fj9vhblff2997pi7qjj7lhmy7wzhnjwmkm2hmq6gr4fzmg10s0w
1255References:
1256System: x86_64-linux~%"
1257 item size)))
1258
1259 ;; Remove entry from the local cache.
1260 (false-if-exception
1261 (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
1262 "/guix/substitute")))
1263
1264 ;; Make sure 'guix substitute' correctly communicates the above
1265 ;; data.
1266 (set-build-options s #:use-substitutes? #t
1267 #:substitute-urls (%test-substitute-urls))
1268 (match (pk 'spi (substitutable-path-info s (list item)))
1269 (((? substitutable? s))
1270 (and (equal? (substitutable-path s) item)
1271 (substitutable-nar-size s)))))))
1272
1273(test-equal "substitute and large size"
1274 (+ 100 (expt 2 31)) ;<https://issues.guix.gnu.org/46212>
1275 (with-store s
1276 (let* ((size (+ 100 (expt 2 31))) ;does not fit in signed 'int'
1277 (item (string-append (%store-prefix)
1278 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bad-size-"
1279 (random-text)))
1280 (nar (string-append (%substitute-directory) "/nar")))
1281 ;; Create a dummy nar to allow for substitution.
1282 (call-with-output-file nar
1283 (lambda (port)
1284 (write-file-tree (store-path-package-name item) port
1285 #:file-type+size (lambda _
1286 (values 'regular 12))
1287 #:file-port (lambda _
1288 (open-input-string "Hello world.")))))
1289
1290 ;; Create fake substituter data, to be read by 'guix substitute'.
1291 (call-with-output-file (string-append (%substitute-directory)
1292 "/" (store-path-hash-part item)
1293 ".narinfo")
1294 (lambda (port)
1295 (format port "StorePath: ~a
1296URL: file://~a
1297Compression: none
1298NarSize: ~a
1299NarHash: sha256:~a
1300References:
1301System: x86_64-linux~%"
1302 item nar size
1303 (bytevector->nix-base32-string (gcrypt:file-sha256 nar)))))
1304
1305 ;; Remove entry from the local cache.
1306 (false-if-exception
1307 (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
1308 "/guix/substitute")))
1309
1310 ;; Make sure 'guix substitute' correctly communicates the above
1311 ;; data.
1312 (set-build-options s #:use-substitutes? #t
1313 #:substitute-urls (%test-substitute-urls))
1314 (ensure-path s item)
1315 (path-info-nar-size (query-path-info s item)))))
1316
1317(test-assert "export/import several paths"
1318 (let* ((texts (unfold (cut >= <> 10)
1319 (lambda _ (random-text))
1320 1+
1321 0))
1322 (files (map (cut add-text-to-store %store "text" <>) texts))
1323 (dump (call-with-bytevector-output-port
1324 (cut export-paths %store files <>))))
1325 (delete-paths %store files)
1326 (and (every (negate file-exists?) files)
1327 (let* ((source (open-bytevector-input-port dump))
1328 (imported (import-paths %store source)))
1329 (and (equal? imported files)
1330 (every file-exists? files)
1331 (equal? texts
1332 (map (lambda (file)
1333 (call-with-input-file file
1334 get-string-all))
1335 files)))))))
1336
1337(test-assert "export/import paths, ensure topological order"
1338 (let* ((file0 (add-text-to-store %store "baz" (random-text)))
1339 (file1 (add-text-to-store %store "foo" (random-text)
1340 (list file0)))
1341 (file2 (add-text-to-store %store "bar" (random-text)
1342 (list file1)))
1343 (files (list file1 file2))
1344 (dump1 (call-with-bytevector-output-port
1345 (cute export-paths %store (list file1 file2) <>)))
1346 (dump2 (call-with-bytevector-output-port
1347 (cute export-paths %store (list file2 file1) <>))))
1348 (delete-paths %store files)
1349 (and (every (negate file-exists?) files)
1350 (bytevector=? dump1 dump2)
1351 (let* ((source (open-bytevector-input-port dump1))
1352 (imported (import-paths %store source)))
1353 ;; DUMP1 should contain exactly FILE1 and FILE2, not FILE0.
1354 (and (equal? imported (list file1 file2))
1355 (every file-exists? files)
1356 (equal? (list file0) (references %store file1))
1357 (equal? (list file1) (references %store file2)))))))
1358
1359(test-assert "export/import incomplete"
1360 (let* ((file0 (add-text-to-store %store "baz" (random-text)))
1361 (file1 (add-text-to-store %store "foo" (random-text)
1362 (list file0)))
1363 (file2 (add-text-to-store %store "bar" (random-text)
1364 (list file1)))
1365 (dump (call-with-bytevector-output-port
1366 (cute export-paths %store (list file2) <>))))
1367 (delete-paths %store (list file0 file1 file2))
1368 (guard (c ((store-protocol-error? c)
1369 (and (not (zero? (store-protocol-error-status c)))
1370 (string-contains (store-protocol-error-message c)
1371 "not valid"))))
1372 ;; Here we get an exception because DUMP does not include FILE0 and
1373 ;; FILE1, which are dependencies of FILE2.
1374 (import-paths %store (open-bytevector-input-port dump)))))
1375
1376(test-assert "export/import recursive"
1377 (let* ((file0 (add-text-to-store %store "baz" (random-text)))
1378 (file1 (add-text-to-store %store "foo" (random-text)
1379 (list file0)))
1380 (file2 (add-text-to-store %store "bar" (random-text)
1381 (list file1)))
1382 (dump (call-with-bytevector-output-port
1383 (cute export-paths %store (list file2) <>
1384 #:recursive? #t))))
1385 (delete-paths %store (list file0 file1 file2))
1386 (let ((imported (import-paths %store (open-bytevector-input-port dump))))
1387 (and (equal? imported (list file0 file1 file2))
1388 (every file-exists? (list file0 file1 file2))
1389 (equal? (list file0) (references %store file1))
1390 (equal? (list file1) (references %store file2))))))
1391
1392(test-assert "write-file & export-path yield the same result"
1393 ;; Here we compare 'write-file' and the daemon's own implementation.
1394 ;; 'write-file' is the reference because we know it sorts file
1395 ;; deterministically. Conversely, the daemon uses 'readdir' and the entries
1396 ;; currently happen to be sorted as a side-effect of some unrelated
1397 ;; operation (search for 'unhacked' in archive.cc.) Make sure we detect any
1398 ;; changes there.
1399 (run-with-store %store
1400 (mlet* %store-monad ((drv1 (package->derivation %bootstrap-guile))
1401 (out1 -> (derivation->output-path drv1))
1402 (data -> (unfold (cut >= <> 26)
1403 (lambda (i)
1404 (random-bytevector 128))
1405 1+ 0))
1406 (build
1407 -> #~(begin
1408 (use-modules (rnrs io ports) (srfi srfi-1))
1409 (let ()
1410 (define letters
1411 (map (lambda (i)
1412 (string
1413 (integer->char
1414 (+ i (char->integer #\a)))))
1415 (iota 26)))
1416 (define (touch file data)
1417 (call-with-output-file file
1418 (lambda (port)
1419 (put-bytevector port data))))
1420
1421 (mkdir #$output)
1422 (chdir #$output)
1423
1424 ;; The files must be different so they have
1425 ;; different inode numbers, and the inode
1426 ;; order must differ from the lexicographic
1427 ;; order.
1428 (for-each touch
1429 (append (drop letters 10)
1430 (take letters 10))
1431 (list #$@data))
1432 #t)))
1433 (drv2 (gexp->derivation "bunch" build))
1434 (out2 -> (derivation->output-path drv2))
1435 (item-info -> (store-lift query-path-info)))
1436 (mbegin %store-monad
1437 (built-derivations (list drv1 drv2))
1438 (foldm %store-monad
1439 (lambda (item result)
1440 (define ref-hash
1441 (let-values (((port get) (gcrypt:open-sha256-port)))
1442 (write-file item port)
1443 (close-port port)
1444 (get)))
1445
1446 ;; 'query-path-info' returns a hash produced by using the
1447 ;; daemon's C++ 'dump' function, which is the implementation
1448 ;; under test.
1449 (>>= (item-info item)
1450 (lambda (info)
1451 (return
1452 (and result
1453 (bytevector=? (path-info-hash info) ref-hash))))))
1454 #t
1455 (list out1 out2))))
1456 #:guile-for-build (%guile-for-build)))
1457
1458
1459(test-assert "import not signed"
1460 (let* ((content (random-text))
1461 (name "fake-derivation")
1462 (store-item (output-path "out"
1463 (gcrypt:sha256 #vu8())
1464 name))
1465 (dump (call-with-bytevector-output-port
1466 (lambda (port)
1467 (write-int 1 port) ;start
1468
1469 (write-file-tree name port ;contents
1470 #:file-type+size
1471 (lambda (_)
1472 (values 'regular
1473 (string-length content)))
1474 #:file-port
1475 (lambda (_)
1476 (open-input-string content)))
1477 (write-int #x4558494e port) ;%export-magic
1478 (write-string store-item port) ;store item
1479 (write-string-list '() port) ;references
1480 (write-string "" port) ;deriver
1481 (write-int 0 port) ;not signed
1482
1483 (write-int 0 port))))) ;done
1484
1485 ;; Ensure 'import-paths' raises an exception.
1486 (guard (c ((store-protocol-error? c)
1487 (and (not (zero? (store-protocol-error-status c)))
1488 (string-contains (store-protocol-error-message c)
1489 "lacks a signature"))))
1490 (let* ((source (open-bytevector-input-port dump))
1491 (imported (import-paths %store source)))
1492 (pk 'unsigned-imported imported)
1493 #f))))
1494
1495(test-assert "import signed by unauthorized key"
1496 (let* ((content (random-text))
1497 (name "fake-derivation")
1498 (store-item (output-path "out"
1499 (gcrypt:sha256 #vu8())
1500 name))
1501 (key (gcrypt:generate-key
1502 (gcrypt:string->canonical-sexp
1503 "(genkey (ecdsa (curve Ed25519) (flags rfc6979)))")))
1504 (dump (call-with-bytevector-output-port
1505 (lambda (port)
1506 (write-int 1 port) ;start
1507
1508 (write-file-tree name port ;contents
1509 #:file-type+size
1510 (lambda (_)
1511 (values 'regular
1512 (string-length content)))
1513 #:file-port
1514 (lambda (_)
1515 (open-input-string content)))
1516 (write-int #x4558494e port) ;%export-magic
1517 (write-string store-item port) ;store item
1518 (write-string-list '() port) ;references
1519 (write-string "" port) ;deriver
1520 (write-int 1 port) ;signed
1521 (write-string (gcrypt:canonical-sexp->string
1522 (signature-sexp
1523 (gcrypt:bytevector->hash-data
1524 (gcrypt:sha256 #vu8(0 1 2))
1525 #:key-type 'ecc)
1526 (gcrypt:find-sexp-token key 'private-key)
1527 (gcrypt:find-sexp-token key 'public-key)))
1528 port)
1529
1530 (write-int 0 port))))) ;done
1531
1532 ;; Ensure 'import-paths' raises an exception.
1533 (guard (c ((store-protocol-error? c)
1534 (and (not (zero? (store-protocol-error-status c)))
1535 (string-contains (store-protocol-error-message c)
1536 "unauthorized public key"))))
1537 (let* ((source (open-bytevector-input-port dump))
1538 (imported (import-paths %store source)))
1539 (pk 'unauthorized-imported imported)
1540 #f))))
1541
1542(test-assert "import with corrupt signature"
1543 (let* ((content (random-text))
1544 (name "fake-derivation")
1545 (store-item (output-path "out"
1546 (gcrypt:sha256 #vu8())
1547 name))
1548 (dump (call-with-bytevector-output-port
1549 (lambda (port)
1550 (write-int 1 port) ;start
1551
1552 (write-file-tree name port ;contents
1553 #:file-type+size
1554 (lambda (_)
1555 (values 'regular
1556 (string-length content)))
1557 #:file-port
1558 (lambda (_)
1559 (open-input-string content)))
1560 (write-int #x4558494e port) ;%export-magic
1561 (write-string store-item port) ;store item
1562 (write-string-list '() port) ;references
1563 (write-string "" port) ;deriver
1564 (write-int 1 port) ;signed
1565 (write-string (object->string '(signature broken))
1566 port)
1567
1568 (write-int 0 port))))) ;done
1569
1570 ;; Ensure 'import-paths' raises an exception.
1571 (guard (c ((store-protocol-error? c)
1572 (and (not (zero? (store-protocol-error-status c)))
1573 (string-contains (store-protocol-error-message c)
1574 "corrupt signature"))))
1575 (let* ((source (open-bytevector-input-port dump))
1576 (imported (import-paths %store source)))
1577 (pk 'corrupt-signature-imported imported)
1578 #f))))
1579
1580(test-assert "import signed by authorized key but hash doesn't match"
1581 (let* ((content (random-text))
1582 (name "fake-derivation")
1583 (store-item (output-path "out"
1584 (gcrypt:sha256 #vu8())
1585 name))
1586 ;; This key is known to be in the ACL by default.
1587 (public-key
1588 (call-with-input-file (string-append %config-directory "/signing-key.pub")
1589 (compose gcrypt:string->canonical-sexp get-string-all)))
1590 (private-key
1591 (call-with-input-file (string-append %config-directory "/signing-key.sec")
1592 (compose gcrypt:string->canonical-sexp get-string-all)))
1593
1594 (dump (call-with-bytevector-output-port
1595 (lambda (port)
1596 (write-int 1 port) ;start
1597
1598 (write-file-tree name port ;contents
1599 #:file-type+size
1600 (lambda (_)
1601 (values 'regular
1602 (string-length content)))
1603 #:file-port
1604 (lambda (_)
1605 (open-input-string content)))
1606 (write-int #x4558494e port) ;%export-magic
1607 (write-string store-item port) ;store item
1608 (write-string-list '() port) ;references
1609 (write-string "" port) ;deriver
1610 (write-int 1 port) ;signed
1611 (write-string (gcrypt:canonical-sexp->string
1612 (signature-sexp
1613 (gcrypt:bytevector->hash-data
1614 (gcrypt:sha256 #vu8(0 1 2))
1615 #:key-type 'rsa)
1616 private-key
1617 public-key))
1618 port)
1619
1620 (write-int 0 port))))) ;done
1621
1622 ;; Ensure 'import-paths' raises an exception.
1623 (guard (c ((store-protocol-error? c)
1624 (and (not (zero? (store-protocol-error-status c)))
1625 (string-contains (store-protocol-error-message c)
1626 "hash doesn't match"))))
1627 (let* ((source (open-bytevector-input-port dump))
1628 (imported (import-paths %store source)))
1629 (pk 'hash-mismatch-imported imported)
1630 #f))))
1631
1632(test-assert "import not signed but content-addressed tree"
1633 (let* ((text (random-text))
1634 (file (add-file-tree-to-store %store
1635 `("tree" directory
1636 ("text" regular (data ,text))
1637 ("link" symlink "text"))))
1638 (dump (call-with-bytevector-output-port
1639 (lambda (port)
1640 (write-int 1 port) ;start
1641
1642 (write-file file port) ;contents
1643 (write-int #x4558494e port) ;%export-magic
1644 (write-string file port) ;store item
1645 (write-string-list '() port) ;references
1646 (write-string "" port) ;deriver
1647 (write-int 0 port) ;not signed
1648
1649 (write-int 0 port))))) ;done
1650
1651 ;; Ensure 'import-paths' completes despite the lack of signature.
1652 (let ((source (open-bytevector-input-port dump)))
1653 (match (import-paths %store source)
1654 ((imported)
1655 (string=? (pk 'imported imported) file))))))
1656
1657(test-assert "import not signed but content-addressed regular file"
1658 (let* ((name "content-addressed")
1659 (content (random-text))
1660 (store-item (store-path "text"
1661 (gcrypt:sha256 (string->utf8 content))
1662 name))
1663 (dump (call-with-bytevector-output-port
1664 (lambda (port)
1665 (write-int 1 port) ;start
1666 (write-file-tree name port ;contents
1667 #:file-type+size
1668 (lambda (_)
1669 (values 'regular
1670 (string-length content)))
1671 #:file-port
1672 (lambda (_)
1673 (open-input-string content)))
1674 (write-int #x4558494e port) ;%export-magic
1675 (write-string store-item port)
1676 (write-string-list '() port) ;references
1677 (write-string "" port) ;deriver
1678 (write-int 0 port) ;not signed
1679 (write-int 0 port))))) ;done
1680
1681 ;; Ensure 'import-paths' completes despite the lack of signature.
1682 (let ((source (open-bytevector-input-port dump)))
1683 (match (import-paths %store source)
1684 ((imported)
1685 (and (string=? (pk 'imported imported) store-item)
1686 (string=? (call-with-input-file imported get-string-all)
1687 content)))))))
1688
1689(test-assert "import signed by unauthorized key but content-addressed"
1690 (let* ((text (random-text))
1691 (file (add-file-tree-to-store %store
1692 `("tree" directory
1693 ("text" regular (data ,text))
1694 ("link" symlink "text"))))
1695 (key (gcrypt:generate-key
1696 (gcrypt:string->canonical-sexp
1697 "(genkey (ecdsa (curve Ed25519) (flags rfc6979)))")))
1698 (dump (call-with-bytevector-output-port
1699 (lambda (port)
1700 (write-int 1 port) ;start
1701
1702 (write-file file port) ;contents
1703 (write-int #x4558494e port) ;%export-magic
1704 (write-string file port) ;store item
1705 (write-string-list '() port) ;references
1706 (write-string "" port) ;deriver
1707 (write-int 1 port) ;signed
1708 (write-string (gcrypt:canonical-sexp->string
1709 (signature-sexp
1710 (gcrypt:bytevector->hash-data
1711 (gcrypt:sha256 #vu8(0 1 2))
1712 #:key-type 'ecc)
1713 (gcrypt:find-sexp-token key 'private-key)
1714 (gcrypt:find-sexp-token key 'public-key)))
1715 port)
1716
1717 (write-int 0 port))))) ;done
1718
1719 ;; Ensure 'import-paths' succeeds despite the unauthorized signature.
1720 (let ((source (open-bytevector-input-port dump)))
1721 (match (import-paths %store source)
1722 ((imported)
1723 (string=? imported file))))))
1724
1725(test-assert "import with corrupt signature but content-addressed"
1726 (let* ((text (random-text))
1727 (file (add-file-tree-to-store %store
1728 `("tree" directory
1729 ("text" regular (data ,text))
1730 ("link" symlink "text"))))
1731 (dump (call-with-bytevector-output-port
1732 (lambda (port)
1733 (write-int 1 port) ;start
1734
1735 (write-file file port) ;contents
1736 (write-int #x4558494e port) ;%export-magic
1737 (write-string file port) ;store item
1738 (write-string-list '() port) ;references
1739 (write-string "" port) ;deriver
1740 (write-int 1 port) ;signed
1741 (write-string (object->string '(signature broken))
1742 port)
1743
1744 (write-int 0 port))))) ;done
1745
1746 ;; Ensure 'import-paths' succeeds despite the corrupt signature.
1747 (let ((source (open-bytevector-input-port dump)))
1748 (match (import-paths %store source)
1749 ((imported)
1750 (string=? imported file))))))
1751
1752(test-assert "import signed by authorized key, hash doesn't match, but content-addressed"
1753 (let* ((text (random-text))
1754 (file (add-file-tree-to-store %store
1755 `("tree" directory
1756 ("text" regular (data ,text))
1757 ("link" symlink "text"))))
1758 ;; This key is known to be in the ACL by default.
1759 (public-key
1760 (call-with-input-file (string-append %config-directory "/signing-key.pub")
1761 (compose gcrypt:string->canonical-sexp get-string-all)))
1762 (private-key
1763 (call-with-input-file (string-append %config-directory "/signing-key.sec")
1764 (compose gcrypt:string->canonical-sexp get-string-all)))
1765 (dump (call-with-bytevector-output-port
1766 (lambda (port)
1767 (write-int 1 port) ;start
1768
1769 (write-file file port) ;contents
1770 (write-int #x4558494e port) ;%export-magic
1771 (write-string file port) ;store item
1772 (write-string-list '() port) ;references
1773 (write-string "" port) ;deriver
1774 (write-int 1 port) ;signed
1775 (write-string (gcrypt:canonical-sexp->string
1776 (signature-sexp
1777 (gcrypt:bytevector->hash-data
1778 (gcrypt:sha256 #vu8(0 1 2))
1779 #:key-type 'rsa)
1780 private-key
1781 public-key))
1782 port)
1783
1784 (write-int 0 port))))) ;done
1785
1786 ;; Ensure 'import-paths' succeeds despite the hash mismatch.
1787 (let ((source (open-bytevector-input-port dump)))
1788 (match (import-paths %store source)
1789 ((imported)
1790 (string=? imported file))))))
1791
1792(test-assert "import corrupt path"
1793 (let* ((text (random-text))
1794 (file (add-text-to-store %store "text" text))
1795 (dump (call-with-bytevector-output-port
1796 (cut export-paths %store (list file) <>))))
1797 (delete-paths %store (list file))
1798
1799 ;; Flip a bit in the stream's payload. INDEX here falls in the middle of
1800 ;; the file contents in DUMP, regardless of the store prefix.
1801 (let* ((index #x70)
1802 (byte (bytevector-u8-ref dump index)))
1803 (bytevector-u8-set! dump index (logxor #xff byte)))
1804
1805 (and (not (file-exists? file))
1806 (guard (c ((store-protocol-error? c)
1807 (pk 'c c)
1808 (and (not (zero? (store-protocol-error-status c)))
1809 (string-contains (store-protocol-error-message c)
1810 "corrupt"))))
1811 (let* ((source (open-bytevector-input-port dump))
1812 (imported (import-paths %store source)))
1813 (pk 'corrupt-imported imported)
1814 #f)))))
1815
1816
1817(define* (plain-dump filename contents #:key signed?)
1818 (let* ((contents (if (bytevector? contents)
1819 contents
1820 (string->utf8 contents)))
1821 (item-dump (call-with-bytevector-output-port
1822 (lambda (port)
1823 (call-with-input-bytevector
1824 contents
1825 (lambda (contents-port)
1826 (write-file-tree #t port
1827 #:file-type+size (lambda (_)
1828 (values 'regular
1829 (bytevector-length
1830 contents)))
1831 #:file-port (const contents-port))))
1832 (write-int #x4558494e port) ;%export-magic
1833 (write-string filename port) ;store item
1834 (write-string-list '() port) ;references
1835 (write-string "" port))))) ;deriver
1836 (call-with-bytevector-output-port
1837 (lambda (port)
1838 (write-int 1 port) ;start
1839 (put-bytevector port item-dump)
1840 (write-int (if signed? 1 0) port) ;signed
1841 (when signed?
1842 (let* ((read-canonical-sexp
1843 (compose gcrypt:string->canonical-sexp read-string))
1844 (public-key (call-with-input-file %public-key-file
1845 read-canonical-sexp))
1846 (private-key (call-with-input-file %private-key-file
1847 read-canonical-sexp)))
1848 (write-string (gcrypt:canonical-sexp->string
1849 (signature-sexp
1850 (gcrypt:bytevector->hash-data
1851 (gcrypt:sha256 item-dump)
1852 #:key-type (gcrypt:key-type public-key))
1853 private-key
1854 public-key))
1855 port)))
1856 (write-int 0 port)))))
1857
1858(test-assert "import path not in store, unsigned"
1859 ;; error should be produced before the signature is even considered
1860 (call-with-input-bytevector
1861 (plain-dump (string-append (%store-prefix) "/../../notinstore")
1862 (random-text))
1863 (lambda (port)
1864 (guard (c ((store-protocol-error? c)
1865 (pk 'c c)
1866 (and (not (zero? (store-protocol-error-status c)))
1867 (let ((message (store-protocol-error-message c)))
1868 (pk 'error-message message)
1869 (or (string-contains message "is not a valid store path")
1870 (string-contains message "is not in the store"))))))
1871 (import-paths %store port)
1872 #f))))
1873
1874(test-assert "import path not in store, signed"
1875 (call-with-input-bytevector
1876 (plain-dump (string-append (%store-prefix) "/../../notinstore")
1877 (random-text))
1878 (lambda (port)
1879 (guard (c ((store-protocol-error? c)
1880 (pk 'c c)
1881 (and (not (zero? (store-protocol-error-status c)))
1882 (let ((message (store-protocol-error-message c)))
1883 (pk 'error-message message)
1884 (or (string-contains message "is not a valid store path")
1885 (string-contains message "is not in the store"))))))
1886 (import-paths %store port)
1887 #f))))
1888
1889(test-assert "import invalid path, unsigned"
1890 ;; error should be produced before the signature is even considered
1891 (call-with-input-bytevector
1892 (plain-dump (string-append (%store-prefix)
1893 "/!@#$%^&*()_+=-[]{}\\|';:,<>.")
1894 (random-text))
1895 (lambda (port)
1896 (guard (c ((store-protocol-error? c)
1897 (pk 'c c)
1898 (and (not (zero? (store-protocol-error-status c)))
1899 (let ((message (store-protocol-error-message c)))
1900 (pk 'error-message message)
1901 (string-contains message "is not a valid store path")))))
1902 (import-paths %store port)
1903 #f))))
1904
1905(test-assert "import invalid path, signed"
1906 (call-with-input-bytevector
1907 (plain-dump (string-append (%store-prefix)
1908 "/!@#$%^&*()_+=-[]{}\\|';:,<>.")
1909 (random-text)
1910 #:signed? #t)
1911 (lambda (port)
1912 (guard (c ((store-protocol-error? c)
1913 (pk 'c c)
1914 (and (not (zero? (store-protocol-error-status c)))
1915 (let ((message (store-protocol-error-message c)))
1916 (pk 'error-message message)
1917 (string-contains message "is not a valid store path")))))
1918 (import-paths %store port)
1919 #f))))
1920
1921(test-assert "verify-store"
1922 (let* ((text (random-text))
1923 (file1 (add-text-to-store %store "foo" text))
1924 (file2 (add-text-to-store %store "bar" (random-text)
1925 (list file1))))
1926 (and (pk 'verify1 (verify-store %store)) ;hopefully OK ;
1927 (begin
1928 (delete-file file1)
1929 (not (pk 'verify2 (verify-store %store)))) ;bad! ;
1930 (begin
1931 ;; Using 'add-text-to-store' here wouldn't work: It would succeed ;
1932 ;; without actually creating the file. ;
1933 (call-with-output-file file1
1934 (lambda (port)
1935 (display text port)))
1936 (pk 'verify3 (verify-store %store)))))) ;OK again
1937
1938(test-assert "verify-store + check-contents"
1939 ;; XXX: This test is I/O intensive.
1940 (with-store s
1941 (let* ((text (random-text))
1942 (drv (build-expression->derivation
1943 s "corrupt"
1944 `(let ((out (assoc-ref %outputs "out")))
1945 (call-with-output-file out
1946 (lambda (port)
1947 (display ,text port)))
1948 #t)
1949 #:guile-for-build
1950 (package-derivation s %bootstrap-guile (%current-system))))
1951 (file (derivation->output-path drv)))
1952 (with-derivation-substitute drv text
1953 (and (build-derivations s (list drv))
1954 (verify-store s #:check-contents? #t) ;should be OK
1955 (begin
1956 (chmod file #o644)
1957 (call-with-output-file file
1958 (lambda (port)
1959 (display "corrupt!" port)))
1960 #t)
1961
1962 ;; Make sure the corruption is detected. We don't test repairing
1963 ;; because only "trusted" users are allowed to do it, but we
1964 ;; don't expose that notion of trusted users that nix-daemon
1965 ;; supports because it seems dubious and redundant with what the
1966 ;; OS provides (in Nix "trusted" users have additional
1967 ;; privileges, such as overriding the set of substitute URLs, but
1968 ;; we instead want to allow anyone to modify them, provided
1969 ;; substitutes are signed by a root-approved key.)
1970 (not (verify-store s #:check-contents? #t))
1971
1972 ;; Delete the corrupt item to leave the store in a clean state.
1973 (delete-paths s (list file)))))))
1974
1975(test-assert "build-things, check mode"
1976 (with-store store
1977 (let* ((drv (build-expression->derivation
1978 store "non-deterministic"
1979 `(begin
1980 (use-modules (rnrs io ports))
1981 (let ((out (assoc-ref %outputs "out")))
1982 (call-with-output-file out
1983 (lambda (port)
1984 (let ((now (gettimeofday)))
1985 (display (+ (car now) (cdr now)) port))))
1986 #t))
1987 #:guile-for-build
1988 (package-derivation store %bootstrap-guile (%current-system))))
1989 (file (derivation->output-path drv)))
1990 (and (build-things store (list (derivation-file-name drv)))
1991 (begin
1992 (guard (c ((store-protocol-error? c)
1993 (pk 'determinism-exception c)
1994 (and (valid-path? store file) ;must still be valid
1995 (not (zero? (store-protocol-error-status c)))
1996 (string-contains (store-protocol-error-message c)
1997 "deterministic"))))
1998 ;; This one will produce a different result. Since we're in
1999 ;; 'check' mode, this must fail.
2000 (build-things store (list (derivation-file-name drv))
2001 (build-mode check))
2002 #f))))))
2003
2004(test-equal "build-things, check mode + keep-failed"
2005 '(#t #t)
2006 (with-store store
2007 (let* ((drv (build-expression->derivation
2008 store "deterministic-thing-to-check"
2009 `(let ((out (assoc-ref %outputs "out")))
2010 (call-with-output-file out
2011 (lambda (port)
2012 (display ,(let ((now (gettimeofday)))
2013 (+ (car now) (cdr now)))
2014 port))))
2015 #:guile-for-build
2016 (package-derivation
2017 store %bootstrap-guile (%current-system))))
2018 (file (derivation->output-path drv)))
2019 (and (build-things store (list (derivation-file-name drv)))
2020 (valid-path? store file)
2021 (begin
2022 ;; This would trigger accidental deletion of FILE.
2023 (set-build-options store
2024 #:keep-failed? #t
2025 #:keep-going? #t
2026 #:rounds 3)
2027 (build-things store (list (derivation-file-name drv))
2028 (build-mode check))
2029 (list (valid-path? store file)
2030 (file-exists? file)))))))
2031
2032(test-assert "build-succeeded trace in check mode"
2033 (string-contains
2034 (call-with-output-string
2035 (lambda (port)
2036 (let ((d (build-expression->derivation
2037 %store "foo" '(mkdir (assoc-ref %outputs "out"))
2038 #:guile-for-build
2039 (package-derivation %store %bootstrap-guile))))
2040 (build-derivations %store (list d))
2041 (parameterize ((current-build-output-port port))
2042 (build-derivations %store (list d) (build-mode check))))))
2043 "@ build-succeeded"))
2044
2045(test-assert "build multiple times"
2046 (with-store store
2047 ;; Ask to build twice.
2048 (set-build-options store #:rounds 2 #:use-substitutes? #f)
2049
2050 (call-with-temporary-output-file
2051 (lambda (entropy entropy-port)
2052 (write (random-text) entropy-port)
2053 (force-output entropy-port)
2054 (let* ((drv (build-expression->derivation
2055 store "non-deterministic"
2056 `(begin
2057 (use-modules (rnrs io ports))
2058 (let ((out (assoc-ref %outputs "out")))
2059 (call-with-output-file out
2060 (lambda (port)
2061 ;; Rely on the fact that tests do not use the
2062 ;; chroot, and thus ENTROPY is accessible.
2063 (display (call-with-input-file ,entropy
2064 get-string-all)
2065 port)
2066 (call-with-output-file ,entropy
2067 (lambda (port)
2068 (write 'foobar port)))))
2069 #t))
2070 #:guile-for-build
2071 (package-derivation store %bootstrap-guile (%current-system))))
2072 (file (derivation->output-path drv)))
2073 (guard (c ((store-protocol-error? c)
2074 (pk 'multiple-build c)
2075 (and (not (zero? (store-protocol-error-status c)))
2076 (string-contains (store-protocol-error-message c)
2077 "deterministic"))))
2078 ;; This one will produce a different result on the second run.
2079 (current-build-output-port (current-error-port))
2080 (build-things store (list (derivation-file-name drv)))
2081 #f))))))
2082
2083(test-equal "store-lower"
2084 "Lowered."
2085 (let* ((add (store-lower text-file))
2086 (file (add %store "foo" "Lowered.")))
2087 (call-with-input-file file get-string-all)))
2088
2089(test-equal "current-system"
2090 "bar"
2091 (parameterize ((%current-system "frob"))
2092 (run-with-store %store
2093 (mbegin %store-monad
2094 (set-current-system "bar")
2095 (current-system))
2096 #:system "foo")))
2097
2098(test-assert "query-path-info"
2099 (let* ((ref (add-text-to-store %store "ref" "foo"))
2100 (item (add-text-to-store %store "item" "bar" (list ref)))
2101 (info (query-path-info %store item)))
2102 (and (equal? (path-info-references info) (list ref))
2103 (equal? (path-info-hash info)
2104 (gcrypt:sha256
2105 (string->utf8
2106 (call-with-output-string (cut write-file item <>))))))))
2107
2108(test-assert "path-info-deriver"
2109 (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
2110 (s (add-to-store %store "bash" #t "sha256"
2111 (search-bootstrap-binary "bash"
2112 (%current-system))))
2113 (d (derivation %store "the-thing"
2114 s `("-e" ,b)
2115 #:env-vars `(("foo" . ,(random-text)))
2116 #:inputs `((,b) (,s))))
2117 (o (derivation->output-path d)))
2118 (and (build-derivations %store (list d))
2119 (not (path-info-deriver (query-path-info %store b)))
2120 (string=? (derivation-file-name d)
2121 (path-info-deriver (query-path-info %store o))))))
2122
2123(test-equal "build-cores"
2124 (list 0 42)
2125 (with-store store
2126 (let* ((build (add-text-to-store store "build.sh"
2127 "echo $NIX_BUILD_CORES > $out"))
2128 (bash (add-to-store store "bash" #t "sha256"
2129 (search-bootstrap-binary "bash"
2130 (%current-system))))
2131 (drv1 (derivation store "the-thing" bash
2132 `("-e" ,build)
2133 #:inputs `((,bash) (,build))
2134 #:env-vars `(("x" . ,(random-text)))))
2135 (drv2 (derivation store "the-thing" bash
2136 `("-e" ,build)
2137 #:inputs `((,bash) (,build))
2138 #:env-vars `(("x" . ,(random-text))))))
2139 (and (build-derivations store (list drv1))
2140 (begin
2141 (set-build-options store #:build-cores 42)
2142 (build-derivations store (list drv2)))
2143 (list (call-with-input-file (derivation->output-path drv1)
2144 read)
2145 (call-with-input-file (derivation->output-path drv2)
2146 read))))))
2147
2148(test-equal "multiplexed-build-output"
2149 '("Hello from first." "Hello from second.")
2150 (with-store store
2151 (let* ((build (add-text-to-store store "build.sh"
2152 "echo Hello from $NAME.; echo > $out"))
2153 (bash (add-to-store store "bash" #t "sha256"
2154 (search-bootstrap-binary "bash"
2155 (%current-system))))
2156 (drv1 (derivation store "one" bash
2157 `("-e" ,build)
2158 #:inputs `((,bash) (,build))
2159 #:env-vars `(("NAME" . "first")
2160 ("x" . ,(random-text)))))
2161 (drv2 (derivation store "two" bash
2162 `("-e" ,build)
2163 #:inputs `((,bash) (,build))
2164 #:env-vars `(("NAME" . "second")
2165 ("x" . ,(random-text))))))
2166 (set-build-options store
2167 #:print-build-trace #t
2168 #:multiplexed-build-output? #t
2169 #:max-build-jobs 10)
2170 (let ((port (open-output-string)))
2171 ;; Send the build log to PORT.
2172 (parameterize ((current-build-output-port port))
2173 (build-derivations store (list drv1 drv2)))
2174
2175 ;; Retrieve the build log; make sure it contains valid "@ build-log"
2176 ;; traces that allow us to retrieve each builder's output (we assume
2177 ;; there's exactly one "build-output" trace for each builder, which is
2178 ;; reasonable.)
2179 (let* ((log (get-output-string port))
2180 (started (fold-matches
2181 (make-regexp "@ build-started ([^ ]+) - ([^ ]+) ([^ ]+) ([0-9]+)")
2182 log '() cons))
2183 (done (fold-matches
2184 (make-regexp "@ build-succeeded (.*) - (.*) (.*) (.*)")
2185 log '() cons))
2186 (output (fold-matches
2187 (make-regexp "@ build-log ([[:digit:]]+) ([[:digit:]]+)\n([A-Za-z .*]+)\n")
2188 log '() cons))
2189 (drv-pid (lambda (name)
2190 (lambda (m)
2191 (let ((drv (match:substring m 1))
2192 (pid (string->number
2193 (match:substring m 4))))
2194 (and (string-suffix? name drv) pid)))))
2195 (pid-log (lambda (pid)
2196 (lambda (m)
2197 (let ((n (string->number
2198 (match:substring m 1)))
2199 (len (string->number
2200 (match:substring m 2)))
2201 (str (match:substring m 3)))
2202 (and (= pid n)
2203 (= (string-length str) (- len 1))
2204 str)))))
2205 (pid1 (any (drv-pid "one.drv") started))
2206 (pid2 (any (drv-pid "two.drv") started)))
2207 (list (any (pid-log pid1) output)
2208 (any (pid-log pid2) output)))))))
2209
2210(test-end "store")