~ruther/guix-local

a5b5df7f7fbbb98487b2e7a59941efee6492bc7f — Maxim Cournoyer 2 years ago 5ff9afb
gnu-maintenance: Support URI list of mixed mirrors, HTTP URLs.

Fixes <https://issues.guix.gnu.org/58697>.

* guix/gnu-maintenance.scm (import-html-updatable-release): Update doc.
<expand-uri>: New nested procedure.  Apply it to the origin URI.

Reported-by: kiasoc5 <kiasoc5@disroot.org>
1 files changed, 18 insertions(+), 11 deletions(-)

M guix/gnu-maintenance.scm
M guix/gnu-maintenance.scm => guix/gnu-maintenance.scm +18 -11
@@ 975,17 975,24 @@ updater."
      ((url-predicate http-url?) package)))

(define* (import-html-updatable-release package #:key (version #f))
  "Return the latest release of PACKAGE.  Do that by crawling the HTML page of
the directory containing its source tarball.  Optionally include a VERSION
string to fetch a specific version."
  (let* ((uri       (string->uri
                     (match (origin-uri (package-source package))
                       ((and (? string?)
                             (? (cut string-prefix? "mirror://" <>) url))
                        ;; Retrieve the authoritative HTTP URL from a mirror.
                        (http-url? url))
                       ((? string? url) url)
                       ((url _ ...) url))))
  "Return the latest release of PACKAGE else #f.  Do that by crawling the HTML
page of the directory containing its source tarball.  Optionally include a
VERSION string to fetch a specific version."

  (define (expand-uri uri)
    (string->uri
     (match uri
       ((and (? string?) (? (cut string-prefix? "mirror://" <>) url))
        ;; Retrieve the authoritative HTTP URL from a mirror.
        (http-url? url))
       ((? string? url)
        url)
       ((url _ ...)
        ;; This case is for when the URI is a list of possibly mirror URLs as
        ;; well as HTTP URLs.
        (expand-uri url)))))

  (let* ((uri (expand-uri (origin-uri (package-source package))))
         (custom    (assoc-ref (package-properties package)
                               'release-monitoring-url))
         (base      (or custom