;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (test-challenge)
#:use-module (guix tests)
- #:use-module (guix hash)
+ #:use-module (guix tests http)
+ #:use-module ((gcrypt hash) #:prefix gcrypt:)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix derivations)
+ #:use-module (guix serialization)
+ #:use-module (guix packages)
#:use-module (guix gexp)
+ #:use-module (guix base32)
#:use-module (guix scripts challenge)
#:use-module (guix scripts substitute)
+ #:use-module ((guix build utils) #:select (find-files))
+ #:use-module (gnu packages bootstrap)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-64)
#:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
#:use-module (ice-9 match))
-(define %store
- (open-connection-for-tests))
-
(define query-path-hash*
(store-lift query-path-hash))
-(define-syntax-rule (test-assertm name exp)
- (test-assert name
- (run-with-store %store exp
- #:guile-for-build (%guile-for-build))))
+(define (query-path-size item)
+ (mlet %store-monad ((info (query-path-info* item)))
+ (return (path-info-nar-size info))))
(define* (call-with-derivation-narinfo* drv thunk hash)
(lambda (store)
(built-derivations (list drv))
(mlet %store-monad ((hash (query-path-hash* out)))
(with-derivation-narinfo* drv (sha256 => hash)
- (>>= (discrepancies (list out) (%test-substitute-urls))
- (lift1 null? %store-monad))))))))
+ (>>= (compare-contents (list out) (%test-substitute-urls))
+ (match-lambda
+ ((report)
+ (return
+ (and (string=? out (comparison-report-item report))
+ (bytevector=?
+ (comparison-report-local-sha256 report)
+ hash)
+ (comparison-report-match? report))))))))))))
(test-assertm "one discrepancy"
(let ((text (random-text)))
(modulo (+ b 1) 128))
w)))
(with-derivation-narinfo* drv (sha256 => wrong-hash)
- (>>= (discrepancies (list out) (%test-substitute-urls))
+ (>>= (compare-contents (list out) (%test-substitute-urls))
(match-lambda
- ((discrepancy)
+ ((report)
(return
- (and (string=? out (discrepancy-item discrepancy))
+ (and (string=? out (comparison-report-item (pk report)))
+ (eq? 'mismatch (comparison-report-result report))
(bytevector=? hash
- (discrepancy-local-sha256
- discrepancy))
- (match (discrepancy-narinfos discrepancy)
+ (comparison-report-local-sha256
+ report))
+ (match (comparison-report-narinfos report)
((bad)
(bytevector=? wrong-hash
(narinfo-hash->sha256
(narinfo-hash bad))))))))))))))))
-(test-end)
+(test-assertm "inconclusive: no substitutes"
+ (mlet* %store-monad ((drv (gexp->derivation "foo" #~(mkdir #$output)))
+ (out -> (derivation->output-path drv))
+ (_ (built-derivations (list drv)))
+ (hash (query-path-hash* out)))
+ (>>= (compare-contents (list out) (%test-substitute-urls))
+ (match-lambda
+ ((report)
+ (return
+ (and (string=? out (comparison-report-item report))
+ (comparison-report-inconclusive? report)
+ (null? (comparison-report-narinfos report))
+ (bytevector=? (comparison-report-local-sha256 report)
+ hash))))))))
-\f
-(exit (= (test-runner-fail-count (test-runner-current)) 0))
+(test-assertm "inconclusive: no local build"
+ (let ((text (random-text)))
+ (mlet* %store-monad ((drv (gexp->derivation "something"
+ #~(list #$output #$text)))
+ (out -> (derivation->output-path drv))
+ (hash -> (gcrypt:sha256 #vu8())))
+ (with-derivation-narinfo* drv (sha256 => hash)
+ (>>= (compare-contents (list out) (%test-substitute-urls))
+ (match-lambda
+ ((report)
+ (return
+ (and (string=? out (comparison-report-item report))
+ (comparison-report-inconclusive? report)
+ (not (comparison-report-local-sha256 report))
+ (match (comparison-report-narinfos report)
+ ((narinfo)
+ (bytevector=? (narinfo-hash->sha256
+ (narinfo-hash narinfo))
+ hash))))))))))))
+(define (make-narinfo item size hash)
+ (format #f "StorePath: ~a
+Compression: none
+URL: nar/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
+NarSize: ~d
+NarHash: sha256:~a
+References: ~%" item size (bytevector->nix-base32-string hash)))
+
+(define (call-mismatch-test proc)
+ "Pass PROC a <comparison-report> for a mismatch and return its return
+value."
+
+ ;; Pretend we have two different results for the same store item, ITEM, with
+ ;; "/bin/guile" differing between the two nars.
+ (mlet* %store-monad
+ ((drv1 (package->derivation %bootstrap-guile))
+ (drv2 (gexp->derivation
+ "broken-guile"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+ (copy-recursively #$drv1 #$output)
+ (chmod (string-append #$output "/bin/guile")
+ #o755)
+ (call-with-output-file (string-append
+ #$output
+ "/bin/guile")
+ (lambda (port)
+ (display "corrupt!" port)))))))
+ (out1 -> (derivation->output-path drv1))
+ (out2 -> (derivation->output-path drv2))
+ (item -> (string-append (%store-prefix) "/"
+ (bytevector->nix-base32-string
+ (random-bytevector 32))
+ "-foo"
+ (number->string (current-time) 16))))
+ (mbegin %store-monad
+ (built-derivations (list drv1 drv2))
+ (mlet* %store-monad ((size1 (query-path-size out1))
+ (size2 (query-path-size out2))
+ (hash1 (query-path-hash* out1))
+ (hash2 (query-path-hash* out2))
+ (nar1 -> (call-with-bytevector-output-port
+ (lambda (port)
+ (write-file out1 port))))
+ (nar2 -> (call-with-bytevector-output-port
+ (lambda (port)
+ (write-file out2 port)))))
+ (parameterize ((%http-server-port 9000))
+ (with-http-server `((200 ,(make-narinfo item size1 hash1))
+ (200 ,nar1))
+ (parameterize ((%http-server-port 9001))
+ (with-http-server `((200 ,(make-narinfo item size2 hash2))
+ (200 ,nar2))
+ (mlet* %store-monad ((urls -> (list (%local-url 9000)
+ (%local-url 9001)))
+ (reports (compare-contents (list item)
+ urls)))
+ (pk 'report reports)
+ (return (proc (car reports))))))))))))
+
+(test-assertm "differing-files"
+ (call-mismatch-test
+ (lambda (report)
+ (equal? (differing-files report) '("/bin/guile")))))
+
+(test-assertm "call-with-mismatches"
+ (call-mismatch-test
+ (lambda (report)
+ (call-with-mismatches
+ report
+ (lambda (directory1 directory2)
+ (let* ((files1 (find-files directory1))
+ (files2 (find-files directory2))
+ (files (map (cute string-drop <> (string-length directory1))
+ files1)))
+ (and (equal? files
+ (map (cute string-drop <> (string-length directory2))
+ files2))
+ (equal? (remove (lambda (file)
+ (file=? (string-append directory1 "/" file)
+ (string-append directory2 "/" file)))
+ files)
+ '("/bin/guile")))))))))
+
+(test-end)
;;; Local Variables:
;;; eval: (put 'with-derivation-narinfo* 'scheme-indent-function 2)
HCoop / jackhill / guix / guix.git / blobdiff