From 84f8bae0f85de081bbc55aa54ad6a50981a06a43 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 28 May 2021 22:56:38 +0200
Subject: [PATCH] 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 4e3a54dcab..19cf1062bd 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -496,9 +496,23 @@ (define (file->signature/guess url)
 
     (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