[bug#75137] [PATCH 0/4] 'package-with-upstream-version' can preserve archive type

[bug#75137] [PATCH 0/4] 'package-with-upstream-version' can preserve archive type

[Ludovic Courtès]

Hello,

This fixes a discrepancy observed in:

  https://ci.guix.gnu.org/jobset/security-updates

For ‘xorg-server’, ‘package-with-upstream-version’ would pick the
tar.gz file, whereas running ‘guix refresh -u xorg-server’ would
pick the tar.xz file since the package definition already uses
a tar.xz file.

Ludo’.

Ludovic Courtès (4):
  upstream: Switch to SRFI-71.
  upstream: Extract ‘preferred-upstream-source-url’.
  upstream: Define ‘preferred-upstream-source’.
  transformations: ‘package-with-upstream-version’ can preserve archive
    type.

 guix/transformations.scm | 44 ++++++++++++++++++--------------
 guix/upstream.scm        | 55 +++++++++++++++++++++++++---------------
 tests/upstream.scm       | 21 ++++++++++++++-
 3 files changed, 80 insertions(+), 40 deletions(-)


base-commit: e4bdd464ebb49f4e698e5105f70b29688fff9475
-- 
2.46.0

[bug#75137] [PATCH 1/4] upstream: Switch to SRFI-71.

[Ludovic Courtès]

* guix/upstream.scm (download-tarball, package-update/url-fetch): Use
SRFI-71 instead of SRFI-11.

Change-Id: Ic7ca79b8e1248d01fd48a07faad3a6fa6a1d0c5f
---
 guix/upstream.scm | 35 ++++++++++++++++-------------------
 1 file changed, 16 insertions(+), 19 deletions(-)

diff --git a/guix/upstream.scm b/guix/upstream.scm
index 0593c363aa..d680199578 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -44,7 +44,6 @@ (define-module (guix upstream)
   #:use-module (guix monads)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -339,12 +338,11 @@ (define* (download-tarball store url signature-url
                              (mbegin %store-monad
                                (built-derivations (list drv))
                                (return (derivation->output-path drv))))))))
-          (let-values (((status data)
-                        (if sig
-                            (gnupg-verify* sig data
-                                           #:server key-server
-                                           #:key-download key-download)
-                            (values 'missing-signature data))))
+          (let ((status data (if sig
+                                 (gnupg-verify* sig data
+                                                #:server key-server
+                                                #:key-download key-download)
+                                 (values 'missing-signature data))))
             (match status
               ('valid-signature
                tarball)
@@ -438,18 +436,17 @@ (define* (package-update/url-fetch store package source
 SOURCE, an <upstream-source>."
   (match source
     (($ <upstream-source> _ version urls signature-urls)
-     (let*-values (((archive-type)
-                    (package-archive-type package))
-                   ((url signature-url)
-                    ;; Try to find a URL that matches ARCHIVE-TYPE.
-                    (find2 (lambda (url sig-url)
-                             ;; Some URIs lack a file extension, like
-                             ;; 'https://crates.io/???/0.1/download'.  In that
-                             ;; case, pick the first URL.
-                             (or (not archive-type)
-                                 (string-suffix? archive-type url)))
-                           urls
-                           (or signature-urls (circular-list #f)))))
+     (let* ((archive-type (package-archive-type package))
+            (url signature-url
+                 ;; Try to find a URL that matches ARCHIVE-TYPE.
+                 (find2 (lambda (url sig-url)
+                          ;; Some URIs lack a file extension, like
+                          ;; 'https://crates.io/???/0.1/download'.  In that
+                          ;; case, pick the first URL.
+                          (or (not archive-type)
+                              (string-suffix? archive-type url)))
+                        urls
+                        (or signature-urls (circular-list #f)))))
        ;; If none of URLS matches ARCHIVE-TYPE, then URL is #f; in that case,
        ;; pick up the first element of URLS.
        (let ((tarball (download-tarball store
-- 
2.46.0

[bug#75137] [PATCH 2/4] upstream: Extract ‘preferred-upstream-source-url’.

[Ludovic Courtès]

* guix/upstream.scm (preferred-upstream-source-url): New procedure.
(package-update/url-fetch): Use it.

Change-Id: I229cdf7668567e30ca156b3d65b77c90ead8bb05
---
 guix/upstream.scm | 30 ++++++++++++++++++------------
 1 file changed, 18 insertions(+), 12 deletions(-)

diff --git a/guix/upstream.scm b/guix/upstream.scm
index d680199578..a6659c3b14 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2019, 2022-2024 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
@@ -430,23 +430,29 @@ (define (package-archive-type package)
                 (string-contains extension "tar"))
             extension)))))
 
+(define (preferred-upstream-source-url source package)
+  "Return two values: a source URL that matches the archive type of
+PACKAGE (gz, xz, bz2, etc.) and the corresponding signature URL or #f if there
+is no signature.  Return #f and #f when this is not applicable."
+  (let ((archive-type (package-archive-type package)))
+    (find2 (lambda (url sig-url)
+             ;; Some URIs lack a file extension, like
+             ;; 'https://crates.io/???/0.1/download'.  In that case, pick the
+             ;; first URL.
+             (or (not archive-type)
+                 (string-suffix? archive-type url)))
+           (upstream-source-urls source)
+           (or (upstream-source-signature-urls source)
+               (circular-list #f)))))
+
 (define* (package-update/url-fetch store package source
                                    #:key key-download key-server)
   "Return the version, tarball, and SOURCE, to update PACKAGE to
 SOURCE, an <upstream-source>."
   (match source
     (($ <upstream-source> _ version urls signature-urls)
-     (let* ((archive-type (package-archive-type package))
-            (url signature-url
-                 ;; Try to find a URL that matches ARCHIVE-TYPE.
-                 (find2 (lambda (url sig-url)
-                          ;; Some URIs lack a file extension, like
-                          ;; 'https://crates.io/???/0.1/download'.  In that
-                          ;; case, pick the first URL.
-                          (or (not archive-type)
-                              (string-suffix? archive-type url)))
-                        urls
-                        (or signature-urls (circular-list #f)))))
+     (let ((url signature-url
+                (preferred-upstream-source-url source package)))
        ;; If none of URLS matches ARCHIVE-TYPE, then URL is #f; in that case,
        ;; pick up the first element of URLS.
        (let ((tarball (download-tarball store
-- 
2.46.0

[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

[bug#75137] [PATCH 4/4] transformations: ‘package-with-upstream-version’ can preserve archive type.

[Ludovic Courtès]

Fixes a discrepancy for ‘url-fetch’ packages where upstream provides
several source tarballs.  For example, for ‘xorg-server’,
‘package-with-upstream-version’ would pick the “tar.gz” tarball even
though the package definition uses “tar.xz”.  It now picks “tar.xz” by
default.

* guix/transformations.scm (package-with-upstream-version):
Add #:preserve-archive-type?.  Call ‘preferred-upstream-source’ to honor
it.

Change-Id: Iefa007aba339d81709faf82b7c52a5a2c7a6aad7
---
 guix/transformations.scm | 44 +++++++++++++++++++++++-----------------
 1 file changed, 25 insertions(+), 19 deletions(-)

diff --git a/guix/transformations.scm b/guix/transformations.scm
index 131b8564f8..2887d91a34 100644
--- a/guix/transformations.scm
+++ b/guix/transformations.scm
@@ -33,6 +33,7 @@ (define-module (guix transformations)
   #:autoload   (guix git) (git-checkout git-checkout? git-checkout-url)
   #:autoload   (guix upstream) (upstream-source
                                 package-latest-release
+                                preferred-upstream-source
                                 upstream-source-version
                                 upstream-source-signature-urls)
   #:autoload   (guix cpu) (current-cpu
@@ -865,12 +866,14 @@ (define (upstream-source-without-signatures source)
 (define* (package-with-upstream-version p #:optional version
                                         #:key
                                         (preserve-patches? #f)
-                                        (authenticate? #t))
+                                        (authenticate? #t)
+                                        (preserve-archive-type? #t))
   "Return package P changed to use the given upstream VERSION or, if VERSION
 is #f, the latest known upstream version.  When PRESERVE-PATCHES? is true,
 preserve patches and snippets found in the source of P, provided it's an
 origin.  When AUTHENTICATE? is false, disable OpenPGP signature verification
-of upstream source code."
+of upstream source code.  When PRESERVE-ARCHIVE-TYPE? is true, use the same
+archive type as P's source (gz, xz, zstd, etc.)"
   (let ((source (and=> (package-latest-release p #:version version)
                        (if authenticate?
                            identity
@@ -899,24 +902,27 @@ (define* (package-with-upstream-version p #:optional version
                       (upstream-source-version source)
                       (package-version p)))
 
-           (unless (pair? (upstream-source-signature-urls source))
-             (warning (G_ "cannot authenticate source of '~a', version ~a~%")
-                      (package-name p)
-                      (upstream-source-version source)))
+           (let ((source (if preserve-archive-type?
+                             (preferred-upstream-source source p)
+                             source)))
+             (unless (pair? (upstream-source-signature-urls source))
+               (warning (G_ "cannot authenticate source of '~a', version ~a~%")
+                        (package-name p)
+                        (upstream-source-version source)))
 
-           ;; TODO: Take 'upstream-source-input-changes' into account.
-           (package
-             (inherit p)
-             (version (upstream-source-version source))
-             (source (if (and preserve-patches?
-                              (origin? (package-source p)))
-                         ;; Inherit P's origin so snippets and patches are
-                         ;; applied as if we had run 'guix refresh -u'.
-                         (origin
-                           (inherit (package-source p))
-                           (method upstream-fetch)
-                           (uri source))
-                         source)))))))
+             ;; TODO: Take 'upstream-source-input-changes' into account.
+             (package
+               (inherit p)
+               (version (upstream-source-version source))
+               (source (if (and preserve-patches?
+                                (origin? (package-source p)))
+                           ;; Inherit P's origin so snippets and patches are
+                           ;; applied as if we had run 'guix refresh -u'.
+                           (origin
+                             (inherit (package-source p))
+                             (method upstream-fetch)
+                             (uri source))
+                           source))))))))
 
 (define (transform-package-latest specs)
   "Return a procedure that rewrites package graphs such that those in SPECS
-- 
2.46.0