05/13: gnu-maintenance: 'latest-html-release' considers non-relative URLs.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit db69ebb9debda9e53ebb62f5113303cd9ff8dc14
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Mar 13 12:45:13 2021 +0100

    gnu-maintenance: 'latest-html-release' considers non-relative URLs.
    
    * guix/gnu-maintenance.scm (latest-html-release): Allow for URL to be an
    arbitrary URL rather than a relative URL reference.
---
 guix/gnu-maintenance.scm | 30 ++++++++++++++++--------------
 1 file changed, 16 insertions(+), 14 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index febed57..98d326e 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 
2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 
2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
@@ -479,19 +479,21 @@ return the corresponding signature URL, or #f it 
signatures are unavailable."
          (port (http-fetch/cached uri #:ttl 3600))
          (sxml (html->sxml port)))
     (define (url->release url)
-      (and (string=? url (basename url))          ;relative reference?
-           (release-file? package url)
-           (let-values (((name version)
-                         (package-name->name+version
-                          (tarball-sans-extension url)
-                          #\-)))
-             (upstream-source
-              (package name)
-              (version version)
-              (urls (list (string-append base-url directory "/" url)))
-              (signature-urls
-               (list (file->signature
-                      (string-append base-url directory "/" url))))))))
+      (let* ((base (basename url))
+             (url  (if (string=? base url)
+                       (string-append base-url directory "/" url)
+                       url)))
+        (and (release-file? package base)
+             (let-values (((name version)
+                           (package-name->name+version
+                            (tarball-sans-extension base)
+                            #\-)))
+               (upstream-source
+                (package name)
+                (version version)
+                (urls (list url))
+                (signature-urls
+                 (list (file->signature url))))))))
 
     (define candidates
       (filter-map url->release (html-links sxml)))