Merge branch 'master' into staging

12 files changed, 162 insertions, 31 deletions

diff --git a/tests/challenge.scm b/tests/challenge.scm
index 9c6d6e0d58..fdd5fd238e 100644
--- a/tests/challenge.scm
+++ b/tests/challenge.scm
@@ -27,8 +27,8 @@
   #:use-module (guix packages)
   #:use-module (guix gexp)
   #:use-module (guix base32)
+  #:use-module (guix narinfo)
   #: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)
diff --git a/tests/crate.scm b/tests/crate.scm
index bb7032c344..b6c3a7ee2e 100644
--- a/tests/crate.scm
+++ b/tests/crate.scm
@@ -148,7 +148,7 @@
        \"crate_id\": \"intermediate-b\",
        \"kind\": \"normal\",
        \"req\": \"^1.0.0\"
-     }
+     },
      {
        \"crate_id\": \"leaf-alice\",
        \"kind\": \"normal\",
diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh
index f8be48f0c0..afadcbe195 100644
--- a/tests/guix-environment.sh
+++ b/tests/guix-environment.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2015, 2016, 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -121,6 +121,12 @@ guix environment --bootstrap -r "$gcroot" --ad-hoc guile-bootstrap \
 test `readlink "$gcroot"` = "$expected"
 rm "$gcroot"
 
+# Try '-r' with a relative file name.
+(cd "$tmpdir"; mkdir "gc-root";
+ guix environment --bootstrap -r "gc-root/r" --ad-hoc guile-bootstrap \
+      -- guile -c 1;
+ rm "gc-root/r"; rmdir "gc-root")
+
 # Same with an absolute file name.
 guix environment --bootstrap -r "$PWD/$gcroot" --ad-hoc guile-bootstrap \
      -- guile -c 1
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index f14c92ca75..f5ddd1dda3 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 # Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
 # Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 #
@@ -204,7 +204,8 @@ cat > "$tmpfile" <<EOF
       (shepherd-service
         (provision '(buggy!))
         (requirement '(does-not-exist))
-        (start #t)))))
+        (start #t)))
+    (description "Buggy.")))
 
 (operating-system
   $OS_BASE
@@ -261,8 +262,8 @@ guix system vm "$tmpfile" -d | grep '\.drv$'
 drv1="`guix system vm "$tmpfile" -d`"
 drv2="`guix system vm "$tmpfile" -d`"
 test "$drv1" = "$drv2"
-drv1="`guix system disk-image -t iso9660 "$tmpfile" -d`"
-drv2="`guix system disk-image -t iso9660 "$tmpfile" -d`"
+drv1="`guix system image -t iso9660 "$tmpfile" -d`"
+drv2="`guix system image -t iso9660 "$tmpfile" -d`"
 test "$drv1" = "$drv2"
 
 make_user_config "group-that-does-not-exist" "users"
diff --git a/tests/inferior.scm b/tests/inferior.scm
index 5fddb1fd13..7c3d730d0c 100644
--- a/tests/inferior.scm
+++ b/tests/inferior.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -75,6 +75,18 @@
       (inferior-eval '(throw 'a 'b 'c 'd) inferior)
       'badness)))
 
+(test-equal "&inferior-exception, legacy mode"
+  '(a b c d)
+  ;; Omit #:command to open an inferior in "legacy" mode, where Guile runs
+  ;; directly.
+  (let ((inferior (open-inferior %top-builddir)))
+    (guard (c ((inferior-exception? c)
+               (close-inferior inferior)
+               (and (eq? inferior (inferior-exception-inferior c))
+                    (inferior-exception-arguments c))))
+      (inferior-eval '(throw 'a 'b 'c 'd) inferior)
+      'badness)))
+
 (test-equal "inferior-packages"
   (take (sort (fold-packages (lambda (package lst)
                                (cons (list (package-name package)
@@ -213,6 +225,26 @@
                                                       "uh uh")))
       #f)))
 
+(test-equal "inferior-eval-with-store, exception"
+  '(the-answer = 42)
+  (let ((inferior (open-inferior %top-builddir
+                                 #:command "scripts/guix")))
+    (guard (c ((inferior-exception? c)
+               (close-inferior inferior)
+               (inferior-exception-arguments c)))
+      (inferior-eval-with-store inferior %store
+                                '(lambda (store)
+                                   (throw 'the-answer '= 42))))))
+
+(test-equal "inferior-eval-with-store, not a procedure"
+  'wrong-type-arg
+  (let ((inferior (open-inferior %top-builddir
+                                 #:command "scripts/guix")))
+    (guard (c ((inferior-exception? c)
+               (close-inferior inferior)
+               (car (inferior-exception-arguments c))))
+     (inferior-eval-with-store inferior %store '(+ 1 2)))))
+
 (test-equal "inferior-package-derivation"
   (map derivation-file-name
        (list (package-derivation %store %bootstrap-guile "x86_64-linux")
diff --git a/tests/networking.scm b/tests/networking.scm
index c494a48067..f2421370d2 100644
--- a/tests/networking.scm
+++ b/tests/networking.scm
@@ -68,8 +68,7 @@
    (listen-on '("127.0.0.1" "::1"))
    (sensor '("udcf0 correction 70000"))
    (constraint-from '("www.gnu.org"))
-   (constraints-from '("https://www.google.com/"))
-   (allow-large-adjustment? #t)))
+   (constraints-from '("https://www.google.com/"))))
 
 (test-assert "openntpd configuration generation sanity check"
 
diff --git a/tests/publish.scm b/tests/publish.scm
index cafd0f13a2..52101876b5 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -38,6 +38,7 @@
   #:use-module ((guix pki) #:select (%public-key-file %private-key-file))
   #:use-module (zlib)
   #:use-module (lzlib)
+  #:autoload   (zstd) (call-with-zstd-input-port)
   #:use-module (web uri)
   #:use-module (web client)
   #:use-module (web response)
@@ -54,6 +55,9 @@
 (define %store
   (open-connection-for-tests))
 
+(define (zstd-supported?)
+  (resolve-module '(zstd) #t #f #:ensure #f))
+
 (define %reference (add-text-to-store %store "ref" "foo"))
 
 (define %item (add-text-to-store %store "item" "bar" (list %reference)))
@@ -237,6 +241,18 @@ References: ~%"
          (cut restore-file <> temp)))
      (call-with-input-file temp read-string))))
 
+(unless (zstd-supported?) (test-skip 1))
+(test-equal "/nar/zstd/*"
+  "bar"
+  (call-with-temporary-output-file
+   (lambda (temp port)
+     (let ((nar (http-get-port
+                 (publish-uri
+                  (string-append "/nar/zstd/" (basename %item))))))
+       (call-with-zstd-input-port nar
+         (cut restore-file <> temp)))
+     (call-with-input-file temp read-string))))
+
 (test-equal "/*.narinfo with compression"
   `(("StorePath" . ,%item)
     ("URL" . ,(string-append "nar/gzip/" (basename %item)))
diff --git a/tests/store.scm b/tests/store.scm
index c9a08ac690..cda0e0302f 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -201,6 +201,17 @@
 ;;          (valid-path? %store p1)
 ;;          (member (pk p2) (live-paths %store)))))
 
+(test-assert "add-indirect-root and find-roots"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (let* ((item (add-text-to-store %store "something" (random-text)))
+            (root (string-append directory "/gc-root")))
+       (symlink item root)
+       (add-indirect-root %store root)
+       (let ((result (member (cons root item) (find-roots %store))))
+         (delete-file root)
+         result)))))
+
 (test-assert "permanent root"
   (let* ((p  (with-store store
                (let ((p (add-text-to-store store "random-text"
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 542aaf603f..697abc4684 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -19,6 +19,7 @@
 
 (define-module (test-substitute)
   #:use-module (guix scripts substitute)
+  #:use-module (guix narinfo)
   #:use-module (guix base64)
   #:use-module (gcrypt hash)
   #:use-module (guix serialization)
diff --git a/tests/swh.scm b/tests/swh.scm
index 06984b2a80..a36f951241 100644
--- a/tests/swh.scm
+++ b/tests/swh.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,15 +20,32 @@
   #:use-module (guix swh)
   #:use-module (guix tests http)
   #:use-module (web response)
-  #:use-module (srfi srfi-64))
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-64)
+  #:use-module (ice-9 match))
 
 ;; Test the JSON mapping machinery used in (guix swh).
 
 (define %origin
-  "{ \"visits_url\": \"/visits/42\",
+  "{ \"origin_visits_url\": \"/visits/42\",
      \"type\": \"git\",
      \"url\": \"http://example.org/guix.git\" }")
 
+(define %visits
+  ;; A single visit where 'snapshot_url' is null.
+  ;; See <https://bugs.gnu.org/45615>.
+  "[ {
+    \"origin\": \"https://github.com/Genivia/ugrep\",
+    \"visit\": 1,
+    \"date\": \"2020-05-17T21:43:45.422977+00:00\",
+    \"status\": \"ongoing\",
+    \"snapshot\": null,
+    \"metadata\": {},
+    \"type\": \"git\",
+    \"origin_visit_url\": \"https://archive.softwareheritage.org/api/1/origin/https://github.com/Genivia/ugrep/visit/1/\",
+    \"snapshot_url\": null
+  } ]")
+
 (define %directory-entries
   "[ { \"name\": \"one\",
        \"type\": \"regular\",
@@ -59,6 +76,20 @@
     (parameterize ((%swh-base-url (%local-url)))
       (lookup-origin "http://example.org/whatever"))))
 
+(test-equal "origin-visit, no snapshots"
+  '("https://github.com/Genivia/ugrep"
+    "2020-05-17T21:43:45Z"
+    #f)                                      ;see <https://bugs.gnu.org/45615>
+  (with-http-server `((200 ,%origin)
+                      (200 ,%visits))
+    (parameterize ((%swh-base-url (%local-url)))
+      (let ((origin (lookup-origin "http://example.org/whatever")))
+        (match (origin-visits origin)
+          ((visit)
+           (list (visit-origin visit)
+                 (date->string (visit-date visit) "~4")
+                 (visit-snapshot-url visit))))))))
+
 (test-equal "lookup-directory"
   '(("one" 123) ("two" 456))
   (with-json-result %directory-entries
diff --git a/tests/transformations.scm b/tests/transformations.scm
index 9053deba41..7877029486 100644
--- a/tests/transformations.scm
+++ b/tests/transformations.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -30,6 +30,7 @@
   #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix git)
+  #:use-module (guix upstream)
   #:use-module (gnu packages)
   #:use-module (gnu packages base)
   #:use-module (gnu packages busybox)
@@ -396,6 +397,22 @@
               (map local-file-file
                    (origin-patches (package-source dep)))))))))
 
+(test-equal "options->transformation, with-latest"
+  "42.0"
+  (mock ((guix upstream) %updaters
+         (delay (list (upstream-updater
+                       (name 'dummy)
+                       (pred (const #t))
+                       (description "")
+                       (latest (const (upstream-source
+                                       (package "foo")
+                                       (version "42.0")
+                                       (urls '("http://example.org")))))))))
+        (let* ((p (dummy-package "foo" (version "1.0")))
+               (t (options->transformation
+                   `((with-latest . "foo")))))
+          (package-version (t p)))))
+
 (test-end)
 
 ;;; Local Variables:
diff --git a/tests/utils.scm b/tests/utils.scm
index 009e2121ab..9bce446d98 100644
--- a/tests/utils.scm
+++ b/tests/utils.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>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;;
@@ -182,19 +182,34 @@ skip these tests."
                        method)
     (let ((data (call-with-input-file (search-path %load-path "guix.scm")
                   get-bytevector-all)))
-      (let*-values (((compressed pids1)
-                     (compressed-port method (open-bytevector-input-port data)))
-                    ((decompressed pids2)
-                     (decompressed-port method compressed)))
-        (and (every (compose zero? cdr waitpid)
-                    (pk 'pids method (append pids1 pids2)))
-             (let ((result (get-bytevector-all decompressed)))
-               (pk 'len method
-                   (if (bytevector? result)
-                       (bytevector-length result)
-                       result)
-                   (bytevector-length data))
-               (equal? result data))))))
+      (call-with-temporary-output-file
+       (lambda (output port)
+         (close-port port)
+         (let*-values (((compressed pids)
+                        ;; Note: 'compressed-output-port' only supports file
+                        ;; ports.
+                        (compressed-output-port method
+                                                (open-file output "w0"))))
+           (put-bytevector compressed data)
+           (close-port compressed)
+           (and (every (compose zero? cdr waitpid)
+                       (pk 'pids method pids))
+                (let*-values (((decompressed pids)
+                               (decompressed-port method
+                                                  (open-bytevector-input-port
+                                                   (call-with-input-file output
+                                                     get-bytevector-all))))
+                              ((result)
+                               (get-bytevector-all decompressed)))
+                  (close-port decompressed)
+                  (pk 'len method
+                      (if (bytevector? result)
+                          (bytevector-length result)
+                          result)
+                      (bytevector-length data))
+                  (and (every (compose zero? cdr waitpid)
+                              (pk 'pids method pids))
+                       (equal? result data)))))))))
 
   (false-if-exception (delete-file temp-file))
   (unless (run?) (test-skip 1))
@@ -213,8 +228,10 @@ skip these tests."
                       get-bytevector-all)))))
 
 (for-each test-compression/decompression
-          '(gzip xz lzip)
-          (list (const #t) (const #t) (const #t)))
+          `(gzip xz lzip zstd)
+          (list (const #t) (const #t) (const #t)
+                (lambda ()
+                  (resolve-module '(zstd) #t #f #:ensure #f))))
 
 ;; This is actually in (guix store).
 (test-equal "store-path-package-name"