aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-05-01 21:07:52 +0200
committerLudovic Courtès <ludo@gnu.org>2014-05-01 22:31:36 +0200
commit6f8f8ccb5bcc883a63c2d98463f514c9745dcb8e (patch)
tree0d3a412209ba2a07dce3a5f47110848b175c3ebf
parent53e89b1732d2935d69a199c0213568ae1e66eb60 (diff)
downloadguix-6f8f8ccb5bcc883a63c2d98463f514c9745dcb8e.tar
guix-6f8f8ccb5bcc883a63c2d98463f514c9745dcb8e.tar.gz
download: Rewrite using gexps.
* guix/download.scm (gnutls-derivation): Remove. (gnutls-package): New procedure. (url-fetch): Rewrite using 'gexp->derivation'.
-rw-r--r--guix/download.scm88
1 files changed, 41 insertions, 47 deletions
diff --git a/guix/download.scm b/guix/download.scm
index 2cb0740897..8ec17ae556 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -23,6 +23,8 @@
#:use-module (guix packages)
#:use-module ((guix store) #:select (derivation-path? add-to-store))
#:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:))
+ #:use-module (guix monads)
+ #:use-module (guix gexp)
#:use-module (guix utils)
#:use-module (web uri)
#:use-module (srfi srfi-1)
@@ -167,11 +169,10 @@
"http://ftp.fr.debian.org/debian/"
"http://ftp.debian.org/debian/"))))
-(define (gnutls-derivation store system)
- "Return the GnuTLS derivation for SYSTEM."
- (let* ((module (resolve-interface '(gnu packages gnutls)))
- (gnutls (module-ref module 'gnutls)))
- (package-derivation store gnutls system)))
+(define (gnutls-package)
+ "Return the GnuTLS package for SYSTEM."
+ (let ((module (resolve-interface '(gnu packages gnutls))))
+ (module-ref module 'gnutls)))
(define* (url-fetch store url hash-algo hash
#:optional name
@@ -186,22 +187,13 @@ 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
- #:mirrors ',mirrors)))
-
(define guile-for-build
- (match guile
- ((? package?)
- (package-derivation store guile system))
- ((and (? string?) (? derivation-path?))
- guile)
- (#f ; the default
- (let* ((distro (resolve-interface '(gnu packages base)))
- (guile (module-ref distro 'guile-final)))
- (package-derivation store guile system)))))
+ (package-derivation store
+ (or guile
+ (let ((distro
+ (resolve-interface '(gnu packages base))))
+ (module-ref distro 'guile-final)))
+ system))
(define file-name
(match url
@@ -219,34 +211,36 @@ must be a list of symbol/URL-list pairs."
((url ...)
(any https? url)))))
- (let* ((gnutls-drv (if need-gnutls?
- (gnutls-derivation store system)
- (values #f #f)))
- (gnutls (and gnutls-drv
- (derivation->output-path gnutls-drv "out")))
- (env-vars (if gnutls
- (let ((dir (string-append gnutls "/share/guile/site")))
- ;; XXX: `GUILE_LOAD_COMPILED_PATH' is overridden
- ;; by `build-expression->derivation', so we can't
- ;; set it here.
- `(("GUILE_LOAD_PATH" . ,dir)))
- '())))
- (build-expression->derivation store (or name file-name) builder
- #:system system
- #:inputs (if gnutls-drv
- `(("gnutls" ,gnutls-drv))
- '())
- #:hash-algo hash-algo
- #:hash hash
- #:modules '((guix build download)
- (guix build utils)
- (guix ftp-client))
- #:guile-for-build guile-for-build
- #:env-vars env-vars
+ (define builder
+ #~(begin
+ #$(if need-gnutls?
+
+ ;; Add GnuTLS to the inputs and to the load path.
+ #~(eval-when (load expand eval)
+ (set! %load-path
+ (cons (string-append #$(gnutls-package)
+ "/share/guile/site")
+ %load-path)))
+ #~#t)
+
+ (use-modules (guix build download))
+ (url-fetch '#$url #$output
+ #:mirrors '#$mirrors)))
+
+ (run-with-store store
+ (gexp->derivation (or name file-name) builder
+ #:system system
+ #:hash-algo hash-algo
+ #:hash hash
+ #:modules '((guix build download)
+ (guix build utils)
+ (guix ftp-client))
+ #:guile-for-build guile-for-build
- ;; In general, offloading downloads is not a
- ;; good idea.
- #:local-build? #t)))
+ ;; In general, offloading downloads is not a good idea.
+ #:local-build? #t)
+ #:guile-for-build guile-for-build
+ #:system system))
(define* (download-to-store store url #:optional (name (basename url))
#:key (log (current-error-port)))