summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-12-29 20:51:12 +0100
committerLudovic Courtès <ludo@gnu.org>2014-12-29 21:19:17 +0100
commitdd8ea244f4e6cb2c9cb0e926e1303bf4d7b113ae (patch)
tree959052760bf0fd7e2783fe8dbc0eddc1d8a6de9e
parent4fbf4ca552b4e1f68e1d0a84b334319d5152cc38 (diff)
download: Export 'maybe-expand-mirrors'.
* guix/build/download.scm (uri-vicinity, maybe-expand-mirrors): New procedures. (url-fetch): Remove them from here.
-rw-r--r--guix/build/download.scm45
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))))))