3 files changed, 32 insertions(+), 16 deletions(-)

M guix/store.scm
M tests/builders.scm
M tests/derivations.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."

@@ 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")
 

@@ 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)))