[bug#65230] [PATCH 00/13] Fix 'guix refresh' for Qt and other packages

[bug#65230] [PATCH 00/13] Fix 'guix refresh' for Qt and other packages

[Maxim Cournoyer]

Hi,

This series improves our generic HTML updater, so that it knows to update
packages using a mirror:// URL, or which URL contains versioned items in its
path.  With a trivial change to the release-file? procedure, this enables the
automatic updates of our many Qt packages.

Thanks,

Maxim Cournoyer (13):
  gnu-maintenance: Make base-url argument of import-html-release
    required.
  download: Add mirrors for Qt.
  gnu: qt: Streamline qt-urls.
  gnu: qt-creator: Use mirror://qt for source URI.
  gnu-maintenance: Fix docstring.
  gnu-maintenance: Extract url->links procedure.
  gnu-maintenance: Fix indentation.
  gnu-maintenance: Accept package object in 'import-html-release'
    procedure.
  gnu-maintenance: Document nested procedures in 'import-html-release'.
  gnu-maintenance: Extract 'canonicalize-url' from
    'import-html-release'.
  gnu-maintenance: Add support to rewrite version in URL path.
  gnu-maintenance: Allow mirror URLs to fallback to the generic HTML
    updater.
  gnu-maintenance: Consider Qt source tarballs as "release files".

 gnu/packages/qt.scm       | 126 +++++++--------
 guix/download.scm         |  14 +-
 guix/gnu-maintenance.scm  | 325 ++++++++++++++++++++++++++------------
 tests/gnu-maintenance.scm |  47 +++++-
 4 files changed, 338 insertions(+), 174 deletions(-)


base-commit: 77251c5f5af193dcd031dffef744001cfc48f7e5
-- 
2.41.0

[bug#65230] [PATCH 01/13] gnu-maintenance: Make base-url argument of import-html-release required.

[Maxim Cournoyer]

It doesn't make sense to have it default to something like
"https://kernel.org/pub"; it should always be provided explicitly.

* guix/gnu-maintenance.scm (import-html-release) <#:base-url>: Turn keyword
argument into a positional argument.  Update doc.
* guix/gnu-maintenance.scm (import-savannah-release): Adjust call accordingly.
(import-kernel.org-release): Likewise.
(import-html-updatable-release): Likewise.
---

 guix/gnu-maintenance.scm | 18 +++++++-----------
 1 file changed, 7 insertions(+), 11 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 32712f7218..b95a45824e 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -483,15 +483,14 @@ (define (html-links sxml)
       (_
        links))))
 
-(define* (import-html-release package
+(define* (import-html-release base-url package
                               #:key
                               (version #f)
-                              (base-url "https://kernel.org/pub")
                               (directory (string-append "/" package))
                               file->signature)
-  "Return an <upstream-source> for the latest release of PACKAGE (a string) on
-SERVER under DIRECTORY, or #f. Optionally include a VERSION string to fetch a
-specific version.
+  "Return an <upstream-source> for the latest release of PACKAGE (a string)
+under DIRECTORY at BASE-URL, or #f. Optionally include a VERSION string to
+fetch a specific version.
 
 BASE-URL should be the URL of an HTML page, typically a directory listing as
 found on 'https://kernel.org/pub'.
@@ -730,9 +729,8 @@ (define* (import-savannah-release package #:key (version #f))
          (directory (dirname (uri-path uri))))
     ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
     ;; or whichever detached signature naming scheme PACKAGE uses.
-    (import-html-release package
+    (import-html-release %savannah-base package
                          #:version version
-                         #:base-url %savannah-base
                          #:directory directory)))
 
 (define* (latest-sourceforge-release package #:key (version #f))
@@ -824,9 +822,8 @@ (define* (import-kernel.org-release package #:key (version #f))
                        ((uri mirrors ...) uri))))
          (package   (package-upstream-name package))
          (directory (dirname (uri-path uri))))
-    (import-html-release package
+    (import-html-release %kernel.org-base package
                          #:version version
-                         #:base-url %kernel.org-base
                          #:directory directory
                          #:file->signature file->signature)))
 
@@ -870,9 +867,8 @@ (define* (import-html-updatable-release package #:key (version #f))
                         (dirname (uri-path uri))))
          (package   (package-upstream-name package)))
     (false-if-networking-error
-     (import-html-release package
+     (import-html-release base package
                           #:version version
-                          #:base-url base
                           #:directory directory))))
 
 (define %gnu-updater

base-commit: 77251c5f5af193dcd031dffef744001cfc48f7e5
-- 
2.41.0

[bug#65230] [PATCH 02/13] download: Add mirrors for Qt.

[Maxim Cournoyer]

* guix/download.scm (%mirrors): Augment with qt mirrors.
---

 guix/download.scm | 10 +++++++++-
 1 file changed, 9 insertions(+), 1 deletion(-)

diff --git a/guix/download.scm b/guix/download.scm
index 30d7c5a86e..d5da866179 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -358,7 +358,15 @@ (define %mirrors
        "https://mirror.esc7.net/pub/OpenBSD/")
       (mate
        "https://pub.mate-desktop.org/releases/"
-       "http://pub.mate-desktop.org/releases/"))))
+       "http://pub.mate-desktop.org/releases/")
+      (qt
+       "https://download.qt.io/official_releases/"
+       "https://ftp.jaist.ac.jp/pub/qtproject/official_releases/"
+       "https://ftp.nluug.nl/languages/qt/official_releases/"
+       "https://mirrors.cloud.tencent.com/qt/official_releases/"
+       "https://mirrors.sjtug.sjtu.edu.cn/qt/official_releases/"
+       "https://qtproject.mirror.liquidtelecom.com/official_releases/"
+       "https://mirrors.ocf.berkeley.edu/qt/official_releases/"))))
 
 (define %mirror-file
   ;; Copy of the list of mirrors to a file.  This allows us to keep a single
-- 
2.41.0

[bug#65230] [PATCH 03/13] gnu: qt: Streamline qt-urls.

[Maxim Cournoyer]

* gnu/packages/qt.scm (qt-urls): Rename to...
(qt-url): ... this.  Return a single URL built using the mirror:// scheme.
Adjust all callers accordingly.
---

 gnu/packages/qt.scm | 124 +++++++++++++++++++++-----------------------
 1 file changed, 58 insertions(+), 66 deletions(-)

diff --git a/gnu/packages/qt.scm b/gnu/packages/qt.scm
index 1184a85938..b73acef3c5 100644
--- a/gnu/packages/qt.scm
+++ b/gnu/packages/qt.scm
@@ -124,6 +124,7 @@ (define-module (gnu packages qt)
   #:use-module (gnu packages xiph)
   #:use-module (gnu packages xorg)
   #:use-module (gnu packages xml)
+  #:use-module (ice-9 match)
   #:use-module (srfi srfi-1))
 
 (define %qt-version "5.15.8")
@@ -315,27 +316,18 @@ (define-public grantlee
 system, and the core design of Django is reused in Grantlee.")
     (license license:lgpl2.1+)))
 
-(define (qt-urls component version)
-  "Return a list of URLs for VERSION of the Qt5 COMPONENT."
+(define (qt-url component version)
+  "Return a mirror URL for the Qt5 COMPONENT at VERSION."
   ;; We can't use a mirror:// scheme because these URLs are not exact copies:
   ;; the layout differs between them.
-  (list (string-append "https://download.qt.io/official_releases/qt/"
-                       (version-major+minor version) "/" version
-                       "/submodules/" component "-everywhere-opensource-src-"
-                       version ".tar.xz")
-        (string-append "https://download.qt.io/official_releases/qt/"
-                       (version-major+minor version) "/" version
-                       "/submodules/" component "-everywhere-src-"
-                       version ".tar.xz")
-        (string-append "https://download.qt.io/archive/qt/"
-                       (version-major+minor version) "/" version
-                       "/submodules/" component "-everywhere-opensource-src-"
-                       version ".tar.xz")
-        (let ((directory (string-append "qt5" (string-drop component 2))))
-          (string-append "http://sources.buildroot.net/" directory "/"
-                         component "-everywhere-opensource-src-" version ".tar.xz"))
-        (string-append "https://distfiles.macports.org/qt5/"
-                       component "-everywhere-opensource-src-" version ".tar.xz")))
+  (let ((x (match (version-major version)
+             ("5" "-everywhere-opensource-src-")
+             ;; Version 6 and later dropped 'opensource' from the archive
+             ;; names.
+             (_ "-everywhere-src-"))))
+    (string-append "mirror://qt/qt/"
+                   (version-major+minor version) "/" version
+                   "/submodules/" component x version ".tar.xz")))
 
 (define-public qtbase-5
   (package
@@ -343,7 +335,7 @@ (define-public qtbase-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "175ynjndpzsw69vnsq4swykn9f48568ww9b4z3yw7azkqwk13cdz"))
@@ -596,7 +588,7 @@ (define-public qtbase
     (version "6.3.2")
     (source (origin
               (inherit (package-source qtbase-5))
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "19m9r8sf9mvyrwipn44if3nhding4ljys2mwf04b7dkhz16vlabr"))
@@ -899,7 +891,7 @@ (define-public qt3d-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "18hbv4l9w0czaxcch6af9130fgs4sf400xp0pfzl81c78fwrkfsb"))))
@@ -961,7 +953,7 @@ (define-public qt5compat
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1k30hnwnlbay1hnkdavgf6plsdzrryzcqd2qz8x11r477w7sr8wi"))))
@@ -991,7 +983,7 @@ (define-public qtsvg-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0qnmcvp5jap4qq9w7xak66g6fsb48q1lg02rn4lycvnhgwzblbww"))))
@@ -1059,7 +1051,7 @@ (define-public qtsvg
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "14i3f23k9k0731akpwa6zzhw5m3c0m2l5r7irvim4h4faah445ac"))))
@@ -1090,7 +1082,7 @@ (define-public qtimageformats
     (version %qt-version)
     (source (origin
              (method url-fetch)
-             (uri (qt-urls name version))
+             (uri (qt-url name version))
              (sha256
               (base32
                "0c6fq9zcw5hbkiny56wx2fbm123x14l7habydv6zhvnhn3rhwi31"))
@@ -1117,7 +1109,7 @@ (define-public qtx11extras
     (version %qt-version)
     (source (origin
              (method url-fetch)
-             (uri (qt-urls name version))
+             (uri (qt-url name version))
              (sha256
               (base32
                "1gzmf0y2byzrgfbing7xk3cwlbk1cyjlhqjbfh8n37y09gg65maf"))))
@@ -1183,7 +1175,7 @@ (define-public qtxmlpatterns
     (version %qt-version)
     (source (origin
              (method url-fetch)
-             (uri (qt-urls name version))
+             (uri (qt-url name version))
              (sha256
               (base32
                "1inf7ar32a557faqpwdsmafhz1p6k8hywpw3wbsdjlj74dkgdq35"))))
@@ -1212,7 +1204,7 @@ (define-public qtdeclarative-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1kb8nj17vmnky0ayiwypim7kf6rmlmfcjf6gnrw8rydmp61w0vh2"))))
@@ -1258,7 +1250,7 @@ (define-public qtdeclarative
     ;; TODO: Package 'masm' and unbundle from sources.
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1hbw63828pp8vm9b46i2pkcbcpr4mq9nblhmpwrw2pflq0fi24xq"))))
@@ -1390,7 +1382,7 @@ (define-public qtconnectivity
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1j6qgkg77ycwcjxnhh38i9np1z8pjsqrzvfk3zsyq07f6k563fnc"))))
@@ -1408,7 +1400,7 @@ (define-public qtwebsockets-5
     (version %qt-version)
     (source (origin
              (method url-fetch)
-             (uri (qt-urls name version))
+             (uri (qt-url name version))
              (sha256
               (base32
                "12h520lpj2pljgkyq36p1509mw4pxgb76n30d32kg52crjsk34pa"))))
@@ -1431,7 +1423,7 @@ (define-public qtwebsockets
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1smbvidaybphvsmaap9v1pbkibwmng11hb925g0ww4ghwzpxkb8q"))))
@@ -1471,7 +1463,7 @@ (define-public qtsensors
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1fdpgbikvxjacyipcyac0czqhv96pvc75dl9cyafslws8m53fm56"))))
@@ -1500,7 +1492,7 @@ (define-public qtmultimedia-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1fz0ffpckvbg6qfhab2rrzfnvh4mlalqxcn0kbkd21mi44apjirk"))
@@ -1544,7 +1536,7 @@ (define-public qtshadertools
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               ;; Note: the source bundles *patched* glslang and SPIRV-Cross
               ;; sources.
               (sha256
@@ -1573,7 +1565,7 @@ (define-public qtmultimedia
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0hqwq0ad6z8c5kyyvbaddj00mciijn2ns2r60jc3mqh98nm2js3z"))
@@ -1639,7 +1631,7 @@ (define-public qtwayland-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (patches (search-patches "qtwayland-gcc-11.patch"
                                        "qtwayland-dont-recreate-callbacks.patch"
                                        "qtwayland-cleanup-callbacks.patch"))
@@ -1689,7 +1681,7 @@ (define-public qtwayland
     (source
      (origin
        (method url-fetch)
-       (uri (qt-urls name version))
+       (uri (qt-url name version))
        (sha256
         (base32 "0rwiirkibgpvx05pg2842j4dcq9ckxmcqxhaf50xx2i55z64ll83"))))
     (build-system cmake-build-system)
@@ -1739,7 +1731,7 @@ (define-public qtserialport
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "04i8pdyml1sw4dkk9vyw2xy5bz3fp6f90fws7ag5y8iizfgs5v2v"))))
@@ -1770,7 +1762,7 @@ (define-public qtserialbus
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0ws3pjbp4g8f49k8q0qa5hgyisbyk3m7kl8pwzkfws048glvz570"))))
@@ -1797,7 +1789,7 @@ (define-public qtwebchannel-5
     (version %qt-version)
     (source (origin
              (method url-fetch)
-             (uri (qt-urls name version))
+             (uri (qt-url name version))
              (sha256
               (base32
                "1pfmy6fqis47awjb590r63y13vvsfm0fq70an3ylsknhyq3firgn"))))
@@ -1815,7 +1807,7 @@ (define-public qtwebchannel
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0gqm09yqdq27kgb02idx5ycj14k5mjhh10ddp9jfs8lblimlgfni"))))
@@ -1853,7 +1845,7 @@ (define-public qtwebglplugin
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1gvzhgfn55kdp5g11fg5yja5xb6wghx5sfc8vfp8zzpxnak7pbn1"))))
@@ -1882,7 +1874,7 @@ (define-public qtwebview
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1b03dzlff840n2i53r105c7sv91ivwzxn7ldpgnhiyrhr897i9kj"))))
@@ -1900,7 +1892,7 @@ (define-public qtlocation
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0r16qxy0pfpwvna4gpz67jk3qv3qizfd659kc9iwdh8bhz7lpjrw"))))
@@ -1924,7 +1916,7 @@ (define-public qtlottie
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1c092hmf114r8jfdhkhxnn3vywj93mg33whzav47gr9mbza44icq"))))
@@ -1957,7 +1949,7 @@ (define-public qttools-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1i79fwsn799x3n3jidp3f4gz9d5vi9gg6p8g8lbswb832gggigm3"))))
@@ -1977,7 +1969,7 @@ (define-public qttools
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1lmfk5bhgg4daxkqrhmx4iyln7pyiz40c9cp6plyp35nz8ppvc75"))))
@@ -2017,7 +2009,7 @@ (define-public qttranslations
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1h66n9cx4g65c9wrgp32h9gm3r47gyh1nrcn3ivbfbvngfawqxpg"))))
@@ -2039,7 +2031,7 @@ (define-public qtscript
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0rjj1pn0fwdq0qz0nzisxza671ywfrq5cv6iplywfyflh7q4dmcs"))
@@ -2058,7 +2050,7 @@ (define-public qtquickcontrols-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0yp47bpkfckms76vw0hrwnzchy8iak23ih6w9pnwrnjkmbc65drc"))))
@@ -2078,7 +2070,7 @@ (define-public qtquickcontrols2-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "058dkj6272za47vnz3mxsmwsj85gxf6g0ski645fphk8s3jp2bk5"))))
@@ -2105,7 +2097,7 @@ (define-public qtgraphicaleffects
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0wypji8i19kjq18qd92z8kkd3fj2n0d5hgh6xiza96833afvibj9"))))
@@ -2128,7 +2120,7 @@ (define-public qtgamepad
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0vgxprgk7lak209wsg2ljzfkpwgjzscpbxmj5fyvvwm2pbnpspvk"))))
@@ -2154,7 +2146,7 @@ (define-public qtscxml
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "17j6npvgr8q3lyrqmvfh1n47mkhfzk18r998hcjm2w75xj46km1n"))
@@ -2181,7 +2173,7 @@ (define-public qtpositioning
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0zh45lf164nzwl1hh96qm64nyw9wzzrnm5s7sx761glz54q6l5xz"))))
@@ -2212,7 +2204,7 @@ (define-public qtpurchasing
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0bjky5ncg9yhz4a63g3jl1r5pa6i09f6g8wgzs591mhybrbmhcw8"))))
@@ -2228,7 +2220,7 @@ (define-public qtcharts
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1q11ank69l9qw3iks2svr0g2g6pzng9v8p87dpsmjs988f4ysmll"))))
@@ -2257,7 +2249,7 @@ (define-public qtdatavis3d
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1mr2kdshahxrkjs9wlgpr59jbqvyvlax16rlnca4iq00w3v5hrdh"))))
@@ -2279,7 +2271,7 @@ (define-public qtnetworkauth-5
     (version %qt-version)
     (source (origin
              (method url-fetch)
-             (uri (qt-urls name version))
+             (uri (qt-url name version))
              (sha256
               (base32
                "0fsmpjwkzzy3281shld7gs1gj217smb1f8ai63gdvnkp0jb2fhc5"))))
@@ -2294,7 +2286,7 @@ (define-public qtnetworkauth
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0mjnz87splyxq7jwydi5ws2aqb6j7czscrkns193w425x0dgy94l"))))
@@ -2314,7 +2306,7 @@ (define-public qtremoteobjects
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "099b3vchi458i4fci9kfwan871jplqlk5l8q78mfnh33g80qnasi"))))
@@ -2352,7 +2344,7 @@ (define-public qtspeech
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1q56lyj7s05sx52j5z6gcs000mni4c7mb7qyq4lfval7c06hw5p6"))))
@@ -2461,7 +2453,7 @@ (define-public qtwebengine-5
     (source
      (origin
        (method url-fetch)
-       (uri (qt-urls name version))
+       (uri (qt-url name version))
        (sha256
         (base32
          "1qv15g5anhlfsdwnjxy21vc3zxxm8149vysi774l93iab6mxqmjg"))
@@ -2789,7 +2781,7 @@ (define-public qtwebengine
     (source
      (origin
        (method url-fetch)
-       (uri (qt-urls name version))
+       (uri (qt-url name version))
        (sha256
         (base32
          "09j4w9ax8242d1yx3hmic7jcwidwdrn8sp7k89hj4l0n8mzkkd35"))
-- 
2.41.0

[bug#65230] [PATCH 04/13] gnu: qt-creator: Use mirror://qt for source URI.

[Maxim Cournoyer]

* gnu/packages/qt.scm (qt-creator) [source]: Use mirror://qt for origin URI.
---

 gnu/packages/qt.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gnu/packages/qt.scm b/gnu/packages/qt.scm
index b73acef3c5..2ca03b77d1 100644
--- a/gnu/packages/qt.scm
+++ b/gnu/packages/qt.scm
@@ -4703,7 +4703,7 @@ (define-public qt-creator
     (source (origin
               (method url-fetch)
               (uri (string-append
-                    "https://download.qt.io/official_releases/qtcreator/"
+                    "mirror://qt/qtcreator/"
                     (version-major+minor version) "/" version
                     "/qt-creator-opensource-src-" version ".tar.gz"))
               (modules '((guix build utils)))
-- 
2.41.0

[bug#65230] [PATCH 05/13] gnu-maintenance: Fix docstring.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (import-kernel.org-release): Fix docstring.
---

 guix/gnu-maintenance.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index b95a45824e..a314923d3b 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -489,7 +489,7 @@ (define* (import-html-release base-url package
                               (directory (string-append "/" package))
                               file->signature)
   "Return an <upstream-source> for the latest release of PACKAGE (a string)
-under DIRECTORY at BASE-URL, or #f. Optionally include a VERSION string to
+under DIRECTORY at BASE-URL, or #f.  Optionally include a VERSION string to
 fetch a specific version.
 
 BASE-URL should be the URL of an HTML page, typically a directory listing as
@@ -806,7 +806,7 @@ (define* (import-xorg-release package #:key (version #f))
       (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
 
 (define* (import-kernel.org-release package #:key (version #f))
-  "Return the latest release of PACKAGE, the name of a kernel.org package.
+  "Return the latest release of PACKAGE, a Linux kernel package.
 Optionally include a VERSION string to fetch a specific version."
   (define %kernel.org-base
     ;; This URL and sub-directories thereof are nginx-generated directory
-- 
2.41.0

[bug#65230] [PATCH 06/13] gnu-maintenance: Extract url->links procedure.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (url->links): New procedure.
(import-html-release): Use it.
---

 guix/gnu-maintenance.scm | 19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index a314923d3b..2e0fc3e8ab 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -483,6 +483,14 @@ (define (html-links sxml)
       (_
        links))))
 
+(define (url->links url)
+  "Return the unique links on the HTML page accessible at URL."
+  (let* ((uri   (string->uri url))
+         (port  (http-fetch/cached uri #:ttl 3600))
+         (sxml  (html->sxml port)))
+    (close-port port)
+    (delete-duplicates (html-links sxml))))
+
 (define* (import-html-release base-url package
                               #:key
                               (version #f)
@@ -499,12 +507,10 @@ (define* (import-html-release base-url package
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
 are unavailable."
-  (let* ((uri   (string->uri (if (string-null? directory)
-                                 base-url
-                                 (string-append base-url directory "/"))))
-         (port  (http-fetch/cached uri #:ttl 3600))
-         (sxml  (html->sxml port))
-         (links (delete-duplicates (html-links sxml))))
+  (let* ((url (if (string-null? directory)
+                  base-url
+                  (string-append base-url directory "/")))
+         (links (url->links url)))
     (define (file->signature/guess url)
       (let ((base (basename url)))
         (any (lambda (link)
@@ -562,7 +568,6 @@ (define* (import-html-release base-url package
     (define candidates
       (filter-map url->release links))
 
-    (close-port port)
     (match candidates
       (() #f)
       ((first . _)
-- 
2.41.0

[bug#65230] [PATCH 07/13] gnu-maintenance: Fix indentation.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm: Re-indent file.
---

 guix/gnu-maintenance.scm | 38 +++++++++++++++++++-------------------
 1 file changed, 19 insertions(+), 19 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 2e0fc3e8ab..67abbc1c5a 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -578,11 +578,11 @@ (define* (import-html-release base-url package
                  (coalesce-sources candidates))
            ;; Select the most recent release and return it.
            (reduce (lambda (r1 r2)
-                         (if (version>? (upstream-source-version r1)
-                                        (upstream-source-version r2))
-                             r1 r2))
-                       first
-                       (coalesce-sources candidates)))))))
+                     (if (version>? (upstream-source-version r1)
+                                    (upstream-source-version r2))
+                         r1 r2))
+                   first
+                   (coalesce-sources candidates)))))))
 
 \f
 ;;;
@@ -656,20 +656,20 @@ (define* (import-gnu-release package #:key (version #f))
            (tarballs (filter (lambda (file)
                                (string=? version (tarball->version file)))
                              relevant)))
-    (match tarballs
-           (() #f)
-           (_
-            (upstream-source
-             (package name)
-             (version version)
-             (urls (map (lambda (file)
-                          (string-append "mirror://gnu/"
-                                         (string-drop file
-                                                      (string-length "/gnu/"))))
-                       ;; Sort so that the tarball with the same compression
-                       ;; format as currently used in PACKAGE comes first.
-                       (sort tarballs better-tarball?)))
-             (signature-urls (map (cut string-append <> ".sig") urls))))))))
+      (match tarballs
+        (() #f)
+        (_
+         (upstream-source
+          (package name)
+          (version version)
+          (urls (map (lambda (file)
+                       (string-append "mirror://gnu/"
+                                      (string-drop file
+                                                   (string-length "/gnu/"))))
+                     ;; Sort so that the tarball with the same compression
+                     ;; format as currently used in PACKAGE comes first.
+                     (sort tarballs better-tarball?)))
+          (signature-urls (map (cut string-append <> ".sig") urls))))))))
 
 (define %package-name-rx
   ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses
-- 
2.41.0

[bug#65230] [PATCH 08/13] gnu-maintenance: Accept package object in 'import-html-release' procedure.

[Maxim Cournoyer]

This is in preparation for a new URL rewriting feature, which will need to
have the current version information available.

* guix/gnu-maintenance.scm (import-html-release): Update doc.  Adjust default
value of the DIRECTORY argument.  Bind PACKAGE in lexical scope so that its
value there is unchanged.
(import-savannah-release, import-kernel.org-release)
(import-html-updatable-release): Adjust accordingly.
---

 guix/gnu-maintenance.scm | 17 ++++++++---------
 1 file changed, 8 insertions(+), 9 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 67abbc1c5a..13d6c1c7f2 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -494,11 +494,12 @@ (define (url->links url)
 (define* (import-html-release base-url package
                               #:key
                               (version #f)
-                              (directory (string-append "/" package))
+                              (directory (string-append
+                                          "/" (package-upstream-name package)))
                               file->signature)
-  "Return an <upstream-source> for the latest release of PACKAGE (a string)
-under DIRECTORY at BASE-URL, or #f.  Optionally include a VERSION string to
-fetch a specific version.
+  "Return an <upstream-source> for the latest release of PACKAGE under
+DIRECTORY at BASE-URL, or #f.  Optionally include a VERSION string to fetch a
+specific version.
 
 BASE-URL should be the URL of an HTML page, typically a directory listing as
 found on 'https://kernel.org/pub'.
@@ -507,7 +508,8 @@ (define* (import-html-release base-url package
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
 are unavailable."
-  (let* ((url (if (string-null? directory)
+  (let* ((package (package-upstream-name package))
+         (url (if (string-null? directory)
                   base-url
                   (string-append base-url directory "/")))
          (links (url->links url)))
@@ -730,7 +732,6 @@ (define* (import-savannah-release package #:key (version #f))
                      (match (origin-uri (package-source package))
                        ((? string? uri) uri)
                        ((uri mirrors ...) uri))))
-         (package   (package-upstream-name package))
          (directory (dirname (uri-path uri))))
     ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
     ;; or whichever detached signature naming scheme PACKAGE uses.
@@ -825,7 +826,6 @@ (define* (import-kernel.org-release package #:key (version #f))
                      (match (origin-uri (package-source package))
                        ((? string? uri) uri)
                        ((uri mirrors ...) uri))))
-         (package   (package-upstream-name package))
          (directory (dirname (uri-path uri))))
     (import-html-release %kernel.org-base package
                          #:version version
@@ -869,8 +869,7 @@ (define* (import-html-updatable-release package #:key (version #f))
                                        "://" (uri-host uri))))
          (directory (if custom
                         ""
-                        (dirname (uri-path uri))))
-         (package   (package-upstream-name package)))
+                        (dirname (uri-path uri)))))
     (false-if-networking-error
      (import-html-release base package
                           #:version version
-- 
2.41.0

[bug#65230] [PATCH 09/13] gnu-maintenance: Document nested procedures in 'import-html-release'.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (import-html-release): Add docstring to the
'file->signature/guess' and 'url->release' nested procedures.
---

 guix/gnu-maintenance.scm | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 13d6c1c7f2..9bab8e9e5f 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -514,6 +514,7 @@ (define* (import-html-release base-url package
                   (string-append base-url directory "/")))
          (links (url->links url)))
     (define (file->signature/guess url)
+      "Return the first link that matches a signature extension, else #f."
       (let ((base (basename url)))
         (any (lambda (link)
                (any (lambda (extension)
@@ -524,6 +525,8 @@ (define* (import-html-release base-url package
              links)))
 
     (define (url->release url)
+      "Return an <upstream-source> object if a release file was found at URL,
+else #f."
       (let* ((base (basename url))
              (base-url (string-append base-url directory))
              (url  (cond ((and=> (string->uri url) uri-scheme) ;full URL?
@@ -574,7 +577,7 @@ (define* (import-html-release base-url package
       (() #f)
       ((first . _)
        (if version
-           ;; find matching release version and return it
+           ;; Find matching release version and return it.
            (find (lambda (upstream)
                    (string=? (upstream-source-version upstream) version))
                  (coalesce-sources candidates))
-- 
2.41.0

[bug#65230] [PATCH 10/13] gnu-maintenance: Extract 'canonicalize-url' from 'import-html-release'.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm
(canonicalize-url): New procedure, extracted from...
(import-html-release): ... here.  Use it.  Rename inner PACKAGE variable to
NAME, to explicit it is a string and not a package object.
---

 guix/gnu-maintenance.scm | 70 +++++++++++++++++++---------------------
 1 file changed, 34 insertions(+), 36 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 9bab8e9e5f..abba891d4b 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -491,6 +491,33 @@ (define (url->links url)
     (close-port port)
     (delete-duplicates (html-links sxml))))
 
+(define (canonicalize-url url base-url)
+  "Make relative URL absolute, by appending URL to BASE-URL as required.  If
+URL is a directory instead of a file, it should be suffixed with a slash (/)."
+  (cond ((and=> (string->uri url) uri-scheme)
+         ;; Fully specified URL.
+         url)
+        ((string-prefix? "//" url)
+         ;; Full URL lacking a URI scheme.  Reuse the URI scheme of the
+         ;; document that contains the URL.
+         (string-append (symbol->string (uri-scheme (string->uri base-url)))
+                        ":" url))
+        ((string-prefix? "/" url)
+         ;; Absolute URL.
+         (let ((uri (string->uri base-url)))
+           (uri->string
+            (build-uri (uri-scheme uri)
+                       #:host (uri-host uri)
+                       #:port (uri-port uri)
+                       #:path url))))
+        ;; URL is relative to BASE-URL, which is assumed to be a directory.
+        ((string-suffix? "/" base-url)
+         (string-append base-url url))
+        (else
+         ;; URL is relative to BASE-URL, which is assumed to denote a file
+         ;; within a directory.
+         (string-append (dirname base-url) "/" url))))
+
 (define* (import-html-release base-url package
                               #:key
                               (version #f)
@@ -508,11 +535,12 @@ (define* (import-html-release base-url package
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
 are unavailable."
-  (let* ((package (package-upstream-name package))
+  (let* ((name (package-upstream-name package))
          (url (if (string-null? directory)
                   base-url
                   (string-append base-url directory "/")))
-         (links (url->links url)))
+         (links (map (cut canonicalize-url <> url) (url->links url))))
+
     (define (file->signature/guess url)
       "Return the first link that matches a signature extension, else #f."
       (let ((base (basename url)))
@@ -526,42 +554,12 @@ (define* (import-html-release base-url package
 
     (define (url->release url)
       "Return an <upstream-source> object if a release file was found at URL,
-else #f."
-      (let* ((base (basename url))
-             (base-url (string-append base-url directory))
-             (url  (cond ((and=> (string->uri url) uri-scheme) ;full URL?
-                          url)
-                         ;; full URL, except for URI scheme.  Reuse the URI
-                         ;; scheme of the document that contains the link.
-                         ((string-prefix? "//" url)
-                          (string-append
-                           (symbol->string (uri-scheme (string->uri base-url)))
-                           ":" url))
-                         ((string-prefix? "/" url) ;absolute path?
-                          (let ((uri (string->uri base-url)))
-                            (uri->string
-                             (build-uri (uri-scheme uri)
-                                        #:host (uri-host uri)
-                                        #:port (uri-port uri)
-                                        #:path url))))
-
-                         ;; URL is a relative path and BASE-URL may or may not
-                         ;; end in slash.
-                         ((string-suffix? "/" base-url)
-                          (string-append base-url url))
-                         (else
-                          ;; If DIRECTORY is non-empty, assume BASE-URL
-                          ;; denotes a directory; otherwise, assume BASE-URL
-                          ;; denotes a file within a directory, and that URL
-                          ;; is relative to that directory.
-                          (string-append (if (string-null? directory)
-                                             (dirname base-url)
-                                             base-url)
-                                         "/" url)))))
-        (and (release-file? package base)
+else #f.  URL is assumed to fully specified."
+      (let ((base (basename url)))
+        (and (release-file? name base)
              (let ((version (tarball->version base)))
                (upstream-source
-                (package package)
+                (package name)
                 (version version)
                 ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp://
                 ;; URLs during "guix refresh -u".
-- 
2.41.0

[bug#65230] [PATCH 11/13] gnu-maintenance: Add support to rewrite version in URL path.

[Maxim Cournoyer]

Fixes <https://issues.guix.gnu.org/64015>.

Previously, the generic HTML updater would only look for the list of files
found at the parent of its current source URL, ignoring that the URL may embed
the version elsewhere in its path.  This could cause 'guix refresh' to report
no updates available, while in fact there were, such as for 'libuv'.

* guix/gnu-maintenance.scm (strip-trailing-slash): New procedure.
(%version-rx): New variable.
(rewrite-url): New procedure.
(import-html-release): New rewrite-url? argument.  When true, use the above
procedure.
(import-html-updatable-release): Call import-html-release with #:rewrite-url
set to #t.
* tests/gnu-maintenance.scm ("rewrite-url, to-version specified")
("rewrite-url, without to-version"): New tests.
---

 guix/gnu-maintenance.scm  | 102 ++++++++++++++++++++++++++++++++++++--
 tests/gnu-maintenance.scm |  43 ++++++++++++++++
 2 files changed, 142 insertions(+), 3 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index abba891d4b..3cd84ee3d7 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,6 +27,7 @@ (define-module (guix gnu-maintenance)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (rnrs io ports)
@@ -61,6 +63,7 @@ (define-module (guix gnu-maintenance)
             gnu-package?
 
             uri-mirror-rewrite
+            rewrite-url
 
             release-file?
             releases
@@ -518,9 +521,93 @@ (define (canonicalize-url url base-url)
          ;; within a directory.
          (string-append (dirname base-url) "/" url))))
 
+(define (strip-trailing-slash s)
+  "Strip any trailing slash from S, a string."
+  (if (string-suffix? "/" s)
+      (string-drop-right s 1)
+      s))
+
+;;; TODO: Extend to support the RPM and GNOME version schemes?
+(define %version-rx "[0-9.]+")
+
+(define* (rewrite-url url version #:key to-version)
+  "Rewrite URL so that the URL path components matching the current VERSION or
+VERSION-MAJOR.VERSION-MINOR are updated with that of the latest version found
+by crawling the corresponding URL directories.  Alternatively, when TO-VERSION
+is specified, rewrite version matches directly to it without crawling URL.
+
+For example, the URL
+\"https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz\" could be
+rewritten to something like
+\"https://dist.libuv.org/dist/v1.46.0/libuv-v1.46.0.tar.gz\"."
+  ;; XXX: major-minor may be #f if version is not a triplet but a single
+  ;; number such as "2".
+  (let* ((major-minor (false-if-exception (version-major+minor version)))
+         (to-major-minor (false-if-exception
+                          (and=> to-version version-major+minor)))
+         (uri (string->uri url))
+         (url-prefix (string-drop-right url (string-length (uri-path uri))))
+         (url-prefix-components (string-split url-prefix #\/))
+         (path (uri-path uri))
+         ;; Strip a forward slash on the path to avoid a double slash when
+         ;; string-joining later.
+         (path (if (string-prefix? "/" path)
+                   (string-drop path 1)
+                   path))
+         (path-components (string-split path #\/)))
+    (string-join
+     (reverse
+      (fold
+       (lambda (s parents)
+         (if to-version
+             ;; Direct rewrite case; the archive is assumed to exist.
+             (let ((u (string-replace-substring s version to-version)))
+               (cons (if (and major-minor to-major-minor)
+                         (string-replace-substring u major-minor to-major-minor)
+                         u)
+                     parents))
+             ;; More involved HTML crawl case.
+             (let* ((pattern (if major-minor
+                                 (format #f "(~a|~a)" version major-minor)
+                                 (format #f "(~a)" version)))
+                    (m (string-match pattern s)))
+               (if m
+                   ;; Crawl parent and rewrite current component.
+                   (let* ((parent-url (string-join (reverse parents) "/"))
+                          (links (url->links parent-url))
+                          ;; The pattern matching the version.
+                          (pattern (string-append "^" (match:prefix m)
+                                                  "(" %version-rx ")"
+                                                  (match:suffix m) "$"))
+                          (candidates (filter-map
+                                       (lambda (l)
+                                         ;; Links may be followed by a
+                                         ;; trailing '/' in the case of
+                                         ;; directories.
+                                         (and-let*
+                                             ((l (strip-trailing-slash l))
+                                              (m (string-match pattern l))
+                                              (v (match:substring m 1)))
+                                           (cons v l)))
+                                       links)))
+                     ;; Retrieve the item having the largest version.
+                     (if (null? candidates)
+                         (error "no candidates found in rewrite-url")
+                         (cons (cdr (first (sort candidates
+                                                 (lambda (x y)
+                                                   (version>? (car x)
+                                                              (car y))))))
+                               parents)))
+                   ;; No version found in path component; continue.
+                   (cons s parents)))))
+       (reverse url-prefix-components)
+       path-components))
+     "/")))
+
 (define* (import-html-release base-url package
                               #:key
-                              (version #f)
+                              rewrite-url?
+                              version
                               (directory (string-append
                                           "/" (package-upstream-name package)))
                               file->signature)
@@ -534,11 +621,19 @@ (define* (import-html-release base-url package
 When FILE->SIGNATURE is omitted or #f, guess the detached signature file name,
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
-are unavailable."
-  (let* ((name (package-upstream-name package))
+are unavailable.
+
+When REWRITE-URL? is #t, versioned components in BASE-URL and/or DIRECTORY are
+also updated to the latest version, as explained in the doc of the
+\"rewrite-url\" procedure used."
+  (let* ((current-version (package-version package))
+         (name (package-upstream-name package))
          (url (if (string-null? directory)
                   base-url
                   (string-append base-url directory "/")))
+         (url (if rewrite-url?
+                  (rewrite-url url current-version #:to-version version)
+                  url))
          (links (map (cut canonicalize-url <> url) (url->links url))))
 
     (define (file->signature/guess url)
@@ -873,6 +968,7 @@ (define* (import-html-updatable-release package #:key (version #f))
                         (dirname (uri-path uri)))))
     (false-if-networking-error
      (import-html-release base package
+                          #:rewrite-url? #t
                           #:version version
                           #:directory directory))))
 
diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm
index 516e02ec6a..196a6f9092 100644
--- a/tests/gnu-maintenance.scm
+++ b/tests/gnu-maintenance.scm
@@ -147,4 +147,47 @@ (define-module (test-gnu-maintenance)
            (equal? (list expected-signature-url)
                    (upstream-source-signature-urls update))))))
 
+(test-equal "rewrite-url, to-version specified"
+  "https://download.qt.io/official_releases/qt/6.5/6.5.2/\
+submodules/qtbase-everywhere-src-6.5.2.tar.xz"
+  (rewrite-url "https://download.qt.io/official_releases/qt/6.3/6.3.2/\
+submodules/qtbase-everywhere-src-6.3.2.tar.xz" "6.3.2" #:to-version "6.5.2"))
+
+(test-equal "rewrite-url, without to-version"
+  "https://dist.libuv.org/dist/v1.46.0/libuv-v1.46.0.tar.gz"
+  (with-http-server
+      ;; First reply, crawling https://dist.libuv.org/dist/.
+      `((200 "\
+<!DOCTYPE html>
+<html>
+<head><title>Index of dist</title></head>
+<body>
+<a href=\"../\">../</a>
+<a href=\"v1.44.0/\" title=\"v1.44.0/\">v1.44.0/</a>
+<a href=\"v1.44.1/\" title=\"v1.44.1/\">v1.44.1/</a>
+<a href=\"v1.44.2/\" title=\"v1.44.2/\">v1.44.2/</a>
+<a href=\"v1.45.0/\" title=\"v1.45.0/\">v1.45.0/</a>
+<a href=\"v1.46.0/\" title=\"v1.46.0/\">v1.46.0/</a>
+</body>
+</html>")
+        ;; Second reply, crawling https://dist.libuv.org/dist/v1.46.0/.
+        (200 "\
+<!DOCTYPE html>
+<html>
+<head><title>Index of dist/v1.46.0</title></head>
+<body>
+<a href=\"../\">../</a>
+<a href=\"libuv-v1.46.0-dist.tar.gz\" title=\"libuv-v1.46.0-dist.tar.gz\">
+   libuv-v1.46.0-dist.tar.gz</a>
+<a href=\"libuv-v1.46.0-dist.tar.gz.sign\"
+   title=\"libuv-v1.46.0-dist.tar.gz.sign\">libuv-v1.46.0-dist.tar.gz.sign</a>
+<a href=\"libuv-v1.46.0.tar.gz\" title=\"libuv-v1.46.0.tar.gz\">
+   libuv-v1.46.0.tar.gz</a>
+<a href=\"libuv-v1.46.0.tar.gz.sign\" title=\"libuv-v1.46.0.tar.gz.sign\">
+   libuv-v1.46.0.tar.gz.sign</a>
+</body>
+</html>"))
+    (rewrite-url "https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz"
+                 "1.45.0")))
+
 (test-end)
-- 
2.41.0

[bug#65230] [PATCH 12/13] gnu-maintenance: Allow mirror URLs to fallback to the generic HTML updater.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (http-url?): Extract from html-updatable-package?,
modify to return the HTTP URL, and support the mirror:// scheme.
(%disallowed-hosting-sites): New variable, extracted from
html-updatable-package.
(html-updatable-package?): Rewrite a mirror:// URL to an HTTP or HTTPS one.
* guix/download.scm (%mirrors): Update comment.
---

 guix/download.scm        |  4 ++-
 guix/gnu-maintenance.scm | 58 +++++++++++++++++++++++++---------------
 2 files changed, 40 insertions(+), 22 deletions(-)

diff --git a/guix/download.scm b/guix/download.scm
index d5da866179..accffae9c8 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -51,7 +51,9 @@ (define-module (guix download)
 ;;; Code:
 
 (define %mirrors
-  ;; Mirror lists used when `mirror://' URLs are passed.
+  ;; Mirror lists used when `mirror://' URLs are passed.  The first mirror
+  ;; entry of each set should ideally be the most authoritative one, as that's
+  ;; what the generic HTML updater will pick to look for updates.
   (let* ((gnu-mirrors
           '(;; This one redirects to a (supposedly) nearby and (supposedly)
             ;; up-to-date mirror.
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 3cd84ee3d7..2574e0f827 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -928,27 +928,40 @@ (define* (import-kernel.org-release package #:key (version #f))
                          #:directory directory
                          #:file->signature file->signature)))
 
-(define html-updatable-package?
-  ;; Return true if the given package may be handled by the generic HTML
-  ;; updater.
-  (let ((hosting-sites '("github.com" "github.io" "gitlab.com"
-                         "notabug.org" "sr.ht" "gitlab.inria.fr"
-                         "ftp.gnu.org" "download.savannah.gnu.org"
-                         "pypi.org" "crates.io" "rubygems.org"
-                         "bioconductor.org")))
-    (define http-url?
-      (url-predicate (lambda (url)
-                       (match (string->uri url)
-                         (#f #f)
-                         (uri
-                          (let ((scheme (uri-scheme uri))
-                                (host   (uri-host uri)))
-                            (and (memq scheme '(http https))
-                                 (not (member host hosting-sites)))))))))
-
-    (lambda (package)
-      (or (assoc-ref (package-properties package) 'release-monitoring-url)
-          (http-url? package)))))
+;;; These sites are disallowed for the generic HTML updater as there are
+;;; better means to query them.
+(define %disallowed-hosting-sites
+  '("github.com" "github.io" "gitlab.com"
+    "notabug.org" "sr.ht" "gitlab.inria.fr"
+    "ftp.gnu.org" "download.savannah.gnu.org"
+    "pypi.org" "crates.io" "rubygems.org"
+    "bioconductor.org"))
+
+(define (http-url? url)
+  "Return URL if URL has HTTP or HTTPS as its protocol.  If URL uses the
+special mirror:// protocol, substitute it with the first HTTP or HTTPS URL
+prefix from its set."
+  (match (string->uri url)
+    (#f #f)
+    (uri
+     (let ((scheme (uri-scheme uri))
+           (host   (uri-host uri)))
+       (or (and (memq scheme '(http https))
+                (not (member host %disallowed-hosting-sites))
+                url)
+           (and (eq? scheme 'mirror)
+                (and=> (find http-url?
+                             (assoc-ref %mirrors
+                                        (string->symbol host)))
+                       (lambda (url)
+                         (string-append (strip-trailing-slash url)
+                                        (uri-path uri))))))))))
+
+(define (html-updatable-package? package)
+  "Return true if the given package may be handled by the generic HTML
+updater."
+  (or (assoc-ref (package-properties package) 'release-monitoring-url)
+      ((url-predicate http-url?) package)))
 
 (define* (import-html-updatable-release package #:key (version #f))
   "Return the latest release of PACKAGE.  Do that by crawling the HTML page of
@@ -956,6 +969,9 @@ (define* (import-html-updatable-release package #:key (version #f))
 string to fetch a specific version."
   (let* ((uri       (string->uri
                      (match (origin-uri (package-source package))
+                       ((? (cut string-prefix? "mirror://" <>) url)
+                        ;; Retrieve the authoritative HTTP URL from a mirror.
+                        (http-url? url))
                        ((? string? url) url)
                        ((url _ ...) url))))
          (custom    (assoc-ref (package-properties package)
-- 
2.41.0

[bug#65230] [PATCH 13/13] gnu-maintenance: Consider Qt source tarballs as "release files".

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (release-file?): Use positive logic in doc.
Add a special case for Qt source archives.
* tests/gnu-maintenance.scm ("release-file?"): Update test.

---

 guix/gnu-maintenance.scm  | 14 +++++++++-----
 tests/gnu-maintenance.scm |  4 +++-
 2 files changed, 12 insertions(+), 6 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 2574e0f827..1661ae3bf3 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -258,8 +258,7 @@ (define %alpha-tarball-rx
   (make-regexp "^.*-.*[0-9](-|~|\\.)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
 
 (define (release-file? project file)
-  "Return #f if FILE is not a release tarball of PROJECT, otherwise return
-true."
+  "Return true if FILE is a release tarball of PROJECT."
   (and (not (member (file-extension file)
                     '("sig" "sign" "asc"
                       "md5sum" "sha1sum" "sha256sum")))
@@ -268,12 +267,17 @@ (define (release-file? project file)
                 ;; Filter out unrelated files, like `guile-www-1.1.1'.
                 ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
                 ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
+                ;; The '-everywhere-src' suffix is for Qt modular components.
                 (and=> (match:substring match 1)
                        (lambda (name)
                          (or (string-ci=? name project)
-                             (string-ci=? name
-                                          (string-append project
-                                                         "-src")))))))
+                             (string-ci=? name (string-append project "-src"))
+                             (string-ci=?
+                              name (string-append project "-everywhere-src"))
+                             ;; For older Qt releases such as version 5.
+                             (string-ci=?
+                              name (string-append
+                                    project "-everywhere-opensource-src")))))))
        (not (regexp-exec %alpha-tarball-rx file))
        (let ((s (tarball-sans-extension file)))
          (regexp-exec %package-name-rx s))))
diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm
index 196a6f9092..5e9c006ee9 100644
--- a/tests/gnu-maintenance.scm
+++ b/tests/gnu-maintenance.scm
@@ -40,7 +40,9 @@ (define-module (test-gnu-maintenance)
                 ("exiv2" "exiv2-0.27.3-Source.tar.gz")
                 ("mpg321" "mpg321_0.3.2.orig.tar.gz")
                 ("bvi" "bvi-1.4.1.src.tar.gz")
-                ("hostscope" "hostscope-V2.1.tgz")))
+                ("hostscope" "hostscope-V2.1.tgz")
+                ("qtbase" "qtbase-everywhere-src-6.5.2.tar.xz")
+                ("qtbase" "qtbase-everywhere-opensource-src-5.15.10.tar.xz")))
        (every (lambda (project+file)
                 (not (apply release-file? project+file)))
               '(("guile" "guile-www-1.1.1.tar.gz")
-- 
2.41.0

[bug#65230] [PATCH v2 01/13] gnu-maintenance: Make base-url argument of import-html-release required.

[Maxim Cournoyer]

It doesn't make sense to have it default to something like
"https://kernel.org/pub"; it should always be provided explicitly.

* guix/gnu-maintenance.scm (import-html-release) <#:base-url>: Turn keyword
argument into a positional argument.  Update doc.
* guix/gnu-maintenance.scm (import-savannah-release): Adjust call accordingly.
(import-kernel.org-release): Likewise.
(import-html-updatable-release): Likewise.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 18 +++++++-----------
 1 file changed, 7 insertions(+), 11 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 32712f7218..b95a45824e 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -483,15 +483,14 @@ (define (html-links sxml)
       (_
        links))))
 
-(define* (import-html-release package
+(define* (import-html-release base-url package
                               #:key
                               (version #f)
-                              (base-url "https://kernel.org/pub")
                               (directory (string-append "/" package))
                               file->signature)
-  "Return an <upstream-source> for the latest release of PACKAGE (a string) on
-SERVER under DIRECTORY, or #f. Optionally include a VERSION string to fetch a
-specific version.
+  "Return an <upstream-source> for the latest release of PACKAGE (a string)
+under DIRECTORY at BASE-URL, or #f. Optionally include a VERSION string to
+fetch a specific version.
 
 BASE-URL should be the URL of an HTML page, typically a directory listing as
 found on 'https://kernel.org/pub'.
@@ -730,9 +729,8 @@ (define* (import-savannah-release package #:key (version #f))
          (directory (dirname (uri-path uri))))
     ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
     ;; or whichever detached signature naming scheme PACKAGE uses.
-    (import-html-release package
+    (import-html-release %savannah-base package
                          #:version version
-                         #:base-url %savannah-base
                          #:directory directory)))
 
 (define* (latest-sourceforge-release package #:key (version #f))
@@ -824,9 +822,8 @@ (define* (import-kernel.org-release package #:key (version #f))
                        ((uri mirrors ...) uri))))
          (package   (package-upstream-name package))
          (directory (dirname (uri-path uri))))
-    (import-html-release package
+    (import-html-release %kernel.org-base package
                          #:version version
-                         #:base-url %kernel.org-base
                          #:directory directory
                          #:file->signature file->signature)))
 
@@ -870,9 +867,8 @@ (define* (import-html-updatable-release package #:key (version #f))
                         (dirname (uri-path uri))))
          (package   (package-upstream-name package)))
     (false-if-networking-error
-     (import-html-release package
+     (import-html-release base package
                           #:version version
-                          #:base-url base
                           #:directory directory))))
 
 (define %gnu-updater

base-commit: a4bed14c438dc0cbc1c1885a38f8409c7fef7957
-- 
2.41.0

[bug#65230] [PATCH v2 02/13] download: Add mirrors for Qt.

[Maxim Cournoyer]

* guix/download.scm (%mirrors): Augment with qt mirrors.

---

Changes in v2:
- Move authoritative mirror last, as it's too slow.

 guix/download.scm | 10 +++++++++-
 1 file changed, 9 insertions(+), 1 deletion(-)

diff --git a/guix/download.scm b/guix/download.scm
index 30d7c5a86e..ce6ebd0df8 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -358,7 +358,15 @@ (define %mirrors
        "https://mirror.esc7.net/pub/OpenBSD/")
       (mate
        "https://pub.mate-desktop.org/releases/"
-       "http://pub.mate-desktop.org/releases/"))))
+       "http://pub.mate-desktop.org/releases/")
+      (qt
+       "https://mirrors.ocf.berkeley.edu/qt/official_releases/"
+       "https://ftp.jaist.ac.jp/pub/qtproject/official_releases/"
+       "https://ftp.nluug.nl/languages/qt/official_releases/"
+       "https://mirrors.cloud.tencent.com/qt/official_releases/"
+       "https://mirrors.sjtug.sjtu.edu.cn/qt/official_releases/"
+       "https://qtproject.mirror.liquidtelecom.com/official_releases/"
+       "https://download.qt.io/official_releases/")))) ;slow
 
 (define %mirror-file
   ;; Copy of the list of mirrors to a file.  This allows us to keep a single
-- 
2.41.0

[bug#65230] [PATCH v2 03/13] gnu: qt: Streamline qt-urls.

[Maxim Cournoyer]

* gnu/packages/qt.scm (qt-urls): Rename to...
(qt-url): ... this.  Return a single URL built using the mirror:// scheme.
Adjust all callers accordingly.
---

(no changes since v1)

 gnu/packages/qt.scm | 124 +++++++++++++++++++++-----------------------
 1 file changed, 58 insertions(+), 66 deletions(-)

diff --git a/gnu/packages/qt.scm b/gnu/packages/qt.scm
index 1184a85938..b73acef3c5 100644
--- a/gnu/packages/qt.scm
+++ b/gnu/packages/qt.scm
@@ -124,6 +124,7 @@ (define-module (gnu packages qt)
   #:use-module (gnu packages xiph)
   #:use-module (gnu packages xorg)
   #:use-module (gnu packages xml)
+  #:use-module (ice-9 match)
   #:use-module (srfi srfi-1))
 
 (define %qt-version "5.15.8")
@@ -315,27 +316,18 @@ (define-public grantlee
 system, and the core design of Django is reused in Grantlee.")
     (license license:lgpl2.1+)))
 
-(define (qt-urls component version)
-  "Return a list of URLs for VERSION of the Qt5 COMPONENT."
+(define (qt-url component version)
+  "Return a mirror URL for the Qt5 COMPONENT at VERSION."
   ;; We can't use a mirror:// scheme because these URLs are not exact copies:
   ;; the layout differs between them.
-  (list (string-append "https://download.qt.io/official_releases/qt/"
-                       (version-major+minor version) "/" version
-                       "/submodules/" component "-everywhere-opensource-src-"
-                       version ".tar.xz")
-        (string-append "https://download.qt.io/official_releases/qt/"
-                       (version-major+minor version) "/" version
-                       "/submodules/" component "-everywhere-src-"
-                       version ".tar.xz")
-        (string-append "https://download.qt.io/archive/qt/"
-                       (version-major+minor version) "/" version
-                       "/submodules/" component "-everywhere-opensource-src-"
-                       version ".tar.xz")
-        (let ((directory (string-append "qt5" (string-drop component 2))))
-          (string-append "http://sources.buildroot.net/" directory "/"
-                         component "-everywhere-opensource-src-" version ".tar.xz"))
-        (string-append "https://distfiles.macports.org/qt5/"
-                       component "-everywhere-opensource-src-" version ".tar.xz")))
+  (let ((x (match (version-major version)
+             ("5" "-everywhere-opensource-src-")
+             ;; Version 6 and later dropped 'opensource' from the archive
+             ;; names.
+             (_ "-everywhere-src-"))))
+    (string-append "mirror://qt/qt/"
+                   (version-major+minor version) "/" version
+                   "/submodules/" component x version ".tar.xz")))
 
 (define-public qtbase-5
   (package
@@ -343,7 +335,7 @@ (define-public qtbase-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "175ynjndpzsw69vnsq4swykn9f48568ww9b4z3yw7azkqwk13cdz"))
@@ -596,7 +588,7 @@ (define-public qtbase
     (version "6.3.2")
     (source (origin
               (inherit (package-source qtbase-5))
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "19m9r8sf9mvyrwipn44if3nhding4ljys2mwf04b7dkhz16vlabr"))
@@ -899,7 +891,7 @@ (define-public qt3d-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "18hbv4l9w0czaxcch6af9130fgs4sf400xp0pfzl81c78fwrkfsb"))))
@@ -961,7 +953,7 @@ (define-public qt5compat
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1k30hnwnlbay1hnkdavgf6plsdzrryzcqd2qz8x11r477w7sr8wi"))))
@@ -991,7 +983,7 @@ (define-public qtsvg-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0qnmcvp5jap4qq9w7xak66g6fsb48q1lg02rn4lycvnhgwzblbww"))))
@@ -1059,7 +1051,7 @@ (define-public qtsvg
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "14i3f23k9k0731akpwa6zzhw5m3c0m2l5r7irvim4h4faah445ac"))))
@@ -1090,7 +1082,7 @@ (define-public qtimageformats
     (version %qt-version)
     (source (origin
              (method url-fetch)
-             (uri (qt-urls name version))
+             (uri (qt-url name version))
              (sha256
               (base32
                "0c6fq9zcw5hbkiny56wx2fbm123x14l7habydv6zhvnhn3rhwi31"))
@@ -1117,7 +1109,7 @@ (define-public qtx11extras
     (version %qt-version)
     (source (origin
              (method url-fetch)
-             (uri (qt-urls name version))
+             (uri (qt-url name version))
              (sha256
               (base32
                "1gzmf0y2byzrgfbing7xk3cwlbk1cyjlhqjbfh8n37y09gg65maf"))))
@@ -1183,7 +1175,7 @@ (define-public qtxmlpatterns
     (version %qt-version)
     (source (origin
              (method url-fetch)
-             (uri (qt-urls name version))
+             (uri (qt-url name version))
              (sha256
               (base32
                "1inf7ar32a557faqpwdsmafhz1p6k8hywpw3wbsdjlj74dkgdq35"))))
@@ -1212,7 +1204,7 @@ (define-public qtdeclarative-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1kb8nj17vmnky0ayiwypim7kf6rmlmfcjf6gnrw8rydmp61w0vh2"))))
@@ -1258,7 +1250,7 @@ (define-public qtdeclarative
     ;; TODO: Package 'masm' and unbundle from sources.
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1hbw63828pp8vm9b46i2pkcbcpr4mq9nblhmpwrw2pflq0fi24xq"))))
@@ -1390,7 +1382,7 @@ (define-public qtconnectivity
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1j6qgkg77ycwcjxnhh38i9np1z8pjsqrzvfk3zsyq07f6k563fnc"))))
@@ -1408,7 +1400,7 @@ (define-public qtwebsockets-5
     (version %qt-version)
     (source (origin
              (method url-fetch)
-             (uri (qt-urls name version))
+             (uri (qt-url name version))
              (sha256
               (base32
                "12h520lpj2pljgkyq36p1509mw4pxgb76n30d32kg52crjsk34pa"))))
@@ -1431,7 +1423,7 @@ (define-public qtwebsockets
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1smbvidaybphvsmaap9v1pbkibwmng11hb925g0ww4ghwzpxkb8q"))))
@@ -1471,7 +1463,7 @@ (define-public qtsensors
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1fdpgbikvxjacyipcyac0czqhv96pvc75dl9cyafslws8m53fm56"))))
@@ -1500,7 +1492,7 @@ (define-public qtmultimedia-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1fz0ffpckvbg6qfhab2rrzfnvh4mlalqxcn0kbkd21mi44apjirk"))
@@ -1544,7 +1536,7 @@ (define-public qtshadertools
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               ;; Note: the source bundles *patched* glslang and SPIRV-Cross
               ;; sources.
               (sha256
@@ -1573,7 +1565,7 @@ (define-public qtmultimedia
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0hqwq0ad6z8c5kyyvbaddj00mciijn2ns2r60jc3mqh98nm2js3z"))
@@ -1639,7 +1631,7 @@ (define-public qtwayland-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (patches (search-patches "qtwayland-gcc-11.patch"
                                        "qtwayland-dont-recreate-callbacks.patch"
                                        "qtwayland-cleanup-callbacks.patch"))
@@ -1689,7 +1681,7 @@ (define-public qtwayland
     (source
      (origin
        (method url-fetch)
-       (uri (qt-urls name version))
+       (uri (qt-url name version))
        (sha256
         (base32 "0rwiirkibgpvx05pg2842j4dcq9ckxmcqxhaf50xx2i55z64ll83"))))
     (build-system cmake-build-system)
@@ -1739,7 +1731,7 @@ (define-public qtserialport
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "04i8pdyml1sw4dkk9vyw2xy5bz3fp6f90fws7ag5y8iizfgs5v2v"))))
@@ -1770,7 +1762,7 @@ (define-public qtserialbus
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0ws3pjbp4g8f49k8q0qa5hgyisbyk3m7kl8pwzkfws048glvz570"))))
@@ -1797,7 +1789,7 @@ (define-public qtwebchannel-5
     (version %qt-version)
     (source (origin
              (method url-fetch)
-             (uri (qt-urls name version))
+             (uri (qt-url name version))
              (sha256
               (base32
                "1pfmy6fqis47awjb590r63y13vvsfm0fq70an3ylsknhyq3firgn"))))
@@ -1815,7 +1807,7 @@ (define-public qtwebchannel
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0gqm09yqdq27kgb02idx5ycj14k5mjhh10ddp9jfs8lblimlgfni"))))
@@ -1853,7 +1845,7 @@ (define-public qtwebglplugin
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1gvzhgfn55kdp5g11fg5yja5xb6wghx5sfc8vfp8zzpxnak7pbn1"))))
@@ -1882,7 +1874,7 @@ (define-public qtwebview
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1b03dzlff840n2i53r105c7sv91ivwzxn7ldpgnhiyrhr897i9kj"))))
@@ -1900,7 +1892,7 @@ (define-public qtlocation
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0r16qxy0pfpwvna4gpz67jk3qv3qizfd659kc9iwdh8bhz7lpjrw"))))
@@ -1924,7 +1916,7 @@ (define-public qtlottie
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1c092hmf114r8jfdhkhxnn3vywj93mg33whzav47gr9mbza44icq"))))
@@ -1957,7 +1949,7 @@ (define-public qttools-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1i79fwsn799x3n3jidp3f4gz9d5vi9gg6p8g8lbswb832gggigm3"))))
@@ -1977,7 +1969,7 @@ (define-public qttools
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1lmfk5bhgg4daxkqrhmx4iyln7pyiz40c9cp6plyp35nz8ppvc75"))))
@@ -2017,7 +2009,7 @@ (define-public qttranslations
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1h66n9cx4g65c9wrgp32h9gm3r47gyh1nrcn3ivbfbvngfawqxpg"))))
@@ -2039,7 +2031,7 @@ (define-public qtscript
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0rjj1pn0fwdq0qz0nzisxza671ywfrq5cv6iplywfyflh7q4dmcs"))
@@ -2058,7 +2050,7 @@ (define-public qtquickcontrols-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0yp47bpkfckms76vw0hrwnzchy8iak23ih6w9pnwrnjkmbc65drc"))))
@@ -2078,7 +2070,7 @@ (define-public qtquickcontrols2-5
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "058dkj6272za47vnz3mxsmwsj85gxf6g0ski645fphk8s3jp2bk5"))))
@@ -2105,7 +2097,7 @@ (define-public qtgraphicaleffects
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0wypji8i19kjq18qd92z8kkd3fj2n0d5hgh6xiza96833afvibj9"))))
@@ -2128,7 +2120,7 @@ (define-public qtgamepad
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0vgxprgk7lak209wsg2ljzfkpwgjzscpbxmj5fyvvwm2pbnpspvk"))))
@@ -2154,7 +2146,7 @@ (define-public qtscxml
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "17j6npvgr8q3lyrqmvfh1n47mkhfzk18r998hcjm2w75xj46km1n"))
@@ -2181,7 +2173,7 @@ (define-public qtpositioning
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0zh45lf164nzwl1hh96qm64nyw9wzzrnm5s7sx761glz54q6l5xz"))))
@@ -2212,7 +2204,7 @@ (define-public qtpurchasing
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0bjky5ncg9yhz4a63g3jl1r5pa6i09f6g8wgzs591mhybrbmhcw8"))))
@@ -2228,7 +2220,7 @@ (define-public qtcharts
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1q11ank69l9qw3iks2svr0g2g6pzng9v8p87dpsmjs988f4ysmll"))))
@@ -2257,7 +2249,7 @@ (define-public qtdatavis3d
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1mr2kdshahxrkjs9wlgpr59jbqvyvlax16rlnca4iq00w3v5hrdh"))))
@@ -2279,7 +2271,7 @@ (define-public qtnetworkauth-5
     (version %qt-version)
     (source (origin
              (method url-fetch)
-             (uri (qt-urls name version))
+             (uri (qt-url name version))
              (sha256
               (base32
                "0fsmpjwkzzy3281shld7gs1gj217smb1f8ai63gdvnkp0jb2fhc5"))))
@@ -2294,7 +2286,7 @@ (define-public qtnetworkauth
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "0mjnz87splyxq7jwydi5ws2aqb6j7czscrkns193w425x0dgy94l"))))
@@ -2314,7 +2306,7 @@ (define-public qtremoteobjects
     (version "6.3.2")
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "099b3vchi458i4fci9kfwan871jplqlk5l8q78mfnh33g80qnasi"))))
@@ -2352,7 +2344,7 @@ (define-public qtspeech
     (version %qt-version)
     (source (origin
               (method url-fetch)
-              (uri (qt-urls name version))
+              (uri (qt-url name version))
               (sha256
                (base32
                 "1q56lyj7s05sx52j5z6gcs000mni4c7mb7qyq4lfval7c06hw5p6"))))
@@ -2461,7 +2453,7 @@ (define-public qtwebengine-5
     (source
      (origin
        (method url-fetch)
-       (uri (qt-urls name version))
+       (uri (qt-url name version))
        (sha256
         (base32
          "1qv15g5anhlfsdwnjxy21vc3zxxm8149vysi774l93iab6mxqmjg"))
@@ -2789,7 +2781,7 @@ (define-public qtwebengine
     (source
      (origin
        (method url-fetch)
-       (uri (qt-urls name version))
+       (uri (qt-url name version))
        (sha256
         (base32
          "09j4w9ax8242d1yx3hmic7jcwidwdrn8sp7k89hj4l0n8mzkkd35"))
-- 
2.41.0

[bug#65230] [PATCH v2 04/13] gnu: qt-creator: Use mirror://qt for source URI.

[Maxim Cournoyer]

* gnu/packages/qt.scm (qt-creator) [source]: Use mirror://qt for origin URI.
---

(no changes since v1)

 gnu/packages/qt.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gnu/packages/qt.scm b/gnu/packages/qt.scm
index b73acef3c5..2ca03b77d1 100644
--- a/gnu/packages/qt.scm
+++ b/gnu/packages/qt.scm
@@ -4703,7 +4703,7 @@ (define-public qt-creator
     (source (origin
               (method url-fetch)
               (uri (string-append
-                    "https://download.qt.io/official_releases/qtcreator/"
+                    "mirror://qt/qtcreator/"
                     (version-major+minor version) "/" version
                     "/qt-creator-opensource-src-" version ".tar.gz"))
               (modules '((guix build utils)))
-- 
2.41.0

[bug#65230] [PATCH v2 05/13] gnu-maintenance: Fix docstring.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (import-kernel.org-release): Fix docstring.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index b95a45824e..a314923d3b 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -489,7 +489,7 @@ (define* (import-html-release base-url package
                               (directory (string-append "/" package))
                               file->signature)
   "Return an <upstream-source> for the latest release of PACKAGE (a string)
-under DIRECTORY at BASE-URL, or #f. Optionally include a VERSION string to
+under DIRECTORY at BASE-URL, or #f.  Optionally include a VERSION string to
 fetch a specific version.
 
 BASE-URL should be the URL of an HTML page, typically a directory listing as
@@ -806,7 +806,7 @@ (define* (import-xorg-release package #:key (version #f))
       (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
 
 (define* (import-kernel.org-release package #:key (version #f))
-  "Return the latest release of PACKAGE, the name of a kernel.org package.
+  "Return the latest release of PACKAGE, a Linux kernel package.
 Optionally include a VERSION string to fetch a specific version."
   (define %kernel.org-base
     ;; This URL and sub-directories thereof are nginx-generated directory
-- 
2.41.0

[bug#65230] [PATCH v2 06/13] gnu-maintenance: Extract url->links procedure.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (url->links): New procedure.
(import-html-release): Use it.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index a314923d3b..2e0fc3e8ab 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -483,6 +483,14 @@ (define (html-links sxml)
       (_
        links))))
 
+(define (url->links url)
+  "Return the unique links on the HTML page accessible at URL."
+  (let* ((uri   (string->uri url))
+         (port  (http-fetch/cached uri #:ttl 3600))
+         (sxml  (html->sxml port)))
+    (close-port port)
+    (delete-duplicates (html-links sxml))))
+
 (define* (import-html-release base-url package
                               #:key
                               (version #f)
@@ -499,12 +507,10 @@ (define* (import-html-release base-url package
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
 are unavailable."
-  (let* ((uri   (string->uri (if (string-null? directory)
-                                 base-url
-                                 (string-append base-url directory "/"))))
-         (port  (http-fetch/cached uri #:ttl 3600))
-         (sxml  (html->sxml port))
-         (links (delete-duplicates (html-links sxml))))
+  (let* ((url (if (string-null? directory)
+                  base-url
+                  (string-append base-url directory "/")))
+         (links (url->links url)))
     (define (file->signature/guess url)
       (let ((base (basename url)))
         (any (lambda (link)
@@ -562,7 +568,6 @@ (define* (import-html-release base-url package
     (define candidates
       (filter-map url->release links))
 
-    (close-port port)
     (match candidates
       (() #f)
       ((first . _)
-- 
2.41.0

[bug#65230] [PATCH v2 07/13] gnu-maintenance: Fix indentation.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm: Re-indent file.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 38 +++++++++++++++++++-------------------
 1 file changed, 19 insertions(+), 19 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 2e0fc3e8ab..67abbc1c5a 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -578,11 +578,11 @@ (define* (import-html-release base-url package
                  (coalesce-sources candidates))
            ;; Select the most recent release and return it.
            (reduce (lambda (r1 r2)
-                         (if (version>? (upstream-source-version r1)
-                                        (upstream-source-version r2))
-                             r1 r2))
-                       first
-                       (coalesce-sources candidates)))))))
+                     (if (version>? (upstream-source-version r1)
+                                    (upstream-source-version r2))
+                         r1 r2))
+                   first
+                   (coalesce-sources candidates)))))))
 
 \f
 ;;;
@@ -656,20 +656,20 @@ (define* (import-gnu-release package #:key (version #f))
            (tarballs (filter (lambda (file)
                                (string=? version (tarball->version file)))
                              relevant)))
-    (match tarballs
-           (() #f)
-           (_
-            (upstream-source
-             (package name)
-             (version version)
-             (urls (map (lambda (file)
-                          (string-append "mirror://gnu/"
-                                         (string-drop file
-                                                      (string-length "/gnu/"))))
-                       ;; Sort so that the tarball with the same compression
-                       ;; format as currently used in PACKAGE comes first.
-                       (sort tarballs better-tarball?)))
-             (signature-urls (map (cut string-append <> ".sig") urls))))))))
+      (match tarballs
+        (() #f)
+        (_
+         (upstream-source
+          (package name)
+          (version version)
+          (urls (map (lambda (file)
+                       (string-append "mirror://gnu/"
+                                      (string-drop file
+                                                   (string-length "/gnu/"))))
+                     ;; Sort so that the tarball with the same compression
+                     ;; format as currently used in PACKAGE comes first.
+                     (sort tarballs better-tarball?)))
+          (signature-urls (map (cut string-append <> ".sig") urls))))))))
 
 (define %package-name-rx
   ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses
-- 
2.41.0

[bug#65230] [PATCH v2 08/13] gnu-maintenance: Accept package object in 'import-html-release' procedure.

[Maxim Cournoyer]

This is in preparation for a new URL rewriting feature, which will need to
have the current version information available.

* guix/gnu-maintenance.scm (import-html-release): Update doc.  Adjust default
value of the DIRECTORY argument.  Bind PACKAGE in lexical scope so that its
value there is unchanged.
(import-savannah-release, import-kernel.org-release)
(import-html-updatable-release): Adjust accordingly.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 17 ++++++++---------
 1 file changed, 8 insertions(+), 9 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 67abbc1c5a..13d6c1c7f2 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -494,11 +494,12 @@ (define (url->links url)
 (define* (import-html-release base-url package
                               #:key
                               (version #f)
-                              (directory (string-append "/" package))
+                              (directory (string-append
+                                          "/" (package-upstream-name package)))
                               file->signature)
-  "Return an <upstream-source> for the latest release of PACKAGE (a string)
-under DIRECTORY at BASE-URL, or #f.  Optionally include a VERSION string to
-fetch a specific version.
+  "Return an <upstream-source> for the latest release of PACKAGE under
+DIRECTORY at BASE-URL, or #f.  Optionally include a VERSION string to fetch a
+specific version.
 
 BASE-URL should be the URL of an HTML page, typically a directory listing as
 found on 'https://kernel.org/pub'.
@@ -507,7 +508,8 @@ (define* (import-html-release base-url package
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
 are unavailable."
-  (let* ((url (if (string-null? directory)
+  (let* ((package (package-upstream-name package))
+         (url (if (string-null? directory)
                   base-url
                   (string-append base-url directory "/")))
          (links (url->links url)))
@@ -730,7 +732,6 @@ (define* (import-savannah-release package #:key (version #f))
                      (match (origin-uri (package-source package))
                        ((? string? uri) uri)
                        ((uri mirrors ...) uri))))
-         (package   (package-upstream-name package))
          (directory (dirname (uri-path uri))))
     ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
     ;; or whichever detached signature naming scheme PACKAGE uses.
@@ -825,7 +826,6 @@ (define* (import-kernel.org-release package #:key (version #f))
                      (match (origin-uri (package-source package))
                        ((? string? uri) uri)
                        ((uri mirrors ...) uri))))
-         (package   (package-upstream-name package))
          (directory (dirname (uri-path uri))))
     (import-html-release %kernel.org-base package
                          #:version version
@@ -869,8 +869,7 @@ (define* (import-html-updatable-release package #:key (version #f))
                                        "://" (uri-host uri))))
          (directory (if custom
                         ""
-                        (dirname (uri-path uri))))
-         (package   (package-upstream-name package)))
+                        (dirname (uri-path uri)))))
     (false-if-networking-error
      (import-html-release base package
                           #:version version
-- 
2.41.0

[bug#65230] [PATCH v2 09/13] gnu-maintenance: Document nested procedures in 'import-html-release'.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (import-html-release): Add docstring to the
'file->signature/guess' and 'url->release' nested procedures.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 13d6c1c7f2..9bab8e9e5f 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -514,6 +514,7 @@ (define* (import-html-release base-url package
                   (string-append base-url directory "/")))
          (links (url->links url)))
     (define (file->signature/guess url)
+      "Return the first link that matches a signature extension, else #f."
       (let ((base (basename url)))
         (any (lambda (link)
                (any (lambda (extension)
@@ -524,6 +525,8 @@ (define* (import-html-release base-url package
              links)))
 
     (define (url->release url)
+      "Return an <upstream-source> object if a release file was found at URL,
+else #f."
       (let* ((base (basename url))
              (base-url (string-append base-url directory))
              (url  (cond ((and=> (string->uri url) uri-scheme) ;full URL?
@@ -574,7 +577,7 @@ (define* (import-html-release base-url package
       (() #f)
       ((first . _)
        (if version
-           ;; find matching release version and return it
+           ;; Find matching release version and return it.
            (find (lambda (upstream)
                    (string=? (upstream-source-version upstream) version))
                  (coalesce-sources candidates))
-- 
2.41.0

[bug#65230] [PATCH v2 10/13] gnu-maintenance: Extract 'canonicalize-url' from 'import-html-release'.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm
(canonicalize-url): New procedure, extracted from...
(import-html-release): ... here.  Use it.  Rename inner PACKAGE variable to
NAME, to explicit it is a string and not a package object.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 70 +++++++++++++++++++---------------------
 1 file changed, 34 insertions(+), 36 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 9bab8e9e5f..abba891d4b 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -491,6 +491,33 @@ (define (url->links url)
     (close-port port)
     (delete-duplicates (html-links sxml))))
 
+(define (canonicalize-url url base-url)
+  "Make relative URL absolute, by appending URL to BASE-URL as required.  If
+URL is a directory instead of a file, it should be suffixed with a slash (/)."
+  (cond ((and=> (string->uri url) uri-scheme)
+         ;; Fully specified URL.
+         url)
+        ((string-prefix? "//" url)
+         ;; Full URL lacking a URI scheme.  Reuse the URI scheme of the
+         ;; document that contains the URL.
+         (string-append (symbol->string (uri-scheme (string->uri base-url)))
+                        ":" url))
+        ((string-prefix? "/" url)
+         ;; Absolute URL.
+         (let ((uri (string->uri base-url)))
+           (uri->string
+            (build-uri (uri-scheme uri)
+                       #:host (uri-host uri)
+                       #:port (uri-port uri)
+                       #:path url))))
+        ;; URL is relative to BASE-URL, which is assumed to be a directory.
+        ((string-suffix? "/" base-url)
+         (string-append base-url url))
+        (else
+         ;; URL is relative to BASE-URL, which is assumed to denote a file
+         ;; within a directory.
+         (string-append (dirname base-url) "/" url))))
+
 (define* (import-html-release base-url package
                               #:key
                               (version #f)
@@ -508,11 +535,12 @@ (define* (import-html-release base-url package
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
 are unavailable."
-  (let* ((package (package-upstream-name package))
+  (let* ((name (package-upstream-name package))
          (url (if (string-null? directory)
                   base-url
                   (string-append base-url directory "/")))
-         (links (url->links url)))
+         (links (map (cut canonicalize-url <> url) (url->links url))))
+
     (define (file->signature/guess url)
       "Return the first link that matches a signature extension, else #f."
       (let ((base (basename url)))
@@ -526,42 +554,12 @@ (define* (import-html-release base-url package
 
     (define (url->release url)
       "Return an <upstream-source> object if a release file was found at URL,
-else #f."
-      (let* ((base (basename url))
-             (base-url (string-append base-url directory))
-             (url  (cond ((and=> (string->uri url) uri-scheme) ;full URL?
-                          url)
-                         ;; full URL, except for URI scheme.  Reuse the URI
-                         ;; scheme of the document that contains the link.
-                         ((string-prefix? "//" url)
-                          (string-append
-                           (symbol->string (uri-scheme (string->uri base-url)))
-                           ":" url))
-                         ((string-prefix? "/" url) ;absolute path?
-                          (let ((uri (string->uri base-url)))
-                            (uri->string
-                             (build-uri (uri-scheme uri)
-                                        #:host (uri-host uri)
-                                        #:port (uri-port uri)
-                                        #:path url))))
-
-                         ;; URL is a relative path and BASE-URL may or may not
-                         ;; end in slash.
-                         ((string-suffix? "/" base-url)
-                          (string-append base-url url))
-                         (else
-                          ;; If DIRECTORY is non-empty, assume BASE-URL
-                          ;; denotes a directory; otherwise, assume BASE-URL
-                          ;; denotes a file within a directory, and that URL
-                          ;; is relative to that directory.
-                          (string-append (if (string-null? directory)
-                                             (dirname base-url)
-                                             base-url)
-                                         "/" url)))))
-        (and (release-file? package base)
+else #f.  URL is assumed to fully specified."
+      (let ((base (basename url)))
+        (and (release-file? name base)
              (let ((version (tarball->version base)))
                (upstream-source
-                (package package)
+                (package name)
                 (version version)
                 ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp://
                 ;; URLs during "guix refresh -u".
-- 
2.41.0

[bug#65230] [PATCH v2 11/13] gnu-maintenance: Add support to rewrite version in URL path.

[Maxim Cournoyer]

Fixes <https://issues.guix.gnu.org/64015>.

Previously, the generic HTML updater would only look for the list of files
found at the parent of its current source URL, ignoring that the URL may embed
the version elsewhere in its path.  This could cause 'guix refresh' to report
no updates available, while in fact there were, such as for 'libuv'.

* guix/gnu-maintenance.scm (strip-trailing-slash): New procedure.
(%version-rx): New variable.
(rewrite-url): New procedure.
(import-html-release): New rewrite-url? argument.  When true, use the above
procedure.
(import-html-updatable-release): Call import-html-release with #:rewrite-url
set to #t.
* tests/gnu-maintenance.scm ("rewrite-url, to-version specified")
("rewrite-url, without to-version"): New tests.
---

(no changes since v1)

 guix/gnu-maintenance.scm  | 102 ++++++++++++++++++++++++++++++++++++--
 tests/gnu-maintenance.scm |  43 ++++++++++++++++
 2 files changed, 142 insertions(+), 3 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index abba891d4b..3cd84ee3d7 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,6 +27,7 @@ (define-module (guix gnu-maintenance)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (rnrs io ports)
@@ -61,6 +63,7 @@ (define-module (guix gnu-maintenance)
             gnu-package?
 
             uri-mirror-rewrite
+            rewrite-url
 
             release-file?
             releases
@@ -518,9 +521,93 @@ (define (canonicalize-url url base-url)
          ;; within a directory.
          (string-append (dirname base-url) "/" url))))
 
+(define (strip-trailing-slash s)
+  "Strip any trailing slash from S, a string."
+  (if (string-suffix? "/" s)
+      (string-drop-right s 1)
+      s))
+
+;;; TODO: Extend to support the RPM and GNOME version schemes?
+(define %version-rx "[0-9.]+")
+
+(define* (rewrite-url url version #:key to-version)
+  "Rewrite URL so that the URL path components matching the current VERSION or
+VERSION-MAJOR.VERSION-MINOR are updated with that of the latest version found
+by crawling the corresponding URL directories.  Alternatively, when TO-VERSION
+is specified, rewrite version matches directly to it without crawling URL.
+
+For example, the URL
+\"https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz\" could be
+rewritten to something like
+\"https://dist.libuv.org/dist/v1.46.0/libuv-v1.46.0.tar.gz\"."
+  ;; XXX: major-minor may be #f if version is not a triplet but a single
+  ;; number such as "2".
+  (let* ((major-minor (false-if-exception (version-major+minor version)))
+         (to-major-minor (false-if-exception
+                          (and=> to-version version-major+minor)))
+         (uri (string->uri url))
+         (url-prefix (string-drop-right url (string-length (uri-path uri))))
+         (url-prefix-components (string-split url-prefix #\/))
+         (path (uri-path uri))
+         ;; Strip a forward slash on the path to avoid a double slash when
+         ;; string-joining later.
+         (path (if (string-prefix? "/" path)
+                   (string-drop path 1)
+                   path))
+         (path-components (string-split path #\/)))
+    (string-join
+     (reverse
+      (fold
+       (lambda (s parents)
+         (if to-version
+             ;; Direct rewrite case; the archive is assumed to exist.
+             (let ((u (string-replace-substring s version to-version)))
+               (cons (if (and major-minor to-major-minor)
+                         (string-replace-substring u major-minor to-major-minor)
+                         u)
+                     parents))
+             ;; More involved HTML crawl case.
+             (let* ((pattern (if major-minor
+                                 (format #f "(~a|~a)" version major-minor)
+                                 (format #f "(~a)" version)))
+                    (m (string-match pattern s)))
+               (if m
+                   ;; Crawl parent and rewrite current component.
+                   (let* ((parent-url (string-join (reverse parents) "/"))
+                          (links (url->links parent-url))
+                          ;; The pattern matching the version.
+                          (pattern (string-append "^" (match:prefix m)
+                                                  "(" %version-rx ")"
+                                                  (match:suffix m) "$"))
+                          (candidates (filter-map
+                                       (lambda (l)
+                                         ;; Links may be followed by a
+                                         ;; trailing '/' in the case of
+                                         ;; directories.
+                                         (and-let*
+                                             ((l (strip-trailing-slash l))
+                                              (m (string-match pattern l))
+                                              (v (match:substring m 1)))
+                                           (cons v l)))
+                                       links)))
+                     ;; Retrieve the item having the largest version.
+                     (if (null? candidates)
+                         (error "no candidates found in rewrite-url")
+                         (cons (cdr (first (sort candidates
+                                                 (lambda (x y)
+                                                   (version>? (car x)
+                                                              (car y))))))
+                               parents)))
+                   ;; No version found in path component; continue.
+                   (cons s parents)))))
+       (reverse url-prefix-components)
+       path-components))
+     "/")))
+
 (define* (import-html-release base-url package
                               #:key
-                              (version #f)
+                              rewrite-url?
+                              version
                               (directory (string-append
                                           "/" (package-upstream-name package)))
                               file->signature)
@@ -534,11 +621,19 @@ (define* (import-html-release base-url package
 When FILE->SIGNATURE is omitted or #f, guess the detached signature file name,
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
-are unavailable."
-  (let* ((name (package-upstream-name package))
+are unavailable.
+
+When REWRITE-URL? is #t, versioned components in BASE-URL and/or DIRECTORY are
+also updated to the latest version, as explained in the doc of the
+\"rewrite-url\" procedure used."
+  (let* ((current-version (package-version package))
+         (name (package-upstream-name package))
          (url (if (string-null? directory)
                   base-url
                   (string-append base-url directory "/")))
+         (url (if rewrite-url?
+                  (rewrite-url url current-version #:to-version version)
+                  url))
          (links (map (cut canonicalize-url <> url) (url->links url))))
 
     (define (file->signature/guess url)
@@ -873,6 +968,7 @@ (define* (import-html-updatable-release package #:key (version #f))
                         (dirname (uri-path uri)))))
     (false-if-networking-error
      (import-html-release base package
+                          #:rewrite-url? #t
                           #:version version
                           #:directory directory))))
 
diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm
index 516e02ec6a..196a6f9092 100644
--- a/tests/gnu-maintenance.scm
+++ b/tests/gnu-maintenance.scm
@@ -147,4 +147,47 @@ (define-module (test-gnu-maintenance)
            (equal? (list expected-signature-url)
                    (upstream-source-signature-urls update))))))
 
+(test-equal "rewrite-url, to-version specified"
+  "https://download.qt.io/official_releases/qt/6.5/6.5.2/\
+submodules/qtbase-everywhere-src-6.5.2.tar.xz"
+  (rewrite-url "https://download.qt.io/official_releases/qt/6.3/6.3.2/\
+submodules/qtbase-everywhere-src-6.3.2.tar.xz" "6.3.2" #:to-version "6.5.2"))
+
+(test-equal "rewrite-url, without to-version"
+  "https://dist.libuv.org/dist/v1.46.0/libuv-v1.46.0.tar.gz"
+  (with-http-server
+      ;; First reply, crawling https://dist.libuv.org/dist/.
+      `((200 "\
+<!DOCTYPE html>
+<html>
+<head><title>Index of dist</title></head>
+<body>
+<a href=\"../\">../</a>
+<a href=\"v1.44.0/\" title=\"v1.44.0/\">v1.44.0/</a>
+<a href=\"v1.44.1/\" title=\"v1.44.1/\">v1.44.1/</a>
+<a href=\"v1.44.2/\" title=\"v1.44.2/\">v1.44.2/</a>
+<a href=\"v1.45.0/\" title=\"v1.45.0/\">v1.45.0/</a>
+<a href=\"v1.46.0/\" title=\"v1.46.0/\">v1.46.0/</a>
+</body>
+</html>")
+        ;; Second reply, crawling https://dist.libuv.org/dist/v1.46.0/.
+        (200 "\
+<!DOCTYPE html>
+<html>
+<head><title>Index of dist/v1.46.0</title></head>
+<body>
+<a href=\"../\">../</a>
+<a href=\"libuv-v1.46.0-dist.tar.gz\" title=\"libuv-v1.46.0-dist.tar.gz\">
+   libuv-v1.46.0-dist.tar.gz</a>
+<a href=\"libuv-v1.46.0-dist.tar.gz.sign\"
+   title=\"libuv-v1.46.0-dist.tar.gz.sign\">libuv-v1.46.0-dist.tar.gz.sign</a>
+<a href=\"libuv-v1.46.0.tar.gz\" title=\"libuv-v1.46.0.tar.gz\">
+   libuv-v1.46.0.tar.gz</a>
+<a href=\"libuv-v1.46.0.tar.gz.sign\" title=\"libuv-v1.46.0.tar.gz.sign\">
+   libuv-v1.46.0.tar.gz.sign</a>
+</body>
+</html>"))
+    (rewrite-url "https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz"
+                 "1.45.0")))
+
 (test-end)
-- 
2.41.0

[bug#65230] [PATCH v2 12/13] gnu-maintenance: Allow mirror URLs to fallback to the generic HTML updater.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (http-url?): Extract from html-updatable-package?,
modify to return the HTTP URL, and support the mirror:// scheme.
(%disallowed-hosting-sites): New variable, extracted from
html-updatable-package.
(html-updatable-package?): Rewrite a mirror:// URL to an HTTP or HTTPS one.
* guix/download.scm (%mirrors): Update comment.

---

Changes in v2:
- Update %mirrors comment to mention speed-related exceptions

 guix/download.scm        |  5 +++-
 guix/gnu-maintenance.scm | 58 +++++++++++++++++++++++++---------------
 2 files changed, 41 insertions(+), 22 deletions(-)

diff --git a/guix/download.scm b/guix/download.scm
index ce6ebd0df8..31a41e8183 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -51,7 +51,10 @@ (define-module (guix download)
 ;;; Code:
 
 (define %mirrors
-  ;; Mirror lists used when `mirror://' URLs are passed.
+  ;; Mirror lists used when `mirror://' URLs are passed.  The first mirror
+  ;; entry of each set should ideally be the most authoritative one, as that's
+  ;; what the generic HTML updater will pick to look for updates, with
+  ;; possible exceptions when the authoritative mirror is too slow.
   (let* ((gnu-mirrors
           '(;; This one redirects to a (supposedly) nearby and (supposedly)
             ;; up-to-date mirror.
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 3cd84ee3d7..2574e0f827 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -928,27 +928,40 @@ (define* (import-kernel.org-release package #:key (version #f))
                          #:directory directory
                          #:file->signature file->signature)))
 
-(define html-updatable-package?
-  ;; Return true if the given package may be handled by the generic HTML
-  ;; updater.
-  (let ((hosting-sites '("github.com" "github.io" "gitlab.com"
-                         "notabug.org" "sr.ht" "gitlab.inria.fr"
-                         "ftp.gnu.org" "download.savannah.gnu.org"
-                         "pypi.org" "crates.io" "rubygems.org"
-                         "bioconductor.org")))
-    (define http-url?
-      (url-predicate (lambda (url)
-                       (match (string->uri url)
-                         (#f #f)
-                         (uri
-                          (let ((scheme (uri-scheme uri))
-                                (host   (uri-host uri)))
-                            (and (memq scheme '(http https))
-                                 (not (member host hosting-sites)))))))))
-
-    (lambda (package)
-      (or (assoc-ref (package-properties package) 'release-monitoring-url)
-          (http-url? package)))))
+;;; These sites are disallowed for the generic HTML updater as there are
+;;; better means to query them.
+(define %disallowed-hosting-sites
+  '("github.com" "github.io" "gitlab.com"
+    "notabug.org" "sr.ht" "gitlab.inria.fr"
+    "ftp.gnu.org" "download.savannah.gnu.org"
+    "pypi.org" "crates.io" "rubygems.org"
+    "bioconductor.org"))
+
+(define (http-url? url)
+  "Return URL if URL has HTTP or HTTPS as its protocol.  If URL uses the
+special mirror:// protocol, substitute it with the first HTTP or HTTPS URL
+prefix from its set."
+  (match (string->uri url)
+    (#f #f)
+    (uri
+     (let ((scheme (uri-scheme uri))
+           (host   (uri-host uri)))
+       (or (and (memq scheme '(http https))
+                (not (member host %disallowed-hosting-sites))
+                url)
+           (and (eq? scheme 'mirror)
+                (and=> (find http-url?
+                             (assoc-ref %mirrors
+                                        (string->symbol host)))
+                       (lambda (url)
+                         (string-append (strip-trailing-slash url)
+                                        (uri-path uri))))))))))
+
+(define (html-updatable-package? package)
+  "Return true if the given package may be handled by the generic HTML
+updater."
+  (or (assoc-ref (package-properties package) 'release-monitoring-url)
+      ((url-predicate http-url?) package)))
 
 (define* (import-html-updatable-release package #:key (version #f))
   "Return the latest release of PACKAGE.  Do that by crawling the HTML page of
@@ -956,6 +969,9 @@ (define* (import-html-updatable-release package #:key (version #f))
 string to fetch a specific version."
   (let* ((uri       (string->uri
                      (match (origin-uri (package-source package))
+                       ((? (cut string-prefix? "mirror://" <>) url)
+                        ;; Retrieve the authoritative HTTP URL from a mirror.
+                        (http-url? url))
                        ((? string? url) url)
                        ((url _ ...) url))))
          (custom    (assoc-ref (package-properties package)
-- 
2.41.0

[bug#65230] [PATCH v2 13/13] gnu-maintenance: Consider Qt source tarballs as "release files".

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (release-file?): Use positive logic in doc.
Add a special case for Qt source archives.
* tests/gnu-maintenance.scm ("release-file?"): Update test.

---

Changes in v2:
- Also special case release file of Qt Creator

 guix/gnu-maintenance.scm  | 18 +++++++++++++-----
 tests/gnu-maintenance.scm |  5 ++++-
 2 files changed, 17 insertions(+), 6 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 2574e0f827..04827a9f27 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -258,8 +258,7 @@ (define %alpha-tarball-rx
   (make-regexp "^.*-.*[0-9](-|~|\\.)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
 
 (define (release-file? project file)
-  "Return #f if FILE is not a release tarball of PROJECT, otherwise return
-true."
+  "Return true if FILE is a release tarball of PROJECT."
   (and (not (member (file-extension file)
                     '("sig" "sign" "asc"
                       "md5sum" "sha1sum" "sha256sum")))
@@ -268,12 +267,21 @@ (define (release-file? project file)
                 ;; Filter out unrelated files, like `guile-www-1.1.1'.
                 ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
                 ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
+                ;; The '-everywhere-src' suffix is for Qt modular components.
                 (and=> (match:substring match 1)
                        (lambda (name)
                          (or (string-ci=? name project)
-                             (string-ci=? name
-                                          (string-append project
-                                                         "-src")))))))
+                             (string-ci=? name (string-append project "-src"))
+                             (string-ci=?
+                              name (string-append project "-everywhere-src"))
+                             ;; For older Qt releases such as version 5.
+                             (string-ci=?
+                              name (string-append
+                                    project "-everywhere-opensource-src"))
+                             ;; For Qt Creator.
+                             (string-ci=?
+                              name (string-append
+                                    project "-opensource-src")))))))
        (not (regexp-exec %alpha-tarball-rx file))
        (let ((s (tarball-sans-extension file)))
          (regexp-exec %package-name-rx s))))
diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm
index 196a6f9092..61ae295b96 100644
--- a/tests/gnu-maintenance.scm
+++ b/tests/gnu-maintenance.scm
@@ -40,7 +40,10 @@ (define-module (test-gnu-maintenance)
                 ("exiv2" "exiv2-0.27.3-Source.tar.gz")
                 ("mpg321" "mpg321_0.3.2.orig.tar.gz")
                 ("bvi" "bvi-1.4.1.src.tar.gz")
-                ("hostscope" "hostscope-V2.1.tgz")))
+                ("hostscope" "hostscope-V2.1.tgz")
+                ("qtbase" "qtbase-everywhere-src-6.5.2.tar.xz")
+                ("qtbase" "qtbase-everywhere-opensource-src-5.15.10.tar.xz")
+                ("qt-creator" "qt-creator-opensource-src-11.0.1.tar.xz")))
        (every (lambda (project+file)
                 (not (apply release-file? project+file)))
               '(("guile" "guile-www-1.1.1.tar.gz")
-- 
2.41.0

[bug#65230] [PATCH v3 01/10] gnu-maintenance: Make base-url argument of import-html-release required.

[Maxim Cournoyer]

It doesn't make sense to have it default to something like
"https://kernel.org/pub"; it should always be provided explicitly.

* guix/gnu-maintenance.scm (import-html-release) <#:base-url>: Turn keyword
argument into a positional argument.  Update doc.
* guix/gnu-maintenance.scm (import-savannah-release): Adjust call accordingly.
(import-kernel.org-release): Likewise.
(import-html-updatable-release): Likewise.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 18 +++++++-----------
 1 file changed, 7 insertions(+), 11 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 32712f7218..b95a45824e 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -483,15 +483,14 @@ (define (html-links sxml)
       (_
        links))))
 
-(define* (import-html-release package
+(define* (import-html-release base-url package
                               #:key
                               (version #f)
-                              (base-url "https://kernel.org/pub")
                               (directory (string-append "/" package))
                               file->signature)
-  "Return an <upstream-source> for the latest release of PACKAGE (a string) on
-SERVER under DIRECTORY, or #f. Optionally include a VERSION string to fetch a
-specific version.
+  "Return an <upstream-source> for the latest release of PACKAGE (a string)
+under DIRECTORY at BASE-URL, or #f. Optionally include a VERSION string to
+fetch a specific version.
 
 BASE-URL should be the URL of an HTML page, typically a directory listing as
 found on 'https://kernel.org/pub'.
@@ -730,9 +729,8 @@ (define* (import-savannah-release package #:key (version #f))
          (directory (dirname (uri-path uri))))
     ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
     ;; or whichever detached signature naming scheme PACKAGE uses.
-    (import-html-release package
+    (import-html-release %savannah-base package
                          #:version version
-                         #:base-url %savannah-base
                          #:directory directory)))
 
 (define* (latest-sourceforge-release package #:key (version #f))
@@ -824,9 +822,8 @@ (define* (import-kernel.org-release package #:key (version #f))
                        ((uri mirrors ...) uri))))
          (package   (package-upstream-name package))
          (directory (dirname (uri-path uri))))
-    (import-html-release package
+    (import-html-release %kernel.org-base package
                          #:version version
-                         #:base-url %kernel.org-base
                          #:directory directory
                          #:file->signature file->signature)))
 
@@ -870,9 +867,8 @@ (define* (import-html-updatable-release package #:key (version #f))
                         (dirname (uri-path uri))))
          (package   (package-upstream-name package)))
     (false-if-networking-error
-     (import-html-release package
+     (import-html-release base package
                           #:version version
-                          #:base-url base
                           #:directory directory))))
 
 (define %gnu-updater

base-commit: b03f4ff76e7502d4636ff805727df437c17de21a
-- 
2.41.0

[bug#65230] [PATCH v3 02/10] gnu-maintenance: Fix docstring.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (import-kernel.org-release): Fix docstring.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index b95a45824e..a314923d3b 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -489,7 +489,7 @@ (define* (import-html-release base-url package
                               (directory (string-append "/" package))
                               file->signature)
   "Return an <upstream-source> for the latest release of PACKAGE (a string)
-under DIRECTORY at BASE-URL, or #f. Optionally include a VERSION string to
+under DIRECTORY at BASE-URL, or #f.  Optionally include a VERSION string to
 fetch a specific version.
 
 BASE-URL should be the URL of an HTML page, typically a directory listing as
@@ -806,7 +806,7 @@ (define* (import-xorg-release package #:key (version #f))
       (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
 
 (define* (import-kernel.org-release package #:key (version #f))
-  "Return the latest release of PACKAGE, the name of a kernel.org package.
+  "Return the latest release of PACKAGE, a Linux kernel package.
 Optionally include a VERSION string to fetch a specific version."
   (define %kernel.org-base
     ;; This URL and sub-directories thereof are nginx-generated directory
-- 
2.41.0

[bug#65230] [PATCH v3 03/10] gnu-maintenance: Extract url->links procedure.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (url->links): New procedure.
(import-html-release): Use it.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index a314923d3b..2e0fc3e8ab 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -483,6 +483,14 @@ (define (html-links sxml)
       (_
        links))))
 
+(define (url->links url)
+  "Return the unique links on the HTML page accessible at URL."
+  (let* ((uri   (string->uri url))
+         (port  (http-fetch/cached uri #:ttl 3600))
+         (sxml  (html->sxml port)))
+    (close-port port)
+    (delete-duplicates (html-links sxml))))
+
 (define* (import-html-release base-url package
                               #:key
                               (version #f)
@@ -499,12 +507,10 @@ (define* (import-html-release base-url package
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
 are unavailable."
-  (let* ((uri   (string->uri (if (string-null? directory)
-                                 base-url
-                                 (string-append base-url directory "/"))))
-         (port  (http-fetch/cached uri #:ttl 3600))
-         (sxml  (html->sxml port))
-         (links (delete-duplicates (html-links sxml))))
+  (let* ((url (if (string-null? directory)
+                  base-url
+                  (string-append base-url directory "/")))
+         (links (url->links url)))
     (define (file->signature/guess url)
       (let ((base (basename url)))
         (any (lambda (link)
@@ -562,7 +568,6 @@ (define* (import-html-release base-url package
     (define candidates
       (filter-map url->release links))
 
-    (close-port port)
     (match candidates
       (() #f)
       ((first . _)
-- 
2.41.0

[bug#65230] [PATCH v3 04/10] gnu-maintenance: Fix indentation.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm: Re-indent file.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 38 +++++++++++++++++++-------------------
 1 file changed, 19 insertions(+), 19 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 2e0fc3e8ab..67abbc1c5a 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -578,11 +578,11 @@ (define* (import-html-release base-url package
                  (coalesce-sources candidates))
            ;; Select the most recent release and return it.
            (reduce (lambda (r1 r2)
-                         (if (version>? (upstream-source-version r1)
-                                        (upstream-source-version r2))
-                             r1 r2))
-                       first
-                       (coalesce-sources candidates)))))))
+                     (if (version>? (upstream-source-version r1)
+                                    (upstream-source-version r2))
+                         r1 r2))
+                   first
+                   (coalesce-sources candidates)))))))
 
 \f
 ;;;
@@ -656,20 +656,20 @@ (define* (import-gnu-release package #:key (version #f))
            (tarballs (filter (lambda (file)
                                (string=? version (tarball->version file)))
                              relevant)))
-    (match tarballs
-           (() #f)
-           (_
-            (upstream-source
-             (package name)
-             (version version)
-             (urls (map (lambda (file)
-                          (string-append "mirror://gnu/"
-                                         (string-drop file
-                                                      (string-length "/gnu/"))))
-                       ;; Sort so that the tarball with the same compression
-                       ;; format as currently used in PACKAGE comes first.
-                       (sort tarballs better-tarball?)))
-             (signature-urls (map (cut string-append <> ".sig") urls))))))))
+      (match tarballs
+        (() #f)
+        (_
+         (upstream-source
+          (package name)
+          (version version)
+          (urls (map (lambda (file)
+                       (string-append "mirror://gnu/"
+                                      (string-drop file
+                                                   (string-length "/gnu/"))))
+                     ;; Sort so that the tarball with the same compression
+                     ;; format as currently used in PACKAGE comes first.
+                     (sort tarballs better-tarball?)))
+          (signature-urls (map (cut string-append <> ".sig") urls))))))))
 
 (define %package-name-rx
   ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses
-- 
2.41.0

[bug#65230] [PATCH v3 05/10] gnu-maintenance: Accept package object in 'import-html-release' procedure.

[Maxim Cournoyer]

This is in preparation for a new URL rewriting feature, which will need to
have the current version information available.

* guix/gnu-maintenance.scm (import-html-release): Update doc.  Adjust default
value of the DIRECTORY argument.  Bind PACKAGE in lexical scope so that its
value there is unchanged.
(import-savannah-release, import-kernel.org-release)
(import-html-updatable-release): Adjust accordingly.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 17 ++++++++---------
 1 file changed, 8 insertions(+), 9 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 67abbc1c5a..13d6c1c7f2 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -494,11 +494,12 @@ (define (url->links url)
 (define* (import-html-release base-url package
                               #:key
                               (version #f)
-                              (directory (string-append "/" package))
+                              (directory (string-append
+                                          "/" (package-upstream-name package)))
                               file->signature)
-  "Return an <upstream-source> for the latest release of PACKAGE (a string)
-under DIRECTORY at BASE-URL, or #f.  Optionally include a VERSION string to
-fetch a specific version.
+  "Return an <upstream-source> for the latest release of PACKAGE under
+DIRECTORY at BASE-URL, or #f.  Optionally include a VERSION string to fetch a
+specific version.
 
 BASE-URL should be the URL of an HTML page, typically a directory listing as
 found on 'https://kernel.org/pub'.
@@ -507,7 +508,8 @@ (define* (import-html-release base-url package
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
 are unavailable."
-  (let* ((url (if (string-null? directory)
+  (let* ((package (package-upstream-name package))
+         (url (if (string-null? directory)
                   base-url
                   (string-append base-url directory "/")))
          (links (url->links url)))
@@ -730,7 +732,6 @@ (define* (import-savannah-release package #:key (version #f))
                      (match (origin-uri (package-source package))
                        ((? string? uri) uri)
                        ((uri mirrors ...) uri))))
-         (package   (package-upstream-name package))
          (directory (dirname (uri-path uri))))
     ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
     ;; or whichever detached signature naming scheme PACKAGE uses.
@@ -825,7 +826,6 @@ (define* (import-kernel.org-release package #:key (version #f))
                      (match (origin-uri (package-source package))
                        ((? string? uri) uri)
                        ((uri mirrors ...) uri))))
-         (package   (package-upstream-name package))
          (directory (dirname (uri-path uri))))
     (import-html-release %kernel.org-base package
                          #:version version
@@ -869,8 +869,7 @@ (define* (import-html-updatable-release package #:key (version #f))
                                        "://" (uri-host uri))))
          (directory (if custom
                         ""
-                        (dirname (uri-path uri))))
-         (package   (package-upstream-name package)))
+                        (dirname (uri-path uri)))))
     (false-if-networking-error
      (import-html-release base package
                           #:version version
-- 
2.41.0

[bug#65230] [PATCH v3 06/10] gnu-maintenance: Document nested procedures in 'import-html-release'.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (import-html-release): Add docstring to the
'file->signature/guess' and 'url->release' nested procedures.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 13d6c1c7f2..9bab8e9e5f 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -514,6 +514,7 @@ (define* (import-html-release base-url package
                   (string-append base-url directory "/")))
          (links (url->links url)))
     (define (file->signature/guess url)
+      "Return the first link that matches a signature extension, else #f."
       (let ((base (basename url)))
         (any (lambda (link)
                (any (lambda (extension)
@@ -524,6 +525,8 @@ (define* (import-html-release base-url package
              links)))
 
     (define (url->release url)
+      "Return an <upstream-source> object if a release file was found at URL,
+else #f."
       (let* ((base (basename url))
              (base-url (string-append base-url directory))
              (url  (cond ((and=> (string->uri url) uri-scheme) ;full URL?
@@ -574,7 +577,7 @@ (define* (import-html-release base-url package
       (() #f)
       ((first . _)
        (if version
-           ;; find matching release version and return it
+           ;; Find matching release version and return it.
            (find (lambda (upstream)
                    (string=? (upstream-source-version upstream) version))
                  (coalesce-sources candidates))
-- 
2.41.0

[bug#65230] [PATCH v3 07/10] gnu-maintenance: Extract 'canonicalize-url' from 'import-html-release'.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm
(canonicalize-url): New procedure, extracted from...
(import-html-release): ... here.  Use it.  Rename inner PACKAGE variable to
NAME, to explicit it is a string and not a package object.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 70 +++++++++++++++++++---------------------
 1 file changed, 34 insertions(+), 36 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 9bab8e9e5f..abba891d4b 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -491,6 +491,33 @@ (define (url->links url)
     (close-port port)
     (delete-duplicates (html-links sxml))))
 
+(define (canonicalize-url url base-url)
+  "Make relative URL absolute, by appending URL to BASE-URL as required.  If
+URL is a directory instead of a file, it should be suffixed with a slash (/)."
+  (cond ((and=> (string->uri url) uri-scheme)
+         ;; Fully specified URL.
+         url)
+        ((string-prefix? "//" url)
+         ;; Full URL lacking a URI scheme.  Reuse the URI scheme of the
+         ;; document that contains the URL.
+         (string-append (symbol->string (uri-scheme (string->uri base-url)))
+                        ":" url))
+        ((string-prefix? "/" url)
+         ;; Absolute URL.
+         (let ((uri (string->uri base-url)))
+           (uri->string
+            (build-uri (uri-scheme uri)
+                       #:host (uri-host uri)
+                       #:port (uri-port uri)
+                       #:path url))))
+        ;; URL is relative to BASE-URL, which is assumed to be a directory.
+        ((string-suffix? "/" base-url)
+         (string-append base-url url))
+        (else
+         ;; URL is relative to BASE-URL, which is assumed to denote a file
+         ;; within a directory.
+         (string-append (dirname base-url) "/" url))))
+
 (define* (import-html-release base-url package
                               #:key
                               (version #f)
@@ -508,11 +535,12 @@ (define* (import-html-release base-url package
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
 are unavailable."
-  (let* ((package (package-upstream-name package))
+  (let* ((name (package-upstream-name package))
          (url (if (string-null? directory)
                   base-url
                   (string-append base-url directory "/")))
-         (links (url->links url)))
+         (links (map (cut canonicalize-url <> url) (url->links url))))
+
     (define (file->signature/guess url)
       "Return the first link that matches a signature extension, else #f."
       (let ((base (basename url)))
@@ -526,42 +554,12 @@ (define* (import-html-release base-url package
 
     (define (url->release url)
       "Return an <upstream-source> object if a release file was found at URL,
-else #f."
-      (let* ((base (basename url))
-             (base-url (string-append base-url directory))
-             (url  (cond ((and=> (string->uri url) uri-scheme) ;full URL?
-                          url)
-                         ;; full URL, except for URI scheme.  Reuse the URI
-                         ;; scheme of the document that contains the link.
-                         ((string-prefix? "//" url)
-                          (string-append
-                           (symbol->string (uri-scheme (string->uri base-url)))
-                           ":" url))
-                         ((string-prefix? "/" url) ;absolute path?
-                          (let ((uri (string->uri base-url)))
-                            (uri->string
-                             (build-uri (uri-scheme uri)
-                                        #:host (uri-host uri)
-                                        #:port (uri-port uri)
-                                        #:path url))))
-
-                         ;; URL is a relative path and BASE-URL may or may not
-                         ;; end in slash.
-                         ((string-suffix? "/" base-url)
-                          (string-append base-url url))
-                         (else
-                          ;; If DIRECTORY is non-empty, assume BASE-URL
-                          ;; denotes a directory; otherwise, assume BASE-URL
-                          ;; denotes a file within a directory, and that URL
-                          ;; is relative to that directory.
-                          (string-append (if (string-null? directory)
-                                             (dirname base-url)
-                                             base-url)
-                                         "/" url)))))
-        (and (release-file? package base)
+else #f.  URL is assumed to fully specified."
+      (let ((base (basename url)))
+        (and (release-file? name base)
              (let ((version (tarball->version base)))
                (upstream-source
-                (package package)
+                (package name)
                 (version version)
                 ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp://
                 ;; URLs during "guix refresh -u".
-- 
2.41.0

[bug#65230] [PATCH v3 08/10] gnu-maintenance: Add support to rewrite version in URL path.

[Maxim Cournoyer]

Fixes <https://issues.guix.gnu.org/64015>.

Previously, the generic HTML updater would only look for the list of files
found at the parent of its current source URL, ignoring that the URL may embed
the version elsewhere in its path.  This could cause 'guix refresh' to report
no updates available, while in fact there were, such as for 'libuv'.

* guix/gnu-maintenance.scm (strip-trailing-slash): New procedure.
(%version-rx): New variable.
(rewrite-url): New procedure.
(import-html-release): New rewrite-url? argument.  When true, use the above
procedure.
(import-html-updatable-release): Call import-html-release with #:rewrite-url
set to #t.
* tests/gnu-maintenance.scm ("rewrite-url, to-version specified")
("rewrite-url, without to-version"): New tests.
---

(no changes since v1)

 guix/gnu-maintenance.scm  | 102 ++++++++++++++++++++++++++++++++++++--
 tests/gnu-maintenance.scm |  43 ++++++++++++++++
 2 files changed, 142 insertions(+), 3 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index abba891d4b..3cd84ee3d7 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,6 +27,7 @@ (define-module (guix gnu-maintenance)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (rnrs io ports)
@@ -61,6 +63,7 @@ (define-module (guix gnu-maintenance)
             gnu-package?
 
             uri-mirror-rewrite
+            rewrite-url
 
             release-file?
             releases
@@ -518,9 +521,93 @@ (define (canonicalize-url url base-url)
          ;; within a directory.
          (string-append (dirname base-url) "/" url))))
 
+(define (strip-trailing-slash s)
+  "Strip any trailing slash from S, a string."
+  (if (string-suffix? "/" s)
+      (string-drop-right s 1)
+      s))
+
+;;; TODO: Extend to support the RPM and GNOME version schemes?
+(define %version-rx "[0-9.]+")
+
+(define* (rewrite-url url version #:key to-version)
+  "Rewrite URL so that the URL path components matching the current VERSION or
+VERSION-MAJOR.VERSION-MINOR are updated with that of the latest version found
+by crawling the corresponding URL directories.  Alternatively, when TO-VERSION
+is specified, rewrite version matches directly to it without crawling URL.
+
+For example, the URL
+\"https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz\" could be
+rewritten to something like
+\"https://dist.libuv.org/dist/v1.46.0/libuv-v1.46.0.tar.gz\"."
+  ;; XXX: major-minor may be #f if version is not a triplet but a single
+  ;; number such as "2".
+  (let* ((major-minor (false-if-exception (version-major+minor version)))
+         (to-major-minor (false-if-exception
+                          (and=> to-version version-major+minor)))
+         (uri (string->uri url))
+         (url-prefix (string-drop-right url (string-length (uri-path uri))))
+         (url-prefix-components (string-split url-prefix #\/))
+         (path (uri-path uri))
+         ;; Strip a forward slash on the path to avoid a double slash when
+         ;; string-joining later.
+         (path (if (string-prefix? "/" path)
+                   (string-drop path 1)
+                   path))
+         (path-components (string-split path #\/)))
+    (string-join
+     (reverse
+      (fold
+       (lambda (s parents)
+         (if to-version
+             ;; Direct rewrite case; the archive is assumed to exist.
+             (let ((u (string-replace-substring s version to-version)))
+               (cons (if (and major-minor to-major-minor)
+                         (string-replace-substring u major-minor to-major-minor)
+                         u)
+                     parents))
+             ;; More involved HTML crawl case.
+             (let* ((pattern (if major-minor
+                                 (format #f "(~a|~a)" version major-minor)
+                                 (format #f "(~a)" version)))
+                    (m (string-match pattern s)))
+               (if m
+                   ;; Crawl parent and rewrite current component.
+                   (let* ((parent-url (string-join (reverse parents) "/"))
+                          (links (url->links parent-url))
+                          ;; The pattern matching the version.
+                          (pattern (string-append "^" (match:prefix m)
+                                                  "(" %version-rx ")"
+                                                  (match:suffix m) "$"))
+                          (candidates (filter-map
+                                       (lambda (l)
+                                         ;; Links may be followed by a
+                                         ;; trailing '/' in the case of
+                                         ;; directories.
+                                         (and-let*
+                                             ((l (strip-trailing-slash l))
+                                              (m (string-match pattern l))
+                                              (v (match:substring m 1)))
+                                           (cons v l)))
+                                       links)))
+                     ;; Retrieve the item having the largest version.
+                     (if (null? candidates)
+                         (error "no candidates found in rewrite-url")
+                         (cons (cdr (first (sort candidates
+                                                 (lambda (x y)
+                                                   (version>? (car x)
+                                                              (car y))))))
+                               parents)))
+                   ;; No version found in path component; continue.
+                   (cons s parents)))))
+       (reverse url-prefix-components)
+       path-components))
+     "/")))
+
 (define* (import-html-release base-url package
                               #:key
-                              (version #f)
+                              rewrite-url?
+                              version
                               (directory (string-append
                                           "/" (package-upstream-name package)))
                               file->signature)
@@ -534,11 +621,19 @@ (define* (import-html-release base-url package
 When FILE->SIGNATURE is omitted or #f, guess the detached signature file name,
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
-are unavailable."
-  (let* ((name (package-upstream-name package))
+are unavailable.
+
+When REWRITE-URL? is #t, versioned components in BASE-URL and/or DIRECTORY are
+also updated to the latest version, as explained in the doc of the
+\"rewrite-url\" procedure used."
+  (let* ((current-version (package-version package))
+         (name (package-upstream-name package))
          (url (if (string-null? directory)
                   base-url
                   (string-append base-url directory "/")))
+         (url (if rewrite-url?
+                  (rewrite-url url current-version #:to-version version)
+                  url))
          (links (map (cut canonicalize-url <> url) (url->links url))))
 
     (define (file->signature/guess url)
@@ -873,6 +968,7 @@ (define* (import-html-updatable-release package #:key (version #f))
                         (dirname (uri-path uri)))))
     (false-if-networking-error
      (import-html-release base package
+                          #:rewrite-url? #t
                           #:version version
                           #:directory directory))))
 
diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm
index 516e02ec6a..196a6f9092 100644
--- a/tests/gnu-maintenance.scm
+++ b/tests/gnu-maintenance.scm
@@ -147,4 +147,47 @@ (define-module (test-gnu-maintenance)
            (equal? (list expected-signature-url)
                    (upstream-source-signature-urls update))))))
 
+(test-equal "rewrite-url, to-version specified"
+  "https://download.qt.io/official_releases/qt/6.5/6.5.2/\
+submodules/qtbase-everywhere-src-6.5.2.tar.xz"
+  (rewrite-url "https://download.qt.io/official_releases/qt/6.3/6.3.2/\
+submodules/qtbase-everywhere-src-6.3.2.tar.xz" "6.3.2" #:to-version "6.5.2"))
+
+(test-equal "rewrite-url, without to-version"
+  "https://dist.libuv.org/dist/v1.46.0/libuv-v1.46.0.tar.gz"
+  (with-http-server
+      ;; First reply, crawling https://dist.libuv.org/dist/.
+      `((200 "\
+<!DOCTYPE html>
+<html>
+<head><title>Index of dist</title></head>
+<body>
+<a href=\"../\">../</a>
+<a href=\"v1.44.0/\" title=\"v1.44.0/\">v1.44.0/</a>
+<a href=\"v1.44.1/\" title=\"v1.44.1/\">v1.44.1/</a>
+<a href=\"v1.44.2/\" title=\"v1.44.2/\">v1.44.2/</a>
+<a href=\"v1.45.0/\" title=\"v1.45.0/\">v1.45.0/</a>
+<a href=\"v1.46.0/\" title=\"v1.46.0/\">v1.46.0/</a>
+</body>
+</html>")
+        ;; Second reply, crawling https://dist.libuv.org/dist/v1.46.0/.
+        (200 "\
+<!DOCTYPE html>
+<html>
+<head><title>Index of dist/v1.46.0</title></head>
+<body>
+<a href=\"../\">../</a>
+<a href=\"libuv-v1.46.0-dist.tar.gz\" title=\"libuv-v1.46.0-dist.tar.gz\">
+   libuv-v1.46.0-dist.tar.gz</a>
+<a href=\"libuv-v1.46.0-dist.tar.gz.sign\"
+   title=\"libuv-v1.46.0-dist.tar.gz.sign\">libuv-v1.46.0-dist.tar.gz.sign</a>
+<a href=\"libuv-v1.46.0.tar.gz\" title=\"libuv-v1.46.0.tar.gz\">
+   libuv-v1.46.0.tar.gz</a>
+<a href=\"libuv-v1.46.0.tar.gz.sign\" title=\"libuv-v1.46.0.tar.gz.sign\">
+   libuv-v1.46.0.tar.gz.sign</a>
+</body>
+</html>"))
+    (rewrite-url "https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz"
+                 "1.45.0")))
+
 (test-end)
-- 
2.41.0

[bug#65230] [PATCH v3 09/10] gnu-maintenance: Allow mirror URLs to fallback to the generic HTML updater.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (http-url?): Extract from html-updatable-package?,
modify to return the HTTP URL, and support the mirror:// scheme.
(%disallowed-hosting-sites): New variable, extracted from
html-updatable-package.
(html-updatable-package?): Rewrite a mirror:// URL to an HTTP or HTTPS one.
* guix/download.scm (%mirrors): Update comment.

---

(no changes since v2)

Changes in v2:
- Update %mirrors comment to mention speed-related exceptions

 guix/download.scm        |  5 +++-
 guix/gnu-maintenance.scm | 58 +++++++++++++++++++++++++---------------
 2 files changed, 41 insertions(+), 22 deletions(-)

diff --git a/guix/download.scm b/guix/download.scm
index 30d7c5a86e..334290c7fb 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -51,7 +51,10 @@ (define-module (guix download)
 ;;; Code:
 
 (define %mirrors
-  ;; Mirror lists used when `mirror://' URLs are passed.
+  ;; Mirror lists used when `mirror://' URLs are passed.  The first mirror
+  ;; entry of each set should ideally be the most authoritative one, as that's
+  ;; what the generic HTML updater will pick to look for updates, with
+  ;; possible exceptions when the authoritative mirror is too slow.
   (let* ((gnu-mirrors
           '(;; This one redirects to a (supposedly) nearby and (supposedly)
             ;; up-to-date mirror.
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 3cd84ee3d7..2574e0f827 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -928,27 +928,40 @@ (define* (import-kernel.org-release package #:key (version #f))
                          #:directory directory
                          #:file->signature file->signature)))
 
-(define html-updatable-package?
-  ;; Return true if the given package may be handled by the generic HTML
-  ;; updater.
-  (let ((hosting-sites '("github.com" "github.io" "gitlab.com"
-                         "notabug.org" "sr.ht" "gitlab.inria.fr"
-                         "ftp.gnu.org" "download.savannah.gnu.org"
-                         "pypi.org" "crates.io" "rubygems.org"
-                         "bioconductor.org")))
-    (define http-url?
-      (url-predicate (lambda (url)
-                       (match (string->uri url)
-                         (#f #f)
-                         (uri
-                          (let ((scheme (uri-scheme uri))
-                                (host   (uri-host uri)))
-                            (and (memq scheme '(http https))
-                                 (not (member host hosting-sites)))))))))
-
-    (lambda (package)
-      (or (assoc-ref (package-properties package) 'release-monitoring-url)
-          (http-url? package)))))
+;;; These sites are disallowed for the generic HTML updater as there are
+;;; better means to query them.
+(define %disallowed-hosting-sites
+  '("github.com" "github.io" "gitlab.com"
+    "notabug.org" "sr.ht" "gitlab.inria.fr"
+    "ftp.gnu.org" "download.savannah.gnu.org"
+    "pypi.org" "crates.io" "rubygems.org"
+    "bioconductor.org"))
+
+(define (http-url? url)
+  "Return URL if URL has HTTP or HTTPS as its protocol.  If URL uses the
+special mirror:// protocol, substitute it with the first HTTP or HTTPS URL
+prefix from its set."
+  (match (string->uri url)
+    (#f #f)
+    (uri
+     (let ((scheme (uri-scheme uri))
+           (host   (uri-host uri)))
+       (or (and (memq scheme '(http https))
+                (not (member host %disallowed-hosting-sites))
+                url)
+           (and (eq? scheme 'mirror)
+                (and=> (find http-url?
+                             (assoc-ref %mirrors
+                                        (string->symbol host)))
+                       (lambda (url)
+                         (string-append (strip-trailing-slash url)
+                                        (uri-path uri))))))))))
+
+(define (html-updatable-package? package)
+  "Return true if the given package may be handled by the generic HTML
+updater."
+  (or (assoc-ref (package-properties package) 'release-monitoring-url)
+      ((url-predicate http-url?) package)))
 
 (define* (import-html-updatable-release package #:key (version #f))
   "Return the latest release of PACKAGE.  Do that by crawling the HTML page of
@@ -956,6 +969,9 @@ (define* (import-html-updatable-release package #:key (version #f))
 string to fetch a specific version."
   (let* ((uri       (string->uri
                      (match (origin-uri (package-source package))
+                       ((? (cut string-prefix? "mirror://" <>) url)
+                        ;; Retrieve the authoritative HTTP URL from a mirror.
+                        (http-url? url))
                        ((? string? url) url)
                        ((url _ ...) url))))
          (custom    (assoc-ref (package-properties package)
-- 
2.41.0

[bug#65230] [PATCH v3 10/10] gnu-maintenance: Consider Qt source tarballs as "release files".

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (release-file?): Use positive logic in doc.
Add a special case for Qt source archives.
* tests/gnu-maintenance.scm ("release-file?"): Update test.

---

Changes in v3:
- Move a couple Qt-specific commits to the qt-updates branch

Changes in v2:
- Also special case release file of Qt Creator

 guix/gnu-maintenance.scm  | 18 +++++++++++++-----
 tests/gnu-maintenance.scm |  5 ++++-
 2 files changed, 17 insertions(+), 6 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 2574e0f827..04827a9f27 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -258,8 +258,7 @@ (define %alpha-tarball-rx
   (make-regexp "^.*-.*[0-9](-|~|\\.)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
 
 (define (release-file? project file)
-  "Return #f if FILE is not a release tarball of PROJECT, otherwise return
-true."
+  "Return true if FILE is a release tarball of PROJECT."
   (and (not (member (file-extension file)
                     '("sig" "sign" "asc"
                       "md5sum" "sha1sum" "sha256sum")))
@@ -268,12 +267,21 @@ (define (release-file? project file)
                 ;; Filter out unrelated files, like `guile-www-1.1.1'.
                 ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
                 ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
+                ;; The '-everywhere-src' suffix is for Qt modular components.
                 (and=> (match:substring match 1)
                        (lambda (name)
                          (or (string-ci=? name project)
-                             (string-ci=? name
-                                          (string-append project
-                                                         "-src")))))))
+                             (string-ci=? name (string-append project "-src"))
+                             (string-ci=?
+                              name (string-append project "-everywhere-src"))
+                             ;; For older Qt releases such as version 5.
+                             (string-ci=?
+                              name (string-append
+                                    project "-everywhere-opensource-src"))
+                             ;; For Qt Creator.
+                             (string-ci=?
+                              name (string-append
+                                    project "-opensource-src")))))))
        (not (regexp-exec %alpha-tarball-rx file))
        (let ((s (tarball-sans-extension file)))
          (regexp-exec %package-name-rx s))))
diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm
index 196a6f9092..61ae295b96 100644
--- a/tests/gnu-maintenance.scm
+++ b/tests/gnu-maintenance.scm
@@ -40,7 +40,10 @@ (define-module (test-gnu-maintenance)
                 ("exiv2" "exiv2-0.27.3-Source.tar.gz")
                 ("mpg321" "mpg321_0.3.2.orig.tar.gz")
                 ("bvi" "bvi-1.4.1.src.tar.gz")
-                ("hostscope" "hostscope-V2.1.tgz")))
+                ("hostscope" "hostscope-V2.1.tgz")
+                ("qtbase" "qtbase-everywhere-src-6.5.2.tar.xz")
+                ("qtbase" "qtbase-everywhere-opensource-src-5.15.10.tar.xz")
+                ("qt-creator" "qt-creator-opensource-src-11.0.1.tar.xz")))
        (every (lambda (project+file)
                 (not (apply release-file? project+file)))
               '(("guile" "guile-www-1.1.1.tar.gz")
-- 
2.41.0

[bug#65230] [PATCH v4 01/10] gnu-maintenance: Make base-url argument of import-html-release required.

[Maxim Cournoyer]

It doesn't make sense to have it default to something like
"https://kernel.org/pub"; it should always be provided explicitly.

* guix/gnu-maintenance.scm (import-html-release) <#:base-url>: Turn keyword
argument into a positional argument.  Update doc.
* guix/gnu-maintenance.scm (import-savannah-release): Adjust call accordingly.
(import-kernel.org-release): Likewise.
(import-html-updatable-release): Likewise.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 18 +++++++-----------
 1 file changed, 7 insertions(+), 11 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 5c16a7617d..198d72fc86 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -483,15 +483,14 @@ (define (html-links sxml)
       (_
        links))))
 
-(define* (import-html-release package
+(define* (import-html-release base-url package
                               #:key
                               (version #f)
-                              (base-url "https://kernel.org/pub")
                               (directory (string-append "/" package))
                               file->signature)
-  "Return an <upstream-source> for the latest release of PACKAGE (a string) on
-SERVER under DIRECTORY, or #f. Optionally include a VERSION string to fetch a
-specific version.
+  "Return an <upstream-source> for the latest release of PACKAGE (a string)
+under DIRECTORY at BASE-URL, or #f. Optionally include a VERSION string to
+fetch a specific version.
 
 BASE-URL should be the URL of an HTML page, typically a directory listing as
 found on 'https://kernel.org/pub'.
@@ -730,9 +729,8 @@ (define* (import-savannah-release package #:key (version #f))
          (directory (dirname (uri-path uri))))
     ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
     ;; or whichever detached signature naming scheme PACKAGE uses.
-    (import-html-release package
+    (import-html-release %savannah-base package
                          #:version version
-                         #:base-url %savannah-base
                          #:directory directory)))
 
 (define* (latest-sourceforge-release package #:key (version #f))
@@ -824,9 +822,8 @@ (define* (import-kernel.org-release package #:key (version #f))
                        ((uri mirrors ...) uri))))
          (package   (package-upstream-name package))
          (directory (dirname (uri-path uri))))
-    (import-html-release package
+    (import-html-release %kernel.org-base package
                          #:version version
-                         #:base-url %kernel.org-base
                          #:directory directory
                          #:file->signature file->signature)))
 
@@ -874,9 +871,8 @@ (define* (import-html-updatable-release package #:key (version #f))
                         (dirname (uri-path uri))))
          (package   (package-upstream-name package)))
     (false-if-networking-error
-     (import-html-release package
+     (import-html-release base package
                           #:version version
-                          #:base-url base
                           #:directory directory))))
 
 (define %gnu-updater

base-commit: c655231b72ac28b5a433069fcf86a835c9c83691
-- 
2.41.0

[bug#65230] [PATCH v4 02/10] gnu-maintenance: Fix docstring.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (import-kernel.org-release): Fix docstring.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 198d72fc86..6db0dd952c 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -489,7 +489,7 @@ (define* (import-html-release base-url package
                               (directory (string-append "/" package))
                               file->signature)
   "Return an <upstream-source> for the latest release of PACKAGE (a string)
-under DIRECTORY at BASE-URL, or #f. Optionally include a VERSION string to
+under DIRECTORY at BASE-URL, or #f.  Optionally include a VERSION string to
 fetch a specific version.
 
 BASE-URL should be the URL of an HTML page, typically a directory listing as
@@ -806,7 +806,7 @@ (define* (import-xorg-release package #:key (version #f))
       (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
 
 (define* (import-kernel.org-release package #:key (version #f))
-  "Return the latest release of PACKAGE, the name of a kernel.org package.
+  "Return the latest release of PACKAGE, a Linux kernel package.
 Optionally include a VERSION string to fetch a specific version."
   (define %kernel.org-base
     ;; This URL and sub-directories thereof are nginx-generated directory
-- 
2.41.0

[bug#65230] [PATCH v4 03/10] gnu-maintenance: Extract url->links procedure.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (url->links): New procedure.
(import-html-release): Use it.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 6db0dd952c..fc9cf50f29 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -483,6 +483,14 @@ (define (html-links sxml)
       (_
        links))))
 
+(define (url->links url)
+  "Return the unique links on the HTML page accessible at URL."
+  (let* ((uri   (string->uri url))
+         (port  (http-fetch/cached uri #:ttl 3600))
+         (sxml  (html->sxml port)))
+    (close-port port)
+    (delete-duplicates (html-links sxml))))
+
 (define* (import-html-release base-url package
                               #:key
                               (version #f)
@@ -499,12 +507,10 @@ (define* (import-html-release base-url package
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
 are unavailable."
-  (let* ((uri   (string->uri (if (string-null? directory)
-                                 base-url
-                                 (string-append base-url directory "/"))))
-         (port  (http-fetch/cached uri #:ttl 3600))
-         (sxml  (html->sxml port))
-         (links (delete-duplicates (html-links sxml))))
+  (let* ((url (if (string-null? directory)
+                  base-url
+                  (string-append base-url directory "/")))
+         (links (url->links url)))
     (define (file->signature/guess url)
       (let ((base (basename url)))
         (any (lambda (link)
@@ -562,7 +568,6 @@ (define* (import-html-release base-url package
     (define candidates
       (filter-map url->release links))
 
-    (close-port port)
     (match candidates
       (() #f)
       ((first . _)
-- 
2.41.0

[bug#65230] [PATCH v4 04/10] gnu-maintenance: Fix indentation.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm: Re-indent file.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 38 +++++++++++++++++++-------------------
 1 file changed, 19 insertions(+), 19 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index fc9cf50f29..30792db60f 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -578,11 +578,11 @@ (define* (import-html-release base-url package
                  (coalesce-sources candidates))
            ;; Select the most recent release and return it.
            (reduce (lambda (r1 r2)
-                         (if (version>? (upstream-source-version r1)
-                                        (upstream-source-version r2))
-                             r1 r2))
-                       first
-                       (coalesce-sources candidates)))))))
+                     (if (version>? (upstream-source-version r1)
+                                    (upstream-source-version r2))
+                         r1 r2))
+                   first
+                   (coalesce-sources candidates)))))))
 
 \f
 ;;;
@@ -656,20 +656,20 @@ (define* (import-gnu-release package #:key (version #f))
            (tarballs (filter (lambda (file)
                                (string=? version (tarball->version file)))
                              relevant)))
-    (match tarballs
-           (() #f)
-           (_
-            (upstream-source
-             (package name)
-             (version version)
-             (urls (map (lambda (file)
-                          (string-append "mirror://gnu/"
-                                         (string-drop file
-                                                      (string-length "/gnu/"))))
-                       ;; Sort so that the tarball with the same compression
-                       ;; format as currently used in PACKAGE comes first.
-                       (sort tarballs better-tarball?)))
-             (signature-urls (map (cut string-append <> ".sig") urls))))))))
+      (match tarballs
+        (() #f)
+        (_
+         (upstream-source
+          (package name)
+          (version version)
+          (urls (map (lambda (file)
+                       (string-append "mirror://gnu/"
+                                      (string-drop file
+                                                   (string-length "/gnu/"))))
+                     ;; Sort so that the tarball with the same compression
+                     ;; format as currently used in PACKAGE comes first.
+                     (sort tarballs better-tarball?)))
+          (signature-urls (map (cut string-append <> ".sig") urls))))))))
 
 (define %package-name-rx
   ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses
-- 
2.41.0

[bug#65230] [PATCH v4 05/10] gnu-maintenance: Accept package object in 'import-html-release' procedure.

[Maxim Cournoyer]

This is in preparation for a new URL rewriting feature, which will need to
have the current version information available.

* guix/gnu-maintenance.scm (import-html-release): Update doc.  Adjust default
value of the DIRECTORY argument.  Bind PACKAGE in lexical scope so that its
value there is unchanged.
(import-savannah-release, import-kernel.org-release)
(import-html-updatable-release): Adjust accordingly.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 17 ++++++++---------
 1 file changed, 8 insertions(+), 9 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 30792db60f..eea75095b5 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -494,11 +494,12 @@ (define (url->links url)
 (define* (import-html-release base-url package
                               #:key
                               (version #f)
-                              (directory (string-append "/" package))
+                              (directory (string-append
+                                          "/" (package-upstream-name package)))
                               file->signature)
-  "Return an <upstream-source> for the latest release of PACKAGE (a string)
-under DIRECTORY at BASE-URL, or #f.  Optionally include a VERSION string to
-fetch a specific version.
+  "Return an <upstream-source> for the latest release of PACKAGE under
+DIRECTORY at BASE-URL, or #f.  Optionally include a VERSION string to fetch a
+specific version.
 
 BASE-URL should be the URL of an HTML page, typically a directory listing as
 found on 'https://kernel.org/pub'.
@@ -507,7 +508,8 @@ (define* (import-html-release base-url package
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
 are unavailable."
-  (let* ((url (if (string-null? directory)
+  (let* ((package (package-upstream-name package))
+         (url (if (string-null? directory)
                   base-url
                   (string-append base-url directory "/")))
          (links (url->links url)))
@@ -730,7 +732,6 @@ (define* (import-savannah-release package #:key (version #f))
                      (match (origin-uri (package-source package))
                        ((? string? uri) uri)
                        ((uri mirrors ...) uri))))
-         (package   (package-upstream-name package))
          (directory (dirname (uri-path uri))))
     ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
     ;; or whichever detached signature naming scheme PACKAGE uses.
@@ -825,7 +826,6 @@ (define* (import-kernel.org-release package #:key (version #f))
                      (match (origin-uri (package-source package))
                        ((? string? uri) uri)
                        ((uri mirrors ...) uri))))
-         (package   (package-upstream-name package))
          (directory (dirname (uri-path uri))))
     (import-html-release %kernel.org-base package
                          #:version version
@@ -873,8 +873,7 @@ (define* (import-html-updatable-release package #:key (version #f))
                                        "://" (uri-host uri))))
          (directory (if custom
                         ""
-                        (dirname (uri-path uri))))
-         (package   (package-upstream-name package)))
+                        (dirname (uri-path uri)))))
     (false-if-networking-error
      (import-html-release base package
                           #:version version
-- 
2.41.0

[bug#65230] [PATCH v4 06/10] gnu-maintenance: Document nested procedures in 'import-html-release'.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (import-html-release): Add docstring to the
'file->signature/guess' and 'url->release' nested procedures.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index eea75095b5..6f08e2e295 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -514,6 +514,7 @@ (define* (import-html-release base-url package
                   (string-append base-url directory "/")))
          (links (url->links url)))
     (define (file->signature/guess url)
+      "Return the first link that matches a signature extension, else #f."
       (let ((base (basename url)))
         (any (lambda (link)
                (any (lambda (extension)
@@ -524,6 +525,8 @@ (define* (import-html-release base-url package
              links)))
 
     (define (url->release url)
+      "Return an <upstream-source> object if a release file was found at URL,
+else #f."
       (let* ((base (basename url))
              (base-url (string-append base-url directory))
              (url  (cond ((and=> (string->uri url) uri-scheme) ;full URL?
@@ -574,7 +577,7 @@ (define* (import-html-release base-url package
       (() #f)
       ((first . _)
        (if version
-           ;; find matching release version and return it
+           ;; Find matching release version and return it.
            (find (lambda (upstream)
                    (string=? (upstream-source-version upstream) version))
                  (coalesce-sources candidates))
-- 
2.41.0

[bug#65230] [PATCH v4 07/10] gnu-maintenance: Extract 'canonicalize-url' from 'import-html-release'.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm
(canonicalize-url): New procedure, extracted from...
(import-html-release): ... here.  Use it.  Rename inner PACKAGE variable to
NAME, to explicit it is a string and not a package object.
---

(no changes since v1)

 guix/gnu-maintenance.scm | 70 +++++++++++++++++++---------------------
 1 file changed, 34 insertions(+), 36 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 6f08e2e295..9eff98217e 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -491,6 +491,33 @@ (define (url->links url)
     (close-port port)
     (delete-duplicates (html-links sxml))))
 
+(define (canonicalize-url url base-url)
+  "Make relative URL absolute, by appending URL to BASE-URL as required.  If
+URL is a directory instead of a file, it should be suffixed with a slash (/)."
+  (cond ((and=> (string->uri url) uri-scheme)
+         ;; Fully specified URL.
+         url)
+        ((string-prefix? "//" url)
+         ;; Full URL lacking a URI scheme.  Reuse the URI scheme of the
+         ;; document that contains the URL.
+         (string-append (symbol->string (uri-scheme (string->uri base-url)))
+                        ":" url))
+        ((string-prefix? "/" url)
+         ;; Absolute URL.
+         (let ((uri (string->uri base-url)))
+           (uri->string
+            (build-uri (uri-scheme uri)
+                       #:host (uri-host uri)
+                       #:port (uri-port uri)
+                       #:path url))))
+        ;; URL is relative to BASE-URL, which is assumed to be a directory.
+        ((string-suffix? "/" base-url)
+         (string-append base-url url))
+        (else
+         ;; URL is relative to BASE-URL, which is assumed to denote a file
+         ;; within a directory.
+         (string-append (dirname base-url) "/" url))))
+
 (define* (import-html-release base-url package
                               #:key
                               (version #f)
@@ -508,11 +535,12 @@ (define* (import-html-release base-url package
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
 are unavailable."
-  (let* ((package (package-upstream-name package))
+  (let* ((name (package-upstream-name package))
          (url (if (string-null? directory)
                   base-url
                   (string-append base-url directory "/")))
-         (links (url->links url)))
+         (links (map (cut canonicalize-url <> url) (url->links url))))
+
     (define (file->signature/guess url)
       "Return the first link that matches a signature extension, else #f."
       (let ((base (basename url)))
@@ -526,42 +554,12 @@ (define* (import-html-release base-url package
 
     (define (url->release url)
       "Return an <upstream-source> object if a release file was found at URL,
-else #f."
-      (let* ((base (basename url))
-             (base-url (string-append base-url directory))
-             (url  (cond ((and=> (string->uri url) uri-scheme) ;full URL?
-                          url)
-                         ;; full URL, except for URI scheme.  Reuse the URI
-                         ;; scheme of the document that contains the link.
-                         ((string-prefix? "//" url)
-                          (string-append
-                           (symbol->string (uri-scheme (string->uri base-url)))
-                           ":" url))
-                         ((string-prefix? "/" url) ;absolute path?
-                          (let ((uri (string->uri base-url)))
-                            (uri->string
-                             (build-uri (uri-scheme uri)
-                                        #:host (uri-host uri)
-                                        #:port (uri-port uri)
-                                        #:path url))))
-
-                         ;; URL is a relative path and BASE-URL may or may not
-                         ;; end in slash.
-                         ((string-suffix? "/" base-url)
-                          (string-append base-url url))
-                         (else
-                          ;; If DIRECTORY is non-empty, assume BASE-URL
-                          ;; denotes a directory; otherwise, assume BASE-URL
-                          ;; denotes a file within a directory, and that URL
-                          ;; is relative to that directory.
-                          (string-append (if (string-null? directory)
-                                             (dirname base-url)
-                                             base-url)
-                                         "/" url)))))
-        (and (release-file? package base)
+else #f.  URL is assumed to fully specified."
+      (let ((base (basename url)))
+        (and (release-file? name base)
              (let ((version (tarball->version base)))
                (upstream-source
-                (package package)
+                (package name)
                 (version version)
                 ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp://
                 ;; URLs during "guix refresh -u".
-- 
2.41.0

[bug#65230] [PATCH v4 08/10] gnu-maintenance: Add support to rewrite version in URL path.

[Maxim Cournoyer]

Fixes <https://issues.guix.gnu.org/64015>.
Fixes <https://issues.guix.gnu.org/65304>.

Previously, the generic HTML updater would only look for the list of files
found at the parent of its current source URL, ignoring that the URL may embed
the version elsewhere in its path.  This could cause 'guix refresh' to report
no updates available, while in fact there were, such as for 'libuv'.

* guix/gnu-maintenance.scm (strip-trailing-slash): New procedure.
(%version-rx): New variable.
(rewrite-url): New procedure.
(import-html-release): New rewrite-url? argument.  When true, use the above
procedure.
(import-html-updatable-release): Call import-html-release with #:rewrite-url
set to #t.
* tests/gnu-maintenance.scm ("rewrite-url, to-version specified")
("rewrite-url, without to-version"): New tests.
---

- Rebase and mention it also fixes #65304 in commit message

 guix/gnu-maintenance.scm  | 102 ++++++++++++++++++++++++++++++++++++--
 tests/gnu-maintenance.scm |  43 ++++++++++++++++
 2 files changed, 142 insertions(+), 3 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 9eff98217e..228a84bd4b 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,6 +27,7 @@ (define-module (guix gnu-maintenance)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (rnrs io ports)
@@ -61,6 +63,7 @@ (define-module (guix gnu-maintenance)
             gnu-package?
 
             uri-mirror-rewrite
+            rewrite-url
 
             release-file?
             releases
@@ -518,9 +521,93 @@ (define (canonicalize-url url base-url)
          ;; within a directory.
          (string-append (dirname base-url) "/" url))))
 
+(define (strip-trailing-slash s)
+  "Strip any trailing slash from S, a string."
+  (if (string-suffix? "/" s)
+      (string-drop-right s 1)
+      s))
+
+;;; TODO: Extend to support the RPM and GNOME version schemes?
+(define %version-rx "[0-9.]+")
+
+(define* (rewrite-url url version #:key to-version)
+  "Rewrite URL so that the URL path components matching the current VERSION or
+VERSION-MAJOR.VERSION-MINOR are updated with that of the latest version found
+by crawling the corresponding URL directories.  Alternatively, when TO-VERSION
+is specified, rewrite version matches directly to it without crawling URL.
+
+For example, the URL
+\"https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz\" could be
+rewritten to something like
+\"https://dist.libuv.org/dist/v1.46.0/libuv-v1.46.0.tar.gz\"."
+  ;; XXX: major-minor may be #f if version is not a triplet but a single
+  ;; number such as "2".
+  (let* ((major-minor (false-if-exception (version-major+minor version)))
+         (to-major-minor (false-if-exception
+                          (and=> to-version version-major+minor)))
+         (uri (string->uri url))
+         (url-prefix (string-drop-right url (string-length (uri-path uri))))
+         (url-prefix-components (string-split url-prefix #\/))
+         (path (uri-path uri))
+         ;; Strip a forward slash on the path to avoid a double slash when
+         ;; string-joining later.
+         (path (if (string-prefix? "/" path)
+                   (string-drop path 1)
+                   path))
+         (path-components (string-split path #\/)))
+    (string-join
+     (reverse
+      (fold
+       (lambda (s parents)
+         (if to-version
+             ;; Direct rewrite case; the archive is assumed to exist.
+             (let ((u (string-replace-substring s version to-version)))
+               (cons (if (and major-minor to-major-minor)
+                         (string-replace-substring u major-minor to-major-minor)
+                         u)
+                     parents))
+             ;; More involved HTML crawl case.
+             (let* ((pattern (if major-minor
+                                 (format #f "(~a|~a)" version major-minor)
+                                 (format #f "(~a)" version)))
+                    (m (string-match pattern s)))
+               (if m
+                   ;; Crawl parent and rewrite current component.
+                   (let* ((parent-url (string-join (reverse parents) "/"))
+                          (links (url->links parent-url))
+                          ;; The pattern matching the version.
+                          (pattern (string-append "^" (match:prefix m)
+                                                  "(" %version-rx ")"
+                                                  (match:suffix m) "$"))
+                          (candidates (filter-map
+                                       (lambda (l)
+                                         ;; Links may be followed by a
+                                         ;; trailing '/' in the case of
+                                         ;; directories.
+                                         (and-let*
+                                             ((l (strip-trailing-slash l))
+                                              (m (string-match pattern l))
+                                              (v (match:substring m 1)))
+                                           (cons v l)))
+                                       links)))
+                     ;; Retrieve the item having the largest version.
+                     (if (null? candidates)
+                         (error "no candidates found in rewrite-url")
+                         (cons (cdr (first (sort candidates
+                                                 (lambda (x y)
+                                                   (version>? (car x)
+                                                              (car y))))))
+                               parents)))
+                   ;; No version found in path component; continue.
+                   (cons s parents)))))
+       (reverse url-prefix-components)
+       path-components))
+     "/")))
+
 (define* (import-html-release base-url package
                               #:key
-                              (version #f)
+                              rewrite-url?
+                              version
                               (directory (string-append
                                           "/" (package-upstream-name package)))
                               file->signature)
@@ -534,11 +621,19 @@ (define* (import-html-release base-url package
 When FILE->SIGNATURE is omitted or #f, guess the detached signature file name,
 if any.  Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
 file URL and must return the corresponding signature URL, or #f it signatures
-are unavailable."
-  (let* ((name (package-upstream-name package))
+are unavailable.
+
+When REWRITE-URL? is #t, versioned components in BASE-URL and/or DIRECTORY are
+also updated to the latest version, as explained in the doc of the
+\"rewrite-url\" procedure used."
+  (let* ((current-version (package-version package))
+         (name (package-upstream-name package))
          (url (if (string-null? directory)
                   base-url
                   (string-append base-url directory "/")))
+         (url (if rewrite-url?
+                  (rewrite-url url current-version #:to-version version)
+                  url))
          (links (map (cut canonicalize-url <> url) (url->links url))))
 
     (define (file->signature/guess url)
@@ -877,6 +972,7 @@ (define* (import-html-updatable-release package #:key (version #f))
                         (dirname (uri-path uri)))))
     (false-if-networking-error
      (import-html-release base package
+                          #:rewrite-url? #t
                           #:version version
                           #:directory directory))))
 
diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm
index 516e02ec6a..196a6f9092 100644
--- a/tests/gnu-maintenance.scm
+++ b/tests/gnu-maintenance.scm
@@ -147,4 +147,47 @@ (define-module (test-gnu-maintenance)
            (equal? (list expected-signature-url)
                    (upstream-source-signature-urls update))))))
 
+(test-equal "rewrite-url, to-version specified"
+  "https://download.qt.io/official_releases/qt/6.5/6.5.2/\
+submodules/qtbase-everywhere-src-6.5.2.tar.xz"
+  (rewrite-url "https://download.qt.io/official_releases/qt/6.3/6.3.2/\
+submodules/qtbase-everywhere-src-6.3.2.tar.xz" "6.3.2" #:to-version "6.5.2"))
+
+(test-equal "rewrite-url, without to-version"
+  "https://dist.libuv.org/dist/v1.46.0/libuv-v1.46.0.tar.gz"
+  (with-http-server
+      ;; First reply, crawling https://dist.libuv.org/dist/.
+      `((200 "\
+<!DOCTYPE html>
+<html>
+<head><title>Index of dist</title></head>
+<body>
+<a href=\"../\">../</a>
+<a href=\"v1.44.0/\" title=\"v1.44.0/\">v1.44.0/</a>
+<a href=\"v1.44.1/\" title=\"v1.44.1/\">v1.44.1/</a>
+<a href=\"v1.44.2/\" title=\"v1.44.2/\">v1.44.2/</a>
+<a href=\"v1.45.0/\" title=\"v1.45.0/\">v1.45.0/</a>
+<a href=\"v1.46.0/\" title=\"v1.46.0/\">v1.46.0/</a>
+</body>
+</html>")
+        ;; Second reply, crawling https://dist.libuv.org/dist/v1.46.0/.
+        (200 "\
+<!DOCTYPE html>
+<html>
+<head><title>Index of dist/v1.46.0</title></head>
+<body>
+<a href=\"../\">../</a>
+<a href=\"libuv-v1.46.0-dist.tar.gz\" title=\"libuv-v1.46.0-dist.tar.gz\">
+   libuv-v1.46.0-dist.tar.gz</a>
+<a href=\"libuv-v1.46.0-dist.tar.gz.sign\"
+   title=\"libuv-v1.46.0-dist.tar.gz.sign\">libuv-v1.46.0-dist.tar.gz.sign</a>
+<a href=\"libuv-v1.46.0.tar.gz\" title=\"libuv-v1.46.0.tar.gz\">
+   libuv-v1.46.0.tar.gz</a>
+<a href=\"libuv-v1.46.0.tar.gz.sign\" title=\"libuv-v1.46.0.tar.gz.sign\">
+   libuv-v1.46.0.tar.gz.sign</a>
+</body>
+</html>"))
+    (rewrite-url "https://dist.libuv.org/dist/v1.45.0/libuv-v1.45.0.tar.gz"
+                 "1.45.0")))
+
 (test-end)
-- 
2.41.0

[bug#65230] [PATCH v4 09/10] gnu-maintenance: Allow mirror URLs to fallback to the generic HTML updater.

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (http-url?): Extract from html-updatable-package?,
modify to return the HTTP URL, and support the mirror:// scheme.
(%disallowed-hosting-sites): New variable, extracted from
html-updatable-package.
(html-updatable-package?): Rewrite a mirror:// URL to an HTTP or HTTPS one.
* guix/download.scm (%mirrors): Update comment.

---

Changes in v4:
- Rebase and fix conflict

Changes in v2:
- Update %mirrors comment to mention speed-related exceptions

 guix/download.scm        |  5 +++-
 guix/gnu-maintenance.scm | 65 ++++++++++++++++++++++++----------------
 2 files changed, 44 insertions(+), 26 deletions(-)

diff --git a/guix/download.scm b/guix/download.scm
index ce6ebd0df8..31a41e8183 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -51,7 +51,10 @@ (define-module (guix download)
 ;;; Code:
 
 (define %mirrors
-  ;; Mirror lists used when `mirror://' URLs are passed.
+  ;; Mirror lists used when `mirror://' URLs are passed.  The first mirror
+  ;; entry of each set should ideally be the most authoritative one, as that's
+  ;; what the generic HTML updater will pick to look for updates, with
+  ;; possible exceptions when the authoritative mirror is too slow.
   (let* ((gnu-mirrors
           '(;; This one redirects to a (supposedly) nearby and (supposedly)
             ;; up-to-date mirror.
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 228a84bd4b..eb30b7874f 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -928,31 +928,43 @@ (define* (import-kernel.org-release package #:key (version #f))
                          #:directory directory
                          #:file->signature file->signature)))
 
-(define html-updatable-package?
-  ;; Return true if the given package may be handled by the generic HTML
-  ;; updater.
-  (let ((hosting-sites '("github.com" "github.io" "gitlab.com"
-                         "notabug.org" "sr.ht" "gitlab.inria.fr"
-                         "ftp.gnu.org" "download.savannah.gnu.org"
-                         "pypi.org" "crates.io" "rubygems.org"
-                         "bioconductor.org")))
-    (define http-url?
-      (url-predicate (lambda (url)
-                       (match (string->uri url)
-                         (#f #f)
-                         (uri
-                          (let ((scheme (uri-scheme uri))
-                                (host   (uri-host uri)))
-                            (and (memq scheme '(http https))
-                                 ;; HOST may contain prefixes,
-                                 ;; e.g. "profanity-im.github.io", hence the
-                                 ;; suffix-based test below.
-                                 (not (any (cut string-suffix? <> host)
-                                           hosting-sites)))))))))
-
-    (lambda (package)
-      (or (assoc-ref (package-properties package) 'release-monitoring-url)
-          (http-url? package)))))
+;;; These sites are disallowed for the generic HTML updater as there are
+;;; better means to query them.
+(define %disallowed-hosting-sites
+  '("github.com" "github.io" "gitlab.com"
+    "notabug.org" "sr.ht" "gitlab.inria.fr"
+    "ftp.gnu.org" "download.savannah.gnu.org"
+    "pypi.org" "crates.io" "rubygems.org"
+    "bioconductor.org"))
+
+(define (http-url? url)
+  "Return URL if URL has HTTP or HTTPS as its protocol.  If URL uses the
+special mirror:// protocol, substitute it with the first HTTP or HTTPS URL
+prefix from its set."
+  (match (string->uri url)
+    (#f #f)
+    (uri
+     (let ((scheme (uri-scheme uri))
+           (host   (uri-host uri)))
+       (or (and (memq scheme '(http https))
+                ;; HOST may contain prefixes, e.g. "profanity-im.github.io",
+                ;; hence the suffix-based test below.
+                (not (any (cut string-suffix? <> host)
+                          %disallowed-hosting-sites))
+                url)
+           (and (eq? scheme 'mirror)
+                (and=> (find http-url?
+                             (assoc-ref %mirrors
+                                        (string->symbol host)))
+                       (lambda (url)
+                         (string-append (strip-trailing-slash url)
+                                        (uri-path uri))))))))))
+
+(define (html-updatable-package? package)
+  "Return true if the given package may be handled by the generic HTML
+updater."
+  (or (assoc-ref (package-properties package) 'release-monitoring-url)
+      ((url-predicate http-url?) package)))
 
 (define* (import-html-updatable-release package #:key (version #f))
   "Return the latest release of PACKAGE.  Do that by crawling the HTML page of
@@ -960,6 +972,9 @@ (define* (import-html-updatable-release package #:key (version #f))
 string to fetch a specific version."
   (let* ((uri       (string->uri
                      (match (origin-uri (package-source package))
+                       ((? (cut string-prefix? "mirror://" <>) url)
+                        ;; Retrieve the authoritative HTTP URL from a mirror.
+                        (http-url? url))
                        ((? string? url) url)
                        ((url _ ...) url))))
          (custom    (assoc-ref (package-properties package)
-- 
2.41.0

[bug#65230] [PATCH v4 10/10] gnu-maintenance: Consider Qt source tarballs as "release files".

[Maxim Cournoyer]

* guix/gnu-maintenance.scm (release-file?): Use positive logic in doc.
Add a special case for Qt source archives.
* tests/gnu-maintenance.scm ("release-file?"): Update test.

---

(no changes since v3)

Changes in v3:
- Move a couple Qt-specific commits to the qt-updates branch

Changes in v2:
- Also special case release file of Qt Creator

 guix/gnu-maintenance.scm  | 18 +++++++++++++-----
 tests/gnu-maintenance.scm |  5 ++++-
 2 files changed, 17 insertions(+), 6 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index eb30b7874f..ee6e0db747 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -258,8 +258,7 @@ (define %alpha-tarball-rx
   (make-regexp "^.*-.*[0-9](-|~|\\.)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
 
 (define (release-file? project file)
-  "Return #f if FILE is not a release tarball of PROJECT, otherwise return
-true."
+  "Return true if FILE is a release tarball of PROJECT."
   (and (not (member (file-extension file)
                     '("sig" "sign" "asc"
                       "md5sum" "sha1sum" "sha256sum")))
@@ -268,12 +267,21 @@ (define (release-file? project file)
                 ;; Filter out unrelated files, like `guile-www-1.1.1'.
                 ;; Case-insensitive for things like "TeXmacs" vs. "texmacs".
                 ;; The "-src" suffix is for "freefont-src-20120503.tar.gz".
+                ;; The '-everywhere-src' suffix is for Qt modular components.
                 (and=> (match:substring match 1)
                        (lambda (name)
                          (or (string-ci=? name project)
-                             (string-ci=? name
-                                          (string-append project
-                                                         "-src")))))))
+                             (string-ci=? name (string-append project "-src"))
+                             (string-ci=?
+                              name (string-append project "-everywhere-src"))
+                             ;; For older Qt releases such as version 5.
+                             (string-ci=?
+                              name (string-append
+                                    project "-everywhere-opensource-src"))
+                             ;; For Qt Creator.
+                             (string-ci=?
+                              name (string-append
+                                    project "-opensource-src")))))))
        (not (regexp-exec %alpha-tarball-rx file))
        (let ((s (tarball-sans-extension file)))
          (regexp-exec %package-name-rx s))))
diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm
index 196a6f9092..61ae295b96 100644
--- a/tests/gnu-maintenance.scm
+++ b/tests/gnu-maintenance.scm
@@ -40,7 +40,10 @@ (define-module (test-gnu-maintenance)
                 ("exiv2" "exiv2-0.27.3-Source.tar.gz")
                 ("mpg321" "mpg321_0.3.2.orig.tar.gz")
                 ("bvi" "bvi-1.4.1.src.tar.gz")
-                ("hostscope" "hostscope-V2.1.tgz")))
+                ("hostscope" "hostscope-V2.1.tgz")
+                ("qtbase" "qtbase-everywhere-src-6.5.2.tar.xz")
+                ("qtbase" "qtbase-everywhere-opensource-src-5.15.10.tar.xz")
+                ("qt-creator" "qt-creator-opensource-src-11.0.1.tar.xz")))
        (every (lambda (project+file)
                 (not (apply release-file? project+file)))
               '(("guile" "guile-www-1.1.1.tar.gz")
-- 
2.41.0

bug#65230: [PATCH v4 08/10] gnu-maintenance: Add support to rewrite version in URL path.

[Maxim Cournoyer]

Hi,

Maxim Cournoyer <maxim.cournoyer@gmail.com> writes:

> Fixes <https://issues.guix.gnu.org/64015>.
> Fixes <https://issues.guix.gnu.org/65304>.
>
> Previously, the generic HTML updater would only look for the list of files
> found at the parent of its current source URL, ignoring that the URL may embed
> the version elsewhere in its path.  This could cause 'guix refresh' to report
> no updates available, while in fact there were, such as for 'libuv'.

I've now installed this series with commit
1dce88777691b7a38ad66ba58b17a9b368c11e07.

Closing!

-- 
Thanks,
Maxim