diff options
| -rw-r--r-- | guix/build/download.scm | 45 |
1 files changed, 24 insertions, 21 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index bb7e4601fd..5928ccd154 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -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)))))) |