diff options
| -rw-r--r-- | guix/download.scm | 88 |
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))) |