From db69ebb9debda9e53ebb62f5113303cd9ff8dc14 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 13 Mar 2021 12:45:13 +0100 Subject: 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 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 +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2012, 2013 Nikita Karetnikov ;;; Copyright © 2021 Simon Tournier ;;; @@ -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))) -- cgit v1.2.3