Merge branch 'master' into staging

5 files changed, 104 insertions, 65 deletions

diff --git a/tests/gexp.scm b/tests/gexp.scm
index ad8e1d57b8..390cf7a207 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -1413,6 +1413,7 @@ importing.* \\(guix config\\) from the host"
 
 (test-assertm "mixed-text-file"
   (mlet* %store-monad ((file ->   (mixed-text-file "mixed"
+                                                   #:guile %bootstrap-guile
                                                    "export PATH="
                                                    %bootstrap-guile "/bin"))
                        (drv       (lower-object file))
@@ -1430,7 +1431,8 @@ importing.* \\(guix config\\) from the host"
   (mlet* %store-monad ((union -> (file-union "union"
                                              `(("a" ,(plain-file "a" "1"))
                                                ("b/c/d" ,(plain-file "d" "2"))
-                                               ("e" ,(plain-file "e" "3")))))
+                                               ("e" ,(plain-file "e" "3")))
+                                             #:guile %bootstrap-guile))
                        (drv      (lower-object union))
                        (out ->   (derivation->output-path drv)))
     (define (contents=? file str)
@@ -1469,7 +1471,8 @@ importing.* \\(guix config\\) from the host"
                        (symlink #$%bootstrap-guile
                                 (string-append #$output "/guile"))
                        (symlink #$text (string-append #$output "/text"))))
-         (computed (computed-file "computed" exp)))
+         (computed (computed-file "computed" exp
+                                  #:guile %bootstrap-guile)))
     (mlet* %store-monad ((text      (lower-object text))
                          (guile-drv (lower-object %bootstrap-guile))
                          (comp-drv  (lower-object computed))
@@ -1504,7 +1507,8 @@ importing.* \\(guix config\\) from the host"
                              (display item port))))))
          (computed (computed-file "computed" exp
                                   #:options
-                                  `(#:references-graphs (("graph" ,pkg)))))
+                                  `(#:references-graphs (("graph" ,pkg)))
+                                  #:guile %bootstrap-guile))
          (drv0     (package-derivation %store pkg #:graft? #t))
          (drv1     (parameterize ((%graft? #t))
                      (run-with-store %store
diff --git a/tests/graph.scm b/tests/graph.scm
index fadac265f9..baa08a6be2 100644
--- a/tests/graph.scm
+++ b/tests/graph.scm
@@ -36,6 +36,7 @@
   #:use-module (gnu packages libunistring)
   #:use-module (gnu packages bootstrap)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 sandbox)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -113,6 +114,33 @@ edges."
                           (list p4 p4)
                           (list p2 p3))))))))
 
+(test-assert "package DAG, oops it was a cycle"
+  (let-values (((backend nodes+edges) (make-recording-backend)))
+    (letrec ((p1 (dummy-package "p1" (inputs `(("p3" ,p3)))))
+             (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
+             (p3 (dummy-package "p3" (inputs `(("p2" ,p2) ("p1", p1))))))
+      (call-with-time-limit
+       600 ;; If ever this test should fail, we still want it to terminate
+       (lambda ()
+         (run-with-store %store
+           (export-graph (list p3) 'port
+                         #:node-type %package-node-type
+                         #:backend backend)))
+       (lambda ()
+         (run-with-store %store
+           (export-graph
+            (list (dummy-package "timeout-reached"))
+            'port
+            #:node-type %package-node-type
+            #:backend backend))))
+      ;; We should see nothing more than these 3 packages.
+      (let-values (((nodes edges) (nodes+edges)))
+        (and (equal? nodes (map package->tuple (list p3 p2 p1)))
+             (equal? edges
+                     (map edge->tuple
+                          (list p3 p3 p2 p1)
+                          (list p2 p1 p1 p3))))))))
+
 (test-assert "reverse package DAG"
   (let-values (((backend nodes+edges) (make-recording-backend)))
     (run-with-store %store
diff --git a/tests/packages.scm b/tests/packages.scm
index 3506f94f91..55b1c4064f 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
@@ -716,7 +716,8 @@
                                   (use-modules (guix build utils))
                                   (setenv "PATH" #+bin)
                                   (invoke "tar" "xvf" #+out)
-                                  (copy-file #+name #$output)))))
+                                  (copy-file #+name #$output)))
+                            #:guile %bootstrap-guile))
                         (drv (run-with-store %store (lower-object f)))
                         (_ (build-derivations %store (list drv))))
                    (call-with-input-file (derivation->output-path drv)
diff --git a/tests/profiles.scm b/tests/profiles.scm
index cac5b73347..d59d75985f 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -302,7 +302,8 @@
                                 (call-with-output-file
                                     (string-append #$output "/bin/guile")
                                   (lambda (port)
-                                    (display "Fake!\n" port))))))))
+                                    (display "Fake!\n" port))))
+                            #:guile %bootstrap-guile))))
        (guile      (package->derivation %bootstrap-guile))
        (drv        (profile-derivation (manifest (list entry1 entry2))
                                        #:hooks '()
diff --git a/tests/pypi.scm b/tests/pypi.scm
index 1ea5f02643..88bb0a3116 100644
--- a/tests/pypi.scm
+++ b/tests/pypi.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2022 Vivien Kraus <vivien@planete-kraus.eu>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,68 +24,50 @@
   #:use-module (guix import pypi)
   #:use-module (guix base32)
   #:use-module (guix memoization)
+  #:use-module (guix utils)
   #:use-module (gcrypt hash)
   #:use-module (guix tests)
   #:use-module (guix build-system python)
   #:use-module ((guix build utils) #:select (delete-file-recursively which mkdir-p))
+  #:use-module ((guix diagnostics) #:select (guix-warning-port))
+  #:use-module (json)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-64)
-  #:use-module (ice-9 match))
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 optargs))
+
+(define* (foo-json #:key (name "foo") (name-in-url #f))
+  "Create a JSON description of an example pypi package, named @var{name},
+optionally using a different @var{name in its URL}."
+  (scm->json-string
+   `((info
+      . ((version . "1.0.0")
+         (name . ,name)
+         (license . "GNU LGPL")
+         (summary . "summary")
+         (home_page . "http://example.com")
+         (classifiers . #())
+         (download_url . "")))
+     (urls . #())
+     (releases
+      . ((1.0.0
+          . #(((url . ,(format #f "https://example.com/~a-1.0.0.egg"
+                               (or name-in-url name)))
+               (packagetype . "bdist_egg"))
+              ((url . ,(format #f "https://example.com/~a-1.0.0.tar.gz"
+                               (or name-in-url name)))
+               (packagetype . "sdist"))
+              ((url . ,(format #f "https://example.com/~a-1.0.0-py2.py3-none-any.whl"
+                               (or name-in-url name)))
+               (packagetype . "bdist_wheel")))))))))
 
 (define test-json-1
-  "{
-  \"info\": {
-    \"version\": \"1.0.0\",
-    \"name\": \"foo\",
-    \"license\": \"GNU LGPL\",
-    \"summary\": \"summary\",
-    \"home_page\": \"http://example.com\",
-    \"classifiers\": [],
-    \"download_url\": \"\"
-  },
-  \"urls\": [],
-  \"releases\": {
-    \"1.0.0\": [
-      {
-        \"url\": \"https://example.com/foo-1.0.0.egg\",
-        \"packagetype\": \"bdist_egg\"
-      }, {
-        \"url\": \"https://example.com/foo-1.0.0.tar.gz\",
-        \"packagetype\": \"sdist\"
-      }, {
-        \"url\": \"https://example.com/foo-1.0.0-py2.py3-none-any.whl\",
-        \"packagetype\": \"bdist_wheel\"
-      }
-    ]
-  }
-}")
+  (foo-json))
 
 (define test-json-2
-  "{
-  \"info\": {
-    \"version\": \"1.0.0\",
-    \"name\": \"foo-99\",
-    \"license\": \"GNU LGPL\",
-    \"summary\": \"summary\",
-    \"home_page\": \"http://example.com\",
-    \"classifiers\": [],
-    \"download_url\": \"\"
-  },
-  \"urls\": [],
-  \"releases\": {
-    \"1.0.0\": [
-      {
-        \"url\": \"https://example.com/foo-99-1.0.0.egg\",
-        \"packagetype\": \"bdist_egg\"
-      }, {
-        \"url\": \"https://example.com/foo-99-1.0.0.tar.gz\",
-        \"packagetype\": \"sdist\"
-      }, {
-        \"url\": \"https://example.com/foo-99-1.0.0-py2.py3-none-any.whl\",
-        \"packagetype\": \"bdist_wheel\"
-      }
-    ]
-  }
-}")
+  (foo-json #:name "foo-99"))
 
 (define test-source-hash
   "")
@@ -211,6 +194,30 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing'
          call-with-input-string)
         (parse-wheel-metadata test-metadata-with-extras-jedi)))
 
+(test-equal "find-project-url, with numpy"
+  "numpy"
+  (find-project-url
+   "numpy"
+   "https://files.pythonhosted.org/packages/0a/c8/a62767a6b374a0dfb02d2a0456e5f56a372cdd1689dbc6ffb6bf1ddedbc0/numpy-1.22.1.zip"))
+
+(test-equal "find-project-url, uWSGI"
+  "uwsgi"
+  (find-project-url
+   "uWSGI"
+   "https://files.pythonhosted.org/packages/24/fd/93851e4a076719199868d4c918cc93a52742e68370188c1c570a6e42a54f/uwsgi-2.0.20.tar.gz"))
+
+(test-equal "find-project-url, flake8-array-spacing"
+  "flake8_array_spacing"
+  (find-project-url
+   "flake8-array-spacing"
+   "https://files.pythonhosted.org/packages/a4/21/ff29b901128b681b7de7a2787b3aeb3e1f3cba4a8c0cffa9712cbff016bc/flake8_array_spacing-0.2.0.tar.gz"))
+
+(test-equal "find-project-url, foo/goo"
+  "foo"
+  (find-project-url
+   "foo"
+   "https://files.pythonhosted.org/packages/f0/f00/goo-0.0.0.tar.gz"))
+
 (test-assert "pypi->guix-package, no wheel"
   ;; Replace network resources with sample data.
     (mock ((guix import utils) url-fetch
@@ -260,10 +267,8 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing'
                                   hash)
                         (equal? (pypi->guix-package "foo" #:version "1.0.0")
                                 (pypi->guix-package "foo"))
-                        (catch 'quit
-                          (lambda ()
-                            (pypi->guix-package "foo" #:version "42"))
-                          (const #t))))
+                        (guard (c ((error? c) #t))
+                          (pypi->guix-package "foo" #:version "42"))))
                   (x
                    (pk 'fail x #f))))))