[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
11/72: gnu-maintenance: Add support to rewrite version in URL path.
From: |
guix-commits |
Subject: |
11/72: gnu-maintenance: Add support to rewrite version in URL path. |
Date: |
Wed, 16 Aug 2023 06:41:07 -0400 (EDT) |
apteryx pushed a commit to branch qt-updates
in repository guix.
commit 0088dbabf3dc9e00ebfa3e5beea4712094956ed6
Author: Maxim Cournoyer <maxim.cournoyer@gmail.com>
AuthorDate: Thu Aug 10 11:42:22 2023 -0400
gnu-maintenance: Add support to rewrite version in URL path.
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 @@
#: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 @@
gnu-package?
uri-mirror-rewrite
+ rewrite-url
release-file?
releases
@@ -518,9 +521,93 @@ URL is a directory instead of a file, it should be
suffixed with a slash (/)."
;; 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 @@ found on 'https://kernel.org/pub'.
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 @@ string to fetch a specific version."
(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 @@
(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)
- 13/72: gnu-maintenance: Consider Qt source tarballs as "release files"., (continued)
- 13/72: gnu-maintenance: Consider Qt source tarballs as "release files"., guix-commits, 2023/08/16
- 07/72: gnu-maintenance: Fix indentation., guix-commits, 2023/08/16
- 09/72: gnu-maintenance: Document nested procedures in 'import-html-release'., guix-commits, 2023/08/16
- 28/72: gnu: qtmultimedia: Update to 6.5.2., guix-commits, 2023/08/16
- 29/72: gnu: qtwayland: Update to 6.5.2., guix-commits, 2023/08/16
- 33/72: gnu: qttranslations: Update to 6.5.2., guix-commits, 2023/08/16
- 10/72: gnu-maintenance: Extract 'canonicalize-url' from 'import-html-release'., guix-commits, 2023/08/16
- 03/72: gnu: qt: Streamline qt-urls., guix-commits, 2023/08/16
- 04/72: gnu: qt-creator: Use mirror://qt for source URI., guix-commits, 2023/08/16
- 05/72: gnu-maintenance: Fix docstring., guix-commits, 2023/08/16
- 11/72: gnu-maintenance: Add support to rewrite version in URL path.,
guix-commits <=
- 14/72: gnu: qt: Revert to use individual versions instead of %qt5-version., guix-commits, 2023/08/16
- 15/72: gnu: qtdeclarative: Disable QML cache to avoid stale cache issues., guix-commits, 2023/08/16
- 20/72: gnu: qtsvg: Update to 6.5.2., guix-commits, 2023/08/16
- 19/72: gnu: qt5compat: Update to 6.5.2., guix-commits, 2023/08/16
- 21/72: gnu: qtimageformats: Rename variable to qtimageformats-5., guix-commits, 2023/08/16
- 22/72: gnu: qtimageformats-5: Fix indentation., guix-commits, 2023/08/16
- 26/72: gnu: qtwebsockets: Update to 6.5.2., guix-commits, 2023/08/16
- 32/72: gnu: qttools: Update to 6.5.2., guix-commits, 2023/08/16
- 38/72: gnu: Remove qtquickcontrols2., guix-commits, 2023/08/16
- 45/72: gnu: qtxmlpatterns: Update to 5.15.10., guix-commits, 2023/08/16