me
/
guix
Archived
1
0
Fork 0
Code

download: Rewrite using gexps. 

* guix/download.scm (gnutls-derivation): Remove.
  (gnutls-package): New procedure.
  (url-fetch): Rewrite using 'gexp->derivation'.
master
Ludovic Courtès 2014-05-01 21:07:52 +02:00
parent 53e89b1732
commit 6f8f8ccb5b
1 changed files with 41 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
guix/download.scm
View File

@ -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
(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
#: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
;; 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)))