Merge branch 'ungrafting' into staging

11 files changed, 232 insertions, 30 deletions

diff --git a/tests/boot-parameters.scm b/tests/boot-parameters.scm
index a00b227551..3deae564c4 100644
--- a/tests/boot-parameters.scm
+++ b/tests/boot-parameters.scm
@@ -50,6 +50,9 @@
 (define %default-store-directory-prefix
   (string-append "/" %default-btrfs-subvolume))
 (define %default-store-mount-point (%store-prefix))
+(define %default-store-crypto-devices
+  (list (uuid "00000000-1111-2222-3333-444444444444")
+        (uuid "55555555-6666-7777-8888-999999999999")))
 (define %default-multiboot-modules '())
 (define %default-locale "es_ES.utf8")
 (define %root-path "/")
@@ -67,6 +70,7 @@
    (locale %default-locale)
    (store-device %default-store-device)
    (store-directory-prefix %default-store-directory-prefix)
+   (store-crypto-devices %default-store-crypto-devices)
    (store-mount-point %default-store-mount-point)))
 
 (define %default-operating-system
@@ -110,6 +114,8 @@
           (with-store #t)
           (store-device
            (quote-uuid %default-store-device))
+          (store-crypto-devices
+           (map quote-uuid %default-store-crypto-devices))
           (store-directory-prefix %default-store-directory-prefix)
           (store-mount-point %default-store-mount-point))
   (define (generate-boot-parameters)
@@ -125,12 +131,14 @@
             (sexp-or-nothing " (kernel-arguments ~S)" kernel-arguments)
             (sexp-or-nothing " (initrd ~S)" initrd)
             (if with-store
-                (format #false " (store~a~a~a)"
+                (format #false " (store~a~a~a~a)"
                         (sexp-or-nothing " (device ~S)" store-device)
                         (sexp-or-nothing " (mount-point ~S)"
                                          store-mount-point)
                         (sexp-or-nothing " (directory-prefix ~S)"
-                                         store-directory-prefix))
+                                         store-directory-prefix)
+                        (sexp-or-nothing " (crypto-devices ~S)"
+                                         store-crypto-devices))
                 "")
             (sexp-or-nothing " (locale ~S)" locale)
             (sexp-or-nothing " (bootloader-name ~a)" bootloader-name)
@@ -158,6 +166,7 @@
        (test-read-boot-parameters #:with-store #false)
        (test-read-boot-parameters #:store-device #false)
        (test-read-boot-parameters #:store-device 'false)
+       (test-read-boot-parameters #:store-crypto-devices #false)
        (test-read-boot-parameters #:store-mount-point #false)
        (test-read-boot-parameters #:store-directory-prefix #false)
        (test-read-boot-parameters #:multiboot-modules #false)
@@ -254,6 +263,23 @@
   (boot-parameters-store-mount-point
    (test-read-boot-parameters #:with-store #false)))
 
+(test-equal "read, store-crypto-devices, default"
+  '()
+  (boot-parameters-store-crypto-devices
+   (test-read-boot-parameters #:store-crypto-devices #false)))
+
+;; XXX: <warning: unrecognized crypto-devices #f at '#f'>
+(test-equal "read, store-crypto-devices, false"
+  '()
+  (boot-parameters-store-crypto-devices
+   (test-read-boot-parameters #:store-crypto-devices 'false)))
+
+;; XXX: <warning: unrecognized crypto-device "bad" at '#f'>
+(test-equal "read, store-crypto-devices, string"
+  '()
+  (boot-parameters-store-crypto-devices
+   (test-read-boot-parameters #:store-crypto-devices "bad")))
+
 ;; For whitebox testing
 (define operating-system-boot-parameters
   (@@ (gnu system) operating-system-boot-parameters))
diff --git a/tests/cve-sample.json b/tests/cve-sample.json
index 39816f9dd4..11b71817bb 100644
--- a/tests/cve-sample.json
+++ b/tests/cve-sample.json
@@ -49,7 +49,7 @@
           "vulnerable" : true,
           "cpe23Uri" : "cpe:2.3:o:juniper:junos:16.1:*:*:*:*:*:*:*"
         } ]
-      } {
+      }, {
         "operator" : "OR",
         "cpe_match" : [ {
           "vulnerable" : true,
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 686334af61..6e92f0e4b3 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -723,10 +723,26 @@
                            (lambda (port)
                              (display "This is the second one." port))))))
         (build-drv #~(begin
-                       (use-modules (guix build store-copy))
+                       (use-modules (guix build store-copy)
+                                    (guix build utils)
+                                    (srfi srfi-1))
+
+                       (define (canonical-file? file)
+                         ;; Copied from (guix tests).
+                         (let ((st (lstat file)))
+                           (or (not (string-prefix? (%store-directory) file))
+                               (eq? 'symlink (stat:type st))
+                               (and (= 1 (stat:mtime st))
+                                    (zero? (logand #o222 (stat:mode st)))))))
 
                        (mkdir #$output)
-                       (populate-store '("graph") #$output))))
+                       (populate-store '("graph") #$output
+                                       #:deduplicate? #f)
+
+                       ;; Check whether 'populate-store' canonicalizes
+                       ;; permissions and timestamps.
+                       (unless (every canonical-file? (find-files #$output))
+                         (error "not canonical!" #$output)))))
     (mlet* %store-monad ((one (gexp->derivation "one" build-one))
                          (two (gexp->derivation "two" (build-two one)))
                          (drv (gexp->derivation "store-copy" build-drv
diff --git a/tests/guix-archive.sh b/tests/guix-archive.sh
index e796c62f9a..00b87ff0ac 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, 2019 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2013, 2014, 2015, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -28,7 +28,7 @@ tmpdir="t-archive-dir-$$"
 rm -f "$archive" "$archive_alt"
 rm -rf "$tmpdir"
 
-trap 'rm -f "$archive" "$archive_alt"; rm -rf "$tmpdir"' EXIT
+trap 'rm -f "$archive" "$archive_alt"; chmod -R +w "$tmpdir"; rm -rf "$tmpdir"' EXIT
 
 guix archive --export guile-bootstrap > "$archive"
 guix archive --export guile-bootstrap:out > "$archive_alt"
diff --git a/tests/nar.scm b/tests/nar.scm
index aeff3d3330..ba4881caaa 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -136,8 +136,11 @@
 (define (rm-rf dir)
   (file-system-fold (const #t)                    ; enter?
                     (lambda (file stat result)    ; leaf
+                      (unless (eq? 'symlink (stat:type stat))
+                        (chmod file #o644))
                       (delete-file file))
-                    (const #t)                    ; down
+                    (lambda (dir stat result)     ; down
+                      (chmod dir #o755))
                     (lambda (dir stat result)     ; up
                       (rmdir dir))
                     (const #t)                    ; skip
@@ -218,8 +221,10 @@
   '(("R" directory #f)
     ("R/dir" directory #f)
     ("R/dir/exe" executable "1234")
+    ("R/dir" directory-complete #f)
     ("R/foo" regular "abcdefg")
-    ("R/lnk" symlink "foo"))
+    ("R/lnk" symlink "foo")
+    ("R" directory-complete #f))
 
   (let ()
     (define-values (port get-bytevector)
@@ -361,7 +366,12 @@
                   (cut write-file input <>))
                 (call-with-input-file nar
                   (cut restore-file <> output))
-                (file-tree-equal? input output))
+
+                (and (file-tree-equal? input output)
+                     (every (lambda (file)
+                              (canonical-file?
+                               (string-append output "/" file)))
+                            '("root" "root/reg" "root/exe"))))
               (lambda ()
                 (false-if-exception (delete-file nar))
                 (false-if-exception (rm-rf output)))))))
@@ -442,6 +452,9 @@
         (false-if-exception (rm-rf %test-dir))
         (setlocale LC_ALL locale)))))
 
+;; XXX: Tell the 'deduplicate' procedure what store we're actually using.
+(setenv "NIX_STORE" (%store-prefix))
+
 (test-assert "restore-file-set (signed, valid)"
   (with-store store
     (let* ((texts (unfold (cut >= <> 10)
diff --git a/tests/store-database.scm b/tests/store-database.scm
index 3b4ef43f6d..17eea38c63 100644
--- a/tests/store-database.scm
+++ b/tests/store-database.scm
@@ -20,6 +20,7 @@
   #:use-module (guix tests)
   #:use-module (guix store)
   #:use-module (guix store database)
+  #:use-module (guix build store-copy)
   #:use-module ((guix utils) #:select (call-with-temporary-output-file))
   #:use-module ((guix build utils)
                 #:select (mkdir-p delete-file-recursively))
@@ -34,8 +35,7 @@
 
 (test-begin "store-database")
 
-(test-equal "register-path"
-  '(1 1)
+(test-assert "register-items"
   (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f)
                              "-fake")))
     (when (valid-path? %store file)
@@ -46,9 +46,9 @@
           (drv (string-append file ".drv")))
       (call-with-output-file file
         (cut display "This is a fake store item.\n" <>))
-      (register-path file
-                     #:references (list ref)
-                     #:deriver drv)
+      (reset-timestamps file)
+      (with-database (store-database-file) db
+        (register-items db (list (store-info file drv (list ref)))))
 
       (and (valid-path? %store file)
            (equal? (references %store file) (list ref))
@@ -57,7 +57,7 @@
            (list (stat:mtime (lstat file))
                  (stat:mtime (lstat ref)))))))
 
-(test-equal "register-path, directory"
+(test-equal "register-items, directory"
   '(1 1 1)
   (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f)
                              "-fake-directory")))
@@ -69,7 +69,9 @@
       (mkdir-p (string-append file "/a"))
       (call-with-output-file (string-append file "/a/b")
         (const #t))
-      (register-path file #:deriver drv)
+      (reset-timestamps file)
+      (with-database (store-database-file) db
+        (register-items db (list (store-info file drv '()))))
 
       (and (valid-path? %store file)
            (null? (references %store file))
@@ -101,7 +103,7 @@
          (list (path-id db "/gnu/foo")
                (path-id db "/gnu/bar")))))))
 
-(test-assert "register-path with unregistered references"
+(test-assert "sqlite-register with unregistered references"
   ;; Make sure we get a "NOT NULL constraint failed: Refs.reference" error
   ;; when we try to add references that are not registered yet.  Better safe
   ;; than sorry.
diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm
index e2870a363d..b1c2d93bbd 100644
--- a/tests/store-deduplication.scm
+++ b/tests/store-deduplication.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,6 +25,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64))
 
 (test-begin "store-deduplication")
@@ -94,7 +95,7 @@
          (lambda ()
            (set! link (lambda (old new)
                         (set! links (+ links 1))
-                        (if (<= links 3)
+                        (if (<= links 4)
                             (true-link old new)
                             (throw 'system-error "link" "~A" '("Whaaat?!")
                                    (list ENOSPC))))))
@@ -106,4 +107,19 @@
        (cons (apply = (map (compose stat:ino stat) identical))
              (map (compose stat:nlink stat) identical))))))
 
+(test-assert "copy-file/deduplicate"
+  (call-with-temporary-directory
+   (lambda (store)
+     (let ((source (search-path %load-path "gnu/packages/emacs-xyz.scm")))
+       (for-each (lambda (target)
+                   (copy-file/deduplicate source
+                                          (string-append store target)
+                                          #:store store))
+                 '("/a" "/b" "/c"))
+       (and (directory-exists? (string-append store "/.links"))
+            (file=? source (string-append store "/a"))
+            (apply = (map (compose stat:ino stat
+                                   (cut string-append store <>))
+                          '("/a" "/b" "/c"))))))))
+
 (test-end "store-deduplication")
diff --git a/tests/store.scm b/tests/store.scm
index 38051bf5e5..c9a08ac690 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -715,8 +715,33 @@
                            #:substitute-urls (%test-substitute-urls))
         (and (has-substitutes? s o)
              (build-derivations s (list d))
+             (canonical-file? o)
              (equal? c (call-with-input-file o get-string-all)))))))
 
+(test-assert "substitute, deduplication"
+  (with-store s
+    (let* ((c   (random-text))                     ; contents of the output
+           (g   (package-derivation s %bootstrap-guile))
+           (d1  (build-expression->derivation s "substitute-me"
+                                              `(begin ,c (exit 1))
+                                              #:guile-for-build g))
+           (d2  (build-expression->derivation s "build-me"
+                                              `(call-with-output-file %output
+                                                 (lambda (p)
+                                                   (display ,c p)))
+                                              #:guile-for-build g))
+           (o1  (derivation->output-path d1))
+           (o2  (derivation->output-path d2)))
+      (with-derivation-substitute d1 c
+        (set-build-options s #:use-substitutes? #t
+                           #:substitute-urls (%test-substitute-urls))
+        (and (has-substitutes? s o1)
+             (build-derivations s (list d2))      ;build
+             (build-derivations s (list d1))      ;substitute
+             (canonical-file? o1)
+             (equal? c (call-with-input-file o1 get-string-all))
+             (= (stat:ino (stat o1)) (stat:ino (stat o2))))))))
+
 (test-assert "substitute + build-things with output path"
   (with-store s
     (let* ((c   (random-text))                    ;contents of the output
@@ -735,6 +760,7 @@
         (and (has-substitutes? s o)
              (build-things s (list o))            ;give the output path
              (valid-path? s o)
+             (canonical-file? o)
              (equal? c (call-with-input-file o get-string-all)))))))
 
 (test-assert "substitute + build-things with specific output"
@@ -755,6 +781,7 @@
              (build-things s `((,(derivation-file-name d) . "out")))
 
              (valid-path? s o)
+             (canonical-file? o)
              (equal? c (call-with-input-file o get-string-all)))))))
 
 (test-assert "substitute, corrupt output hash"
@@ -787,6 +814,61 @@
                (build-derivations s (list d))
                #f))))))
 
+(test-assert "substitute, corrupt output hash, build trace"
+  ;; Likewise, and check the build trace.
+  (with-store s
+    (let* ((c   "hello, world")                   ; contents of the output
+           (d   (build-expression->derivation
+                 s "corrupt-substitute"
+                 `(mkdir %output)
+                 #:guile-for-build
+                 (package-derivation s %bootstrap-guile (%current-system))))
+           (o   (derivation->output-path d)))
+      ;; Make sure we use 'guix substitute'.
+      (set-build-options s
+                         #:print-build-trace #t
+                         #:use-substitutes? #t
+                         #:fallback? #f
+                         #:substitute-urls (%test-substitute-urls))
+
+      (with-derivation-substitute d c
+        (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C
+
+        (define output
+          (call-with-output-string
+            (lambda (port)
+              (parameterize ((current-build-output-port port))
+                (guard (c ((store-protocol-error? c) #t))
+                  (build-derivations s (list d))
+                  #f)))))
+
+        (define actual-hash
+          (let-values (((port get-hash)
+                        (gcrypt:open-hash-port
+                         (gcrypt:hash-algorithm gcrypt:sha256))))
+            (write-file-tree "foo" port
+                             #:file-type+size
+                             (lambda _
+                               (values 'regular (string-length c)))
+                             #:file-port
+                             (lambda _
+                               (open-input-string c)))
+            (close-port port)
+            (bytevector->nix-base32-string (get-hash))))
+
+        (define expected-hash
+          (bytevector->nix-base32-string (make-bytevector 32 0)))
+
+        (define mismatch
+          (string-append "@ hash-mismatch " o " sha256 "
+                         expected-hash " " actual-hash "\n"))
+
+        (define failure
+          (string-append "@ substituter-failed " o))
+
+        (and (string-contains output mismatch)
+             (string-contains output failure))))))
+
 (test-assert "substitute --fallback"
   (with-store s
     (let* ((t   (random-text))                    ; contents of the output
diff --git a/tests/substitute.scm b/tests/substitute.scm
index b86ce09425..542aaf603f 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -28,7 +28,9 @@
   #:use-module (guix base32)
   #:use-module ((guix store) #:select (%store-prefix))
   #:use-module ((guix ui) #:select (guix-warning-port))
-  #:use-module ((guix utils) #:select (call-with-compressed-output-port))
+  #:use-module ((guix utils)
+                #:select (call-with-temporary-directory
+                          call-with-compressed-output-port))
   #:use-module ((guix build utils)
                 #:select (mkdir-p delete-file-recursively dump-port))
   #:use-module (guix tests http)
@@ -36,6 +38,7 @@
   #:use-module (rnrs io ports)
   #:use-module (web uri)
   #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -304,7 +307,7 @@ System: mips64el-linux\n")
       (lambda ()
         (guix-substitute "--substitute")))))
 
-(test-quit "substitute, invalid hash"
+(test-quit "substitute, invalid narinfo hash"
     "no valid substitute"
   ;; The hash in the signature differs from the hash of %NARINFO.
   (with-narinfo (string-append %narinfo "Signature: "
@@ -317,6 +320,49 @@ System: mips64el-linux\n")
       (lambda ()
         (guix-substitute "--substitute")))))
 
+(test-equal "substitute, invalid hash"
+  (string-append "hash-mismatch sha256 "
+                 (bytevector->nix-base32-string (sha256 #vu8())) " "
+                 (let-values (((port get-hash)
+                               (open-hash-port (hash-algorithm sha256)))
+                              ((content)
+                               "Substitutable data."))
+                   (write-file-tree "foo" port
+                                    #:file-type+size
+                                    (lambda _
+                                      (values 'regular
+                                              (string-length content)))
+                                    #:file-port
+                                    (lambda _
+                                      (open-input-string content)))
+                   (close-port port)
+                   (bytevector->nix-base32-string (get-hash)))
+                 "\n")
+
+  ;; Arrange so the actual data hash does not match the 'NarHash' field in the
+  ;; narinfo.
+  (with-output-to-string
+    (lambda ()
+      (let ((narinfo (string-append "StorePath: " (%store-prefix)
+                                    "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-wrong-hash
+URL: example.nar
+Compression: none
+NarHash: sha256:" (bytevector->nix-base32-string (sha256 #vu8())) "
+NarSize: 42
+References: 
+Deriver: " (%store-prefix) "/foo.drv
+System: mips64el-linux\n")))
+        (with-narinfo (string-append narinfo "Signature: "
+                                     (signature-field narinfo) "\n")
+          (call-with-temporary-directory
+           (lambda (directory)
+             (with-input-from-string (string-append
+                                      "substitute " (%store-prefix)
+                                      "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-wrong-hash "
+                                      directory "/wrong-hash\n")
+               (lambda ()
+                 (guix-substitute "--substitute"))))))))))
+
 (test-quit "substitute, unauthorized key"
     "no valid substitute"
   (with-narinfo (string-append %narinfo "Signature: "
@@ -332,7 +378,7 @@ System: mips64el-linux\n")
         (guix-substitute "--substitute")))))
 
 (test-equal "substitute, authorized key"
-  "Substitutable data."
+  '("Substitutable data." 1 #o444)
   (with-narinfo (string-append %narinfo "Signature: "
                                (signature-field %narinfo))
     (dynamic-wind
@@ -341,7 +387,9 @@ System: mips64el-linux\n")
         (request-substitution (string-append (%store-prefix)
                                              "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
                               "substitute-retrieved")
-        (call-with-input-file "substitute-retrieved" get-string-all))
+        (list (call-with-input-file "substitute-retrieved" get-string-all)
+              (stat:mtime (lstat "substitute-retrieved"))
+              (stat:perms (lstat "substitute-retrieved"))))
       (lambda ()
         (false-if-exception (delete-file "substitute-retrieved"))))))
 
diff --git a/tests/swh.scm b/tests/swh.scm
index aef68acbe7..06984b2a80 100644
--- a/tests/swh.scm
+++ b/tests/swh.scm
@@ -33,7 +33,7 @@
   "[ { \"name\": \"one\",
        \"type\": \"regular\",
        \"length\": 123,
-       \"dir_id\": 1 }
+       \"dir_id\": 1 },
      { \"name\": \"two\",
        \"type\": \"regular\",
        \"length\": 456,
diff --git a/tests/transformations.scm b/tests/transformations.scm
index 07ed8b1234..2d33bed7ae 100644
--- a/tests/transformations.scm
+++ b/tests/transformations.scm
@@ -368,10 +368,9 @@
     (let ((new (t p)))
       (match (bag-direct-inputs (package->bag new))
         ((("dep" dep) ("tar" tar) _ ...)
-         ;; TODO: Check whether TAR has #:tests? #f when transformations
-         ;; apply to implicit inputs.
-         (equal? (package-arguments dep)
-                 '(#:tests? #f)))))))
+         (and (equal? (package-arguments dep) '(#:tests? #f))
+              (match (memq #:tests? (package-arguments tar))
+                ((#:tests? #f _ ...) #t))))))))
 
 (test-end)