Merge remote-tracking branch 'master' into core-updates.

6 files changed, 209 insertions, 4 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)
 
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 84c16422c2..8b1596f66d 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -886,6 +886,12 @@
     (run-with-store %store
       (lower-gexp #~(foo #$+)))))
 
+(test-equal "lower-gexp, character literal"
+  '(#\+)
+  (lowered-gexp-sexp
+   (run-with-store %store
+     (lower-gexp #~(#\+)))))
+
 (test-assertm "gexp->derivation #:references-graphs"
   (mlet* %store-monad
       ((one (text-file "one" (random-text)))
diff --git a/tests/git.scm b/tests/git.scm
index 8ba10ece51..052f8a79c4 100644
--- a/tests/git.scm
+++ b/tests/git.scm
@@ -96,4 +96,30 @@
              (lset= eq? (commit-difference master4 master2)
                     (list master4 merge master3 devel1 devel2)))))))
 
+(unless (which (git-command)) (test-skip 1))
+(test-assert "commit-difference, excluded commits"
+  (with-temporary-git-repository directory
+      '((add "a.txt" "A")
+        (commit "first commit")
+        (add "b.txt" "B")
+        (commit "second commit")
+        (add "c.txt" "C")
+        (commit "third commit")
+        (add "d.txt" "D")
+        (commit "fourth commit")
+        (add "e.txt" "E")
+        (commit "fifth commit"))
+    (with-repository directory repository
+      (let ((commit1 (find-commit repository "first"))
+            (commit2 (find-commit repository "second"))
+            (commit3 (find-commit repository "third"))
+            (commit4 (find-commit repository "fourth"))
+            (commit5 (find-commit repository "fifth")))
+        (and (lset= eq? (commit-difference commit4 commit1 (list commit2))
+                    (list commit3 commit4))
+             (lset= eq? (commit-difference commit4 commit1 (list commit3))
+                    (list commit4))
+             (lset= eq? (commit-difference commit4 commit1 (list commit5))
+                    (list commit2 commit3 commit4)))))))
+
 (test-end "git")
diff --git a/tests/guix-archive.sh b/tests/guix-archive.sh
index fdaeb98ad2..4c5eea05cf 100644
--- a/tests/guix-archive.sh
+++ b/tests/guix-archive.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2013, 2014, 2015, 2019 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -74,5 +74,10 @@ guix archive -x "$tmpdir" < "$archive"
 test -x "$tmpdir/bin/guile"
 test -d "$tmpdir/lib/guile"
 
+# Check '--list'.
+guix archive -t < "$archive" | grep "^D /share/guile"
+guix archive -t < "$archive" | grep "^x /bin/guile"
+guix archive -t < "$archive" | grep "^r /share/guile.*/boot-9\.scm"
+
 if echo foo | guix archive --authorize
 then false; else true; fi
diff --git a/tests/nar.scm b/tests/nar.scm
index bfc71c69a8..aeff3d3330 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -214,6 +214,80 @@
       (lambda ()
         (false-if-exception (rm-rf %test-dir))))))
 
+(test-equal "write-file-tree + fold-archive"
+  '(("R" directory #f)
+    ("R/dir" directory #f)
+    ("R/dir/exe" executable "1234")
+    ("R/foo" regular "abcdefg")
+    ("R/lnk" symlink "foo"))
+
+  (let ()
+    (define-values (port get-bytevector)
+      (open-bytevector-output-port))
+    (write-file-tree "root" port
+                     #:file-type+size
+                     (match-lambda
+                       ("root"
+                        (values 'directory 0))
+                       ("root/foo"
+                        (values 'regular 7))
+                       ("root/lnk"
+                        (values 'symlink 0))
+                       ("root/dir"
+                        (values 'directory 0))
+                       ("root/dir/exe"
+                        (values 'executable 4)))
+                     #:file-port
+                     (match-lambda
+                       ("root/foo" (open-input-string "abcdefg"))
+                       ("root/dir/exe" (open-input-string "1234")))
+                     #:symlink-target
+                     (match-lambda
+                       ("root/lnk" "foo"))
+                     #:directory-entries
+                     (match-lambda
+                       ("root" '("foo" "dir" "lnk"))
+                       ("root/dir" '("exe"))))
+    (close-port port)
+
+    (reverse
+     (fold-archive (lambda (file type contents result)
+                     (let ((contents (if (memq type '(regular executable))
+                                         (utf8->string
+                                          (get-bytevector-n (car contents)
+                                                            (cdr contents)))
+                                         contents)))
+                       (cons `(,file ,type ,contents)
+                             result)))
+                   '()
+                   (open-bytevector-input-port (get-bytevector))
+                   "R"))))
+
+(test-equal "write-file-tree + fold-archive, flat file"
+  '(("R" regular "abcdefg"))
+
+  (let ()
+    (define-values (port get-bytevector)
+      (open-bytevector-output-port))
+    (write-file-tree "root" port
+                     #:file-type+size
+                     (match-lambda
+                       ("root" (values 'regular 7)))
+                     #:file-port
+                     (match-lambda
+                       ("root" (open-input-string "abcdefg"))))
+    (close-port port)
+
+    (reverse
+     (fold-archive (lambda (file type contents result)
+                     (let ((contents (utf8->string
+                                      (get-bytevector-n (car contents)
+                                                        (cdr contents)))))
+                       (cons `(,file ,type ,contents) result)))
+                   '()
+                   (open-bytevector-input-port (get-bytevector))
+                   "R"))))
+
 (test-assert "write-file supports non-file output ports"
   (let ((input  (string-append (dirname (search-path %load-path "guix.scm"))
                                "/guix"))
diff --git a/tests/pack.scm b/tests/pack.scm
index 71ff5aec18..0c1406e687 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -28,7 +28,7 @@
   #:use-module (guix tests)
   #:use-module (guix gexp)
   #:use-module (gnu packages bootstrap)
-  #:use-module ((gnu packages compression) #:select (squashfs-tools-next))
+  #:use-module ((gnu packages compression) #:select (squashfs-tools))
   #:use-module (srfi srfi-64))
 
 (define %store
@@ -199,7 +199,7 @@
                            (string-append "." #$profile "/bin"))
 
                          (setenv "PATH"
-                                 (string-append #$squashfs-tools-next "/bin"))
+                                 (string-append #$squashfs-tools "/bin"))
                          (invoke "unsquashfs" #$image)
                          (with-directory-excursion "squashfs-root"
                            (when (and (file-exists? (string-append bin