GNU bug report logs - #63571
[PATCH 00/14] 'guix refresh -u' updates input fields

Previous Next

Package: guix-patches;

Reported by: Ludovic Courtès <ludo <at> gnu.org>

Date: Thu, 18 May 2023 15:13:02 UTC

Severity: normal

Tags: patch

Done: Ludovic Courtès <ludo <at> gnu.org>

Bug is archived. No further changes may be made.

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 63571 in the body.
You can then email your comments to 63571 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

View this report as an mbox folder, status mbox, maintainer mbox


Report forwarded to andrew <at> trop.in, liliana.prikler <at> gmail.com, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 15:13:02 GMT) Full text and rfc822 format available.

Acknowledgement sent to Ludovic Courtès <ludo <at> gnu.org>:
New bug report received and forwarded. Copy sent to andrew <at> trop.in, liliana.prikler <at> gmail.com, guix-patches <at> gnu.org. (Thu, 18 May 2023 15:13:02 GMT) Full text and rfc822 format available.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: guix-patches <at> gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 00/14] 'guix refresh -u' updates input fields
Date: Thu, 18 May 2023 17:11:59 +0200
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





Information forwarded to lars <at> 6xq.net, jgart <at> dismail.de, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 15:17:01 GMT) Full text and rfc822 format available.

Message #8 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 01/14] tests: pypi: Factorize tarball and wheel file creation.
Date: Thu, 18 May 2023 17:16:09 +0200
* 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))
+
 
 (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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 15:17:02 GMT) Full text and rfc822 format available.

Message #11 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 02/14] tests: http: Allow responses to specify a path.
Date: Thu, 18 May 2023 17:16:10 +0200
* 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 <at> gnu.org>
+;;; Copyright © 2014-2017, 2019, 2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2021 Maxime Devos <maximedevos <at> 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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 15:17:02 GMT) Full text and rfc822 format available.

Message #14 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 04/14] import: utils: 'call-with-networking-exception-handler'
 doesn't unwind.
Date: Thu, 18 May 2023 17:16:12 +0200
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





Information forwarded to lars <at> 6xq.net, jgart <at> dismail.de, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 15:17:03 GMT) Full text and rfc822 format available.

Message #17 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 03/14] tests: pypi: Rewrite tests using a local HTTP server.
Date: Thu, 18 May 2023 17:16:11 +0200
* 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 ...)))
+
 
 (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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 15:17:03 GMT) Full text and rfc822 format available.

Message #20 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 05/14] import: json: Add #:timeout to 'json-fetch'.
Date: Thu, 18 May 2023 17:16:13 +0200
* 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 <at> gnu.org>
 ;;; Copyright © 2015, 2016 Eric Bavier <bavier <at> member.fsf.org>
-;;; Copyright © 2018, 2019 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2018, 2019, 2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2020 Ricardo Wurmus <rekado <at> 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





Information forwarded to mail <at> cbaines.net, dev <at> jpoiret.xyz, ludo <at> gnu.org, othacehe <at> gnu.org, rekado <at> elephly.net, zimon.toutoune <at> gmail.com, me <at> tobias.gr, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 15:17:03 GMT) Full text and rfc822 format available.

Message #23 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 07/14] diagnostics: Factorize 'absolute-location'.
Date: Thu, 18 May 2023 17:16:15 +0200
* 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 <at> gnu.org>
+;;; Copyright © 2012-2021, 2023 Ludovic Courtès <ludo <at> 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)))
+
 
 (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





Information forwarded to mail <at> cbaines.net, dev <at> jpoiret.xyz, ludo <at> gnu.org, othacehe <at> gnu.org, rekado <at> elephly.net, zimon.toutoune <at> gmail.com, me <at> tobias.gr, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 15:17:04 GMT) Full text and rfc822 format available.

Message #26 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 08/14] upstream: 'update-package-source' edits input fields.
Date: Thu, 18 May 2023 17:16:16 +0200
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





Information forwarded to mail <at> cbaines.net, dev <at> jpoiret.xyz, ludo <at> gnu.org, othacehe <at> gnu.org, rekado <at> elephly.net, zimon.toutoune <at> gmail.com, me <at> tobias.gr, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 15:17:04 GMT) Full text and rfc822 format available.

Message #29 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 09/14] upstream: Remove <upstream-input-change> and related
 code.
Date: Thu, 18 May 2023 17:16:17 +0200
* 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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 15:17:05 GMT) Full text and rfc822 format available.

Message #32 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 10/14] tests: upstream: Restore test that was skipped.
Date: Thu, 18 May 2023 17:16:18 +0200
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)
 
 (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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 15:18:01 GMT) Full text and rfc822 format available.

Message #35 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 11/14] import: cpan: Remove unary 'string-append' call.
Date: Thu, 18 May 2023 17:16:19 +0200
* 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





Information forwarded to mail <at> cbaines.net, dev <at> jpoiret.xyz, lars <at> 6xq.net, ludo <at> gnu.org, othacehe <at> gnu.org, rekado <at> elephly.net, zimon.toutoune <at> gmail.com, me <at> tobias.gr, jgart <at> dismail.de, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 15:18:02 GMT) Full text and rfc822 format available.

Message #38 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 06/14] upstream: Replace 'input-changes' field by 'inputs'.
Date: Thu, 18 May 2023 17:16:14 +0200
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 <at> elephly.net>
-;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2015-2017, 2019-2021, 2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe <at> gmail.com>
 ;;; Copyright © 2020 Martin Becze <mjbecze <at> riseup.net>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian <at> 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 <at> mgsn.dev>
 ;;; Copyright © 2019 Simon Tournier <zimon.toutoune <at> gmail.com>
 ;;; Copyright © 2022 Hartmut Goebel <h.goebel <at> crazy-compilers.com>
+;;; Copyright © 2023 Ludovic Courtès <ludo <at> 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 <at> gnu.org>
 ;;; Copyright © 2015 Cyril Roelandt <tipecaml <at> gmail.com>
-;;; Copyright © 2015-2017, 2019-2022 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2015-2017, 2019-2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe <at> gmail.com>
 ;;; Copyright © 2018, 2023 Ricardo Wurmus <rekado <at> elephly.net>
 ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer <at> 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 <at> gnu.org>
+;;; Copyright © 2013-2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita <at> karetnikov.org>
 ;;; Copyright © 2014 Eric Bavier <bavier <at> member.fsf.org>
 ;;; Copyright © 2015 Alex Kost <alezost <at> 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 <at> gnu.org>
+;;; Copyright © 2010-2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2015 Alex Kost <alezost <at> gmail.com>
 ;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado <at> elephly.net>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian <at> 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 <at> gnu.org>
+;;; Copyright © 2016, 2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2022 Ricardo Wurmus <rekado <at> 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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 15:18:02 GMT) Full text and rfc822 format available.

Message #41 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 13/14] import: cpan: Updater provides input list.
Date: Thu, 18 May 2023 17:16:21 +0200
* 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





Information forwarded to andrew <at> trop.in, liliana.prikler <at> gmail.com, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 15:18:03 GMT) Full text and rfc822 format available.

Message #44 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 14/14] import: elpa: Updater provides input list.
Date: Thu, 18 May 2023 17:16:22 +0200
* 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 <at> fbengineering.ch>
-;;; Copyright © 2020 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2020, 2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2020 Martin Becze <mjbecze <at> riseup.net>
 ;;; Copyright © 2021 Xinglu Chen <public <at> 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"))])))
 
+
 (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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 15:18:04 GMT) Full text and rfc822 format available.

Message #47 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 12/14] import: cpan: Represent dependencies as
 <upstream-input> records.
Date: Thu, 18 May 2023 17:16:20 +0200
* 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 <at> netris.org>
 ;;; Copyright © 2016 Alex Sassmannshausen <alex <at> pompo.co>
 ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me <at> tobias.gr>
-;;; Copyright © 2020, 2021 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2020, 2021, 2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2022 Hartmut Goebel <h.goebel <at> 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 <at> member.fsf.org>
 ;;; Copyright © 2016 Alex Sassmannshausen <alex <at> pompo.co>
-;;; Copyright © 2020 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2020, 2023 Ludovic Courtès <ludo <at> 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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 16:02:03 GMT) Full text and rfc822 format available.

Message #50 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Liliana Marie Prikler <liliana.prikler <at> gmail.com>
To: Ludovic Courtès <ludo <at> gnu.org>, 63571 <at> debbugs.gnu.org
Cc: Andrew Tropin <andrew <at> trop.in>
Subject: Re: [bug#63571] [PATCH 00/14] 'guix refresh -u' updates input fields
Date: Thu, 18 May 2023 18:01:29 +0200
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




Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Thu, 18 May 2023 17:04:02 GMT) Full text and rfc822 format available.

Message #53 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: Liliana Marie Prikler <liliana.prikler <at> gmail.com>
Cc: 63571 <at> debbugs.gnu.org, Andrew Tropin <andrew <at> trop.in>
Subject: Re: bug#63571: [PATCH 00/14] 'guix refresh -u' updates input fields
Date: Thu, 18 May 2023 19:02:54 +0200
Hi,

Liliana Marie Prikler <liliana.prikler <at> 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’.




Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:45:02 GMT) Full text and rfc822 format available.

Message #56 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Subject: Re: bug#63571: [PATCH 00/14] 'guix refresh -u' updates input fields
Date: Mon, 29 May 2023 16:44:08 +0200
Hi!

Ludovic Courtès <ludo <at> 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’.




Information forwarded to lars <at> 6xq.net, jgart <at> dismail.de, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:46:02 GMT) Full text and rfc822 format available.

Message #59 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 01/19] tests: pypi: Factorize tarball and wheel file
 creation.
Date: Mon, 29 May 2023 16:45:12 +0200
* 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))
+
 
 (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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:46:02 GMT) Full text and rfc822 format available.

Message #62 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 02/19] tests: http: Allow responses to specify a path.
Date: Mon, 29 May 2023 16:45:13 +0200
* 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 <at> gnu.org>
+;;; Copyright © 2014-2017, 2019, 2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2021 Maxime Devos <maximedevos <at> 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





Information forwarded to lars <at> 6xq.net, jgart <at> dismail.de, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:01 GMT) Full text and rfc822 format available.

Message #65 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 03/19] tests: pypi: Rewrite tests using a local HTTP server.
Date: Mon, 29 May 2023 16:45:14 +0200
* 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 ...)))
+
 
 (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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:02 GMT) Full text and rfc822 format available.

Message #68 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 04/19] import: utils:
 'call-with-networking-exception-handler' doesn't unwind.
Date: Mon, 29 May 2023 16:45:15 +0200
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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:02 GMT) Full text and rfc822 format available.

Message #71 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 05/19] import: json: Add #:timeout to 'json-fetch'.
Date: Mon, 29 May 2023 16:45:16 +0200
* 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 <at> gnu.org>
 ;;; Copyright © 2015, 2016 Eric Bavier <bavier <at> member.fsf.org>
-;;; Copyright © 2018, 2019 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2018, 2019, 2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2020 Ricardo Wurmus <rekado <at> 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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:03 GMT) Full text and rfc822 format available.

Message #74 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 06/19] doc: Mention 'guix refresh -u' for third-party
 channels.
Date: Mon, 29 May 2023 16:45:17 +0200
* 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





Information forwarded to mail <at> cbaines.net, dev <at> jpoiret.xyz, ludo <at> gnu.org, othacehe <at> gnu.org, rekado <at> elephly.net, zimon.toutoune <at> gmail.com, me <at> tobias.gr, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:03 GMT) Full text and rfc822 format available.

Message #77 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 08/19] diagnostics: Factorize 'absolute-location'.
Date: Mon, 29 May 2023 16:45:19 +0200
* 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 <at> gnu.org>
+;;; Copyright © 2012-2021, 2023 Ludovic Courtès <ludo <at> 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)))
+
 
 (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





Information forwarded to mail <at> cbaines.net, dev <at> jpoiret.xyz, ludo <at> gnu.org, othacehe <at> gnu.org, rekado <at> elephly.net, zimon.toutoune <at> gmail.com, me <at> tobias.gr, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:04 GMT) Full text and rfc822 format available.

Message #80 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 09/19] upstream: 'update-package-source' edits input fields.
Date: Mon, 29 May 2023 16:45:20 +0200
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





Information forwarded to mail <at> cbaines.net, dev <at> jpoiret.xyz, lars <at> 6xq.net, ludo <at> gnu.org, othacehe <at> gnu.org, rekado <at> elephly.net, zimon.toutoune <at> gmail.com, me <at> tobias.gr, jgart <at> dismail.de, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:04 GMT) Full text and rfc822 format available.

Message #83 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 07/19] upstream: Replace 'input-changes' field by 'inputs'.
Date: Mon, 29 May 2023 16:45:18 +0200
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 <at> elephly.net>
-;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2015-2017, 2019-2021, 2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe <at> gmail.com>
 ;;; Copyright © 2020 Martin Becze <mjbecze <at> riseup.net>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian <at> 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 <at> mgsn.dev>
 ;;; Copyright © 2019 Simon Tournier <zimon.toutoune <at> gmail.com>
 ;;; Copyright © 2022 Hartmut Goebel <h.goebel <at> crazy-compilers.com>
+;;; Copyright © 2023 Ludovic Courtès <ludo <at> 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 <at> gnu.org>
 ;;; Copyright © 2015 Cyril Roelandt <tipecaml <at> gmail.com>
-;;; Copyright © 2015-2017, 2019-2022 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2015-2017, 2019-2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe <at> gmail.com>
 ;;; Copyright © 2018, 2023 Ricardo Wurmus <rekado <at> elephly.net>
 ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer <at> 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 <at> gnu.org>
+;;; Copyright © 2013-2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita <at> karetnikov.org>
 ;;; Copyright © 2014 Eric Bavier <bavier <at> member.fsf.org>
 ;;; Copyright © 2015 Alex Kost <alezost <at> 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 <at> gnu.org>
+;;; Copyright © 2010-2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2015 Alex Kost <alezost <at> gmail.com>
 ;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado <at> elephly.net>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian <at> 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 <at> gnu.org>
+;;; Copyright © 2016, 2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2022 Ricardo Wurmus <rekado <at> 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





Information forwarded to mail <at> cbaines.net, dev <at> jpoiret.xyz, ludo <at> gnu.org, othacehe <at> gnu.org, rekado <at> elephly.net, zimon.toutoune <at> gmail.com, me <at> tobias.gr, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:05 GMT) Full text and rfc822 format available.

Message #86 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 10/19] upstream: Remove <upstream-input-change> and related
 code.
Date: Mon, 29 May 2023 16:45:21 +0200
* 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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:05 GMT) Full text and rfc822 format available.

Message #89 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 11/19] tests: upstream: Restore test that was skipped.
Date: Mon, 29 May 2023 16:45:22 +0200
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)
 
 (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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:06 GMT) Full text and rfc822 format available.

Message #92 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 12/19] import: cpan: Remove unary 'string-append' call.
Date: Mon, 29 May 2023 16:45:23 +0200
* 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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:06 GMT) Full text and rfc822 format available.

Message #95 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 13/19] import: cpan: Represent dependencies as
 <upstream-input> records.
Date: Mon, 29 May 2023 16:45:24 +0200
* 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 <at> netris.org>
 ;;; Copyright © 2016 Alex Sassmannshausen <alex <at> pompo.co>
 ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me <at> tobias.gr>
-;;; Copyright © 2020, 2021 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2020, 2021, 2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2022 Hartmut Goebel <h.goebel <at> 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 <at> member.fsf.org>
 ;;; Copyright © 2016 Alex Sassmannshausen <alex <at> pompo.co>
-;;; Copyright © 2020 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2020, 2023 Ludovic Courtès <ludo <at> 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





Information forwarded to guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:07 GMT) Full text and rfc822 format available.

Message #98 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 14/19] import: cpan: Updater provides input list.
Date: Mon, 29 May 2023 16:45:25 +0200
* 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





Information forwarded to andrew <at> trop.in, liliana.prikler <at> gmail.com, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:07 GMT) Full text and rfc822 format available.

Message #101 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 15/19] import: elpa: Updater provides input list.
Date: Mon, 29 May 2023 16:45:26 +0200
* 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 <at> fbengineering.ch>
-;;; Copyright © 2020 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2020, 2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2020 Martin Becze <mjbecze <at> riseup.net>
 ;;; Copyright © 2021 Xinglu Chen <public <at> 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"))])))
 
+
 (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





Information forwarded to mail <at> cbaines.net, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:08 GMT) Full text and rfc822 format available.

Message #104 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 16/19] import: gem: Factorize "bundler" special case for
 name mapping.
Date: Mon, 29 May 2023 16:45:27 +0200
* 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





Information forwarded to mail <at> cbaines.net, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:08 GMT) Full text and rfc822 format available.

Message #107 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 17/19] import: gem: Updater provides input list.
Date: Mon, 29 May 2023 16:45:28 +0200
* 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 <at> gnu.org>
 ;;; Copyright © 2016 Ben Woodcroft <donttrustben <at> gmail.com>
 ;;; Copyright © 2018 Oleg Pykhalov <go.wigust <at> gmail.com>
-;;; Copyright © 2020, 2021 Ludovic Courtès <ludo <at> gnu.org>
+;;; Copyright © 2020, 2021, 2023 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2020 Martin Becze <mjbecze <at> riseup.net>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian <at> mgsn.dev>
 ;;; Copyright © 2022 Taiju HIGASHI <higashi <at> 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 <at> gmail.com>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian <at> mgsn.dev>
 ;;; Copyright © 2022 Taiju HIGASHI <higashi <at> taiju.info>
+;;; Copyright © 2023 Ludovic Courtès <ludo <at> 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





Information forwarded to mail <at> cbaines.net, dev <at> jpoiret.xyz, ludo <at> gnu.org, othacehe <at> gnu.org, rekado <at> elephly.net, zimon.toutoune <at> gmail.com, me <at> tobias.gr, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:08 GMT) Full text and rfc822 format available.

Message #110 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 18/19] upstream: Honor package properties for ignored and
 extra inputs.
Date: Mon, 29 May 2023 16:45:29 +0200
* 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





Information forwarded to rekado <at> elephly.net, guix-patches <at> gnu.org:
bug#63571; Package guix-patches. (Mon, 29 May 2023 14:47:09 GMT) Full text and rfc822 format available.

Message #113 received at 63571 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2 19/19] gnu: Add updater input properties for R and Python
 packages.
Date: Mon, 29 May 2023 16:45:30 +0200
* 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





Reply sent to Ludovic Courtès <ludo <at> gnu.org>:
You have taken responsibility. (Wed, 31 May 2023 21:55:01 GMT) Full text and rfc822 format available.

Notification sent to Ludovic Courtès <ludo <at> gnu.org>:
bug acknowledged by developer. (Wed, 31 May 2023 21:55:01 GMT) Full text and rfc822 format available.

Message #118 received at 63571-done <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 63571-done <at> debbugs.gnu.org
Subject: Re: bug#63571: [PATCH 00/14] 'guix refresh -u' updates input fields
Date: Wed, 31 May 2023 23:54:14 +0200
Ludovic Courtès <ludo <at> 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’.




bug archived. Request was from Debbugs Internal Request <help-debbugs <at> gnu.org> to internal_control <at> debbugs.gnu.org. (Thu, 29 Jun 2023 11:24:08 GMT) Full text and rfc822 format available.

This bug report was last modified 273 days ago.

Previous Next


GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.