From 94d222ad9750868de82c2fb0b8664a3323753fd7 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
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 +++++++++++++++---
 guix/download.scm       | 68 ++++++++++++++++++++++++++++++++++++++++++++++---
 2 files changed, 86 insertions(+), 7 deletions(-)

(limited to 'guix')

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
-- 
cgit v1.2.3