ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2015-02-02 11:24:24 +01:00
parent 6eebbab562
commit e6c8839c18
3 changed files with 73 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.dir-locals.el
View file

@ -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))

52
guix/tests.scm
View file

@ -21,6 +21,8 @@ (define-module (guix tests)
#: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 @@ (define-module (guix tests)
random-text
random-bytevector
mock
%substitute-directory
with-derivation-narinfo
with-derivation-substitute
dummy-package))
;;; Commentary:
@ -107,14 +111,18 @@ (define* (derivation-narinfo drv #:key (nar "example.nar")
(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 @@ (define-syntax with-derivation-narinfo
(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 @@ (define-syntax-rule (dummy-package name* extra-fields ...)
;; 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

69
tests/store.scm
View file

@ -343,27 +343,12 @@ (define (same? x y)
(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 @@ (define (same? x y)
`(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)))
(o (derivation->output-path d)))
(with-derivation-substitute d c
(sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match 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))))))
;; 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