gnu-maintenance: ‘generic-html’ recognizes ‘release-file-regexp’ property.

* guix/gnu-maintenance.scm (package-release-file?): New procedure.
(tarball->version): Add optional parameter and honor it.
(import-html-release): Use ‘package-release-file?’ and pass second argument to
‘tarball->version’.
* tests/gnu-maintenance.scm ("latest-html-release, 'release-file-regexp' property")
("latest-html-release, invalid 'release-file-regexp' property"): New tests.
* doc/guix.texi (Invoking guix refresh): Document it.

Change-Id: Ia9328418fdd2faf118e4ec9d5fbde4a279e100ed
Reviewed-by: Maxim Cournoyer <maxim@guixotic.coop>

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\">