From 94d222ad9750868de82c2fb0b8664a3323753fd7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 12 Nov 2012 23:20:06 +0100 Subject: download: Add support for mirror:// URLs. * guix/download.scm (%mirrors): New variable. Mirror lists taken from Nixpkgs. (url-fetch): New `mirrors' keyword parameter. [builder]: Pass it. * guix/build/download.scm (url-fetch): New `mirrors' keyword parameter. [maybe-expand-mirrors]: New procedure. [uri]: Use it. --- guix/build/download.scm | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) (limited to 'guix/build/download.scm') diff --git a/guix/build/download.scm b/guix/build/download.scm index 7043c1b398..7af16da65f 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -23,7 +23,9 @@ #:use-module (guix ftp-client) #:use-module (guix build utils) #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (url-fetch)) @@ -129,14 +131,29 @@ which is not available during bootstrap." (lambda (key . args) (print-exception (current-error-port) #f key args)))) -(define (url-fetch url file) +(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 (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 string-append <> path)) + mirrors)) + (_ + (error "unsupported URL mirror kind" kind uri))))) + (else + (list uri)))) + (define uri - (match url - ((_ ...) (map string->uri url)) - (_ (list (string->uri url))))) + (append-map maybe-expand-mirrors + (match url + ((_ ...) (map string->uri url)) + (_ (list (string->uri url)))))) (define (fetch uri file) (format #t "starting download of `~a' from `~a'...~%" -- cgit v1.2.3