all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
* [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields
@ 2023-05-18 15:11 Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 01/14] tests: pypi: Factorize tarball and wheel file creation Ludovic Courtès
                   ` (15 more replies)
  0 siblings, 16 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 15:11 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès, Andrew Tropin, Liliana Marie Prikler

Hello!

Until now, ‘guix refresh -u’ would tell you what inputs need to
be changed in your packages, for the ‘cran’, ‘pypi’, and ‘stackage’
updaters.  With this change it changes them right away.

Furthermore, ‘guix refresh -u’ will now also update inputs when the
‘cpan’ and ‘elpa’ updaters are used.  Doing that for other updaters
is left as an exercise to the reader.  :-)

I’d like to get feedback from those who use ‘guix refresh -u’
frequently, which is why I Cc’d Ricardo and Lars-Dominik, but
surely they’re not the only ones!

This is implemented by reifying dependency information
as <upstream-input> records part of <upstream-source>.

In the future, we could improve importers so that they fill in
the ‘min-version’ and ‘max-version’ fields.  In turn, ‘guix refresh’
could let you know when the version of a dependency doesn’t match,
or it could add the right one or something.  This would be particularly
useful for PyPI, which doesn’t provide a consistent package set like
package.

Another thing we should do longer-term is decouple how we fetch the
latest version number and latest source code (from the catalog of
PyPI/ELPA/etc., from Git, etc.) and how we obtain metadata (from
PyPI/ELPA/etc., from ‘requirements.txt’, etc.)  Right now, many
Python packages for example are handled by the ‘generic-git’ updater;
consequently they do not get dependency info that the ‘pypi’ updater
would get them.  Decoupling would address that.

One last thing: Crates remain out of the scope.  As I mentioned
at the Guix Days¹, I think Crates packaging as currently done is
not sustainable: this new feature won’t work for Crates, just like
‘guix refresh -l’ doesn’t work for them.  There’s Antioxydant and
there’s <https://issues.guix.gnu.org/53127>, but if nobody
champions to push these over the finish line, this will all get
out of control for good.

Thoughts?

Ludo’.

¹ https://gitlab.com/pjotrp/guix-days-fosdem-2023/-/blob/main/state-of-guix-2023.org

Ludovic Courtès (14):
  tests: pypi: Factorize tarball and wheel file creation.
  tests: http: Allow responses to specify a path.
  tests: pypi: Rewrite tests using a local HTTP server.
  import: utils: 'call-with-networking-exception-handler' doesn't
    unwind.
  import: json: Add #:timeout to 'json-fetch'.
  upstream: Replace 'input-changes' field by 'inputs'.
  diagnostics: Factorize 'absolute-location'.
  upstream: 'update-package-source' edits input fields.
  upstream: Remove <upstream-input-change> and related code.
  tests: upstream: Restore test that was skipped.
  import: cpan: Remove unary 'string-append' call.
  import: cpan: Represent dependencies as <upstream-input> records.
  import: cpan: Updater provides input list.
  import: elpa: Updater provides input list.

 guix/diagnostics.scm     |  20 +-
 guix/import/cpan.scm     | 103 +++++----
 guix/import/cran.scm     | 180 ++++++++++-----
 guix/import/elpa.scm     |  28 ++-
 guix/import/hackage.scm  |  90 +++++---
 guix/import/json.scm     |   5 +-
 guix/import/pypi.scm     | 216 ++++++++++--------
 guix/import/stackage.scm |   9 +-
 guix/import/test.scm     |  13 +-
 guix/import/utils.scm    |  33 ++-
 guix/scripts/refresh.scm |  38 +---
 guix/scripts/style.scm   |  17 --
 guix/tests/http.scm      |  46 +++-
 guix/upstream.scm        | 181 ++++++++-------
 tests/cpan.scm           |  34 ++-
 tests/cran.scm           |   2 +-
 tests/elpa.scm           |  48 +++-
 tests/guix-refresh.sh    |   7 +-
 tests/pypi.scm           | 473 +++++++++++++++++++++------------------
 tests/upstream.scm       | 199 ++--------------
 20 files changed, 946 insertions(+), 796 deletions(-)


base-commit: c5fa9dd0e96493307cc76ea098a6bca9b076e012
-- 
2.40.1





^ permalink raw reply	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 01/14] tests: pypi: Factorize tarball and wheel file creation.
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
@ 2023-05-18 15:16 ` Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 02/14] tests: http: Allow responses to specify a path Ludovic Courtès
                   ` (14 subsequent siblings)
  15 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 15:16 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès, Lars-Dominik Braun, jgart

* tests/pypi.scm (sample-directory): New variable.
(pypi-tarball, wheel-file): New procedures.
("pypi->guix-package, no wheel")
("pypi->guix-package, wheels")
("pypi->guix-package, no usable requirement file.")
("pypi->guix-package, package name contains \"-\" followed by digits"):
Use them.
---
 tests/pypi.scm | 126 ++++++++++++++++++++++++++++++++-----------------
 1 file changed, 82 insertions(+), 44 deletions(-)

diff --git a/tests/pypi.scm b/tests/pypi.scm
index 1ddcc542ff..1c85e6a16f 100644
--- a/tests/pypi.scm
+++ b/tests/pypi.scm
@@ -28,8 +28,12 @@ (define-module (test-pypi)
   #: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 build utils)
+                #:select (delete-file-recursively
+                          which mkdir-p
+                          with-directory-excursion))
   #:use-module ((guix diagnostics) #:select (guix-warning-port))
+  #:use-module ((guix build syscalls) #:select (mkdtemp!))
   #:use-module (json)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
@@ -131,6 +135,58 @@ (define test-metadata-with-extras-jedi "\
 Requires-Dist: pytest (>=3.1.0); extra == 'testing'
 ")
 
+(define sample-directory
+  ;; Directory containing tarballs and .whl files for this test.
+  (let ((template (string-append (or (getenv "TMPDIR") "/tmp")
+                                 "/guix-pypi-test-XXXXXX")))
+    (mkdtemp! template)))
+
+(define (pypi-tarball name specs)
+  "Return a PyPI tarball called NAME suffixed with '.tar.gz' and containing
+the files specified in SPECS.  Return its file name."
+  (let ((directory (in-vicinity sample-directory name))
+        (tarball (in-vicinity sample-directory (string-append name ".tar.gz"))))
+    (false-if-exception (delete-file tarball))
+    (mkdir-p directory)
+    (for-each (match-lambda
+                ((file content)
+                 (mkdir-p (in-vicinity directory (dirname file)))
+                 (call-with-output-file (in-vicinity directory file)
+                   (lambda (port)
+                     (display content port)))))
+              specs)
+    (parameterize ((current-output-port (%make-void-port "w0")))
+      (system* "tar" "-C" sample-directory "-czvf" tarball
+               (basename directory)))
+    (delete-file-recursively directory)
+    tarball))
+
+(define (wheel-file name specs)
+  "Return a Wheel file called NAME suffixed with '.whl' and containing the
+files specified by SPECS.  Return its file name."
+  (let* ((directory (in-vicinity sample-directory
+                                 (string-append name ".dist-info")))
+         (zip-file (in-vicinity sample-directory
+                                (string-append name ".zip")))
+         (whl-file (in-vicinity sample-directory
+                                (string-append name ".whl"))))
+    (false-if-exception (delete-file whl-file))
+    (mkdir-p directory)
+    (for-each (match-lambda
+                ((file content)
+                 (mkdir-p (in-vicinity directory (dirname file)))
+                 (call-with-output-file (in-vicinity directory file)
+                   (lambda (port)
+                     (display content port)))))
+              specs)
+    ;; zip always adds a "zip" extension to the file it creates,
+    ;; so we need to rename it.
+    (with-directory-excursion (dirname directory)
+      (system* "zip" "-qr" zip-file (basename directory)))
+    (rename-file zip-file whl-file)
+    (delete-file-recursively directory)
+    whl-file))
+
 \f
 (test-begin "pypi")
 
@@ -224,17 +280,13 @@ (define test-metadata-with-extras-jedi "\
            (lambda (url file-name)
              (match url
                ("https://example.com/foo-1.0.0.tar.gz"
-                (begin
-                  ;; Unusual requires.txt location should still be found.
-                  (mkdir-p "foo-1.0.0/src/bizarre.egg-info")
-                  (with-output-to-file "foo-1.0.0/src/bizarre.egg-info/requires.txt"
-                    (lambda ()
-                      (display test-requires.txt)))
-                  (parameterize ((current-output-port (%make-void-port "rw+")))
-                    (system* "tar" "czvf" file-name "foo-1.0.0/"))
-                  (delete-file-recursively "foo-1.0.0")
+                ;; Unusual requires.txt location should still be found.
+                (let ((tarball (pypi-tarball "foo-1.0.0"
+                                             `(("src/bizarre.egg-info/requires.txt"
+                                                ,test-requires.txt)))))
+                  (copy-file tarball file-name)
                   (set! test-source-hash
-                    (call-with-input-file file-name port-sha256))))
+                        (call-with-input-file file-name port-sha256))))
                ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
                (_ (error "Unexpected URL: " url)))))
           (mock ((guix http-client) http-fetch
@@ -279,28 +331,18 @@ (define test-metadata-with-extras-jedi "\
          (lambda (url file-name)
            (match url
              ("https://example.com/foo-1.0.0.tar.gz"
-              (begin
-                (mkdir-p "foo-1.0.0/foo.egg-info/")
-                (with-output-to-file "foo-1.0.0/foo.egg-info/requires.txt"
-                  (lambda ()
-                    (display "wrong data to make sure we're testing wheels ")))
-                (parameterize ((current-output-port (%make-void-port "rw+")))
-                  (system* "tar" "czvf" file-name "foo-1.0.0/"))
-                (delete-file-recursively "foo-1.0.0")
+              (let ((tarball (pypi-tarball
+                              "foo-1.0.0"
+                              '(("foo-1.0.0/foo.egg-info/requires.txt"
+                                 "wrong data \
+to make sure we're testing wheels")))))
+                (copy-file tarball file-name)
                 (set! test-source-hash
                   (call-with-input-file file-name port-sha256))))
              ("https://example.com/foo-1.0.0-py2.py3-none-any.whl"
-              (begin
-                (mkdir "foo-1.0.0.dist-info")
-                (with-output-to-file "foo-1.0.0.dist-info/METADATA"
-                  (lambda ()
-                    (display test-metadata)))
-                (let ((zip-file (string-append file-name ".zip")))
-                  ;; zip always adds a "zip" extension to the file it creates,
-                  ;; so we need to rename it.
-                  (system* "zip" "-q" zip-file "foo-1.0.0.dist-info/METADATA")
-                  (rename-file zip-file file-name))
-                (delete-file-recursively "foo-1.0.0.dist-info")))
+              (let ((wheel (wheel-file "foo-1.0.0"
+                                       `(("METADATA" ,test-metadata)))))
+                (copy-file wheel file-name)))
              (_ (error "Unexpected URL: " url)))))
         (mock ((guix http-client) http-fetch
                (lambda (url . rest)
@@ -342,12 +384,11 @@ (define test-metadata-with-extras-jedi "\
          (lambda (url file-name)
            (match url
              ("https://example.com/foo-1.0.0.tar.gz"
-              (mkdir-p "foo-1.0.0/foo.egg-info/")
-              (parameterize ((current-output-port (%make-void-port "rw+")))
-                (system* "tar" "czvf" file-name "foo-1.0.0/"))
-              (delete-file-recursively "foo-1.0.0")
-              (set! test-source-hash
-                (call-with-input-file file-name port-sha256)))
+              (let ((tarball (pypi-tarball "foo-1.0.0"
+                                           '(("foo.egg-info/.empty" "")))))
+                (copy-file tarball file-name)
+                (set! test-source-hash
+                      (call-with-input-file file-name port-sha256))))
              ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
              (_ (error "Unexpected URL: " url)))))
         (mock ((guix http-client) http-fetch
@@ -388,15 +429,11 @@ (define test-metadata-with-extras-jedi "\
          (lambda (url file-name)
            (match url
              ("https://example.com/foo-99-1.0.0.tar.gz"
-              (begin
+              (let ((tarball (pypi-tarball "foo-99-1.0.0"
+                                           `(("src/bizarre.egg-info/requires.txt"
+                                              ,test-requires.txt)))))
                 ;; Unusual requires.txt location should still be found.
-                (mkdir-p "foo-99-1.0.0/src/bizarre.egg-info")
-                (with-output-to-file "foo-99-1.0.0/src/bizarre.egg-info/requires.txt"
-                  (lambda ()
-                    (display test-requires.txt)))
-                (parameterize ((current-output-port (%make-void-port "rw+")))
-                  (system* "tar" "czvf" file-name "foo-99-1.0.0/"))
-                (delete-file-recursively "foo-99-1.0.0")
+                (copy-file tarball file-name)
                 (set! test-source-hash
                   (call-with-input-file file-name port-sha256))))
              ("https://example.com/foo-99-1.0.0-py2.py3-none-any.whl" #f)
@@ -434,3 +471,4 @@ (define test-metadata-with-extras-jedi "\
                  (pk 'fail x #f))))))
 
 (test-end "pypi")
+(delete-file-recursively sample-directory)
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 02/14] tests: http: Allow responses to specify a path.
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 01/14] tests: pypi: Factorize tarball and wheel file creation Ludovic Courtès
@ 2023-05-18 15:16 ` Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 03/14] tests: pypi: Rewrite tests using a local HTTP server Ludovic Courtès
                   ` (13 subsequent siblings)
  15 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 15:16 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain; charset=^[[6~, Size: 4419 bytes --]

* guix/tests/http.scm (%local-url): Add #:path parameter and honor it.
(call-with-http-server)[responses]: Add extra clause with 'path'.
[bad-request]: New variable.
[server-body]: Handle three-element clauses.
Wrap 'run-server' call in 'parameterize'.
---
 guix/tests/http.scm | 46 +++++++++++++++++++++++++++++++++++++++------
 1 file changed, 40 insertions(+), 6 deletions(-)

diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index 37e5744353..17485df9ef 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2017, 2019, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -21,7 +21,10 @@ (define-module (guix tests http)
   #:use-module (ice-9 threads)
   #:use-module (web server)
   #:use-module (web server http)
+  #:use-module (web request)
   #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (ice-9 match)
   #:export (with-http-server
@@ -60,12 +63,13 @@ (define (open-http-server-socket)
                 (strerror err))
         (values #f #f)))))
 
-(define* (%local-url #:optional (port (%http-server-port)))
+(define* (%local-url #:optional (port (%http-server-port))
+                     #:key (path "/foo/bar"))
   (when (= port 0)
     (error "no web server is running!"))
   ;; URL to use for 'home-page' tests.
   (string-append "http://localhost:" (number->string port)
-                 "/foo/bar"))
+                 path))
 
 (define* (call-with-http-server responses+data thunk)
   "Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
@@ -81,6 +85,18 @@ (define* (call-with-http-server responses+data thunk)
            (((? integer? code) data)
             (list (build-response #:code code
                                   #:reason-phrase "Such is life")
+                  data))
+           (((? string? path) (? integer? code) data)
+            (list path
+                  (build-response #:code code
+                                  #:headers
+                                  (if (string? data)
+                                      '()
+                                      '((content-type ;binary data
+                                         . (application/octet-stream
+                                            (charset
+                                             . "ISO-8859-1")))))
+                                  #:reason-phrase "Such is life")
                   data)))
          responses+data))
 
@@ -116,19 +132,37 @@ (define* (call-with-http-server responses+data thunk)
     http-write
     (@@ (web server http) http-close))
 
+  (define bad-request
+    (build-response #:code 400 #:reason-phrase "Unexpected request"))
+
   (define (server-body)
     (define (handle request body)
       (match responses
         (((response data) rest ...)
          (set! responses rest)
-         (values response data))))
+         (values response data))
+        ((((? string?) response data) ...)
+         (let ((path (uri-path (request-uri request))))
+           (match (assoc path responses)
+             (#f (values bad-request ""))
+             ((_ response data)
+              (if (eq? 'GET (request-method request))
+                  ;; Note: Use 'assoc-remove!' to remove only the first entry
+                  ;; with PATH as its key.  That way, RESPONSES can contain
+                  ;; the same path several times.
+                  (let ((rest (assoc-remove! responses path)))
+                    (set! responses rest)
+                    (values response data))
+                  (values bad-request ""))))))))
 
     (let-values (((socket port) (open-http-server-socket)))
       (set! %http-real-server-port port)
       (catch 'quit
         (lambda ()
-          (run-server handle stub-http-server
-                      `(#:socket ,socket)))
+          ;; Let HANDLE refer to '%http-server-port' if needed.
+          (parameterize ((%http-server-port %http-real-server-port))
+            (run-server handle stub-http-server
+                        `(#:socket ,socket))))
         (lambda _
           (close-port socket)))))
 
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 03/14] tests: pypi: Rewrite tests using a local HTTP server.
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 01/14] tests: pypi: Factorize tarball and wheel file creation Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 02/14] tests: http: Allow responses to specify a path Ludovic Courtès
@ 2023-05-18 15:16 ` Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 04/14] import: utils: 'call-with-networking-exception-handler' doesn't unwind Ludovic Courtès
                   ` (12 subsequent siblings)
  15 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 15:16 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès, Lars-Dominik Braun, jgart

* guix/import/pypi.scm (%pypi-base-url): New variable.
(pypi-fetch): Use it.
* tests/pypi.scm (foo-json): Compute URLs relative to '%local-url'.
(test-json-1, test-json-2, test-source-hash): Remove.
(file-dump): New procedure.
(with-pypi): New macro.
("pypi->guix-package, no wheel")
("pypi->guix-package, wheels")
("pypi->guix-package, no usable requirement file.")
("pypi->guix-package, package name contains \"-\" followed by digits"):
Rewrite using 'with-pypi'.
---
 guix/import/pypi.scm |   9 +-
 tests/pypi.scm       | 353 +++++++++++++++++++------------------------
 2 files changed, 160 insertions(+), 202 deletions(-)

diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index f780bf1f15..8c06b19cff 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -55,7 +55,8 @@ (define-module (guix import pypi)
   #:use-module (guix packages)
   #:use-module (guix upstream)
   #:use-module ((guix licenses) #:prefix license:)
-  #:export (parse-requires.txt
+  #:export (%pypi-base-url
+            parse-requires.txt
             parse-wheel-metadata
             specification->requirement-name
             guix-package->pypi-name
@@ -67,6 +68,10 @@ (define-module (guix import pypi)
 ;; The PyPI API (notice the rhyme) is "documented" at:
 ;; <https://warehouse.readthedocs.io/api-reference/json/>.
 
+(define %pypi-base-url
+  ;; Base URL of the PyPI API.
+  (make-parameter "https://pypi.org/pypi/"))
+
 (define non-empty-string-or-false
   (match-lambda
     ("" #f)
@@ -123,7 +128,7 @@ (define-json-mapping <distribution> make-distribution distribution?
 
 (define (pypi-fetch name)
   "Return a <pypi-project> record for package NAME, or #f on failure."
-  (and=> (json-fetch (string-append "https://pypi.org/pypi/" name "/json"))
+  (and=> (json-fetch (string-append (%pypi-base-url) name "/json"))
          json->pypi-project))
 
 ;; For packages found on PyPI that lack a source distribution.
diff --git a/tests/pypi.scm b/tests/pypi.scm
index 1c85e6a16f..497744511f 100644
--- a/tests/pypi.scm
+++ b/tests/pypi.scm
@@ -27,10 +27,11 @@ (define-module (test-pypi)
   #:use-module (guix utils)
   #:use-module (gcrypt hash)
   #:use-module (guix tests)
+  #:use-module (guix tests http)
   #:use-module (guix build-system python)
   #:use-module ((guix build utils)
                 #:select (delete-file-recursively
-                          which mkdir-p
+                          which mkdir-p dump-port
                           with-directory-excursion))
   #:use-module ((guix diagnostics) #:select (guix-warning-port))
   #:use-module ((guix build syscalls) #:select (mkdtemp!))
@@ -57,25 +58,19 @@ (define* (foo-json #:key (name "foo") (name-in-url #f))
      (urls . #())
      (releases
       . ((1.0.0
-          . #(((url . ,(format #f "https://example.com/~a-1.0.0.egg"
+          . #(((url . ,(format #f "~a/~a-1.0.0.egg"
+                               (%local-url #:path "")
                                (or name-in-url name)))
                (packagetype . "bdist_egg"))
-              ((url . ,(format #f "https://example.com/~a-1.0.0.tar.gz"
+              ((url . ,(format #f "~a/~a-1.0.0.tar.gz"
+                               (%local-url #:path "")
                                (or name-in-url name)))
                (packagetype . "sdist"))
-              ((url . ,(format #f "https://example.com/~a-1.0.0-py2.py3-none-any.whl"
+              ((url . ,(format #f "~a/~a-1.0.0-py2.py3-none-any.whl"
+                               (%local-url #:path "")
                                (or name-in-url name)))
                (packagetype . "bdist_wheel")))))))))
 
-(define test-json-1
-  (foo-json))
-
-(define test-json-2
-  (foo-json #:name "foo-99"))
-
-(define test-source-hash
-  "")
-
 (define test-specifications
   '("Fizzy [foo, bar]"
     "PickyThing<1.6,>1.9,!=1.9.6,<2.0a0,==2.4c1"
@@ -187,6 +182,18 @@ (define (wheel-file name specs)
     (delete-file-recursively directory)
     whl-file))
 
+(define (file-dump file)
+  "Return a procedure that dumps FILE to the given port."
+  (lambda (output)
+    (call-with-input-file file
+      (lambda (input)
+        (dump-port input output)))))
+
+(define-syntax-rule (with-pypi responses body ...)
+  (with-http-server responses
+    (parameterize ((%pypi-base-url (%local-url #:path "/")))
+      body ...)))
+
 \f
 (test-begin "pypi")
 
@@ -275,200 +282,146 @@ (define (wheel-file name specs)
    "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
-           (lambda (url file-name)
-             (match url
-               ("https://example.com/foo-1.0.0.tar.gz"
-                ;; Unusual requires.txt location should still be found.
-                (let ((tarball (pypi-tarball "foo-1.0.0"
-                                             `(("src/bizarre.egg-info/requires.txt"
-                                                ,test-requires.txt)))))
-                  (copy-file tarball file-name)
-                  (set! test-source-hash
-                        (call-with-input-file file-name port-sha256))))
-               ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
-               (_ (error "Unexpected URL: " url)))))
-          (mock ((guix http-client) http-fetch
-                 (lambda (url . rest)
-                   (match url
-                     ("https://pypi.org/pypi/foo/json"
-                      (values (open-input-string test-json-1)
-                              (string-length test-json-1)))
-                     ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
-                     (_ (error "Unexpected URL: " url)))))
-                (match (pypi->guix-package "foo")
-                  (('package
-                     ('name "python-foo")
-                     ('version "1.0.0")
-                     ('source ('origin
-                                ('method 'url-fetch)
-                                ('uri ('pypi-uri "foo" 'version))
-                                ('sha256
-                                 ('base32
-                                  (? string? hash)))))
-                     ('build-system 'pyproject-build-system)
-                     ('propagated-inputs ('list 'python-bar 'python-foo))
-                     ('native-inputs ('list 'python-pytest))
-                     ('home-page "http://example.com")
-                     ('synopsis "summary")
-                     ('description "summary")
-                     ('license 'license:lgpl2.0))
-                   (and (string=? (bytevector->nix-base32-string
-                                   test-source-hash)
-                                  hash)
-                        (equal? (pypi->guix-package "foo" #:version "1.0.0")
-                                (pypi->guix-package "foo"))
-                        (guard (c ((error? c) #t))
-                          (pypi->guix-package "foo" #:version "42"))))
-                  (x
-                   (pk 'fail x #f))))))
+  (let ((tarball (pypi-tarball
+                  "foo-1.0.0"
+                  `(("src/bizarre.egg-info/requires.txt"
+                     ,test-requires.txt))))
+        (twice (lambda (lst) (append lst lst))))
+    (with-pypi (twice `(("/foo-1.0.0.tar.gz" 200 ,(file-dump tarball))
+                        ("/foo-1.0.0-py2.py3-none-any.whl" 404 "")
+                        ("/foo/json" 200 ,(lambda (port)
+                                            (display (foo-json) port)))))
+      (match (pypi->guix-package "foo")
+        (('package
+           ('name "python-foo")
+           ('version "1.0.0")
+           ('source ('origin
+                      ('method 'url-fetch)
+                      ('uri ('pypi-uri "foo" 'version))
+                      ('sha256
+                       ('base32
+                        (? string? hash)))))
+           ('build-system 'pyproject-build-system)
+           ('propagated-inputs ('list 'python-bar 'python-foo))
+           ('native-inputs ('list 'python-pytest))
+           ('home-page "http://example.com")
+           ('synopsis "summary")
+           ('description "summary")
+           ('license 'license:lgpl2.0))
+         (and (string=? (bytevector->nix-base32-string
+                         (file-sha256 tarball))
+                        hash)
+              (equal? (pypi->guix-package "foo" #:version "1.0.0")
+                      (pypi->guix-package "foo"))
+              (guard (c ((error? c) #t))
+                (pypi->guix-package "foo" #:version "42"))))
+        (x
+         (pk 'fail x #f))))))
 
 (test-skip (if (which "zip") 0 1))
 (test-assert "pypi->guix-package, wheels"
-  ;; Replace network resources with sample data.
-  (mock ((guix import utils) url-fetch
-         (lambda (url file-name)
-           (match url
-             ("https://example.com/foo-1.0.0.tar.gz"
-              (let ((tarball (pypi-tarball
-                              "foo-1.0.0"
-                              '(("foo-1.0.0/foo.egg-info/requires.txt"
-                                 "wrong data \
-to make sure we're testing wheels")))))
-                (copy-file tarball file-name)
-                (set! test-source-hash
-                  (call-with-input-file file-name port-sha256))))
-             ("https://example.com/foo-1.0.0-py2.py3-none-any.whl"
-              (let ((wheel (wheel-file "foo-1.0.0"
-                                       `(("METADATA" ,test-metadata)))))
-                (copy-file wheel file-name)))
-             (_ (error "Unexpected URL: " url)))))
-        (mock ((guix http-client) http-fetch
-               (lambda (url . rest)
-                 (match url
-                   ("https://pypi.org/pypi/foo/json"
-                    (values (open-input-string test-json-1)
-                            (string-length test-json-1)))
-                   ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
-                   (_ (error "Unexpected URL: " url)))))
-              ;; Not clearing the memoization cache here would mean returning the value
-              ;; computed in the previous test.
-              (invalidate-memoization! pypi->guix-package)
-              (match (pypi->guix-package "foo")
-                (('package
-                   ('name "python-foo")
-                   ('version "1.0.0")
-                   ('source ('origin
-                              ('method 'url-fetch)
-                              ('uri ('pypi-uri "foo" 'version))
-                              ('sha256
-                               ('base32
-                                (? string? hash)))))
-                   ('build-system 'pyproject-build-system)
-                   ('propagated-inputs ('list 'python-bar 'python-baz))
-                   ('native-inputs ('list 'python-pytest))
-                   ('home-page "http://example.com")
-                   ('synopsis "summary")
-                   ('description "summary")
-                   ('license 'license:lgpl2.0))
-                 (string=? (bytevector->nix-base32-string
-                            test-source-hash)
-                           hash))
-                (x
-                 (pk 'fail x #f))))))
+  (let ((tarball (pypi-tarball
+                  "foo-1.0.0"
+                  '(("foo-1.0.0/foo.egg-info/requires.txt"
+                     "wrong data \
+to make sure we're testing wheels"))))
+        (wheel (wheel-file "foo-1.0.0"
+                           `(("METADATA" ,test-metadata)))))
+    (with-pypi `(("/foo-1.0.0.tar.gz" 200 ,(file-dump tarball))
+                 ("/foo-1.0.0-py2.py3-none-any.whl"
+                  200 ,(file-dump wheel))
+                 ("/foo/json" 200 ,(lambda (port)
+                                     (display (foo-json) port))))
+      ;; Not clearing the memoization cache here would mean returning the value
+      ;; computed in the previous test.
+      (invalidate-memoization! pypi->guix-package)
+      (match (pypi->guix-package "foo")
+        (('package
+           ('name "python-foo")
+           ('version "1.0.0")
+           ('source ('origin
+                      ('method 'url-fetch)
+                      ('uri ('pypi-uri "foo" 'version))
+                      ('sha256
+                       ('base32
+                        (? string? hash)))))
+           ('build-system 'pyproject-build-system)
+           ('propagated-inputs ('list 'python-bar 'python-baz))
+           ('native-inputs ('list 'python-pytest))
+           ('home-page "http://example.com")
+           ('synopsis "summary")
+           ('description "summary")
+           ('license 'license:lgpl2.0))
+         (string=? (bytevector->nix-base32-string (file-sha256 tarball))
+                   hash))
+        (x
+         (pk 'fail x #f))))))
 
 (test-assert "pypi->guix-package, no usable requirement file."
-  ;; Replace network resources with sample data.
-  (mock ((guix import utils) url-fetch
-         (lambda (url file-name)
-           (match url
-             ("https://example.com/foo-1.0.0.tar.gz"
-              (let ((tarball (pypi-tarball "foo-1.0.0"
-                                           '(("foo.egg-info/.empty" "")))))
-                (copy-file tarball file-name)
-                (set! test-source-hash
-                      (call-with-input-file file-name port-sha256))))
-             ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
-             (_ (error "Unexpected URL: " url)))))
-        (mock ((guix http-client) http-fetch
-               (lambda (url . rest)
-                 (match url
-                   ("https://pypi.org/pypi/foo/json"
-                    (values (open-input-string test-json-1)
-                            (string-length test-json-1)))
-                   ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
-                   (_ (error "Unexpected URL: " url)))))
-              ;; Not clearing the memoization cache here would mean returning the value
-              ;; computed in the previous test.
-              (invalidate-memoization! pypi->guix-package)
-              (match (pypi->guix-package "foo")
-                (('package
-                   ('name "python-foo")
-                   ('version "1.0.0")
-                   ('source ('origin
-                              ('method 'url-fetch)
-                              ('uri ('pypi-uri "foo" 'version))
-                              ('sha256
-                               ('base32
-                                (? string? hash)))))
-                   ('build-system 'pyproject-build-system)
-                   ('home-page "http://example.com")
-                   ('synopsis "summary")
-                   ('description "summary")
-                   ('license 'license:lgpl2.0))
-                 (string=? (bytevector->nix-base32-string
-                            test-source-hash)
-                           hash))
-                (x
-                 (pk 'fail x #f))))))
+  (let ((tarball (pypi-tarball "foo-1.0.0"
+                               '(("foo.egg-info/.empty" "")))))
+    (with-pypi `(("/foo-1.0.0.tar.gz" 200 ,(file-dump tarball))
+                 ("/foo-1.0.0-py2.py3-none-any.whl" 404 "")
+                 ("/foo/json" 200 ,(lambda (port)
+                                     (display (foo-json) port))))
+      ;; Not clearing the memoization cache here would mean returning the
+      ;; value computed in the previous test.
+      (invalidate-memoization! pypi->guix-package)
+      (match (pypi->guix-package "foo")
+        (('package
+           ('name "python-foo")
+           ('version "1.0.0")
+           ('source ('origin
+                      ('method 'url-fetch)
+                      ('uri ('pypi-uri "foo" 'version))
+                      ('sha256
+                       ('base32
+                        (? string? hash)))))
+           ('build-system 'pyproject-build-system)
+           ('home-page "http://example.com")
+           ('synopsis "summary")
+           ('description "summary")
+           ('license 'license:lgpl2.0))
+         (string=? (bytevector->nix-base32-string (file-sha256 tarball))
+                   hash))
+        (x
+         (pk 'fail x #f))))))
 
 (test-assert "pypi->guix-package, package name contains \"-\" followed by digits"
-  ;; Replace network resources with sample data.
-  (mock ((guix import utils) url-fetch
-         (lambda (url file-name)
-           (match url
-             ("https://example.com/foo-99-1.0.0.tar.gz"
-              (let ((tarball (pypi-tarball "foo-99-1.0.0"
-                                           `(("src/bizarre.egg-info/requires.txt"
-                                              ,test-requires.txt)))))
-                ;; Unusual requires.txt location should still be found.
-                (copy-file tarball file-name)
-                (set! test-source-hash
-                  (call-with-input-file file-name port-sha256))))
-             ("https://example.com/foo-99-1.0.0-py2.py3-none-any.whl" #f)
-             (_ (error "Unexpected URL: " url)))))
-        (mock ((guix http-client) http-fetch
-               (lambda (url . rest)
-                 (match url
-                   ("https://pypi.org/pypi/foo-99/json"
-                    (values (open-input-string test-json-2)
-                            (string-length test-json-2)))
-                   ("https://example.com/foo-99-1.0.0-py2.py3-none-any.whl" #f)
-                   (_ (error "Unexpected URL: " url)))))
-              (match (pypi->guix-package "foo-99")
-                (('package
-                   ('name "python-foo-99")
-                   ('version "1.0.0")
-                   ('source ('origin
-                              ('method 'url-fetch)
-                              ('uri ('pypi-uri "foo-99" 'version))
-                              ('sha256
-                               ('base32
-                                (? string? hash)))))
-                   ('properties ('quote (("upstream-name" . "foo-99"))))
-                   ('build-system 'pyproject-build-system)
-                   ('propagated-inputs ('list 'python-bar 'python-foo))
-                   ('native-inputs ('list 'python-pytest))
-                   ('home-page "http://example.com")
-                   ('synopsis "summary")
-                   ('description "summary")
-                   ('license 'license:lgpl2.0))
-                 (string=? (bytevector->nix-base32-string
-                            test-source-hash)
-                           hash))
-                (x
-                 (pk 'fail x #f))))))
+  (let ((tarball (pypi-tarball "foo-99-1.0.0"
+                               `(("src/bizarre.egg-info/requires.txt"
+                                  ,test-requires.txt)))))
+    (with-pypi `(("/foo-99-1.0.0.tar.gz" 200 ,(file-dump tarball))
+                 ("/foo-99-1.0.0-py2.py3-none-any.whl" 404 "")
+                 ("/foo-99/json" 200 ,(lambda (port)
+                                        (display (foo-json #:name "foo-99")
+                                                 port))))
+      (match (pypi->guix-package "foo-99")
+        (('package
+           ('name "python-foo-99")
+           ('version "1.0.0")
+           ('source ('origin
+                      ('method 'url-fetch)
+                      ('uri ('pypi-uri "foo-99" 'version))
+                      ('sha256
+                       ('base32
+                        (? string? hash)))))
+           ('properties ('quote (("upstream-name" . "foo-99"))))
+           ('build-system 'pyproject-build-system)
+           ('propagated-inputs ('list 'python-bar 'python-foo))
+           ('native-inputs ('list 'python-pytest))
+           ('home-page "http://example.com")
+           ('synopsis "summary")
+           ('description "summary")
+           ('license 'license:lgpl2.0))
+         (string=? (bytevector->nix-base32-string (file-sha256 tarball))
+                   hash))
+        (x
+         (pk 'fail x #f))))))
 
 (test-end "pypi")
 (delete-file-recursively sample-directory)
+
+;; Local Variables:
+;; eval: (put 'with-pypi 'scheme-indent-function 1)
+;; End:
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 04/14] import: utils: 'call-with-networking-exception-handler' doesn't unwind.
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
                   ` (2 preceding siblings ...)
  2023-05-18 15:16 ` [bug#63571] [PATCH 03/14] tests: pypi: Rewrite tests using a local HTTP server Ludovic Courtès
@ 2023-05-18 15:16 ` Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 05/14] import: json: Add #:timeout to 'json-fetch' Ludovic Courtès
                   ` (11 subsequent siblings)
  15 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 15:16 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès

That way backtraces show where the error actually originates from.

* guix/import/utils.scm (call-with-networking-exception-handler):
Rewrite using 'with-exception-handler'.
---
 guix/import/utils.scm | 33 +++++++++++++++++++++------------
 1 file changed, 21 insertions(+), 12 deletions(-)

diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 177817b10c..e9a0a7ecd7 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -45,6 +45,7 @@ (define-module (guix import utils)
   #:use-module (guix sets)
   #:use-module ((guix ui) #:select (fill-paragraph))
   #:use-module (gnu packages)
+  #:autoload   (ice-9 control) (let/ec)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 receive)
@@ -126,18 +127,26 @@ (define (flatten lst)
 (define (call-with-networking-exception-handler thunk)
   "Invoke THUNK, returning #f if one of the usual networking exception is
 thrown."
-  (catch #t
-    (lambda ()
-      (guard (c ((http-get-error? c) #f))
-        (thunk)))
-    (lambda (key . args)
-      ;; Return false and move on upon connection failures and bogus HTTP
-      ;; servers.
-      (unless (memq key '(gnutls-error tls-certificate-error
-                                       system-error getaddrinfo-error
-                                       bad-header bad-header-component))
-        (apply throw key args))
-      #f)))
+  (let/ec return
+    (with-exception-handler
+        (lambda (exception)
+          (cond ((http-get-error? exception)
+                 (return #f))
+                (((exception-predicate &exception-with-kind-and-args) exception)
+                 ;; Return false and move on upon connection failures and bogus
+                 ;; HTTP servers.
+                 (if (memq (exception-kind exception)
+                           '(gnutls-error tls-certificate-error
+                                          system-error getaddrinfo-error
+                                          bad-header bad-header-component))
+                     (return #f)
+                     (raise-exception exception)))
+                (else
+                 (raise-exception exception))))
+      thunk
+
+      ;; Do not unwind to preserve meaningful backtraces.
+      #:unwind? #f)))
 
 (define-syntax-rule (false-if-networking-error exp)
   "Evaluate EXP, returning #f if a networking-related exception is thrown."
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 05/14] import: json: Add #:timeout to 'json-fetch'.
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
                   ` (3 preceding siblings ...)
  2023-05-18 15:16 ` [bug#63571] [PATCH 04/14] import: utils: 'call-with-networking-exception-handler' doesn't unwind Ludovic Courtès
@ 2023-05-18 15:16 ` Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 06/14] upstream: Replace 'input-changes' field by 'inputs' Ludovic Courtès
                   ` (10 subsequent siblings)
  15 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 15:16 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain; charset=^[[6~, Size: 1464 bytes --]

* guix/import/json.scm (json-fetch): Add #:timeout and pass it to
'http-fetch'.
---
 guix/import/json.scm | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/guix/import/json.scm b/guix/import/json.scm
index ae00ee929e..b87e9918c5 100644
--- a/guix/import/json.scm
+++ b/guix/import/json.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015, 2016 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -37,6 +37,7 @@ (define-module (guix import json)
 (define* (json-fetch url
                      #:key
                      (http-fetch http-fetch)
+                     (timeout 10)
                      ;; Note: many websites returns 403 if we omit a
                      ;; 'User-Agent' header.
                      (headers `((user-agent . "GNU Guile")
@@ -50,7 +51,7 @@ (define* (json-fetch url
                     (or (= 403 error)
                         (= 404 error))))
              #f))
-    (let* ((port   (http-fetch url #:headers headers))
+    (let* ((port   (http-fetch url #:timeout timeout #:headers headers))
            (result (json->scm port)))
       (close-port port)
       result)))
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 06/14] upstream: Replace 'input-changes' field by 'inputs'.
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
                   ` (4 preceding siblings ...)
  2023-05-18 15:16 ` [bug#63571] [PATCH 05/14] import: json: Add #:timeout to 'json-fetch' Ludovic Courtès
@ 2023-05-18 15:16 ` Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 07/14] diagnostics: Factorize 'absolute-location' Ludovic Courtès
                   ` (9 subsequent siblings)
  15 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 15:16 UTC (permalink / raw)
  To: 63571
  Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret,
	Lars-Dominik Braun, Ludovic Courtès, Mathieu Othacehe,
	Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice, jgart

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain; charset=^[[6~, Size: 56329 bytes --]

Returning the expected list of inputs rather than changes relative to
the current package definition is less ambiguous and offers more
possibilities for further processing.

* guix/upstream.scm (<upstream-source>)[input-changes]: Remove.
[inputs]: New field.
(<upstream-input>): New record type.
* guix/upstream.scm (upstream-input-type-predicate)
(input-type-filter, upstream-source-regular-inputs)
(upstream-source-native-inputs, upstream-source-propagated-inputs): New
procedures.
(changed-inputs): Expect an <upstream-source> as its second argument.
Adjust accordingly.
* guix/import/pypi.scm (distribution-sha256): New procedure.
(maybe-inputs): Expect a list of <upstream-input>.
(compute-inputs): Rewrite to return a list of <upstream-input>.
(pypi-package-inputs, pypi-package->upstream-source): New procedures.
(make-pypi-sexp): Use it.
* guix/import/stackage.scm (latest-lts-release): Define 'cabal'.
Replace 'input-changes' field by 'inputs'.
* guix/scripts/refresh.scm (update-package): Use 'changed-inputs'
instead of 'upstream-source-input-changes'.
* tests/cran.scm ("description->package"): Adjust order of inputs.
* tests/pypi.scm (default-sha256, default-sha256/base32): New variables.
(foo-json): Add 'digests' entry.
("pypi->guix-package, no wheel"): Check HASH against DEFAULT-SHA256/BASE32.
("pypi->guix-package, wheels"): Likewise.
("pypi->guix-package, no usable requirement file."): Likewise.
("pypi->guix-package, package name contains \"-\" followed by digits"):
Likewise.
("package-latest-release"): New test.
* tests/upstream.scm (test-package-sexp): Remove.
("changed-inputs returns no changes"): Rewrite to use <upstream-source>.
(test-new-package-sexp): Remove.
("changed-inputs returns changes to plain input list"): Rewrite.
("changed-inputs returns changes to all plain input lists"): Likewise.
("changed-inputs returns changes to labelled input list")
("changed-inputs returns changes to all labelled input lists"): Remove.
* guix/import/cran.scm (maybe-inputs): Expect PACKAGE-INPUTS to be a
list of <upstream-input>.
(source-dir->dependencies): Return a list of <upstream-input>.
(vignette-builders): Likewise.
(uri-helper, cran-package-source-url)
(cran-package-propagated-inputs, cran-package-inputs): New procedures.
(description->package): Use them instead of local definitions.
(latest-cran-release): Replace 'input-changes' field by 'inputs'.
(latest-bioconductor-release): Likewise.
* guix/import/hackage.scm (cabal-package-inputs): New procedure.
(hackage-module->sexp): Use it.
[maybe-inputs]: Expect a list of <upstream-input>.
---
 guix/import/cran.scm     | 180 +++++++++++++++++++++++-----------
 guix/import/hackage.scm  |  90 ++++++++++-------
 guix/import/pypi.scm     | 207 +++++++++++++++++++++++----------------
 guix/import/stackage.scm |   9 +-
 guix/scripts/refresh.scm |   4 +-
 guix/upstream.scm        | 163 ++++++++++++++++++------------
 tests/cran.scm           |   2 +-
 tests/pypi.scm           |  62 ++++++++++--
 tests/upstream.scm       | 140 ++++++++++----------------
 9 files changed, 508 insertions(+), 349 deletions(-)

diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index bb271634ed..40bad08407 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015-2023 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015-2017, 2019-2021, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
@@ -174,14 +174,16 @@ (define (format-inputs names)
             (string->symbol name))))
        (sort names string-ci<?)))
 
-(define* (maybe-inputs package-inputs #:optional (type 'inputs))
+(define* (maybe-inputs package-inputs #:optional (input-type 'inputs))
   "Given a list of PACKAGE-INPUTS, tries to generate the TYPE field of a
 package definition."
   (match package-inputs
     (()
      '())
     ((package-inputs ...)
-     `((,type (list ,@(format-inputs package-inputs)))))))
+     `((,input-type (list ,@(map (compose string->symbol
+                                          upstream-input-downstream-name)
+                                 package-inputs)))))))
 
 (define %cran-url "https://cran.r-project.org/web/packages/")
 (define %cran-canonical-url "https://cran.r-project.org/package=")
@@ -520,14 +522,29 @@ (define (directory-needs-pkg-config? dir)
                         "(Makevars.*|configure.*)"))
 
 (define (source-dir->dependencies dir)
-  "Guess dependencies of R package source in DIR and return two values: a list
-of package names for INPUTS and another list of names of NATIVE-INPUTS."
-  (values
-   (needed-libraries-in-directory dir)
-   (append
-       (if (directory-needs-esbuild? dir) '("esbuild") '())
-       (if (directory-needs-pkg-config? dir) '("pkg-config") '())
-       (if (directory-needs-fortran? dir) '("gfortran") '()))))
+  "Guess dependencies of R package source in DIR and return a list of
+<upstream-input> corresponding to the dependencies guessed from source files
+in DIR."
+  (define (native name)
+    (upstream-input
+     (name name)
+     (downstream-name name)
+     (type 'native)))
+
+  (append (map (lambda (name)
+                 (upstream-input
+                  (name name)
+                  (downstream-name (cran-guix-name name))))
+               (needed-libraries-in-directory dir))
+          (if (directory-needs-esbuild? dir)
+              (list (native "esbuild"))
+              '())
+          (if (directory-needs-pkg-config? dir)
+              (list (native "pkg-config"))
+              '())
+          (if (directory-needs-fortran? dir)
+              (list (native "gfortran"))
+              '())))
 
 (define (source->dependencies source tarball?)
   "SOURCE-DIR->DEPENDENCIES, but for directories and tarballs as indicated
@@ -541,7 +558,75 @@ (define (source->dependencies source tarball?)
     (source-dir->dependencies source)))
 
 (define (vignette-builders meta)
-  (map cran-guix-name (listify meta "VignetteBuilder")))
+  (map (lambda (name)
+         (upstream-input
+          (name name)
+          (downstream-name (cran-guix-name name))
+          (type 'native)))
+       (listify meta "VignetteBuilder")))
+
+(define (uri-helper repository)
+  (match repository
+    ('cran         cran-uri)
+    ('bioconductor bioconductor-uri)
+    ('git          #f)
+    ('hg           #f)))
+
+(define (cran-package-source-url meta repository)
+  "Return the URL of the source code referred to by META, a package in
+REPOSITORY."
+  (case repository
+    ((git) (assoc-ref meta 'git))
+    ((hg)  (assoc-ref meta 'hg))
+    (else
+     (match (apply (uri-helper repository)
+                   (assoc-ref meta "Package")
+                   (assoc-ref meta "Version")
+                   (case repository
+                     ((bioconductor)
+                      (list (assoc-ref meta 'bioconductor-type)))
+                     (else '())))
+       ((urls ...) urls)
+       ((? string? url) url)
+       (_ #f)))))
+
+(define (cran-package-propagated-inputs meta)
+  "Return the list of <upstream-input> derived from dependency information in
+META."
+  (filter-map (lambda (name)
+                (and (not (member name
+                                  (append default-r-packages invalid-packages)))
+                     (upstream-input
+                      (name name)
+                      (downstream-name (cran-guix-name name))
+                      (type 'propagated))))
+              (lset-union equal?
+                          (listify meta "Imports")
+                          (listify meta "LinkingTo")
+                          (delete "R" (listify meta "Depends")))))
+
+(define* (cran-package-inputs meta repository
+                              #:key (download-source download))
+  "Return the list of <upstream-input> corresponding to all the dependencies
+of META, a package in REPOSITORY."
+  (let* ((url    (cran-package-source-url meta repository))
+         (source (download-source url
+                                  #:method
+                                  (cond ((assoc-ref meta 'git) 'git)
+                                        ((assoc-ref meta 'hg) 'hg)
+                                        (else #f))))
+         (tarball? (not (or (assoc-ref meta 'git)
+                            (assoc-ref meta 'hg)))))
+    (append (source->dependencies source tarball?)
+            (filter-map (lambda (name)
+                          (and (not (member name invalid-packages))
+                               (upstream-input
+                                (name name)
+                                (downstream-name (transform-sysname name)))))
+                        (map string-downcase
+                             (listify meta "SystemRequirements")))
+            (cran-package-propagated-inputs meta)
+            (vignette-builders meta))))
 
 (define* (description->package repository meta #:key (license-prefix identity)
                                (download-source download))
@@ -556,11 +641,6 @@ (define* (description->package repository meta #:key (license-prefix identity)
                                ((cran)         %cran-canonical-url)
                                ((bioconductor) %bioconductor-url)
                                ((git)          #f)))
-         (uri-helper (case repository
-                       ((cran)         cran-uri)
-                       ((bioconductor) bioconductor-uri)
-                       ((git)          #f)
-                       ((hg)           #f)))
          (name       (assoc-ref meta "Package"))
          (synopsis   (assoc-ref meta "Title"))
          (version    (assoc-ref meta "Version"))
@@ -572,40 +652,16 @@ (define* (description->package repository meta #:key (license-prefix identity)
                        (else (match (listify meta "URL")
                                ((url rest ...) url)
                                (_ (string-append canonical-url-base name))))))
-         (source-url (case repository
-                       ((git) (assoc-ref meta 'git))
-                       ((hg)  (assoc-ref meta 'hg))
-                       (else
-                        (match (apply uri-helper name version
-                                      (case repository
-                                        ((bioconductor)
-                                         (list (assoc-ref meta 'bioconductor-type)))
-                                        (else '())))
-                          ((urls ...) urls)
-                          ((? string? url) url)
-                          (_ #f)))))
+         (source-url (cran-package-source-url meta repository))
          (git?       (if (assoc-ref meta 'git) #true #false))
          (hg?        (if (assoc-ref meta 'hg) #true #false))
          (source     (download-source source-url #:method (cond
                                                            (git? 'git)
                                                            (hg? 'hg)
                                                            (else #f))))
-         (tarball?   (not (or git? hg?)))
-         (source-inputs source-native-inputs
-          (source->dependencies source tarball?))
-         (sysdepends (append
-                      source-inputs
-                      (filter (lambda (name)
-                                (not (member name invalid-packages)))
-                              (map string-downcase (listify meta "SystemRequirements")))))
-         (propagate  (filter (lambda (name)
-                               (not (member name (append default-r-packages
-                                                         invalid-packages))))
-                             (lset-union equal?
-                                         (listify meta "Imports")
-                                         (listify meta "LinkingTo")
-                                         (delete "R"
-                                                 (listify meta "Depends")))))
+         (uri-helper (uri-helper repository))
+         (inputs     (cran-package-inputs meta repository
+                                          #:download-source download-source))
          (package
            `(package
               (name ,(cran-guix-name name))
@@ -651,12 +707,18 @@ (define* (description->package repository meta #:key (license-prefix identity)
                     `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
                     '())
               (build-system r-build-system)
-              ,@(maybe-inputs (map transform-sysname sysdepends))
-              ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs)
-              ,@(maybe-inputs
-                 `(,@source-native-inputs
-                   ,@(vignette-builders meta))
-                 'native-inputs)
+
+              ,@(maybe-inputs (filter (upstream-input-type-predicate 'regular)
+                                      inputs)
+                              'inputs)
+              ,@(maybe-inputs (filter (upstream-input-type-predicate
+                                       'propagated)
+                                      inputs)
+                              'propagated-inputs)
+              ,@(maybe-inputs (filter (upstream-input-type-predicate 'native)
+                                      inputs)
+                              'native-inputs)
+
               (home-page ,(if (string-null? home-page)
                               (string-append base-url name)
                               home-page))
@@ -675,7 +737,10 @@ (define* (description->package repository meta #:key (license-prefix identity)
               (revision "1"))
           ,package))
       (else package))
-     propagate)))
+     (filter-map (lambda (input)
+                   (and (eq? 'propagated (upstream-input-type input))
+                        (upstream-input-name input)))
+                 inputs))))
 
 (define cran->guix-package
   (memoize
@@ -760,9 +825,7 @@ (define* (latest-cran-release pkg #:key (version #f))
           (package (package-name pkg))
           (version version)
           (urls (cran-uri upstream-name version))
-          (input-changes
-           (changed-inputs pkg
-                           (description->package 'cran meta)))))))
+          (inputs (cran-package-inputs meta 'cran))))))
 
 (define* (latest-bioconductor-release pkg #:key (version #f))
   "Return an <upstream-source> for the latest release of the package PKG."
@@ -784,10 +847,9 @@ (define* (latest-bioconductor-release pkg #:key (version #f))
         (package (package-name pkg))
         (version latest-version)
         (urls (bioconductor-uri upstream-name latest-version))
-        (input-changes
-         (changed-inputs
-          pkg
-          (cran->guix-package upstream-name #:repo 'bioconductor))))))
+        (inputs
+         (let ((meta (fetch-description 'bioconductor upstream-name)))
+           (cran-package-inputs meta 'bioconductor))))))
 
 (define (cran-package? package)
   "Return true if PACKAGE is an R package from CRAN."
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 56c8696ad7..9333bedbbd 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -56,7 +57,9 @@ (define-module (guix import hackage)
             hackage-fetch
             hackage-source-url
             hackage-cabal-url
-            hackage-package?))
+            hackage-package?
+
+            cabal-package-inputs))
 
 (define ghc-standard-libraries
   ;; List of libraries distributed with ghc (as of 8.10.7).
@@ -224,27 +227,12 @@ (define (filter-dependencies dependencies own-names)
     (filter (lambda (d) (not (member (string-downcase d) ignored-dependencies)))
             dependencies)))
 
-(define* (hackage-module->sexp cabal cabal-hash
-                               #:key (include-test-dependencies? #t))
-  "Return the `package' S-expression for a Cabal package.  CABAL is the
-representation of a Cabal file as produced by 'read-cabal'.  CABAL-HASH is
-the hash of the Cabal file."
-
-  (define name
-    (cabal-package-name cabal))
-
-  (define version
-    (cabal-package-version cabal))
-
-  (define revision
-    (cabal-package-revision cabal))
-  
-  (define source-url
-    (hackage-source-url name version))
-
-  (define own-names (cons (cabal-package-name cabal)
-                          (filter (lambda (x) (not (eqv? x #f)))
-                            (map cabal-library-name (cabal-package-library cabal)))))
+(define* (cabal-package-inputs cabal #:key (include-test-dependencies? #t))
+  "Return the list of <upstream-input> for CABAL representing its
+dependencies."
+  (define own-names
+    (cons (cabal-package-name cabal)
+          (filter-map cabal-library-name (cabal-package-library cabal))))
 
   (define hackage-dependencies
     (filter-dependencies (cabal-dependencies->names cabal) own-names))
@@ -261,22 +249,54 @@ (define* (hackage-module->sexp cabal cabal-hash
      hackage-dependencies))
 
   (define dependencies
-    (map string->symbol
-         (map hackage-name->package-name
-              hackage-dependencies)))
+    (map (lambda (name)
+           (upstream-input
+            (name name)
+            (downstream-name (hackage-name->package-name name))
+            (type 'regular)))
+         hackage-dependencies))
 
   (define native-dependencies
-    (map string->symbol
-         (map hackage-name->package-name
-              hackage-native-dependencies)))
-  
+    (map (lambda (name)
+           (upstream-input
+            (name name)
+            (downstream-name (hackage-name->package-name name))
+            (type 'native)))
+         hackage-native-dependencies))
+
+  (append dependencies native-dependencies))
+
+(define* (hackage-module->sexp cabal cabal-hash
+                               #:key (include-test-dependencies? #t))
+  "Return the `package' S-expression for a Cabal package.  CABAL is the
+representation of a Cabal file as produced by 'read-cabal'.  CABAL-HASH is
+the hash of the Cabal file."
+  (define name
+    (cabal-package-name cabal))
+
+  (define version
+    (cabal-package-version cabal))
+
+  (define revision
+    (cabal-package-revision cabal))
+
+  (define source-url
+    (hackage-source-url name version))
+
+  (define inputs
+    (cabal-package-inputs cabal
+                          #:include-test-dependencies?
+                          include-test-dependencies?))
+
   (define (maybe-inputs input-type inputs)
     (match inputs
       (()
        '())
       ((inputs ...)
        (list (list input-type
-                   `(list ,@inputs))))))
+                   `(list ,@(map (compose string->symbol
+                                          upstream-input-downstream-name)
+                                 inputs)))))))
 
   (define (maybe-arguments)
     (match (append (if (not include-test-dependencies?)
@@ -304,14 +324,18 @@ (define* (hackage-module->sexp cabal cabal-hash
                          "failed to download tar archive")))))
         (build-system haskell-build-system)
         (properties '((upstream-name . ,name)))
-        ,@(maybe-inputs 'inputs dependencies)
-        ,@(maybe-inputs 'native-inputs native-dependencies)
+        ,@(maybe-inputs 'inputs
+                        (filter (upstream-input-type-predicate 'regular)
+                                inputs))
+        ,@(maybe-inputs 'native-inputs
+                        (filter (upstream-input-type-predicate 'native)
+                                inputs))
         ,@(maybe-arguments)
         (home-page ,(cabal-package-home-page cabal))
         (synopsis ,(cabal-package-synopsis cabal))
         (description ,(beautify-description (cabal-package-description cabal)))
         (license ,(string->license (cabal-package-license cabal))))
-     (append hackage-dependencies hackage-native-dependencies))))
+     inputs)))
 
 (define* (hackage->guix-package package-name #:key
                                 (include-test-dependencies? #t)
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index 8c06b19cff..1a3070fb36 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com>
-;;; Copyright © 2015-2017, 2019-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015-2017, 2019-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2018, 2023 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
@@ -33,12 +33,16 @@
 (define-module (guix import pypi)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
-  #:use-module (ice-9 receive)
   #:use-module ((ice-9 rdelim) #:select (read-line))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-71)
+  #:autoload   (gcrypt hash) (port-sha256)
+  #:autoload   (guix base16) (base16-string->bytevector)
+  #:autoload   (guix base32) (bytevector->nix-base32-string)
+  #:autoload   (guix http-client) (http-fetch)
   #:use-module (guix utils)
   #:use-module (guix memoization)
   #:use-module (guix diagnostics)
@@ -126,6 +130,12 @@ (define-json-mapping <distribution> make-distribution distribution?
   (python-version distribution-package-python-version
                   "python_version"))
 
+(define (distribution-sha256 distribution)
+  "Return the SHA256 hash of DISTRIBUTION as a bytevector, or #f."
+  (match (assoc-ref (distribution-digests distribution) "sha256")
+    (#f #f)
+    (str (base16-string->bytevector str))))
+
 (define (pypi-fetch name)
   "Return a <pypi-project> record for package NAME, or #f on failure."
   (and=> (json-fetch (string-append (%pypi-base-url) name "/json"))
@@ -198,7 +208,9 @@ (define (maybe-inputs package-inputs input-type)
     (()
      '())
     ((package-inputs ...)
-     `((,input-type (list ,@package-inputs))))))
+     `((,input-type (list ,@(map (compose string->symbol
+                                          upstream-input-downstream-name)
+                                 package-inputs)))))))
 
 (define %requirement-name-regexp
   ;; Regexp to match the requirement name in a requirement specification.
@@ -409,23 +421,36 @@ (define (guess-requirements source-url wheel-url archive)
 
 (define (compute-inputs source-url wheel-url archive)
   "Given the SOURCE-URL and WHEEL-URL of an already downloaded ARCHIVE, return
-a pair of lists, each consisting of a list of name/variable pairs, for the
-propagated inputs and the native inputs, respectively.  Also
-return the unaltered list of upstream dependency names."
-
-  (define (strip-argparse deps)
-    (remove (cut string=? "argparse" <>) deps))
-
-  (define (requirement->package-name/sort deps)
-    (map string->symbol
-         (sort (map python->package-name deps) string-ci<?)))
-
-  (define process-requirements
-    (compose requirement->package-name/sort strip-argparse))
-
+the corresponding list of <upstream-input> records."
+  (define (requirements->upstream-inputs deps type)
+    (filter-map (match-lambda
+                  ("argparse" #f)
+                  (name (upstream-input
+                         (name name)
+                         (downstream-name (python->package-name name))
+                         (type type))))
+                (sort deps string-ci<?)))
+
+  ;; TODO: Record version number ranges in <upstream-input>.
   (let ((dependencies (guess-requirements source-url wheel-url archive)))
-    (values (map process-requirements dependencies)
-            (concatenate dependencies))))
+    (match dependencies
+      ((propagated native)
+       (append (requirements->upstream-inputs propagated 'propagated)
+               (requirements->upstream-inputs native 'native))))))
+
+(define* (pypi-package-inputs pypi-package #:optional version)
+  "Return the list of <upstream-input> for PYPI-PACKAGE.  This procedure
+downloads the source and possibly the wheel of PYPI-PACKAGE."
+  (let* ((info       (pypi-project-info pypi-package))
+         (version    (or version (project-info-version info)))
+         (dist       (source-release pypi-package version))
+         (source-url (distribution-url dist))
+         (wheel-url  (and=> (wheel-release pypi-package version)
+                            distribution-url)))
+    (call-with-temporary-output-file
+     (lambda (archive port)
+       (and (url-fetch source-url archive)
+            (compute-inputs source-url wheel-url archive))))))
 
 (define (find-project-url name pypi-url)
   "Try different project name substitution until the result is found in
@@ -445,52 +470,85 @@ (define (find-project-url name pypi-url)
 a substring of the PyPI URI that identifies the package.")  pypi-url name))
 name)))
 
-(define (make-pypi-sexp name version source-url wheel-url home-page synopsis
-                        description license)
-  "Return the `package' s-expression for a python package with the given NAME,
-VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
+(define* (pypi-package->upstream-source pypi-package #:optional version)
+  "Return the upstream source for the given VERSION of PYPI-PACKAGE, a
+<pypi-project> record.  If VERSION is omitted or #f, use the latest version."
+  (let* ((info       (pypi-project-info pypi-package))
+         (version    (or version (project-info-version info)))
+         (dist       (source-release pypi-package version))
+         (source-url (distribution-url dist))
+         (wheel-url  (and=> (wheel-release pypi-package version)
+                            distribution-url)))
+    (let ((extra-inputs (if (string-suffix? ".zip" source-url)
+                            (list (upstream-input
+                                   (name "zip")
+                                   (downstream-name "zip")
+                                   (type 'native)))
+                            '())))
+      (upstream-source
+       (urls (list source-url))
+       (signature-urls
+        (if (distribution-has-signature? dist)
+            (list (string-append source-url ".asc"))
+            #f))
+       (inputs (append (pypi-package-inputs pypi-package)
+                       extra-inputs))
+       (package (project-info-name info))
+       (version version)))))
+
+(define* (make-pypi-sexp pypi-package
+                         #:optional (version (latest-version pypi-package)))
+  "Return the `package' s-expression the given VERSION of PYPI-PACKAGE, a
+<pypi-project> record."
   (define (maybe-upstream-name name)
     (if (string-match ".*\\-[0-9]+" name)
         `((properties ,`'(("upstream-name" . ,name))))
         '()))
-  
-  (call-with-temporary-output-file
-   (lambda (temp port)
-     (and (url-fetch source-url temp)
-          (receive (guix-dependencies upstream-dependencies)
-              (compute-inputs source-url wheel-url temp)
-            (match guix-dependencies
-              ((required-inputs native-inputs)
-               (when (string-suffix? ".zip" source-url)
-                 (set! native-inputs (cons 'unzip native-inputs)))
-               (values
-                `(package
-                   (name ,(python->package-name name))
-                   (version ,version)
-                   (source
-                    (origin
-                      (method url-fetch)
-                      (uri (pypi-uri
-                             ,(find-project-url name source-url)
-                             version
-                             ;; Some packages have been released as `.zip`
-                             ;; instead of the more common `.tar.gz`. For
-                             ;; example, see "path-and-address".
-                             ,@(if (string-suffix? ".zip" source-url)
-                                   '(".zip")
-                                   '())))
-                      (sha256
-                       (base32
-                        ,(guix-hash-url temp)))))
-                   ,@(maybe-upstream-name name)
-                   (build-system pyproject-build-system)
-                   ,@(maybe-inputs required-inputs 'propagated-inputs)
-                   ,@(maybe-inputs native-inputs 'native-inputs)
-                   (home-page ,home-page)
-                   (synopsis ,synopsis)
-                   (description ,(beautify-description description))
-                   (license ,(license->symbol license)))
-                upstream-dependencies))))))))
+
+  (let* ((info (pypi-project-info pypi-package))
+         (name (project-info-name info))
+         (source-url (and=> (source-release pypi-package version)
+                            distribution-url))
+         (sha256 (and=> (source-release pypi-package version)
+                        distribution-sha256))
+         (source (pypi-package->upstream-source pypi-package version)))
+    (values
+     `(package
+        (name ,(python->package-name name))
+        (version ,version)
+        (source
+         (origin
+           (method url-fetch)
+           (uri (pypi-uri
+                 ,(find-project-url name source-url)
+                 version
+                 ;; Some packages have been released as `.zip`
+                 ;; instead of the more common `.tar.gz`. For
+                 ;; example, see "path-and-address".
+                 ,@(if (string-suffix? ".zip" source-url)
+                       '(".zip")
+                       '())))
+           (sha256 (base32
+                    ,(and=> (or sha256
+                                (let* ((port (http-fetch source-url))
+                                       (hash (port-sha256 port)))
+                                  (close-port port)
+                                  hash))
+                            bytevector->nix-base32-string)))))
+        ,@(maybe-upstream-name name)
+        (build-system pyproject-build-system)
+        ,@(maybe-inputs (upstream-source-propagated-inputs source)
+                        'propagated-inputs)
+        ,@(maybe-inputs (upstream-source-native-inputs source)
+                        'native-inputs)
+        (home-page ,(project-info-home-page info))
+        (synopsis ,(project-info-summary info))
+        (description ,(beautify-description
+                       (project-info-summary info)))
+        (license ,(license->symbol
+                   (string->license
+                    (project-info-license info)))))
+     (map upstream-input-name (upstream-source-inputs source)))))
 
 (define pypi->guix-package
   (memoize
@@ -520,16 +578,7 @@ (define pypi->guix-package
 source.  To build it from source, refer to the upstream repository at
 @uref{~a}.")
                                               url))))))))))))
-             (make-pypi-sexp (project-info-name info) version
-                             (and=> (source-release project version)
-                                    distribution-url)
-                             (and=> (wheel-release project version)
-                                    distribution-url)
-                             (project-info-home-page info)
-                             (project-info-summary info)
-                             (project-info-summary info)
-                             (string->license
-                              (project-info-license info))))
+             (make-pypi-sexp project version))
            (values #f '()))))))
 
 (define* (pypi-recursive-import package-name #:optional version)
@@ -566,21 +615,7 @@ (define* (import-release package #:key (version #f))
          (pypi-package (pypi-fetch pypi-name)))
     (and pypi-package
          (guard (c ((missing-source-error? c) #f))
-           (let* ((info    (pypi-project-info pypi-package))
-                  (version (or version (project-info-version info)))
-                  (dist    (source-release pypi-package version))
-                  (url     (distribution-url dist)))
-             (upstream-source
-              (urls (list url))
-              (signature-urls
-               (if (distribution-has-signature? dist)
-                   (list (string-append url ".asc"))
-                   #f))
-              (input-changes
-               (changed-inputs package
-                               (pypi->guix-package pypi-name #:version version)))
-              (package (package-name package))
-              (version version)))))))
+           (pypi-package->upstream-source pypi-package version)))))
 
 (define %pypi-updater
   (upstream-updater
diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm
index f98b86c334..f8b2726591 100644
--- a/guix/import/stackage.scm
+++ b/guix/import/stackage.scm
@@ -29,6 +29,7 @@ (define-module (guix import stackage)
   #:use-module (srfi srfi-35)
   #:use-module (guix import json)
   #:use-module (guix import hackage)
+  #:autoload   (guix import cabal) (eval-cabal)
   #:use-module (guix import utils)
   #:use-module (guix memoization)
   #:use-module (guix packages)
@@ -157,15 +158,13 @@ (define latest-lts-release
            (warning (G_ "failed to parse ~a~%")
                     (hackage-cabal-url hackage-name))
            #f)
-          (_ (let ((url (hackage-source-url hackage-name version)))
+          (_ (let ((url (hackage-source-url hackage-name version))
+                   (cabal (eval-cabal (hackage-fetch hackage-name) '())))
                (upstream-source
                 (package (package-name pkg))
                 (version version)
                 (urls (list url))
-                (input-changes
-                 (changed-inputs
-                  pkg
-                  (stackage->guix-package hackage-name #:packages (packages))))))))))))
+                (inputs (cabal-package-inputs cabal))))))))))
 
 (define (stackage-lts-package? package)
   "Return whether PACKAGE is available on the default Stackage LTS release."
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 47c4d55ec4..e9e3eda9eb 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
@@ -401,7 +401,7 @@ (define* (update-package store package version updaters
                      (('remove 'propagated)
                       (info loc (G_ "~a: consider removing this propagated input: ~a~%")
                             name change-name))))
-                 (upstream-source-input-changes source))
+                 (changed-inputs package source))
                 (let ((hash (file-hash* output)))
                   (update-package-source package source hash)))
               (warning (G_ "~a: version ~a could not be \
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 52fae11832..6f2a4dca28 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
@@ -55,7 +55,20 @@ (define-module (guix upstream)
             upstream-source-urls
             upstream-source-signature-urls
             upstream-source-archive-types
-            upstream-source-input-changes
+            upstream-source-inputs
+
+            upstream-input-type-predicate
+            upstream-source-regular-inputs
+            upstream-source-native-inputs
+            upstream-source-propagated-inputs
+
+            upstream-input
+            upstream-input?
+            upstream-input-name
+            upstream-input-downstream-name
+            upstream-input-type
+            upstream-input-min-version
+            upstream-input-max-version
 
             url-predicate
             url-prefix-predicate
@@ -102,8 +115,40 @@ (define-record-type* <upstream-source>
   (urls           upstream-source-urls)           ;list of strings|git-reference
   (signature-urls upstream-source-signature-urls  ;#f | list of strings
                   (default #f))
-  (input-changes  upstream-source-input-changes
-                  (default '()) (thunked)))
+  (inputs         upstream-source-inputs        ;#f | list of <upstream-input>
+                  (delayed) (default #f))) ;delayed because optional and costly
+
+;; Representation of a dependency as expressed by upstream.
+(define-record-type* <upstream-input>
+  upstream-input make-upstream-input
+  upstream-input?
+  (name         upstream-input-name)               ;upstream package name
+  (downstream-name upstream-input-downstream-name) ;Guix package name
+  (type         upstream-input-type          ;'regular | 'native | 'propagated
+                (default 'regular))
+  (min-version  upstream-input-min-version
+                (default 'any))
+  (max-version  upstream-input-max-version
+                (default 'any)))
+
+(define (upstream-input-type-predicate type)
+  "Return a predicate that returns true when passed an <upstream-input> record
+of the given TYPE (a symbol such as 'propagated)."
+  (lambda (source)
+    (eq? type (upstream-input-type source))))
+
+(define (input-type-filter type)
+  "Return a procedure that, given an <upstream-source>, returns the subset of
+its inputs that have the given TYPE (a symbol such as 'native)."
+  (lambda (source)
+    "Return the subset of inputs of SOURCE that have the given TYPE."
+    (filter (lambda (input)
+              (eq? type (upstream-input-type input)))
+            (upstream-source-inputs source))))
+
+(define upstream-source-regular-inputs (input-type-filter 'regular))
+(define upstream-source-native-inputs (input-type-filter 'native))
+(define upstream-source-propagated-inputs (input-type-filter 'propagated))
 
 ;; Representation of an upstream input change.
 (define-record-type* <upstream-input-change>
@@ -113,67 +158,55 @@ (define-record-type* <upstream-input-change>
   (type    upstream-input-change-type)    ;symbol: regular | native | propagated
   (action  upstream-input-change-action)) ;symbol: add | remove
 
-(define (changed-inputs package package-sexp)
-  "Return a list of input changes for PACKAGE based on the newly imported
-S-expression PACKAGE-SEXP."
-  (match package-sexp
-    ((and expr ('package fields ...))
-     (let* ((input->name (match-lambda ((name pkg . out) name)))
-            (new-regular
-             (match expr
-               ((path *** ('inputs
-                           ('quasiquote ((label ('unquote sym)) ...)))) label)
-               ((path *** ('inputs
-                           ('list sym ...))) (map symbol->string sym))
-               (_ '())))
-            (new-native
-             (match expr
-               ((path *** ('native-inputs
-                           ('quasiquote ((label ('unquote sym)) ...)))) label)
-               ((path *** ('native-inputs
-                           ('list sym ...))) (map symbol->string sym))
-               (_ '())))
-            (new-propagated
-             (match expr
-               ((path *** ('propagated-inputs
-                           ('quasiquote ((label ('unquote sym)) ...)))) label)
-               ((path *** ('propagated-inputs
-                           ('list sym ...))) (map symbol->string sym))
-               (_ '())))
-            (current-regular
-             (map input->name (package-inputs package)))
-            (current-native
-             (map input->name (package-native-inputs package)))
-            (current-propagated
-             (map input->name (package-propagated-inputs package))))
-       (append-map
-        (match-lambda
-          ((action type names)
-           (map (lambda (name)
-                  (upstream-input-change
-                   (name name)
-                   (type type)
-                   (action action)))
-                names)))
-        `((add regular
-           ,(lset-difference equal?
-                             new-regular current-regular))
-          (remove regular
-           ,(lset-difference equal?
-                             current-regular new-regular))
-          (add native
-           ,(lset-difference equal?
-                             new-native current-native))
-          (remove native
-           ,(lset-difference equal?
-                             current-native new-native))
-          (add propagated
-           ,(lset-difference equal?
-                             new-propagated current-propagated))
-          (remove propagated
-           ,(lset-difference equal?
-                             current-propagated new-propagated))))))
-    (_ '())))
+(define (changed-inputs package source)
+  "Return a list of input changes for PACKAGE compared to the 'inputs' field
+of SOURCE, an <upstream-source> record."
+  (define input->name
+    (match-lambda
+      ((label (? package? pkg) . out) (package-name pkg))
+      (_ #f)))
+
+  (if (upstream-source-inputs source)
+      (let* ((new-regular (map upstream-input-downstream-name
+                               (upstream-source-regular-inputs source)))
+             (new-native (map upstream-input-downstream-name
+                              (upstream-source-native-inputs source)))
+             (new-propagated (map upstream-input-downstream-name
+                                  (upstream-source-propagated-inputs source)))
+             (current-regular
+              (filter-map input->name (package-inputs package)))
+             (current-native
+              (filter-map input->name (package-native-inputs package)))
+             (current-propagated
+              (filter-map input->name (package-propagated-inputs package))))
+        (append-map
+         (match-lambda
+           ((action type names)
+            (map (lambda (name)
+                   (upstream-input-change
+                    (name name)
+                    (type type)
+                    (action action)))
+                 names)))
+         `((add regular
+                ,(lset-difference equal?
+                                  new-regular current-regular))
+           (remove regular
+                   ,(lset-difference equal?
+                                     current-regular new-regular))
+           (add native
+                ,(lset-difference equal?
+                                  new-native current-native))
+           (remove native
+                   ,(lset-difference equal?
+                                     current-native new-native))
+           (add propagated
+                ,(lset-difference equal?
+                                  new-propagated current-propagated))
+           (remove propagated
+                   ,(lset-difference equal?
+                                     current-propagated new-propagated)))))
+      '()))
 
 (define* (url-predicate matching-url?)
   "Return a predicate that returns true when passed a package whose source is
diff --git a/tests/cran.scm b/tests/cran.scm
index 5c820b1ab3..1ef533a41c 100644
--- a/tests/cran.scm
+++ b/tests/cran.scm
@@ -119,7 +119,7 @@ (define simple-alist
          ('build-system 'r-build-system)
          ('inputs ('list 'cairo))
          ('propagated-inputs
-          ('list 'r-bh 'r-proto 'r-rcpp 'r-scales))
+          ('list 'r-bh 'r-rcpp 'r-proto 'r-scales))
          ('home-page "http://gnu.org/s/my-example")
          ('synopsis "Example package")
          ('description
diff --git a/tests/pypi.scm b/tests/pypi.scm
index 497744511f..f3b2771f4b 100644
--- a/tests/pypi.scm
+++ b/tests/pypi.scm
@@ -25,9 +25,12 @@ (define-module (test-pypi)
   #:use-module (guix base32)
   #:use-module (guix memoization)
   #:use-module (guix utils)
+  #:use-module ((guix base16) #:select (base16-string->bytevector))
+  #:use-module (guix upstream)
   #:use-module (gcrypt hash)
   #:use-module (guix tests)
   #:use-module (guix tests http)
+  #:use-module ((guix download) #:select (url-fetch))
   #:use-module (guix build-system python)
   #:use-module ((guix build utils)
                 #:select (delete-file-recursively
@@ -43,6 +46,12 @@ (define-module (test-pypi)
   #:use-module (ice-9 match)
   #:use-module (ice-9 optargs))
 
+(define default-sha256
+  "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")
+(define default-sha256/base32
+  (bytevector->nix-base32-string
+   (base16-string->bytevector default-sha256)))
+
 (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}."
@@ -65,7 +74,8 @@ (define* (foo-json #:key (name "foo") (name-in-url #f))
               ((url . ,(format #f "~a/~a-1.0.0.tar.gz"
                                (%local-url #:path "")
                                (or name-in-url name)))
-               (packagetype . "sdist"))
+               (packagetype . "sdist")
+               (digests . (("sha256" . ,default-sha256))))
               ((url . ,(format #f "~a/~a-1.0.0-py2.py3-none-any.whl"
                                (%local-url #:path "")
                                (or name-in-url name)))
@@ -308,9 +318,7 @@ (define-syntax-rule (with-pypi responses body ...)
            ('synopsis "summary")
            ('description "summary")
            ('license 'license:lgpl2.0))
-         (and (string=? (bytevector->nix-base32-string
-                         (file-sha256 tarball))
-                        hash)
+         (and (string=? default-sha256/base32 hash)
               (equal? (pypi->guix-package "foo" #:version "1.0.0")
                       (pypi->guix-package "foo"))
               (guard (c ((error? c) #t))
@@ -352,8 +360,7 @@ (define-syntax-rule (with-pypi responses body ...)
            ('synopsis "summary")
            ('description "summary")
            ('license 'license:lgpl2.0))
-         (string=? (bytevector->nix-base32-string (file-sha256 tarball))
-                   hash))
+         (string=? default-sha256/base32 hash))
         (x
          (pk 'fail x #f))))))
 
@@ -382,8 +389,7 @@ (define-syntax-rule (with-pypi responses body ...)
            ('synopsis "summary")
            ('description "summary")
            ('license 'license:lgpl2.0))
-         (string=? (bytevector->nix-base32-string (file-sha256 tarball))
-                   hash))
+         (string=? default-sha256/base32 hash))
         (x
          (pk 'fail x #f))))))
 
@@ -414,11 +420,47 @@ (define-syntax-rule (with-pypi responses body ...)
            ('synopsis "summary")
            ('description "summary")
            ('license 'license:lgpl2.0))
-         (string=? (bytevector->nix-base32-string (file-sha256 tarball))
-                   hash))
+         (string=? default-sha256/base32 hash))
         (x
          (pk 'fail x #f))))))
 
+(test-equal "package-latest-release"
+  (list '("foo-1.0.0.tar.gz")
+        '("foo-1.0.0.tar.gz.asc")
+        (list (upstream-input
+               (name "bar")
+               (downstream-name "python-bar")
+               (type 'propagated))
+              (upstream-input
+               (name "foo")
+               (downstream-name "python-foo")
+               (type 'propagated))
+              (upstream-input
+               (name "pytest")
+               (downstream-name "python-pytest")
+               (type 'native))))
+  (let ((tarball (pypi-tarball
+                  "foo-1.0.0"
+                  `(("src/bizarre.egg-info/requires.txt"
+                     ,test-requires.txt)))))
+    (with-pypi `(("/foo-1.0.0.tar.gz" 200 ,(file-dump tarball))
+                 ("/foo-1.0.0-py2.py3-none-any.whl" 404 "")
+                 ("/foo/json" 200 ,(lambda (port)
+                                     (display (foo-json) port))))
+      (define source
+        (package-latest-release
+         (dummy-package "python-foo"
+                        (version "0.1.2")
+                        (source (dummy-origin
+                                 (method url-fetch)
+                                 (uri (pypi-uri "foo" version))))
+                        (build-system python-build-system))
+         (list %pypi-updater)))
+
+      (list (map basename (upstream-source-urls source))
+            (map basename (upstream-source-signature-urls source))
+            (upstream-source-inputs source)))))
+
 (test-end "pypi")
 (delete-file-recursively sample-directory)
 
diff --git a/tests/upstream.scm b/tests/upstream.scm
index 9aacb77229..0792ebd5d0 100644
--- a/tests/upstream.scm
+++ b/tests/upstream.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -78,69 +78,29 @@ (define test-package
     (description "test")
     (license license:gpl3+)))
 
-(define test-package-sexp
-  '(package
-    (name "test")
-    (version "2.10")
-    (source (origin
-              (method url-fetch)
-              (uri (string-append "mirror://gnu/hello/hello-" version
-                                  ".tar.gz"))
-              (sha256
-               (base32
-                "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i"))))
-    (build-system gnu-build-system)
-    (inputs
-     `(("hello" ,hello)))
-    (native-inputs
-     `(("sed" ,sed)
-       ("tar" ,tar)))
-    (propagated-inputs
-     `(("grep" ,grep)))
-    (home-page "http://localhost")
-    (synopsis "test")
-    (description "test")
-    (license license:gpl3+)))
-
 (test-equal "changed-inputs returns no changes"
   '()
-  (changed-inputs test-package test-package-sexp))
-
-(test-assert "changed-inputs returns changes to labelled input list"
-  (let ((changes (changed-inputs
-                  (package
-                    (inherit test-package)
-                    (inputs `(("hello" ,hello)
-                              ("sed" ,sed))))
-                  test-package-sexp)))
-    (match changes
-      ;; Exactly one change
-      (((? upstream-input-change? item))
-       (and (equal? (upstream-input-change-type item)
-                    'regular)
-            (equal? (upstream-input-change-action item)
-                    'remove)
-            (string=? (upstream-input-change-name item)
-                      "sed")))
-      (else (pk else #false)))))
-
-(test-assert "changed-inputs returns changes to all labelled input lists"
-  (let ((changes (changed-inputs
-                  (package
-                    (inherit test-package)
-                    (inputs '())
-                    (native-inputs '())
-                    (propagated-inputs '()))
-                  test-package-sexp)))
-    (match changes
-      (((? upstream-input-change? items) ...)
-       (and (equal? (map upstream-input-change-type items)
-                    '(regular native native propagated))
-            (equal? (map upstream-input-change-action items)
-                    '(add add add add))
-            (equal? (map upstream-input-change-name items)
-                    '("hello" "sed" "tar" "grep"))))
-      (else (pk else #false)))))
+  (changed-inputs test-package
+                  (upstream-source
+                   (package "test")
+                   (version "1")
+                   (urls '())
+                   (inputs
+                    (let ((->input
+                           (lambda (type)
+                             (match-lambda
+                               ((label _)
+                                (upstream-input
+                                 (name label)
+                                 (downstream-name label)
+                                 (type type)))))))
+                      (append (map (->input 'regular)
+                                   (package-inputs test-package))
+                              (map (->input 'native)
+                                   (package-native-inputs test-package))
+                              (map (->input 'propagated)
+                                   (package-propagated-inputs
+                                    test-package))))))))
 
 (define test-new-package
   (package
@@ -152,35 +112,20 @@ (define test-new-package
     (propagated-inputs
      (list grep))))
 
-(define test-new-package-sexp
-  '(package
-    (name "test")
-    (version "2.10")
-    (source (origin
-              (method url-fetch)
-              (uri (string-append "mirror://gnu/hello/hello-" version
-                                  ".tar.gz"))
-              (sha256
-               (base32
-                "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i"))))
-    (build-system gnu-build-system)
-    (inputs
-     (list hello))
-    (native-inputs
-     (list sed tar))
-    (propagated-inputs
-     (list grep))
-    (home-page "http://localhost")
-    (synopsis "test")
-    (description "test")
-    (license license:gpl3+)))
-
 (test-assert "changed-inputs returns changes to plain input list"
   (let ((changes (changed-inputs
                   (package
                     (inherit test-new-package)
-                    (inputs (list hello sed)))
-                  test-new-package-sexp)))
+                    (inputs (list hello sed))
+                    (native-inputs '())
+                    (propagated-inputs '()))
+                  (upstream-source
+                   (package "test")
+                   (version "1")
+                   (urls '())
+                   (inputs (list (upstream-input
+                                  (name "hello")
+                                  (downstream-name name))))))))
     (match changes
       ;; Exactly one change
       (((? upstream-input-change? item))
@@ -199,7 +144,26 @@ (define test-new-package-sexp
                     (inputs '())
                     (native-inputs '())
                     (propagated-inputs '()))
-                  test-new-package-sexp)))
+                  (upstream-source
+                   (package "test")
+                   (version "1")
+                   (urls '())
+                   (inputs (list (upstream-input
+                                  (name "hello")
+                                  (downstream-name name)
+                                  (type 'regular))
+                                 (upstream-input
+                                  (name "sed")
+                                  (downstream-name name)
+                                  (type 'native))
+                                 (upstream-input
+                                  (name "tar")
+                                  (downstream-name name)
+                                  (type 'native))
+                                 (upstream-input
+                                  (name "grep")
+                                  (downstream-name name)
+                                  (type 'propagated))))))))
     (match changes
       (((? upstream-input-change? items) ...)
        (and (equal? (map upstream-input-change-type items)
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 07/14] diagnostics: Factorize 'absolute-location'.
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
                   ` (5 preceding siblings ...)
  2023-05-18 15:16 ` [bug#63571] [PATCH 06/14] upstream: Replace 'input-changes' field by 'inputs' Ludovic Courtès
@ 2023-05-18 15:16 ` Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 08/14] upstream: 'update-package-source' edits input fields Ludovic Courtès
                   ` (8 subsequent siblings)
  15 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 15:16 UTC (permalink / raw)
  To: 63571
  Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret,
	Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus,
	Simon Tournier, Tobias Geerinckx-Rice

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain; charset=^[[6~, Size: 4229 bytes --]

* guix/scripts/style.scm (absolute-location): Move to...
* guix/diagnostics.scm (absolute-location): ... here.
* guix/upstream.scm (update-package-source): Use it.
---
 guix/diagnostics.scm   | 20 +++++++++++++++++++-
 guix/scripts/style.scm | 17 -----------------
 guix/upstream.scm      |  4 ++--
 3 files changed, 21 insertions(+), 20 deletions(-)

diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
index 9f0d558f2f..3f1f527b43 100644
--- a/guix/diagnostics.scm
+++ b/guix/diagnostics.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-2021, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -36,6 +36,7 @@ (define-module (guix diagnostics)
             location-file
             location-line
             location-column
+            absolute-location
             source-properties->location
             location->source-properties
             location->string
@@ -340,6 +341,23 @@ (define-syntax formatted-message
               (&formatted-message (format str)
                                   (arguments (list args ...))))))))))
 
+(define (absolute-location loc)
+  "Replace the file name in LOC by an absolute location."
+  (location (if (string-prefix? "/" (location-file loc))
+                (location-file loc)
+
+                ;; 'search-path' might return #f in obscure cases, such as
+                ;; when %LOAD-PATH includes "." or ".." and LOC comes from a
+                ;; file in a subdirectory thereof.
+                (match (search-path %load-path (location-file loc))
+                  (#f
+                   (raise (formatted-message
+                           (G_ "file '~a' not found on load path")
+                           (location-file loc))))
+                  (str str)))
+            (location-line loc)
+            (location-column loc)))
+
 \f
 (define guix-warning-port
   (make-parameter (current-warning-port)))
diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm
index 00c7d3f90c..3f5d757e10 100644
--- a/guix/scripts/style.scm
+++ b/guix/scripts/style.scm
@@ -225,23 +225,6 @@ (define (edit-expression/dry-run properties rewrite-string)
                              (G_ "would be edited~%")))
                      str)))
 
-(define (absolute-location loc)
-  "Replace the file name in LOC by an absolute location."
-  (location (if (string-prefix? "/" (location-file loc))
-                (location-file loc)
-
-                ;; 'search-path' might return #f in obscure cases, such as
-                ;; when %LOAD-PATH includes "." or ".." and LOC comes from a
-                ;; file in a subdirectory thereof.
-                (match (search-path %load-path (location-file loc))
-                  (#f
-                   (raise (formatted-message
-                           (G_ "file '~a' not found on load path")
-                           (location-file loc))))
-                  (str str)))
-            (location-line loc)
-            (location-column loc)))
-
 (define (trivial-package-arguments? package)
   "Return true if PACKAGE has zero arguments or only \"trivial\" arguments
 guaranteed not to refer to input labels."
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 6f2a4dca28..29dd923e63 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -630,8 +630,8 @@ (define* (update-package-source package source hash)
               ;; function of the person who uploads the package.  Note that
               ;; package definitions usually concatenate fragments of the URL,
               ;; which is why we only attempt to replace a subset of the URL.
-              (let ((properties (assq-set! (location->source-properties loc)
-                                           'filename file))
+              (let ((properties (location->source-properties
+                                 (absolute-location loc)))
                     (replacements `((,old-version . ,version)
                                     (,old-hash . ,hash)
                                     ,@(if (and old-commit new-commit)
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 08/14] upstream: 'update-package-source' edits input fields.
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
                   ` (6 preceding siblings ...)
  2023-05-18 15:16 ` [bug#63571] [PATCH 07/14] diagnostics: Factorize 'absolute-location' Ludovic Courtès
@ 2023-05-18 15:16 ` Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 09/14] upstream: Remove <upstream-input-change> and related code Ludovic Courtès
                   ` (7 subsequent siblings)
  15 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 15:16 UTC (permalink / raw)
  To: 63571
  Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret,
	Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus,
	Simon Tournier, Tobias Geerinckx-Rice

Previously, 'guix refresh r-ggplot2 -u' and similar commands would print
of list of input changes that would have to be made manually.  With this
change, 'guix refresh -u' takes care of updating input fields
automatically.

* guix/upstream.scm (update-package-inputs): New procedure.
(update-package-source): Call it when 'upstream-source-inputs' returns
true.
* guix/scripts/refresh.scm (update-package): Remove iteration over the
result of 'changed-inputs'.
* guix/import/test.scm (available-updates): Add support for input
lists.
* tests/guix-refresh.sh (GUIX_TEST_UPDATER_TARGETS): Add input list for
"the-test-package".
Make sure 'guix refresh -u' updates 'inputs' accordingly.
---
 guix/import/test.scm     | 13 +++++++++-
 guix/scripts/refresh.scm | 36 --------------------------
 guix/upstream.scm        | 56 +++++++++++++++++++++++++++++++++++++---
 tests/guix-refresh.sh    |  7 +++--
 4 files changed, 69 insertions(+), 43 deletions(-)

diff --git a/guix/import/test.scm b/guix/import/test.scm
index b1ed0b455d..4bd356bddc 100644
--- a/guix/import/test.scm
+++ b/guix/import/test.scm
@@ -52,7 +52,18 @@ (define (available-updates package)
                                         (upstream-source
                                          (package (package-name package))
                                          (version version)
-                                         (urls (list url)))))
+                                         (urls (list url))))
+                                       ((version url (inputs ...))
+                                        (upstream-source
+                                         (package (package-name package))
+                                         (version version)
+                                         (urls (list url))
+                                         (inputs
+                                          (map (lambda (name)
+                                                 (upstream-input
+                                                  (name name)
+                                                  (downstream-name name)))
+                                               inputs)))))
                                      updates)
                                 result)
                         result))))
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index e9e3eda9eb..7d74729a88 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -366,42 +366,6 @@ (define* (update-package store package version updaters
                       (G_ "~a: updating from version ~a to version ~a...~%")
                       (package-name package)
                       (package-version package) version)
-                (for-each
-                 (lambda (change)
-                   (define field
-                     (match (upstream-input-change-type change)
-                       ('native 'native-inputs)
-                       ('propagated 'propagated-inputs)
-                       (_ 'inputs)))
-
-                   (define name
-                     (package-name package))
-                   (define loc
-                     (package-field-location package field))
-                   (define change-name
-                     (upstream-input-change-name change))
-
-                   (match (list (upstream-input-change-action change)
-                                (upstream-input-change-type change))
-                     (('add 'regular)
-                      (info loc (G_ "~a: consider adding this input: ~a~%")
-                            name change-name))
-                     (('add 'native)
-                      (info loc (G_ "~a: consider adding this native input: ~a~%")
-                            name change-name))
-                     (('add 'propagated)
-                      (info loc (G_ "~a: consider adding this propagated input: ~a~%")
-                            name change-name))
-                     (('remove 'regular)
-                      (info loc (G_ "~a: consider removing this input: ~a~%")
-                            name change-name))
-                     (('remove 'native)
-                      (info loc (G_ "~a: consider removing this native input: ~a~%")
-                            name change-name))
-                     (('remove 'propagated)
-                      (info loc (G_ "~a: consider removing this propagated input: ~a~%")
-                            name change-name))))
-                 (changed-inputs package source))
                 (let ((hash (file-hash* output)))
                   (update-package-source package source hash)))
               (warning (G_ "~a: version ~a could not be \
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 29dd923e63..1a90a342ff 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -38,6 +38,7 @@ (define-module (guix upstream)
   #:use-module (guix hash)
   #:use-module (guix store)
   #:use-module ((guix derivations) #:select (built-derivations derivation->output-path))
+  #:autoload   (guix read-print) (object->string*)
   #:autoload   (gcrypt hash) (port-sha256)
   #:use-module (guix monads)
   #:use-module (srfi srfi-1)
@@ -576,6 +577,52 @@ (define* (package-update store package
                   (package-name package)))
      (values #f #f #f))))
 
+(define (update-package-inputs package source)
+  "Update the input fields of the definition of PACKAGE according to those
+specified in SOURCE, an <upstream-source>."
+  (define (update-field field source-inputs package-inputs)
+    (define loc
+      (package-field-location package field))
+
+    (define new
+      (map (compose string->symbol upstream-input-downstream-name)
+           (source-inputs source)))
+
+    (define old
+      (match (package-inputs package)
+        (((labels (? package? packages)) ...)
+         labels)
+        (_
+         '())))
+
+    (define unchanged?
+      (equal? new old))
+
+    (if (and loc (not unchanged?))
+        (edit-expression (location->source-properties
+                          (absolute-location loc))
+                         (lambda (str)
+                           (object->string* `(list ,@new)
+                                            (location-column loc))))
+        (unless unchanged?
+          ;; XXX: Bail out when FIELD isn't already present in the source.
+          ;; TODO: Add the field if it's missing.
+          (warning (package-location package)
+                   (G_ "~a: '~a' field not found; leaving it unchanged~%")
+                   (package-name package) field)
+          (warning (package-location package)
+                   (G_ "~a: expected '~a' value: ~s~%")
+                   (package-name package) field new))))
+
+  (for-each update-field
+            '(inputs native-inputs propagated-inputs)
+            (list upstream-source-regular-inputs
+                  upstream-source-native-inputs
+                  upstream-source-propagated-inputs)
+            (list package-inputs
+                  package-native-inputs
+                  package-propagated-inputs)))
+
 (define* (update-package-source package source hash)
   "Modify the source file that defines PACKAGE to refer to SOURCE, an
 <upstream-source> whose tarball has SHA256 HASH (a bytevector).  Return the
@@ -630,9 +677,7 @@ (define* (update-package-source package source hash)
               ;; function of the person who uploads the package.  Note that
               ;; package definitions usually concatenate fragments of the URL,
               ;; which is why we only attempt to replace a subset of the URL.
-              (let ((properties (location->source-properties
-                                 (absolute-location loc)))
-                    (replacements `((,old-version . ,version)
+              (let ((replacements `((,old-version . ,version)
                                     (,old-hash . ,hash)
                                     ,@(if (and old-commit new-commit)
                                           `((,old-commit . ,new-commit))
@@ -641,8 +686,11 @@ (define* (update-package-source package source hash)
                                           `((,(dirname old-url) .
                                              ,(dirname new-url)))
                                           '()))))
-                (and (edit-expression properties
+                (and (edit-expression (location->source-properties
+                                       (absolute-location loc))
                                       (cut update-expression <> replacements))
+                     (or (not (upstream-source-inputs source))
+                         (update-package-inputs package source))
                      version))
               (begin
                 (warning (G_ "~a: could not locate source file")
diff --git a/tests/guix-refresh.sh b/tests/guix-refresh.sh
index 691020b031..9d7a57a36e 100644
--- a/tests/guix-refresh.sh
+++ b/tests/guix-refresh.sh
@@ -34,7 +34,8 @@ GUIX_TEST_UPDATER_TARGETS='
                  ("1.6.4" "file:///dev/null")))
    ("libreoffice" "" (("1.0" "file:///dev/null")))
    ("idutils" "" (("'$idutils_version'" "file:///dev/null")))
-   ("the-test-package" "" (("5.5" "file://'$PWD/$module_dir'/source"))))'
+   ("the-test-package" "" (("5.5" "file://'$PWD/$module_dir'/source"
+                                   ("grep" "sed")))))'
 
 # No newer version available.
 guix refresh -t test idutils	# XXX: should return non-zero?
@@ -91,13 +92,15 @@ cat > "$module_dir/sample.scm"<<EOF
                                   ".tar.gz"))
               (sha256
                (base32
-                "086vqwk2wl8zfs47sq2xpjc9k066ilmb8z6dn0q6ymwjzlm196cd"))))))
+                "086vqwk2wl8zfs47sq2xpjc9k066ilmb8z6dn0q6ymwjzlm196cd"))))
+    (inputs (list coreutils tar))))
 EOF
 guix refresh -t test -L "$module_dir" the-test-package
 guix refresh -t test -L "$module_dir" the-test-package -u \
      --keyring="$module_dir/keyring.kbx"  # so we don't create $HOME/.config
 grep 'version "5.5"' "$module_dir/sample.scm"
 grep "$(guix hash -H sha256 -f nix-base32 "$module_dir/source")" "$module_dir/sample.scm"
+grep '(inputs (list grep sed))' "$module_dir/sample.scm"
 
 # Specifying a target version.
 guix refresh -t test guile=2.0.0 # XXX: should return non-zero?
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 09/14] upstream: Remove <upstream-input-change> and related code.
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
                   ` (7 preceding siblings ...)
  2023-05-18 15:16 ` [bug#63571] [PATCH 08/14] upstream: 'update-package-source' edits input fields Ludovic Courtès
@ 2023-05-18 15:16 ` Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 10/14] tests: upstream: Restore test that was skipped Ludovic Courtès
                   ` (6 subsequent siblings)
  15 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 15:16 UTC (permalink / raw)
  To: 63571
  Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret,
	Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus,
	Simon Tournier, Tobias Geerinckx-Rice

* guix/upstream.scm (<upstream-input-change>): Remove.
(changed-inputs): Remove.
* tests/upstream.scm (test-package, test-new-package)
("changed-inputs returns no changes")
("changed-inputs returns changes to plain input list")
("changed-inputs returns changes to all plain input lists"): Remove.
---
 guix/upstream.scm  |  64 ------------------------
 tests/upstream.scm | 120 ---------------------------------------------
 2 files changed, 184 deletions(-)

diff --git a/guix/upstream.scm b/guix/upstream.scm
index 1a90a342ff..54e6c3b89c 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -82,12 +82,6 @@ (define-module (guix upstream)
             upstream-updater-predicate
             upstream-updater-import
 
-            upstream-input-change?
-            upstream-input-change-name
-            upstream-input-change-type
-            upstream-input-change-action
-            changed-inputs
-
             %updaters
             lookup-updater
 
@@ -151,64 +145,6 @@ (define upstream-source-regular-inputs (input-type-filter 'regular))
 (define upstream-source-native-inputs (input-type-filter 'native))
 (define upstream-source-propagated-inputs (input-type-filter 'propagated))
 
-;; Representation of an upstream input change.
-(define-record-type* <upstream-input-change>
-  upstream-input-change make-upstream-input-change
-  upstream-input-change?
-  (name    upstream-input-change-name)    ;string
-  (type    upstream-input-change-type)    ;symbol: regular | native | propagated
-  (action  upstream-input-change-action)) ;symbol: add | remove
-
-(define (changed-inputs package source)
-  "Return a list of input changes for PACKAGE compared to the 'inputs' field
-of SOURCE, an <upstream-source> record."
-  (define input->name
-    (match-lambda
-      ((label (? package? pkg) . out) (package-name pkg))
-      (_ #f)))
-
-  (if (upstream-source-inputs source)
-      (let* ((new-regular (map upstream-input-downstream-name
-                               (upstream-source-regular-inputs source)))
-             (new-native (map upstream-input-downstream-name
-                              (upstream-source-native-inputs source)))
-             (new-propagated (map upstream-input-downstream-name
-                                  (upstream-source-propagated-inputs source)))
-             (current-regular
-              (filter-map input->name (package-inputs package)))
-             (current-native
-              (filter-map input->name (package-native-inputs package)))
-             (current-propagated
-              (filter-map input->name (package-propagated-inputs package))))
-        (append-map
-         (match-lambda
-           ((action type names)
-            (map (lambda (name)
-                   (upstream-input-change
-                    (name name)
-                    (type type)
-                    (action action)))
-                 names)))
-         `((add regular
-                ,(lset-difference equal?
-                                  new-regular current-regular))
-           (remove regular
-                   ,(lset-difference equal?
-                                     current-regular new-regular))
-           (add native
-                ,(lset-difference equal?
-                                  new-native current-native))
-           (remove native
-                   ,(lset-difference equal?
-                                     current-native new-native))
-           (add propagated
-                ,(lset-difference equal?
-                                  new-propagated current-propagated))
-           (remove propagated
-                   ,(lset-difference equal?
-                                     current-propagated new-propagated)))))
-      '()))
-
 (define* (url-predicate matching-url?)
   "Return a predicate that returns true when passed a package whose source is
 an <origin> with the URL-FETCH method, and one of its URLs passes
diff --git a/tests/upstream.scm b/tests/upstream.scm
index 0792ebd5d0..b82579228a 100644
--- a/tests/upstream.scm
+++ b/tests/upstream.scm
@@ -54,124 +54,4 @@ (define-module (test-upstream)
                            (signature-urls
                             '("ftp://example.org/foo-1.tar.xz.sig"))))))
 
-(define test-package
-  (package
-    (name "test")
-    (version "2.10")
-    (source (origin
-              (method url-fetch)
-              (uri (string-append "mirror://gnu/hello/hello-" version
-                                  ".tar.gz"))
-              (sha256
-               (base32
-                "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i"))))
-    (build-system gnu-build-system)
-    (inputs
-     `(("hello" ,hello)))
-    (native-inputs
-     `(("sed" ,sed)
-       ("tar" ,tar)))
-    (propagated-inputs
-     `(("grep" ,grep)))
-    (home-page "http://localhost")
-    (synopsis "test")
-    (description "test")
-    (license license:gpl3+)))
-
-(test-equal "changed-inputs returns no changes"
-  '()
-  (changed-inputs test-package
-                  (upstream-source
-                   (package "test")
-                   (version "1")
-                   (urls '())
-                   (inputs
-                    (let ((->input
-                           (lambda (type)
-                             (match-lambda
-                               ((label _)
-                                (upstream-input
-                                 (name label)
-                                 (downstream-name label)
-                                 (type type)))))))
-                      (append (map (->input 'regular)
-                                   (package-inputs test-package))
-                              (map (->input 'native)
-                                   (package-native-inputs test-package))
-                              (map (->input 'propagated)
-                                   (package-propagated-inputs
-                                    test-package))))))))
-
-(define test-new-package
-  (package
-    (inherit test-package)
-    (inputs
-     (list hello))
-    (native-inputs
-     (list sed tar))
-    (propagated-inputs
-     (list grep))))
-
-(test-assert "changed-inputs returns changes to plain input list"
-  (let ((changes (changed-inputs
-                  (package
-                    (inherit test-new-package)
-                    (inputs (list hello sed))
-                    (native-inputs '())
-                    (propagated-inputs '()))
-                  (upstream-source
-                   (package "test")
-                   (version "1")
-                   (urls '())
-                   (inputs (list (upstream-input
-                                  (name "hello")
-                                  (downstream-name name))))))))
-    (match changes
-      ;; Exactly one change
-      (((? upstream-input-change? item))
-       (and (equal? (upstream-input-change-type item)
-                    'regular)
-            (equal? (upstream-input-change-action item)
-                    'remove)
-            (string=? (upstream-input-change-name item)
-                      "sed")))
-      (else (pk else #false)))))
-
-(test-assert "changed-inputs returns changes to all plain input lists"
-  (let ((changes (changed-inputs
-                  (package
-                    (inherit test-new-package)
-                    (inputs '())
-                    (native-inputs '())
-                    (propagated-inputs '()))
-                  (upstream-source
-                   (package "test")
-                   (version "1")
-                   (urls '())
-                   (inputs (list (upstream-input
-                                  (name "hello")
-                                  (downstream-name name)
-                                  (type 'regular))
-                                 (upstream-input
-                                  (name "sed")
-                                  (downstream-name name)
-                                  (type 'native))
-                                 (upstream-input
-                                  (name "tar")
-                                  (downstream-name name)
-                                  (type 'native))
-                                 (upstream-input
-                                  (name "grep")
-                                  (downstream-name name)
-                                  (type 'propagated))))))))
-    (match changes
-      (((? upstream-input-change? items) ...)
-       (and (equal? (map upstream-input-change-type items)
-                    '(regular native native propagated))
-            (equal? (map upstream-input-change-action items)
-                    '(add add add add))
-            (equal? (map upstream-input-change-name items)
-                    '("hello" "sed" "tar" "grep"))))
-      (else (pk else #false)))))
-
 (test-end)
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 10/14] tests: upstream: Restore test that was skipped.
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
                   ` (8 preceding siblings ...)
  2023-05-18 15:16 ` [bug#63571] [PATCH 09/14] upstream: Remove <upstream-input-change> and related code Ludovic Courtès
@ 2023-05-18 15:16 ` Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 11/14] import: cpan: Remove unary 'string-append' call Ludovic Courtès
                   ` (5 subsequent siblings)
  15 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 15:16 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès

This test was being skipped since
ea6fb108f6a3a53d48ea187b1f82b5f7ffce00a7.

* tests/upstream.scm ("coalesce-sources same version"): Compare a
serialized form of <upstream-source>.
---
 tests/upstream.scm | 39 ++++++++++++++++++++-------------------
 1 file changed, 20 insertions(+), 19 deletions(-)

diff --git a/tests/upstream.scm b/tests/upstream.scm
index b82579228a..a94bb66068 100644
--- a/tests/upstream.scm
+++ b/tests/upstream.scm
@@ -32,26 +32,27 @@ (define-module (test-upstream)
 \f
 (test-begin "upstream")
 
-;; FIXME: Temporarily skipping this test; see <https://bugs.gnu.org/34229>.
-(test-skip 1)
-
 (test-equal "coalesce-sources same version"
-  (list (upstream-source
-         (package "foo") (version "1")
-         (urls '("ftp://example.org/foo-1.tar.xz"
-                 "ftp://example.org/foo-1.tar.gz"))
-         (signature-urls '("ftp://example.org/foo-1.tar.xz.sig"
-                           "ftp://example.org/foo-1.tar.gz.sig"))))
+  '((source "foo" "1"
+            ("ftp://example.org/foo-1.tar.xz"
+             "ftp://example.org/foo-1.tar.gz")
+            ("ftp://example.org/foo-1.tar.xz.sig"
+             "ftp://example.org/foo-1.tar.gz.sig")))
 
-  (coalesce-sources (list (upstream-source
-                           (package "foo") (version "1")
-                           (urls '("ftp://example.org/foo-1.tar.gz"))
-                           (signature-urls
-                            '("ftp://example.org/foo-1.tar.gz.sig")))
-                          (upstream-source
-                           (package "foo") (version "1")
-                           (urls '("ftp://example.org/foo-1.tar.xz"))
-                           (signature-urls
-                            '("ftp://example.org/foo-1.tar.xz.sig"))))))
+  (map (lambda (source)
+         `(source ,(upstream-source-package source)
+                  ,(upstream-source-version source)
+                  ,(upstream-source-urls source)
+                  ,(upstream-source-signature-urls source)))
+       (coalesce-sources (list (upstream-source
+                                (package "foo") (version "1")
+                                (urls '("ftp://example.org/foo-1.tar.gz"))
+                                (signature-urls
+                                 '("ftp://example.org/foo-1.tar.gz.sig")))
+                               (upstream-source
+                                (package "foo") (version "1")
+                                (urls '("ftp://example.org/foo-1.tar.xz"))
+                                (signature-urls
+                                 '("ftp://example.org/foo-1.tar.xz.sig")))))))
 
 (test-end)
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 11/14] import: cpan: Remove unary 'string-append' call.
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
                   ` (9 preceding siblings ...)
  2023-05-18 15:16 ` [bug#63571] [PATCH 10/14] tests: upstream: Restore test that was skipped Ludovic Courtès
@ 2023-05-18 15:16 ` Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 12/14] import: cpan: Represent dependencies as <upstream-input> records Ludovic Courtès
                   ` (4 subsequent siblings)
  15 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 15:16 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès

* guix/import/cpan.scm (package->upstream-name): Remove useless
'string-append'.
---
 guix/import/cpan.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index da47018c35..d7f300777e 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -154,7 +154,7 @@ (define (package->upstream-name package)
           ((? origin? origin)
            (match (origin-uri origin)
              ((or (? string? url) (url _ ...))
-              (match (string-match (string-append "([^/]*)-v?[0-9\\.]+") url)
+              (match (string-match "([^/]*)-v?[0-9\\.]+" url)
                 (#f #f)
                 (m (match:substring m 1))))
              (_ #f)))
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 12/14] import: cpan: Represent dependencies as <upstream-input> records.
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
                   ` (10 preceding siblings ...)
  2023-05-18 15:16 ` [bug#63571] [PATCH 11/14] import: cpan: Remove unary 'string-append' call Ludovic Courtès
@ 2023-05-18 15:16 ` Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 13/14] import: cpan: Updater provides input list Ludovic Courtès
                   ` (3 subsequent siblings)
  15 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 15:16 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain; charset=^[[6~, Size: 7972 bytes --]

* guix/import/cpan.scm (cpan-name->downstream-name)
(cran-dependency->upstream-input, cran-module-inputs): New procedures.
(cpan-module->sexp)[guix-name, convert-inputs]: Remove.
[maybe-inputs]: Adjust to deal with <upstream-input>.
Use 'cpan-name->downstream-name' instead of 'guix-name'.  Add call to
'cpan-module-inputs' and adjust calls to 'maybe-inputs'.  No longer emit
input labels.
* tests/cpan.scm ("cpan->guix-package"): Adjust test accordingly.
---
 guix/import/cpan.scm | 98 +++++++++++++++++++++++++-------------------
 tests/cpan.scm       |  7 +---
 2 files changed, 58 insertions(+), 47 deletions(-)

diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index d7f300777e..b6587d6821 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -3,7 +3,7 @@
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
 ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
-;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020, 2021, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -222,56 +222,73 @@ (define core-module?
                                        first perl-version last))))
                            (loop)))))))))))
 
+(define (cpan-name->downstream-name name)
+  "Return the Guix package name corresponding to NAME."
+  (if (string-prefix? "perl-" name)
+      (string-downcase name)
+      (string-append "perl-" (string-downcase name))))
+
+(define (cran-dependency->upstream-input dependency)
+  "Return the <upstream-input> corresponding to DEPENDENCY, or #f if
+DEPENDENCY denotes an implicit or otherwise unnecessary dependency."
+  (match (cpan-dependency-module dependency)
+    ("perl" #f)                                   ;implicit dependency
+    (module
+     (let ((type (match (cpan-dependency-phase dependency)
+                   ((or 'configure 'build 'test)
+                    ;; "runtime" may also be needed here.  See
+                    ;; https://metacpan.org/pod/CPAN::Meta::Spec#Phases,
+                    ;; which says they are required during
+                    ;; building.  We have not yet had a need for
+                    ;; cross-compiled Perl modules, however, so
+                    ;; we leave it out.
+                    'native)
+                   ('runtime
+                    'propagated)
+                   (_
+                    #f))))
+       (and type
+            (not (core-module? module))           ;expensive call!
+            (upstream-input
+             (name (module->dist-name module))
+             (downstream-name (cpan-name->downstream-name name))
+             (type type)))))))
+
+(define (cpan-module-inputs release)
+  "Return the list of <upstream-input> for dependencies of RELEASE, a
+<cpan-release>."
+  (define (upstream-input<? a b)
+    (string<? (upstream-input-downstream-name a)
+              (upstream-input-downstream-name b)))
+
+  (sort (delete-duplicates
+         (filter-map cran-dependency->upstream-input
+                     (cpan-release-dependencies release)))
+        upstream-input<?))
+
 (define (cpan-module->sexp release)
   "Return the 'package' s-expression for a CPAN module from the release data
 in RELEASE, a <cpan-release> record."
   (define name
     (cpan-release-distribution release))
 
-  (define (guix-name name)
-    (if (string-prefix? "perl-" name)
-        (string-downcase name)
-        (string-append "perl-" (string-downcase name))))
-
   (define version (cpan-release-version release))
   (define source-url (cpan-source-url release))
 
-  (define (convert-inputs phases)
-    ;; Convert phase dependencies into a list of name/variable pairs.
-    (match (filter-map (lambda (dependency)
-                         (and (memq (cpan-dependency-phase dependency)
-                                    phases)
-                              (cpan-dependency-module dependency)))
-                       (cpan-release-dependencies release))
-      ((inputs ...)
-       (sort
-        (delete-duplicates
-         ;; Listed dependencies may include core modules.  Filter those out.
-         (filter-map (match-lambda
-                       ("perl" #f)                ;implicit dependency
-                       ((? core-module?) #f)
-                       (module
-                         (let ((name (guix-name (module->dist-name module))))
-                           (list name
-                                 (list 'unquote (string->symbol name))))))
-                     inputs))
-        (lambda args
-          (match args
-            (((a _ ...) (b _ ...))
-             (string<? a b))))))))
-
-  (define (maybe-inputs guix-name inputs)
+  (define (maybe-inputs input-type inputs)
     (match inputs
       (()
        '())
       ((inputs ...)
-       (list (list guix-name
-                   (list 'quasiquote inputs))))))
+       `((,input-type (list ,@(map (compose string->symbol
+                                            upstream-input-downstream-name)
+                                   inputs)))))))
 
   (let ((tarball (with-store store
-                   (download-to-store store source-url))))
+                   (download-to-store store source-url)))
+        (inputs (cpan-module-inputs release)))
     `(package
-       (name ,(guix-name name))
+       (name ,(cpan-name->downstream-name name))
        (version ,version)
        (source (origin
                  (method url-fetch)
@@ -281,14 +298,11 @@ (define (cpan-module->sexp release)
                    ,(bytevector->nix-base32-string (file-sha256 tarball))))))
        (build-system perl-build-system)
        ,@(maybe-inputs 'native-inputs
-                       ;; "runtime" may also be needed here.  See
-                       ;; https://metacpan.org/pod/CPAN::Meta::Spec#Phases,
-                       ;; which says they are required during building.  We
-                       ;; have not yet had a need for cross-compiled perl
-                       ;; modules, however, so we leave it out.
-                       (convert-inputs '(configure build test)))
+                       (filter (upstream-input-type-predicate 'native)
+                               inputs))
        ,@(maybe-inputs 'propagated-inputs
-                       (convert-inputs '(runtime)))
+                       (filter (upstream-input-type-predicate 'propagated)
+                               inputs))
        (home-page ,(cpan-home name))
        (synopsis ,(cpan-release-abstract release))
        (description fill-in-yourself!)
diff --git a/tests/cpan.scm b/tests/cpan.scm
index bbcd108e12..c9dd6d36de 100644
--- a/tests/cpan.scm
+++ b/tests/cpan.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
-;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -64,7 +64,6 @@ (define test-source
 (test-begin "cpan")
 
 (test-assert "cpan->guix-package"
-  ;; Replace network resources with sample data.
   (with-http-server `((200 ,test-json)
                       (200 ,test-source)
                       (200 "{ \"distribution\" : \"Test-Script\" }"))
@@ -82,9 +81,7 @@ (define test-source
                        ('base32
                         (? string? hash)))))
            ('build-system 'perl-build-system)
-           ('propagated-inputs
-            ('quasiquote
-             (("perl-test-script" ('unquote 'perl-test-script)))))
+           ('propagated-inputs ('list 'perl-test-script))
            ('home-page "https://metacpan.org/release/Foo-Bar")
            ('synopsis "Fizzle Fuzz")
            ('description 'fill-in-yourself!)
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 13/14] import: cpan: Updater provides input list.
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
                   ` (11 preceding siblings ...)
  2023-05-18 15:16 ` [bug#63571] [PATCH 12/14] import: cpan: Represent dependencies as <upstream-input> records Ludovic Courtès
@ 2023-05-18 15:16 ` Ludovic Courtès
  2023-05-18 15:16 ` [bug#63571] [PATCH 14/14] import: elpa: " Ludovic Courtès
                   ` (2 subsequent siblings)
  15 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 15:16 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès

* guix/import/cpan.scm (latest-release): Add 'inputs' field.
* tests/cpan.scm ("package-latest-release"): New test.
---
 guix/import/cpan.scm |  3 ++-
 tests/cpan.scm       | 27 +++++++++++++++++++++++++++
 2 files changed, 29 insertions(+), 1 deletion(-)

diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index b6587d6821..b87736eef6 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -354,7 +354,8 @@ (define* (latest-release package #:key (version #f))
        (upstream-source
         (package (package-name package))
         (version version)
-        (urls (list url)))))))
+        (urls (list url))
+        (inputs (cpan-module-inputs release)))))))
 
 (define %cpan-updater
   (upstream-updater
diff --git a/tests/cpan.scm b/tests/cpan.scm
index c9dd6d36de..5fcce85d8d 100644
--- a/tests/cpan.scm
+++ b/tests/cpan.scm
@@ -21,7 +21,10 @@
 (define-module (test-cpan)
   #:use-module (guix import cpan)
   #:use-module (guix base32)
+  #:use-module (guix upstream)
+  #:use-module ((guix download) #:select (url-fetch))
   #:use-module (gcrypt hash)
+  #:use-module (guix tests)
   #:use-module (guix tests http)
   #:use-module ((guix store) #:select (%graft?))
   #:use-module (srfi srfi-64)
@@ -92,6 +95,30 @@ (define test-source
         (x
          (pk 'fail x #f))))))
 
+(test-equal "package-latest-release"
+  (list '("http://example.com/Foo-Bar-0.1.tar.gz")
+        #f
+        (list (upstream-input
+               (name "Test-Script")
+               (downstream-name "perl-test-script")
+               (type 'propagated))))
+  (with-http-server `((200 ,test-json)
+                      (200 ,test-source)
+                      (200 "{ \"distribution\" : \"Test-Script\" }"))
+    (define source
+      (parameterize ((%metacpan-base-url (%local-url)))
+        (package-latest-release
+         (dummy-package "perl-test-script"
+                        (version "0.0.0")
+                        (source (dummy-origin
+                                 (method url-fetch)
+                                 (uri "mirror://cpan/Foo-Bar-0.0.0.tgz"))))
+         (list %cpan-updater))))
+
+    (list (upstream-source-urls source)
+          (upstream-source-signature-urls source)
+          (upstream-source-inputs source))))
+
 (test-equal "metacpan-url->mirror-url, http"
   "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"
   (metacpan-url->mirror-url
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 14/14] import: elpa: Updater provides input list.
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
                   ` (12 preceding siblings ...)
  2023-05-18 15:16 ` [bug#63571] [PATCH 13/14] import: cpan: Updater provides input list Ludovic Courtès
@ 2023-05-18 15:16 ` Ludovic Courtès
  2023-05-18 16:01 ` [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Liliana Marie Prikler
  2023-05-29 14:44 ` Ludovic Courtès
  15 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 15:16 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès, Andrew Tropin, Liliana Marie Prikler

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain; charset=^[[6~, Size: 5449 bytes --]

* guix/import/elpa.scm (elpa-dependency->upstream-input): New
procedure.
(latest-release): Add 'inputs' field.
* tests/elpa.scm ("package-latest-release"): New test.
---
 guix/import/elpa.scm | 28 ++++++++++++++++++++++++--
 tests/elpa.scm       | 48 ++++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 72 insertions(+), 4 deletions(-)

diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index 1313a8aa67..f32a3a156e 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -272,6 +272,25 @@ (define* (melpa-recipe->origin recipe)
                 (assq-ref recipe ':fetcher))
        #f)))
 
+(define (elpa-dependency->upstream-input dependency)
+  "Convert DEPENDENCY, an sexp as returned by 'elpa-package-inputs', into an
+<upstream-input>."
+  (match dependency
+    ((name version)
+     (and (not (emacs-standard-library? (symbol->string name)))
+          (upstream-input
+           (name (symbol->string name))
+           (downstream-name (elpa-guix-name name))
+           (type 'propagated)
+           (min-version (if (pair? version)
+                            (string-join (map number->string version) ".")
+                            #f))
+           (max-version (match version
+                          (() #f)
+                          ((_) #f)
+                          ((_ _) #f)
+                          (_ min-version))))))))
+
 (define default-files-spec
   ;; This contains more than just the things contained in %default-include and
   ;; %default-exclude, presumably because this includes source files (*.in,
@@ -421,12 +440,17 @@ (define* (latest-release package #:key (version #f))
                         (elpa-version->string raw-version))))
             (url     (match info
                        ((_ raw-version reqs synopsis kind . rest)
-                        (package-source-url kind name version repo)))))
+                        (package-source-url kind name version repo))))
+            (inputs  (match info
+                       ((name raw-version reqs . _)
+                        (filter-map elpa-dependency->upstream-input
+                                    reqs)))))
        (upstream-source
         (package (package-name package))
         (version version)
         (urls (list url))
-        (signature-urls (list (string-append url ".sig"))))))))
+        (signature-urls (list (string-append url ".sig")))
+        (inputs inputs))))))
 
 (define elpa-repository
   (memoize
diff --git a/tests/elpa.scm b/tests/elpa.scm
index 1efdf2457f..56008fe014 100644
--- a/tests/elpa.scm
+++ b/tests/elpa.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
-;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
 ;;;
@@ -21,6 +21,8 @@
 
 (define-module (test-elpa)
   #:use-module (guix import elpa)
+  #:use-module (guix upstream)
+  #:use-module ((guix download) #:select (url-fetch))
   #:use-module (guix tests)
   #:use-module (guix tests http)
   #:use-module (srfi srfi-1)
@@ -40,8 +42,20 @@ (define elpa-mock-archive
     (auctex .
             [(11 88 6)
              nil "Integrated environment for *TeX*" tar
-             ((:url . "http://www.gnu.org/software/auctex/"))])))
+             ((:url . "http://www.gnu.org/software/auctex/"))])
+    (taxy-magit-section .
+		        [(0 12 2)
+		         ((emacs
+			   (26 3))
+		          (magit-section
+			   (3 2 1))
+		          (taxy
+			   (0 10)))
+		         "View Taxy structs in a Magit Section buffer" tar
+		         ((:url . "https://github.com/alphapapa/taxy.el")
+		          (:keywords "lisp"))])))
 
+\f
 (test-begin "elpa")
 
 (define (eval-test-with-elpa pkg)
@@ -73,6 +87,36 @@ (define (eval-test-with-elpa pkg)
 (test-assert "elpa->guix-package test 1"
   (eval-test-with-elpa "auctex"))
 
+(test-equal "package-latest-release"
+  (list '("https://elpa.gnu.org/packages/taxy-magit-section-0.12.2.tar")
+        '("https://elpa.gnu.org/packages/taxy-magit-section-0.12.2.tar.sig")
+        (list (upstream-input
+               (name "magit-section")
+               (downstream-name "emacs-magit-section")
+               (type 'propagated)
+               (min-version "3.2.1")
+               (max-version min-version))
+              (upstream-input
+               (name "taxy")
+               (downstream-name "emacs-taxy")
+               (type 'propagated)
+               (min-version "0.10")
+               (max-version #f))))
+  (with-http-server `((200 ,(object->string elpa-mock-archive)))
+    (parameterize ((current-http-proxy (%local-url)))
+      (define source
+        (package-latest-release
+         (dummy-package "emacs-taxy-magit-section"
+                        (version "0.0.0")
+                        (source (dummy-origin
+                                 (method url-fetch)
+                                 (uri "https://elpa.gnu.org/xyz"))))
+         (list %elpa-updater)))
+
+      (list (upstream-source-urls source)
+            (upstream-source-signature-urls source)
+            (upstream-source-inputs source)))))
+
 (test-equal "guix-package->elpa-name: without 'upstream-name' property"
   "auctex"
   (guix-package->elpa-name (dummy-package "emacs-auctex")))
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
                   ` (13 preceding siblings ...)
  2023-05-18 15:16 ` [bug#63571] [PATCH 14/14] import: elpa: " Ludovic Courtès
@ 2023-05-18 16:01 ` Liliana Marie Prikler
  2023-05-18 17:02   ` Ludovic Courtès
  2023-05-29 14:44 ` Ludovic Courtès
  15 siblings, 1 reply; 38+ messages in thread
From: Liliana Marie Prikler @ 2023-05-18 16:01 UTC (permalink / raw)
  To: Ludovic Courtès, 63571; +Cc: Andrew Tropin

Am Donnerstag, dem 18.05.2023 um 17:11 +0200 schrieb Ludovic Courtès:
> Hello!
> 
> Until now, ‘guix refresh -u’ would tell you what inputs need to
> be changed in your packages, for the ‘cran’, ‘pypi’, and ‘stackage’
> updaters.  With this change it changes them right away.
> 
> [...]
> Thoughts?
Sounds useful, but we should still look over the additions and removals
to check whether they are adequate.  When I refreshed python-mpi4py
today, it suggested to remove the openmpi input :)

Cheers




^ permalink raw reply	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields
  2023-05-18 16:01 ` [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Liliana Marie Prikler
@ 2023-05-18 17:02   ` Ludovic Courtès
  0 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-18 17:02 UTC (permalink / raw)
  To: Liliana Marie Prikler; +Cc: 63571, Andrew Tropin

Hi,

Liliana Marie Prikler <liliana.prikler@gmail.com> skribis:

> Am Donnerstag, dem 18.05.2023 um 17:11 +0200 schrieb Ludovic Courtès:
>> Hello!
>> 
>> Until now, ‘guix refresh -u’ would tell you what inputs need to
>> be changed in your packages, for the ‘cran’, ‘pypi’, and ‘stackage’
>> updaters.  With this change it changes them right away.
>> 
>> [...]
>> Thoughts?
> Sounds useful, but we should still look over the additions and removals
> to check whether they are adequate.

Yes, definitely!

> When I refreshed python-mpi4py today, it suggested to remove the
> openmpi input :)

Yeah, in general these per-language repositories don’t express
foreign-language dependencies, or they do it in a way that’s hard to
translate.  So this is the typical case where one needs to pay
attention, indeed.

Ludo’.




^ permalink raw reply	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields
  2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
                   ` (14 preceding siblings ...)
  2023-05-18 16:01 ` [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Liliana Marie Prikler
@ 2023-05-29 14:44 ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 01/19] tests: pypi: Factorize tarball and wheel file creation Ludovic Courtès
                     ` (19 more replies)
  15 siblings, 20 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:44 UTC (permalink / raw)
  To: 63571

Hi!

Ludovic Courtès <ludo@gnu.org> skribis:

> Until now, ‘guix refresh -u’ would tell you what inputs need to
> be changed in your packages, for the ‘cran’, ‘pypi’, and ‘stackage’
> updaters.  With this change it changes them right away.
>
> Furthermore, ‘guix refresh -u’ will now also update inputs when the
> ‘cpan’ and ‘elpa’ updaters are used.  Doing that for other updaters
> is left as an exercise to the reader.  :-)

One thing discussed with Ricardo on #guix-hpc is the need for
exceptions for cases where the importer gets inputs wrong.  Examples:

  • The CRAN updater might suggest adding ‘r-knitr’ as an input to a
    dependency of ‘r-knitr’.

  • There are other more complicated cases such as ‘r-dt’, which depends
    on JavaScript code.

  • The PyPI updater doesn’t know about the ‘openmpi’ input of
    ‘python-mpi4py’ so it would remove it.

This is addressed in v2 of this patch series, along with other
improvements (changes since v1):

  • honors ‘updater-extra-inputs’ and ‘updater-ignored-inputs’ package
    properties (and similarly for native and propagated inputs);

  • add those properties to a few packages;

  • ‘cran’ updater keeps inputs alphabetically sorted;

  • ‘gem’ updater now updates inputs as well.

Surely this will reveal limitations of updaters/importers but I’d like
to see it as an opportunity to improve them; more importantly, we have
to reduce the maintenance cost of all these imported packages, and this
is a step in that direction.

If there are no objections, I’d like to apply this series within a few
days.

Feedback welcome!

Ludo’.




^ permalink raw reply	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 01/19] tests: pypi: Factorize tarball and wheel file creation.
  2023-05-29 14:44 ` Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 02/19] tests: http: Allow responses to specify a path Ludovic Courtès
                     ` (18 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès, Lars-Dominik Braun, jgart

* tests/pypi.scm (sample-directory): New variable.
(pypi-tarball, wheel-file): New procedures.
("pypi->guix-package, no wheel")
("pypi->guix-package, wheels")
("pypi->guix-package, no usable requirement file.")
("pypi->guix-package, package name contains \"-\" followed by digits"):
Use them.
---
 tests/pypi.scm | 126 ++++++++++++++++++++++++++++++++-----------------
 1 file changed, 82 insertions(+), 44 deletions(-)

diff --git a/tests/pypi.scm b/tests/pypi.scm
index 1ddcc542ff..1c85e6a16f 100644
--- a/tests/pypi.scm
+++ b/tests/pypi.scm
@@ -28,8 +28,12 @@ (define-module (test-pypi)
   #: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 build utils)
+                #:select (delete-file-recursively
+                          which mkdir-p
+                          with-directory-excursion))
   #:use-module ((guix diagnostics) #:select (guix-warning-port))
+  #:use-module ((guix build syscalls) #:select (mkdtemp!))
   #:use-module (json)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
@@ -131,6 +135,58 @@ (define test-metadata-with-extras-jedi "\
 Requires-Dist: pytest (>=3.1.0); extra == 'testing'
 ")
 
+(define sample-directory
+  ;; Directory containing tarballs and .whl files for this test.
+  (let ((template (string-append (or (getenv "TMPDIR") "/tmp")
+                                 "/guix-pypi-test-XXXXXX")))
+    (mkdtemp! template)))
+
+(define (pypi-tarball name specs)
+  "Return a PyPI tarball called NAME suffixed with '.tar.gz' and containing
+the files specified in SPECS.  Return its file name."
+  (let ((directory (in-vicinity sample-directory name))
+        (tarball (in-vicinity sample-directory (string-append name ".tar.gz"))))
+    (false-if-exception (delete-file tarball))
+    (mkdir-p directory)
+    (for-each (match-lambda
+                ((file content)
+                 (mkdir-p (in-vicinity directory (dirname file)))
+                 (call-with-output-file (in-vicinity directory file)
+                   (lambda (port)
+                     (display content port)))))
+              specs)
+    (parameterize ((current-output-port (%make-void-port "w0")))
+      (system* "tar" "-C" sample-directory "-czvf" tarball
+               (basename directory)))
+    (delete-file-recursively directory)
+    tarball))
+
+(define (wheel-file name specs)
+  "Return a Wheel file called NAME suffixed with '.whl' and containing the
+files specified by SPECS.  Return its file name."
+  (let* ((directory (in-vicinity sample-directory
+                                 (string-append name ".dist-info")))
+         (zip-file (in-vicinity sample-directory
+                                (string-append name ".zip")))
+         (whl-file (in-vicinity sample-directory
+                                (string-append name ".whl"))))
+    (false-if-exception (delete-file whl-file))
+    (mkdir-p directory)
+    (for-each (match-lambda
+                ((file content)
+                 (mkdir-p (in-vicinity directory (dirname file)))
+                 (call-with-output-file (in-vicinity directory file)
+                   (lambda (port)
+                     (display content port)))))
+              specs)
+    ;; zip always adds a "zip" extension to the file it creates,
+    ;; so we need to rename it.
+    (with-directory-excursion (dirname directory)
+      (system* "zip" "-qr" zip-file (basename directory)))
+    (rename-file zip-file whl-file)
+    (delete-file-recursively directory)
+    whl-file))
+
 \f
 (test-begin "pypi")
 
@@ -224,17 +280,13 @@ (define test-metadata-with-extras-jedi "\
            (lambda (url file-name)
              (match url
                ("https://example.com/foo-1.0.0.tar.gz"
-                (begin
-                  ;; Unusual requires.txt location should still be found.
-                  (mkdir-p "foo-1.0.0/src/bizarre.egg-info")
-                  (with-output-to-file "foo-1.0.0/src/bizarre.egg-info/requires.txt"
-                    (lambda ()
-                      (display test-requires.txt)))
-                  (parameterize ((current-output-port (%make-void-port "rw+")))
-                    (system* "tar" "czvf" file-name "foo-1.0.0/"))
-                  (delete-file-recursively "foo-1.0.0")
+                ;; Unusual requires.txt location should still be found.
+                (let ((tarball (pypi-tarball "foo-1.0.0"
+                                             `(("src/bizarre.egg-info/requires.txt"
+                                                ,test-requires.txt)))))
+                  (copy-file tarball file-name)
                   (set! test-source-hash
-                    (call-with-input-file file-name port-sha256))))
+                        (call-with-input-file file-name port-sha256))))
                ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
                (_ (error "Unexpected URL: " url)))))
           (mock ((guix http-client) http-fetch
@@ -279,28 +331,18 @@ (define test-metadata-with-extras-jedi "\
          (lambda (url file-name)
            (match url
              ("https://example.com/foo-1.0.0.tar.gz"
-              (begin
-                (mkdir-p "foo-1.0.0/foo.egg-info/")
-                (with-output-to-file "foo-1.0.0/foo.egg-info/requires.txt"
-                  (lambda ()
-                    (display "wrong data to make sure we're testing wheels ")))
-                (parameterize ((current-output-port (%make-void-port "rw+")))
-                  (system* "tar" "czvf" file-name "foo-1.0.0/"))
-                (delete-file-recursively "foo-1.0.0")
+              (let ((tarball (pypi-tarball
+                              "foo-1.0.0"
+                              '(("foo-1.0.0/foo.egg-info/requires.txt"
+                                 "wrong data \
+to make sure we're testing wheels")))))
+                (copy-file tarball file-name)
                 (set! test-source-hash
                   (call-with-input-file file-name port-sha256))))
              ("https://example.com/foo-1.0.0-py2.py3-none-any.whl"
-              (begin
-                (mkdir "foo-1.0.0.dist-info")
-                (with-output-to-file "foo-1.0.0.dist-info/METADATA"
-                  (lambda ()
-                    (display test-metadata)))
-                (let ((zip-file (string-append file-name ".zip")))
-                  ;; zip always adds a "zip" extension to the file it creates,
-                  ;; so we need to rename it.
-                  (system* "zip" "-q" zip-file "foo-1.0.0.dist-info/METADATA")
-                  (rename-file zip-file file-name))
-                (delete-file-recursively "foo-1.0.0.dist-info")))
+              (let ((wheel (wheel-file "foo-1.0.0"
+                                       `(("METADATA" ,test-metadata)))))
+                (copy-file wheel file-name)))
              (_ (error "Unexpected URL: " url)))))
         (mock ((guix http-client) http-fetch
                (lambda (url . rest)
@@ -342,12 +384,11 @@ (define test-metadata-with-extras-jedi "\
          (lambda (url file-name)
            (match url
              ("https://example.com/foo-1.0.0.tar.gz"
-              (mkdir-p "foo-1.0.0/foo.egg-info/")
-              (parameterize ((current-output-port (%make-void-port "rw+")))
-                (system* "tar" "czvf" file-name "foo-1.0.0/"))
-              (delete-file-recursively "foo-1.0.0")
-              (set! test-source-hash
-                (call-with-input-file file-name port-sha256)))
+              (let ((tarball (pypi-tarball "foo-1.0.0"
+                                           '(("foo.egg-info/.empty" "")))))
+                (copy-file tarball file-name)
+                (set! test-source-hash
+                      (call-with-input-file file-name port-sha256))))
              ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
              (_ (error "Unexpected URL: " url)))))
         (mock ((guix http-client) http-fetch
@@ -388,15 +429,11 @@ (define test-metadata-with-extras-jedi "\
          (lambda (url file-name)
            (match url
              ("https://example.com/foo-99-1.0.0.tar.gz"
-              (begin
+              (let ((tarball (pypi-tarball "foo-99-1.0.0"
+                                           `(("src/bizarre.egg-info/requires.txt"
+                                              ,test-requires.txt)))))
                 ;; Unusual requires.txt location should still be found.
-                (mkdir-p "foo-99-1.0.0/src/bizarre.egg-info")
-                (with-output-to-file "foo-99-1.0.0/src/bizarre.egg-info/requires.txt"
-                  (lambda ()
-                    (display test-requires.txt)))
-                (parameterize ((current-output-port (%make-void-port "rw+")))
-                  (system* "tar" "czvf" file-name "foo-99-1.0.0/"))
-                (delete-file-recursively "foo-99-1.0.0")
+                (copy-file tarball file-name)
                 (set! test-source-hash
                   (call-with-input-file file-name port-sha256))))
              ("https://example.com/foo-99-1.0.0-py2.py3-none-any.whl" #f)
@@ -434,3 +471,4 @@ (define test-metadata-with-extras-jedi "\
                  (pk 'fail x #f))))))
 
 (test-end "pypi")
+(delete-file-recursively sample-directory)

base-commit: fb1c5d4df7d1479e715f9a28246ef8f92513be59
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 02/19] tests: http: Allow responses to specify a path.
  2023-05-29 14:44 ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 01/19] tests: pypi: Factorize tarball and wheel file creation Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 03/19] tests: pypi: Rewrite tests using a local HTTP server Ludovic Courtès
                     ` (17 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès

* guix/tests/http.scm (%local-url): Add #:path parameter and honor it.
(call-with-http-server)[responses]: Add extra clause with 'path'.
[bad-request]: New variable.
[server-body]: Handle three-element clauses.
Wrap 'run-server' call in 'parameterize'.
---
 guix/tests/http.scm | 46 +++++++++++++++++++++++++++++++++++++++------
 1 file changed, 40 insertions(+), 6 deletions(-)

diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index 37e5744353..17485df9ef 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2017, 2019, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -21,7 +21,10 @@ (define-module (guix tests http)
   #:use-module (ice-9 threads)
   #:use-module (web server)
   #:use-module (web server http)
+  #:use-module (web request)
   #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (ice-9 match)
   #:export (with-http-server
@@ -60,12 +63,13 @@ (define (open-http-server-socket)
                 (strerror err))
         (values #f #f)))))
 
-(define* (%local-url #:optional (port (%http-server-port)))
+(define* (%local-url #:optional (port (%http-server-port))
+                     #:key (path "/foo/bar"))
   (when (= port 0)
     (error "no web server is running!"))
   ;; URL to use for 'home-page' tests.
   (string-append "http://localhost:" (number->string port)
-                 "/foo/bar"))
+                 path))
 
 (define* (call-with-http-server responses+data thunk)
   "Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
@@ -81,6 +85,18 @@ (define* (call-with-http-server responses+data thunk)
            (((? integer? code) data)
             (list (build-response #:code code
                                   #:reason-phrase "Such is life")
+                  data))
+           (((? string? path) (? integer? code) data)
+            (list path
+                  (build-response #:code code
+                                  #:headers
+                                  (if (string? data)
+                                      '()
+                                      '((content-type ;binary data
+                                         . (application/octet-stream
+                                            (charset
+                                             . "ISO-8859-1")))))
+                                  #:reason-phrase "Such is life")
                   data)))
          responses+data))
 
@@ -116,19 +132,37 @@ (define* (call-with-http-server responses+data thunk)
     http-write
     (@@ (web server http) http-close))
 
+  (define bad-request
+    (build-response #:code 400 #:reason-phrase "Unexpected request"))
+
   (define (server-body)
     (define (handle request body)
       (match responses
         (((response data) rest ...)
          (set! responses rest)
-         (values response data))))
+         (values response data))
+        ((((? string?) response data) ...)
+         (let ((path (uri-path (request-uri request))))
+           (match (assoc path responses)
+             (#f (values bad-request ""))
+             ((_ response data)
+              (if (eq? 'GET (request-method request))
+                  ;; Note: Use 'assoc-remove!' to remove only the first entry
+                  ;; with PATH as its key.  That way, RESPONSES can contain
+                  ;; the same path several times.
+                  (let ((rest (assoc-remove! responses path)))
+                    (set! responses rest)
+                    (values response data))
+                  (values bad-request ""))))))))
 
     (let-values (((socket port) (open-http-server-socket)))
       (set! %http-real-server-port port)
       (catch 'quit
         (lambda ()
-          (run-server handle stub-http-server
-                      `(#:socket ,socket)))
+          ;; Let HANDLE refer to '%http-server-port' if needed.
+          (parameterize ((%http-server-port %http-real-server-port))
+            (run-server handle stub-http-server
+                        `(#:socket ,socket))))
         (lambda _
           (close-port socket)))))
 
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 03/19] tests: pypi: Rewrite tests using a local HTTP server.
  2023-05-29 14:44 ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 01/19] tests: pypi: Factorize tarball and wheel file creation Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 02/19] tests: http: Allow responses to specify a path Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 04/19] import: utils: 'call-with-networking-exception-handler' doesn't unwind Ludovic Courtès
                     ` (16 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès, Lars-Dominik Braun, jgart

* guix/import/pypi.scm (%pypi-base-url): New variable.
(pypi-fetch): Use it.
* tests/pypi.scm (foo-json): Compute URLs relative to '%local-url'.
(test-json-1, test-json-2, test-source-hash): Remove.
(file-dump): New procedure.
(with-pypi): New macro.
("pypi->guix-package, no wheel")
("pypi->guix-package, wheels")
("pypi->guix-package, no usable requirement file.")
("pypi->guix-package, package name contains \"-\" followed by digits"):
Rewrite using 'with-pypi'.
---
 guix/import/pypi.scm |   9 +-
 tests/pypi.scm       | 353 +++++++++++++++++++------------------------
 2 files changed, 160 insertions(+), 202 deletions(-)

diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index f780bf1f15..8c06b19cff 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -55,7 +55,8 @@ (define-module (guix import pypi)
   #:use-module (guix packages)
   #:use-module (guix upstream)
   #:use-module ((guix licenses) #:prefix license:)
-  #:export (parse-requires.txt
+  #:export (%pypi-base-url
+            parse-requires.txt
             parse-wheel-metadata
             specification->requirement-name
             guix-package->pypi-name
@@ -67,6 +68,10 @@ (define-module (guix import pypi)
 ;; The PyPI API (notice the rhyme) is "documented" at:
 ;; <https://warehouse.readthedocs.io/api-reference/json/>.
 
+(define %pypi-base-url
+  ;; Base URL of the PyPI API.
+  (make-parameter "https://pypi.org/pypi/"))
+
 (define non-empty-string-or-false
   (match-lambda
     ("" #f)
@@ -123,7 +128,7 @@ (define-json-mapping <distribution> make-distribution distribution?
 
 (define (pypi-fetch name)
   "Return a <pypi-project> record for package NAME, or #f on failure."
-  (and=> (json-fetch (string-append "https://pypi.org/pypi/" name "/json"))
+  (and=> (json-fetch (string-append (%pypi-base-url) name "/json"))
          json->pypi-project))
 
 ;; For packages found on PyPI that lack a source distribution.
diff --git a/tests/pypi.scm b/tests/pypi.scm
index 1c85e6a16f..497744511f 100644
--- a/tests/pypi.scm
+++ b/tests/pypi.scm
@@ -27,10 +27,11 @@ (define-module (test-pypi)
   #:use-module (guix utils)
   #:use-module (gcrypt hash)
   #:use-module (guix tests)
+  #:use-module (guix tests http)
   #:use-module (guix build-system python)
   #:use-module ((guix build utils)
                 #:select (delete-file-recursively
-                          which mkdir-p
+                          which mkdir-p dump-port
                           with-directory-excursion))
   #:use-module ((guix diagnostics) #:select (guix-warning-port))
   #:use-module ((guix build syscalls) #:select (mkdtemp!))
@@ -57,25 +58,19 @@ (define* (foo-json #:key (name "foo") (name-in-url #f))
      (urls . #())
      (releases
       . ((1.0.0
-          . #(((url . ,(format #f "https://example.com/~a-1.0.0.egg"
+          . #(((url . ,(format #f "~a/~a-1.0.0.egg"
+                               (%local-url #:path "")
                                (or name-in-url name)))
                (packagetype . "bdist_egg"))
-              ((url . ,(format #f "https://example.com/~a-1.0.0.tar.gz"
+              ((url . ,(format #f "~a/~a-1.0.0.tar.gz"
+                               (%local-url #:path "")
                                (or name-in-url name)))
                (packagetype . "sdist"))
-              ((url . ,(format #f "https://example.com/~a-1.0.0-py2.py3-none-any.whl"
+              ((url . ,(format #f "~a/~a-1.0.0-py2.py3-none-any.whl"
+                               (%local-url #:path "")
                                (or name-in-url name)))
                (packagetype . "bdist_wheel")))))))))
 
-(define test-json-1
-  (foo-json))
-
-(define test-json-2
-  (foo-json #:name "foo-99"))
-
-(define test-source-hash
-  "")
-
 (define test-specifications
   '("Fizzy [foo, bar]"
     "PickyThing<1.6,>1.9,!=1.9.6,<2.0a0,==2.4c1"
@@ -187,6 +182,18 @@ (define (wheel-file name specs)
     (delete-file-recursively directory)
     whl-file))
 
+(define (file-dump file)
+  "Return a procedure that dumps FILE to the given port."
+  (lambda (output)
+    (call-with-input-file file
+      (lambda (input)
+        (dump-port input output)))))
+
+(define-syntax-rule (with-pypi responses body ...)
+  (with-http-server responses
+    (parameterize ((%pypi-base-url (%local-url #:path "/")))
+      body ...)))
+
 \f
 (test-begin "pypi")
 
@@ -275,200 +282,146 @@ (define (wheel-file name specs)
    "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
-           (lambda (url file-name)
-             (match url
-               ("https://example.com/foo-1.0.0.tar.gz"
-                ;; Unusual requires.txt location should still be found.
-                (let ((tarball (pypi-tarball "foo-1.0.0"
-                                             `(("src/bizarre.egg-info/requires.txt"
-                                                ,test-requires.txt)))))
-                  (copy-file tarball file-name)
-                  (set! test-source-hash
-                        (call-with-input-file file-name port-sha256))))
-               ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
-               (_ (error "Unexpected URL: " url)))))
-          (mock ((guix http-client) http-fetch
-                 (lambda (url . rest)
-                   (match url
-                     ("https://pypi.org/pypi/foo/json"
-                      (values (open-input-string test-json-1)
-                              (string-length test-json-1)))
-                     ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
-                     (_ (error "Unexpected URL: " url)))))
-                (match (pypi->guix-package "foo")
-                  (('package
-                     ('name "python-foo")
-                     ('version "1.0.0")
-                     ('source ('origin
-                                ('method 'url-fetch)
-                                ('uri ('pypi-uri "foo" 'version))
-                                ('sha256
-                                 ('base32
-                                  (? string? hash)))))
-                     ('build-system 'pyproject-build-system)
-                     ('propagated-inputs ('list 'python-bar 'python-foo))
-                     ('native-inputs ('list 'python-pytest))
-                     ('home-page "http://example.com")
-                     ('synopsis "summary")
-                     ('description "summary")
-                     ('license 'license:lgpl2.0))
-                   (and (string=? (bytevector->nix-base32-string
-                                   test-source-hash)
-                                  hash)
-                        (equal? (pypi->guix-package "foo" #:version "1.0.0")
-                                (pypi->guix-package "foo"))
-                        (guard (c ((error? c) #t))
-                          (pypi->guix-package "foo" #:version "42"))))
-                  (x
-                   (pk 'fail x #f))))))
+  (let ((tarball (pypi-tarball
+                  "foo-1.0.0"
+                  `(("src/bizarre.egg-info/requires.txt"
+                     ,test-requires.txt))))
+        (twice (lambda (lst) (append lst lst))))
+    (with-pypi (twice `(("/foo-1.0.0.tar.gz" 200 ,(file-dump tarball))
+                        ("/foo-1.0.0-py2.py3-none-any.whl" 404 "")
+                        ("/foo/json" 200 ,(lambda (port)
+                                            (display (foo-json) port)))))
+      (match (pypi->guix-package "foo")
+        (('package
+           ('name "python-foo")
+           ('version "1.0.0")
+           ('source ('origin
+                      ('method 'url-fetch)
+                      ('uri ('pypi-uri "foo" 'version))
+                      ('sha256
+                       ('base32
+                        (? string? hash)))))
+           ('build-system 'pyproject-build-system)
+           ('propagated-inputs ('list 'python-bar 'python-foo))
+           ('native-inputs ('list 'python-pytest))
+           ('home-page "http://example.com")
+           ('synopsis "summary")
+           ('description "summary")
+           ('license 'license:lgpl2.0))
+         (and (string=? (bytevector->nix-base32-string
+                         (file-sha256 tarball))
+                        hash)
+              (equal? (pypi->guix-package "foo" #:version "1.0.0")
+                      (pypi->guix-package "foo"))
+              (guard (c ((error? c) #t))
+                (pypi->guix-package "foo" #:version "42"))))
+        (x
+         (pk 'fail x #f))))))
 
 (test-skip (if (which "zip") 0 1))
 (test-assert "pypi->guix-package, wheels"
-  ;; Replace network resources with sample data.
-  (mock ((guix import utils) url-fetch
-         (lambda (url file-name)
-           (match url
-             ("https://example.com/foo-1.0.0.tar.gz"
-              (let ((tarball (pypi-tarball
-                              "foo-1.0.0"
-                              '(("foo-1.0.0/foo.egg-info/requires.txt"
-                                 "wrong data \
-to make sure we're testing wheels")))))
-                (copy-file tarball file-name)
-                (set! test-source-hash
-                  (call-with-input-file file-name port-sha256))))
-             ("https://example.com/foo-1.0.0-py2.py3-none-any.whl"
-              (let ((wheel (wheel-file "foo-1.0.0"
-                                       `(("METADATA" ,test-metadata)))))
-                (copy-file wheel file-name)))
-             (_ (error "Unexpected URL: " url)))))
-        (mock ((guix http-client) http-fetch
-               (lambda (url . rest)
-                 (match url
-                   ("https://pypi.org/pypi/foo/json"
-                    (values (open-input-string test-json-1)
-                            (string-length test-json-1)))
-                   ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
-                   (_ (error "Unexpected URL: " url)))))
-              ;; Not clearing the memoization cache here would mean returning the value
-              ;; computed in the previous test.
-              (invalidate-memoization! pypi->guix-package)
-              (match (pypi->guix-package "foo")
-                (('package
-                   ('name "python-foo")
-                   ('version "1.0.0")
-                   ('source ('origin
-                              ('method 'url-fetch)
-                              ('uri ('pypi-uri "foo" 'version))
-                              ('sha256
-                               ('base32
-                                (? string? hash)))))
-                   ('build-system 'pyproject-build-system)
-                   ('propagated-inputs ('list 'python-bar 'python-baz))
-                   ('native-inputs ('list 'python-pytest))
-                   ('home-page "http://example.com")
-                   ('synopsis "summary")
-                   ('description "summary")
-                   ('license 'license:lgpl2.0))
-                 (string=? (bytevector->nix-base32-string
-                            test-source-hash)
-                           hash))
-                (x
-                 (pk 'fail x #f))))))
+  (let ((tarball (pypi-tarball
+                  "foo-1.0.0"
+                  '(("foo-1.0.0/foo.egg-info/requires.txt"
+                     "wrong data \
+to make sure we're testing wheels"))))
+        (wheel (wheel-file "foo-1.0.0"
+                           `(("METADATA" ,test-metadata)))))
+    (with-pypi `(("/foo-1.0.0.tar.gz" 200 ,(file-dump tarball))
+                 ("/foo-1.0.0-py2.py3-none-any.whl"
+                  200 ,(file-dump wheel))
+                 ("/foo/json" 200 ,(lambda (port)
+                                     (display (foo-json) port))))
+      ;; Not clearing the memoization cache here would mean returning the value
+      ;; computed in the previous test.
+      (invalidate-memoization! pypi->guix-package)
+      (match (pypi->guix-package "foo")
+        (('package
+           ('name "python-foo")
+           ('version "1.0.0")
+           ('source ('origin
+                      ('method 'url-fetch)
+                      ('uri ('pypi-uri "foo" 'version))
+                      ('sha256
+                       ('base32
+                        (? string? hash)))))
+           ('build-system 'pyproject-build-system)
+           ('propagated-inputs ('list 'python-bar 'python-baz))
+           ('native-inputs ('list 'python-pytest))
+           ('home-page "http://example.com")
+           ('synopsis "summary")
+           ('description "summary")
+           ('license 'license:lgpl2.0))
+         (string=? (bytevector->nix-base32-string (file-sha256 tarball))
+                   hash))
+        (x
+         (pk 'fail x #f))))))
 
 (test-assert "pypi->guix-package, no usable requirement file."
-  ;; Replace network resources with sample data.
-  (mock ((guix import utils) url-fetch
-         (lambda (url file-name)
-           (match url
-             ("https://example.com/foo-1.0.0.tar.gz"
-              (let ((tarball (pypi-tarball "foo-1.0.0"
-                                           '(("foo.egg-info/.empty" "")))))
-                (copy-file tarball file-name)
-                (set! test-source-hash
-                      (call-with-input-file file-name port-sha256))))
-             ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
-             (_ (error "Unexpected URL: " url)))))
-        (mock ((guix http-client) http-fetch
-               (lambda (url . rest)
-                 (match url
-                   ("https://pypi.org/pypi/foo/json"
-                    (values (open-input-string test-json-1)
-                            (string-length test-json-1)))
-                   ("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
-                   (_ (error "Unexpected URL: " url)))))
-              ;; Not clearing the memoization cache here would mean returning the value
-              ;; computed in the previous test.
-              (invalidate-memoization! pypi->guix-package)
-              (match (pypi->guix-package "foo")
-                (('package
-                   ('name "python-foo")
-                   ('version "1.0.0")
-                   ('source ('origin
-                              ('method 'url-fetch)
-                              ('uri ('pypi-uri "foo" 'version))
-                              ('sha256
-                               ('base32
-                                (? string? hash)))))
-                   ('build-system 'pyproject-build-system)
-                   ('home-page "http://example.com")
-                   ('synopsis "summary")
-                   ('description "summary")
-                   ('license 'license:lgpl2.0))
-                 (string=? (bytevector->nix-base32-string
-                            test-source-hash)
-                           hash))
-                (x
-                 (pk 'fail x #f))))))
+  (let ((tarball (pypi-tarball "foo-1.0.0"
+                               '(("foo.egg-info/.empty" "")))))
+    (with-pypi `(("/foo-1.0.0.tar.gz" 200 ,(file-dump tarball))
+                 ("/foo-1.0.0-py2.py3-none-any.whl" 404 "")
+                 ("/foo/json" 200 ,(lambda (port)
+                                     (display (foo-json) port))))
+      ;; Not clearing the memoization cache here would mean returning the
+      ;; value computed in the previous test.
+      (invalidate-memoization! pypi->guix-package)
+      (match (pypi->guix-package "foo")
+        (('package
+           ('name "python-foo")
+           ('version "1.0.0")
+           ('source ('origin
+                      ('method 'url-fetch)
+                      ('uri ('pypi-uri "foo" 'version))
+                      ('sha256
+                       ('base32
+                        (? string? hash)))))
+           ('build-system 'pyproject-build-system)
+           ('home-page "http://example.com")
+           ('synopsis "summary")
+           ('description "summary")
+           ('license 'license:lgpl2.0))
+         (string=? (bytevector->nix-base32-string (file-sha256 tarball))
+                   hash))
+        (x
+         (pk 'fail x #f))))))
 
 (test-assert "pypi->guix-package, package name contains \"-\" followed by digits"
-  ;; Replace network resources with sample data.
-  (mock ((guix import utils) url-fetch
-         (lambda (url file-name)
-           (match url
-             ("https://example.com/foo-99-1.0.0.tar.gz"
-              (let ((tarball (pypi-tarball "foo-99-1.0.0"
-                                           `(("src/bizarre.egg-info/requires.txt"
-                                              ,test-requires.txt)))))
-                ;; Unusual requires.txt location should still be found.
-                (copy-file tarball file-name)
-                (set! test-source-hash
-                  (call-with-input-file file-name port-sha256))))
-             ("https://example.com/foo-99-1.0.0-py2.py3-none-any.whl" #f)
-             (_ (error "Unexpected URL: " url)))))
-        (mock ((guix http-client) http-fetch
-               (lambda (url . rest)
-                 (match url
-                   ("https://pypi.org/pypi/foo-99/json"
-                    (values (open-input-string test-json-2)
-                            (string-length test-json-2)))
-                   ("https://example.com/foo-99-1.0.0-py2.py3-none-any.whl" #f)
-                   (_ (error "Unexpected URL: " url)))))
-              (match (pypi->guix-package "foo-99")
-                (('package
-                   ('name "python-foo-99")
-                   ('version "1.0.0")
-                   ('source ('origin
-                              ('method 'url-fetch)
-                              ('uri ('pypi-uri "foo-99" 'version))
-                              ('sha256
-                               ('base32
-                                (? string? hash)))))
-                   ('properties ('quote (("upstream-name" . "foo-99"))))
-                   ('build-system 'pyproject-build-system)
-                   ('propagated-inputs ('list 'python-bar 'python-foo))
-                   ('native-inputs ('list 'python-pytest))
-                   ('home-page "http://example.com")
-                   ('synopsis "summary")
-                   ('description "summary")
-                   ('license 'license:lgpl2.0))
-                 (string=? (bytevector->nix-base32-string
-                            test-source-hash)
-                           hash))
-                (x
-                 (pk 'fail x #f))))))
+  (let ((tarball (pypi-tarball "foo-99-1.0.0"
+                               `(("src/bizarre.egg-info/requires.txt"
+                                  ,test-requires.txt)))))
+    (with-pypi `(("/foo-99-1.0.0.tar.gz" 200 ,(file-dump tarball))
+                 ("/foo-99-1.0.0-py2.py3-none-any.whl" 404 "")
+                 ("/foo-99/json" 200 ,(lambda (port)
+                                        (display (foo-json #:name "foo-99")
+                                                 port))))
+      (match (pypi->guix-package "foo-99")
+        (('package
+           ('name "python-foo-99")
+           ('version "1.0.0")
+           ('source ('origin
+                      ('method 'url-fetch)
+                      ('uri ('pypi-uri "foo-99" 'version))
+                      ('sha256
+                       ('base32
+                        (? string? hash)))))
+           ('properties ('quote (("upstream-name" . "foo-99"))))
+           ('build-system 'pyproject-build-system)
+           ('propagated-inputs ('list 'python-bar 'python-foo))
+           ('native-inputs ('list 'python-pytest))
+           ('home-page "http://example.com")
+           ('synopsis "summary")
+           ('description "summary")
+           ('license 'license:lgpl2.0))
+         (string=? (bytevector->nix-base32-string (file-sha256 tarball))
+                   hash))
+        (x
+         (pk 'fail x #f))))))
 
 (test-end "pypi")
 (delete-file-recursively sample-directory)
+
+;; Local Variables:
+;; eval: (put 'with-pypi 'scheme-indent-function 1)
+;; End:
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 04/19] import: utils: 'call-with-networking-exception-handler' doesn't unwind.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (2 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 03/19] tests: pypi: Rewrite tests using a local HTTP server Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 05/19] import: json: Add #:timeout to 'json-fetch' Ludovic Courtès
                     ` (15 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès

That way backtraces show where the error actually originates from.

* guix/import/utils.scm (call-with-networking-exception-handler):
Rewrite using 'with-exception-handler'.
---
 guix/import/utils.scm | 33 +++++++++++++++++++++------------
 1 file changed, 21 insertions(+), 12 deletions(-)

diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 177817b10c..e9a0a7ecd7 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -45,6 +45,7 @@ (define-module (guix import utils)
   #:use-module (guix sets)
   #:use-module ((guix ui) #:select (fill-paragraph))
   #:use-module (gnu packages)
+  #:autoload   (ice-9 control) (let/ec)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 receive)
@@ -126,18 +127,26 @@ (define (flatten lst)
 (define (call-with-networking-exception-handler thunk)
   "Invoke THUNK, returning #f if one of the usual networking exception is
 thrown."
-  (catch #t
-    (lambda ()
-      (guard (c ((http-get-error? c) #f))
-        (thunk)))
-    (lambda (key . args)
-      ;; Return false and move on upon connection failures and bogus HTTP
-      ;; servers.
-      (unless (memq key '(gnutls-error tls-certificate-error
-                                       system-error getaddrinfo-error
-                                       bad-header bad-header-component))
-        (apply throw key args))
-      #f)))
+  (let/ec return
+    (with-exception-handler
+        (lambda (exception)
+          (cond ((http-get-error? exception)
+                 (return #f))
+                (((exception-predicate &exception-with-kind-and-args) exception)
+                 ;; Return false and move on upon connection failures and bogus
+                 ;; HTTP servers.
+                 (if (memq (exception-kind exception)
+                           '(gnutls-error tls-certificate-error
+                                          system-error getaddrinfo-error
+                                          bad-header bad-header-component))
+                     (return #f)
+                     (raise-exception exception)))
+                (else
+                 (raise-exception exception))))
+      thunk
+
+      ;; Do not unwind to preserve meaningful backtraces.
+      #:unwind? #f)))
 
 (define-syntax-rule (false-if-networking-error exp)
   "Evaluate EXP, returning #f if a networking-related exception is thrown."
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 05/19] import: json: Add #:timeout to 'json-fetch'.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (3 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 04/19] import: utils: 'call-with-networking-exception-handler' doesn't unwind Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 06/19] doc: Mention 'guix refresh -u' for third-party channels Ludovic Courtès
                     ` (14 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès

* guix/import/json.scm (json-fetch): Add #:timeout and pass it to
'http-fetch'.
---
 guix/import/json.scm | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/guix/import/json.scm b/guix/import/json.scm
index ae00ee929e..b87e9918c5 100644
--- a/guix/import/json.scm
+++ b/guix/import/json.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015, 2016 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -37,6 +37,7 @@ (define-module (guix import json)
 (define* (json-fetch url
                      #:key
                      (http-fetch http-fetch)
+                     (timeout 10)
                      ;; Note: many websites returns 403 if we omit a
                      ;; 'User-Agent' header.
                      (headers `((user-agent . "GNU Guile")
@@ -50,7 +51,7 @@ (define* (json-fetch url
                     (or (= 403 error)
                         (= 404 error))))
              #f))
-    (let* ((port   (http-fetch url #:headers headers))
+    (let* ((port   (http-fetch url #:timeout timeout #:headers headers))
            (result (json->scm port)))
       (close-port port)
       result)))
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 06/19] doc: Mention 'guix refresh -u' for third-party channels.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (4 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 05/19] import: json: Add #:timeout to 'json-fetch' Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 07/19] upstream: Replace 'input-changes' field by 'inputs' Ludovic Courtès
                     ` (13 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès

* doc/guix.texi (Invoking guix refresh): Show how to run 'guix refresh
-u' on a third-party channel.
---
 doc/guix.texi | 11 +++++++++--
 1 file changed, 9 insertions(+), 2 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 31dc33fb97..b52a40cc38 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -14340,15 +14340,22 @@ Invoking guix refresh
 
 @item --update
 @itemx -u
-Update distribution source files (package recipes) in place.  This is
+Update distribution source files (package definitions) in place.  This is
 usually run from a checkout of the Guix source tree (@pxref{Running
 Guix Before It Is Installed}):
 
 @example
-$ ./pre-inst-env guix refresh -s non-core -u
+./pre-inst-env guix refresh -s non-core -u
 @end example
 
 @xref{Defining Packages}, for more information on package definitions.
+You can also run it on packages from a third-party channel:
+
+@example
+guix refresh -L /path/to/channel -u @var{package}
+@end example
+
+@xref{Creating a Channel}, on how to create a channel.
 
 @item --select=[@var{subset}]
 @itemx -s @var{subset}
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 07/19] upstream: Replace 'input-changes' field by 'inputs'.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (5 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 06/19] doc: Mention 'guix refresh -u' for third-party channels Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 08/19] diagnostics: Factorize 'absolute-location' Ludovic Courtès
                     ` (12 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571
  Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret,
	Lars-Dominik Braun, Ludovic Courtès, Mathieu Othacehe,
	Ricardo Wurmus, Simon Tournier, Tobias Geerinckx-Rice, jgart

Returning the expected list of inputs rather than changes relative to
the current package definition is less ambiguous and offers more
possibilities for further processing.

* guix/upstream.scm (<upstream-source>)[input-changes]: Remove.
[inputs]: New field.
(<upstream-input>): New record type.
* guix/upstream.scm (upstream-input-type-predicate)
(input-type-filter, upstream-source-regular-inputs)
(upstream-source-native-inputs, upstream-source-propagated-inputs): New
procedures.
(changed-inputs): Expect an <upstream-source> as its second argument.
Adjust accordingly.
* guix/import/pypi.scm (distribution-sha256): New procedure.
(maybe-inputs): Expect a list of <upstream-input>.
(compute-inputs): Rewrite to return a list of <upstream-input>.
(pypi-package-inputs, pypi-package->upstream-source): New procedures.
(make-pypi-sexp): Use it.
* guix/import/stackage.scm (latest-lts-release): Define 'cabal'.
Replace 'input-changes' field by 'inputs'.
* guix/scripts/refresh.scm (update-package): Use 'changed-inputs'
instead of 'upstream-source-input-changes'.
* tests/cran.scm ("description->package"): Adjust order of inputs.
* tests/pypi.scm (default-sha256, default-sha256/base32): New variables.
(foo-json): Add 'digests' entry.
("pypi->guix-package, no wheel"): Check HASH against DEFAULT-SHA256/BASE32.
("pypi->guix-package, wheels"): Likewise.
("pypi->guix-package, no usable requirement file."): Likewise.
("pypi->guix-package, package name contains \"-\" followed by digits"):
Likewise.
("package-latest-release"): New test.
* tests/upstream.scm (test-package-sexp): Remove.
("changed-inputs returns no changes"): Rewrite to use <upstream-source>.
(test-new-package-sexp): Remove.
("changed-inputs returns changes to plain input list"): Rewrite.
("changed-inputs returns changes to all plain input lists"): Likewise.
("changed-inputs returns changes to labelled input list")
("changed-inputs returns changes to all labelled input lists"): Remove.
* guix/import/cran.scm (maybe-inputs): Expect PACKAGE-INPUTS to be a
list of <upstream-input>.
(source-dir->dependencies): Return a list of <upstream-input>.
(vignette-builders): Likewise.
(uri-helper, cran-package-source-url)
(cran-package-propagated-inputs, cran-package-inputs): New procedures.
(description->package): Use them instead of local definitions.
(latest-cran-release): Replace 'input-changes' field by 'inputs'.
(latest-bioconductor-release): Likewise.
(format-inputs): Remove.
* guix/import/hackage.scm (cabal-package-inputs): New procedure.
(hackage-module->sexp): Use it.
[maybe-inputs]: Expect a list of <upstream-input>.
---
 guix/import/cran.scm     | 194 +++++++++++++++++++++++-------------
 guix/import/hackage.scm  |  90 ++++++++++-------
 guix/import/pypi.scm     | 207 +++++++++++++++++++++++----------------
 guix/import/stackage.scm |   9 +-
 guix/scripts/refresh.scm |   4 +-
 guix/upstream.scm        | 163 ++++++++++++++++++------------
 tests/pypi.scm           |  62 ++++++++++--
 tests/upstream.scm       | 140 ++++++++++----------------
 8 files changed, 511 insertions(+), 358 deletions(-)

diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index bb271634ed..d25f334396 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015-2023 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015-2017, 2019-2021, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
@@ -164,24 +164,16 @@ (define (description->alist description)
                                  rest)))))))
     (fold parse '() lines)))
 
-(define (format-inputs names)
-  "Generate a sorted list of package inputs from a list of package NAMES."
-  (map (lambda (name)
-         (case (%input-style)
-           ((specification)
-            `(specification->package ,name))
-           (else
-            (string->symbol name))))
-       (sort names string-ci<?)))
-
-(define* (maybe-inputs package-inputs #:optional (type 'inputs))
+(define* (maybe-inputs package-inputs #:optional (input-type 'inputs))
   "Given a list of PACKAGE-INPUTS, tries to generate the TYPE field of a
 package definition."
   (match package-inputs
     (()
      '())
     ((package-inputs ...)
-     `((,type (list ,@(format-inputs package-inputs)))))))
+     `((,input-type (list ,@(map (compose string->symbol
+                                          upstream-input-downstream-name)
+                                 package-inputs)))))))
 
 (define %cran-url "https://cran.r-project.org/web/packages/")
 (define %cran-canonical-url "https://cran.r-project.org/package=")
@@ -520,14 +512,29 @@ (define (directory-needs-pkg-config? dir)
                         "(Makevars.*|configure.*)"))
 
 (define (source-dir->dependencies dir)
-  "Guess dependencies of R package source in DIR and return two values: a list
-of package names for INPUTS and another list of names of NATIVE-INPUTS."
-  (values
-   (needed-libraries-in-directory dir)
-   (append
-       (if (directory-needs-esbuild? dir) '("esbuild") '())
-       (if (directory-needs-pkg-config? dir) '("pkg-config") '())
-       (if (directory-needs-fortran? dir) '("gfortran") '()))))
+  "Guess dependencies of R package source in DIR and return a list of
+<upstream-input> corresponding to the dependencies guessed from source files
+in DIR."
+  (define (native name)
+    (upstream-input
+     (name name)
+     (downstream-name name)
+     (type 'native)))
+
+  (append (map (lambda (name)
+                 (upstream-input
+                  (name name)
+                  (downstream-name (cran-guix-name name))))
+               (needed-libraries-in-directory dir))
+          (if (directory-needs-esbuild? dir)
+              (list (native "esbuild"))
+              '())
+          (if (directory-needs-pkg-config? dir)
+              (list (native "pkg-config"))
+              '())
+          (if (directory-needs-fortran? dir)
+              (list (native "gfortran"))
+              '())))
 
 (define (source->dependencies source tarball?)
   "SOURCE-DIR->DEPENDENCIES, but for directories and tarballs as indicated
@@ -541,7 +548,79 @@ (define (source->dependencies source tarball?)
     (source-dir->dependencies source)))
 
 (define (vignette-builders meta)
-  (map cran-guix-name (listify meta "VignetteBuilder")))
+  (map (lambda (name)
+         (upstream-input
+          (name name)
+          (downstream-name (cran-guix-name name))
+          (type 'native)))
+       (listify meta "VignetteBuilder")))
+
+(define (uri-helper repository)
+  (match repository
+    ('cran         cran-uri)
+    ('bioconductor bioconductor-uri)
+    ('git          #f)
+    ('hg           #f)))
+
+(define (cran-package-source-url meta repository)
+  "Return the URL of the source code referred to by META, a package in
+REPOSITORY."
+  (case repository
+    ((git) (assoc-ref meta 'git))
+    ((hg)  (assoc-ref meta 'hg))
+    (else
+     (match (apply (uri-helper repository)
+                   (assoc-ref meta "Package")
+                   (assoc-ref meta "Version")
+                   (case repository
+                     ((bioconductor)
+                      (list (assoc-ref meta 'bioconductor-type)))
+                     (else '())))
+       ((urls ...) urls)
+       ((? string? url) url)
+       (_ #f)))))
+
+(define (cran-package-propagated-inputs meta)
+  "Return the list of <upstream-input> derived from dependency information in
+META."
+  (filter-map (lambda (name)
+                (and (not (member name
+                                  (append default-r-packages invalid-packages)))
+                     (upstream-input
+                      (name name)
+                      (downstream-name (cran-guix-name name))
+                      (type 'propagated))))
+              (lset-union equal?
+                          (listify meta "Imports")
+                          (listify meta "LinkingTo")
+                          (delete "R" (listify meta "Depends")))))
+
+(define* (cran-package-inputs meta repository
+                              #:key (download-source download))
+  "Return the list of <upstream-input> corresponding to all the dependencies
+of META, a package in REPOSITORY."
+  (let* ((url    (cran-package-source-url meta repository))
+         (source (download-source url
+                                  #:method
+                                  (cond ((assoc-ref meta 'git) 'git)
+                                        ((assoc-ref meta 'hg) 'hg)
+                                        (else #f))))
+         (tarball? (not (or (assoc-ref meta 'git)
+                            (assoc-ref meta 'hg)))))
+    (sort (append (source->dependencies source tarball?)
+                  (filter-map (lambda (name)
+                                (and (not (member name invalid-packages))
+                                     (upstream-input
+                                      (name name)
+                                      (downstream-name
+                                       (transform-sysname name)))))
+                              (map string-downcase
+                                   (listify meta "SystemRequirements")))
+                  (cran-package-propagated-inputs meta)
+                  (vignette-builders meta))
+          (lambda (input1 input2)
+            (string<? (upstream-input-downstream-name input1)
+                      (upstream-input-downstream-name input2))))))
 
 (define* (description->package repository meta #:key (license-prefix identity)
                                (download-source download))
@@ -556,11 +635,6 @@ (define* (description->package repository meta #:key (license-prefix identity)
                                ((cran)         %cran-canonical-url)
                                ((bioconductor) %bioconductor-url)
                                ((git)          #f)))
-         (uri-helper (case repository
-                       ((cran)         cran-uri)
-                       ((bioconductor) bioconductor-uri)
-                       ((git)          #f)
-                       ((hg)           #f)))
          (name       (assoc-ref meta "Package"))
          (synopsis   (assoc-ref meta "Title"))
          (version    (assoc-ref meta "Version"))
@@ -572,40 +646,16 @@ (define* (description->package repository meta #:key (license-prefix identity)
                        (else (match (listify meta "URL")
                                ((url rest ...) url)
                                (_ (string-append canonical-url-base name))))))
-         (source-url (case repository
-                       ((git) (assoc-ref meta 'git))
-                       ((hg)  (assoc-ref meta 'hg))
-                       (else
-                        (match (apply uri-helper name version
-                                      (case repository
-                                        ((bioconductor)
-                                         (list (assoc-ref meta 'bioconductor-type)))
-                                        (else '())))
-                          ((urls ...) urls)
-                          ((? string? url) url)
-                          (_ #f)))))
+         (source-url (cran-package-source-url meta repository))
          (git?       (if (assoc-ref meta 'git) #true #false))
          (hg?        (if (assoc-ref meta 'hg) #true #false))
          (source     (download-source source-url #:method (cond
                                                            (git? 'git)
                                                            (hg? 'hg)
                                                            (else #f))))
-         (tarball?   (not (or git? hg?)))
-         (source-inputs source-native-inputs
-          (source->dependencies source tarball?))
-         (sysdepends (append
-                      source-inputs
-                      (filter (lambda (name)
-                                (not (member name invalid-packages)))
-                              (map string-downcase (listify meta "SystemRequirements")))))
-         (propagate  (filter (lambda (name)
-                               (not (member name (append default-r-packages
-                                                         invalid-packages))))
-                             (lset-union equal?
-                                         (listify meta "Imports")
-                                         (listify meta "LinkingTo")
-                                         (delete "R"
-                                                 (listify meta "Depends")))))
+         (uri-helper (uri-helper repository))
+         (inputs     (cran-package-inputs meta repository
+                                          #:download-source download-source))
          (package
            `(package
               (name ,(cran-guix-name name))
@@ -651,12 +701,18 @@ (define* (description->package repository meta #:key (license-prefix identity)
                     `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
                     '())
               (build-system r-build-system)
-              ,@(maybe-inputs (map transform-sysname sysdepends))
-              ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs)
-              ,@(maybe-inputs
-                 `(,@source-native-inputs
-                   ,@(vignette-builders meta))
-                 'native-inputs)
+
+              ,@(maybe-inputs (filter (upstream-input-type-predicate 'regular)
+                                      inputs)
+                              'inputs)
+              ,@(maybe-inputs (filter (upstream-input-type-predicate
+                                       'propagated)
+                                      inputs)
+                              'propagated-inputs)
+              ,@(maybe-inputs (filter (upstream-input-type-predicate 'native)
+                                      inputs)
+                              'native-inputs)
+
               (home-page ,(if (string-null? home-page)
                               (string-append base-url name)
                               home-page))
@@ -675,7 +731,10 @@ (define* (description->package repository meta #:key (license-prefix identity)
               (revision "1"))
           ,package))
       (else package))
-     propagate)))
+     (filter-map (lambda (input)
+                   (and (eq? 'propagated (upstream-input-type input))
+                        (upstream-input-name input)))
+                 inputs))))
 
 (define cran->guix-package
   (memoize
@@ -760,9 +819,7 @@ (define* (latest-cran-release pkg #:key (version #f))
           (package (package-name pkg))
           (version version)
           (urls (cran-uri upstream-name version))
-          (input-changes
-           (changed-inputs pkg
-                           (description->package 'cran meta)))))))
+          (inputs (cran-package-inputs meta 'cran))))))
 
 (define* (latest-bioconductor-release pkg #:key (version #f))
   "Return an <upstream-source> for the latest release of the package PKG."
@@ -784,10 +841,9 @@ (define* (latest-bioconductor-release pkg #:key (version #f))
         (package (package-name pkg))
         (version latest-version)
         (urls (bioconductor-uri upstream-name latest-version))
-        (input-changes
-         (changed-inputs
-          pkg
-          (cran->guix-package upstream-name #:repo 'bioconductor))))))
+        (inputs
+         (let ((meta (fetch-description 'bioconductor upstream-name)))
+           (cran-package-inputs meta 'bioconductor))))))
 
 (define (cran-package? package)
   "Return true if PACKAGE is an R package from CRAN."
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 56c8696ad7..9333bedbbd 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -56,7 +57,9 @@ (define-module (guix import hackage)
             hackage-fetch
             hackage-source-url
             hackage-cabal-url
-            hackage-package?))
+            hackage-package?
+
+            cabal-package-inputs))
 
 (define ghc-standard-libraries
   ;; List of libraries distributed with ghc (as of 8.10.7).
@@ -224,27 +227,12 @@ (define (filter-dependencies dependencies own-names)
     (filter (lambda (d) (not (member (string-downcase d) ignored-dependencies)))
             dependencies)))
 
-(define* (hackage-module->sexp cabal cabal-hash
-                               #:key (include-test-dependencies? #t))
-  "Return the `package' S-expression for a Cabal package.  CABAL is the
-representation of a Cabal file as produced by 'read-cabal'.  CABAL-HASH is
-the hash of the Cabal file."
-
-  (define name
-    (cabal-package-name cabal))
-
-  (define version
-    (cabal-package-version cabal))
-
-  (define revision
-    (cabal-package-revision cabal))
-  
-  (define source-url
-    (hackage-source-url name version))
-
-  (define own-names (cons (cabal-package-name cabal)
-                          (filter (lambda (x) (not (eqv? x #f)))
-                            (map cabal-library-name (cabal-package-library cabal)))))
+(define* (cabal-package-inputs cabal #:key (include-test-dependencies? #t))
+  "Return the list of <upstream-input> for CABAL representing its
+dependencies."
+  (define own-names
+    (cons (cabal-package-name cabal)
+          (filter-map cabal-library-name (cabal-package-library cabal))))
 
   (define hackage-dependencies
     (filter-dependencies (cabal-dependencies->names cabal) own-names))
@@ -261,22 +249,54 @@ (define* (hackage-module->sexp cabal cabal-hash
      hackage-dependencies))
 
   (define dependencies
-    (map string->symbol
-         (map hackage-name->package-name
-              hackage-dependencies)))
+    (map (lambda (name)
+           (upstream-input
+            (name name)
+            (downstream-name (hackage-name->package-name name))
+            (type 'regular)))
+         hackage-dependencies))
 
   (define native-dependencies
-    (map string->symbol
-         (map hackage-name->package-name
-              hackage-native-dependencies)))
-  
+    (map (lambda (name)
+           (upstream-input
+            (name name)
+            (downstream-name (hackage-name->package-name name))
+            (type 'native)))
+         hackage-native-dependencies))
+
+  (append dependencies native-dependencies))
+
+(define* (hackage-module->sexp cabal cabal-hash
+                               #:key (include-test-dependencies? #t))
+  "Return the `package' S-expression for a Cabal package.  CABAL is the
+representation of a Cabal file as produced by 'read-cabal'.  CABAL-HASH is
+the hash of the Cabal file."
+  (define name
+    (cabal-package-name cabal))
+
+  (define version
+    (cabal-package-version cabal))
+
+  (define revision
+    (cabal-package-revision cabal))
+
+  (define source-url
+    (hackage-source-url name version))
+
+  (define inputs
+    (cabal-package-inputs cabal
+                          #:include-test-dependencies?
+                          include-test-dependencies?))
+
   (define (maybe-inputs input-type inputs)
     (match inputs
       (()
        '())
       ((inputs ...)
        (list (list input-type
-                   `(list ,@inputs))))))
+                   `(list ,@(map (compose string->symbol
+                                          upstream-input-downstream-name)
+                                 inputs)))))))
 
   (define (maybe-arguments)
     (match (append (if (not include-test-dependencies?)
@@ -304,14 +324,18 @@ (define* (hackage-module->sexp cabal cabal-hash
                          "failed to download tar archive")))))
         (build-system haskell-build-system)
         (properties '((upstream-name . ,name)))
-        ,@(maybe-inputs 'inputs dependencies)
-        ,@(maybe-inputs 'native-inputs native-dependencies)
+        ,@(maybe-inputs 'inputs
+                        (filter (upstream-input-type-predicate 'regular)
+                                inputs))
+        ,@(maybe-inputs 'native-inputs
+                        (filter (upstream-input-type-predicate 'native)
+                                inputs))
         ,@(maybe-arguments)
         (home-page ,(cabal-package-home-page cabal))
         (synopsis ,(cabal-package-synopsis cabal))
         (description ,(beautify-description (cabal-package-description cabal)))
         (license ,(string->license (cabal-package-license cabal))))
-     (append hackage-dependencies hackage-native-dependencies))))
+     inputs)))
 
 (define* (hackage->guix-package package-name #:key
                                 (include-test-dependencies? #t)
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index 8c06b19cff..1a3070fb36 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com>
-;;; Copyright © 2015-2017, 2019-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015-2017, 2019-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2018, 2023 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
@@ -33,12 +33,16 @@
 (define-module (guix import pypi)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
-  #:use-module (ice-9 receive)
   #:use-module ((ice-9 rdelim) #:select (read-line))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-71)
+  #:autoload   (gcrypt hash) (port-sha256)
+  #:autoload   (guix base16) (base16-string->bytevector)
+  #:autoload   (guix base32) (bytevector->nix-base32-string)
+  #:autoload   (guix http-client) (http-fetch)
   #:use-module (guix utils)
   #:use-module (guix memoization)
   #:use-module (guix diagnostics)
@@ -126,6 +130,12 @@ (define-json-mapping <distribution> make-distribution distribution?
   (python-version distribution-package-python-version
                   "python_version"))
 
+(define (distribution-sha256 distribution)
+  "Return the SHA256 hash of DISTRIBUTION as a bytevector, or #f."
+  (match (assoc-ref (distribution-digests distribution) "sha256")
+    (#f #f)
+    (str (base16-string->bytevector str))))
+
 (define (pypi-fetch name)
   "Return a <pypi-project> record for package NAME, or #f on failure."
   (and=> (json-fetch (string-append (%pypi-base-url) name "/json"))
@@ -198,7 +208,9 @@ (define (maybe-inputs package-inputs input-type)
     (()
      '())
     ((package-inputs ...)
-     `((,input-type (list ,@package-inputs))))))
+     `((,input-type (list ,@(map (compose string->symbol
+                                          upstream-input-downstream-name)
+                                 package-inputs)))))))
 
 (define %requirement-name-regexp
   ;; Regexp to match the requirement name in a requirement specification.
@@ -409,23 +421,36 @@ (define (guess-requirements source-url wheel-url archive)
 
 (define (compute-inputs source-url wheel-url archive)
   "Given the SOURCE-URL and WHEEL-URL of an already downloaded ARCHIVE, return
-a pair of lists, each consisting of a list of name/variable pairs, for the
-propagated inputs and the native inputs, respectively.  Also
-return the unaltered list of upstream dependency names."
-
-  (define (strip-argparse deps)
-    (remove (cut string=? "argparse" <>) deps))
-
-  (define (requirement->package-name/sort deps)
-    (map string->symbol
-         (sort (map python->package-name deps) string-ci<?)))
-
-  (define process-requirements
-    (compose requirement->package-name/sort strip-argparse))
-
+the corresponding list of <upstream-input> records."
+  (define (requirements->upstream-inputs deps type)
+    (filter-map (match-lambda
+                  ("argparse" #f)
+                  (name (upstream-input
+                         (name name)
+                         (downstream-name (python->package-name name))
+                         (type type))))
+                (sort deps string-ci<?)))
+
+  ;; TODO: Record version number ranges in <upstream-input>.
   (let ((dependencies (guess-requirements source-url wheel-url archive)))
-    (values (map process-requirements dependencies)
-            (concatenate dependencies))))
+    (match dependencies
+      ((propagated native)
+       (append (requirements->upstream-inputs propagated 'propagated)
+               (requirements->upstream-inputs native 'native))))))
+
+(define* (pypi-package-inputs pypi-package #:optional version)
+  "Return the list of <upstream-input> for PYPI-PACKAGE.  This procedure
+downloads the source and possibly the wheel of PYPI-PACKAGE."
+  (let* ((info       (pypi-project-info pypi-package))
+         (version    (or version (project-info-version info)))
+         (dist       (source-release pypi-package version))
+         (source-url (distribution-url dist))
+         (wheel-url  (and=> (wheel-release pypi-package version)
+                            distribution-url)))
+    (call-with-temporary-output-file
+     (lambda (archive port)
+       (and (url-fetch source-url archive)
+            (compute-inputs source-url wheel-url archive))))))
 
 (define (find-project-url name pypi-url)
   "Try different project name substitution until the result is found in
@@ -445,52 +470,85 @@ (define (find-project-url name pypi-url)
 a substring of the PyPI URI that identifies the package.")  pypi-url name))
 name)))
 
-(define (make-pypi-sexp name version source-url wheel-url home-page synopsis
-                        description license)
-  "Return the `package' s-expression for a python package with the given NAME,
-VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
+(define* (pypi-package->upstream-source pypi-package #:optional version)
+  "Return the upstream source for the given VERSION of PYPI-PACKAGE, a
+<pypi-project> record.  If VERSION is omitted or #f, use the latest version."
+  (let* ((info       (pypi-project-info pypi-package))
+         (version    (or version (project-info-version info)))
+         (dist       (source-release pypi-package version))
+         (source-url (distribution-url dist))
+         (wheel-url  (and=> (wheel-release pypi-package version)
+                            distribution-url)))
+    (let ((extra-inputs (if (string-suffix? ".zip" source-url)
+                            (list (upstream-input
+                                   (name "zip")
+                                   (downstream-name "zip")
+                                   (type 'native)))
+                            '())))
+      (upstream-source
+       (urls (list source-url))
+       (signature-urls
+        (if (distribution-has-signature? dist)
+            (list (string-append source-url ".asc"))
+            #f))
+       (inputs (append (pypi-package-inputs pypi-package)
+                       extra-inputs))
+       (package (project-info-name info))
+       (version version)))))
+
+(define* (make-pypi-sexp pypi-package
+                         #:optional (version (latest-version pypi-package)))
+  "Return the `package' s-expression the given VERSION of PYPI-PACKAGE, a
+<pypi-project> record."
   (define (maybe-upstream-name name)
     (if (string-match ".*\\-[0-9]+" name)
         `((properties ,`'(("upstream-name" . ,name))))
         '()))
-  
-  (call-with-temporary-output-file
-   (lambda (temp port)
-     (and (url-fetch source-url temp)
-          (receive (guix-dependencies upstream-dependencies)
-              (compute-inputs source-url wheel-url temp)
-            (match guix-dependencies
-              ((required-inputs native-inputs)
-               (when (string-suffix? ".zip" source-url)
-                 (set! native-inputs (cons 'unzip native-inputs)))
-               (values
-                `(package
-                   (name ,(python->package-name name))
-                   (version ,version)
-                   (source
-                    (origin
-                      (method url-fetch)
-                      (uri (pypi-uri
-                             ,(find-project-url name source-url)
-                             version
-                             ;; Some packages have been released as `.zip`
-                             ;; instead of the more common `.tar.gz`. For
-                             ;; example, see "path-and-address".
-                             ,@(if (string-suffix? ".zip" source-url)
-                                   '(".zip")
-                                   '())))
-                      (sha256
-                       (base32
-                        ,(guix-hash-url temp)))))
-                   ,@(maybe-upstream-name name)
-                   (build-system pyproject-build-system)
-                   ,@(maybe-inputs required-inputs 'propagated-inputs)
-                   ,@(maybe-inputs native-inputs 'native-inputs)
-                   (home-page ,home-page)
-                   (synopsis ,synopsis)
-                   (description ,(beautify-description description))
-                   (license ,(license->symbol license)))
-                upstream-dependencies))))))))
+
+  (let* ((info (pypi-project-info pypi-package))
+         (name (project-info-name info))
+         (source-url (and=> (source-release pypi-package version)
+                            distribution-url))
+         (sha256 (and=> (source-release pypi-package version)
+                        distribution-sha256))
+         (source (pypi-package->upstream-source pypi-package version)))
+    (values
+     `(package
+        (name ,(python->package-name name))
+        (version ,version)
+        (source
+         (origin
+           (method url-fetch)
+           (uri (pypi-uri
+                 ,(find-project-url name source-url)
+                 version
+                 ;; Some packages have been released as `.zip`
+                 ;; instead of the more common `.tar.gz`. For
+                 ;; example, see "path-and-address".
+                 ,@(if (string-suffix? ".zip" source-url)
+                       '(".zip")
+                       '())))
+           (sha256 (base32
+                    ,(and=> (or sha256
+                                (let* ((port (http-fetch source-url))
+                                       (hash (port-sha256 port)))
+                                  (close-port port)
+                                  hash))
+                            bytevector->nix-base32-string)))))
+        ,@(maybe-upstream-name name)
+        (build-system pyproject-build-system)
+        ,@(maybe-inputs (upstream-source-propagated-inputs source)
+                        'propagated-inputs)
+        ,@(maybe-inputs (upstream-source-native-inputs source)
+                        'native-inputs)
+        (home-page ,(project-info-home-page info))
+        (synopsis ,(project-info-summary info))
+        (description ,(beautify-description
+                       (project-info-summary info)))
+        (license ,(license->symbol
+                   (string->license
+                    (project-info-license info)))))
+     (map upstream-input-name (upstream-source-inputs source)))))
 
 (define pypi->guix-package
   (memoize
@@ -520,16 +578,7 @@ (define pypi->guix-package
 source.  To build it from source, refer to the upstream repository at
 @uref{~a}.")
                                               url))))))))))))
-             (make-pypi-sexp (project-info-name info) version
-                             (and=> (source-release project version)
-                                    distribution-url)
-                             (and=> (wheel-release project version)
-                                    distribution-url)
-                             (project-info-home-page info)
-                             (project-info-summary info)
-                             (project-info-summary info)
-                             (string->license
-                              (project-info-license info))))
+             (make-pypi-sexp project version))
            (values #f '()))))))
 
 (define* (pypi-recursive-import package-name #:optional version)
@@ -566,21 +615,7 @@ (define* (import-release package #:key (version #f))
          (pypi-package (pypi-fetch pypi-name)))
     (and pypi-package
          (guard (c ((missing-source-error? c) #f))
-           (let* ((info    (pypi-project-info pypi-package))
-                  (version (or version (project-info-version info)))
-                  (dist    (source-release pypi-package version))
-                  (url     (distribution-url dist)))
-             (upstream-source
-              (urls (list url))
-              (signature-urls
-               (if (distribution-has-signature? dist)
-                   (list (string-append url ".asc"))
-                   #f))
-              (input-changes
-               (changed-inputs package
-                               (pypi->guix-package pypi-name #:version version)))
-              (package (package-name package))
-              (version version)))))))
+           (pypi-package->upstream-source pypi-package version)))))
 
 (define %pypi-updater
   (upstream-updater
diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm
index f98b86c334..f8b2726591 100644
--- a/guix/import/stackage.scm
+++ b/guix/import/stackage.scm
@@ -29,6 +29,7 @@ (define-module (guix import stackage)
   #:use-module (srfi srfi-35)
   #:use-module (guix import json)
   #:use-module (guix import hackage)
+  #:autoload   (guix import cabal) (eval-cabal)
   #:use-module (guix import utils)
   #:use-module (guix memoization)
   #:use-module (guix packages)
@@ -157,15 +158,13 @@ (define latest-lts-release
            (warning (G_ "failed to parse ~a~%")
                     (hackage-cabal-url hackage-name))
            #f)
-          (_ (let ((url (hackage-source-url hackage-name version)))
+          (_ (let ((url (hackage-source-url hackage-name version))
+                   (cabal (eval-cabal (hackage-fetch hackage-name) '())))
                (upstream-source
                 (package (package-name pkg))
                 (version version)
                 (urls (list url))
-                (input-changes
-                 (changed-inputs
-                  pkg
-                  (stackage->guix-package hackage-name #:packages (packages))))))))))))
+                (inputs (cabal-package-inputs cabal))))))))))
 
 (define (stackage-lts-package? package)
   "Return whether PACKAGE is available on the default Stackage LTS release."
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index bfa6269aa3..d838a4aca2 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
@@ -404,7 +404,7 @@ (define* (update-package store package version updaters
                      (('remove 'propagated)
                       (info loc (G_ "~a: consider removing this propagated input: ~a~%")
                             name change-name))))
-                 (upstream-source-input-changes source))
+                 (changed-inputs package source))
                 (let ((hash (file-hash* output)))
                   (update-package-source package source hash)))
               (warning (G_ "~a: version ~a could not be \
diff --git a/guix/upstream.scm b/guix/upstream.scm
index aac501c466..52f9333878 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
@@ -55,7 +55,20 @@ (define-module (guix upstream)
             upstream-source-urls
             upstream-source-signature-urls
             upstream-source-archive-types
-            upstream-source-input-changes
+            upstream-source-inputs
+
+            upstream-input-type-predicate
+            upstream-source-regular-inputs
+            upstream-source-native-inputs
+            upstream-source-propagated-inputs
+
+            upstream-input
+            upstream-input?
+            upstream-input-name
+            upstream-input-downstream-name
+            upstream-input-type
+            upstream-input-min-version
+            upstream-input-max-version
 
             url-predicate
             url-prefix-predicate
@@ -102,8 +115,40 @@ (define-record-type* <upstream-source>
   (urls           upstream-source-urls)           ;list of strings|git-reference
   (signature-urls upstream-source-signature-urls  ;#f | list of strings
                   (default #f))
-  (input-changes  upstream-source-input-changes
-                  (default '()) (thunked)))
+  (inputs         upstream-source-inputs        ;#f | list of <upstream-input>
+                  (delayed) (default #f))) ;delayed because optional and costly
+
+;; Representation of a dependency as expressed by upstream.
+(define-record-type* <upstream-input>
+  upstream-input make-upstream-input
+  upstream-input?
+  (name         upstream-input-name)               ;upstream package name
+  (downstream-name upstream-input-downstream-name) ;Guix package name
+  (type         upstream-input-type          ;'regular | 'native | 'propagated
+                (default 'regular))
+  (min-version  upstream-input-min-version
+                (default 'any))
+  (max-version  upstream-input-max-version
+                (default 'any)))
+
+(define (upstream-input-type-predicate type)
+  "Return a predicate that returns true when passed an <upstream-input> record
+of the given TYPE (a symbol such as 'propagated)."
+  (lambda (source)
+    (eq? type (upstream-input-type source))))
+
+(define (input-type-filter type)
+  "Return a procedure that, given an <upstream-source>, returns the subset of
+its inputs that have the given TYPE (a symbol such as 'native)."
+  (lambda (source)
+    "Return the subset of inputs of SOURCE that have the given TYPE."
+    (filter (lambda (input)
+              (eq? type (upstream-input-type input)))
+            (upstream-source-inputs source))))
+
+(define upstream-source-regular-inputs (input-type-filter 'regular))
+(define upstream-source-native-inputs (input-type-filter 'native))
+(define upstream-source-propagated-inputs (input-type-filter 'propagated))
 
 ;; Representation of an upstream input change.
 (define-record-type* <upstream-input-change>
@@ -113,67 +158,55 @@ (define-record-type* <upstream-input-change>
   (type    upstream-input-change-type)    ;symbol: regular | native | propagated
   (action  upstream-input-change-action)) ;symbol: add | remove
 
-(define (changed-inputs package package-sexp)
-  "Return a list of input changes for PACKAGE based on the newly imported
-S-expression PACKAGE-SEXP."
-  (match package-sexp
-    ((and expr ('package fields ...))
-     (let* ((input->name (match-lambda ((name pkg . out) name)))
-            (new-regular
-             (match expr
-               ((path *** ('inputs
-                           ('quasiquote ((label ('unquote sym)) ...)))) label)
-               ((path *** ('inputs
-                           ('list sym ...))) (map symbol->string sym))
-               (_ '())))
-            (new-native
-             (match expr
-               ((path *** ('native-inputs
-                           ('quasiquote ((label ('unquote sym)) ...)))) label)
-               ((path *** ('native-inputs
-                           ('list sym ...))) (map symbol->string sym))
-               (_ '())))
-            (new-propagated
-             (match expr
-               ((path *** ('propagated-inputs
-                           ('quasiquote ((label ('unquote sym)) ...)))) label)
-               ((path *** ('propagated-inputs
-                           ('list sym ...))) (map symbol->string sym))
-               (_ '())))
-            (current-regular
-             (map input->name (package-inputs package)))
-            (current-native
-             (map input->name (package-native-inputs package)))
-            (current-propagated
-             (map input->name (package-propagated-inputs package))))
-       (append-map
-        (match-lambda
-          ((action type names)
-           (map (lambda (name)
-                  (upstream-input-change
-                   (name name)
-                   (type type)
-                   (action action)))
-                names)))
-        `((add regular
-           ,(lset-difference equal?
-                             new-regular current-regular))
-          (remove regular
-           ,(lset-difference equal?
-                             current-regular new-regular))
-          (add native
-           ,(lset-difference equal?
-                             new-native current-native))
-          (remove native
-           ,(lset-difference equal?
-                             current-native new-native))
-          (add propagated
-           ,(lset-difference equal?
-                             new-propagated current-propagated))
-          (remove propagated
-           ,(lset-difference equal?
-                             current-propagated new-propagated))))))
-    (_ '())))
+(define (changed-inputs package source)
+  "Return a list of input changes for PACKAGE compared to the 'inputs' field
+of SOURCE, an <upstream-source> record."
+  (define input->name
+    (match-lambda
+      ((label (? package? pkg) . out) (package-name pkg))
+      (_ #f)))
+
+  (if (upstream-source-inputs source)
+      (let* ((new-regular (map upstream-input-downstream-name
+                               (upstream-source-regular-inputs source)))
+             (new-native (map upstream-input-downstream-name
+                              (upstream-source-native-inputs source)))
+             (new-propagated (map upstream-input-downstream-name
+                                  (upstream-source-propagated-inputs source)))
+             (current-regular
+              (filter-map input->name (package-inputs package)))
+             (current-native
+              (filter-map input->name (package-native-inputs package)))
+             (current-propagated
+              (filter-map input->name (package-propagated-inputs package))))
+        (append-map
+         (match-lambda
+           ((action type names)
+            (map (lambda (name)
+                   (upstream-input-change
+                    (name name)
+                    (type type)
+                    (action action)))
+                 names)))
+         `((add regular
+                ,(lset-difference equal?
+                                  new-regular current-regular))
+           (remove regular
+                   ,(lset-difference equal?
+                                     current-regular new-regular))
+           (add native
+                ,(lset-difference equal?
+                                  new-native current-native))
+           (remove native
+                   ,(lset-difference equal?
+                                     current-native new-native))
+           (add propagated
+                ,(lset-difference equal?
+                                  new-propagated current-propagated))
+           (remove propagated
+                   ,(lset-difference equal?
+                                     current-propagated new-propagated)))))
+      '()))
 
 (define* (url-predicate matching-url?)
   "Return a predicate that returns true when passed a package whose source is
diff --git a/tests/pypi.scm b/tests/pypi.scm
index 497744511f..f3b2771f4b 100644
--- a/tests/pypi.scm
+++ b/tests/pypi.scm
@@ -25,9 +25,12 @@ (define-module (test-pypi)
   #:use-module (guix base32)
   #:use-module (guix memoization)
   #:use-module (guix utils)
+  #:use-module ((guix base16) #:select (base16-string->bytevector))
+  #:use-module (guix upstream)
   #:use-module (gcrypt hash)
   #:use-module (guix tests)
   #:use-module (guix tests http)
+  #:use-module ((guix download) #:select (url-fetch))
   #:use-module (guix build-system python)
   #:use-module ((guix build utils)
                 #:select (delete-file-recursively
@@ -43,6 +46,12 @@ (define-module (test-pypi)
   #:use-module (ice-9 match)
   #:use-module (ice-9 optargs))
 
+(define default-sha256
+  "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")
+(define default-sha256/base32
+  (bytevector->nix-base32-string
+   (base16-string->bytevector default-sha256)))
+
 (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}."
@@ -65,7 +74,8 @@ (define* (foo-json #:key (name "foo") (name-in-url #f))
               ((url . ,(format #f "~a/~a-1.0.0.tar.gz"
                                (%local-url #:path "")
                                (or name-in-url name)))
-               (packagetype . "sdist"))
+               (packagetype . "sdist")
+               (digests . (("sha256" . ,default-sha256))))
               ((url . ,(format #f "~a/~a-1.0.0-py2.py3-none-any.whl"
                                (%local-url #:path "")
                                (or name-in-url name)))
@@ -308,9 +318,7 @@ (define-syntax-rule (with-pypi responses body ...)
            ('synopsis "summary")
            ('description "summary")
            ('license 'license:lgpl2.0))
-         (and (string=? (bytevector->nix-base32-string
-                         (file-sha256 tarball))
-                        hash)
+         (and (string=? default-sha256/base32 hash)
               (equal? (pypi->guix-package "foo" #:version "1.0.0")
                       (pypi->guix-package "foo"))
               (guard (c ((error? c) #t))
@@ -352,8 +360,7 @@ (define-syntax-rule (with-pypi responses body ...)
            ('synopsis "summary")
            ('description "summary")
            ('license 'license:lgpl2.0))
-         (string=? (bytevector->nix-base32-string (file-sha256 tarball))
-                   hash))
+         (string=? default-sha256/base32 hash))
         (x
          (pk 'fail x #f))))))
 
@@ -382,8 +389,7 @@ (define-syntax-rule (with-pypi responses body ...)
            ('synopsis "summary")
            ('description "summary")
            ('license 'license:lgpl2.0))
-         (string=? (bytevector->nix-base32-string (file-sha256 tarball))
-                   hash))
+         (string=? default-sha256/base32 hash))
         (x
          (pk 'fail x #f))))))
 
@@ -414,11 +420,47 @@ (define-syntax-rule (with-pypi responses body ...)
            ('synopsis "summary")
            ('description "summary")
            ('license 'license:lgpl2.0))
-         (string=? (bytevector->nix-base32-string (file-sha256 tarball))
-                   hash))
+         (string=? default-sha256/base32 hash))
         (x
          (pk 'fail x #f))))))
 
+(test-equal "package-latest-release"
+  (list '("foo-1.0.0.tar.gz")
+        '("foo-1.0.0.tar.gz.asc")
+        (list (upstream-input
+               (name "bar")
+               (downstream-name "python-bar")
+               (type 'propagated))
+              (upstream-input
+               (name "foo")
+               (downstream-name "python-foo")
+               (type 'propagated))
+              (upstream-input
+               (name "pytest")
+               (downstream-name "python-pytest")
+               (type 'native))))
+  (let ((tarball (pypi-tarball
+                  "foo-1.0.0"
+                  `(("src/bizarre.egg-info/requires.txt"
+                     ,test-requires.txt)))))
+    (with-pypi `(("/foo-1.0.0.tar.gz" 200 ,(file-dump tarball))
+                 ("/foo-1.0.0-py2.py3-none-any.whl" 404 "")
+                 ("/foo/json" 200 ,(lambda (port)
+                                     (display (foo-json) port))))
+      (define source
+        (package-latest-release
+         (dummy-package "python-foo"
+                        (version "0.1.2")
+                        (source (dummy-origin
+                                 (method url-fetch)
+                                 (uri (pypi-uri "foo" version))))
+                        (build-system python-build-system))
+         (list %pypi-updater)))
+
+      (list (map basename (upstream-source-urls source))
+            (map basename (upstream-source-signature-urls source))
+            (upstream-source-inputs source)))))
+
 (test-end "pypi")
 (delete-file-recursively sample-directory)
 
diff --git a/tests/upstream.scm b/tests/upstream.scm
index 9aacb77229..0792ebd5d0 100644
--- a/tests/upstream.scm
+++ b/tests/upstream.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -78,69 +78,29 @@ (define test-package
     (description "test")
     (license license:gpl3+)))
 
-(define test-package-sexp
-  '(package
-    (name "test")
-    (version "2.10")
-    (source (origin
-              (method url-fetch)
-              (uri (string-append "mirror://gnu/hello/hello-" version
-                                  ".tar.gz"))
-              (sha256
-               (base32
-                "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i"))))
-    (build-system gnu-build-system)
-    (inputs
-     `(("hello" ,hello)))
-    (native-inputs
-     `(("sed" ,sed)
-       ("tar" ,tar)))
-    (propagated-inputs
-     `(("grep" ,grep)))
-    (home-page "http://localhost")
-    (synopsis "test")
-    (description "test")
-    (license license:gpl3+)))
-
 (test-equal "changed-inputs returns no changes"
   '()
-  (changed-inputs test-package test-package-sexp))
-
-(test-assert "changed-inputs returns changes to labelled input list"
-  (let ((changes (changed-inputs
-                  (package
-                    (inherit test-package)
-                    (inputs `(("hello" ,hello)
-                              ("sed" ,sed))))
-                  test-package-sexp)))
-    (match changes
-      ;; Exactly one change
-      (((? upstream-input-change? item))
-       (and (equal? (upstream-input-change-type item)
-                    'regular)
-            (equal? (upstream-input-change-action item)
-                    'remove)
-            (string=? (upstream-input-change-name item)
-                      "sed")))
-      (else (pk else #false)))))
-
-(test-assert "changed-inputs returns changes to all labelled input lists"
-  (let ((changes (changed-inputs
-                  (package
-                    (inherit test-package)
-                    (inputs '())
-                    (native-inputs '())
-                    (propagated-inputs '()))
-                  test-package-sexp)))
-    (match changes
-      (((? upstream-input-change? items) ...)
-       (and (equal? (map upstream-input-change-type items)
-                    '(regular native native propagated))
-            (equal? (map upstream-input-change-action items)
-                    '(add add add add))
-            (equal? (map upstream-input-change-name items)
-                    '("hello" "sed" "tar" "grep"))))
-      (else (pk else #false)))))
+  (changed-inputs test-package
+                  (upstream-source
+                   (package "test")
+                   (version "1")
+                   (urls '())
+                   (inputs
+                    (let ((->input
+                           (lambda (type)
+                             (match-lambda
+                               ((label _)
+                                (upstream-input
+                                 (name label)
+                                 (downstream-name label)
+                                 (type type)))))))
+                      (append (map (->input 'regular)
+                                   (package-inputs test-package))
+                              (map (->input 'native)
+                                   (package-native-inputs test-package))
+                              (map (->input 'propagated)
+                                   (package-propagated-inputs
+                                    test-package))))))))
 
 (define test-new-package
   (package
@@ -152,35 +112,20 @@ (define test-new-package
     (propagated-inputs
      (list grep))))
 
-(define test-new-package-sexp
-  '(package
-    (name "test")
-    (version "2.10")
-    (source (origin
-              (method url-fetch)
-              (uri (string-append "mirror://gnu/hello/hello-" version
-                                  ".tar.gz"))
-              (sha256
-               (base32
-                "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i"))))
-    (build-system gnu-build-system)
-    (inputs
-     (list hello))
-    (native-inputs
-     (list sed tar))
-    (propagated-inputs
-     (list grep))
-    (home-page "http://localhost")
-    (synopsis "test")
-    (description "test")
-    (license license:gpl3+)))
-
 (test-assert "changed-inputs returns changes to plain input list"
   (let ((changes (changed-inputs
                   (package
                     (inherit test-new-package)
-                    (inputs (list hello sed)))
-                  test-new-package-sexp)))
+                    (inputs (list hello sed))
+                    (native-inputs '())
+                    (propagated-inputs '()))
+                  (upstream-source
+                   (package "test")
+                   (version "1")
+                   (urls '())
+                   (inputs (list (upstream-input
+                                  (name "hello")
+                                  (downstream-name name))))))))
     (match changes
       ;; Exactly one change
       (((? upstream-input-change? item))
@@ -199,7 +144,26 @@ (define test-new-package-sexp
                     (inputs '())
                     (native-inputs '())
                     (propagated-inputs '()))
-                  test-new-package-sexp)))
+                  (upstream-source
+                   (package "test")
+                   (version "1")
+                   (urls '())
+                   (inputs (list (upstream-input
+                                  (name "hello")
+                                  (downstream-name name)
+                                  (type 'regular))
+                                 (upstream-input
+                                  (name "sed")
+                                  (downstream-name name)
+                                  (type 'native))
+                                 (upstream-input
+                                  (name "tar")
+                                  (downstream-name name)
+                                  (type 'native))
+                                 (upstream-input
+                                  (name "grep")
+                                  (downstream-name name)
+                                  (type 'propagated))))))))
     (match changes
       (((? upstream-input-change? items) ...)
        (and (equal? (map upstream-input-change-type items)
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 08/19] diagnostics: Factorize 'absolute-location'.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (6 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 07/19] upstream: Replace 'input-changes' field by 'inputs' Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 09/19] upstream: 'update-package-source' edits input fields Ludovic Courtès
                     ` (11 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571
  Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret,
	Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus,
	Simon Tournier, Tobias Geerinckx-Rice

* guix/scripts/style.scm (absolute-location): Move to...
* guix/diagnostics.scm (absolute-location): ... here.
* guix/upstream.scm (update-package-source): Use it.
---
 guix/diagnostics.scm   | 20 +++++++++++++++++++-
 guix/scripts/style.scm | 17 -----------------
 guix/upstream.scm      |  4 ++--
 3 files changed, 21 insertions(+), 20 deletions(-)

diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
index 9f0d558f2f..3f1f527b43 100644
--- a/guix/diagnostics.scm
+++ b/guix/diagnostics.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-2021, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -36,6 +36,7 @@ (define-module (guix diagnostics)
             location-file
             location-line
             location-column
+            absolute-location
             source-properties->location
             location->source-properties
             location->string
@@ -340,6 +341,23 @@ (define-syntax formatted-message
               (&formatted-message (format str)
                                   (arguments (list args ...))))))))))
 
+(define (absolute-location loc)
+  "Replace the file name in LOC by an absolute location."
+  (location (if (string-prefix? "/" (location-file loc))
+                (location-file loc)
+
+                ;; 'search-path' might return #f in obscure cases, such as
+                ;; when %LOAD-PATH includes "." or ".." and LOC comes from a
+                ;; file in a subdirectory thereof.
+                (match (search-path %load-path (location-file loc))
+                  (#f
+                   (raise (formatted-message
+                           (G_ "file '~a' not found on load path")
+                           (location-file loc))))
+                  (str str)))
+            (location-line loc)
+            (location-column loc)))
+
 \f
 (define guix-warning-port
   (make-parameter (current-warning-port)))
diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm
index 1d02742524..4920a8d969 100644
--- a/guix/scripts/style.scm
+++ b/guix/scripts/style.scm
@@ -226,23 +226,6 @@ (define (edit-expression/dry-run properties rewrite-string)
                              (G_ "would be edited~%")))
                      str)))
 
-(define (absolute-location loc)
-  "Replace the file name in LOC by an absolute location."
-  (location (if (string-prefix? "/" (location-file loc))
-                (location-file loc)
-
-                ;; 'search-path' might return #f in obscure cases, such as
-                ;; when %LOAD-PATH includes "." or ".." and LOC comes from a
-                ;; file in a subdirectory thereof.
-                (match (search-path %load-path (location-file loc))
-                  (#f
-                   (raise (formatted-message
-                           (G_ "file '~a' not found on load path")
-                           (location-file loc))))
-                  (str str)))
-            (location-line loc)
-            (location-column loc)))
-
 (define (trivial-package-arguments? package)
   "Return true if PACKAGE has zero arguments or only \"trivial\" arguments
 guaranteed not to refer to input labels."
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 52f9333878..4ae2d1c8c8 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -637,8 +637,8 @@ (define* (update-package-source package source hash)
               ;; function of the person who uploads the package.  Note that
               ;; package definitions usually concatenate fragments of the URL,
               ;; which is why we only attempt to replace a subset of the URL.
-              (let ((properties (assq-set! (location->source-properties loc)
-                                           'filename file))
+              (let ((properties (location->source-properties
+                                 (absolute-location loc)))
                     (replacements `((,old-version . ,version)
                                     (,old-hash . ,hash)
                                     ,@(if (and old-commit new-commit)
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 09/19] upstream: 'update-package-source' edits input fields.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (7 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 08/19] diagnostics: Factorize 'absolute-location' Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 10/19] upstream: Remove <upstream-input-change> and related code Ludovic Courtès
                     ` (10 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571
  Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret,
	Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus,
	Simon Tournier, Tobias Geerinckx-Rice

Previously, 'guix refresh r-ggplot2 -u' and similar commands would print
of list of input changes that would have to be made manually.  With this
change, 'guix refresh -u' takes care of updating input fields
automatically.

* guix/upstream.scm (update-package-inputs): New procedure.
(update-package-source): Call it when 'upstream-source-inputs' returns
true.
* guix/scripts/refresh.scm (update-package): Remove iteration over the
result of 'changed-inputs'.
* guix/import/test.scm (available-updates): Add support for input
lists.
* tests/guix-refresh.sh (GUIX_TEST_UPDATER_TARGETS): Add input list for
"the-test-package".
Make sure 'guix refresh -u' updates 'inputs' accordingly.
* doc/guix.texi (Invoking guix refresh): Mention it.
---
 doc/guix.texi            |  5 ++--
 guix/import/test.scm     | 13 +++++++++-
 guix/scripts/refresh.scm | 36 --------------------------
 guix/upstream.scm        | 56 +++++++++++++++++++++++++++++++++++++---
 tests/guix-refresh.sh    |  7 +++--
 5 files changed, 72 insertions(+), 45 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index b52a40cc38..c54a72bfaa 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -14308,8 +14308,9 @@ Invoking guix refresh
 @end lisp
 
 When passed @option{--update}, it modifies distribution source files to
-update the version numbers and source tarball hashes of those package
-recipes (@pxref{Defining Packages}).  This is achieved by downloading
+update the version numbers and source code hashes of those package
+definitions, as well as possibly their inputs (@pxref{Defining Packages}).
+This is achieved by downloading
 each package's latest source tarball and its associated OpenPGP
 signature, authenticating the downloaded tarball against its signature
 using @command{gpgv}, and finally computing its hash---note that GnuPG must be
diff --git a/guix/import/test.scm b/guix/import/test.scm
index b1ed0b455d..4bd356bddc 100644
--- a/guix/import/test.scm
+++ b/guix/import/test.scm
@@ -52,7 +52,18 @@ (define (available-updates package)
                                         (upstream-source
                                          (package (package-name package))
                                          (version version)
-                                         (urls (list url)))))
+                                         (urls (list url))))
+                                       ((version url (inputs ...))
+                                        (upstream-source
+                                         (package (package-name package))
+                                         (version version)
+                                         (urls (list url))
+                                         (inputs
+                                          (map (lambda (name)
+                                                 (upstream-input
+                                                  (name name)
+                                                  (downstream-name name)))
+                                               inputs)))))
                                      updates)
                                 result)
                         result))))
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index d838a4aca2..9676271542 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -369,42 +369,6 @@ (define* (update-package store package version updaters
                       (G_ "~a: updating from version ~a to version ~a...~%")
                       (package-name package)
                       (package-version package) version)
-                (for-each
-                 (lambda (change)
-                   (define field
-                     (match (upstream-input-change-type change)
-                       ('native 'native-inputs)
-                       ('propagated 'propagated-inputs)
-                       (_ 'inputs)))
-
-                   (define name
-                     (package-name package))
-                   (define loc
-                     (package-field-location package field))
-                   (define change-name
-                     (upstream-input-change-name change))
-
-                   (match (list (upstream-input-change-action change)
-                                (upstream-input-change-type change))
-                     (('add 'regular)
-                      (info loc (G_ "~a: consider adding this input: ~a~%")
-                            name change-name))
-                     (('add 'native)
-                      (info loc (G_ "~a: consider adding this native input: ~a~%")
-                            name change-name))
-                     (('add 'propagated)
-                      (info loc (G_ "~a: consider adding this propagated input: ~a~%")
-                            name change-name))
-                     (('remove 'regular)
-                      (info loc (G_ "~a: consider removing this input: ~a~%")
-                            name change-name))
-                     (('remove 'native)
-                      (info loc (G_ "~a: consider removing this native input: ~a~%")
-                            name change-name))
-                     (('remove 'propagated)
-                      (info loc (G_ "~a: consider removing this propagated input: ~a~%")
-                            name change-name))))
-                 (changed-inputs package source))
                 (let ((hash (file-hash* output)))
                   (update-package-source package source hash)))
               (warning (G_ "~a: version ~a could not be \
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 4ae2d1c8c8..7d9ae70eda 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -38,6 +38,7 @@ (define-module (guix upstream)
   #:use-module (guix hash)
   #:use-module (guix store)
   #:use-module ((guix derivations) #:select (built-derivations derivation->output-path))
+  #:autoload   (guix read-print) (object->string*)
   #:autoload   (gcrypt hash) (port-sha256)
   #:use-module (guix monads)
   #:use-module (srfi srfi-1)
@@ -583,6 +584,52 @@ (define* (package-update store package
                   (package-name package)))
      (values #f #f #f))))
 
+(define (update-package-inputs package source)
+  "Update the input fields of the definition of PACKAGE according to those
+specified in SOURCE, an <upstream-source>."
+  (define (update-field field source-inputs package-inputs)
+    (define loc
+      (package-field-location package field))
+
+    (define new
+      (map (compose string->symbol upstream-input-downstream-name)
+           (source-inputs source)))
+
+    (define old
+      (match (package-inputs package)
+        (((labels (? package? packages)) ...)
+         labels)
+        (_
+         '())))
+
+    (define unchanged?
+      (equal? new old))
+
+    (if (and loc (not unchanged?))
+        (edit-expression (location->source-properties
+                          (absolute-location loc))
+                         (lambda (str)
+                           (object->string* `(list ,@new)
+                                            (location-column loc))))
+        (unless unchanged?
+          ;; XXX: Bail out when FIELD isn't already present in the source.
+          ;; TODO: Add the field if it's missing.
+          (warning (package-location package)
+                   (G_ "~a: '~a' field not found; leaving it unchanged~%")
+                   (package-name package) field)
+          (warning (package-location package)
+                   (G_ "~a: expected '~a' value: ~s~%")
+                   (package-name package) field new))))
+
+  (for-each update-field
+            '(inputs native-inputs propagated-inputs)
+            (list upstream-source-regular-inputs
+                  upstream-source-native-inputs
+                  upstream-source-propagated-inputs)
+            (list package-inputs
+                  package-native-inputs
+                  package-propagated-inputs)))
+
 (define* (update-package-source package source hash)
   "Modify the source file that defines PACKAGE to refer to SOURCE, an
 <upstream-source> whose tarball has SHA256 HASH (a bytevector).  Return the
@@ -637,9 +684,7 @@ (define* (update-package-source package source hash)
               ;; function of the person who uploads the package.  Note that
               ;; package definitions usually concatenate fragments of the URL,
               ;; which is why we only attempt to replace a subset of the URL.
-              (let ((properties (location->source-properties
-                                 (absolute-location loc)))
-                    (replacements `((,old-version . ,version)
+              (let ((replacements `((,old-version . ,version)
                                     (,old-hash . ,hash)
                                     ,@(if (and old-commit new-commit)
                                           `((,old-commit . ,new-commit))
@@ -648,8 +693,11 @@ (define* (update-package-source package source hash)
                                           `((,(dirname old-url) .
                                              ,(dirname new-url)))
                                           '()))))
-                (and (edit-expression properties
+                (and (edit-expression (location->source-properties
+                                       (absolute-location loc))
                                       (cut update-expression <> replacements))
+                     (or (not (upstream-source-inputs source))
+                         (update-package-inputs package source))
                      version))
               (begin
                 (warning (G_ "~a: could not locate source file")
diff --git a/tests/guix-refresh.sh b/tests/guix-refresh.sh
index 691020b031..9d7a57a36e 100644
--- a/tests/guix-refresh.sh
+++ b/tests/guix-refresh.sh
@@ -34,7 +34,8 @@ GUIX_TEST_UPDATER_TARGETS='
                  ("1.6.4" "file:///dev/null")))
    ("libreoffice" "" (("1.0" "file:///dev/null")))
    ("idutils" "" (("'$idutils_version'" "file:///dev/null")))
-   ("the-test-package" "" (("5.5" "file://'$PWD/$module_dir'/source"))))'
+   ("the-test-package" "" (("5.5" "file://'$PWD/$module_dir'/source"
+                                   ("grep" "sed")))))'
 
 # No newer version available.
 guix refresh -t test idutils	# XXX: should return non-zero?
@@ -91,13 +92,15 @@ cat > "$module_dir/sample.scm"<<EOF
                                   ".tar.gz"))
               (sha256
                (base32
-                "086vqwk2wl8zfs47sq2xpjc9k066ilmb8z6dn0q6ymwjzlm196cd"))))))
+                "086vqwk2wl8zfs47sq2xpjc9k066ilmb8z6dn0q6ymwjzlm196cd"))))
+    (inputs (list coreutils tar))))
 EOF
 guix refresh -t test -L "$module_dir" the-test-package
 guix refresh -t test -L "$module_dir" the-test-package -u \
      --keyring="$module_dir/keyring.kbx"  # so we don't create $HOME/.config
 grep 'version "5.5"' "$module_dir/sample.scm"
 grep "$(guix hash -H sha256 -f nix-base32 "$module_dir/source")" "$module_dir/sample.scm"
+grep '(inputs (list grep sed))' "$module_dir/sample.scm"
 
 # Specifying a target version.
 guix refresh -t test guile=2.0.0 # XXX: should return non-zero?
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 10/19] upstream: Remove <upstream-input-change> and related code.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (8 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 09/19] upstream: 'update-package-source' edits input fields Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 11/19] tests: upstream: Restore test that was skipped Ludovic Courtès
                     ` (9 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571
  Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret,
	Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus,
	Simon Tournier, Tobias Geerinckx-Rice

* guix/upstream.scm (<upstream-input-change>): Remove.
(changed-inputs): Remove.
* tests/upstream.scm (test-package, test-new-package)
("changed-inputs returns no changes")
("changed-inputs returns changes to plain input list")
("changed-inputs returns changes to all plain input lists"): Remove.
---
 guix/upstream.scm  |  64 ------------------------
 tests/upstream.scm | 120 ---------------------------------------------
 2 files changed, 184 deletions(-)

diff --git a/guix/upstream.scm b/guix/upstream.scm
index 7d9ae70eda..53e473715c 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -82,12 +82,6 @@ (define-module (guix upstream)
             upstream-updater-predicate
             upstream-updater-import
 
-            upstream-input-change?
-            upstream-input-change-name
-            upstream-input-change-type
-            upstream-input-change-action
-            changed-inputs
-
             %updaters
             lookup-updater
 
@@ -151,64 +145,6 @@ (define upstream-source-regular-inputs (input-type-filter 'regular))
 (define upstream-source-native-inputs (input-type-filter 'native))
 (define upstream-source-propagated-inputs (input-type-filter 'propagated))
 
-;; Representation of an upstream input change.
-(define-record-type* <upstream-input-change>
-  upstream-input-change make-upstream-input-change
-  upstream-input-change?
-  (name    upstream-input-change-name)    ;string
-  (type    upstream-input-change-type)    ;symbol: regular | native | propagated
-  (action  upstream-input-change-action)) ;symbol: add | remove
-
-(define (changed-inputs package source)
-  "Return a list of input changes for PACKAGE compared to the 'inputs' field
-of SOURCE, an <upstream-source> record."
-  (define input->name
-    (match-lambda
-      ((label (? package? pkg) . out) (package-name pkg))
-      (_ #f)))
-
-  (if (upstream-source-inputs source)
-      (let* ((new-regular (map upstream-input-downstream-name
-                               (upstream-source-regular-inputs source)))
-             (new-native (map upstream-input-downstream-name
-                              (upstream-source-native-inputs source)))
-             (new-propagated (map upstream-input-downstream-name
-                                  (upstream-source-propagated-inputs source)))
-             (current-regular
-              (filter-map input->name (package-inputs package)))
-             (current-native
-              (filter-map input->name (package-native-inputs package)))
-             (current-propagated
-              (filter-map input->name (package-propagated-inputs package))))
-        (append-map
-         (match-lambda
-           ((action type names)
-            (map (lambda (name)
-                   (upstream-input-change
-                    (name name)
-                    (type type)
-                    (action action)))
-                 names)))
-         `((add regular
-                ,(lset-difference equal?
-                                  new-regular current-regular))
-           (remove regular
-                   ,(lset-difference equal?
-                                     current-regular new-regular))
-           (add native
-                ,(lset-difference equal?
-                                  new-native current-native))
-           (remove native
-                   ,(lset-difference equal?
-                                     current-native new-native))
-           (add propagated
-                ,(lset-difference equal?
-                                  new-propagated current-propagated))
-           (remove propagated
-                   ,(lset-difference equal?
-                                     current-propagated new-propagated)))))
-      '()))
-
 (define* (url-predicate matching-url?)
   "Return a predicate that returns true when passed a package whose source is
 an <origin> with the URL-FETCH method, and one of its URLs passes
diff --git a/tests/upstream.scm b/tests/upstream.scm
index 0792ebd5d0..b82579228a 100644
--- a/tests/upstream.scm
+++ b/tests/upstream.scm
@@ -54,124 +54,4 @@ (define-module (test-upstream)
                            (signature-urls
                             '("ftp://example.org/foo-1.tar.xz.sig"))))))
 
-(define test-package
-  (package
-    (name "test")
-    (version "2.10")
-    (source (origin
-              (method url-fetch)
-              (uri (string-append "mirror://gnu/hello/hello-" version
-                                  ".tar.gz"))
-              (sha256
-               (base32
-                "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i"))))
-    (build-system gnu-build-system)
-    (inputs
-     `(("hello" ,hello)))
-    (native-inputs
-     `(("sed" ,sed)
-       ("tar" ,tar)))
-    (propagated-inputs
-     `(("grep" ,grep)))
-    (home-page "http://localhost")
-    (synopsis "test")
-    (description "test")
-    (license license:gpl3+)))
-
-(test-equal "changed-inputs returns no changes"
-  '()
-  (changed-inputs test-package
-                  (upstream-source
-                   (package "test")
-                   (version "1")
-                   (urls '())
-                   (inputs
-                    (let ((->input
-                           (lambda (type)
-                             (match-lambda
-                               ((label _)
-                                (upstream-input
-                                 (name label)
-                                 (downstream-name label)
-                                 (type type)))))))
-                      (append (map (->input 'regular)
-                                   (package-inputs test-package))
-                              (map (->input 'native)
-                                   (package-native-inputs test-package))
-                              (map (->input 'propagated)
-                                   (package-propagated-inputs
-                                    test-package))))))))
-
-(define test-new-package
-  (package
-    (inherit test-package)
-    (inputs
-     (list hello))
-    (native-inputs
-     (list sed tar))
-    (propagated-inputs
-     (list grep))))
-
-(test-assert "changed-inputs returns changes to plain input list"
-  (let ((changes (changed-inputs
-                  (package
-                    (inherit test-new-package)
-                    (inputs (list hello sed))
-                    (native-inputs '())
-                    (propagated-inputs '()))
-                  (upstream-source
-                   (package "test")
-                   (version "1")
-                   (urls '())
-                   (inputs (list (upstream-input
-                                  (name "hello")
-                                  (downstream-name name))))))))
-    (match changes
-      ;; Exactly one change
-      (((? upstream-input-change? item))
-       (and (equal? (upstream-input-change-type item)
-                    'regular)
-            (equal? (upstream-input-change-action item)
-                    'remove)
-            (string=? (upstream-input-change-name item)
-                      "sed")))
-      (else (pk else #false)))))
-
-(test-assert "changed-inputs returns changes to all plain input lists"
-  (let ((changes (changed-inputs
-                  (package
-                    (inherit test-new-package)
-                    (inputs '())
-                    (native-inputs '())
-                    (propagated-inputs '()))
-                  (upstream-source
-                   (package "test")
-                   (version "1")
-                   (urls '())
-                   (inputs (list (upstream-input
-                                  (name "hello")
-                                  (downstream-name name)
-                                  (type 'regular))
-                                 (upstream-input
-                                  (name "sed")
-                                  (downstream-name name)
-                                  (type 'native))
-                                 (upstream-input
-                                  (name "tar")
-                                  (downstream-name name)
-                                  (type 'native))
-                                 (upstream-input
-                                  (name "grep")
-                                  (downstream-name name)
-                                  (type 'propagated))))))))
-    (match changes
-      (((? upstream-input-change? items) ...)
-       (and (equal? (map upstream-input-change-type items)
-                    '(regular native native propagated))
-            (equal? (map upstream-input-change-action items)
-                    '(add add add add))
-            (equal? (map upstream-input-change-name items)
-                    '("hello" "sed" "tar" "grep"))))
-      (else (pk else #false)))))
-
 (test-end)
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 11/19] tests: upstream: Restore test that was skipped.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (9 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 10/19] upstream: Remove <upstream-input-change> and related code Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 12/19] import: cpan: Remove unary 'string-append' call Ludovic Courtès
                     ` (8 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès

This test was being skipped since
ea6fb108f6a3a53d48ea187b1f82b5f7ffce00a7.

* tests/upstream.scm ("coalesce-sources same version"): Compare a
serialized form of <upstream-source>.
---
 tests/upstream.scm | 39 ++++++++++++++++++++-------------------
 1 file changed, 20 insertions(+), 19 deletions(-)

diff --git a/tests/upstream.scm b/tests/upstream.scm
index b82579228a..a94bb66068 100644
--- a/tests/upstream.scm
+++ b/tests/upstream.scm
@@ -32,26 +32,27 @@ (define-module (test-upstream)
 \f
 (test-begin "upstream")
 
-;; FIXME: Temporarily skipping this test; see <https://bugs.gnu.org/34229>.
-(test-skip 1)
-
 (test-equal "coalesce-sources same version"
-  (list (upstream-source
-         (package "foo") (version "1")
-         (urls '("ftp://example.org/foo-1.tar.xz"
-                 "ftp://example.org/foo-1.tar.gz"))
-         (signature-urls '("ftp://example.org/foo-1.tar.xz.sig"
-                           "ftp://example.org/foo-1.tar.gz.sig"))))
+  '((source "foo" "1"
+            ("ftp://example.org/foo-1.tar.xz"
+             "ftp://example.org/foo-1.tar.gz")
+            ("ftp://example.org/foo-1.tar.xz.sig"
+             "ftp://example.org/foo-1.tar.gz.sig")))
 
-  (coalesce-sources (list (upstream-source
-                           (package "foo") (version "1")
-                           (urls '("ftp://example.org/foo-1.tar.gz"))
-                           (signature-urls
-                            '("ftp://example.org/foo-1.tar.gz.sig")))
-                          (upstream-source
-                           (package "foo") (version "1")
-                           (urls '("ftp://example.org/foo-1.tar.xz"))
-                           (signature-urls
-                            '("ftp://example.org/foo-1.tar.xz.sig"))))))
+  (map (lambda (source)
+         `(source ,(upstream-source-package source)
+                  ,(upstream-source-version source)
+                  ,(upstream-source-urls source)
+                  ,(upstream-source-signature-urls source)))
+       (coalesce-sources (list (upstream-source
+                                (package "foo") (version "1")
+                                (urls '("ftp://example.org/foo-1.tar.gz"))
+                                (signature-urls
+                                 '("ftp://example.org/foo-1.tar.gz.sig")))
+                               (upstream-source
+                                (package "foo") (version "1")
+                                (urls '("ftp://example.org/foo-1.tar.xz"))
+                                (signature-urls
+                                 '("ftp://example.org/foo-1.tar.xz.sig")))))))
 
 (test-end)
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 12/19] import: cpan: Remove unary 'string-append' call.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (10 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 11/19] tests: upstream: Restore test that was skipped Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 13/19] import: cpan: Represent dependencies as <upstream-input> records Ludovic Courtès
                     ` (7 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès

* guix/import/cpan.scm (package->upstream-name): Remove useless
'string-append'.
---
 guix/import/cpan.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index da47018c35..d7f300777e 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -154,7 +154,7 @@ (define (package->upstream-name package)
           ((? origin? origin)
            (match (origin-uri origin)
              ((or (? string? url) (url _ ...))
-              (match (string-match (string-append "([^/]*)-v?[0-9\\.]+") url)
+              (match (string-match "([^/]*)-v?[0-9\\.]+" url)
                 (#f #f)
                 (m (match:substring m 1))))
              (_ #f)))
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 13/19] import: cpan: Represent dependencies as <upstream-input> records.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (11 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 12/19] import: cpan: Remove unary 'string-append' call Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 14/19] import: cpan: Updater provides input list Ludovic Courtès
                     ` (6 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès

* guix/import/cpan.scm (cpan-name->downstream-name)
(cran-dependency->upstream-input, cran-module-inputs): New procedures.
(cpan-module->sexp)[guix-name, convert-inputs]: Remove.
[maybe-inputs]: Adjust to deal with <upstream-input>.
Use 'cpan-name->downstream-name' instead of 'guix-name'.  Add call to
'cpan-module-inputs' and adjust calls to 'maybe-inputs'.  No longer emit
input labels.
* tests/cpan.scm ("cpan->guix-package"): Adjust test accordingly.
---
 guix/import/cpan.scm | 98 +++++++++++++++++++++++++-------------------
 tests/cpan.scm       |  7 +---
 2 files changed, 58 insertions(+), 47 deletions(-)

diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index d7f300777e..b6587d6821 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -3,7 +3,7 @@
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
 ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
-;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020, 2021, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -222,56 +222,73 @@ (define core-module?
                                        first perl-version last))))
                            (loop)))))))))))
 
+(define (cpan-name->downstream-name name)
+  "Return the Guix package name corresponding to NAME."
+  (if (string-prefix? "perl-" name)
+      (string-downcase name)
+      (string-append "perl-" (string-downcase name))))
+
+(define (cran-dependency->upstream-input dependency)
+  "Return the <upstream-input> corresponding to DEPENDENCY, or #f if
+DEPENDENCY denotes an implicit or otherwise unnecessary dependency."
+  (match (cpan-dependency-module dependency)
+    ("perl" #f)                                   ;implicit dependency
+    (module
+     (let ((type (match (cpan-dependency-phase dependency)
+                   ((or 'configure 'build 'test)
+                    ;; "runtime" may also be needed here.  See
+                    ;; https://metacpan.org/pod/CPAN::Meta::Spec#Phases,
+                    ;; which says they are required during
+                    ;; building.  We have not yet had a need for
+                    ;; cross-compiled Perl modules, however, so
+                    ;; we leave it out.
+                    'native)
+                   ('runtime
+                    'propagated)
+                   (_
+                    #f))))
+       (and type
+            (not (core-module? module))           ;expensive call!
+            (upstream-input
+             (name (module->dist-name module))
+             (downstream-name (cpan-name->downstream-name name))
+             (type type)))))))
+
+(define (cpan-module-inputs release)
+  "Return the list of <upstream-input> for dependencies of RELEASE, a
+<cpan-release>."
+  (define (upstream-input<? a b)
+    (string<? (upstream-input-downstream-name a)
+              (upstream-input-downstream-name b)))
+
+  (sort (delete-duplicates
+         (filter-map cran-dependency->upstream-input
+                     (cpan-release-dependencies release)))
+        upstream-input<?))
+
 (define (cpan-module->sexp release)
   "Return the 'package' s-expression for a CPAN module from the release data
 in RELEASE, a <cpan-release> record."
   (define name
     (cpan-release-distribution release))
 
-  (define (guix-name name)
-    (if (string-prefix? "perl-" name)
-        (string-downcase name)
-        (string-append "perl-" (string-downcase name))))
-
   (define version (cpan-release-version release))
   (define source-url (cpan-source-url release))
 
-  (define (convert-inputs phases)
-    ;; Convert phase dependencies into a list of name/variable pairs.
-    (match (filter-map (lambda (dependency)
-                         (and (memq (cpan-dependency-phase dependency)
-                                    phases)
-                              (cpan-dependency-module dependency)))
-                       (cpan-release-dependencies release))
-      ((inputs ...)
-       (sort
-        (delete-duplicates
-         ;; Listed dependencies may include core modules.  Filter those out.
-         (filter-map (match-lambda
-                       ("perl" #f)                ;implicit dependency
-                       ((? core-module?) #f)
-                       (module
-                         (let ((name (guix-name (module->dist-name module))))
-                           (list name
-                                 (list 'unquote (string->symbol name))))))
-                     inputs))
-        (lambda args
-          (match args
-            (((a _ ...) (b _ ...))
-             (string<? a b))))))))
-
-  (define (maybe-inputs guix-name inputs)
+  (define (maybe-inputs input-type inputs)
     (match inputs
       (()
        '())
       ((inputs ...)
-       (list (list guix-name
-                   (list 'quasiquote inputs))))))
+       `((,input-type (list ,@(map (compose string->symbol
+                                            upstream-input-downstream-name)
+                                   inputs)))))))
 
   (let ((tarball (with-store store
-                   (download-to-store store source-url))))
+                   (download-to-store store source-url)))
+        (inputs (cpan-module-inputs release)))
     `(package
-       (name ,(guix-name name))
+       (name ,(cpan-name->downstream-name name))
        (version ,version)
        (source (origin
                  (method url-fetch)
@@ -281,14 +298,11 @@ (define (cpan-module->sexp release)
                    ,(bytevector->nix-base32-string (file-sha256 tarball))))))
        (build-system perl-build-system)
        ,@(maybe-inputs 'native-inputs
-                       ;; "runtime" may also be needed here.  See
-                       ;; https://metacpan.org/pod/CPAN::Meta::Spec#Phases,
-                       ;; which says they are required during building.  We
-                       ;; have not yet had a need for cross-compiled perl
-                       ;; modules, however, so we leave it out.
-                       (convert-inputs '(configure build test)))
+                       (filter (upstream-input-type-predicate 'native)
+                               inputs))
        ,@(maybe-inputs 'propagated-inputs
-                       (convert-inputs '(runtime)))
+                       (filter (upstream-input-type-predicate 'propagated)
+                               inputs))
        (home-page ,(cpan-home name))
        (synopsis ,(cpan-release-abstract release))
        (description fill-in-yourself!)
diff --git a/tests/cpan.scm b/tests/cpan.scm
index bbcd108e12..c9dd6d36de 100644
--- a/tests/cpan.scm
+++ b/tests/cpan.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
-;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -64,7 +64,6 @@ (define test-source
 (test-begin "cpan")
 
 (test-assert "cpan->guix-package"
-  ;; Replace network resources with sample data.
   (with-http-server `((200 ,test-json)
                       (200 ,test-source)
                       (200 "{ \"distribution\" : \"Test-Script\" }"))
@@ -82,9 +81,7 @@ (define test-source
                        ('base32
                         (? string? hash)))))
            ('build-system 'perl-build-system)
-           ('propagated-inputs
-            ('quasiquote
-             (("perl-test-script" ('unquote 'perl-test-script)))))
+           ('propagated-inputs ('list 'perl-test-script))
            ('home-page "https://metacpan.org/release/Foo-Bar")
            ('synopsis "Fizzle Fuzz")
            ('description 'fill-in-yourself!)
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 14/19] import: cpan: Updater provides input list.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (12 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 13/19] import: cpan: Represent dependencies as <upstream-input> records Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 15/19] import: elpa: " Ludovic Courtès
                     ` (5 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès

* guix/import/cpan.scm (latest-release): Add 'inputs' field.
* tests/cpan.scm ("package-latest-release"): New test.
---
 guix/import/cpan.scm |  3 ++-
 tests/cpan.scm       | 27 +++++++++++++++++++++++++++
 2 files changed, 29 insertions(+), 1 deletion(-)

diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index b6587d6821..b87736eef6 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -354,7 +354,8 @@ (define* (latest-release package #:key (version #f))
        (upstream-source
         (package (package-name package))
         (version version)
-        (urls (list url)))))))
+        (urls (list url))
+        (inputs (cpan-module-inputs release)))))))
 
 (define %cpan-updater
   (upstream-updater
diff --git a/tests/cpan.scm b/tests/cpan.scm
index c9dd6d36de..5fcce85d8d 100644
--- a/tests/cpan.scm
+++ b/tests/cpan.scm
@@ -21,7 +21,10 @@
 (define-module (test-cpan)
   #:use-module (guix import cpan)
   #:use-module (guix base32)
+  #:use-module (guix upstream)
+  #:use-module ((guix download) #:select (url-fetch))
   #:use-module (gcrypt hash)
+  #:use-module (guix tests)
   #:use-module (guix tests http)
   #:use-module ((guix store) #:select (%graft?))
   #:use-module (srfi srfi-64)
@@ -92,6 +95,30 @@ (define test-source
         (x
          (pk 'fail x #f))))))
 
+(test-equal "package-latest-release"
+  (list '("http://example.com/Foo-Bar-0.1.tar.gz")
+        #f
+        (list (upstream-input
+               (name "Test-Script")
+               (downstream-name "perl-test-script")
+               (type 'propagated))))
+  (with-http-server `((200 ,test-json)
+                      (200 ,test-source)
+                      (200 "{ \"distribution\" : \"Test-Script\" }"))
+    (define source
+      (parameterize ((%metacpan-base-url (%local-url)))
+        (package-latest-release
+         (dummy-package "perl-test-script"
+                        (version "0.0.0")
+                        (source (dummy-origin
+                                 (method url-fetch)
+                                 (uri "mirror://cpan/Foo-Bar-0.0.0.tgz"))))
+         (list %cpan-updater))))
+
+    (list (upstream-source-urls source)
+          (upstream-source-signature-urls source)
+          (upstream-source-inputs source))))
+
 (test-equal "metacpan-url->mirror-url, http"
   "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz"
   (metacpan-url->mirror-url
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 15/19] import: elpa: Updater provides input list.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (13 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 14/19] import: cpan: Updater provides input list Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 16/19] import: gem: Factorize "bundler" special case for name mapping Ludovic Courtès
                     ` (4 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès, Andrew Tropin, Liliana Marie Prikler

* guix/import/elpa.scm (elpa-dependency->upstream-input): New
procedure.
(latest-release): Add 'inputs' field.
* tests/elpa.scm ("package-latest-release"): New test.
---
 guix/import/elpa.scm | 30 +++++++++++++++++++++++++--
 tests/elpa.scm       | 48 ++++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 74 insertions(+), 4 deletions(-)

diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index 1313a8aa67..e65cf6683b 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -272,6 +272,25 @@ (define* (melpa-recipe->origin recipe)
                 (assq-ref recipe ':fetcher))
        #f)))
 
+(define (elpa-dependency->upstream-input dependency)
+  "Convert DEPENDENCY, an sexp as returned by 'elpa-package-inputs', into an
+<upstream-input>."
+  (match dependency
+    ((name version)
+     (and (not (emacs-standard-library? (symbol->string name)))
+          (upstream-input
+           (name (symbol->string name))
+           (downstream-name (elpa-guix-name name))
+           (type 'propagated)
+           (min-version (if (pair? version)
+                            (string-join (map number->string version) ".")
+                            #f))
+           (max-version (match version
+                          (() #f)
+                          ((_) #f)
+                          ((_ _) #f)
+                          (_ min-version))))))))
+
 (define default-files-spec
   ;; This contains more than just the things contained in %default-include and
   ;; %default-exclude, presumably because this includes source files (*.in,
@@ -421,12 +440,19 @@ (define* (latest-release package #:key (version #f))
                         (elpa-version->string raw-version))))
             (url     (match info
                        ((_ raw-version reqs synopsis kind . rest)
-                        (package-source-url kind name version repo)))))
+                        (package-source-url kind name version repo))))
+            (inputs  (match info
+                       ((name raw-version reqs . _)
+                        (filter-map elpa-dependency->upstream-input
+                                    (if (eq? 'nil reqs)
+                                        '()
+                                        reqs))))))
        (upstream-source
         (package (package-name package))
         (version version)
         (urls (list url))
-        (signature-urls (list (string-append url ".sig"))))))))
+        (signature-urls (list (string-append url ".sig")))
+        (inputs inputs))))))
 
 (define elpa-repository
   (memoize
diff --git a/tests/elpa.scm b/tests/elpa.scm
index 1efdf2457f..56008fe014 100644
--- a/tests/elpa.scm
+++ b/tests/elpa.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
-;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
 ;;;
@@ -21,6 +21,8 @@
 
 (define-module (test-elpa)
   #:use-module (guix import elpa)
+  #:use-module (guix upstream)
+  #:use-module ((guix download) #:select (url-fetch))
   #:use-module (guix tests)
   #:use-module (guix tests http)
   #:use-module (srfi srfi-1)
@@ -40,8 +42,20 @@ (define elpa-mock-archive
     (auctex .
             [(11 88 6)
              nil "Integrated environment for *TeX*" tar
-             ((:url . "http://www.gnu.org/software/auctex/"))])))
+             ((:url . "http://www.gnu.org/software/auctex/"))])
+    (taxy-magit-section .
+		        [(0 12 2)
+		         ((emacs
+			   (26 3))
+		          (magit-section
+			   (3 2 1))
+		          (taxy
+			   (0 10)))
+		         "View Taxy structs in a Magit Section buffer" tar
+		         ((:url . "https://github.com/alphapapa/taxy.el")
+		          (:keywords "lisp"))])))
 
+\f
 (test-begin "elpa")
 
 (define (eval-test-with-elpa pkg)
@@ -73,6 +87,36 @@ (define (eval-test-with-elpa pkg)
 (test-assert "elpa->guix-package test 1"
   (eval-test-with-elpa "auctex"))
 
+(test-equal "package-latest-release"
+  (list '("https://elpa.gnu.org/packages/taxy-magit-section-0.12.2.tar")
+        '("https://elpa.gnu.org/packages/taxy-magit-section-0.12.2.tar.sig")
+        (list (upstream-input
+               (name "magit-section")
+               (downstream-name "emacs-magit-section")
+               (type 'propagated)
+               (min-version "3.2.1")
+               (max-version min-version))
+              (upstream-input
+               (name "taxy")
+               (downstream-name "emacs-taxy")
+               (type 'propagated)
+               (min-version "0.10")
+               (max-version #f))))
+  (with-http-server `((200 ,(object->string elpa-mock-archive)))
+    (parameterize ((current-http-proxy (%local-url)))
+      (define source
+        (package-latest-release
+         (dummy-package "emacs-taxy-magit-section"
+                        (version "0.0.0")
+                        (source (dummy-origin
+                                 (method url-fetch)
+                                 (uri "https://elpa.gnu.org/xyz"))))
+         (list %elpa-updater)))
+
+      (list (upstream-source-urls source)
+            (upstream-source-signature-urls source)
+            (upstream-source-inputs source)))))
+
 (test-equal "guix-package->elpa-name: without 'upstream-name' property"
   "auctex"
   (guix-package->elpa-name (dummy-package "emacs-auctex")))
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 16/19] import: gem: Factorize "bundler" special case for name mapping.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (14 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 15/19] import: elpa: " Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 17/19] import: gem: Updater provides input list Ludovic Courtès
                     ` (3 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès, Christopher Baines

* guix/import/gem.scm (ruby-package-name): Add "bundler" special case.
(gem->guix-package): Adjust accordingly.
* tests/gem.scm ("gem-recursive-import")
("gem-recursive-import with a specific version"): Remove "ruby-bundler"
from the expected packages.
---
 guix/import/gem.scm | 14 ++++++--------
 tests/gem.scm       | 30 ------------------------------
 2 files changed, 6 insertions(+), 38 deletions(-)

diff --git a/guix/import/gem.scm b/guix/import/gem.scm
index 4e2be0f5f8..87a75bdaa6 100644
--- a/guix/import/gem.scm
+++ b/guix/import/gem.scm
@@ -93,9 +93,11 @@ (define* (rubygems-fetch name #:optional version)
 (define (ruby-package-name name)
   "Given the NAME of a package on RubyGems, return a Guix-compliant name for
 the package."
-  (if (string-prefix? "ruby-" name)
-      (snake-case name)
-      (string-append "ruby-" (snake-case name))))
+  (if (string=? name "bundler")
+      name                                        ;special case: no prefix
+      (if (string-prefix? "ruby-" name)
+          (snake-case name)
+          (string-append "ruby-" (snake-case name)))))
 
 (define (make-gem-sexp name version hash home-page synopsis description
                        dependencies licenses)
@@ -135,11 +137,7 @@ (define* (gem->guix-package package-name #:key (repo 'rubygems) version
         (let* ((dependencies-names (map gem-dependency-name
                                         (gem-dependencies-runtime
                                          (gem-dependencies gem))))
-               (dependencies (map (lambda (dep)
-                                    (if (string=? dep "bundler")
-                                        "bundler" ; special case, no prefix
-                                        (ruby-package-name dep)))
-                                  dependencies-names))
+               (dependencies (map ruby-package-name dependencies-names))
                (licenses     (map string->license (gem-licenses gem))))
           (values (make-gem-sexp (gem-name gem) (gem-version gem)
                                  (gem-sha256 gem) (gem-home-page gem)
diff --git a/tests/gem.scm b/tests/gem.scm
index 6aa0d279dc..023415de7b 100644
--- a/tests/gem.scm
+++ b/tests/gem.scm
@@ -181,21 +181,6 @@ (define test-bundler-json
               ('description "Another cool gem")
               ('home-page "https://example.com")
               ('license #f))                      ;no licensing info
-            ('package
-              ('name "ruby-bundler")
-              ('version "1.14.2")
-              ('source
-               ('origin
-                 ('method 'url-fetch)
-                 ('uri ('rubygems-uri "bundler" 'version))
-                 ('sha256
-                  ('base32
-                   "1446xiz7zg0bz7kgx9jv84y0s4hpsg61dj5l3qb0i00avc1kxd9v"))))
-              ('build-system 'ruby-build-system)
-              ('synopsis "Ruby gem bundler")
-              ('description "Ruby gem bundler")
-              ('home-page "https://bundler.io/")
-              ('license 'license:expat))
             ('package
               ('name "ruby-foo")
               ('version "1.0.0")
@@ -248,21 +233,6 @@ (define test-bundler-json
               ('description "Another cool gem")
               ('home-page "https://example.com")
               ('license #f))                      ;no licensing info
-            ('package
-              ('name "ruby-bundler")
-              ('version "1.14.2")
-              ('source
-               ('origin
-                 ('method 'url-fetch)
-                 ('uri ('rubygems-uri "bundler" 'version))
-                 ('sha256
-                  ('base32
-                   "1446xiz7zg0bz7kgx9jv84y0s4hpsg61dj5l3qb0i00avc1kxd9v"))))
-              ('build-system 'ruby-build-system)
-              ('synopsis "Ruby gem bundler")
-              ('description "Ruby gem bundler")
-              ('home-page "https://bundler.io/")
-              ('license 'license:expat))
             ('package
               ('name "ruby-foo")
               ('version "2.0.0")
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 17/19] import: gem: Updater provides input list.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (15 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 16/19] import: gem: Factorize "bundler" special case for name mapping Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 18/19] upstream: Honor package properties for ignored and extra inputs Ludovic Courtès
                     ` (2 subsequent siblings)
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès, Christopher Baines

* guix/import/gem.scm (import-release): Add 'inputs' field.
* tests/gem.scm ("package-latest-release"): New test.
---
 guix/import/gem.scm | 13 +++++++++++--
 tests/gem.scm       | 31 +++++++++++++++++++++++++++++++
 2 files changed, 42 insertions(+), 2 deletions(-)

diff --git a/guix/import/gem.scm b/guix/import/gem.scm
index 87a75bdaa6..56cbc681a1 100644
--- a/guix/import/gem.scm
+++ b/guix/import/gem.scm
@@ -2,7 +2,7 @@
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
 ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
-;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020, 2021, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info>
@@ -176,12 +176,21 @@ (define* (import-release package #:key (version #f))
   "Return an <upstream-source> for the latest release of PACKAGE."
   (let* ((gem-name (guix-package->gem-name package))
          (gem      (rubygems-fetch gem-name))
+         (inputs   (map (lambda (dependency)
+                          (let ((name (gem-dependency-name dependency)))
+                            (upstream-input
+                             (name name)
+                             (downstream-name
+                              (ruby-package-name name))
+                             (type 'propagated))))
+                        (gem-dependencies-runtime (gem-dependencies gem))))
          (version  (or version (gem-version gem)))
          (url      (rubygems-uri gem-name version)))
     (upstream-source
      (package (package-name package))
      (version version)
-     (urls (list url)))))
+     (urls (list url))
+     (inputs inputs))))
 
 (define %gem-updater
   (upstream-updater
diff --git a/tests/gem.scm b/tests/gem.scm
index 023415de7b..a2b5e39077 100644
--- a/tests/gem.scm
+++ b/tests/gem.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info>
+;;; Copyright © 2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,6 +23,9 @@
 
 (define-module (test-gem)
   #:use-module (guix import gem)
+  #:use-module (guix upstream)
+  #:use-module ((guix download) #:select (url-fetch))
+  #:use-module ((guix build-system ruby) #:select (rubygems-uri))
   #:use-module (guix base32)
   #:use-module (gcrypt hash)
   #:use-module (guix tests)
@@ -253,4 +257,31 @@ (define test-bundler-json
           (x
            (pk 'fail x #f)))))
 
+(test-equal "package-latest-release"
+  (list '("https://rubygems.org/downloads/foo-1.0.0.gem")
+        (list (upstream-input
+               (name "bundler")
+               (downstream-name name)
+               (type 'propagated))
+              (upstream-input
+               (name "bar")
+               (downstream-name "ruby-bar")
+               (type 'propagated))))
+  (mock ((guix http-client) http-fetch
+         (lambda (url . rest)
+           (match url
+             ("https://rubygems.org/api/v1/gems/foo.json"
+              (values (open-input-string test-foo-json)
+                      (string-length test-foo-json)))
+             (_ (error "Unexpected URL: " url)))))
+        (let ((source (package-latest-release
+                       (dummy-package "ruby-foo"
+                                      (version "0.1.2")
+                                      (source (dummy-origin
+                                               (method url-fetch)
+                                               (uri (rubygems-uri "foo"
+                                                                  version))))))))
+          (list (upstream-source-urls source)
+                (upstream-source-inputs source)))))
+
 (test-end "gem")
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 18/19] upstream: Honor package properties for ignored and extra inputs.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (16 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 17/19] import: gem: Updater provides input list Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 19/19] gnu: Add updater input properties for R and Python packages Ludovic Courtès
  2023-05-31 21:54   ` bug#63571: [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571
  Cc: Ludovic Courtès, Christopher Baines, Josselin Poiret,
	Ludovic Courtès, Mathieu Othacehe, Ricardo Wurmus,
	Simon Tournier, Tobias Geerinckx-Rice

* guix/upstream.scm (update-package-inputs)[filtered-inputs]
[regular-inputs, native-inputs, propagated-inputs]: New procedures.
Use them in 'update-field' calls.
* tests/guix-refresh.sh (GUIX_TEST_UPDATER_TARGETS): Add "libreoffice"
to the dependencies of "the-test-package".  Add 'updater-ignored-inputs'
property to "the-test-package".
* doc/guix.texi (Invoking guix refresh): Document it.
---
 doc/guix.texi         | 30 ++++++++++++++++++++++++++++++
 guix/upstream.scm     | 39 ++++++++++++++++++++++++++++++++++++---
 tests/guix-refresh.sh |  5 +++--
 3 files changed, 69 insertions(+), 5 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index c54a72bfaa..33528e997e 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -14358,6 +14358,36 @@ Invoking guix refresh
 
 @xref{Creating a Channel}, on how to create a channel.
 
+This command updates the version and source code hash of the package.
+Depending on the updater being used, it can also update the various
+@samp{inputs} fields of the package.  In some cases, the updater might
+get inputs wrong---it might not know about an extra input that's
+necessary, or it might add an input that should be avoided.
+
+@cindex @code{updater-extra-inputs}, package property
+@cindex @code{updater-ignored-inputs}, package property
+To address that, packagers can add properties stating inputs that should
+be added to those found by the updater or inputs that should be ignored:
+the @code{updater-extra-inputs} and @code{updater-ignored-inputs}
+properties pertain to ``regular'' inputs, and there are equivalent
+properties for @samp{native} and @samp{propagated} inputs.  In the
+example below, we tell the updater that we need @samp{openmpi} as an
+additional input:
+
+@lisp
+(define-public python-mpi4py
+  (package
+    (name "python-mpi4py")
+    ;; @dots{}
+    (inputs (list openmpi))
+    (properties
+     '((updater-extra-inputs . ("openmpi"))))))
+@end lisp
+
+That way, @command{guix refresh -u python-mpi4py} will leave the
+@samp{openmpi} input, even if it is not among the inputs it would
+normally add.
+
 @item --select=[@var{subset}]
 @itemx -s @var{subset}
 Select all the packages in @var{subset}, one of @code{core}, @code{non-core}
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 53e473715c..33248d645c 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -557,11 +557,44 @@ (define (update-package-inputs package source)
                    (G_ "~a: expected '~a' value: ~s~%")
                    (package-name package) field new))))
 
+  (define (filtered-inputs source-inputs extra-property ignore-property)
+    ;; Return a procedure that behaves like SOURCE-INPUTS but additionally
+    ;; honors EXTRA-PROPERTY and IGNORE-PROPERTY from PACKAGE.
+    (lambda (source)
+      (let* ((inputs (source-inputs source))
+             (properties (package-properties package))
+             (ignore (or (assoc-ref properties ignore-property) '()))
+             (extra (or (assoc-ref properties extra-property) '())))
+        (append (if (null? ignore)
+                    inputs
+                    (remove (lambda (input)
+                              (member (upstream-input-downstream-name input)
+                                      ignore))
+                            inputs))
+                (map (lambda (name)
+                       (upstream-input
+                        (name name)
+                        (downstream-name name)))
+                     extra)))))
+
+  (define regular-inputs
+    (filtered-inputs upstream-source-regular-inputs
+                     'updater-extra-inputs
+                     'updater-ignored-inputs))
+  (define native-inputs
+    (filtered-inputs upstream-source-native-inputs
+                     'updater-extra-native-inputs
+                     'updater-ignored-native-inputs))
+  (define propagated-inputs
+    (filtered-inputs upstream-source-propagated-inputs
+                     'updater-extra-propagated-inputs
+                     'updater-ignored-propagated-inputs))
+
   (for-each update-field
             '(inputs native-inputs propagated-inputs)
-            (list upstream-source-regular-inputs
-                  upstream-source-native-inputs
-                  upstream-source-propagated-inputs)
+            (list regular-inputs
+                  native-inputs
+                  propagated-inputs)
             (list package-inputs
                   package-native-inputs
                   package-propagated-inputs)))
diff --git a/tests/guix-refresh.sh b/tests/guix-refresh.sh
index 9d7a57a36e..51d34c4b51 100644
--- a/tests/guix-refresh.sh
+++ b/tests/guix-refresh.sh
@@ -35,7 +35,7 @@ GUIX_TEST_UPDATER_TARGETS='
    ("libreoffice" "" (("1.0" "file:///dev/null")))
    ("idutils" "" (("'$idutils_version'" "file:///dev/null")))
    ("the-test-package" "" (("5.5" "file://'$PWD/$module_dir'/source"
-                                   ("grep" "sed")))))'
+                                   ("grep" "sed" "libreoffice")))))'
 
 # No newer version available.
 guix refresh -t test idutils	# XXX: should return non-zero?
@@ -93,7 +93,8 @@ cat > "$module_dir/sample.scm"<<EOF
               (sha256
                (base32
                 "086vqwk2wl8zfs47sq2xpjc9k066ilmb8z6dn0q6ymwjzlm196cd"))))
-    (inputs (list coreutils tar))))
+    (inputs (list coreutils tar))
+    (properties '((updater-ignored-inputs . ("libreoffice"))))))
 EOF
 guix refresh -t test -L "$module_dir" the-test-package
 guix refresh -t test -L "$module_dir" the-test-package -u \
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* [bug#63571] [PATCH v2 19/19] gnu: Add updater input properties for R and Python packages.
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (17 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 18/19] upstream: Honor package properties for ignored and extra inputs Ludovic Courtès
@ 2023-05-29 14:45   ` Ludovic Courtès
  2023-05-31 21:54   ` bug#63571: [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-29 14:45 UTC (permalink / raw)
  To: 63571; +Cc: Ludovic Courtès, Ricardo Wurmus

* gnu/packages/cran.scm (r-glue, r-xfun, r-vctrs)
(r-lifecycle): Turn comment about r-knitr into 'properties' field.
* gnu/packages/mpi.scm (python-mpi4py)[properties]: New field.
---
 gnu/packages/cran.scm | 36 ++++++++++++++++--------------------
 gnu/packages/mpi.scm  |  2 ++
 2 files changed, 18 insertions(+), 20 deletions(-)

diff --git a/gnu/packages/cran.scm b/gnu/packages/cran.scm
index 4fafcaea9c..fa6f86c587 100644
--- a/gnu/packages/cran.scm
+++ b/gnu/packages/cran.scm
@@ -5085,11 +5085,10 @@ (define-public r-glue
         (base32
          "1gzxk5jgdh2xq9r7z09xs306ygzf27vhg3pyfl7ck1755gqii9cx"))))
     (build-system r-build-system)
-    ;; knitr depends on glue, so we can't add knitr here to build the
-    ;; vignettes.
-    #;
-    (native-inputs
-     `(("r-knitr" ,r-knitr)))
+    (properties
+     ;; knitr depends on glue, so we can't add knitr here to build the
+     ;; vignettes.
+     '((updater-ignored-native-inputs . ("r-knitr"))))
     (home-page "https://github.com/tidyverse/glue")
     (synopsis "Interpreted string literals")
     (description
@@ -8777,10 +8776,9 @@ (define-public r-xfun
        (sha256
         (base32 "1jan2ggfywm1g05zszyy8d492wj7vpy35682lrnlklrx4jxsmv6h"))))
     (build-system r-build-system)
-    ;; knitr itself depends on xfun
-    #;
-    (native-inputs
-     `(("r-knitr" ,r-knitr)))
+    (properties
+     ;; knitr itself depends on xfun
+     '((updater-ignored-native-inputs . ("r-knitr"))))
     (home-page "https://github.com/yihui/xfun")
     (synopsis "Miscellaneous functions")
     (description
@@ -8867,11 +8865,10 @@ (define-public r-vctrs
     (build-system r-build-system)
     (propagated-inputs
      (list r-cli r-glue r-lifecycle r-rlang))
-    ;; We can't have r-knitr among the inputs here, because r-vctrs ends up
-    ;; being an eventual input to r-knitr.
-    #;
-    (native-inputs
-     (list r-knitr))
+    (properties
+     ;; We can't have r-knitr among the inputs here, because r-vctrs ends up
+     ;; being an eventual input to r-knitr.
+     '((updater-ignored-native-inputs . ("r-knitr"))))
     (home-page "https://github.com/r-lib/vctrs")
     (synopsis "Vector helpers")
     (description
@@ -25253,15 +25250,14 @@ (define-public r-lifecycle
        (sha256
         (base32
          "1hk9mblhap429fk77qpgc4hv0j91q5wpahi0y76w118m471zsnb4"))))
-    (properties `((upstream-name . "lifecycle")))
     (build-system r-build-system)
     (propagated-inputs
      (list r-cli r-glue r-rlang))
-    ;; We can't add this here because via r-stringr this package ends up being
-    ;; an input to r-knitr.
-    #;
-    (native-inputs
-     (list r-knitr)) ; for vignettes
+    (properties
+     ;; We can't add this here because via r-stringr this package ends up
+     ;; being an input to r-knitr.
+     '((updater-ignored-native-inputs . ("r-knitr"))
+       (upstream-name . "lifecycle")))
     (home-page "https://github.com/r-lib/lifecycle")
     (synopsis "Manage the life cycle of your package functions")
     (description
diff --git a/gnu/packages/mpi.scm b/gnu/packages/mpi.scm
index fb874484bf..c78799e640 100644
--- a/gnu/packages/mpi.scm
+++ b/gnu/packages/mpi.scm
@@ -422,6 +422,8 @@ (define-public python-mpi4py
              #t)))))
     (inputs
      (list openmpi))
+    (properties
+     '((updater-extra-inputs . ("openmpi"))))
     (home-page "https://bitbucket.org/mpi4py/mpi4py/")
     (synopsis "Python bindings for the Message Passing Interface standard")
     (description "MPI for Python (mpi4py) provides bindings of the Message
-- 
2.40.1





^ permalink raw reply related	[flat|nested] 38+ messages in thread

* bug#63571: [PATCH 00/14] 'guix refresh -u' updates input fields
  2023-05-29 14:44 ` Ludovic Courtès
                     ` (18 preceding siblings ...)
  2023-05-29 14:45   ` [bug#63571] [PATCH v2 19/19] gnu: Add updater input properties for R and Python packages Ludovic Courtès
@ 2023-05-31 21:54   ` Ludovic Courtès
  19 siblings, 0 replies; 38+ messages in thread
From: Ludovic Courtès @ 2023-05-31 21:54 UTC (permalink / raw)
  To: 63571-done

Ludovic Courtès <ludo@gnu.org> skribis:

> This is addressed in v2 of this patch series, along with other
> improvements (changes since v1):
>
>   • honors ‘updater-extra-inputs’ and ‘updater-ignored-inputs’ package
>     properties (and similarly for native and propagated inputs);
>
>   • add those properties to a few packages;
>
>   • ‘cran’ updater keeps inputs alphabetically sorted;
>
>   • ‘gem’ updater now updates inputs as well.
>
> Surely this will reveal limitations of updaters/importers but I’d like
> to see it as an opportunity to improve them; more importantly, we have
> to reduce the maintenance cost of all these imported packages, and this
> is a step in that direction.
>
> If there are no objections, I’d like to apply this series within a few
> days.

Pushed as 9f7cd1fcaf99c8e8430d0b29335220701664dc54!

Let me know how it works for you!

Ludo’.




^ permalink raw reply	[flat|nested] 38+ messages in thread

end of thread, other threads:[~2023-05-31 21:55 UTC | newest]

Thread overview: 38+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2023-05-18 15:11 [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès
2023-05-18 15:16 ` [bug#63571] [PATCH 01/14] tests: pypi: Factorize tarball and wheel file creation Ludovic Courtès
2023-05-18 15:16 ` [bug#63571] [PATCH 02/14] tests: http: Allow responses to specify a path Ludovic Courtès
2023-05-18 15:16 ` [bug#63571] [PATCH 03/14] tests: pypi: Rewrite tests using a local HTTP server Ludovic Courtès
2023-05-18 15:16 ` [bug#63571] [PATCH 04/14] import: utils: 'call-with-networking-exception-handler' doesn't unwind Ludovic Courtès
2023-05-18 15:16 ` [bug#63571] [PATCH 05/14] import: json: Add #:timeout to 'json-fetch' Ludovic Courtès
2023-05-18 15:16 ` [bug#63571] [PATCH 06/14] upstream: Replace 'input-changes' field by 'inputs' Ludovic Courtès
2023-05-18 15:16 ` [bug#63571] [PATCH 07/14] diagnostics: Factorize 'absolute-location' Ludovic Courtès
2023-05-18 15:16 ` [bug#63571] [PATCH 08/14] upstream: 'update-package-source' edits input fields Ludovic Courtès
2023-05-18 15:16 ` [bug#63571] [PATCH 09/14] upstream: Remove <upstream-input-change> and related code Ludovic Courtès
2023-05-18 15:16 ` [bug#63571] [PATCH 10/14] tests: upstream: Restore test that was skipped Ludovic Courtès
2023-05-18 15:16 ` [bug#63571] [PATCH 11/14] import: cpan: Remove unary 'string-append' call Ludovic Courtès
2023-05-18 15:16 ` [bug#63571] [PATCH 12/14] import: cpan: Represent dependencies as <upstream-input> records Ludovic Courtès
2023-05-18 15:16 ` [bug#63571] [PATCH 13/14] import: cpan: Updater provides input list Ludovic Courtès
2023-05-18 15:16 ` [bug#63571] [PATCH 14/14] import: elpa: " Ludovic Courtès
2023-05-18 16:01 ` [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields Liliana Marie Prikler
2023-05-18 17:02   ` Ludovic Courtès
2023-05-29 14:44 ` Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 01/19] tests: pypi: Factorize tarball and wheel file creation Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 02/19] tests: http: Allow responses to specify a path Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 03/19] tests: pypi: Rewrite tests using a local HTTP server Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 04/19] import: utils: 'call-with-networking-exception-handler' doesn't unwind Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 05/19] import: json: Add #:timeout to 'json-fetch' Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 06/19] doc: Mention 'guix refresh -u' for third-party channels Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 07/19] upstream: Replace 'input-changes' field by 'inputs' Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 08/19] diagnostics: Factorize 'absolute-location' Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 09/19] upstream: 'update-package-source' edits input fields Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 10/19] upstream: Remove <upstream-input-change> and related code Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 11/19] tests: upstream: Restore test that was skipped Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 12/19] import: cpan: Remove unary 'string-append' call Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 13/19] import: cpan: Represent dependencies as <upstream-input> records Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 14/19] import: cpan: Updater provides input list Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 15/19] import: elpa: " Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 16/19] import: gem: Factorize "bundler" special case for name mapping Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 17/19] import: gem: Updater provides input list Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 18/19] upstream: Honor package properties for ignored and extra inputs Ludovic Courtès
2023-05-29 14:45   ` [bug#63571] [PATCH v2 19/19] gnu: Add updater input properties for R and Python packages Ludovic Courtès
2023-05-31 21:54   ` bug#63571: [PATCH 00/14] 'guix refresh -u' updates input fields Ludovic Courtès

Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/guix.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.