summaryrefslogtreecommitdiff
path: root/guix/gnu-maintenance.scm
diff options
context:
space:
mode:
authorMaxim Cournoyer <maxim.cournoyer@gmail.com>2023-08-10 16:54:52 -0400
committerMaxim Cournoyer <maxim.cournoyer@gmail.com>2023-08-26 11:38:56 -0400
commit6fb8cc312dcf561817c99eced8c8d58d38e0150a (patch)
tree78024dd7314040c8bf4e16e5c7410a34818ae6fa /guix/gnu-maintenance.scm
parent265423266084e75877fa758691276b368e61da0a (diff)
gnu-maintenance: Extract 'canonicalize-url' from 'import-html-release'.
* guix/gnu-maintenance.scm (canonicalize-url): New procedure, extracted from... (import-html-release): ... here. Use it. Rename inner PACKAGE variable to NAME, to explicit it is a string and not a package object.
Diffstat (limited to 'guix/gnu-maintenance.scm')
-rw-r--r--guix/gnu-maintenance.scm70
1 files changed, 34 insertions, 36 deletions
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 6f08e2e295..9eff98217e 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -491,6 +491,33 @@ hosted on ftp.gnu.org, or not under that name (this is the case for
(close-port port)
(delete-duplicates (html-links sxml))))
+(define (canonicalize-url url base-url)
+ "Make relative URL absolute, by appending URL to BASE-URL as required. If
+URL is a directory instead of a file, it should be suffixed with a slash (/)."
+ (cond ((and=> (string->uri url) uri-scheme)
+ ;; Fully specified URL.
+ url)
+ ((string-prefix? "//" url)
+ ;; Full URL lacking a URI scheme. Reuse the URI scheme of the
+ ;; document that contains the URL.
+ (string-append (symbol->string (uri-scheme (string->uri base-url)))
+ ":" url))
+ ((string-prefix? "/" url)
+ ;; Absolute URL.
+ (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 to BASE-URL, which is assumed to be a directory.
+ ((string-suffix? "/" base-url)
+ (string-append base-url url))
+ (else
+ ;; URL is relative to BASE-URL, which is assumed to denote a file
+ ;; within a directory.
+ (string-append (dirname base-url) "/" url))))
+
(define* (import-html-release base-url package
#:key
(version #f)
@@ -508,11 +535,12 @@ When FILE->SIGNATURE is omitted or #f, guess the detached signature file name,
if any. Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source
file URL and must return the corresponding signature URL, or #f it signatures
are unavailable."
- (let* ((package (package-upstream-name package))
+ (let* ((name (package-upstream-name package))
(url (if (string-null? directory)
base-url
(string-append base-url directory "/")))
- (links (url->links url)))
+ (links (map (cut canonicalize-url <> url) (url->links url))))
+
(define (file->signature/guess url)
"Return the first link that matches a signature extension, else #f."
(let ((base (basename url)))
@@ -526,42 +554,12 @@ are unavailable."
(define (url->release url)
"Return an <upstream-source> object if a release file was found at URL,
-else #f."
- (let* ((base (basename url))
- (base-url (string-append base-url directory))
- (url (cond ((and=> (string->uri url) uri-scheme) ;full URL?
- url)
- ;; full URL, except for URI scheme. Reuse the URI
- ;; scheme of the document that contains the link.
- ((string-prefix? "//" url)
- (string-append
- (symbol->string (uri-scheme (string->uri base-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 a relative path and BASE-URL may or may not
- ;; end in slash.
- ((string-suffix? "/" base-url)
- (string-append base-url url))
- (else
- ;; If DIRECTORY is non-empty, assume BASE-URL
- ;; denotes a directory; otherwise, assume BASE-URL
- ;; denotes a file within a directory, and that URL
- ;; is relative to that directory.
- (string-append (if (string-null? directory)
- (dirname base-url)
- base-url)
- "/" url)))))
- (and (release-file? package base)
+else #f. URL is assumed to fully specified."
+ (let ((base (basename url)))
+ (and (release-file? name base)
(let ((version (tarball->version base)))
(upstream-source
- (package package)
+ (package name)
(version version)
;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp://
;; URLs during "guix refresh -u".