09/12: gnu-maintenance: 'generic-html' correctly handles relative release URLs.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 84f8bae0f85de081bbc55aa54ad6a50981a06a43
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri May 28 22:56:38 2021 +0200

    gnu-maintenance: 'generic-html' correctly handles relative release URLs.
    
    * guix/gnu-maintenance.scm (latest-html-release)[url->release]: Fix
    source URL construction in cases where URL is a possibly relative path.
---
 guix/gnu-maintenance.scm | 20 +++++++++++++++++---
 1 file changed, 17 insertions(+), 3 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 4e3a54d..19cf106 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -496,9 +496,23 @@ are unavailable."
 
     (define (url->release url)
       (let* ((base (basename url))
-             (url  (if (string=? base url)
-                       (string-append base-url directory "/" url)
-                       url)))
+             (base-url (string-append base-url directory))
+             (url  (cond ((and=> (string->uri url) uri-scheme) ;full URL?
+                          url)
+                         ((string-prefix? "/" url) ;absolute path?
+                          (let ((uri (string->uri base-url)))
+                            (uri->string
+                             (build-uri (uri-scheme uri)
+                                        #:host (uri-host uri)
+                                        #:port (uri-port uri)
+                                        #:path url))))
+
+                         ;; URL is relative path and BASE-URL may or may not
+                         ;; end in slash.
+                         ((string-suffix? "/" base-url)
+                          (string-append base-url url))
+                         (else
+                          (string-append (dirname base-url) "/" url)))))
         (and (release-file? package base)
              (let ((version (tarball->version base)))
                (upstream-source