04/08: tests: Add 'with-derivation-substitute' and use it.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit e6c8839c180b88a9ef9e68af8acc3148099e286b
Author: Ludovic Courtès <address@hidden>
Date:   Mon Feb 2 11:24:24 2015 +0100

    tests: Add 'with-derivation-substitute' and use it.
    
    * guix/tests.scm (%substitute-directory): New variable.
      (call-with-derivation-narinfo): Use it.
      (call-with-derivation-substitute): New procedure.
      (with-derivation-substitute): New macro.
    * tests/store.scm ("substitute"): Use 'with-derivation-substitute'.
      ("substitute, corrupt output hash"): Likewise.
---
 .dir-locals.el  |    2 +-
 guix/tests.scm  |   52 ++++++++++++++++++++++++++++++++++++++-
 tests/store.scm |   71 +++++++++++++++++-------------------------------------
 3 files changed, 74 insertions(+), 51 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 91d57b9..3c989d1 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -43,7 +43,7 @@
    (eval . (put 'emacs-substitute-sexps 'scheme-indent-function 1))
    (eval . (put 'emacs-substitute-variables 'scheme-indent-function 1))
    (eval . (put 'with-derivation-narinfo 'scheme-indent-function 1))
-
+   (eval . (put 'with-derivation-substitute 'scheme-indent-function 1))
 
    (eval . (put 'syntax-parameterize 'scheme-indent-function 1))
    (eval . (put 'with-monad 'scheme-indent-function 1))
diff --git a/guix/tests.scm b/guix/tests.scm
index ed2ad45..451c1ba 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -21,6 +21,8 @@
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix base32)
+  #:use-module (guix serialization)
+  #:use-module (guix hash)
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-34)
   #:use-module (rnrs bytevectors)
@@ -29,7 +31,9 @@
             random-text
             random-bytevector
             mock
+            %substitute-directory
             with-derivation-narinfo
+            with-derivation-substitute
             dummy-package))
 
 ;;; Commentary:
@@ -107,14 +111,18 @@ Deriver: ~a~%"
           (basename
            (derivation-file-name drv))))      ; Deriver
 
+(define %substitute-directory
+  (make-parameter
+   (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
+          (compose uri-path string->uri))))
+
 (define* (call-with-derivation-narinfo drv thunk
                                        #:key (sha256 (make-bytevector 32 0)))
   "Call THUNK in a context where fake substituter data, as read by 'guix
 substitute-binary', has been installed for DRV.  SHA256 is the hash of the
 expected output of DRV."
   (let* ((output  (derivation->output-path drv))
-         (dir     (uri-path
-                   (string->uri (getenv "GUIX_BINARY_SUBSTITUTE_URL"))))
+         (dir     (%substitute-directory))
          (info    (string-append dir "/nix-cache-info"))
          (narinfo (string-append dir "/" (store-path-hash-part output)
                                  ".narinfo")))
@@ -145,6 +153,45 @@ substituter's viewpoint."
        (lambda ()
          body ...)))))
 
+(define* (call-with-derivation-substitute drv contents thunk
+                                          #:key sha256)
+  "Call THUNK in a context where a substitute for DRV has been installed,
+using CONTENTS, a string, as its contents.  If SHA256 is true, use it as the
+expected hash of the substitute; otherwise use the hash of the nar containing
+CONTENTS."
+  (define dir (%substitute-directory))
+  (dynamic-wind
+    (lambda ()
+      (call-with-output-file (string-append dir "/example.out")
+        (lambda (port)
+          (display contents port)))
+      (call-with-output-file (string-append dir "/example.nar")
+        (lambda (p)
+          (write-file (string-append dir "/example.out") p))))
+    (lambda ()
+      (let ((hash (call-with-input-file (string-append dir "/example.nar")
+                    port-sha256)))
+        ;; Create fake substituter data, to be read by `substitute-binary'.
+        (call-with-derivation-narinfo drv
+          thunk
+          #:sha256 (or sha256 hash))))
+    (lambda ()
+      (delete-file (string-append dir "/example.out"))
+      (delete-file (string-append dir "/example.nar")))))
+
+(define-syntax with-derivation-substitute
+  (syntax-rules (sha256 =>)
+    "Evaluate BODY in a context where DRV is substitutable with the given
+CONTENTS."
+    ((_ drv contents (sha256 => hash) body ...)
+     (call-with-derivation-substitute drv contents
+       (lambda () body ...)
+       #:sha256 hash))
+    ((_ drv contents body ...)
+     (call-with-derivation-substitute drv contents
+       (lambda ()
+         body ...)))))
+
 (define-syntax-rule (dummy-package name* extra-fields ...)
   "Return a \"dummy\" package called NAME*, with all its compulsory fields
 initialized with default values, and with EXTRA-FIELDS set as specified."
@@ -156,6 +203,7 @@ initialized with default values, and with EXTRA-FIELDS set 
as specified."
 
 ;; Local Variables:
 ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1)
+;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2)
 ;; End:
 
 ;;; tests.scm ends here
diff --git a/tests/store.scm b/tests/store.scm
index 07ebff2..73d64e4 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -343,27 +343,12 @@
                       (display ,c p)))
                  #:guile-for-build
                  (package-derivation s %bootstrap-guile (%current-system))))
-           (o   (derivation->output-path d))
-           (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
-                       (compose uri-path string->uri))))
-        (call-with-output-file (string-append dir "/example.out")
-          (lambda (p)
-            (display c p)))
-        (call-with-output-file (string-append dir "/example.nar")
-          (lambda (p)
-            (write-file (string-append dir "/example.out") p)))
-
-        (let ((h (call-with-input-file (string-append dir "/example.nar")
-                   port-sha256)))
-          ;; Create fake substituter data, to be read by `substitute-binary'.
-          (with-derivation-narinfo d
-            (sha256 => h)
-
-            ;; Make sure we use `substitute-binary'.
-            (set-build-options s #:use-substitutes? #t)
-            (and (has-substitutes? s o)
-                 (build-derivations s (list d))
-                 (equal? c (call-with-input-file o get-string-all))))))))
+           (o   (derivation->output-path d)))
+      (with-derivation-substitute d c
+        (set-build-options s #:use-substitutes? #t)
+        (and (has-substitutes? s o)
+             (build-derivations s (list d))
+             (equal? c (call-with-input-file o get-string-all)))))))
 
 (test-assert "substitute, corrupt output hash"
   ;; Tweak the substituter into installing a substitute whose hash doesn't
@@ -376,33 +361,23 @@
                  `(mkdir %output)
                  #:guile-for-build
                  (package-derivation s %bootstrap-guile (%current-system))))
-           (o   (derivation->output-path d))
-           (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
-                       (compose uri-path string->uri))))
-      ;; Create fake substituter data, to be read by `substitute-binary'.
-      (with-derivation-narinfo d
-        (sha256 => (sha256 (string->utf8 c)))
-
-        (call-with-output-file (string-append dir "/example.out")
-          (lambda (p)
-            (display "The contents here do not match C." p)))
-        (call-with-output-file (string-append dir "/example.nar")
-          (lambda (p)
-            (write-file (string-append dir "/example.out") p)))
-
-       ;; Make sure we use `substitute-binary'.
-       (set-build-options s
-                          #:use-substitutes? #t
-                          #:fallback? #f)
-       (and (has-substitutes? s o)
-            (guard (c ((nix-protocol-error? c)
-                       ;; XXX: the daemon writes "hash mismatch in downloaded
-                       ;; path", but the actual error returned to the client
-                       ;; doesn't mention that.
-                       (pk 'corrupt c)
-                       (not (zero? (nix-protocol-error-status c)))))
-              (build-derivations s (list d))
-              #f))))))
+           (o   (derivation->output-path d)))
+      (with-derivation-substitute d c
+        (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C
+
+        ;; Make sure we use `substitute-binary'.
+        (set-build-options s
+                           #:use-substitutes? #t
+                           #:fallback? #f)
+        (and (has-substitutes? s o)
+             (guard (c ((nix-protocol-error? c)
+                        ;; XXX: the daemon writes "hash mismatch in downloaded
+                        ;; path", but the actual error returned to the client
+                        ;; doesn't mention that.
+                        (pk 'corrupt c)
+                        (not (zero? (nix-protocol-error-status c)))))
+               (build-derivations s (list d))
+               #f))))))
 
 (test-assert "substitute --fallback"
   (with-store s