diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2021-05-28 22:56:38 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2021-05-28 23:04:44 +0200 |
| commit | 84f8bae0f85de081bbc55aa54ad6a50981a06a43 (patch) | |
| tree | d7727f2287b951abccf5868c85b2af901f4665b1 | |
| parent | d7c356edb9719f1e236ee926c0288f914076481a (diff) | |
| download | guix-84f8bae0f85de081bbc55aa54ad6a50981a06a43.tar.gz | |
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.
| -rw-r--r-- | guix/gnu-maintenance.scm | 20 |
1 files 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 @@ 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 |