nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

download: Rewrite using gexps. 

* guix/download.scm (gnutls-derivation): Remove.
  (gnutls-package): New procedure.
  (url-fetch): Rewrite using 'gexp->derivation'.
This commit is contained in:
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 packages)
#:use-module ((guix store) #:select (derivation-path? add-to-store)) #:use-module ((guix store) #:select (derivation-path? add-to-store))
#:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:)) #:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:))
#:use-module (guix monads)
#:use-module (guix gexp)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (web uri) #:use-module (web uri)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
@ -167,11 +169,10 @@
"http://ftp.fr.debian.org/debian/" "http://ftp.fr.debian.org/debian/"
"http://ftp.debian.org/debian/")))) "http://ftp.debian.org/debian/"))))
(define (gnutls-derivation store system) (define (gnutls-package)
"Return the GnuTLS derivation for SYSTEM." "Return the GnuTLS package for SYSTEM."
(let* ((module (resolve-interface '(gnu packages gnutls))) (let ((module (resolve-interface '(gnu packages gnutls))))
(gnutls (module-ref module 'gnutls))) (module-ref module 'gnutls)))
(package-derivation store gnutls system)))
(define* (url-fetch store url hash-algo hash (define* (url-fetch store url hash-algo hash
#:optional name #:optional name
@ -186,22 +187,13 @@ different file name.
When one of the URL starts with mirror://, then its host part is 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 interpreted as the name of a mirror scheme, taken from MIRRORS; MIRRORS
must be a list of symbol/URL-list pairs." 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 (define guile-for-build
(match guile (package-derivation store
((? package?) (or guile
(package-derivation store guile system)) (let ((distro
((and (? string?) (? derivation-path?)) (resolve-interface '(gnu packages base))))
guile) (module-ref distro 'guile-final)))
(#f ; the default system))
(let* ((distro (resolve-interface '(gnu packages base)))
(guile (module-ref distro 'guile-final)))
(package-derivation store guile system)))))
(define file-name (define file-name
(match url (match url
@ -219,34 +211,36 @@ must be a list of symbol/URL-list pairs."
((url ...) ((url ...)
(any https? url))))) (any https? url)))))
(let* ((gnutls-drv (if need-gnutls? (define builder
(gnutls-derivation store system) #~(begin
(values #f #f))) #$(if need-gnutls?
(gnutls (and gnutls-drv
(derivation->output-path gnutls-drv "out"))) ;; Add GnuTLS to the inputs and to the load path.
(env-vars (if gnutls #~(eval-when (load expand eval)
(let ((dir (string-append gnutls "/share/guile/site"))) (set! %load-path
;; XXX: `GUILE_LOAD_COMPILED_PATH' is overridden (cons (string-append #$(gnutls-package)
;; by `build-expression->derivation', so we can't "/share/guile/site")
;; set it here. %load-path)))
`(("GUILE_LOAD_PATH" . ,dir))) #~#t)
'())))
(build-expression->derivation store (or name file-name) builder (use-modules (guix build download))
(url-fetch '#$url #$output
#:mirrors '#$mirrors)))
(run-with-store store
(gexp->derivation (or name file-name) builder
#:system system #:system system
#:inputs (if gnutls-drv
`(("gnutls" ,gnutls-drv))
'())
#:hash-algo hash-algo #:hash-algo hash-algo
#:hash hash #:hash hash
#:modules '((guix build download) #:modules '((guix build download)
(guix build utils) (guix build utils)
(guix ftp-client)) (guix ftp-client))
#:guile-for-build guile-for-build #:guile-for-build guile-for-build
#:env-vars env-vars
;; In general, offloading downloads is not a ;; In general, offloading downloads is not a good idea.
;; good idea. #:local-build? #t)
#:local-build? #t))) #:guile-for-build guile-for-build
#:system system))
(define* (download-to-store store url #:optional (name (basename url)) (define* (download-to-store store url #:optional (name (basename url))
#:key (log (current-error-port))) #:key (log (current-error-port)))