download: Export 'maybe-expand-mirrors'.

* guix/build/download.scm (uri-vicinity, maybe-expand-mirrors): New
  procedures.
  (url-fetch): Remove them from here.
master
Ludovic Courtès 2014-12-29 20:51:12 +01:00
parent 4fbf4ca552
commit dd8ea244f4
1 changed files with 24 additions and 21 deletions

View File

@ -29,6 +29,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (open-connection-for-uri
maybe-expand-mirrors
url-fetch
progress-proc
uri-abbreviation))
@ -279,32 +280,34 @@ which is not available during bootstrap."
(lambda (key . args)
(print-exception (current-error-port) #f key args))))
(define (uri-vicinity dir file)
"Concatenate DIR, slash, and FILE, keeping only one slash in between.
This is required by some HTTP servers."
(string-append (string-trim-right dir #\/) "/"
(string-trim file #\/)))
(define (maybe-expand-mirrors uri mirrors)
"If URI uses the 'mirror' scheme, expand it according to the MIRRORS alist.
Return a list of URIs."
(case (uri-scheme uri)
((mirror)
(let ((kind (string->symbol (uri-host uri)))
(path (uri-path uri)))
(match (assoc-ref mirrors kind)
((mirrors ..1)
(map (compose string->uri (cut uri-vicinity <> path))
mirrors))
(_
(error "unsupported URL mirror kind" kind uri)))))
(else
(list uri))))
(define* (url-fetch url file #:key (mirrors '()))
"Fetch FILE from URL; URL may be either a single string, or a list of
string denoting alternate URLs for FILE. Return #f on failure, and FILE
on success."
(define (uri-vicinity dir file)
;; Concatenate DIR, slash, and FILE, keeping only one slash in between.
;; This is required by some HTTP servers.
(string-append (string-trim-right dir #\/) "/"
(string-trim file #\/)))
(define (maybe-expand-mirrors uri)
(case (uri-scheme uri)
((mirror)
(let ((kind (string->symbol (uri-host uri)))
(path (uri-path uri)))
(match (assoc-ref mirrors kind)
((mirrors ..1)
(map (compose string->uri (cut uri-vicinity <> path))
mirrors))
(_
(error "unsupported URL mirror kind" kind uri)))))
(else
(list uri))))
(define uri
(append-map maybe-expand-mirrors
(append-map (cut maybe-expand-mirrors <> mirrors)
(match url
((_ ...) (map string->uri url))
(_ (list (string->uri url))))))