diff options
| -rw-r--r-- | guix/store.scm | 5 | ||||
| -rw-r--r-- | tests/builders.scm | 13 | ||||
| -rw-r--r-- | tests/derivations.scm | 30 |
3 files changed, 32 insertions, 16 deletions
diff --git a/guix/store.scm b/guix/store.scm index 1ecb2cc359..b525994672 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -42,6 +42,7 @@ open-connection set-build-options + valid-path? add-text-to-store add-to-store build-derivations @@ -374,6 +375,10 @@ again until #t is returned or an error is raised." (or done? (loop (process-stderr server)))) (read-arg return s)))))) +(define-operation (valid-path? (string path)) + "Return #t when PATH is a valid store path." + boolean) + (define-operation (add-text-to-store (string name) (string text) (string-list references)) "Add TEXT under file NAME in the store." diff --git a/tests/builders.scm b/tests/builders.scm index 17bae2c754..762944ba73 100644 --- a/tests/builders.scm +++ b/tests/builders.scm @@ -38,9 +38,11 @@ (let* ((url "http://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz") (hash (nix-base32-string->bytevector "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6")) - (drv-path (http-fetch %store url 'sha256 hash))) + (drv-path (http-fetch %store url 'sha256 hash)) + (out-path (derivation-path->output-path drv-path))) (and (build-derivations %store (list drv-path)) - (file-exists? (derivation-path->output-path drv-path))))) + (file-exists? out-path) + (valid-path? %store out-path)))) (test-assert "gnu-build-system" (and (build-system? gnu-build-system) @@ -52,10 +54,11 @@ "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6")) (tarball (http-fetch %store url 'sha256 hash)) (build (gnu-build %store "hello-2.8" tarball - `(("gawk" ,(nixpkgs-derivation "gawk")))))) + `(("gawk" ,(nixpkgs-derivation "gawk"))))) + (out (derivation-path->output-path build))) (and (build-derivations %store (list (pk 'hello-drv build))) - (file-exists? (string-append (derivation-path->output-path build) - "/bin/hello"))))) + (valid-path? %store out) + (file-exists? (string-append out "/bin/hello"))))) (test-end "builders") diff --git a/tests/derivations.scm b/tests/derivations.scm index 1e9a136d04..3fc7097a87 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -71,6 +71,7 @@ (let* ((file (search-path %load-path "language/tree-il/spec.scm")) (drv (add-to-store %store "flat-test" #t #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))))) @@ -78,15 +79,18 @@ (let* ((dir (dirname (search-path %load-path "language/tree-il/spec.scm"))) (drv (add-to-store %store "dir-tree-test" #t #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" - "#!/bin/sh\necho hello, world\n" - '()))) - (store-path? (derivation %store "foo" (%current-system) builder - '() '(("HOME" . "/homeless")) '())))) + (let* ((builder (add-text-to-store %store "my-builder.sh" + "#!/bin/sh\necho hello, world\n" + '())) + (drv-path (derivation %store "foo" (%current-system) builder + '() '(("HOME" . "/homeless")) '()))) + (and (store-path? drv-path) + (valid-path? %store drv-path)))) (test-assert "build derivation with 1 source" (let*-values (((builder) @@ -105,8 +109,9 @@ (and succeeded? (let ((path (derivation-output-path (assoc-ref (derivation-outputs drv) "out")))) - (string=? (call-with-input-file path read-line) - "hello, world"))))) + (and (valid-path? %store path) + (string=? (call-with-input-file path read-line) + "hello, world")))))) (test-assert "fixed-output derivation" (let* ((builder (add-text-to-store %store "my-fixed-builder.sh" @@ -164,7 +169,8 @@ (build-derivations %store (list drv-path)))) (and succeeded? (let ((p (derivation-path->output-path drv-path))) - (file-exists? (string-append p "/good")))))) + (and (valid-path? %store p) + (file-exists? (string-append p "/good"))))))) (test-skip (if (%guile-for-build) 0 4)) @@ -187,12 +193,14 @@ (mkdir %output) #f)) ; fail! (drv-path (build-expression->derivation %store "fail" (%current-system) - builder '()))) + 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. - (not (not (string-match "build .* failed" - (nix-protocol-error-message c)))))) + (and (string-match "build .* failed" + (nix-protocol-error-message c)) + (not (valid-path? %store out-path))))) (build-derivations %store (list drv-path)) #f))) |