diff options
| -rw-r--r-- | guix/upstream.scm | 12 | ||||
| -rw-r--r-- | tests/upstream.scm | 21 |
2 files changed, 32 insertions, 1 deletions
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 @@ url-predicate url-prefix-predicate coalesce-sources + preferred-upstream-source upstream-updater upstream-updater? @@ -445,6 +446,17 @@ is no signature. Return #f and #f when this is not applicable." (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 @@ #: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 @@ (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) |