You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

280 lines
11 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2013, 2014 Andreas Enge <andreas@enge.fr>
  4. ;;;
  5. ;;; This file is part of GNU Guix.
  6. ;;;
  7. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  8. ;;; under the terms of the GNU General Public License as published by
  9. ;;; the Free Software Foundation; either version 3 of the License, or (at
  10. ;;; your option) any later version.
  11. ;;;
  12. ;;; GNU Guix is distributed in the hope that it will be useful, but
  13. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;;; GNU General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  19. (define-module (guix download)
  20. #:use-module (ice-9 match)
  21. #:use-module (guix derivations)
  22. #:use-module (guix packages)
  23. #:use-module ((guix store) #:select (derivation-path? add-to-store))
  24. #:use-module ((guix build download) #:prefix build:)
  25. #:use-module (guix monads)
  26. #:use-module (guix gexp)
  27. #:use-module (guix utils)
  28. #:use-module (web uri)
  29. #:use-module (srfi srfi-1)
  30. #:use-module (srfi srfi-26)
  31. #:export (%mirrors
  32. url-fetch
  33. download-to-store))
  34. ;;; Commentary:
  35. ;;;
  36. ;;; Produce fixed-output derivations with data fetched over HTTP or FTP.
  37. ;;;
  38. ;;; Code:
  39. (define %mirrors
  40. ;; Mirror lists used when `mirror://' URLs are passed.
  41. (let* ((gnu-mirrors
  42. '(;; This one redirects to a (supposedly) nearby and (supposedly)
  43. ;; up-to-date mirror.
  44. "http://ftpmirror.gnu.org/"
  45. "ftp://ftp.cs.tu-berlin.de/pub/gnu/"
  46. "ftp://ftp.funet.fi/pub/mirrors/ftp.gnu.org/gnu/"
  47. ;; This one is the master repository, and thus it's always
  48. ;; up-to-date.
  49. "http://ftp.gnu.org/pub/gnu/")))
  50. `((gnu ,@gnu-mirrors)
  51. (gcc
  52. "ftp://ftp.nluug.nl/mirror/languages/gcc/"
  53. "ftp://ftp.fu-berlin.de/unix/languages/gcc/"
  54. "ftp://ftp.irisa.fr/pub/mirrors/gcc.gnu.org/gcc/"
  55. "ftp://gcc.gnu.org/pub/gcc/"
  56. ,@(map (cut string-append <> "/gcc") gnu-mirrors))
  57. (gnupg
  58. "ftp://gd.tuwien.ac.at/privacy/gnupg/"
  59. "ftp://gnupg.x-zone.org/pub/gnupg/"
  60. "ftp://ftp.gnupg.cz/pub/gcrypt/"
  61. "ftp://sunsite.dk/pub/security/gcrypt/"
  62. "http://gnupg.wildyou.net/"
  63. "http://ftp.gnupg.zone-h.org/"
  64. "ftp://ftp.jyu.fi/pub/crypt/gcrypt/"
  65. "ftp://trumpetti.atm.tut.fi/gcrypt/"
  66. "ftp://mirror.cict.fr/gnupg/"
  67. "ftp://ftp.strasbourg.linuxfr.org/pub/gnupg/")
  68. (gnome
  69. "http://ftp.belnet.be/ftp.gnome.org/"
  70. "http://ftp.linux.org.uk/mirrors/ftp.gnome.org/"
  71. "http://ftp.gnome.org/pub/GNOME/"
  72. "http://mirror.yandex.ru/mirrors/ftp.gnome.org/")
  73. (savannah
  74. "http://download.savannah.gnu.org/releases/"
  75. "ftp://ftp.twaren.net/Unix/NonGNU/"
  76. "ftp://mirror.csclub.uwaterloo.ca/nongnu/"
  77. "ftp://mirror.publicns.net/pub/nongnu/"
  78. "ftp://savannah.c3sl.ufpr.br/"
  79. "http://ftp.cc.uoc.gr/mirrors/nongnu.org/"
  80. "http://ftp.twaren.net/Unix/NonGNU/"
  81. "http://mirror.csclub.uwaterloo.ca/nongnu/"
  82. "http://nongnu.askapache.com/"
  83. "http://savannah.c3sl.ufpr.br/"
  84. "http://www.centervenus.com/mirrors/nongnu/"
  85. "http://download.savannah.gnu.org/releases-noredirect/")
  86. (sourceforge
  87. "http://prdownloads.sourceforge.net/"
  88. "http://heanet.dl.sourceforge.net/sourceforge/"
  89. "http://surfnet.dl.sourceforge.net/sourceforge/"
  90. "http://dfn.dl.sourceforge.net/sourceforge/"
  91. "http://mesh.dl.sourceforge.net/sourceforge/"
  92. "http://ovh.dl.sourceforge.net/sourceforge/"
  93. "http://osdn.dl.sourceforge.net/sourceforge/")
  94. (kernel.org
  95. "http://www.all.kernel.org/pub/"
  96. "http://ramses.wh2.tu-dresden.de/pub/mirrors/kernel.org/"
  97. "http://linux-kernel.uio.no/pub/"
  98. "http://kernel.osuosl.org/pub/"
  99. "ftp://ftp.funet.fi/pub/mirrors/ftp.kernel.org/pub/"
  100. "http://ftp.be.debian.org/pub/"
  101. "http://mirror.linux.org.au/")
  102. (apache ; from http://www.apache.org/mirrors/dist.html
  103. "http://www.eu.apache.org/dist/"
  104. "http://www.us.apache.org/dist/"
  105. "ftp://gd.tuwien.ac.at/pub/infosys/servers/http/apache/dist/"
  106. "http://apache.belnet.be/"
  107. "http://mirrors.ircam.fr/pub/apache/"
  108. "http://apache-mirror.rbc.ru/pub/apache/"
  109. ;; As a last resort, try the archive.
  110. "http://archive.apache.org/dist/")
  111. (xorg ; from http://www.x.org/wiki/Releases/Download
  112. "http://www.x.org/releases/" ; main mirrors
  113. "ftp://mirror.csclub.uwaterloo.ca/x.org/" ; North America
  114. "ftp://xorg.mirrors.pair.com/"
  115. "http://mirror.csclub.uwaterloo.ca/x.org/"
  116. "http://xorg.mirrors.pair.com/"
  117. "http://mirror.us.leaseweb.net/xorg/"
  118. "ftp://artfiles.org/x.org/" ; Europe
  119. "ftp://ftp.chg.ru/pub/X11/x.org/"
  120. "ftp://ftp.fu-berlin.de/unix/X11/FTP.X.ORG/"
  121. "ftp://ftp.gwdg.de/pub/x11/x.org/"
  122. "ftp://ftp.mirrorservice.org/sites/ftp.x.org/"
  123. "ftp://ftp.ntua.gr/pub/X11/"
  124. "ftp://ftp.piotrkosoft.net/pub/mirrors/ftp.x.org/"
  125. "ftp://ftp.portal-to-web.de/pub/mirrors/x.org/"
  126. "ftp://ftp.solnet.ch/mirror/x.org/"
  127. "ftp://gd.tuwien.ac.at/X11/"
  128. "ftp://mi.mirror.garr.it/mirrors/x.org/"
  129. "ftp://mirror.cict.fr/x.org/"
  130. "ftp://mirror.switch.ch/mirror/X11/"
  131. "ftp://mirrors.ircam.fr/pub/x.org/"
  132. "ftp://x.mirrors.skynet.be/pub/ftp.x.org/"
  133. "ftp://ftp.cs.cuhk.edu.hk/pub/X11" ; East Asia
  134. "ftp://ftp.u-aizu.ac.jp/pub/x11/x.org/"
  135. "ftp://ftp.yz.yamagata-u.ac.jp/pub/X11/x.org/"
  136. "ftp://ftp.kaist.ac.kr/x.org/"
  137. "ftp://mirrors.go-part.com/xorg/"
  138. "http://x.cs.pu.edu.tw/"
  139. "ftp://ftp.is.co.za/pub/x.org") ; South Africa
  140. (cpan ; from http://www.cpan.org/SITES.html
  141. "http://cpan.enstimac.fr/"
  142. "ftp://ftp.ciril.fr/pub/cpan/"
  143. "ftp://artfiles.org/cpan.org/"
  144. "http://www.cpan.org/"
  145. "ftp://cpan.rinet.ru/pub/mirror/CPAN/"
  146. "http://cpan.cu.be/"
  147. "ftp://cpan.inode.at/"
  148. "ftp://cpan.iht.co.il/"
  149. "ftp://ftp.osuosl.org/pub/CPAN/"
  150. "ftp://ftp.nara.wide.ad.jp/pub/CPAN/"
  151. "http://mirrors.163.com/cpan/"
  152. "ftp://cpan.mirror.ac.za/")
  153. (imagemagick
  154. ;; from http://www.imagemagick.org/script/download.php
  155. ;; (without mirrors that are unavailable or not up to date)
  156. ;; mirrors keeping old versions at the top level
  157. "ftp://sunsite.icm.edu.pl/packages/ImageMagick/"
  158. ;; mirrors moving old versions to "legacy"
  159. "http://mirrors-au.go-parts.com/mirrors/ImageMagick/"
  160. "ftp://mirror.aarnet.edu.au/pub/imagemagick/"
  161. "http://mirror.checkdomain.de/imagemagick/"
  162. "ftp://ftp.kddlabs.co.jp/graphics/ImageMagick/"
  163. "ftp://ftp.u-aizu.ac.jp/pub/graphics/image/ImageMagick/imagemagick.org/"
  164. "ftp://ftp.nluug.nl/pub/ImageMagick/"
  165. "http://ftp.surfnet.nl/pub/ImageMagick/"
  166. "http://mirror.searchdaimon.com/ImageMagick"
  167. "ftp://ftp.tpnet.pl/pub/graphics/ImageMagick/"
  168. "http://mirrors-ru.go-parts.com/mirrors/ImageMagick/"
  169. "http://mirror.is.co.za/pub/imagemagick/"
  170. "http://mirrors-uk.go-parts.com/mirrors/ImageMagick/"
  171. "http://mirrors-usa.go-parts.com/mirrors/ImageMagick/"
  172. "ftp://ftp.fifi.org/pub/ImageMagick/"
  173. "http://www.imagemagick.org/download/"
  174. ;; one legacy location as a last resort
  175. "http://www.imagemagick.org/download/legacy/")
  176. (debian
  177. "http://ftp.de.debian.org/debian/"
  178. "http://ftp.fr.debian.org/debian/"
  179. "http://ftp.debian.org/debian/"))))
  180. (define (gnutls-package)
  181. "Return the default GnuTLS package."
  182. (let ((module (resolve-interface '(gnu packages gnutls))))
  183. (module-ref module 'gnutls)))
  184. (define* (url-fetch store url hash-algo hash
  185. #:optional name
  186. #:key (system (%current-system)) guile
  187. (mirrors %mirrors))
  188. "Return the path of a fixed-output derivation in STORE that fetches
  189. URL (a string, or a list of strings denoting alternate URLs), which is
  190. expected to have hash HASH of type HASH-ALGO (a symbol). By default,
  191. the file name is the base name of URL; optionally, NAME can specify a
  192. different file name.
  193. When one of the URL starts with mirror://, then its host part is
  194. interpreted as the name of a mirror scheme, taken from MIRRORS; MIRRORS
  195. must be a list of symbol/URL-list pairs."
  196. (define guile-for-build
  197. (package-derivation store
  198. (or guile
  199. (let ((distro (resolve-interface
  200. '(gnu packages commencement))))
  201. (module-ref distro 'guile-final)))
  202. system))
  203. (define file-name
  204. (match url
  205. ((head _ ...)
  206. (basename head))
  207. (_
  208. (basename url))))
  209. (define need-gnutls?
  210. ;; True if any of the URLs need TLS support.
  211. (let ((https? (cut string-prefix? "https://" <>)))
  212. (match url
  213. ((? string?)
  214. (https? url))
  215. ((url ...)
  216. (any https? url)))))
  217. (define builder
  218. #~(begin
  219. #$(if need-gnutls?
  220. ;; Add GnuTLS to the inputs and to the load path.
  221. #~(eval-when (load expand eval)
  222. (set! %load-path
  223. (cons (string-append #$(gnutls-package)
  224. "/share/guile/site")
  225. %load-path)))
  226. #~#t)
  227. (use-modules (guix build download))
  228. (url-fetch '#$url #$output
  229. #:mirrors '#$mirrors)))
  230. (run-with-store store
  231. (gexp->derivation (or name file-name) builder
  232. #:system system
  233. #:hash-algo hash-algo
  234. #:hash hash
  235. #:modules '((guix build download)
  236. (guix build utils)
  237. (guix ftp-client))
  238. #:guile-for-build guile-for-build
  239. ;; In general, offloading downloads is not a good idea.
  240. #:local-build? #t)
  241. #:guile-for-build guile-for-build
  242. #:system system))
  243. (define* (download-to-store store url #:optional (name (basename url))
  244. #:key (log (current-error-port)))
  245. "Download from URL to STORE, either under NAME or URL's basename if
  246. omitted. Write progress reports to LOG."
  247. (define uri
  248. (string->uri url))
  249. (if (or (not uri) (memq (uri-scheme uri) '(file #f)))
  250. (add-to-store store name #f "sha256"
  251. (if uri (uri-path uri) url))
  252. (call-with-temporary-output-file
  253. (lambda (temp port)
  254. (let ((result
  255. (parameterize ((current-output-port log))
  256. (build:url-fetch url temp #:mirrors %mirrors))))
  257. (close port)
  258. (and result
  259. (add-to-store store name #f "sha256" temp)))))))
  260. ;;; download.scm ends here