[bug#57460] [PATCH 05/20] refresh: Allow updating to a specific version (gnu-maintenance)

[Hartmut Goebel <h.goebel@crazy-compilers.com>]

* guix/gnu-maintenance.scm
  (latest-ftp-release): Rename to (import-ftp-release),
  add keyword-argument 'version'.
  If version is given, try to find the respective version.
  (latest-html-release): Rename to (import-html-release),
  add keyword-argument 'version'.
  If version is given, try to find the respective version.
  (latest-gnu-release): Rename to (import-gnu-release),
  add keyword-argument 'version'. Refactor to first select archives for
  respective package, the find the requested or latest version, then create
  the upstream-source.
  (latest-release): Rename to (import-release),
  add keyword-argument 'version', pass on to import-ftp-release.
  (import-release*): Rename to (import-release*),
  add keyword-argument 'version', pass on to latest-release.
  (latest-savannah-release): Rename to (import-savannah-release),
  add keword-argument version, pass on to import-html-release.
  (latest-xorg-release): Rename to (import-xorg-release),
  add keword-argument version, pass on to import-ftp-release.
  (latest-kernel.org-release): Rename to (import-kernel.org-release),
  add keyword-argument 'version', pass on to import-html-release.
  (latest-html-updatable-release): Rename to (import-html-updatable-release),
  add keyword-argument 'version', pass on to import-html-release.
* guix/import/gnu.scm(gnu->guix-package): Adjust function call.
---
 guix/gnu-maintenance.scm | 140 +++++++++++++++++++++++----------------
 guix/import/gnu.scm      |   2 +-
 2 files changed, 84 insertions(+), 58 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 8446a59fb5..ea3394e9e8 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -328,8 +328,9 @@ name/directory pairs."
                             files)
                 result)))))))
 
-(define* (latest-ftp-release project
+(define* (import-ftp-release project
                              #:key
+                             (version #f)
                              (server "ftp.gnu.org")
                              (directory (string-append "/gnu/" project))
                              (file->signature (cut string-append <> ".sig")))
@@ -400,8 +401,11 @@ return the corresponding signature URL, or #f it signatures are unavailable."
 
       ;; Assume that SUBDIRS correspond to versions, and jump into the
       ;; one with the highest version number.
-      (let* ((release  (reduce latest-release #f
-                               (coalesce-sources releases)))
+      (let* ((release  (if version
+                           (car (filter (lambda (r) (string=? version (upstream-source-version r)))
+                                        (coalesce-sources releases)))
+                           (reduce latest-release #f
+                                   (coalesce-sources releases))))
              (result   (if (and result release)
                            (latest-release release result)
                            (or release result)))
@@ -413,13 +417,15 @@ return the corresponding signature URL, or #f it signatures are unavailable."
               (ftp-close conn)
               result))))))
 
-(define* (latest-release package
+(define* (import-release package
                          #:key
+                         (version #f)
                          (server "ftp.gnu.org")
                          (directory (string-append "/gnu/" package)))
   "Return the <upstream-source> for the latest version of PACKAGE or #f.
 PACKAGE must be the canonical name of a GNU package."
-  (latest-ftp-release package
+  (import-ftp-release package
+                      #:version version
                       #:server server
                       #:directory directory))
 
@@ -435,14 +441,15 @@ of EXP otherwise."
           (close-port port))
       #f)))
 
-(define (latest-release* package)
-  "Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP
+(define* (import-release* package #:key (version #f))
+  "Like 'import-release', but (1) take a <package> object, and (2) ignore FTP
 errors that might occur when PACKAGE is not actually a GNU package, or not
 hosted on ftp.gnu.org, or not under that name (this is the case for
 \"emacs-auctex\", for instance.)"
   (let-values (((server directory)
                 (ftp-server/directory package)))
-    (false-if-ftp-error (latest-release (package-upstream-name package)
+    (false-if-ftp-error (import-release (package-upstream-name package)
+                                        #:version version
                                         #:server server
                                         #:directory directory))))
 
@@ -467,8 +474,9 @@ hosted on ftp.gnu.org, or not under that name (this is the case for
       (_
        links))))
 
-(define* (latest-html-release package
+(define* (import-html-release package
                               #:key
+                              (version #f)
                               (base-url "https://kernel.org/pub")
                               (directory (string-append "/" package))
                               file->signature)
@@ -538,13 +546,17 @@ are unavailable."
     (match candidates
       (() #f)
       ((first . _)
-       ;; 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
+           ;; find matching release version and return it
+           (car (filter (lambda (r) (string=? version (upstream-source-version r)))
+                        (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)))))))
 
 \f
 ;;;
@@ -576,46 +588,55 @@ are unavailable."
            (call-with-gzip-input-port port
              (compose string->lines get-string-all))))))
 
-(define (latest-gnu-release package)
+(define* (import-gnu-release package #:key (version #f))
   "Return the latest release of PACKAGE, a GNU package available via
 ftp.gnu.org.
 
 This method does not rely on FTP access at all; instead, it browses the file
 list available from %GNU-FILE-LIST-URI over HTTP(S)."
+
+  (define (find-latest-archive-version archives)
+    (fold (lambda (file1 file2)
+            (if (and file2
+                     (version>? (tarball-sans-extension (basename file2))
+                                (tarball-sans-extension (basename file1))))
+                file2
+                file1))
+          #f
+          archives))
+
   (let-values (((server directory)
                 (ftp-server/directory package))
                ((name)
                 (package-upstream-name package)))
     (let* ((files    (ftp.gnu.org-files))
+           ;; select archives for this package
            (relevant (filter (lambda (file)
                                (and (string-prefix? "/gnu" file)
                                     (string-contains file directory)
                                     (release-file? name (basename file))))
-                             files)))
-      (match (sort relevant (lambda (file1 file2)
-                              (version>? (tarball-sans-extension
-                                          (basename file1))
-                                         (tarball-sans-extension
-                                          (basename file2)))))
-        ((and tarballs (reference _ ...))
-         (let* ((version  (tarball->version reference))
-                (tarballs (filter (lambda (file)
-                                    (string=? (tarball-sans-extension
-                                               (basename file))
-                                              (tarball-sans-extension
-                                               (basename reference))))
-                                  tarballs)))
-           (upstream-source
-            (package name)
-            (version version)
-            (urls (map (lambda (file)
-                         (string-append "mirror://gnu/"
-                                        (string-drop file
-                                                     (string-length "/gnu/"))))
-                       tarballs))
-            (signature-urls (map (cut string-append <> ".sig") urls)))))
-        (()
-         #f)))))
+                             files))
+           ;; find latest version
+           (version (or version
+                        (and (not (null? relevant))
+                             (tarball->version
+                              (find-latest-archive-version relevant)))))
+           ;; find archives matching this version
+           (archives (filter (lambda (file)
+                               (string=? version (tarball->version file)))
+                             relevant)))
+    (match archives
+           (() #f)
+           (_
+            (upstream-source
+             (package name)
+             (version version)
+             (urls (map (lambda (file)
+                          (string-append "mirror://gnu/"
+                                         (string-drop file
+                                                      (string-length "/gnu/"))))
+                        archives))
+             (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
@@ -668,7 +689,7 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
   ;; HTML (unlike <https://download.savannah.nongnu.org/releases>.)
   "https://nongnu.freemirror.org/nongnu")
 
-(define (latest-savannah-release package)
+(define* (import-savannah-release package #:key (version #f))
   "Return the latest release of PACKAGE."
   (let* ((uri       (string->uri
                      (match (origin-uri (package-source package))
@@ -680,7 +701,8 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
                                         "mirror://savannah")))
     ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
     ;; or whichever detached signature naming scheme PACKAGE uses.
-    (and=> (latest-html-release package
+    (and=> (import-html-release package
+                                #:version version
                                 #:base-url %savannah-base
                                 #:directory directory)
            (cut adjusted-upstream-source <> rewrite))))
@@ -744,21 +766,22 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
         (when port
           (close-port port))))))
 
-(define (latest-xorg-release package)
+(define* (import-xorg-release package #:key (version #f))
   "Return the latest release of PACKAGE."
   (let ((uri (string->uri (origin-uri (package-source package)))))
     (false-if-ftp-error
-     (latest-ftp-release
+     (import-ftp-release
       (package-name package)
+      #:version version
       #:server "ftp.freedesktop.org"
       #:directory
       (string-append "/pub/xorg/" (dirname (uri-path uri)))))))
 
-(define (latest-kernel.org-release package)
+(define* (import-kernel.org-release package #:key (version #f))
   "Return the latest release of PACKAGE, the name of a kernel.org package."
   (define %kernel.org-base
     ;; This URL and sub-directories thereof are nginx-generated directory
-    ;; listings suitable for 'latest-html-release'.
+    ;; listings suitable for 'import-html-release'.
     "https://mirrors.edge.kernel.org/pub")
 
   (define (file->signature file)
@@ -772,7 +795,8 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
          (directory (dirname (uri-path uri)))
          (rewrite   (url-prefix-rewrite %kernel.org-base
                                         "mirror://kernel.org")))
-    (and=> (latest-html-release package
+    (and=> (import-html-release package
+                                #:version version
                                 #:base-url %kernel.org-base
                                 #:directory directory
                                 #:file->signature file->signature)
@@ -801,7 +825,7 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
       (or (assoc-ref (package-properties package) 'release-monitoring-url)
           (http-url? package)))))
 
-(define (latest-html-updatable-release package)
+(define* (import-html-updatable-release package #:key (version #f))
   "Return the latest release of PACKAGE.  Do that by crawling the HTML page of
 the directory containing its source tarball."
   (let* ((uri       (string->uri
@@ -817,10 +841,12 @@ the directory containing its source tarball."
                         ""
                         (dirname (uri-path uri))))
          (package   (package-upstream-name package)))
+
     (catch #t
       (lambda ()
         (guard (c ((http-get-error? c) #f))
-          (latest-html-release package
+          (import-html-release package
+                               #:version version
                                #:base-url base
                                #:directory directory)))
       (lambda (key . args)
@@ -838,7 +864,7 @@ the directory containing its source tarball."
    (name 'gnu)
    (description "Updater for GNU packages")
    (pred gnu-hosted?)
-   (import latest-gnu-release)))
+   (import import-gnu-release)))
 
 (define %gnu-ftp-updater
   ;; This is for GNU packages taken from alternate locations, such as
@@ -849,14 +875,14 @@ the directory containing its source tarball."
    (pred (lambda (package)
            (and (not (gnu-hosted? package))
                 (pure-gnu-package? package))))
-   (import latest-release*)))
+   (import import-release*)))
 
 (define %savannah-updater
   (upstream-updater
    (name 'savannah)
    (description "Updater for packages hosted on savannah.gnu.org")
    (pred (url-prefix-predicate "mirror://savannah/"))
-   (import latest-savannah-release)))
+   (import import-savannah-release)))
 
 (define %sourceforge-updater
   (upstream-updater
@@ -870,20 +896,20 @@ the directory containing its source tarball."
    (name 'xorg)
    (description "Updater for X.org packages")
    (pred (url-prefix-predicate "mirror://xorg/"))
-   (import latest-xorg-release)))
+   (import import-xorg-release)))
 
 (define %kernel.org-updater
   (upstream-updater
    (name 'kernel.org)
    (description "Updater for packages hosted on kernel.org")
    (pred (url-prefix-predicate "mirror://kernel.org/"))
-   (import latest-kernel.org-release)))
+   (import import-kernel.org-release)))
 
 (define %generic-html-updater
   (upstream-updater
    (name 'generic-html)
    (description "Updater that crawls HTML pages.")
    (pred html-updatable-package?)
-   (import latest-html-updatable-release)))
+   (import import-html-updatable-release)))
 
 ;;; gnu-maintenance.scm ends here
diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm
index 2b9b71feb0..139c32a545 100644
--- a/guix/import/gnu.scm
+++ b/guix/import/gnu.scm
@@ -117,7 +117,7 @@ details.)"
     (unless package
       (raise (formatted-message (G_ "no GNU package found for ~a") name)))
 
-    (match (latest-release name)
+    (match (import-release name)
       ((? upstream-source? release)
        (let ((version (upstream-source-version release)))
          (gnu-package->sexp package release #:key-download key-download)))
-- 
2.30.4