diff options
| -rw-r--r-- | .dir-locals.el | 2 | ||||
| -rw-r--r-- | guix/tests.scm | 52 | ||||
| -rw-r--r-- | tests/store.scm | 71 |
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 |