aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.dir-locals.el2
-rw-r--r--guix/tests.scm52
-rw-r--r--tests/store.scm71
3 files changed, 74 insertions, 51 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index 91d57b9eb2..3c989d1338 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 ed2ad45a03..451c1ba4bb 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 07ebff2ea2..73d64e468b 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