;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (test-derivations)
#:use-module (guix derivations)
+ #:use-module (guix grafts)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix hash)
(define %store
(open-connection-for-tests))
+;; Globally disable grafts because they can trigger early builds.
+(%graft? #f)
+
(define (bootstrap-binary name)
(let ((bin (search-bootstrap-binary name (%current-system))))
(and %store
(lambda (e1 e2)
(string<? (car e1) (car e2)))))
+\f
(test-begin "derivations")
(test-assert "parse & export"
;; the contents.
(valid-path? %store (derivation->output-path drv)))))
+(test-assert "derivation fails but keep going"
+ ;; In keep-going mode, 'build-derivations' should fail because of D1, but it
+ ;; must return only after D2 has succeeded.
+ (with-store store
+ (let* ((d1 (derivation %store "fails"
+ %bash `("-c" "false")
+ #:inputs `((,%bash))))
+ (d2 (build-expression->derivation %store "sleep-then-succeed"
+ `(begin
+ ,(random-text)
+ ;; XXX: Hopefully that's long
+ ;; enough that D1 has already
+ ;; failed.
+ (sleep 2)
+ (mkdir %output)))))
+ (set-build-options %store
+ #:use-substitutes? #f
+ #:keep-going? #t)
+ (guard (c ((nix-protocol-error? c)
+ (and (= 100 (nix-protocol-error-status c))
+ (string-contains (nix-protocol-error-message c)
+ (derivation-file-name d1))
+ (not (valid-path? %store (derivation->output-path d1)))
+ (valid-path? %store (derivation->output-path d2)))))
+ (build-derivations %store (list d1 d2))
+ #f))))
+
(test-assert "identical files are deduplicated"
(let* ((build1 (add-text-to-store %store "one.sh"
"echo hello, world > \"$out\"\n"
(test-assert "offloadable-derivation?"
(and (offloadable-derivation? (derivation %store "foo" %bash '()))
+ (offloadable-derivation? ;see <http://bugs.gnu.org/18747>
+ (derivation %store "foo" %bash '()
+ #:substitutable? #f))
(not (offloadable-derivation?
(derivation %store "foo" %bash '()
#:local-build? #t)))))
+(test-assert "substitutable-derivation?"
+ (and (substitutable-derivation? (derivation %store "foo" %bash '()))
+ (substitutable-derivation? ;see <http://bugs.gnu.org/18747>
+ (derivation %store "foo" %bash '()
+ #:local-build? #t))
+ (not (substitutable-derivation?
+ (derivation %store "foo" %bash '()
+ #:substitutable? #f)))))
+
(test-assert "fixed-output-derivation?"
(let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
"echo -n hello > $out" '()))
(and (eq? 'one (call-with-input-file one read))
(eq? 'two (call-with-input-file two read)))))))
+(test-assert "read-derivation vs. derivation"
+ ;; Make sure 'derivation' and 'read-derivation' return objects that are
+ ;; identical.
+ (let* ((sources (unfold (cut >= <> 10)
+ (lambda (n)
+ (add-text-to-store %store
+ (format #f "input~a" n)
+ (random-text)))
+ 1+
+ 0))
+ (inputs (map (lambda (file)
+ (derivation %store "derivation-input"
+ %bash '()
+ #:inputs `((,%bash) (,file))))
+ sources))
+ (builder (add-text-to-store %store "builder.sh"
+ "echo one > $one ; echo two > $two"
+ '()))
+ (drv (derivation %store "derivation"
+ %bash `(,builder)
+ #:inputs `((,%bash) (,builder)
+ ,@(map list (append sources inputs)))
+ #:outputs '("two" "one")))
+ (drv* (call-with-input-file (derivation-file-name drv)
+ read-derivation)))
+ (equal? drv* drv)))
+
(test-assert "multiple-output derivation, derivation-path->output-path"
(let* ((builder (add-text-to-store %store "builder.sh"
"echo one > $out ; echo two > $second"
(build-derivations %store (list drv))
#f)))
+(test-assert "derivation #:disallowed-references, ok"
+ (let ((drv (derivation %store "disallowed" %bash
+ '("-c" "echo hello > $out")
+ #:inputs `((,%bash))
+ #:disallowed-references '("out"))))
+ (build-derivations %store (list drv))))
+
+(test-assert "derivation #:disallowed-references, not ok"
+ (let* ((txt (add-text-to-store %store "foo" "Hello, world."))
+ (drv (derivation %store "disdisallowed" %bash
+ `("-c" ,(string-append "echo " txt "> $out"))
+ #:inputs `((,%bash) (,txt))
+ #:disallowed-references (list txt))))
+ (guard (c ((nix-protocol-error? c)
+ ;; There's no specific error message to check for.
+ #t))
+ (build-derivations %store (list drv))
+ #f)))
+
+;; Here we should get the value of $NIX_STATE_DIR that the daemon sees, which
+;; is a unique value for each test process; this value is the same as the one
+;; we see in the process executing this file since it is set by 'test-env'.
+(test-equal "derivation #:leaked-env-vars"
+ (getenv "NIX_STATE_DIR")
+ (let* ((value (getenv "NIX_STATE_DIR"))
+ (drv (derivation %store "leaked-env-vars" %bash
+ '("-c" "echo -n $NIX_STATE_DIR > $out")
+ #:hash (sha256 (string->utf8 value))
+ #:hash-algo 'sha256
+ #:inputs `((,%bash))
+ #:leaked-env-vars '("NIX_STATE_DIR"))))
+ (and (build-derivations %store (list drv))
+ (call-with-input-file (derivation->output-path drv)
+ get-string-all))))
+
\f
(define %coreutils
(false-if-exception
- (and (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)
- (or (package-derivation %store %bootstrap-coreutils&co)
- (nixpkgs-derivation "coreutils")))))
+ (and (network-reachable?)
+ (package-derivation %store %bootstrap-coreutils&co))))
(test-skip (if %coreutils 0 1))
(test-skip (if (%guile-for-build) 0 8))
+(test-equal "build-expression->derivation and invalid module name"
+ '(file-search-error "guix/module/that/does/not/exist.scm")
+ (guard (c ((file-search-error? c)
+ (list 'file-search-error
+ (file-search-error-file-name c))))
+ (build-expression->derivation %store "foo" #t
+ #:modules '((guix module that
+ does not exist)))))
+
(test-assert "build-expression->derivation and derivation-prerequisites"
(let ((drv (build-expression->derivation %store "fail" #f)))
(any (match-lambda
(string=? path (derivation-file-name (%guile-for-build)))))
(derivation-prerequisites drv))))
+(test-assert "derivation-prerequisites and valid-derivation-input?"
+ (let* ((a (build-expression->derivation %store "a" '(mkdir %output)))
+ (b (build-expression->derivation %store "b" `(list ,(random-text))))
+ (c (build-expression->derivation %store "c" `(mkdir %output)
+ #:inputs `(("a" ,a) ("b" ,b)))))
+ ;; Make sure both A and %BOOTSTRAP-GUILE are built (the latter could have
+ ;; be removed by tests/guix-gc.sh.)
+ (build-derivations %store
+ (list a (package-derivation %store %bootstrap-guile)))
+
+ (match (derivation-prerequisites c
+ (cut valid-derivation-input? %store
+ <>))
+ ((($ <derivation-input> file ("out")))
+ (string=? file (derivation-file-name b)))
+ (x
+ (pk 'fail x #f)))))
+
(test-assert "build-expression->derivation without inputs"
(let* ((builder '(begin
(mkdir %output)
(output (derivation->output-path drv)))
;; Make sure substitutes are usable.
- (set-build-options store #:use-substitutes? #t)
+ (set-build-options store #:use-substitutes? #t
+ #:substitute-urls (%test-substitute-urls))
(with-derivation-narinfo drv
(let-values (((build download)
(null? download*)
(null? build*))))))
-(test-assert "derivation-prerequisites-to-build and substitutes, local build"
+(test-assert "derivation-prerequisites-to-build and substitutes, non-substitutable build"
(let* ((store (open-connection))
- (drv (build-expression->derivation store "prereq-subst-local"
+ (drv (build-expression->derivation store "prereq-no-subst"
(random 1000)
- ;; XXX: Adjust once
- ;; <http://bugs.gnu.org/18747>
- ;; is fixed.
- #:local-build? #t))
+ #:substitutable? #f))
(output (derivation->output-path drv)))
;; Make sure substitutes are usable.
- (set-build-options store #:use-substitutes? #t)
+ (set-build-options store #:use-substitutes? #t
+ #:substitute-urls (%test-substitute-urls))
(with-derivation-narinfo drv
(let-values (((build download)
(derivation-prerequisites-to-build store drv)))
;; Despite being available as a substitute, DRV will be built locally
- ;; due to #:local-build?.
+ ;; due to #:substitutable? #f.
(and (null? download)
(match build
(((? derivation-input? input))
(string=? (derivation-input-path input)
(derivation-file-name drv)))))))))
+(test-assert "derivation-prerequisites-to-build and substitutes, local build"
+ (with-store store
+ (let* ((drv (build-expression->derivation store "prereq-subst-local"
+ (random 1000)
+ #:local-build? #t))
+ (output (derivation->output-path drv)))
+
+ ;; Make sure substitutes are usable.
+ (set-build-options store #:use-substitutes? #t
+ #:substitute-urls (%test-substitute-urls))
+
+ (with-derivation-narinfo drv
+ (let-values (((build download)
+ (derivation-prerequisites-to-build store drv)))
+ ;; #:local-build? is *not* synonymous with #:substitutable?, so we
+ ;; must be able to substitute DRV's output.
+ ;; See <http://bugs.gnu.org/18747>.
+ (and (null? build)
+ (match download
+ (((? string? item))
+ (string=? item (derivation->output-path drv))))))))))
+
+(test-assert "derivation-prerequisites-to-build in 'check' mode"
+ (with-store store
+ (let* ((dep (build-expression->derivation store "dep"
+ `(begin ,(random-text)
+ (mkdir %output))))
+ (drv (build-expression->derivation store "to-check"
+ '(mkdir %output)
+ #:inputs `(("dep" ,dep)))))
+ (build-derivations store (list drv))
+ (delete-paths store (list (derivation->output-path dep)))
+
+ ;; In 'check' mode, DEP must be rebuilt.
+ (and (null? (derivation-prerequisites-to-build store drv))
+ (match (derivation-prerequisites-to-build store drv
+ #:mode (build-mode
+ check))
+ ((input)
+ (string=? (derivation-input-path input)
+ (derivation-file-name dep))))))))
+
(test-assert "build-expression->derivation with expression returning #f"
(let* ((builder '(begin
(mkdir %output)
(let ((p (derivation->output-path drv)))
(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 (imported-files %store files)))
- (and (build-derivations %store (list drv))
- (let ((dir (derivation->output-path drv)))
- (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))
((p2 . _)
(string<? p1 p2)))))))))))))
-
-(test-assert "graft-derivation"
- (let* ((build `(begin
- (mkdir %output)
- (chdir %output)
- (symlink %output "self")
- (call-with-output-file "text"
- (lambda (output)
- (format output "foo/~a/bar" ,%mkdir)))
- (symlink ,%bash "sh")))
- (orig (build-expression->derivation %store "graft" build
- #:inputs `(("a" ,%bash)
- ("b" ,%mkdir))))
- (one (add-text-to-store %store "bash" "fake bash"))
- (two (build-expression->derivation %store "mkdir"
- '(call-with-output-file %output
- (lambda (port)
- (display "fake mkdir" port)))))
- (graft (graft-derivation %store "graft" orig
- (list (graft
- (origin %bash)
- (replacement one))
- (graft
- (origin %mkdir)
- (replacement two))))))
- (and (build-derivations %store (list graft))
- (let ((two (derivation->output-path two))
- (graft (derivation->output-path graft)))
- (and (string=? (format #f "foo/~a/bar" two)
- (call-with-input-file (string-append graft "/text")
- get-string-all))
- (string=? (readlink (string-append graft "/sh")) one)
- (string=? (readlink (string-append graft "/self")) graft))))))
-
(test-equal "map-derivation"
"hello"
(let* ((joke (package-derivation %store guile-1.8))
(call-with-input-file out get-string-all))))
(test-end)
-
-\f
-(exit (= (test-runner-fail-count (test-runner-current)) 0))
-
-;; Local Variables:
-;; eval: (put 'with-derivation-narinfo 'scheme-indent-function 1)
-;; End: