;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+(unsetenv "http_proxy")
(define-module (test-derivations)
#:use-module (guix derivations)
+ #:use-module (guix grafts)
#:use-module (guix store)
#:use-module (guix utils)
- #:use-module (guix hash)
+ #:use-module (gcrypt hash)
#:use-module (guix base32)
- #:use-module ((guix packages) #:select (package-derivation))
- #:use-module ((gnu packages) #:select (search-bootstrap-binary))
+ #:use-module (guix tests)
+ #:use-module (guix tests http)
+ #:use-module ((guix packages) #:select (package-derivation base32))
+ #:use-module ((guix build utils) #:select (executable-file?))
#:use-module (gnu packages bootstrap)
#:use-module ((gnu packages guile) #:select (guile-1.8))
#:use-module (srfi srfi-1)
#:use-module (ice-9 match))
(define %store
- (false-if-exception (open-connection)))
+ (open-connection-for-tests))
-(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)))
+;; Globally disable grafts because they can trigger early builds.
+(%graft? #f)
(define (bootstrap-binary name)
(let ((bin (search-bootstrap-binary name (%current-system))))
(lambda (e1 e2)
(string<? (car e1) (car e2)))))
+;; Avoid collisions with other tests.
+(%http-server-port 10500)
+
+\f
(test-begin "derivations")
(test-assert "parse & export"
(test-skip (if %store 0 12))
(test-assert "add-to-store, flat"
- (let* ((file (search-path %load-path "language/tree-il/spec.scm"))
+ ;; Use 'readlink*' in case spec.scm is a symlink, as is the case when Guile
+ ;; was installed with Stow.
+ (let* ((file (readlink*
+ (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)
(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")))
+ (let* ((dir (dirname
+ (readlink* (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)
;; 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 ((store-protocol-error? c)
+ (and (= 100 (store-protocol-error-status c))
+ (string-contains (store-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"
+ '()))
+ (build2 (add-text-to-store %store "two.sh"
+ "# Hey!\necho hello, world > \"$out\"\n"
+ '()))
+ (drv1 (derivation %store "foo"
+ %bash `(,build1)
+ #:inputs `((,%bash) (,build1))))
+ (drv2 (derivation %store "bar"
+ %bash `(,build2)
+ #:inputs `((,%bash) (,build2)))))
+ (and (build-derivations %store (list drv1 drv2))
+ (let ((file1 (derivation->output-path drv1))
+ (file2 (derivation->output-path drv2)))
+ (and (valid-path? %store file1) (valid-path? %store file2)
+ (string=? (call-with-input-file file1 get-string-all)
+ "hello, world\n")
+ (= (stat:ino (lstat file1))
+ (stat:ino (lstat file2))))))))
+
+(test-equal "built-in-builders"
+ '("download")
+ (built-in-builders %store))
+
+(test-assert "unknown built-in builder"
+ (let ((drv (derivation %store "ohoh" "builtin:does-not-exist" '())))
+ (guard (c ((store-protocol-error? c)
+ (string-contains (store-protocol-error-message c) "failed")))
+ (build-derivations %store (list drv))
+ #f)))
+
+(unless (http-server-can-listen?)
+ (test-skip 1))
+(test-assert "'download' built-in builder"
+ (let ((text (random-text)))
+ (with-http-server 200 text
+ (let* ((drv (derivation %store "world"
+ "builtin:download" '()
+ #:env-vars `(("url"
+ . ,(object->string (%local-url))))
+ #:hash-algo 'sha256
+ #:hash (sha256 (string->utf8 text)))))
+ (and (build-derivations %store (list drv))
+ (string=? (call-with-input-file (derivation->output-path drv)
+ get-string-all)
+ text))))))
+
+(unless (http-server-can-listen?)
+ (test-skip 1))
+(test-assert "'download' built-in builder, invalid hash"
+ (with-http-server 200 "hello, world!"
+ (let* ((drv (derivation %store "world"
+ "builtin:download" '()
+ #:env-vars `(("url"
+ . ,(object->string (%local-url))))
+ #:hash-algo 'sha256
+ #:hash (sha256 (random-bytevector 100))))) ;wrong
+ (guard (c ((store-protocol-error? c)
+ (string-contains (store-protocol-error-message c) "failed")))
+ (build-derivations %store (list drv))
+ #f))))
+
+(unless (http-server-can-listen?)
+ (test-skip 1))
+(test-assert "'download' built-in builder, not found"
+ (with-http-server 404 "not found"
+ (let* ((drv (derivation %store "will-never-be-found"
+ "builtin:download" '()
+ #:env-vars `(("url"
+ . ,(object->string (%local-url))))
+ #:hash-algo 'sha256
+ #:hash (sha256 (random-bytevector 100)))))
+ (guard (c ((store-protocol-error? c)
+ (string-contains (store-protocol-error-message (pk c)) "failed")))
+ (build-derivations %store (list drv))
+ #f))))
+
+(test-assert "'download' built-in builder, not fixed-output"
+ (let* ((source (add-text-to-store %store "hello" "hi!"))
+ (url (string-append "file://" source))
+ (drv (derivation %store "world"
+ "builtin:download" '()
+ #:env-vars `(("url" . ,(object->string url))))))
+ (guard (c ((store-protocol-error? c)
+ (string-contains (store-protocol-error-message c) "failed")))
+ (build-derivations %store (list drv))
+ #f)))
+
+(unless (http-server-can-listen?)
+ (test-skip 1))
+(test-assert "'download' built-in builder, check mode"
+ ;; Make sure rebuilding the 'builtin:download' derivation in check mode
+ ;; works. See <http://bugs.gnu.org/25089>.
+ (let* ((text (random-text))
+ (drv (derivation %store "world"
+ "builtin:download" '()
+ #:env-vars `(("url"
+ . ,(object->string (%local-url))))
+ #:hash-algo 'sha256
+ #:hash (sha256 (string->utf8 text)))))
+ (and (with-http-server 200 text
+ (build-derivations %store (list drv)))
+ (with-http-server 200 text
+ (build-derivations %store (list drv)
+ (build-mode check)))
+ (string=? (call-with-input-file (derivation->output-path drv)
+ get-string-all)
+ text))))
+
+(test-equal "derivation-name"
+ "foo-0.0"
+ (let ((drv (derivation %store "foo-0.0" %bash '())))
+ (derivation-name drv)))
+
+(test-equal "derivation-output-names"
+ '(("out") ("bar" "chbouib"))
+ (let ((drv1 (derivation %store "foo-0.0" %bash '()))
+ (drv2 (derivation %store "foo-0.0" %bash '()
+ #:outputs '("bar" "chbouib"))))
+ (list (derivation-output-names drv1)
+ (derivation-output-names drv2))))
+
+(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" '()))
+ (hash (sha256 (string->utf8 "hello")))
+ (drv (derivation %store "fixed"
+ %bash `(,builder)
+ #:inputs `((,builder))
+ #:hash hash #:hash-algo 'sha256)))
+ (fixed-output-derivation? drv)))
+
(test-assert "fixed-output derivation"
(let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
"echo -n hello > $out" '()))
(equal? (derivation->output-path drv1)
(derivation->output-path drv2)))))
+(test-assert "fixed-output derivation, recursive"
+ (let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
+ "echo -n hello > $out" '()))
+ (hash (sha256 (string->utf8 "hello")))
+ (drv (derivation %store "fixed-rec"
+ %bash `(,builder)
+ #:inputs `((,builder))
+ #:hash (base32 "0sg9f58l1jj88w6pdrfdpj5x9b1zrwszk84j81zvby36q9whhhqa")
+ #:hash-algo 'sha256
+ #:recursive? #t))
+ (succeeded? (build-derivations %store (list drv))))
+ (and succeeded?
+ (let ((p (derivation->output-path drv)))
+ (and (equal? (string->utf8 "hello")
+ (call-with-input-file p get-bytevector-all))
+ (bytevector? (query-path-hash %store p)))))))
+
(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
(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"
((p2 . _)
(string<? p1 p2)))))))))))))))
+(test-assert "derivation #:allowed-references, ok"
+ (let ((drv (derivation %store "allowed" %bash
+ '("-c" "echo hello > $out")
+ #:inputs `((,%bash))
+ #:allowed-references '())))
+ (build-derivations %store (list drv))))
+
+(test-assert "derivation #:allowed-references, not allowed"
+ (let* ((txt (add-text-to-store %store "foo" "Hello, world."))
+ (drv (derivation %store "disallowed" %bash
+ `("-c" ,(string-append "echo " txt "> $out"))
+ #:inputs `((,%bash) (,txt))
+ #:allowed-references '())))
+ (guard (c ((store-protocol-error? c)
+ ;; There's no specific error message to check for.
+ #t))
+ (build-derivations %store (list drv))
+ #f)))
+
+(test-assert "derivation #:allowed-references, self allowed"
+ (let ((drv (derivation %store "allowed" %bash
+ '("-c" "echo $out > $out")
+ #:inputs `((,%bash))
+ #:allowed-references '("out"))))
+ (build-derivations %store (list drv))))
+
+(test-assert "derivation #:allowed-references, self not allowed"
+ (let ((drv (derivation %store "disallowed" %bash
+ `("-c" ,"echo $out > $out")
+ #:inputs `((,%bash))
+ #:allowed-references '())))
+ (guard (c ((store-protocol-error? c)
+ ;; There's no specific error message to check for.
+ #t))
+ (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 ((store-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 $GUIX_STATE_DIRECTORY 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 "GUIX_STATE_DIRECTORY")
+ (let* ((value (getenv "GUIX_STATE_DIRECTORY"))
+ (drv (derivation %store "leaked-env-vars" %bash
+ '("-c" "echo -n $GUIX_STATE_DIRECTORY > $out")
+ #:hash (sha256 (string->utf8 value))
+ #:hash-algo 'sha256
+ #:inputs `((,%bash))
+ #:leaked-env-vars '("GUIX_STATE_DIRECTORY"))))
+ (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-equal "build-expression->derivation and builder encoding"
+ '("UTF-8" #t)
+ (let* ((exp '(λ (α) (+ α 1)))
+ (drv (build-expression->derivation %store "foo" exp)))
+ (match (derivation-builder-arguments drv)
+ ((... builder)
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (call-with-input-file builder
+ (lambda (port)
+ (list (port-encoding port)
+ (->bool
+ (string-contains (get-string-all port)
+ "(λ (α) (+ α 1))"))))))))))
+
(test-assert "build-expression->derivation and derivation-prerequisites"
- (let ((drv (build-expression->derivation %store "fail" (%current-system)
- #f '())))
+ (let ((drv (build-expression->derivation %store "fail" #f)))
(any (match-lambda
(($ <derivation-input> path)
(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)
(call-with-output-file (string-append %output "/test")
(lambda (p)
(display '(hello guix) p)))))
- (drv (build-expression->derivation %store "goo" (%current-system)
- builder '()))
+ (drv (build-expression->derivation %store "goo" builder))
(succeeded? (build-derivations %store (list drv))))
(and succeeded?
(let ((p (derivation->output-path drv)))
(set-build-options s #:max-silent-time 1)
s))
(builder '(begin (sleep 100) (mkdir %output) #t))
- (drv (build-expression->derivation store "silent"
- (%current-system)
- builder '()))
+ (drv (build-expression->derivation store "silent" builder))
+ (out-path (derivation->output-path drv)))
+ (guard (c ((store-protocol-error? c)
+ (and (string-contains (store-protocol-error-message c)
+ "failed")
+ (not (valid-path? store out-path)))))
+ (build-derivations store (list drv))
+ #f)))
+
+(test-assert "build-expression->derivation and timeout"
+ (let* ((store (let ((s (open-connection)))
+ (set-build-options s #:timeout 1)
+ s))
+ (builder '(begin (sleep 100) (mkdir %output) #t))
+ (drv (build-expression->derivation store "slow" builder))
(out-path (derivation->output-path drv)))
- (guard (c ((nix-protocol-error? c)
- (and (string-contains (nix-protocol-error-message c)
+ (guard (c ((store-protocol-error? c)
+ (and (string-contains (store-protocol-error-message c)
"failed")
(not (valid-path? store out-path)))))
(build-derivations store (list drv))
#f)))
+(test-assert "build-derivations with specific output"
+ (with-store store
+ (let* ((content (random-text)) ;contents of the output
+ (drv (build-expression->derivation
+ store "substitute-me"
+ `(begin ,content (exit 1)) ;would fail
+ #:outputs '("out" "one" "two")
+ #:guile-for-build
+ (package-derivation store %bootstrap-guile)))
+ (out (derivation->output-path drv)))
+ (with-derivation-substitute drv content
+ (set-build-options store #:use-substitutes? #t
+ #:substitute-urls (%test-substitute-urls))
+ (and (has-substitutes? store out)
+
+ ;; Ask for nothing but the "out" output of DRV.
+ (build-derivations store `((,drv . "out")))
+
+ (valid-path? store out)
+ (equal? (pk 'x content) (pk 'y (call-with-input-file out get-string-all)))
+ )))))
+
(test-assert "build-expression->derivation and derivation-prerequisites-to-build"
- (let ((drv (build-expression->derivation %store "fail" (%current-system)
- #f '())))
+ (let ((drv (build-expression->derivation %store "fail" #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* ((builder '(begin (mkdir %output) #t))
- (input-drv (build-expression->derivation %store "input"
- (%current-system)
- builder '()))
+ (input-drv (build-expression->derivation %store "input" builder))
(input-path (derivation-output-path
(assoc-ref (derivation-outputs input-drv)
"out")))
- (drv (build-expression->derivation %store "something"
- (%current-system) builder
+ (drv (build-expression->derivation %store "something" builder
+ #:inputs
`(("i" ,input-drv))))
(output (derivation->output-path drv)))
;; Make sure these things are not already built.
;; 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* ((store (open-connection))
(drv (build-expression->derivation store "prereq-subst"
- (%current-system)
- (random 1000) '()))
- (output (derivation->output-path drv))
- (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
- (derivation-file-name drv))))) ; 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*)))))
+ (random 1000)))
+ (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))
+ ((build* download*)
+ (derivation-prerequisites-to-build store drv
+ #:substitutable-info
+ (const #f))))
+ (and (null? build)
+ (equal? (map substitutable-path download) (list output))
+ (null? download*)
+ (null? build*))))))
+
+(test-assert "derivation-prerequisites-to-build and substitutes, non-substitutable build"
+ (let* ((store (open-connection))
+ (drv (build-expression->derivation store "prereq-no-subst"
+ (random 1000)
+ #:substitutable? #f))
+ (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)))
+ ;; Despite being available as a substitute, DRV will be built locally
+ ;; 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
+ (((= substitutable-path 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 "substitution-oracle and #:substitute? #f"
+ (with-store store
+ (let* ((dep (build-expression->derivation store "dep"
+ `(begin ,(random-text)
+ (mkdir %output))))
+ (drv (build-expression->derivation store "not-subst"
+ `(begin ,(random-text)
+ (mkdir %output))
+ #:substitutable? #f
+ #:inputs `(("dep" ,dep))))
+ (query #f))
+ (define (record-substitutable-path-query store paths)
+ (when query
+ (error "already called!" query))
+ (set! query paths)
+ '())
+
+ (mock ((guix store) substitutable-path-info
+ record-substitutable-path-query)
+
+ (let ((pred (substitution-oracle store (list drv))))
+ (pred (derivation->output-path drv))))
+
+ ;; Make sure the oracle didn't try to get substitute info for DRV since
+ ;; DRV is mark as non-substitutable. Assume that GUILE-FOR-BUILD is
+ ;; already in store and thus not part of QUERY.
+ (equal? (pk 'query query)
+ (list (derivation->output-path dep))))))
(test-assert "build-expression->derivation with expression returning #f"
(let* ((builder '(begin
(mkdir %output)
#f)) ; fail!
- (drv (build-expression->derivation %store "fail" (%current-system)
- builder '()))
+ (drv (build-expression->derivation %store "fail" builder))
(out-path (derivation->output-path drv)))
- (guard (c ((nix-protocol-error? c)
+ (guard (c ((store-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))
+ (store-protocol-error-message c))
(not (valid-path? %store out-path)))))
(build-derivations %store (list drv))
#f)))
(call-with-output-file (assoc-ref %outputs "second")
(lambda (p)
(display '(world) p)))))
- (drv (build-expression->derivation %store "double"
- (%current-system)
- builder '()
+ (drv (build-expression->derivation %store "double" builder
#:outputs '("out"
"second")))
(succeeded? (build-derivations %store (list drv))))
(dup2 (port->fdes p) 1)
(execl (string-append cu "/bin/uname")
"uname" "-a")))))
- (drv (build-expression->derivation %store "uname" (%current-system)
- builder
+ (drv (build-expression->derivation %store "uname" builder
+ #:inputs
`(("cu" ,%coreutils))))
(succeeded? (build-derivations %store (list drv))))
(and succeeded?
(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))
(mkdir-p (string-append out "/guile/guix/nix"))
#t)))
(drv (build-expression->derivation %store "test-with-modules"
- (%current-system)
- builder '()
+ builder
#:modules
'((guix build utils)))))
(and (build-derivations %store (list drv))
(lambda (p)
(write "hello" p))))
(hash (sha256 (string->utf8 "hello")))
- (input1 (build-expression->derivation %store "fixed"
- (%current-system)
- builder1 '()
+ (input1 (build-expression->derivation %store "fixed" builder1
#:hash hash
#:hash-algo 'sha256))
- (input2 (build-expression->derivation %store "fixed"
- (%current-system)
- builder2 '()
+ (input2 (build-expression->derivation %store "fixed" builder2
#:hash hash
#:hash-algo 'sha256))
(succeeded? (build-derivations %store (list input1 input2))))
(lambda (p)
(write "hello" p))))
(hash (sha256 (string->utf8 "hello")))
- (input1 (build-expression->derivation %store "fixed"
- (%current-system)
- builder1 '()
+ (input1 (build-expression->derivation %store "fixed" builder1
#:hash hash
#:hash-algo 'sha256))
- (input2 (build-expression->derivation %store "fixed"
- (%current-system)
- builder2 '()
+ (input2 (build-expression->derivation %store "fixed" 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
+ (final1 (build-expression->derivation %store "final" builder3
+ #:inputs
`(("input" ,input1))))
- (final2 (build-expression->derivation %store "final"
- (%current-system)
- builder3
+ (final2 (build-expression->derivation %store "final" builder3
+ #:inputs
`(("input" ,input2)))))
(and (string=? (derivation->output-path final1)
(derivation->output-path final2))
(derivation-file-name final1)))
(build-derivations %store (list final1 final2)))))
+(test-assert "build-expression->derivation produces recursive fixed-output"
+ (let* ((builder '(begin
+ (use-modules (srfi srfi-26))
+ (mkdir %output)
+ (chdir %output)
+ (call-with-output-file "exe"
+ (cut display "executable" <>))
+ (chmod "exe" #o777)
+ (symlink "exe" "symlink")
+ (mkdir "subdir")))
+ (drv (build-expression->derivation %store "fixed-rec" builder
+ #:hash-algo 'sha256
+ #:hash (base32
+ "10k1lw41wyrjf9mxydi0is5nkpynlsvgslinics4ppir13g7d74p")
+ #:recursive? #t)))
+ (and (build-derivations %store (list drv))
+ (let* ((dir (derivation->output-path drv))
+ (exe (string-append dir "/exe"))
+ (link (string-append dir "/symlink"))
+ (subdir (string-append dir "/subdir")))
+ (and (executable-file? exe)
+ (string=? "executable"
+ (call-with-input-file exe get-string-all))
+ (string=? "exe" (readlink link))
+ (file-is-directory? subdir))))))
+
+(test-assert "build-expression->derivation uses recursive fixed-output"
+ (let* ((builder '(call-with-output-file %output
+ (lambda (port)
+ (display "hello" port))))
+ (fixed (build-expression->derivation %store "small-fixed-rec"
+ builder
+ #:hash-algo 'sha256
+ #:hash (base32
+ "0sg9f58l1jj88w6pdrfdpj5x9b1zrwszk84j81zvby36q9whhhqa")
+ #:recursive? #t))
+ (in (derivation->output-path fixed))
+ (builder `(begin
+ (mkdir %output)
+ (chdir %output)
+ (symlink ,in "symlink")))
+ (drv (build-expression->derivation %store "fixed-rec-user"
+ builder
+ #:inputs `(("fixed" ,fixed)))))
+ (and (build-derivations %store (list drv))
+ (let ((out (derivation->output-path drv)))
+ (string=? (readlink (string-append out "/symlink")) in)))))
+
(test-assert "build-expression->derivation with #:references-graphs"
(let* ((input (add-text-to-store %store "foo" "hello"
(list %bash %mkdir)))
(builder '(copy-file "input" %output))
(drv (build-expression->derivation %store "references-graphs"
- (%current-system)
- builder '()
+ builder
#:references-graphs
`(("input" . ,input))))
(out (derivation->output-path drv)))
((p2 . _)
(string<? p1 p2)))))))))))))
+(test-equal "derivation-properties"
+ (list '() '((type . test)))
+ (let ((drv1 (build-expression->derivation %store "bar"
+ '(mkdir %output)))
+ (drv2 (build-expression->derivation %store "foo"
+ '(mkdir %output)
+ #:properties '((type . test)))))
+ (list (derivation-properties drv1)
+ (derivation-properties drv2))))
(test-equal "map-derivation"
"hello"
(let* ((joke (package-derivation %store guile-1.8))
(good (package-derivation %store %bootstrap-guile))
(drv1 (build-expression->derivation %store "original-drv1"
- (%current-system)
#f ; systematically fail
- '()
#:guile-for-build joke))
(drv2 (build-expression->derivation %store "original-drv2"
- (%current-system)
'(call-with-output-file %output
(lambda (p)
- (display "hello" p)))
- '()))
+ (display "hello" p)))))
(drv3 (build-expression->derivation %store "drv-to-remap"
- (%current-system)
'(let ((in (assoc-ref
%build-inputs "in")))
(copy-file in %output))
- `(("in" ,drv1))
+ #:inputs `(("in" ,drv1))
#:guile-for-build joke))
(drv4 (map-derivation %store drv3 `((,drv1 . ,drv2)
(,joke . ,good))))
(test-end)
-\f
-(exit (= (test-runner-fail-count (test-runner-current)) 0))
+;; Local Variables:
+;; eval: (put 'with-http-server 'scheme-indent-function 2)
+;; End: