diff mbox series

[bug#47126,2/7] gnu-maintenance: 'latest-html-release' considers non-relative URLs.

Message ID 20210313214620.28186-2-ludo@gnu.org
State Accepted
Headers show
Series Add 'generic-html' updater | expand

Checks

Context Check Description
cbaines/comparison success View comparision
cbaines/git branch success View Git branch
cbaines/applying patch success View Laminar job
cbaines/issue success View issue

Commit Message

Ludovic Courtès March 13, 2021, 9:46 p.m. UTC 
* 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 mbox series

Patch

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index febed57c3a..98d326e500 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)))