From 6f8f8ccb5bcc883a63c2d98463f514c9745dcb8e Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 1 May 2014 21:07:52 +0200
Subject: download: Rewrite using gexps.

* guix/download.scm (gnutls-derivation): Remove.
  (gnutls-package): New procedure.
  (url-fetch): Rewrite using 'gexp->derivation'.
---
 guix/download.scm | 88 ++++++++++++++++++++++++++-----------------------------
 1 file changed, 41 insertions(+), 47 deletions(-)

(limited to 'guix/download.scm')

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)))
-- 
cgit v1.2.3