projects/guix·blob java-team · refs

1641 lines · 78.8 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012-2026 Ludovic Courtès <[email protected]>
3;;; Copyright © 2025 Sergio Pastor Pérez <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
7;;; GNU Guix is free software; you can redistribute it and/or modify it
8;;; under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 3 of the License, or (at
10;;; your option) any later version.
11;;;
12;;; GNU Guix is distributed in the hope that it will be useful, but
13;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19
20(unsetenv "http_proxy")
21
22(define-module (test-derivations)
23 #:use-module (guix derivations)
24 #:use-module (guix gexp)
25 #:use-module (guix store)
26 #:use-module (guix utils)
27 #:use-module ((gcrypt hash) #:prefix gcrypt:)
28 #:use-module (guix base32)
29 #:use-module ((guix git) #:select (with-repository))
30 #:use-module (guix config)
31 #:use-module (guix tests)
32 #:use-module (guix tests git)
33 #:use-module (guix tests http)
34 #:use-module ((guix packages) #:select (package-derivation base32))
35 #:use-module ((guix build utils)
36 #:select (executable-file? strip-store-file-name which))
37 #:use-module ((gnu build linux-container)
38 #:select (unprivileged-user-namespace-supported?))
39 #:use-module ((guix hash) #:select (file-hash*))
40 #:use-module ((git oid) #:select (oid->string))
41 #:use-module ((git reference) #:select (reference-name->oid))
42 #:use-module (gnu packages bootstrap)
43 #:use-module ((gnu packages guile) #:select (guile-1.8))
44 #:use-module (srfi srfi-1)
45 #:use-module (srfi srfi-11)
46 #:use-module (srfi srfi-26)
47 #:use-module (srfi srfi-34)
48 #:use-module (srfi srfi-64)
49 #:use-module (rnrs io ports)
50 #:use-module (rnrs bytevectors)
51 #:use-module (web uri)
52 #:use-module (ice-9 rdelim)
53 #:use-module (ice-9 regex)
54 #:use-module (ice-9 ftw)
55 #:use-module (ice-9 match))
56
57(define %store
58 (open-connection-for-tests))
59
60;; Globally disable grafts because they can trigger early builds.
61(%graft? #f)
62
63;; This can happen when someone is running tests without --disable-chroot and
64;; with either slirp4netns or /dev/net/tun unavailable.
65(define builder-network-isolated?
66 (and (target-linux? %system)
67 (unprivileged-user-namespace-supported?)
68 (or (not (which "slirp4netns"))
69 (not (file-exists? "/dev/net/tun")))))
70
71(define (bootstrap-binary name)
72 (let ((bin (search-bootstrap-binary name (%current-system))))
73 (and %store
74 (add-to-store %store name #t "sha256" bin))))
75
76(define %bash
77 (bootstrap-binary "bash"))
78(define %mkdir
79 (bootstrap-binary "mkdir"))
80
81(define* (directory-contents dir #:optional (slurp get-bytevector-all))
82 "Return an alist representing the contents of DIR."
83 (define prefix-len (string-length dir))
84 (sort (file-system-fold (const #t) ; enter?
85 (lambda (path stat result) ; leaf
86 (alist-cons (string-drop path prefix-len)
87 (call-with-input-file path slurp)
88 result))
89 (lambda (path stat result) result) ; down
90 (lambda (path stat result) result) ; up
91 (lambda (path stat result) result) ; skip
92 (lambda (path stat errno result) result) ; error
93 '()
94 dir)
95 (lambda (e1 e2)
96 (string<? (car e1) (car e2)))))
97
98
99(test-begin "derivations")
100
101(test-assert "parse & export"
102 (let* ((f (search-path %load-path "tests/test.drv"))
103 (b1 (call-with-input-file f get-bytevector-all))
104 (d1 (read-derivation (open-bytevector-input-port b1)
105 identity))
106 (b2 (call-with-bytevector-output-port (cut write-derivation d1 <>)))
107 (d2 (read-derivation (open-bytevector-input-port b2)
108 identity)))
109 (and (equal? b1 b2)
110 (equal? d1 d2))))
111
112(test-skip (if %store 0 12))
113
114(test-assert "add-to-store, flat"
115 ;; Use 'readlink*' in case spec.scm is a symlink, as is the case when Guile
116 ;; was installed with Stow.
117 (let* ((file (readlink*
118 (search-path %load-path "language/tree-il/spec.scm")))
119 (drv (add-to-store %store "flat-test" #f "sha256" file)))
120 (and (eq? 'regular (stat:type (stat drv)))
121 (valid-path? %store drv)
122 (equal? (call-with-input-file file get-bytevector-all)
123 (call-with-input-file drv get-bytevector-all)))))
124
125(test-assert "add-to-store, recursive"
126 (let* ((dir (dirname
127 (readlink* (search-path %load-path
128 "language/tree-il/spec.scm"))))
129 (drv (add-to-store %store "dir-tree-test" #t "sha256" dir)))
130 (and (eq? 'directory (stat:type (stat drv)))
131 (valid-path? %store drv)
132 (equal? (directory-contents dir)
133 (directory-contents drv)))))
134
135(test-assert "derivation with no inputs"
136 (let* ((builder (add-text-to-store %store "my-builder.sh"
137 "echo hello, world\n"
138 '()))
139 (drv (derivation %store "foo"
140 %bash `("-e" ,builder)
141 #:env-vars '(("HOME" . "/homeless")))))
142 (and (store-path? (derivation-file-name drv))
143 (valid-path? %store (derivation-file-name drv)))))
144
145(test-assert "build derivation with 1 source"
146 (let* ((builder (add-text-to-store %store "my-builder.sh"
147 "echo hello, world > \"$out\"\n"
148 '()))
149 (drv (derivation %store "foo"
150 %bash `(,builder)
151 #:env-vars '(("HOME" . "/homeless")
152 ("zzz" . "Z!")
153 ("AAA" . "A!"))
154 #:sources `(,%bash ,builder)))
155 (succeeded?
156 (build-derivations %store (list drv))))
157 (and succeeded?
158 (let ((path (derivation->output-path drv)))
159 (and (valid-path? %store path)
160 (string=? (call-with-input-file path read-line)
161 "hello, world"))))))
162
163(test-assert "derivation fails but keep going"
164 ;; In keep-going mode, 'build-derivations' should fail because of D1, but it
165 ;; must return only after D2 has succeeded.
166 (let* ((d1 (derivation %store "fails"
167 %bash `("-c" "false")
168 #:sources (list %bash)))
169 (d2 (build-expression->derivation %store "sleep-then-succeed"
170 `(begin
171 ,(random-text)
172 ;; XXX: Hopefully that's long
173 ;; enough that D1 has already
174 ;; failed.
175 (sleep 2)
176 (mkdir %output)))))
177 (set-build-options %store
178 #:use-substitutes? #f
179 #:keep-going? #t)
180 (guard (c ((store-protocol-error? c)
181 (and (= 100 (store-protocol-error-status c))
182 (string-contains (store-protocol-error-message c)
183 (derivation-file-name d1))
184 (not (valid-path? %store (derivation->output-path d1)))
185 (valid-path? %store (derivation->output-path d2)))))
186 (build-derivations %store (list d1 d2))
187 #f)))
188
189(test-assert "identical files are deduplicated"
190 ;; Note: DATA must be longer than %DEDUPLICATION-MINIMUM-SIZE.
191 (let* ((data (make-string 9000 #\a))
192 (build1 (add-text-to-store %store "one.sh"
193 (string-append "echo -n " data
194 " > \"$out\"\n")
195 '()))
196 (build2 (add-text-to-store %store "two.sh"
197 (string-append "# Hey!\necho -n "
198 data " > \"$out\"\n")
199 '()))
200 (drv1 (derivation %store "foo"
201 %bash `(,build1)
202 #:sources `(,%bash ,build1)))
203 (drv2 (derivation %store "bar"
204 %bash `(,build2)
205 #:sources `(,%bash ,build2))))
206 (and (build-derivations %store (list drv1 drv2))
207 (let ((file1 (derivation->output-path drv1))
208 (file2 (derivation->output-path drv2)))
209 (and (valid-path? %store file1) (valid-path? %store file2)
210 (string=? (call-with-input-file file1 get-string-all)
211 data)
212 (= (stat:ino (lstat file1))
213 (stat:ino (lstat file2))))))))
214
215(test-equal "built-in-builders"
216 '("download" "git-download")
217 (built-in-builders %store))
218
219(test-assert "unknown built-in builder"
220 (let ((drv (derivation %store "ohoh" "builtin:does-not-exist" '())))
221 (guard (c ((store-protocol-error? c)
222 (string-contains (store-protocol-error-message c) "failed")))
223 (build-derivations %store (list drv))
224 #f)))
225
226(test-assert "'download' built-in builder"
227 (let ((text (random-text)))
228 (with-http-server `((200 ,text))
229 (let* ((drv (derivation %store "world"
230 "builtin:download" '()
231 #:env-vars `(("url"
232 . ,(object->string (%local-url))))
233 #:hash-algo 'sha256
234 #:hash (gcrypt:sha256 (string->utf8 text)))))
235 (and (build-derivations %store (list drv))
236 (string=? (call-with-input-file (derivation->output-path drv)
237 get-string-all)
238 text))))))
239
240(test-assert "'download' built-in builder, invalid hash"
241 (with-http-server `((200 "hello, world!"))
242 (let* ((drv (derivation %store "world"
243 "builtin:download" '()
244 #:env-vars `(("url"
245 . ,(object->string (%local-url))))
246 #:hash-algo 'sha256
247 #:hash (gcrypt:sha256 (random-bytevector 100))))) ;wrong
248 (guard (c ((store-protocol-error? c)
249 (string-contains (store-protocol-error-message c) "failed")))
250 (build-derivations %store (list drv))
251 #f))))
252
253(test-assert "'download' built-in builder, not found"
254 (with-http-server '((404 "not found"))
255 (let* ((drv (derivation %store "will-never-be-found"
256 "builtin:download" '()
257 #:env-vars `(("url"
258 . ,(object->string (%local-url))))
259 #:hash-algo 'sha256
260 #:hash (gcrypt:sha256 (random-bytevector 100)))))
261 (guard (c ((store-protocol-error? c)
262 (string-contains (store-protocol-error-message (pk c)) "failed")))
263 (build-derivations %store (list drv))
264 #f))))
265
266(test-assert "'download' built-in builder, not fixed-output"
267 (let* ((source (add-text-to-store %store "hello" "hi!"))
268 (url (string-append "file://" source))
269 (drv (derivation %store "world"
270 "builtin:download" '()
271 #:env-vars `(("url" . ,(object->string url))))))
272 (guard (c ((store-protocol-error? c)
273 (string-contains (store-protocol-error-message c) "failed")))
274 (build-derivations %store (list drv))
275 #f)))
276
277(test-assert "'download' built-in builder, no fixed-output hash"
278 ;; 'guix perform-download' should bail out with a message saying "not a
279 ;; fixed-output derivation".
280 (with-http-server '((200 "This should not be downloaded."))
281 (let* ((drv (derivation %store "download-without-hash"
282 "builtin:download" '()
283 #:env-vars `(("url"
284 . ,(object->string (%local-url))))
285 #:hash-algo 'sha256
286 #:hash #f)))
287 (guard (c ((store-protocol-error? c)
288 (string-contains (store-protocol-error-message c) "failed")))
289 (build-derivations %store (list drv))
290 #f))))
291
292(test-assert "'download' built-in builder, check mode"
293 ;; Make sure rebuilding the 'builtin:download' derivation in check mode
294 ;; works. See <http://bugs.gnu.org/25089>.
295 (let* ((text (random-text)))
296 (with-http-server `((200 ,text))
297 (let ((drv (derivation %store "world"
298 "builtin:download" '()
299 #:env-vars `(("url"
300 . ,(object->string (%local-url))))
301 #:hash-algo 'sha256
302 #:hash (gcrypt:sha256 (string->utf8 text)))))
303 (and drv (build-derivations %store (list drv))
304 (with-http-server `((200 ,text))
305 (build-derivations %store (list drv)
306 (build-mode check)))
307 (string=? (call-with-input-file (derivation->output-path drv)
308 get-string-all)
309 text))))))
310
311(define %nonce (random-text))
312
313(test-equal "'git-download' built-in builder"
314 `(("/a.txt" . ,%nonce)
315 ("/b.scm" . "#t"))
316 (let ((nonce (random-text)))
317 (with-served-temporary-git-repository directory port
318 `((add "a.txt" ,%nonce)
319 (add "b.scm" "#t")
320 (commit ,nonce))
321 (let* ((commit (with-repository directory repository
322 (oid->string
323 (reference-name->oid repository "HEAD"))))
324 (drv (derivation %store "git-download"
325 "builtin:git-download" '()
326 #:env-vars
327 `(("url"
328 . ,(object->string
329 (string-append "git://localhost:"
330 (number->string port)
331 "/")))
332 ("commit" . ,commit))
333 #:hash-algo 'sha256
334 #:hash (file-hash* directory
335 #:algorithm
336 (gcrypt:hash-algorithm
337 gcrypt:sha256)
338 #:recursive? #t)
339 #:recursive? #t)))
340 (build-derivations %store (list drv))
341 (directory-contents (derivation->output-path drv) get-string-all)))))
342
343(test-assert "'git-download' built-in builder, invalid hash"
344 (with-served-temporary-git-repository directory port
345 `((add "a.txt" "AAA")
346 (add "b.scm" "#t")
347 (commit "Commit!"))
348 (let* ((commit (with-repository directory repository
349 (oid->string
350 (reference-name->oid repository "HEAD"))))
351 (drv (derivation %store "git-download"
352 "builtin:git-download" '()
353 #:env-vars
354 `(("url"
355 . ,(object->string
356 (string-append "git://localhost:"
357 (number->string port)
358 "/")))
359 ("commit" . ,commit))
360 #:hash-algo 'sha256
361 #:hash (gcrypt:sha256 #vu8())
362 #:recursive? #t)))
363 (guard (c ((store-protocol-error? c)
364 (string-contains (store-protocol-error-message c) "failed")))
365 (build-derivations %store (list drv))
366 #f))))
367
368(test-assert "'git-download' built-in builder, invalid commit"
369 (with-served-temporary-git-repository directory port
370 `((add "a.txt" "AAA")
371 (add "b.scm" "#t")
372 (commit "Commit!"))
373 (let* ((drv (derivation %store "git-download"
374 "builtin:git-download" '()
375 #:env-vars
376 `(("url"
377 . ,(object->string
378 (string-append "git://localhost:"
379 (number->string port)
380 "/")))
381 ("commit"
382 . "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))
383 #:hash-algo 'sha256
384 #:hash (gcrypt:sha256 #vu8())
385 #:recursive? #t)))
386 (guard (c ((store-protocol-error? c)
387 (string-contains (store-protocol-error-message c) "failed")))
388 (build-derivations %store (list drv))
389 #f))))
390
391(test-assert "'git-download' built-in builder, not found"
392 (with-served-temporary-git-repository directory port
393 '()
394 (let* ((drv (derivation %store "git-download"
395 "builtin:git-download" '()
396 #:env-vars
397 `(("url" . ,(object->string
398 (string-append "git://localhost:"
399 (number->string port)
400 "/nonexistent")))
401 ("commit"
402 . "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))
403 #:hash-algo 'sha256
404 #:hash (gcrypt:sha256 #vu8())
405 #:recursive? #t)))
406 (guard (c ((store-protocol-error? c)
407 (string-contains (store-protocol-error-message c) "failed")))
408 (build-derivations %store (list drv))
409 #f))))
410
411(test-equal "derivation-name"
412 "foo-0.0"
413 (let ((drv (derivation %store "foo-0.0" %bash '())))
414 (derivation-name drv)))
415
416(test-equal "derivation-output-names"
417 '(("out") ("bar" "chbouib"))
418 (let ((drv1 (derivation %store "foo-0.0" %bash '()))
419 (drv2 (derivation %store "foo-0.0" %bash '()
420 #:outputs '("bar" "chbouib"))))
421 (list (derivation-output-names drv1)
422 (derivation-output-names drv2))))
423
424(test-assert "offloadable-derivation?"
425 (and (offloadable-derivation? (derivation %store "foo" %bash '()))
426 (offloadable-derivation? ;see <http://bugs.gnu.org/18747>
427 (derivation %store "foo" %bash '()
428 #:substitutable? #f))
429 (not (offloadable-derivation?
430 (derivation %store "foo" %bash '()
431 #:local-build? #t)))))
432
433(test-assert "substitutable-derivation?"
434 (and (substitutable-derivation? (derivation %store "foo" %bash '()))
435 (substitutable-derivation? ;see <http://bugs.gnu.org/18747>
436 (derivation %store "foo" %bash '()
437 #:local-build? #t))
438 (not (substitutable-derivation?
439 (derivation %store "foo" %bash '()
440 #:substitutable? #f)))))
441
442(test-assert "fixed-output-derivation?"
443 (let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
444 "echo -n hello > $out" '()))
445 (hash (gcrypt:sha256 (string->utf8 "hello")))
446 (drv (derivation %store "fixed"
447 %bash `(,builder)
448 #:sources (list builder)
449 #:hash hash #:hash-algo 'sha256)))
450 (fixed-output-derivation? drv)))
451
452(test-assert "fixed-output-derivation?, no hash"
453 ;; A derivation that has #:hash-algo and #:hash #f is *not* fixed-output.
454 (let* ((drv (derivation %store "not-quite-fixed"
455 "builtin:download" '()
456 #:hash #f #:hash-algo 'sha256)))
457 (not (fixed-output-derivation? drv))))
458
459(test-equal "fixed-output derivation"
460 '(sha1 sha256 sha512)
461 (map (lambda (hash-algorithm)
462 (let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
463 "echo -n hello > $out" '()))
464 (sha256 (gcrypt:sha256 (string->utf8 "hello")))
465 (hash (gcrypt:bytevector-hash
466 (string->utf8 "hello")
467 (gcrypt:lookup-hash-algorithm hash-algorithm)))
468 (drv (derivation %store
469 (string-append
470 "fixed-" (symbol->string hash-algorithm))
471 %bash `(,builder)
472 #:sources (list %bash builder)
473 #:hash hash
474 #:hash-algo hash-algorithm)))
475 (build-derivations %store (list drv))
476 (let ((p (derivation->output-path drv)))
477 (and (bytevector=? (string->utf8 "hello")
478 (call-with-input-file p get-bytevector-all))
479 (bytevector? (query-path-hash %store p))
480 hash-algorithm))))
481 '(sha1 sha256 sha512)))
482
483(test-assert "fixed-output derivation: output paths are equal"
484 (let* ((builder1 (add-text-to-store %store "fixed-builder1.sh"
485 "echo -n hello > $out" '()))
486 (builder2 (add-text-to-store %store "fixed-builder2.sh"
487 "echo hey; echo -n hello > $out" '()))
488 (hash (gcrypt:sha256 (string->utf8 "hello")))
489 (drv1 (derivation %store "fixed"
490 %bash `(,builder1)
491 #:sources (list %bash builder1)
492 #:hash hash #:hash-algo 'sha256))
493 (drv2 (derivation %store "fixed"
494 %bash `(,builder2)
495 #:sources (list %bash builder2)
496 #:hash hash #:hash-algo 'sha256))
497 (succeeded? (build-derivations %store (list drv1 drv2))))
498 (and succeeded?
499 (equal? (derivation->output-path drv1)
500 (derivation->output-path drv2)))))
501
502(test-assert "fixed-output derivation, recursive"
503 (let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
504 "echo -n hello > $out" '()))
505 (hash (gcrypt:sha256 (string->utf8 "hello")))
506 (drv (derivation %store "fixed-rec"
507 %bash `(,builder)
508 #:sources (list %bash builder)
509 #:hash (base32 "0sg9f58l1jj88w6pdrfdpj5x9b1zrwszk84j81zvby36q9whhhqa")
510 #:hash-algo 'sha256
511 #:recursive? #t))
512 (succeeded? (build-derivations %store (list drv))))
513 (and succeeded?
514 (let ((p (derivation->output-path drv)))
515 (and (equal? (string->utf8 "hello")
516 (call-with-input-file p get-bytevector-all))
517 (bytevector? (query-path-hash %store p)))))))
518
519(test-assert "fixed-output derivation, invalid hash size"
520 (guard (c ((store-protocol-error? c)
521 (string-contains-ci (store-protocol-error-message c)
522 "invalid SHA512 hash")))
523 (derivation %store "download-with-invalid-hash"
524 "builtin:download" '()
525 #:env-vars `(("url"
526 . ,(object->string "http://example.org")))
527 #:hash-algo 'sha512
528 #:hash #vu8(1 2 3))
529 #f))
530
531(unless (not builder-network-isolated?) (test-skip 1))
532(test-assert "fixed-output derivation, network access, localhost"
533 ;; Test a fixed-output derivation connecting to "localhost".
534 (let ((text (random-text)))
535 (with-http-server `((200 ,text))
536 (let* ((drv (build-expression->derivation
537 %store
538 "fixed-output-download"
539 `(begin
540 (use-modules (web client)
541 (srfi srfi-11)
542 (rnrs io ports))
543
544 ;; Neutralize 'set-port-encoding!' because
545 ;; guile-bootstrap cannot open iconv descriptors
546 ;; contrary to what 'read-response' expects.
547 (set! (@ (guile) set-port-encoding!) (const #t))
548
549 (let-values (((response body)
550 (http-get ,(%local-url)
551 #:decode-body? #f)))
552 (format #t "response: ~s~%body: ~s~%"
553 response body)
554 (call-with-output-file %output
555 (lambda (port)
556 (put-bytevector port body)))))
557 #:hash-algo 'sha256
558 #:hash (gcrypt:sha256 (string->utf8 text)))))
559 (and (build-derivations %store (list drv))
560 (string=? (call-with-input-file (derivation->output-path drv)
561 get-string-all)
562 text))))))
563
564(unless (and (network-reachable?) (not builder-network-isolated?))
565 (test-skip 1))
566(test-assert "fixed-output derivation, network access, external host"
567 ;; Test a fixed-output derivation connecting to an external server.
568 (let* ((drv (build-expression->derivation
569 %store
570 (string-append (number->string (random (expt 2 64) (%seed))
571 16)
572 "-gplv3.txt")
573 '(begin
574 (use-modules (web client)
575 (srfi srfi-11)
576 (rnrs io ports))
577
578 ;; DNS working?
579 (pk 'addr (getaddrinfo "www.gnu.org" "https"))
580
581 ;; Neutralize 'set-port-encoding!' because
582 ;; guile-bootstrap cannot open iconv descriptors
583 ;; contrary to what 'read-response' expects.
584 (set! (@ (guile) set-port-encoding!) (const #t))
585
586 (let-values (((response body)
587 ;; Note: www.gnu.org returns 403 when
588 ;; 'User-Agent' is missing.
589 (http-get "http://www.gnu.org/licenses/gpl-3.0.txt"
590 #:decode-body? #f
591 #:headers '((user-agent . "GNU Guile")))))
592 (call-with-output-file %output
593 (lambda (port)
594 (put-bytevector port body)))))
595 #:hash-algo 'sha256
596 #:hash (base32 "11k9nggwk1mgsrkdwgdjz65avrradxlpdgrdkc7ryjgn8jbxqwir"))))
597 (build-derivations %store (list drv))))
598
599(test-assert "derivation with a fixed-output input"
600 ;; A derivation D using a fixed-output derivation F doesn't has the same
601 ;; output path when passed F or F', as long as F and F' have the same output
602 ;; path.
603 (let* ((builder1 (add-text-to-store %store "fixed-builder1.sh"
604 "echo -n hello > $out" '()))
605 (builder2 (add-text-to-store %store "fixed-builder2.sh"
606 "echo hey; echo -n hello > $out" '()))
607 (hash (gcrypt:sha256 (string->utf8 "hello")))
608 (fixed1 (derivation %store "fixed"
609 %bash `(,builder1)
610 #:sources (list %bash builder1)
611 #:hash hash #:hash-algo 'sha256))
612 (fixed2 (derivation %store "fixed"
613 %bash `(,builder2)
614 #:sources (list %bash builder2)
615 #:hash hash #:hash-algo 'sha256))
616 (fixed-out (derivation->output-path fixed1))
617 (builder3 (add-text-to-store
618 %store "final-builder.sh"
619 ;; Use Bash hackery to avoid Coreutils.
620 "echo $in ; (read -u 3 c; echo $c) 3< $in > $out" '()))
621 (final1 (derivation %store "final"
622 %bash `(,builder3)
623 #:env-vars `(("in" . ,fixed-out))
624 #:sources (list %bash builder3)
625 #:inputs (list (derivation-input fixed1))))
626 (final2 (derivation %store "final"
627 %bash `(,builder3)
628 #:env-vars `(("in" . ,fixed-out))
629 #:sources (list %bash builder3)
630 #:inputs (list (derivation-input fixed2))))
631 (succeeded? (build-derivations %store
632 (list final1 final2))))
633 (and succeeded?
634 (equal? (derivation->output-path final1)
635 (derivation->output-path final2)))))
636
637(test-assert "derivation with duplicate fixed-output inputs"
638 ;; Here we create a derivation that has two inputs, both of which are
639 ;; fixed-output leading to the same result. This test ensures the hash of
640 ;; that derivation is correctly computed, namely that duplicate inputs are
641 ;; coalesced. See <https://bugs.gnu.org/36777>.
642 (let* ((builder1 (add-text-to-store %store "fixed-builder1.sh"
643 "echo -n hello > $out" '()))
644 (builder2 (add-text-to-store %store "fixed-builder2.sh"
645 "echo hey; echo -n hello > $out" '()))
646 (hash (gcrypt:sha256 (string->utf8 "hello")))
647 (fixed1 (derivation %store "fixed"
648 %bash `(,builder1)
649 #:sources (list %bash builder1)
650 #:hash hash #:hash-algo 'sha256))
651 (fixed2 (derivation %store "fixed"
652 %bash `(,builder2)
653 #:sources (list %bash builder2)
654 #:hash hash #:hash-algo 'sha256))
655 (builder3 (add-text-to-store %store "builder.sh"
656 "echo fake builder"))
657 (final (derivation %store "final"
658 %bash `(,builder3)
659 #:sources (list %bash builder3)
660 #:inputs (list (derivation-input fixed1)
661 (derivation-input fixed2)))))
662 (and (derivation? final)
663 (match (derivation-inputs final)
664 (((= derivation-input-derivation drv))
665 (memq drv (list fixed1 fixed2)))))))
666
667(test-assert "derivation with equivalent fixed-output inputs"
668 ;; Similar as the test above, but indirectly: DRV3A and DRV3B below are
669 ;; equivalent derivations (same output paths) but they depend on
670 ;; different-but-equivalent fixed-output derivations. Thus, DRV3A and DRV3B
671 ;; must be coalesced as inputs of DRV4. See <https://bugs.gnu.org/54209>.
672 (let* ((builder1 (add-text-to-store %store "fixed-builder1.sh"
673 "echo -n hello > $out"
674 '()))
675 (builder2 (add-text-to-store %store "fixed-builder2.sh"
676 "echo -n hello > $out"
677 '()))
678 (builder3 (add-text-to-store %store "user-builder.sh"
679 "echo 1 > $one; echo 2 > $two"
680 '()))
681 (hash (gcrypt:sha256 (string->utf8 "hello")))
682 (drv1 (derivation %store "fixed" %bash (list builder1)
683 #:sources (list %bash builder1)
684 #:hash hash #:hash-algo 'sha256))
685 (drv2 (derivation %store "fixed" %bash (list builder2)
686 #:sources (list %bash builder2)
687 #:hash hash #:hash-algo 'sha256))
688 (drv3a (derivation %store "fixed-user" %bash (list builder3)
689 #:outputs '("one" "two")
690 #:sources (list %bash builder3)
691 #:inputs (list (derivation-input drv1))))
692 (drv3b (derivation %store "fixed-user" %bash (list builder3)
693 #:outputs '("one" "two")
694 #:sources (list %bash builder3)
695 #:inputs (list (derivation-input drv2))))
696 (drv4 (derivation %store "fixed-user-user" %bash (list builder1)
697 #:sources (list %bash builder1)
698 #:inputs (list (derivation-input drv3a '("one"))
699 (derivation-input drv3b '("two"))))))
700 (match (derivation-inputs drv4)
701 ((input)
702 (and (memq (derivation-input-derivation input)
703 (list drv3a drv3b))
704 (lset= string=? (derivation-input-sub-derivations input)
705 '("one" "two")))))))
706
707(test-assert "multiple-output derivation"
708 (let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
709 "echo one > $out ; echo two > $second"
710 '()))
711 (drv (derivation %store "fixed"
712 %bash `(,builder)
713 #:env-vars '(("HOME" . "/homeless")
714 ("zzz" . "Z!")
715 ("AAA" . "A!"))
716 #:sources `(,%bash ,builder)
717 #:outputs '("out" "second")))
718 (succeeded? (build-derivations %store (list drv))))
719 (and succeeded?
720 (let ((one (derivation->output-path drv "out"))
721 (two (derivation->output-path drv "second")))
722 (and (lset= equal?
723 (derivation->output-paths drv)
724 `(("out" . ,one) ("second" . ,two)))
725 (eq? 'one (call-with-input-file one read))
726 (eq? 'two (call-with-input-file two read)))))))
727
728(test-assert "multiple-output derivation, non-alphabetic order"
729 ;; Here, the outputs are not listed in alphabetic order. Yet, the store
730 ;; path computation must reorder them first.
731 (let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
732 "echo one > $out ; echo two > $AAA"
733 '()))
734 (drv (derivation %store "fixed"
735 %bash `(,builder)
736 #:sources `(,%bash ,builder)
737 #:outputs '("out" "AAA")))
738 (succeeded? (build-derivations %store (list drv))))
739 (and succeeded?
740 (let ((one (derivation->output-path drv "out"))
741 (two (derivation->output-path drv "AAA")))
742 (and (eq? 'one (call-with-input-file one read))
743 (eq? 'two (call-with-input-file two read)))))))
744
745(test-assert "read-derivation vs. derivation"
746 ;; Make sure 'derivation' and 'read-derivation' return objects that are
747 ;; identical.
748 (let* ((sources (unfold (cut >= <> 10)
749 (lambda (n)
750 (add-text-to-store %store
751 (format #f "input~a" n)
752 (random-text)))
753 1+
754 0))
755 (inputs (map (lambda (file)
756 (derivation %store "derivation-input"
757 %bash '()
758 #:sources `(,%bash ,file)))
759 sources))
760 (builder (add-text-to-store %store "builder.sh"
761 "echo one > $one ; echo two > $two"
762 '()))
763 (drv (derivation %store "derivation"
764 %bash `(,builder)
765 #:sources `(,%bash ,builder ,@sources)
766 #:inputs (map derivation-input inputs)
767 #:outputs '("two" "one")))
768 (drv* (call-with-input-file (derivation-file-name drv)
769 read-derivation)))
770 (equal? drv* drv)))
771
772(test-assert "read-derivation with hash = #f"
773 ;; Passing #:hash-algo together with #:hash #f is accepted and #:hash-algo
774 ;; is preserved. However it is not a fixed-output derivation. It used to
775 ;; be that 'read-derivation' would incorrectly return #vu8() instead of #f
776 ;; for the hash in this case:
777 ;; <https://lists.gnu.org/archive/html/guix-devel/2023-01/msg00040.html>.
778 (let* ((drv1 (derivation %store "almost-fixed-output"
779 "builtin:download" '()
780 #:env-vars `(("url" . "http://example.org"))
781 #:hash-algo 'sha256
782 #:hash #f))
783 (drv2 (call-with-input-file (derivation-file-name drv1)
784 read-derivation)))
785 (and (not (eq? drv1 drv2)) ;ensure memoization doesn't kick in
786 (equal? drv1 drv2))))
787
788(test-assert "multiple-output derivation, derivation-path->output-path"
789 (let* ((builder (add-text-to-store %store "builder.sh"
790 "echo one > $out ; echo two > $second"
791 '()))
792 (drv (derivation %store "multiple"
793 %bash `(,builder)
794 #:outputs '("out" "second")))
795 (drv-file (derivation-file-name drv))
796 (one (derivation->output-path drv "out"))
797 (two (derivation->output-path drv "second"))
798 (first (derivation-path->output-path drv-file "out"))
799 (second (derivation-path->output-path drv-file "second")))
800 (and (not (string=? one two))
801 (string-suffix? "-second" two)
802 (string=? first one)
803 (string=? second two))))
804
805(test-assert "user of multiple-output derivation"
806 ;; Check whether specifying several inputs coming from the same
807 ;; multiple-output derivation works.
808 (let* ((builder1 (add-text-to-store %store "my-mo-builder.sh"
809 "echo one > $out ; echo two > $two"
810 '()))
811 (mdrv (derivation %store "multiple-output"
812 %bash `(,builder1)
813 #:sources (list %bash builder1)
814 #:outputs '("out" "two")))
815 (builder2 (add-text-to-store %store "my-mo-user-builder.sh"
816 "read x < $one;
817 read y < $two;
818 echo \"($x $y)\" > $out"
819 '()))
820 (udrv (derivation %store "multiple-output-user"
821 %bash `(,builder2)
822 #:env-vars `(("one"
823 . ,(derivation->output-path
824 mdrv "out"))
825 ("two"
826 . ,(derivation->output-path
827 mdrv "two")))
828 #:sources (list %bash builder2)
829 ;; two occurrences of MDRV:
830 #:inputs
831 (list (derivation-input mdrv)
832 (derivation-input mdrv '("two"))))))
833 (and (build-derivations %store (list (pk 'udrv udrv)))
834 (let ((p (derivation->output-path udrv)))
835 (and (valid-path? %store p)
836 (equal? '(one two) (call-with-input-file p read)))))))
837
838(test-assert "derivation with #:references-graphs"
839 (let* ((input1 (add-text-to-store %store "foo" "hello"
840 (list %bash)))
841 (input2 (add-text-to-store %store "bar"
842 (number->string (random 7777))
843 (list input1)))
844 (builder (add-text-to-store %store "build-graph"
845 (format #f "
846~a $out
847 (while read l ; do echo $l ; done) < bash > $out/bash
848 (while read l ; do echo $l ; done) < input1 > $out/input1
849 (while read l ; do echo $l ; done) < input2 > $out/input2"
850 %mkdir)
851 (list %mkdir)))
852 (drv (derivation %store "closure-graphs"
853 %bash `(,builder)
854 #:references-graphs
855 `(("bash" . ,%bash)
856 ("input1" . ,input1)
857 ("input2" . ,input2))
858 #:sources (list %bash builder)))
859 (out (derivation->output-path drv)))
860 (define (deps path . deps)
861 (let ((count (length deps)))
862 (string-append path "\n\n" (number->string count) "\n"
863 (string-join (sort deps string<?) "\n")
864 (if (zero? count) "" "\n"))))
865
866 (and (build-derivations %store (list drv))
867 (equal? (directory-contents out get-string-all)
868 `(("/bash" . ,(string-append %bash "\n\n0\n"))
869 ("/input1" . ,(if (string>? input1 %bash)
870 (string-append (deps %bash)
871 (deps input1 %bash))
872 (string-append (deps input1 %bash)
873 (deps %bash))))
874 ("/input2" . ,(string-concatenate
875 (map cdr
876 (sort
877 (map (lambda (p d)
878 (cons p (apply deps p d)))
879 (list %bash input1 input2)
880 (list '() (list %bash) (list input1)))
881 (lambda (x y)
882 (match x
883 ((p1 . _)
884 (match y
885 ((p2 . _)
886 (string<? p1 p2)))))))))))))))
887
888(test-assert "derivation #:allowed-references, ok"
889 (let ((drv (derivation %store "allowed" %bash
890 '("-c" "echo hello > $out")
891 #:sources (list %bash)
892 #:allowed-references '())))
893 (build-derivations %store (list drv))))
894
895(test-assert "derivation #:allowed-references, not allowed"
896 (let* ((txt (add-text-to-store %store "foo" "Hello, world."))
897 (drv (derivation %store "disallowed" %bash
898 `("-c" ,(string-append "echo " txt "> $out"))
899 #:sources (list %bash txt)
900 #:allowed-references '())))
901 (guard (c ((store-protocol-error? c)
902 ;; There's no specific error message to check for.
903 #t))
904 (build-derivations %store (list drv))
905 #f)))
906
907(test-assert "derivation #:allowed-references, self allowed"
908 (let ((drv (derivation %store "allowed" %bash
909 '("-c" "echo $out > $out")
910 #:sources (list %bash)
911 #:allowed-references '("out"))))
912 (build-derivations %store (list drv))))
913
914(test-assert "derivation #:allowed-references, self not allowed"
915 (let ((drv (derivation %store "disallowed" %bash
916 `("-c" ,"echo $out > $out")
917 #:sources (list %bash)
918 #:allowed-references '())))
919 (guard (c ((store-protocol-error? c)
920 ;; There's no specific error message to check for.
921 #t))
922 (build-derivations %store (list drv))
923 #f)))
924
925(test-assert "derivation #:disallowed-references, ok"
926 (let ((drv (derivation %store "disallowed" %bash
927 '("-c" "echo hello > $out")
928 #:sources (list %bash)
929 #:disallowed-references '("out"))))
930 (build-derivations %store (list drv))))
931
932(test-assert "derivation #:disallowed-references, not ok"
933 (let* ((txt (add-text-to-store %store "foo" "Hello, world."))
934 (drv (derivation %store "disdisallowed" %bash
935 `("-c" ,(string-append "echo " txt "> $out"))
936 #:sources (list %bash txt)
937 #:disallowed-references (list txt))))
938 (guard (c ((store-protocol-error? c)
939 ;; There's no specific error message to check for.
940 #t))
941 (build-derivations %store (list drv))
942 #f)))
943
944;; Here we should get the value of $GUIX_STATE_DIRECTORY that the daemon sees,
945;; which is a unique value for each test process; this value is the same as
946;; the one we see in the process executing this file since it is set by
947;; 'test-env'.
948(test-equal "derivation #:leaked-env-vars"
949 (getenv "GUIX_STATE_DIRECTORY")
950 (let* ((value (getenv "GUIX_STATE_DIRECTORY"))
951 (drv (derivation %store "leaked-env-vars" %bash
952 '("-c" "echo -n $GUIX_STATE_DIRECTORY > $out")
953 #:hash (gcrypt:sha256 (string->utf8 value))
954 #:hash-algo 'sha256
955 #:sources (list %bash)
956 #:leaked-env-vars '("GUIX_STATE_DIRECTORY"))))
957 (and (build-derivations %store (list drv))
958 (call-with-input-file (derivation->output-path drv)
959 get-string-all))))
960
961(test-assert "builder is outside the store"
962 ;; Ensure that attempts to build derivations whose builder is outside the
963 ;; store are rejected. This is a protection against attacks similar to
964 ;; CVE-2019-5736, which abuse the fact that /proc/self/exe can be opened
965 ;; even when it presents itself as a symlink to a file not in the chroot.
966 (let* ((builder (add-file-tree-to-store %store
967 `("builder" symlink "/proc/self/exe")))
968 (drv (derivation %store "attempt-to-run-guix-daemon" builder '()
969 #:env-vars
970 '(("LD_PRELOAD" . "attacker-controlled.so")))))
971 (guard (c ((store-protocol-error? c) c))
972 (build-derivations %store (list drv))
973 #f)))
974
975(test-assert "unreadable directories in build tree can be removed"
976 ;; Unreadable directories created in the build tree should be removed
977 ;; without problem. See <https://codeberg.org/guix/guix/issues/5891>.
978 (let* ((drv (build-expression->derivation
979 %store
980 (string-append (number->string (random (expt 2 64) (%seed))
981 16)
982 "-unreadable-test")
983 '(begin
984 (mkdir "unreadable" #o000)
985 (mkdir %output)))))
986 (build-derivations %store (list drv))
987 (file-is-directory? (derivation->output-path drv))))
988
989
990(define %coreutils
991 (false-if-exception
992 (and (network-reachable?)
993 (package-derivation %store %bootstrap-coreutils&co))))
994
995(test-skip (if %coreutils 0 1))
996
997(test-assert "build derivation with coreutils"
998 (let* ((builder
999 (add-text-to-store %store "build-with-coreutils.sh"
1000 "echo $PATH ; mkdir --version ; mkdir $out ; touch $out/good"
1001 '()))
1002 (drv
1003 (derivation %store "foo"
1004 %bash `(,builder)
1005 #:env-vars `(("PATH" .
1006 ,(string-append
1007 (derivation->output-path %coreutils)
1008 "/bin")))
1009 #:sources (list %bash builder)
1010 #:inputs (list (derivation-input %coreutils))))
1011 (succeeded?
1012 (build-derivations %store (list drv))))
1013 (and succeeded?
1014 (let ((p (derivation->output-path drv)))
1015 (and (valid-path? %store p)
1016 (file-exists? (string-append p "/good")))))))
1017
1018(test-skip (if (%guile-for-build) 0 8))
1019
1020(test-equal "build-expression->derivation and invalid module name"
1021 '(file-search-error "guix/module/that/does/not/exist.scm")
1022 (guard (c ((file-search-error? c)
1023 (list 'file-search-error
1024 (file-search-error-file-name c))))
1025 (build-expression->derivation %store "foo" #t
1026 #:modules '((guix module that
1027 does not exist)))))
1028
1029(test-equal "build-expression->derivation and builder encoding"
1030 '("UTF-8" #t)
1031 (let* ((exp '(λ (α) (+ α 1)))
1032 (drv (build-expression->derivation %store "foo" exp)))
1033 (match (derivation-builder-arguments drv)
1034 ((... builder)
1035 (with-fluids ((%default-port-encoding "UTF-8"))
1036 (call-with-input-file builder
1037 (lambda (port)
1038 (list (port-encoding port)
1039 (->bool
1040 (string-contains (get-string-all port)
1041 "(λ (α) (+ α 1))"))))))))))
1042
1043(test-assert "build-expression->derivation and derivation-prerequisites"
1044 (let ((drv (build-expression->derivation %store "fail" #f)))
1045 (any (match-lambda
1046 (($ <derivation-input> (= derivation-file-name path))
1047 (string=? path (derivation-file-name (%guile-for-build)))))
1048 (derivation-prerequisites drv))))
1049
1050(test-assert "derivation-prerequisites and valid-derivation-input?"
1051 (let* ((a (build-expression->derivation %store "a" '(mkdir %output)))
1052 (b (build-expression->derivation %store "b" `(list ,(random-text))))
1053 (c (build-expression->derivation %store "c" `(mkdir %output)
1054 #:inputs `(("a" ,a) ("b" ,b)))))
1055 ;; Make sure both A and %BOOTSTRAP-GUILE are built (the latter could have
1056 ;; be removed by tests/guix-gc.sh.)
1057 (build-derivations %store
1058 (list a (package-derivation %store %bootstrap-guile)))
1059
1060 (match (derivation-prerequisites c
1061 (cut valid-derivation-input? %store
1062 <>))
1063 ((($ <derivation-input> (= derivation-file-name file) ("out")))
1064 (string=? file (derivation-file-name b)))
1065 (x
1066 (pk 'fail x #f)))))
1067
1068(test-assert "build-expression->derivation without inputs"
1069 (let* ((builder '(begin
1070 (mkdir %output)
1071 (call-with-output-file (string-append %output "/test")
1072 (lambda (p)
1073 (display '(hello guix) p)))))
1074 (drv (build-expression->derivation %store "goo" builder))
1075 (succeeded? (build-derivations %store (list drv))))
1076 (and succeeded?
1077 (let ((p (derivation->output-path drv)))
1078 (equal? '(hello guix)
1079 (call-with-input-file (string-append p "/test") read))))))
1080
1081(test-assert "build-expression->derivation and max-silent-time"
1082 (let* ((store (let ((s (open-connection)))
1083 (set-build-options s #:max-silent-time 1)
1084 s))
1085 (builder '(begin (sleep 100) (mkdir %output) #t))
1086 (drv (build-expression->derivation store "silent" builder))
1087 (out-path (derivation->output-path drv)))
1088 (guard (c ((store-protocol-error? c)
1089 (and (string-contains (store-protocol-error-message c)
1090 "failed")
1091 (not (valid-path? store out-path)))))
1092 (build-derivations store (list drv))
1093 #f)))
1094
1095(test-assert "build-expression->derivation and timeout"
1096 (let* ((store (let ((s (open-connection)))
1097 (set-build-options s #:timeout 1)
1098 s))
1099 (builder '(begin (sleep 100) (mkdir %output) #t))
1100 (drv (build-expression->derivation store "slow" builder))
1101 (out-path (derivation->output-path drv)))
1102 (guard (c ((store-protocol-error? c)
1103 (and (string-contains (store-protocol-error-message c)
1104 "failed")
1105 (not (valid-path? store out-path)))))
1106 (build-derivations store (list drv))
1107 #f)))
1108
1109(test-assert "build-derivations with specific output"
1110 (with-store store
1111 (let* ((content (random-text)) ;contents of the output
1112 (drv (build-expression->derivation
1113 store "substitute-me"
1114 `(begin ,content (exit 1)) ;would fail
1115 #:outputs '("out" "one" "two")
1116 #:guile-for-build
1117 (package-derivation store %bootstrap-guile)))
1118 (out (derivation->output-path drv)))
1119 (with-derivation-substitute drv content
1120 (set-build-options store #:use-substitutes? #t
1121 #:substitute-urls (%test-substitute-urls))
1122 (and (has-substitutes? store out)
1123
1124 ;; Ask for nothing but the "out" output of DRV.
1125 (build-derivations store `((,drv . "out")))
1126
1127 ;; Synonymous:
1128 (build-derivations store (list (derivation-input drv '("out"))))
1129
1130 (valid-path? store out)
1131 (equal? (pk 'x content)
1132 (pk 'y (call-with-input-file out get-string-all))))))))
1133
1134(test-assert "build-expression->derivation and derivation-build-plan"
1135 (let ((drv (build-expression->derivation %store "fail" #f)))
1136 ;; The only direct dependency is (%guile-for-build) and it's already
1137 ;; built.
1138 (null? (derivation-build-plan %store (derivation-inputs drv)))))
1139
1140(test-assert "derivation-build-plan when outputs already present"
1141 (let* ((builder `(begin ,(random-text) (mkdir %output) #t))
1142 (input-drv (build-expression->derivation %store "input" builder))
1143 (input-path (derivation->output-path input-drv))
1144 (drv (build-expression->derivation %store "something" builder
1145 #:inputs
1146 `(("i" ,input-drv))))
1147 (output (derivation->output-path drv)))
1148 ;; Assume these things are not already built.
1149 (when (or (valid-path? %store input-path)
1150 (valid-path? %store output))
1151 (error "things already built" input-drv))
1152
1153 (and (lset= equal?
1154 (map derivation-file-name
1155 (derivation-build-plan %store
1156 (list (derivation-input drv))))
1157 (list (derivation-file-name input-drv)
1158 (derivation-file-name drv)))
1159
1160 ;; Build DRV and delete its input.
1161 (build-derivations %store (list drv))
1162 (delete-paths %store (list input-path))
1163 (not (valid-path? %store input-path))
1164
1165 ;; Now INPUT-PATH is missing, yet it shouldn't be listed as a
1166 ;; prerequisite to build because DRV itself is already built.
1167 (null? (derivation-build-plan %store
1168 (list (derivation-input drv)))))))
1169
1170(test-assert "derivation-build-plan and substitutes"
1171 (let* ((store (open-connection))
1172 (drv (build-expression->derivation store "prereq-subst"
1173 (random 1000)))
1174 (output (derivation->output-path drv)))
1175
1176 ;; Make sure substitutes are usable.
1177 (set-build-options store #:use-substitutes? #t
1178 #:substitute-urls (%test-substitute-urls))
1179
1180 (with-derivation-narinfo drv
1181 (let-values (((build download)
1182 (derivation-build-plan store
1183 (list (derivation-input drv))))
1184 ((build* download*)
1185 (derivation-build-plan store
1186 (list (derivation-input drv))
1187 #:substitutable-info
1188 (const #f))))
1189 (and (null? build)
1190 (equal? (map substitutable-path download) (list output))
1191 (null? download*)
1192 (equal? (list drv) build*))))))
1193
1194(test-assert "derivation-build-plan and substitutes, non-substitutable build"
1195 (let* ((store (open-connection))
1196 (drv (build-expression->derivation store "prereq-no-subst"
1197 (random 1000)
1198 #:substitutable? #f))
1199 (output (derivation->output-path drv)))
1200
1201 ;; Make sure substitutes are usable.
1202 (set-build-options store #:use-substitutes? #t
1203 #:substitute-urls (%test-substitute-urls))
1204
1205 (with-derivation-narinfo drv
1206 (let-values (((build download)
1207 (derivation-build-plan store
1208 (list (derivation-input drv)))))
1209 ;; Despite being available as a substitute, DRV will be built locally
1210 ;; due to #:substitutable? #f.
1211 (and (null? download)
1212 (match build
1213 (((= derivation-file-name build))
1214 (string=? build (derivation-file-name drv)))))))))
1215
1216(test-assert "derivation-build-plan and substitutes, non-substitutable dep"
1217 (with-store store
1218 (let* ((drv1 (build-expression->derivation store "prereq-no-subst"
1219 (random 1000)
1220 #:substitutable? #f))
1221 (drv2 (build-expression->derivation store "substitutable"
1222 (random 1000)
1223 #:inputs `(("dep" ,drv1)))))
1224
1225 ;; Make sure substitutes are usable.
1226 (set-build-options store #:use-substitutes? #t
1227 #:substitute-urls (%test-substitute-urls))
1228
1229 (with-derivation-narinfo drv2
1230 (sha256 => (make-bytevector 32 0))
1231 (references => (list (derivation->output-path drv1)))
1232
1233 (let-values (((build download)
1234 (derivation-build-plan store
1235 (list (derivation-input drv2)))))
1236 ;; Although DRV2 is available as a substitute, we must build its
1237 ;; dependency, DRV1, due to #:substitutable? #f.
1238 (and (match download
1239 (((= substitutable-path item))
1240 (string=? item (derivation->output-path drv2))))
1241 (match build
1242 (((= derivation-file-name build))
1243 (string=? build (derivation-file-name drv1))))))))))
1244
1245(test-assert "derivation-build-plan and substitutes, local build"
1246 (with-store store
1247 (let* ((drv (build-expression->derivation store "prereq-subst-local"
1248 (random 1000)
1249 #:local-build? #t))
1250 (output (derivation->output-path drv)))
1251
1252 ;; Make sure substitutes are usable.
1253 (set-build-options store #:use-substitutes? #t
1254 #:substitute-urls (%test-substitute-urls))
1255
1256 (with-derivation-narinfo drv
1257 (let-values (((build download)
1258 (derivation-build-plan store
1259 (list (derivation-input drv)))))
1260 ;; #:local-build? is *not* synonymous with #:substitutable?, so we
1261 ;; must be able to substitute DRV's output.
1262 ;; See <http://bugs.gnu.org/18747>.
1263 (and (null? build)
1264 (match download
1265 (((= substitutable-path item))
1266 (string=? item (derivation->output-path drv))))))))))
1267
1268(test-assert "derivation-build-plan in 'check' mode"
1269 (with-store store
1270 (let* ((dep (build-expression->derivation store "dep"
1271 `(begin ,(random-text)
1272 (mkdir %output))))
1273 (drv (build-expression->derivation store "to-check"
1274 '(mkdir %output)
1275 #:inputs `(("dep" ,dep)))))
1276 (build-derivations store (list drv))
1277 (delete-paths store (list (derivation->output-path dep)))
1278
1279 ;; In 'check' mode, DEP must be rebuilt.
1280 (and (null? (derivation-build-plan store
1281 (list (derivation-input drv))))
1282 (lset= equal?
1283 (derivation-build-plan store
1284 (list (derivation-input drv))
1285 #:mode (build-mode check))
1286 (list drv dep))))))
1287
1288(test-equal "derivation-build-plan, topological ordering"
1289 (make-list 5 '("0.drv" "1.drv" "2.drv" "3.drv" "4.drv"))
1290 (with-store store
1291 (define (test _)
1292 (let* ((simple-derivation
1293 (lambda (name . deps)
1294 (build-expression->derivation
1295 store name
1296 `(begin ,(random-text) (mkdir %output))
1297 #:inputs (map (lambda (n dep)
1298 (list (number->string n) dep))
1299 (iota (length deps))
1300 deps))))
1301 (drv0 (simple-derivation "0"))
1302 (drv1 (simple-derivation "1" drv0))
1303 (drv2 (simple-derivation "2" drv1))
1304 (drv3 (simple-derivation "3" drv2 drv0))
1305 (drv4 (simple-derivation "4" drv3 drv1)))
1306 (map (compose strip-store-file-name derivation-file-name)
1307 (derivation-build-plan store (list (derivation-input drv4))))))
1308
1309 ;; This is probabilistic: if the traversal is buggy, it may or may not
1310 ;; produce the wrong ordering, depending on a variety of actors. Thus,
1311 ;; try multiple times.
1312 (map test (iota 5))))
1313
1314(test-assert "derivation-input-fold"
1315 (let* ((builder (add-text-to-store %store "my-builder.sh"
1316 "echo hello, world > \"$out\"\n"
1317 '()))
1318 (drv1 (derivation %store "foo"
1319 %bash `(,builder)
1320 #:sources `(,%bash ,builder)))
1321 (drv2 (derivation %store "bar"
1322 %bash `(,builder)
1323 #:inputs `((,drv1))
1324 #:sources `(,%bash ,builder))))
1325 (equal? (derivation-input-fold (lambda (input result)
1326 (cons (derivation-input-derivation input)
1327 result))
1328 '()
1329 (list (derivation-input drv2)))
1330 (list drv1 drv2))))
1331
1332(test-assert "substitution-oracle and #:substitute? #f"
1333 (with-store store
1334 (let* ((dep (build-expression->derivation store "dep"
1335 `(begin ,(random-text)
1336 (mkdir %output))))
1337 (drv (build-expression->derivation store "not-subst"
1338 `(begin ,(random-text)
1339 (mkdir %output))
1340 #:substitutable? #f
1341 #:inputs `(("dep" ,dep))))
1342 (query #f))
1343 (define (record-substitutable-path-query store paths)
1344 (when query
1345 (error "already called!" query))
1346 (set! query paths)
1347 '())
1348
1349 (mock ((guix store) substitutable-path-info
1350 record-substitutable-path-query)
1351
1352 (let ((pred (substitution-oracle store (list drv))))
1353 (pred (derivation->output-path drv))))
1354
1355 ;; Make sure the oracle didn't try to get substitute info for DRV since
1356 ;; DRV is mark as non-substitutable. Assume that GUILE-FOR-BUILD is
1357 ;; already in store and thus not part of QUERY.
1358 (equal? (pk 'query query)
1359 (list (derivation->output-path dep))))))
1360
1361(test-assert "build-expression->derivation with expression returning #f"
1362 (let* ((builder '(begin
1363 (mkdir %output)
1364 #f)) ; fail!
1365 (drv (build-expression->derivation %store "fail" builder))
1366 (out-path (derivation->output-path drv)))
1367 (guard (c ((store-protocol-error? c)
1368 ;; Note that the output path may exist at this point, but it
1369 ;; is invalid.
1370 (and (string-match "build .* failed"
1371 (store-protocol-error-message c))
1372 (not (valid-path? %store out-path)))))
1373 (build-derivations %store (list drv))
1374 #f)))
1375
1376(test-assert "build-expression->derivation with two outputs"
1377 (let* ((builder '(begin
1378 (call-with-output-file (assoc-ref %outputs "out")
1379 (lambda (p)
1380 (display '(hello) p)))
1381 (call-with-output-file (assoc-ref %outputs "second")
1382 (lambda (p)
1383 (display '(world) p)))))
1384 (drv (build-expression->derivation %store "double" builder
1385 #:outputs '("out"
1386 "second")))
1387 (succeeded? (build-derivations %store (list drv))))
1388 (and succeeded?
1389 (let ((one (derivation->output-path drv))
1390 (two (derivation->output-path drv "second")))
1391 (and (equal? '(hello) (call-with-input-file one read))
1392 (equal? '(world) (call-with-input-file two read)))))))
1393
1394(test-skip (if %coreutils 0 1))
1395(test-assert "build-expression->derivation with one input"
1396 (let* ((builder '(call-with-output-file %output
1397 (lambda (p)
1398 (let ((cu (assoc-ref %build-inputs "cu")))
1399 (close 1)
1400 (dup2 (port->fdes p) 1)
1401 (execl (string-append cu "/bin/uname")
1402 "uname" "-a")))))
1403 (drv (build-expression->derivation %store "uname" builder
1404 #:inputs
1405 `(("cu" ,%coreutils))))
1406 (succeeded? (build-derivations %store (list drv))))
1407 (and succeeded?
1408 (let ((p (derivation->output-path drv)))
1409 (string-contains (call-with-input-file p read-line) "GNU")))))
1410
1411(test-assert "build-expression->derivation with modules"
1412 (let* ((builder `(begin
1413 (use-modules (guix build utils))
1414 (let ((out (assoc-ref %outputs "out")))
1415 (mkdir-p (string-append out "/guile/guix/nix"))
1416 #t)))
1417 (drv (build-expression->derivation %store "test-with-modules"
1418 builder
1419 #:modules
1420 '((guix build utils)))))
1421 (and (build-derivations %store (list drv))
1422 (let* ((p (derivation->output-path drv))
1423 (s (stat (string-append p "/guile/guix/nix"))))
1424 (eq? (stat:type s) 'directory)))))
1425
1426(test-assert "build-expression->derivation: same fixed-output path"
1427 (let* ((builder1 '(call-with-output-file %output
1428 (lambda (p)
1429 (write "hello" p))))
1430 (builder2 '(call-with-output-file (pk 'difference-here! %output)
1431 (lambda (p)
1432 (write "hello" p))))
1433 (hash (gcrypt:sha256 (string->utf8 "hello")))
1434 (input1 (build-expression->derivation %store "fixed" builder1
1435 #:hash hash
1436 #:hash-algo 'sha256))
1437 (input2 (build-expression->derivation %store "fixed" builder2
1438 #:hash hash
1439 #:hash-algo 'sha256))
1440 (succeeded? (build-derivations %store (list input1 input2))))
1441 (and succeeded?
1442 (not (string=? (derivation-file-name input1)
1443 (derivation-file-name input2)))
1444 (string=? (derivation->output-path input1)
1445 (derivation->output-path input2)))))
1446
1447(test-assert "build-expression->derivation with a fixed-output input"
1448 (let* ((builder1 '(call-with-output-file %output
1449 (lambda (p)
1450 (write "hello" p))))
1451 (builder2 '(call-with-output-file (pk 'difference-here! %output)
1452 (lambda (p)
1453 (write "hello" p))))
1454 (hash (gcrypt:sha256 (string->utf8 "hello")))
1455 (input1 (build-expression->derivation %store "fixed" builder1
1456 #:hash hash
1457 #:hash-algo 'sha256))
1458 (input2 (build-expression->derivation %store "fixed" builder2
1459 #:hash hash
1460 #:hash-algo 'sha256))
1461 (builder3 '(let ((input (assoc-ref %build-inputs "input")))
1462 (call-with-output-file %output
1463 (lambda (out)
1464 (format #f "My input is ~a.~%" input)))))
1465 (final1 (build-expression->derivation %store "final" builder3
1466 #:inputs
1467 `(("input" ,input1))))
1468 (final2 (build-expression->derivation %store "final" builder3
1469 #:inputs
1470 `(("input" ,input2)))))
1471 (and (string=? (derivation->output-path final1)
1472 (derivation->output-path final2))
1473 (string=? (derivation->output-path final1)
1474 (derivation-path->output-path
1475 (derivation-file-name final1)))
1476 (build-derivations %store (list final1 final2)))))
1477
1478(test-assert "build-expression->derivation produces recursive fixed-output"
1479 (let* ((builder '(begin
1480 (use-modules (srfi srfi-26))
1481 (mkdir %output)
1482 (chdir %output)
1483 (call-with-output-file "exe"
1484 (cut display "executable" <>))
1485 (chmod "exe" #o777)
1486 (symlink "exe" "symlink")
1487 (mkdir "subdir")))
1488 (drv (build-expression->derivation %store "fixed-rec" builder
1489 #:hash-algo 'sha256
1490 #:hash (base32
1491 "10k1lw41wyrjf9mxydi0is5nkpynlsvgslinics4ppir13g7d74p")
1492 #:recursive? #t)))
1493 (and (build-derivations %store (list drv))
1494 (let* ((dir (derivation->output-path drv))
1495 (exe (string-append dir "/exe"))
1496 (link (string-append dir "/symlink"))
1497 (subdir (string-append dir "/subdir")))
1498 (and (executable-file? exe)
1499 (string=? "executable"
1500 (call-with-input-file exe get-string-all))
1501 (string=? "exe" (readlink link))
1502 (file-is-directory? subdir))))))
1503
1504(test-assert "build-expression->derivation uses recursive fixed-output"
1505 (let* ((builder '(call-with-output-file %output
1506 (lambda (port)
1507 (display "hello" port))))
1508 (fixed (build-expression->derivation %store "small-fixed-rec"
1509 builder
1510 #:hash-algo 'sha256
1511 #:hash (base32
1512 "0sg9f58l1jj88w6pdrfdpj5x9b1zrwszk84j81zvby36q9whhhqa")
1513 #:recursive? #t))
1514 (in (derivation->output-path fixed))
1515 (builder `(begin
1516 (mkdir %output)
1517 (chdir %output)
1518 (symlink ,in "symlink")))
1519 (drv (build-expression->derivation %store "fixed-rec-user"
1520 builder
1521 #:inputs `(("fixed" ,fixed)))))
1522 (and (build-derivations %store (list drv))
1523 (let ((out (derivation->output-path drv)))
1524 (string=? (readlink (string-append out "/symlink")) in)))))
1525
1526(test-assert "build-expression->derivation with #:references-graphs"
1527 (let* ((input (add-text-to-store %store "foo" "hello"
1528 (list %bash %mkdir)))
1529 (builder '(copy-file "input" %output))
1530 (drv (build-expression->derivation %store "references-graphs"
1531 builder
1532 #:references-graphs
1533 `(("input" . ,input))))
1534 (out (derivation->output-path drv)))
1535 (define (deps path . deps)
1536 (let ((count (length deps)))
1537 (string-append path "\n\n" (number->string count) "\n"
1538 (string-join (sort deps string<?) "\n")
1539 (if (zero? count) "" "\n"))))
1540
1541 (and (build-derivations %store (list drv))
1542 (equal? (call-with-input-file out get-string-all)
1543 (string-concatenate
1544 (map cdr
1545 (sort (map (lambda (p d)
1546 (cons p (apply deps p d)))
1547 (list input %bash %mkdir)
1548 (list (list %bash %mkdir)
1549 '() '()))
1550 (lambda (x y)
1551 (match x
1552 ((p1 . _)
1553 (match y
1554 ((p2 . _)
1555 (string<? p1 p2)))))))))))))
1556
1557(test-equal "derivation-properties"
1558 (list '() '((type . test)))
1559 (let ((drv1 (build-expression->derivation %store "bar"
1560 '(mkdir %output)))
1561 (drv2 (build-expression->derivation %store "foo"
1562 '(mkdir %output)
1563 #:properties '((type . test)))))
1564 (list (derivation-properties drv1)
1565 (derivation-properties drv2))))
1566
1567(test-equal "map-derivation"
1568 "hello"
1569 (let* ((joke (package-derivation %store guile-1.8))
1570 (good (package-derivation %store %bootstrap-guile))
1571 (drv1 (build-expression->derivation %store "original-drv1"
1572 #f ; systematically fail
1573 #:guile-for-build joke))
1574 (drv2 (build-expression->derivation %store "original-drv2"
1575 '(call-with-output-file %output
1576 (lambda (p)
1577 (display "hello" p)))))
1578 (drv3 (build-expression->derivation %store "drv-to-remap"
1579 '(let ((in (assoc-ref
1580 %build-inputs "in")))
1581 (copy-file in %output))
1582 #:inputs `(("in" ,drv1))
1583 #:guile-for-build joke))
1584 (drv4 (map-derivation %store drv3 `((,drv1 . ,drv2)
1585 (,joke . ,good))))
1586 (out (derivation->output-path drv4)))
1587 (and (build-derivations %store (list (pk 'remapped drv4)))
1588 (call-with-input-file out get-string-all))))
1589
1590(test-equal "map-derivation, sources"
1591 "hello"
1592 (let* ((script1 (add-text-to-store %store "fail.sh" "exit 1"))
1593 (script2 (add-text-to-store %store "hi.sh" "echo -n hello > $out"))
1594 (bash-full (package-derivation %store (@ (gnu packages bash) bash)))
1595 (drv1 (derivation %store "drv-to-remap"
1596
1597 ;; XXX: This wouldn't work in practice, but if
1598 ;; we append "/bin/bash" then we can't replace
1599 ;; it with the bootstrap bash, which is a
1600 ;; single file.
1601 (derivation->output-path bash-full)
1602
1603 `("-e" ,script1)
1604 #:sources (list script1)
1605 #:inputs
1606 (list (derivation-input bash-full '("out")))))
1607 (drv2 (map-derivation %store drv1
1608 `((,bash-full . ,%bash)
1609 (,script1 . ,script2))))
1610 (out (derivation->output-path drv2)))
1611 (and (build-derivations %store (list (pk 'remapped* drv2)))
1612 (call-with-input-file out get-string-all))))
1613
1614(test-assert "map-derivation, modules"
1615 (let* ((bash-drv (package-derivation %store (@ (gnu packages bash) bash)))
1616 (bash-input (car (derivation-inputs bash-drv)))
1617 (bash-input-drv (derivation-input-derivation bash-input))
1618 (drv-with-modules (run-with-store %store
1619 (gexp->derivation "derivation-with-modules"
1620 (with-imported-modules '((guix build utils))
1621 #~(begin
1622 (use-modules (guix build utils))
1623 (mkdir-p (string-append #$output
1624 "/bin")))))))
1625 (bash-mapped-1 (map-derivation %store bash-drv
1626 `((,bash-input-drv . ,drv-with-modules))))
1627 (bash-mapped-2 (map-derivation %store bash-mapped-1
1628 `((,drv-with-modules . ,bash-input-drv))))
1629 (is-input? (lambda (in drv)
1630 (not (null? (filter (lambda (input)
1631 (eq? in (derivation-input-derivation input)))
1632 (derivation-inputs drv)))))))
1633 (and
1634 (not (is-input? bash-input-drv bash-mapped-1))
1635 (is-input? bash-input-drv bash-mapped-2))))
1636
1637(test-end)
1638
1639;; Local Variables:
1640;; eval: (put 'with-http-server 'scheme-indent-function 1)
1641;; End: