diff options
| -rw-r--r-- | guix/build/download.scm | 25 | ||||
| -rw-r--r-- | guix/download.scm | 68 |
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 |