diff options
| -rw-r--r-- | .dir-locals.el | 2 | ||||
| -rw-r--r-- | guix/tests.scm | 35 | ||||
| -rw-r--r-- | tests/derivations.scm | 4 | ||||
| -rw-r--r-- | tests/store.scm | 235 |
4 files changed, 105 insertions, 171 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index b82d0494e4..91d57b9eb2 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 36341cb4cc..ed2ad45a03 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 <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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 8e592ab6a1..80aabad3a8 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 5494e1a348..07ebff2ea2 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) |