01ede11af09cc8e9ab5a23559991d37f80fb1c36
[jackhill/guix/guix.git] / tests / derivations.scm
1 ;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
2 ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
3 ;;;
4 ;;; This file is part of Guix.
5 ;;;
6 ;;; 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 ;;; 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 Guix. If not, see <http://www.gnu.org/licenses/>.
18
19
20 (define-module (test-derivations)
21 #:use-module (guix derivations)
22 #:use-module (guix store)
23 #:use-module (guix utils)
24 #:use-module ((guix packages) #:select (package-derivation))
25 #:use-module (distro packages bootstrap)
26 #:use-module (srfi srfi-1)
27 #:use-module (srfi srfi-11)
28 #:use-module (srfi srfi-26)
29 #:use-module (srfi srfi-34)
30 #:use-module (srfi srfi-64)
31 #:use-module (rnrs io ports)
32 #:use-module (rnrs bytevectors)
33 #:use-module (ice-9 rdelim)
34 #:use-module (ice-9 regex)
35 #:use-module (ice-9 ftw)
36 #:use-module (ice-9 match))
37
38 (define %store
39 (false-if-exception (open-connection)))
40
41 (when %store
42 ;; Make sure we build everything by ourselves.
43 (set-build-options %store #:use-substitutes? #f)
44
45 ;; By default, use %BOOTSTRAP-GUILE for the current system.
46 (let ((drv (package-derivation %store %bootstrap-guile)))
47 (%guile-for-build drv)))
48
49 (define (directory-contents dir)
50 "Return an alist representing the contents of DIR."
51 (define prefix-len (string-length dir))
52 (sort (file-system-fold (const #t) ; enter?
53 (lambda (path stat result) ; leaf
54 (alist-cons (string-drop path prefix-len)
55 (call-with-input-file path
56 get-bytevector-all)
57 result))
58 (lambda (path stat result) result) ; down
59 (lambda (path stat result) result) ; up
60 (lambda (path stat result) result) ; skip
61 (lambda (path stat errno result) result) ; error
62 '()
63 dir)
64 (lambda (e1 e2)
65 (string<? (car e1) (car e2)))))
66
67 (test-begin "derivations")
68
69 (test-assert "parse & export"
70 (let* ((f (search-path %load-path "tests/test.drv"))
71 (b1 (call-with-input-file f get-bytevector-all))
72 (d1 (read-derivation (open-bytevector-input-port b1)))
73 (b2 (call-with-bytevector-output-port (cut write-derivation d1 <>)))
74 (d2 (read-derivation (open-bytevector-input-port b2))))
75 (and (equal? b1 b2)
76 (equal? d1 d2))))
77
78 (test-skip (if %store 0 4))
79
80 (test-assert "add-to-store, flat"
81 (let* ((file (search-path %load-path "language/tree-il/spec.scm"))
82 (drv (add-to-store %store "flat-test" #t #f "sha256" file)))
83 (and (eq? 'regular (stat:type (stat drv)))
84 (valid-path? %store drv)
85 (equal? (call-with-input-file file get-bytevector-all)
86 (call-with-input-file drv get-bytevector-all)))))
87
88 (test-assert "add-to-store, recursive"
89 (let* ((dir (dirname (search-path %load-path "language/tree-il/spec.scm")))
90 (drv (add-to-store %store "dir-tree-test" #t #t "sha256" dir)))
91 (and (eq? 'directory (stat:type (stat drv)))
92 (valid-path? %store drv)
93 (equal? (directory-contents dir)
94 (directory-contents drv)))))
95
96 (test-assert "derivation with no inputs"
97 (let* ((builder (add-text-to-store %store "my-builder.sh"
98 "#!/bin/sh\necho hello, world\n"
99 '()))
100 (drv-path (derivation %store "foo" (%current-system) builder
101 '() '(("HOME" . "/homeless")) '())))
102 (and (store-path? drv-path)
103 (valid-path? %store drv-path))))
104
105 (test-assert "build derivation with 1 source"
106 (let*-values (((builder)
107 (add-text-to-store %store "my-builder.sh"
108 "echo hello, world > \"$out\"\n"
109 '()))
110 ((drv-path drv)
111 (derivation %store "foo" (%current-system)
112 "/bin/sh" `(,builder)
113 '(("HOME" . "/homeless")
114 ("zzz" . "Z!")
115 ("AAA" . "A!"))
116 `((,builder))))
117 ((succeeded?)
118 (build-derivations %store (list drv-path))))
119 (and succeeded?
120 (let ((path (derivation-output-path
121 (assoc-ref (derivation-outputs drv) "out"))))
122 (and (valid-path? %store path)
123 (string=? (call-with-input-file path read-line)
124 "hello, world"))))))
125
126 (test-assert "fixed-output derivation"
127 (let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
128 "echo -n hello > $out" '()))
129 (hash (sha256 (string->utf8 "hello")))
130 (drv-path (derivation %store "fixed" (%current-system)
131 "/bin/sh" `(,builder)
132 '()
133 `((,builder)) ; optional
134 #:hash hash #:hash-algo 'sha256))
135 (succeeded? (build-derivations %store (list drv-path))))
136 (and succeeded?
137 (let ((p (derivation-path->output-path drv-path)))
138 (and (equal? (string->utf8 "hello")
139 (call-with-input-file p get-bytevector-all))
140 (bytevector? (query-path-hash %store p)))))))
141
142 (test-assert "fixed-output derivation: output paths are equal"
143 (let* ((builder1 (add-text-to-store %store "fixed-builder1.sh"
144 "echo -n hello > $out" '()))
145 (builder2 (add-text-to-store %store "fixed-builder2.sh"
146 "echo hey; echo -n hello > $out" '()))
147 (hash (sha256 (string->utf8 "hello")))
148 (drv-path1 (derivation %store "fixed" (%current-system)
149 "/bin/sh" `(,builder1)
150 '() `()
151 #:hash hash #:hash-algo 'sha256))
152 (drv-path2 (derivation %store "fixed" (%current-system)
153 "/bin/sh" `(,builder2)
154 '() `()
155 #:hash hash #:hash-algo 'sha256))
156 (succeeded? (build-derivations %store
157 (list drv-path1 drv-path2))))
158 (and succeeded?
159 (equal? (derivation-path->output-path drv-path1)
160 (derivation-path->output-path drv-path2)))))
161
162 (test-assert "derivation with a fixed-output input"
163 ;; A derivation D using a fixed-output derivation F doesn't has the same
164 ;; output path when passed F or F', as long as F and F' have the same output
165 ;; path.
166 (let* ((builder1 (add-text-to-store %store "fixed-builder1.sh"
167 "echo -n hello > $out" '()))
168 (builder2 (add-text-to-store %store "fixed-builder2.sh"
169 "echo hey; echo -n hello > $out" '()))
170 (hash (sha256 (string->utf8 "hello")))
171 (fixed1 (derivation %store "fixed" (%current-system)
172 "/bin/sh" `(,builder1)
173 '() `()
174 #:hash hash #:hash-algo 'sha256))
175 (fixed2 (derivation %store "fixed" (%current-system)
176 "/bin/sh" `(,builder2)
177 '() `()
178 #:hash hash #:hash-algo 'sha256))
179 (fixed-out (derivation-path->output-path fixed1))
180 (builder3 (add-text-to-store
181 %store "final-builder.sh"
182 ;; Use Bash hackery to avoid Coreutils.
183 "echo $in ; (read -u 3 c; echo $c) 3< $in > $out" '()))
184 (final1 (derivation %store "final" (%current-system)
185 "/bin/sh" `(,builder3)
186 `(("in" . ,fixed-out))
187 `((,builder3) (,fixed1))))
188 (final2 (derivation %store "final" (%current-system)
189 "/bin/sh" `(,builder3)
190 `(("in" . ,fixed-out))
191 `((,builder3) (,fixed2))))
192 (succeeded? (build-derivations %store
193 (list final1 final2))))
194 (and succeeded?
195 (equal? (derivation-path->output-path final1)
196 (derivation-path->output-path final2)))))
197
198 (test-assert "multiple-output derivation"
199 (let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
200 "echo one > $out ; echo two > $second"
201 '()))
202 (drv-path (derivation %store "fixed" (%current-system)
203 "/bin/sh" `(,builder)
204 '(("HOME" . "/homeless")
205 ("zzz" . "Z!")
206 ("AAA" . "A!"))
207 `((,builder))
208 #:outputs '("out" "second")))
209 (succeeded? (build-derivations %store (list drv-path))))
210 (and succeeded?
211 (let ((one (derivation-path->output-path drv-path "out"))
212 (two (derivation-path->output-path drv-path "second")))
213 (and (eq? 'one (call-with-input-file one read))
214 (eq? 'two (call-with-input-file two read)))))))
215
216 (test-assert "multiple-output derivation, non-alphabetic order"
217 ;; Here, the outputs are not listed in alphabetic order. Yet, the store
218 ;; path computation must reorder them first.
219 (let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
220 "echo one > $out ; echo two > $AAA"
221 '()))
222 (drv-path (derivation %store "fixed" (%current-system)
223 "/bin/sh" `(,builder)
224 '()
225 `((,builder))
226 #:outputs '("out" "AAA")))
227 (succeeded? (build-derivations %store (list drv-path))))
228 (and succeeded?
229 (let ((one (derivation-path->output-path drv-path "out"))
230 (two (derivation-path->output-path drv-path "AAA")))
231 (and (eq? 'one (call-with-input-file one read))
232 (eq? 'two (call-with-input-file two read)))))))
233
234 (test-assert "user of multiple-output derivation"
235 ;; Check whether specifying several inputs coming from the same
236 ;; multiple-output derivation works.
237 (let* ((builder1 (add-text-to-store %store "my-mo-builder.sh"
238 "echo one > $out ; echo two > $two"
239 '()))
240 (mdrv (derivation %store "multiple-output" (%current-system)
241 "/bin/sh" `(,builder1)
242 '()
243 `((,builder1))
244 #:outputs '("out" "two")))
245 (builder2 (add-text-to-store %store "my-mo-user-builder.sh"
246 "read x < $one;
247 read y < $two;
248 echo \"($x $y)\" > $out"
249 '()))
250 (udrv (derivation %store "multiple-output-user"
251 (%current-system)
252 "/bin/sh" `(,builder2)
253 `(("one" . ,(derivation-path->output-path
254 mdrv "out"))
255 ("two" . ,(derivation-path->output-path
256 mdrv "two")))
257 `((,builder2)
258 ;; two occurrences of MDRV:
259 (,mdrv)
260 (,mdrv "two")))))
261 (and (build-derivations %store (list (pk 'udrv udrv)))
262 (let ((p (derivation-path->output-path udrv)))
263 (and (valid-path? %store p)
264 (equal? '(one two) (call-with-input-file p read)))))))
265
266 \f
267 (define %coreutils
268 (false-if-exception
269 (or (package-derivation %store %bootstrap-coreutils&co)
270 (nixpkgs-derivation "coreutils"))))
271
272 (test-skip (if %coreutils 0 1))
273
274 (test-assert "build derivation with coreutils"
275 (let* ((builder
276 (add-text-to-store %store "build-with-coreutils.sh"
277 "echo $PATH ; mkdir --version ; mkdir $out ; touch $out/good"
278 '()))
279 (drv-path
280 (derivation %store "foo" (%current-system)
281 "/bin/sh" `(,builder)
282 `(("PATH" .
283 ,(string-append
284 (derivation-path->output-path %coreutils)
285 "/bin")))
286 `((,builder)
287 (,%coreutils))))
288 (succeeded?
289 (build-derivations %store (list drv-path))))
290 (and succeeded?
291 (let ((p (derivation-path->output-path drv-path)))
292 (and (valid-path? %store p)
293 (file-exists? (string-append p "/good")))))))
294
295 (test-skip (if (%guile-for-build) 0 7))
296
297 (test-assert "build-expression->derivation and derivation-prerequisites"
298 (let-values (((drv-path drv)
299 (build-expression->derivation %store "fail" (%current-system)
300 #f '())))
301 (any (match-lambda
302 (($ <derivation-input> path)
303 (string=? path (%guile-for-build))))
304 (derivation-prerequisites drv))))
305
306 (test-assert "build-expression->derivation without inputs"
307 (let* ((builder '(begin
308 (mkdir %output)
309 (call-with-output-file (string-append %output "/test")
310 (lambda (p)
311 (display '(hello guix) p)))))
312 (drv-path (build-expression->derivation %store "goo" (%current-system)
313 builder '()))
314 (succeeded? (build-derivations %store (list drv-path))))
315 (and succeeded?
316 (let ((p (derivation-path->output-path drv-path)))
317 (equal? '(hello guix)
318 (call-with-input-file (string-append p "/test") read))))))
319
320 (test-assert "build-expression->derivation and derivation-prerequisites-to-build"
321 (let-values (((drv-path drv)
322 (build-expression->derivation %store "fail" (%current-system)
323 #f '())))
324 ;; The only direct dependency is (%guile-for-build) and it's already
325 ;; built.
326 (null? (derivation-prerequisites-to-build %store drv))))
327
328 (test-assert "build-expression->derivation with expression returning #f"
329 (let* ((builder '(begin
330 (mkdir %output)
331 #f)) ; fail!
332 (drv-path (build-expression->derivation %store "fail" (%current-system)
333 builder '()))
334 (out-path (derivation-path->output-path drv-path)))
335 (guard (c ((nix-protocol-error? c)
336 ;; Note that the output path may exist at this point, but it
337 ;; is invalid.
338 (and (string-match "build .* failed"
339 (nix-protocol-error-message c))
340 (not (valid-path? %store out-path)))))
341 (build-derivations %store (list drv-path))
342 #f)))
343
344 (test-assert "build-expression->derivation with two outputs"
345 (let* ((builder '(begin
346 (call-with-output-file (assoc-ref %outputs "out")
347 (lambda (p)
348 (display '(hello) p)))
349 (call-with-output-file (assoc-ref %outputs "second")
350 (lambda (p)
351 (display '(world) p)))))
352 (drv-path (build-expression->derivation %store "double"
353 (%current-system)
354 builder '()
355 #:outputs '("out"
356 "second")))
357 (succeeded? (build-derivations %store (list drv-path))))
358 (and succeeded?
359 (let ((one (derivation-path->output-path drv-path))
360 (two (derivation-path->output-path drv-path "second")))
361 (and (equal? '(hello) (call-with-input-file one read))
362 (equal? '(world) (call-with-input-file two read)))))))
363
364 (test-assert "build-expression->derivation with one input"
365 (let* ((builder '(call-with-output-file %output
366 (lambda (p)
367 (let ((cu (assoc-ref %build-inputs "cu")))
368 (close 1)
369 (dup2 (port->fdes p) 1)
370 (execl (string-append cu "/bin/uname")
371 "uname" "-a")))))
372 (drv-path (build-expression->derivation %store "uname" (%current-system)
373 builder
374 `(("cu" ,%coreutils))))
375 (succeeded? (build-derivations %store (list drv-path))))
376 (and succeeded?
377 (let ((p (derivation-path->output-path drv-path)))
378 (string-contains (call-with-input-file p read-line) "GNU")))))
379
380 (test-assert "imported-files"
381 (let* ((files `(("x" . ,(search-path %load-path "ice-9/q.scm"))
382 ("a/b/c" . ,(search-path %load-path
383 "guix/derivations.scm"))
384 ("p/q" . ,(search-path %load-path "guix.scm"))
385 ("p/z" . ,(search-path %load-path "guix/store.scm"))))
386 (drv-path (imported-files %store files)))
387 (and (build-derivations %store (list drv-path))
388 (let ((dir (derivation-path->output-path drv-path)))
389 (every (match-lambda
390 ((path . source)
391 (equal? (call-with-input-file (string-append dir "/" path)
392 get-bytevector-all)
393 (call-with-input-file source
394 get-bytevector-all))))
395 files)))))
396
397 (test-assert "build-expression->derivation with modules"
398 (let* ((builder `(begin
399 (use-modules (guix build utils))
400 (let ((out (assoc-ref %outputs "out")))
401 (mkdir-p (string-append out "/guile/guix/nix"))
402 #t)))
403 (drv-path (build-expression->derivation %store
404 "test-with-modules"
405 (%current-system)
406 builder '()
407 #:modules
408 '((guix build utils)))))
409 (and (build-derivations %store (list drv-path))
410 (let* ((p (derivation-path->output-path drv-path))
411 (s (stat (string-append p "/guile/guix/nix"))))
412 (eq? (stat:type s) 'directory)))))
413
414 (test-skip (if (false-if-exception (getaddrinfo "ftp.gnu.org" "http"))
415 0
416 1))
417
418 (test-assert "build-expression->derivation for fixed-output derivation"
419 (let* ((url "http://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz")
420 (builder
421 `(begin
422 (use-modules (web client) (web uri)
423 (rnrs io ports) (srfi srfi-11))
424 (let-values (((resp bv)
425 (http-get (string->uri ,url) #:decode-body? #f)))
426 (call-with-output-file %output
427 (lambda (p)
428 (put-bytevector p bv))))))
429 (drv-path (build-expression->derivation
430 %store "hello-2.8.tar.gz" (%current-system) builder '()
431 #:hash (nix-base32-string->bytevector
432 "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6")
433 #:hash-algo 'sha256))
434 (succeeded? (build-derivations %store (list drv-path))))
435 (and succeeded?
436 (file-exists? (derivation-path->output-path drv-path)))))
437
438 (test-assert "build-expression->derivation: same fixed-output path"
439 (let* ((builder1 '(call-with-output-file %output
440 (lambda (p)
441 (write "hello" p))))
442 (builder2 '(call-with-output-file (pk 'difference-here! %output)
443 (lambda (p)
444 (write "hello" p))))
445 (hash (sha256 (string->utf8 "hello")))
446 (input1 (build-expression->derivation %store "fixed"
447 (%current-system)
448 builder1 '()
449 #:hash hash
450 #:hash-algo 'sha256))
451 (input2 (build-expression->derivation %store "fixed"
452 (%current-system)
453 builder2 '()
454 #:hash hash
455 #:hash-algo 'sha256))
456 (succeeded? (build-derivations %store (list input1 input2))))
457 (and succeeded?
458 (not (string=? input1 input2))
459 (string=? (derivation-path->output-path input1)
460 (derivation-path->output-path input2)))))
461
462 (test-assert "build-expression->derivation with a fixed-output input"
463 (let* ((builder1 '(call-with-output-file %output
464 (lambda (p)
465 (write "hello" p))))
466 (builder2 '(call-with-output-file (pk 'difference-here! %output)
467 (lambda (p)
468 (write "hello" p))))
469 (hash (sha256 (string->utf8 "hello")))
470 (input1 (build-expression->derivation %store "fixed"
471 (%current-system)
472 builder1 '()
473 #:hash hash
474 #:hash-algo 'sha256))
475 (input2 (build-expression->derivation %store "fixed"
476 (%current-system)
477 builder2 '()
478 #:hash hash
479 #:hash-algo 'sha256))
480 (builder3 '(let ((input (assoc-ref %build-inputs "input")))
481 (call-with-output-file %output
482 (lambda (out)
483 (format #f "My input is ~a.~%" input)))))
484 (final1 (build-expression->derivation %store "final"
485 (%current-system)
486 builder3
487 `(("input" ,input1))))
488 (final2 (build-expression->derivation %store "final"
489 (%current-system)
490 builder3
491 `(("input" ,input2)))))
492 (and (string=? (derivation-path->output-path final1)
493 (derivation-path->output-path final2))
494 (build-derivations %store (list final1 final2)))))
495
496 (test-end)
497
498 \f
499 (exit (= (test-runner-fail-count (test-runner-current)) 0))
500
501 ;;; Local Variables:
502 ;;; eval: (put 'test-assert 'scheme-indent-function 1)
503 ;;; eval: (put 'guard 'scheme-indent-function 1)
504 ;;; End: