aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2012-11-12 23:20:06 +0100
committerLudovic Courtès <ludo@gnu.org>2012-11-13 00:23:43 +0100
commit94d222ad9750868de82c2fb0b8664a3323753fd7 (patch)
tree0c79ecd4ab110fd6ac3c3c839b2c13c4d54e1dcd
parent270246defe541778ceaea1a87b5812c01799eaea (diff)
downloadguix-94d222ad9750868de82c2fb0b8664a3323753fd7.tar
guix-94d222ad9750868de82c2fb0b8664a3323753fd7.tar.gz
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.
-rw-r--r--guix/build/download.scm25
-rw-r--r--guix/download.scm68
2 files changed, 86 insertions, 7 deletions
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'...~%"
diff --git a/guix/download.scm b/guix/download.scm
index b5e8c675ac..27f58139b3 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -22,6 +22,7 @@
#:use-module (guix packages)
#:use-module ((guix store) #:select (derivation-path?))
#:use-module (guix utils)
+ #:use-module (srfi srfi-26)
#:export (url-fetch))
;;; Commentary:
@@ -30,18 +31,79 @@
;;;
;;; Code:
+(define %mirrors
+ ;; Mirror lists used when `mirror://' URLs are passed.
+ (let* ((gnu-mirrors
+ '(;; This one redirects to a (supposedly) nearby and (supposedly)
+ ;; up-to-date mirror.
+ "http://ftpmirror.gnu.org/"
+
+ "ftp://ftp.cs.tu-berlin.de/pub/gnu/"
+ "ftp://ftp.chg.ru/pub/gnu/"
+ "ftp://ftp.funet.fi/pub/mirrors/ftp.gnu.org/gnu/"
+
+ ;; This one is the master repository, and thus it's always
+ ;; up-to-date.
+ "http://ftp.gnu.org/pub/gnu/")))
+ `((gnu ,@gnu-mirrors)
+ (gcc
+ "ftp://ftp.nluug.nl/mirror/languages/gcc/"
+ "ftp://ftp.fu-berlin.de/unix/languages/gcc/"
+ "ftp://ftp.irisa.fr/pub/mirrors/gcc.gnu.org/gcc/"
+ "ftp://gcc.gnu.org/pub/gcc/"
+ ,@(map (cut string-append <> "/gcc") gnu-mirrors))
+ (gnupg
+ "ftp://gd.tuwien.ac.at/privacy/gnupg/"
+ "ftp://gnupg.x-zone.org/pub/gnupg/"
+ "ftp://ftp.gnupg.cz/pub/gcrypt/"
+ "ftp://sunsite.dk/pub/security/gcrypt/"
+ "http://gnupg.wildyou.net/"
+ "http://ftp.gnupg.zone-h.org/"
+ "ftp://ftp.jyu.fi/pub/crypt/gcrypt/"
+ "ftp://trumpetti.atm.tut.fi/gcrypt/"
+ "ftp://mirror.cict.fr/gnupg/"
+ "ftp://ftp.strasbourg.linuxfr.org/pub/gnupg/")
+ (savannah
+ "http://download.savannah.gnu.org/"
+ "ftp://ftp.twaren.net/Unix/NonGNU/"
+ "ftp://mirror.csclub.uwaterloo.ca/nongnu/"
+ "ftp://mirror.publicns.net/pub/nongnu/"
+ "ftp://savannah.c3sl.ufpr.br/"
+ "http://ftp.cc.uoc.gr/mirrors/nongnu.org/"
+ "http://ftp.twaren.net/Unix/NonGNU/"
+ "http://mirror.csclub.uwaterloo.ca/nongnu/"
+ "http://nongnu.askapache.com/"
+ "http://savannah.c3sl.ufpr.br/"
+ "http://www.centervenus.com/mirrors/nongnu/")
+ (sourceforge
+ "http://prdownloads.sourceforge.net/"
+ "http://heanet.dl.sourceforge.net/sourceforge/"
+ "http://surfnet.dl.sourceforge.net/sourceforge/"
+ "http://dfn.dl.sourceforge.net/sourceforge/"
+ "http://mesh.dl.sourceforge.net/sourceforge/"
+ "http://ovh.dl.sourceforge.net/sourceforge/"
+ "http://osdn.dl.sourceforge.net/sourceforge/"
+ "http://kent.dl.sourceforge.net/sourceforge/"))))
+
+
(define* (url-fetch store url hash-algo hash
#:optional name
- #:key (system (%current-system)) guile)
+ #:key (system (%current-system)) guile
+ (mirrors %mirrors))
"Return the path of a fixed-output derivation in STORE that fetches
URL (a string, or a list of strings denoting alternate URLs), which is
expected to have hash HASH of type HASH-ALGO (a symbol). By default,
the file name is the base name of URL; optionally, NAME can specify a
-different file name."
+different file name.
+
+When one of the URL starts with mirror://, then its host part is
+interpreted as the name of a mirror scheme, taken from MIRRORS; MIRRORS
+must be a list of symbol/URL-list pairs."
(define builder
`(begin
(use-modules (guix build download))
- (url-fetch ',url %output)))
+ (url-fetch ',url %output
+ #:mirrors ',mirrors)))
(define guile-for-build
(match guile