guix/tests/derivations.scm
Ludovic Courtès dd36b51bf7 scripts: Report what will be substituted.
* guix/derivations.scm (derivation-input-output-paths): New procedure.
  (derivation-prerequisites-to-build): New `use-substitutes?' keyword
  argument.  Change two return the list of substitutable paths as a
  second argument.
* guix/ui.scm (show-what-to-build): Turn `dry-run?' into a keyword
  argument.  New `use-substitutes?' keyword argument.  Use `fold2' and
  adjust to use both return values of
  `derivation-prerequisites-to-build'.  Display what will/would be
  downloaded.
* guix/scripts/build.scm (guix-build): Adjust accordingly.
* guix/scripts/package.scm (guix-package): Likewise.
* tests/derivations.scm ("derivation-prerequisites-to-build and
  substitutes"): New test.
2013-04-17 00:08:21 +02:00

596 lines
28 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-derivations)
#:use-module (guix derivations)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix base32)
#:use-module ((guix packages) #:select (package-derivation))
#:use-module ((gnu packages) #:select (search-bootstrap-binary))
#:use-module (gnu packages bootstrap)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-64)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (web uri)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match))
(define %store
(false-if-exception (open-connection)))
(when %store
;; Make sure we build everything by ourselves.
(set-build-options %store #:use-substitutes? #f)
;; By default, use %BOOTSTRAP-GUILE for the current system.
(let ((drv (package-derivation %store %bootstrap-guile)))
(%guile-for-build drv)))
(define %bash
(let ((bash (search-bootstrap-binary "bash" (%current-system))))
(and %store
(add-to-store %store "bash" #t "sha256" bash))))
(define (directory-contents dir)
"Return an alist representing the contents of DIR."
(define prefix-len (string-length dir))
(sort (file-system-fold (const #t) ; enter?
(lambda (path stat result) ; leaf
(alist-cons (string-drop path prefix-len)
(call-with-input-file path
get-bytevector-all)
result))
(lambda (path stat result) result) ; down
(lambda (path stat result) result) ; up
(lambda (path stat result) result) ; skip
(lambda (path stat errno result) result) ; error
'()
dir)
(lambda (e1 e2)
(string<? (car e1) (car e2)))))
(test-begin "derivations")
(test-assert "parse & export"
(let* ((f (search-path %load-path "tests/test.drv"))
(b1 (call-with-input-file f get-bytevector-all))
(d1 (read-derivation (open-bytevector-input-port b1)))
(b2 (call-with-bytevector-output-port (cut write-derivation d1 <>)))
(d2 (read-derivation (open-bytevector-input-port b2))))
(and (equal? b1 b2)
(equal? d1 d2))))
(test-skip (if %store 0 11))
(test-assert "add-to-store, flat"
(let* ((file (search-path %load-path "language/tree-il/spec.scm"))
(drv (add-to-store %store "flat-test" #f "sha256" file)))
(and (eq? 'regular (stat:type (stat drv)))
(valid-path? %store drv)
(equal? (call-with-input-file file get-bytevector-all)
(call-with-input-file drv get-bytevector-all)))))
(test-assert "add-to-store, recursive"
(let* ((dir (dirname (search-path %load-path "language/tree-il/spec.scm")))
(drv (add-to-store %store "dir-tree-test" #t "sha256" dir)))
(and (eq? 'directory (stat:type (stat drv)))
(valid-path? %store drv)
(equal? (directory-contents dir)
(directory-contents drv)))))
(test-assert "derivation with no inputs"
(let* ((builder (add-text-to-store %store "my-builder.sh"
"echo hello, world\n"
'()))
(drv-path (derivation %store "foo" (%current-system)
%bash `("-e" ,builder)
'(("HOME" . "/homeless")) '())))
(and (store-path? drv-path)
(valid-path? %store drv-path))))
(test-assert "build derivation with 1 source"
(let*-values (((builder)
(add-text-to-store %store "my-builder.sh"
"echo hello, world > \"$out\"\n"
'()))
((drv-path drv)
(derivation %store "foo" (%current-system)
%bash `(,builder)
'(("HOME" . "/homeless")
("zzz" . "Z!")
("AAA" . "A!"))
`((,builder))))
((succeeded?)
(build-derivations %store (list drv-path))))
(and succeeded?
(let ((path (derivation-output-path
(assoc-ref (derivation-outputs drv) "out"))))
(and (valid-path? %store path)
(string=? (call-with-input-file path read-line)
"hello, world"))))))
(test-assert "derivation with local file as input"
(let* ((builder (add-text-to-store
%store "my-builder.sh"
"(while read line ; do echo \"$line\" ; done) < $in > $out"
'()))
(input (search-path %load-path "ice-9/boot-9.scm"))
(drv-path (derivation %store "derivation-with-input-file"
(%current-system)
%bash `(,builder)
`(("in"
;; Cheat to pass the actual file
;; name to the builder.
. ,(add-to-store %store
(basename input)
#t "sha256"
input)))
`((,builder)
(,input))))) ; ← local file name
(and (build-derivations %store (list drv-path))
;; Note: we can't compare the files because the above trick alters
;; the contents.
(valid-path? %store (derivation-path->output-path drv-path)))))
(test-assert "fixed-output derivation"
(let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
"echo -n hello > $out" '()))
(hash (sha256 (string->utf8 "hello")))
(drv-path (derivation %store "fixed" (%current-system)
%bash `(,builder)
'()
`((,builder)) ; optional
#:hash hash #:hash-algo 'sha256))
(succeeded? (build-derivations %store (list drv-path))))
(and succeeded?
(let ((p (derivation-path->output-path drv-path)))
(and (equal? (string->utf8 "hello")
(call-with-input-file p get-bytevector-all))
(bytevector? (query-path-hash %store p)))))))
(test-assert "fixed-output derivation: output paths are equal"
(let* ((builder1 (add-text-to-store %store "fixed-builder1.sh"
"echo -n hello > $out" '()))
(builder2 (add-text-to-store %store "fixed-builder2.sh"
"echo hey; echo -n hello > $out" '()))
(hash (sha256 (string->utf8 "hello")))
(drv-path1 (derivation %store "fixed" (%current-system)
%bash `(,builder1)
'() `()
#:hash hash #:hash-algo 'sha256))
(drv-path2 (derivation %store "fixed" (%current-system)
%bash `(,builder2)
'() `()
#:hash hash #:hash-algo 'sha256))
(succeeded? (build-derivations %store
(list drv-path1 drv-path2))))
(and succeeded?
(equal? (derivation-path->output-path drv-path1)
(derivation-path->output-path drv-path2)))))
(test-assert "derivation with a fixed-output input"
;; A derivation D using a fixed-output derivation F doesn't has the same
;; output path when passed F or F', as long as F and F' have the same output
;; path.
(let* ((builder1 (add-text-to-store %store "fixed-builder1.sh"
"echo -n hello > $out" '()))
(builder2 (add-text-to-store %store "fixed-builder2.sh"
"echo hey; echo -n hello > $out" '()))
(hash (sha256 (string->utf8 "hello")))
(fixed1 (derivation %store "fixed" (%current-system)
%bash `(,builder1)
'() `()
#:hash hash #:hash-algo 'sha256))
(fixed2 (derivation %store "fixed" (%current-system)
%bash `(,builder2)
'() `()
#:hash hash #:hash-algo 'sha256))
(fixed-out (derivation-path->output-path fixed1))
(builder3 (add-text-to-store
%store "final-builder.sh"
;; Use Bash hackery to avoid Coreutils.
"echo $in ; (read -u 3 c; echo $c) 3< $in > $out" '()))
(final1 (derivation %store "final" (%current-system)
%bash `(,builder3)
`(("in" . ,fixed-out))
`((,builder3) (,fixed1))))
(final2 (derivation %store "final" (%current-system)
%bash `(,builder3)
`(("in" . ,fixed-out))
`((,builder3) (,fixed2))))
(succeeded? (build-derivations %store
(list final1 final2))))
(and succeeded?
(equal? (derivation-path->output-path final1)
(derivation-path->output-path final2)))))
(test-assert "multiple-output derivation"
(let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
"echo one > $out ; echo two > $second"
'()))
(drv-path (derivation %store "fixed" (%current-system)
%bash `(,builder)
'(("HOME" . "/homeless")
("zzz" . "Z!")
("AAA" . "A!"))
`((,builder))
#:outputs '("out" "second")))
(succeeded? (build-derivations %store (list drv-path))))
(and succeeded?
(let ((one (derivation-path->output-path drv-path "out"))
(two (derivation-path->output-path drv-path "second")))
(and (lset= equal?
(derivation-path->output-paths drv-path)
`(("out" . ,one) ("second" . ,two)))
(eq? 'one (call-with-input-file one read))
(eq? 'two (call-with-input-file two read)))))))
(test-assert "multiple-output derivation, non-alphabetic order"
;; Here, the outputs are not listed in alphabetic order. Yet, the store
;; path computation must reorder them first.
(let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
"echo one > $out ; echo two > $AAA"
'()))
(drv-path (derivation %store "fixed" (%current-system)
%bash `(,builder)
'()
`((,builder))
#:outputs '("out" "AAA")))
(succeeded? (build-derivations %store (list drv-path))))
(and succeeded?
(let ((one (derivation-path->output-path drv-path "out"))
(two (derivation-path->output-path drv-path "AAA")))
(and (eq? 'one (call-with-input-file one read))
(eq? 'two (call-with-input-file two read)))))))
(test-assert "user of multiple-output derivation"
;; Check whether specifying several inputs coming from the same
;; multiple-output derivation works.
(let* ((builder1 (add-text-to-store %store "my-mo-builder.sh"
"echo one > $out ; echo two > $two"
'()))
(mdrv (derivation %store "multiple-output" (%current-system)
%bash `(,builder1)
'()
`((,builder1))
#:outputs '("out" "two")))
(builder2 (add-text-to-store %store "my-mo-user-builder.sh"
"read x < $one;
read y < $two;
echo \"($x $y)\" > $out"
'()))
(udrv (derivation %store "multiple-output-user"
(%current-system)
%bash `(,builder2)
`(("one" . ,(derivation-path->output-path
mdrv "out"))
("two" . ,(derivation-path->output-path
mdrv "two")))
`((,builder2)
;; two occurrences of MDRV:
(,mdrv)
(,mdrv "two")))))
(and (build-derivations %store (list (pk 'udrv udrv)))
(let ((p (derivation-path->output-path udrv)))
(and (valid-path? %store p)
(equal? '(one two) (call-with-input-file p read)))))))
(define %coreutils
(false-if-exception
(and (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)
(or (package-derivation %store %bootstrap-coreutils&co)
(nixpkgs-derivation "coreutils")))))
(test-skip (if %coreutils 0 1))
(test-assert "build derivation with coreutils"
(let* ((builder
(add-text-to-store %store "build-with-coreutils.sh"
"echo $PATH ; mkdir --version ; mkdir $out ; touch $out/good"
'()))
(drv-path
(derivation %store "foo" (%current-system)
%bash `(,builder)
`(("PATH" .
,(string-append
(derivation-path->output-path %coreutils)
"/bin")))
`((,builder)
(,%coreutils))))
(succeeded?
(build-derivations %store (list drv-path))))
(and succeeded?
(let ((p (derivation-path->output-path drv-path)))
(and (valid-path? %store p)
(file-exists? (string-append p "/good")))))))
(test-skip (if (%guile-for-build) 0 7))
(test-assert "build-expression->derivation and derivation-prerequisites"
(let-values (((drv-path drv)
(build-expression->derivation %store "fail" (%current-system)
#f '())))
(any (match-lambda
(($ <derivation-input> path)
(string=? path (%guile-for-build))))
(derivation-prerequisites drv))))
(test-assert "build-expression->derivation without inputs"
(let* ((builder '(begin
(mkdir %output)
(call-with-output-file (string-append %output "/test")
(lambda (p)
(display '(hello guix) p)))))
(drv-path (build-expression->derivation %store "goo" (%current-system)
builder '()))
(succeeded? (build-derivations %store (list drv-path))))
(and succeeded?
(let ((p (derivation-path->output-path drv-path)))
(equal? '(hello guix)
(call-with-input-file (string-append p "/test") read))))))
(test-assert "build-expression->derivation and derivation-prerequisites-to-build"
(let-values (((drv-path drv)
(build-expression->derivation %store "fail" (%current-system)
#f '())))
;; The only direct dependency is (%guile-for-build) and it's already
;; built.
(null? (derivation-prerequisites-to-build %store drv))))
(test-assert "derivation-prerequisites-to-build when outputs already present"
(let*-values (((builder)
'(begin (mkdir %output) #t))
((input-drv-path input-drv)
(build-expression->derivation %store "input"
(%current-system)
builder '()))
((input-path)
(derivation-output-path
(assoc-ref (derivation-outputs input-drv)
"out")))
((drv-path drv)
(build-expression->derivation %store "something"
(%current-system)
builder
`(("i" ,input-drv-path))))
((output)
(derivation-output-path
(assoc-ref (derivation-outputs drv) "out"))))
;; Make sure these things are not already built.
(when (valid-path? %store input-path)
(delete-paths %store (list input-path)))
(when (valid-path? %store output)
(delete-paths %store (list output)))
(and (equal? (map derivation-input-path
(derivation-prerequisites-to-build %store drv))
(list input-drv-path))
;; Build DRV and delete its input.
(build-derivations %store (list drv-path))
(delete-paths %store (list input-path))
(not (valid-path? %store input-path))
;; Now INPUT-PATH is missing, yet it shouldn't be listed as a
;; prerequisite to build because DRV itself is already built.
(null? (derivation-prerequisites-to-build %store drv)))))
(test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
(test-assert "derivation-prerequisites-to-build and substitutes"
(let*-values (((store)
(open-connection))
((drv-path drv)
(build-expression->derivation store "prereq-subst"
(%current-system)
(random 1000) '()))
((output)
(derivation-output-path
(assoc-ref (derivation-outputs drv) "out")))
((dir)
(and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
(compose uri-path string->uri))))
;; Create fake substituter data, to be read by `substitute-binary'.
(call-with-output-file (string-append dir "/nix-cache-info")
(lambda (p)
(format p "StoreDir: ~a\nWantMassQuery: 0\n"
(%store-prefix))))
(call-with-output-file (string-append dir "/" (store-path-hash-part output)
".narinfo")
(lambda (p)
(format p "StorePath: ~a
URL: ~a
Compression: none
NarSize: 1234
References:
System: ~a
Deriver: ~a~%"
output ; StorePath
(string-append dir "/example.nar") ; URL
(%current-system) ; System
(basename drv-path)))) ; Deriver
(let-values (((build download)
(derivation-prerequisites-to-build store drv))
((build* download*)
(derivation-prerequisites-to-build store drv
#:use-substitutes? #f)))
(pk build download build* download*)
(and (null? build)
(equal? download (list output))
(null? download*)
(null? build*)))))
(test-assert "build-expression->derivation with expression returning #f"
(let* ((builder '(begin
(mkdir %output)
#f)) ; fail!
(drv-path (build-expression->derivation %store "fail" (%current-system)
builder '()))
(out-path (derivation-path->output-path drv-path)))
(guard (c ((nix-protocol-error? c)
;; Note that the output path may exist at this point, but it
;; is invalid.
(and (string-match "build .* failed"
(nix-protocol-error-message c))
(not (valid-path? %store out-path)))))
(build-derivations %store (list drv-path))
#f)))
(test-assert "build-expression->derivation with two outputs"
(let* ((builder '(begin
(call-with-output-file (assoc-ref %outputs "out")
(lambda (p)
(display '(hello) p)))
(call-with-output-file (assoc-ref %outputs "second")
(lambda (p)
(display '(world) p)))))
(drv-path (build-expression->derivation %store "double"
(%current-system)
builder '()
#:outputs '("out"
"second")))
(succeeded? (build-derivations %store (list drv-path))))
(and succeeded?
(let ((one (derivation-path->output-path drv-path))
(two (derivation-path->output-path drv-path "second")))
(and (equal? '(hello) (call-with-input-file one read))
(equal? '(world) (call-with-input-file two read)))))))
(test-skip (if %coreutils 0 1))
(test-assert "build-expression->derivation with one input"
(let* ((builder '(call-with-output-file %output
(lambda (p)
(let ((cu (assoc-ref %build-inputs "cu")))
(close 1)
(dup2 (port->fdes p) 1)
(execl (string-append cu "/bin/uname")
"uname" "-a")))))
(drv-path (build-expression->derivation %store "uname" (%current-system)
builder
`(("cu" ,%coreutils))))
(succeeded? (build-derivations %store (list drv-path))))
(and succeeded?
(let ((p (derivation-path->output-path drv-path)))
(string-contains (call-with-input-file p read-line) "GNU")))))
(test-assert "imported-files"
(let* ((files `(("x" . ,(search-path %load-path "ice-9/q.scm"))
("a/b/c" . ,(search-path %load-path
"guix/derivations.scm"))
("p/q" . ,(search-path %load-path "guix.scm"))
("p/z" . ,(search-path %load-path "guix/store.scm"))))
(drv-path (imported-files %store files)))
(and (build-derivations %store (list drv-path))
(let ((dir (derivation-path->output-path drv-path)))
(every (match-lambda
((path . source)
(equal? (call-with-input-file (string-append dir "/" path)
get-bytevector-all)
(call-with-input-file source
get-bytevector-all))))
files)))))
(test-assert "build-expression->derivation with modules"
(let* ((builder `(begin
(use-modules (guix build utils))
(let ((out (assoc-ref %outputs "out")))
(mkdir-p (string-append out "/guile/guix/nix"))
#t)))
(drv-path (build-expression->derivation %store
"test-with-modules"
(%current-system)
builder '()
#:modules
'((guix build utils)))))
(and (build-derivations %store (list drv-path))
(let* ((p (derivation-path->output-path drv-path))
(s (stat (string-append p "/guile/guix/nix"))))
(eq? (stat:type s) 'directory)))))
(test-assert "build-expression->derivation: same fixed-output path"
(let* ((builder1 '(call-with-output-file %output
(lambda (p)
(write "hello" p))))
(builder2 '(call-with-output-file (pk 'difference-here! %output)
(lambda (p)
(write "hello" p))))
(hash (sha256 (string->utf8 "hello")))
(input1 (build-expression->derivation %store "fixed"
(%current-system)
builder1 '()
#:hash hash
#:hash-algo 'sha256))
(input2 (build-expression->derivation %store "fixed"
(%current-system)
builder2 '()
#:hash hash
#:hash-algo 'sha256))
(succeeded? (build-derivations %store (list input1 input2))))
(and succeeded?
(not (string=? input1 input2))
(string=? (derivation-path->output-path input1)
(derivation-path->output-path input2)))))
(test-assert "build-expression->derivation with a fixed-output input"
(let* ((builder1 '(call-with-output-file %output
(lambda (p)
(write "hello" p))))
(builder2 '(call-with-output-file (pk 'difference-here! %output)
(lambda (p)
(write "hello" p))))
(hash (sha256 (string->utf8 "hello")))
(input1 (build-expression->derivation %store "fixed"
(%current-system)
builder1 '()
#:hash hash
#:hash-algo 'sha256))
(input2 (build-expression->derivation %store "fixed"
(%current-system)
builder2 '()
#:hash hash
#:hash-algo 'sha256))
(builder3 '(let ((input (assoc-ref %build-inputs "input")))
(call-with-output-file %output
(lambda (out)
(format #f "My input is ~a.~%" input)))))
(final1 (build-expression->derivation %store "final"
(%current-system)
builder3
`(("input" ,input1))))
(final2 (build-expression->derivation %store "final"
(%current-system)
builder3
`(("input" ,input2)))))
(and (string=? (derivation-path->output-path final1)
(derivation-path->output-path final2))
(build-derivations %store (list final1 final2)))))
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))