03/08: tests: Further factorize substitute mocks.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 6eebbab5624f213a298afb1baed28cec026b2727
Author: Ludovic Courtès <address@hidden>
Date:   Mon Feb 2 10:37:23 2015 +0100

    tests: Further factorize substitute mocks.
    
    * guix/tests.scm (derivation-narinfo): Turn 'nar' into a keyword
      parameter.  Add #:sha256 parameter, and honor it.
      (call-with-derivation-narinfo): Add #:sha256 and pass it to
      'derivation-narinfo'.
      (with-derivation-narinfo): Extend with support for (sha256 => value).
    * tests/store.scm ("substitute query"): Use 'with-derivation-narinfo'.
      ("substitute"): Likewise.
      ("substitute, corrupt output hash"): Likewise.
      ("substitute --fallback"): Likewise.
    * tests/derivations.scm: Remove Emacs local variable.
---
 .dir-locals.el        |    2 +
 guix/tests.scm        |   35 +++++---
 tests/derivations.scm |    4 -
 tests/store.scm       |  235 +++++++++++++++++--------------------------------
 4 files changed, 105 insertions(+), 171 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index b82d049..91d57b9 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -42,6 +42,8 @@
    (eval . (put 'emacs-batch-edit-file 'scheme-indent-function 1))
    (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 '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 36341cb..ed2ad45 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <address@hidden>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,6 +20,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix base32)
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-34)
   #:use-module (rnrs bytevectors)
@@ -86,25 +87,31 @@ given by REPLACEMENT."
 ;;; Narinfo files, as used by the substituter.
 ;;;
 
-(define* (derivation-narinfo drv #:optional (nar "example.nar"))
+(define* (derivation-narinfo drv #:key (nar "example.nar")
+                             (sha256 (make-bytevector 32 0)))
   "Return the contents of the narinfo corresponding to DRV; NAR should be the
-file name of the archive containing the substitute for DRV."
+file name of the archive containing the substitute for DRV, and SHA256 is the
+expected hash."
   (format #f "StorePath: ~a
 URL: ~a
 Compression: none
 NarSize: 1234
+NarHash: sha256:~a
 References: 
 System: ~a
 Deriver: ~a~%"
           (derivation->output-path drv)       ; StorePath
           nar                                 ; URL
+          (bytevector->nix-base32-string sha256)  ; NarHash
           (derivation-system drv)             ; System
           (basename
            (derivation-file-name drv))))      ; Deriver
 
-(define (call-with-derivation-narinfo drv thunk)
+(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."
+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"))))
@@ -119,18 +126,24 @@ substitute-binary', has been installed for DRV."
                     (%store-prefix))))
         (call-with-output-file narinfo
           (lambda (p)
-            (display (derivation-narinfo drv) p))))
+            (display (derivation-narinfo drv #:sha256 sha256) p))))
       thunk
       (lambda ()
         (delete-file narinfo)
         (delete-file info)))))
 
-(define-syntax-rule (with-derivation-narinfo drv body ...)
-  "Evaluate BODY in a context where DRV looks substitutable from the
+(define-syntax with-derivation-narinfo
+  (syntax-rules (sha256 =>)
+    "Evaluate BODY in a context where DRV looks substitutable from the
 substituter's viewpoint."
-  (call-with-derivation-narinfo drv
-    (lambda ()
-      body ...)))
+    ((_ drv (sha256 => hash) body ...)
+     (call-with-derivation-narinfo drv
+       (lambda () body ...)
+       #:sha256 hash))
+    ((_ drv body ...)
+     (call-with-derivation-narinfo drv
+       (lambda ()
+         body ...)))))
 
 (define-syntax-rule (dummy-package name* extra-fields ...)
   "Return a \"dummy\" package called NAME*, with all its compulsory fields
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 8e592ab..80aabad 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -916,7 +916,3 @@
 
 
 (exit (= (test-runner-fail-count (test-runner-current)) 0))
-
-;; Local Variables:
-;; eval: (put 'with-derivation-narinfo 'scheme-indent-function 1)
-;; End:
diff --git a/tests/store.scm b/tests/store.scm
index 5494e1a..07ebff2 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -310,46 +310,27 @@
 
 (test-assert "substitute query"
   (with-store s
-    (let* ((d   (package-derivation s %bootstrap-guile (%current-system)))
-           (o   (derivation->output-path d))
-           (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
-                       (compose uri-path string->uri))))
+    (let* ((d (package-derivation s %bootstrap-guile (%current-system)))
+           (o (derivation->output-path d)))
       ;; 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 o)
-                                            ".narinfo")
-        (lambda (p)
-          (format p "StorePath: ~a
-URL: ~a
-Compression: none
-NarSize: 1234
-References: 
-System: ~a
-Deriver: ~a~%"
-                  o                                 ; StorePath
-                  (string-append dir "/example.nar") ; URL
-                  (%current-system)                  ; System
-                  (basename
-                   (derivation-file-name d)))))    ; Deriver
-
-      ;; Remove entry from the local cache.
-      (false-if-exception
-       (delete-file (string-append (getenv "XDG_CACHE_HOME")
-                                   "/guix/substitute-binary/"
-                                   (store-path-hash-part o))))
-
-      ;; Make sure `substitute-binary' correctly communicates the above data.
-      (set-build-options s #:use-substitutes? #t)
-      (and (has-substitutes? s o)
-           (equal? (list o) (substitutable-paths s (list o)))
-           (match (pk 'spi (substitutable-path-info s (list o)))
-             (((? substitutable? s))
-              (and (string=? (substitutable-deriver s) (derivation-file-name 
d))
-                   (null? (substitutable-references s))
-                   (equal? (substitutable-nar-size s) 1234))))))))
+      (with-derivation-narinfo d
+        ;; Remove entry from the local cache.
+        (false-if-exception
+         (delete-file (string-append (getenv "XDG_CACHE_HOME")
+                                     "/guix/substitute-binary/"
+                                     (store-path-hash-part o))))
+
+        ;; Make sure `substitute-binary' correctly communicates the above
+        ;; data.
+        (set-build-options s #:use-substitutes? #t)
+        (and (has-substitutes? s o)
+             (equal? (list o) (substitutable-paths s (list o)))
+             (match (pk 'spi (substitutable-path-info s (list o)))
+               (((? substitutable? s))
+                (and (string=? (substitutable-deriver s)
+                               (derivation-file-name d))
+                     (null? (substitutable-references s))
+                     (equal? (substitutable-nar-size s) 1234)))))))))
 
 (test-assert "substitute"
   (with-store s
@@ -365,42 +346,24 @@ Deriver: ~a~%"
            (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'.
-      (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 "/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)))
-      (call-with-output-file (string-append dir "/" (store-path-hash-part o)
-                                            ".narinfo")
-        (lambda (p)
-          (format p "StorePath: ~a
-URL: ~a
-Compression: none
-NarSize: 1234
-NarHash: sha256:~a
-References: 
-System: ~a
-Deriver: ~a~%"
-                  o                                ; StorePath
-                  "example.nar"                    ; relative URL
-                  (call-with-input-file (string-append dir "/example.nar")
-                    (compose bytevector->nix-base32-string sha256
-                             get-bytevector-all))
-                  (%current-system)                ; System
-                  (basename
-                   (derivation-file-name d)))))    ; Deriver
-
-      ;; 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))))))
+        (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))))))))
 
 (test-assert "substitute, corrupt output hash"
   ;; Tweak the substituter into installing a substitute whose hash doesn't
@@ -417,52 +380,33 @@ Deriver: ~a~%"
            (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 "/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)))
-      (call-with-output-file (string-append dir "/" (store-path-hash-part o)
-                                            ".narinfo")
-        (lambda (p)
-          (format p "StorePath: ~a
-URL: ~a
-Compression: none
-NarSize: 1234
-NarHash: sha256:~a
-References: 
-System: ~a
-Deriver: ~a~%"
-                  o                                ; StorePath
-                  "example.nar"                    ; relative URL
-                  (bytevector->nix-base32-string
-                   (sha256 (string->utf8 c)))
-                  (%current-system)                ; System
-                  (basename
-                   (derivation-file-name d)))))    ; Deriver
-
-      ;; 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)))))
+      (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))))))
 
 (test-assert "substitute --fallback"
   (with-store s
-    (let* ((t   (random-text))                     ; contents of the output
+    (let* ((t   (random-text))                    ; contents of the output
            (d   (build-expression->derivation
                  s "substitute-me-not"
                  `(call-with-output-file %output
@@ -470,45 +414,24 @@ Deriver: ~a~%"
                       (display ,t 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))))
+           (o   (derivation->output-path d)))
       ;; 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 o)
-                                            ".narinfo")
-        (lambda (p)
-          (format p "StorePath: ~a
-URL: ~a
-Compression: none
-NarSize: 1234
-NarHash: sha256:0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73
-References: 
-System: ~a
-Deriver: ~a~%"
-                  o                                ; StorePath
-                  "does-not-exist.nar"             ; relative URL
-                  (%current-system)                ; System
-                  (basename
-                   (derivation-file-name d)))))    ; Deriver
-
-      ;; Make sure we use `substitute-binary'.
-      (set-build-options s #:use-substitutes? #t)
-      (and (has-substitutes? s o)
-           (guard (c ((nix-protocol-error? c)
-                      ;; The substituter failed as expected.  Now make sure 
that
-                      ;; #:fallback? #t works correctly.
-                      (set-build-options s
-                                         #:use-substitutes? #t
-                                         #:fallback? #t)
-                      (and (build-derivations s (list d))
-                           (equal? t (call-with-input-file o 
get-string-all)))))
-             ;; Should fail.
-             (build-derivations s (list d))
-             #f)))))
+      (with-derivation-narinfo d
+        ;; Make sure we use `substitute-binary'.
+        (set-build-options s #:use-substitutes? #t)
+        (and (has-substitutes? s o)
+             (guard (c ((nix-protocol-error? c)
+                        ;; The substituter failed as expected.  Now make
+                        ;; sure that #:fallback? #t works correctly.
+                        (set-build-options s
+                                           #:use-substitutes? #t
+                                           #:fallback? #t)
+                        (and (build-derivations s (list d))
+                             (equal? t (call-with-input-file o
+                                         get-string-all)))))
+               ;; Should fail.
+               (build-derivations s (list d))
+               #f))))))
 
 (test-assert "export/import several paths"
   (let* ((texts (unfold (cut >= <> 10)