;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2019 Guy Fleury Iteriteka <hoonandon@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix store)
- #:use-module ((guix build download) #:prefix build:)
+ #:autoload (guix build download) (url-fetch)
#:use-module (guix monads)
#:use-module (guix gexp)
#:use-module (guix utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (%mirrors
- url-fetch
+ (url-fetch* . url-fetch)
+ url-fetch/executable
url-fetch/tarbomb
url-fetch/zipbomb
download-to-store))
"http://mirror.yandex.ru/mirrors/ftp.gnome.org/")
(hackage
"http://hackage.haskell.org/")
- (savannah
+ (savannah ; http://download0.savannah.gnu.org/mirmon/savannah/
"http://download.savannah.gnu.org/releases/"
+ "http://nongnu.freemirror.org/nongnu/"
"http://ftp.cc.uoc.gr/mirrors/nongnu.org/"
"http://ftp.twaren.net/Unix/NonGNU/"
"http://mirror.csclub.uwaterloo.ca/nongnu/"
"ftp://ftp.hu.netfilter.org/"
"ftp://www.lt.netfilter.org/pub/")
(kernel.org
- "http://ramses.wh2.tu-dresden.de/pub/mirrors/kernel.org/"
"http://linux-kernel.uio.no/pub/"
"http://kernel.osuosl.org/pub/"
"http://ftp.be.debian.org/pub/"
(apache ; from http://www.apache.org/mirrors/dist.html
"http://www.eu.apache.org/dist/"
"http://www.us.apache.org/dist/"
- "http://apache.belnet.be/"
+ "https://ftp.nluug.nl/internet/apache/"
+ "http://apache.mirror.iweb.ca/"
"http://mirrors.ircam.fr/pub/apache/"
+ "http://apache.mirrors.ovh.net/ftp.apache.org/dist/"
"http://apache-mirror.rbc.ru/pub/apache/"
+ "ftp://ftp.osuosl.org/pub/apache/"
+ "http://mirrors.ibiblio.org/apache/"
;; As a last resort, try the archive.
"http://archive.apache.org/dist/")
"http://mirrors.nic.cz/CPAN/"
"http://mirror.ibcp.fr/pub/CPAN/"
"http://ftp.ntua.gr/pub/lang/perl/"
- "http://kvin.lv/pub/CPAN/"
"http://mirror.as43289.net/pub/CPAN/"
"http://cpan.cs.uu.nl/"
"http://cpan.uib.no/"
(imagemagick
;; from http://www.imagemagick.org/script/download.php
;; (without mirrors that are unavailable or not up to date)
- ;; mirrors keeping old versions at the top level
- "https://sunsite.icm.edu.pl/packages/ImageMagick/"
- ;; mirrors moving old versions to "legacy"
- "http://mirrors-usa.go-parts.com/mirrors/ImageMagick/"
- "http://mirror.checkdomain.de/imagemagick/"
- "http://ftp.surfnet.nl/pub/ImageMagick/"
- "http://mirror.searchdaimon.com/ImageMagick"
- "http://mirror.is.co.za/pub/imagemagick/"
- "http://www.imagemagick.org/download/"
- "ftp://mirror.aarnet.edu.au/pub/imagemagick/"
- "ftp://ftp.kddlabs.co.jp/graphics/ImageMagick/"
- "ftp://ftp.u-aizu.ac.jp/pub/graphics/image/ImageMagick/imagemagick.org/"
+ "https://sunsite.icm.edu.pl/packages/ImageMagick/releases"
+ "http://mirror.checkdomain.de/imagemagick/releases"
+ "ftp://ftp.u-aizu.ac.jp/pub/graphics/image/ImageMagick/imagemagick.org/releases"
"ftp://ftp.nluug.nl/pub/ImageMagick/"
- "ftp://ftp.tpnet.pl/pub/graphics/ImageMagick/"
- "ftp://ftp.fifi.org/pub/ImageMagick/"
- ;; one legacy location as a last resort
- "http://www.imagemagick.org/download/legacy/")
+ "http://www.imagemagick.org/download/releases/"
+ ;; Try this if all else fails (normally contains just the latest version).
+ "http://www.imagemagick.org/download/")
(debian
"http://ftp.de.debian.org/debian/"
"http://ftp.fr.debian.org/debian/"
"http://mirror.its.dal.ca/kde/"
"http://mirror.csclub.uwaterloo.ca/kde/"
"http://mirror.cc.columbia.edu/pub/software/kde/"
- "http://mirrors-usa.go-parts.com/kde"
"http://kde.mirrors.hoobly.com/"
"http://ftp.ussg.iu.edu/kde/"
"http://mirrors.mit.edu/kde/"
"https://openbsd.mirror.constant.com/pub/OpenBSD/"
"https://ftp4.usa.openbsd.org/pub/OpenBSD/"
"https://ftp5.usa.openbsd.org/pub/OpenBSD/"
- "https://mirror.esc7.net/pub/OpenBSD/"))))
+ "https://mirror.esc7.net/pub/OpenBSD/")
+ (mate
+ "https://pub.mate-desktop.org/releases/"
+ "http://pub.mate-desktop.org/releases/"))))
(define %mirror-file
;; Copy of the list of mirrors to a file. This allows us to keep a single
;; List of content-addressed mirrors. Each mirror is represented as a
;; procedure that takes a file name, an algorithm (symbol) and a hash
;; (bytevector), and returns a URL or #f.
- ;; Note: Avoid 'https' to mitigate <http://bugs.gnu.org/22774>.
- ;; TODO: Add more.
- '(list (lambda (file algo hash)
- ;; Files served by 'guix publish' are accessible under a single
- ;; hash algorithm.
- (string-append "http://mirror.hydra.gnu.org/file/"
- file "/" (symbol->string algo) "/"
- (bytevector->nix-base32-string hash)))
- (lambda (file algo hash)
- ;; 'tarballs.nixos.org' supports several algorithms.
- (string-append "http://tarballs.nixos.org/"
- (symbol->string algo) "/"
- (bytevector->nix-base32-string hash)))))
+ '(begin
+ (use-modules (guix base32))
+
+ (define (guix-publish host)
+ (lambda (file algo hash)
+ ;; Files served by 'guix publish' are accessible under a single
+ ;; hash algorithm.
+ (string-append "https://" host "/file/"
+ file "/" (symbol->string algo) "/"
+ (bytevector->nix-base32-string hash))))
+
+ ;; XXX: (guix base16) appeared in March 2017 (and thus 0.13.0) so old
+ ;; installations of the daemon might lack it. Thus, load it lazily to
+ ;; avoid gratuitous errors. See <https://bugs.gnu.org/33542>.
+ (module-autoload! (current-module)
+ '(guix base16) '(bytevector->base16-string))
+
+ (list (guix-publish "ci.guix.gnu.org")
+ (lambda (file algo hash)
+ ;; 'tarballs.nixos.org' supports several algorithms.
+ (string-append "https://tarballs.nixos.org/"
+ (symbol->string algo) "/"
+ (bytevector->nix-base32-string hash)))
+ (lambda (file algo hash)
+ ;; Software Heritage usually archives VCS history rather than
+ ;; tarballs, but tarballs are sometimes available (and can be
+ ;; explicitly stored there.) For example, see
+ ;; <https://archive.softwareheritage.org/api/1/content/sha256:92d0fa1c311cacefa89853bdb53c62f4110cdfda3820346b59cbd098f40f955e/>.
+ (string-append "https://archive.softwareheritage.org/api/1/content/"
+ (symbol->string algo) ":"
+ (bytevector->base16-string hash) "/raw/")))))
(define %content-addressed-mirror-file
;; Content-addressed mirrors stored in a file.
(object->string %content-addressed-mirrors)))
(define built-in-builders*
- (let ((cache (make-weak-key-hash-table)))
- (lambda ()
- "Return, as a monadic value, the list of built-in builders supported by
-the daemon."
- (lambda (store)
- ;; Memoize the result to avoid repeated RPCs.
- (values (or (hashq-ref cache store)
- (let ((result (built-in-builders store)))
- (hashq-set! cache store result)
- result))
- store)))))
+ (store-lift built-in-builders))
(define* (built-in-download file-name url
#:key system hash-algo hash
mirrors content-addressed-mirrors
+ executable?
(guile 'unused))
- "Download FILE-NAME from URL using the built-in 'download' builder.
+ "Download FILE-NAME from URL using the built-in 'download' builder. When
+EXECUTABLE? is true, make the downloaded file executable.
This is an \"out-of-band\" download in that the returned derivation does not
explicitly depend on Guile, GnuTLS, etc. Instead, the daemon performs the
#:system system
#:hash-algo hash-algo
#:hash hash
- #:inputs `((,mirrors)
- (,content-addressed-mirrors))
+ #:recursive? executable?
+ #:sources (list mirrors content-addressed-mirrors)
;; Honor the user's proxy and locale settings.
#:leaked-env-vars '("http_proxy" "https_proxy"
#:env-vars `(("url" . ,(object->string url))
("mirrors" . ,mirrors)
("content-addressed-mirrors"
- . ,content-addressed-mirrors))
+ . ,content-addressed-mirrors)
+ ,@(if executable?
+ '(("executable" . "1"))
+ '()))
;; Do not offload this derivation because we cannot be
;; sure that the remote daemon supports the 'download'
;; for that built-in is widespread.
#:local-build? #t)))
-(define* (url-fetch url hash-algo hash
- #:optional name
- #:key (system (%current-system))
- (guile (default-guile)))
- "Return a fixed-output derivation 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.
+(define* (url-fetch* url hash-algo hash
+ #:optional name
+ #:key (system (%current-system))
+ (guile (default-guile))
+ executable?)
+ "Return a fixed-output derivation that fetches data from 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. When EXECUTABLE? is
+true, make the downloaded file executable.
When one of the URL starts with mirror://, then its host part is
interpreted as the name of a mirror scheme, taken from %MIRROR-FILE.
-Alternately, when URL starts with file://, return the corresponding file name
-in the store."
+Alternatively, when URL starts with file://, return the corresponding file
+name in the store."
(define file-name
(match url
((head _ ...)
#:system system
#:hash-algo hash-algo
#:hash hash
+ #:executable? executable?
#:mirrors %mirror-file
#:content-addressed-mirrors
%content-addressed-mirror-file)))))
+(define* (url-fetch/executable url hash-algo hash
+ #:optional name
+ #:key (system (%current-system))
+ (guile (default-guile)))
+ "Like 'url-fetch', but make the downloaded file executable."
+ (url-fetch* url hash-algo hash name
+ #:system system
+ #:guile guile
+ #:executable? #t))
+
(define* (url-fetch/tarbomb url hash-algo hash
#:optional name
#:key (system (%current-system))
(define tar
(module-ref (resolve-interface '(gnu packages base)) 'tar))
- (mlet %store-monad ((drv (url-fetch url hash-algo hash
- (string-append "tarbomb-"
- (or name file-name))
- #:system system
- #:guile guile)))
+ (mlet %store-monad ((drv (url-fetch* url hash-algo hash
+ (string-append "tarbomb-"
+ (or name file-name))
+ #:system system
+ #:guile guile))
+ (guile (package->derivation guile system)))
;; Take the tar bomb, and simply unpack it as a directory.
;; Use ungrafted tar/gzip so that the resulting tarball doesn't depend on
;; whether grafts are enabled.
#~(begin
(use-modules (guix build utils))
(mkdir #$output)
- (setenv "PATH" (string-append #$gzip "/bin"))
+ (setenv "PATH" (string-append #+gzip "/bin"))
(chdir #$output)
- (invoke (string-append #$tar "/bin/tar")
+ (invoke (string-append #+tar "/bin/tar")
"xf" #$drv)))
+ #:system system
+ #:guile-for-build guile
#:graft? #f
#:local-build? #t)))
(define unzip
(module-ref (resolve-interface '(gnu packages compression)) 'unzip))
- (mlet %store-monad ((drv (url-fetch url hash-algo hash
- (string-append "zipbomb-"
- (or name file-name))
- #:system system
- #:guile guile)))
+ (mlet %store-monad ((drv (url-fetch* url hash-algo hash
+ (string-append "zipbomb-"
+ (or name file-name))
+ #:system system
+ #:guile guile))
+ (guile (package->derivation guile system)))
;; Take the zip bomb, and simply unpack it as a directory.
;; Use ungrafted unzip so that the resulting tarball doesn't depend on
;; whether grafts are enabled.
(use-modules (guix build utils))
(mkdir #$output)
(chdir #$output)
- (invoke (string-append #$unzip "/bin/unzip")
+ (invoke (string-append #+unzip "/bin/unzip")
#$drv)))
+ #:system system
+ #:guile-for-build guile
#:graft? #f
#:local-build? #t)))
(lambda (temp port)
(let ((result
(parameterize ((current-output-port log))
- (build:url-fetch url temp
- #:mirrors %mirrors
- #:verify-certificate?
- verify-certificate?))))
+ (url-fetch url temp
+ #:mirrors %mirrors
+ #:verify-certificate? verify-certificate?))))
(close port)
(and result
(add-to-store store name recursive? "sha256" temp)))))))
HCoop / jackhill / guix / guix.git / blobdiff