Merge branch 'master' into staging

1 files changed, 95 insertions, 1 deletions

diff --git a/tests/challenge.scm b/tests/challenge.scm
index c962800f3f..bb5633a3eb 100644
--- a/tests/challenge.scm
+++ b/tests/challenge.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,22 +18,33 @@
 
 (define-module (test-challenge)
   #:use-module (guix tests)
+  #:use-module (guix tests http)
   #:use-module (gcrypt hash)
   #: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 query-path-hash*
   (store-lift query-path-hash))
 
+(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)
     (with-derivation-narinfo drv (sha256 => hash)
@@ -138,7 +149,90 @@
                          (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)