diff options
| -rw-r--r-- | doc/guix.texi | 30 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 45 | ||||
| -rw-r--r-- | tests/gnu-maintenance.scm | 58 |
3 files changed, 121 insertions, 12 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index 8b569c7fbc2..7bba256b838 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -15530,10 +15530,34 @@ the updater for @uref{https://www.stackage.org, Stackage} packages. the updater for @uref{https://crates.io, Crates} packages. @item launchpad the updater for @uref{https://launchpad.net, Launchpad} packages. + @item generic-html -a generic updater that crawls the HTML page where the source tarball of -the package is hosted, when applicable, or the HTML page specified by -the @code{release-monitoring-url} property of the package. +a generic updater that crawls, by default, the HTML page where the +source tarball of the package is hosted, when applicable. Behavior can +be customized with the following package properties: + +@table @code +@item release-monitoring-url +an alternate URL to crawl; + +@item release-file-regexp +an regular expression matching release file names, whose first +subexpression must correspond to the version string. +@end table + +Here is an example package with a custom release monitoring URL and a +regexp matching an unconventional release file name (it's unconventional +due to the use of upper case letter and the lack of a hyphen before the +version string): + +@lisp +(package + ;; @dots{} + (home-page "http://example.org/software/the-package.html") + (properties + `((release-monitoring-url . ,home-page) + (release-file-regexp . "ThePackage([0-9\\.]+)\\.tgz")))) +@end lisp @item generic-git a generic updater for packages hosted on Git repositories. It tries to diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 08332425083..a33f941cb80 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -288,13 +288,41 @@ network to check in GNU's database." (let ((s (tarball-sans-extension file))) (regexp-exec %package-name-rx s)))) -(define (tarball->version tarball) +(define (package-release-file? package file) + "Return true if FILE, a string like \"NPB2.3.tar.gz\", denotes a release +file for PACKAGE." + (match (assoc-ref (package-properties package) 'release-file-regexp) + (#f + (release-file? (package-upstream-name package) file)) + (str + (catch #t + (lambda () + (string-match str file)) + (lambda _ + (warning (package-field-location package 'properties) + (G_ "~a: invalid 'release-file-regexp' property~%") + (package-full-name package)) + #f))))) + +(define* (tarball->version tarball #:optional regexp) "Return the version TARBALL corresponds to. TARBALL is a file name like \"coreutils-8.23.tar.xz\"." - (let-values (((name version) - (gnu-package-name->name+version - (tarball-sans-extension tarball)))) - version)) + (if regexp + (let ((match (string-match regexp tarball))) + (if (= 2 (match:count match)) + (match:substring match 1) + (begin + (warning (N_ "release file regexp ~s has ~a subexpression\ + (expected one for the version string)~%" + "release file regexp ~s has ~a subexpressions\ + (expected one for the version string)~%" + (- (match:count match) 1)) + regexp (- (match:count match) 1)) + #f))) + (let-values (((name version) + (gnu-package-name->name+version + (tarball-sans-extension tarball)))) + version))) (define* (releases project #:key @@ -705,8 +733,11 @@ also updated to the latest version, as explained in the doc of the "Return an <upstream-source> object if a release file was found at URL, else #f. URL is assumed to fully specified." (let ((base (basename url))) - (and (release-file? name base) - (let ((version (tarball->version base))) + (and (package-release-file? package base) + (let ((version (tarball->version + base + (assoc-ref (package-properties package) + 'release-file-regexp)))) (upstream-source (package name) (version version) diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm index 644cd1f2a90..01bcea04aab 100644 --- a/tests/gnu-maintenance.scm +++ b/tests/gnu-maintenance.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2021, 2025 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2023-2024 Maxim Cournoyer <maxim@guixotic.coop> ;;; @@ -27,7 +27,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) #:use-module ((web client) #:select (current-http-proxy)) - #:use-module ((web uri) #:select (uri? uri->string)) + #:use-module ((web uri) #:select (uri? uri->string string->uri uri-path)) #:use-module (ice-9 match)) (test-begin "gnu-maintenance") @@ -91,6 +91,60 @@ (equal? (upstream-source-version update) "2") (equal? (list expected-new-url) (upstream-source-urls update)))))) +(test-equal "latest-html-release, 'release-file-regexp' property" + '("foo" + "1.2.3" + ("/dl/FOO1.2.3.tgz")) + (with-http-server + `((200 "<html xmlns=\"http://www.w3.org/1999/xhtml\"> +<head> +<title>Releases with unusual file names</title> +</head> +<body +<a href=\"FOO1.2.3.tgz\">version 1.2</a> +</body> +</html>")) + (let () + (define package + (dummy-package "foo" + (source + (dummy-origin + (uri (string-append (%local-url #:path "/dl") + "/FOO1.0.0.tar.gz")))) + (properties + `((release-monitoring-url . ,(%local-url #:path "/dl/")) + (release-file-regexp . "FOO([0-9\\.]+)\\.tgz"))))) + (define update + ((upstream-updater-import %generic-html-updater) package)) + + (list (upstream-source-package update) + (upstream-source-version update) + (map (compose uri-path string->uri) + (upstream-source-urls update)))))) + +(test-assert "latest-html-release, invalid 'release-file-regexp' property" + (with-http-server + `((200 "<html xmlns=\"http://www.w3.org/1999/xhtml\"> +<head> +<title>Releases with unusual file names</title> +</head> +<body +<a href=\"FOO1.2.3.tgz\">version 1.2</a> +</body> +</html>")) + (let () + (define package + (dummy-package "foo" + (source + (dummy-origin + (uri (string-append (%local-url #:path "/dl") + "/FOO1.0.0.tar.gz")))) + (properties + `((release-monitoring-url . ,(%local-url #:path "/dl/")) + (release-file-regexp . "FOO[0-9\\.]+\\.tgz"))))) + (not ((upstream-updater-import %generic-html-updater) package))))) + + (test-assert "latest-html-release, no signature" (with-http-server `((200 "<html xmlns=\"http://www.w3.org/1999/xhtml\"> |