[bug#75137] [PATCH 3/4] upstream: Define ‘preferred-upstream-source’.

[Ludovic Courtès]

* guix/upstream.scm (preferred-upstream-source): New procedure.
* tests/upstream.scm ("preferred-upstream-source"): New test.

Change-Id: I4b48b44f1aa233d2e99bfe2e1359a670297efae8
---
 guix/upstream.scm  | 12 ++++++++++++
 tests/upstream.scm | 21 ++++++++++++++++++++-
 2 files changed, 32 insertions(+), 1 deletion(-)

diff --git a/guix/upstream.scm b/guix/upstream.scm
index a6659c3b14..19c5efc21b 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -76,6 +76,7 @@ (define-module (guix upstream)
             url-predicate
             url-prefix-predicate
             coalesce-sources
+            preferred-upstream-source
 
             upstream-updater
             upstream-updater?
@@ -445,6 +446,17 @@ (define (preferred-upstream-source-url source package)
            (or (upstream-source-signature-urls source)
                (circular-list #f)))))
 
+(define (preferred-upstream-source source package)
+  "Return a variant of SOURCE that uses the same archive type as PACKAGE's
+source (gz, xz, zst, etc.).  Return SOURCE if this is not applicable."
+  (let ((url signature-url (preferred-upstream-source-url source package)))
+    (if url
+        (upstream-source
+         (inherit source)
+         (urls (list url))
+         (signature-urls (and=> signature-url list)))
+        source)))
+
 (define* (package-update/url-fetch store package source
                                    #:key key-download key-server)
   "Return the version, tarball, and SOURCE, to update PACKAGE to
diff --git a/tests/upstream.scm b/tests/upstream.scm
index a94bb66068..c75ab091e5 100644
--- a/tests/upstream.scm
+++ b/tests/upstream.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2023-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -26,6 +26,7 @@ (define-module (test-upstream)
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix upstream)
   #:use-module (guix tests)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 match))
 
@@ -55,4 +56,22 @@ (define-module (test-upstream)
                                 (signature-urls
                                  '("ftp://example.org/foo-1.tar.xz.sig";)))))))
 
+(test-equal "preferred-upstream-source"
+  '(("http://example.org/foo-2.0.tar.xz";)
+    ("http://example.org/foo-2.0.tar.xz.sig";))
+  (let* ((package (dummy-package
+                   "foo"
+                   (version "1.0")
+                   (source
+                    (dummy-origin (uri "http://example.org/foo-1.0.tar.xz";)))))
+         (source (upstream-source
+                  (package "foo")
+                  (version "2.0")
+                  (urls '("http://example.org/foo-2.0.tar.gz";
+                          "http://example.org/foo-2.0.tar.xz";))
+                  (signature-urls (map (cut string-append <> ".sig") urls))))
+         (preferred (preferred-upstream-source source package)))
+    (list (upstream-source-urls preferred)
+          (upstream-source-signature-urls preferred))))
+
 (test-end)
-- 
2.46.0