7 files changed, 89 insertions(+), 110 deletions(-)

M gnu/packages/bootstrap.scm
M guix/download.scm
M guix/git-download.scm
M guix/packages.scm
M guix/svn-download.scm
M tests/builders.scm
M tests/packages.scm

@@ 1,5 1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;


@@ 58,9 58,9 @@
   "Return a variant of SOURCE, an <origin> instance, whose method uses
 %BOOTSTRAP-GUILE to do its job."
   (define (boot fetch)
-    (lambda* (store url hash-algo hash
+    (lambda* (url hash-algo hash
               #:optional name #:key system)
-      (fetch store url hash-algo hash
+      (fetch url hash-algo hash
              #:guile %bootstrap-guile
              #:system system)))
 

@@ 197,27 197,22 @@
   (let ((module (resolve-interface '(gnu packages gnutls))))
     (module-ref module 'gnutls)))
 
-(define* (url-fetch store url hash-algo hash
+(define* (url-fetch url hash-algo hash
                     #:optional name
-                    #:key (system (%current-system)) guile
+                    #:key (system (%current-system))
+                    (guile (default-guile))
                     (mirrors %mirrors))
-  "Return the path of a fixed-output derivation in STORE that fetches
-URL (a string, or a list of strings denoting alternate URLs), which is
-expected to have hash HASH of type HASH-ALGO (a symbol).  By default,
-the file name is the base name of URL; optionally, NAME can specify a
-different file name.
+  "Return a fixed-output derivation that fetches URL (a string, or a list of
+strings denoting alternate URLs), which is expected to have hash HASH of type
+HASH-ALGO (a symbol).  By default, the file name is the base name of URL;
+optionally, NAME can specify a 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 guile-for-build
-    (package-derivation store
-                        (or guile
-                            (let ((distro (resolve-interface
-                                           '(gnu packages commencement))))
-                              (module-ref distro 'guile-final)))
-                        system))
+must be a list of symbol/URL-list pairs.
 
+Alternately, when URL starts with file://, return the corresponding file name
+in the store."
   (define file-name
     (match url
       ((head _ ...)


@@ 254,26 249,24 @@ must be a list of symbol/URL-list pairs."
   (let ((uri (and (string? url) (string->uri url))))
     (if (or (and (string? url) (not uri))
             (and uri (memq (uri-scheme uri) '(#f file))))
-        (add-to-store store (or name file-name)
-                      #f "sha256" (if uri (uri-path uri) url))
-        (run-with-store store
+        (interned-file (if uri (uri-path uri) url)
+                       (or name file-name))
+        (mlet %store-monad ((guile (package->derivation guile system)))
           (gexp->derivation (or name file-name) builder
+                            #:guile-for-build guile
                             #: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
                             ;; FIXME: The above would also disable use of
                             ;; substitutes, so comment it out; see
                             ;; <https://bugs.gnu.org/18747>.
-                            )
-          #:guile-for-build guile-for-build
-          #:system system))))
+                            )))))
 
 (define* (download-to-store store url #:optional (name (basename url))
                             #:key (log (current-error-port)))

@@ 53,23 53,13 @@
   (let ((distro (resolve-interface '(gnu packages version-control))))
     (module-ref distro 'git)))
 
-(define* (git-fetch store ref hash-algo hash
+(define* (git-fetch ref hash-algo hash
                     #:optional name
-                    #:key (system (%current-system)) guile
+                    #:key (system (%current-system)) (guile (default-guile))
                     (git (git-package)))
-  "Return a fixed-output derivation in STORE that fetches REF, a
-<git-reference> object.  The output is expected to have recursive hash HASH of
-type HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if
-#f."
-  (define guile-for-build
-    (match guile
-      ((? package?)
-       (package-derivation store guile system))
-      (#f                                         ; the default
-       (let* ((distro (resolve-interface '(gnu packages commencement)))
-              (guile  (module-ref distro 'guile-final)))
-         (package-derivation store guile system)))))
-
+  "Return a fixed-output derivation that fetches REF, a <git-reference>
+object.  The output is expected to have recursive hash HASH of type
+HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
   (define inputs
     ;; When doing 'git clone --recursive', we need sed, grep, etc. to be
     ;; available so that 'git submodule' works.


@@ 96,7 86,7 @@ type HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if
                    #:recursive? '#$(git-reference-recursive? ref)
                    #:git-command (string-append #$git "/bin/git"))))
 
-  (run-with-store store
+  (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "git-checkout") build
                       #:system system
                       ;; FIXME: See <https://bugs.gnu.org/18747>.


@@ 106,9 96,7 @@ type HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if
                       #:recursive? #t
                       #:modules '((guix build git)
                                   (guix build utils))
-                      #:guile-for-build guile-for-build
-                      #:local-build? #t)
-    #:guile-for-build guile-for-build
-    #:system system))
+                      #:guile-for-build guile
+                      #:local-build? #t)))
 
 ;;; git-download.scm ends here

@@ 331,6 331,7 @@ derivations."
   (let ((distro (resolve-interface '(gnu packages commencement))))
     (module-ref distro 'guile-final)))
 
+;; TODO: Rewrite using %STORE-MONAD and gexps.
 (define* (patch-and-repack store source patches
                            #:key
                            (inputs '())


@@ 476,37 477,6 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
                                  #:modules modules
                                  #:guile-for-build guile-for-build)))
 
-(define* (package-source-derivation store source
-                                    #:optional (system (%current-system)))
-  "Return the derivation path for SOURCE, a package source, for SYSTEM."
-  (match source
-    (($ <origin> uri method sha256 name () #f)
-     ;; No patches, no snippet: this is a fixed-output derivation.
-     (method store uri 'sha256 sha256 name
-             #:system system))
-    (($ <origin> uri method sha256 name (patches ...) snippet
-        (flags ...) inputs (modules ...) (imported-modules ...)
-        guile-for-build)
-     ;; Patches and/or a snippet.
-     (let ((source (method store uri 'sha256 sha256 name
-                           #:system system))
-           (guile  (match (or guile-for-build (default-guile))
-                     ((? package? p)
-                      (package-derivation store p system
-                                          #:graft? #f)))))
-       (patch-and-repack store source patches
-                         #:inputs inputs
-                         #:snippet snippet
-                         #:flags flags
-                         #:system system
-                         #:modules modules
-                         #:imported-modules modules
-                         #:guile-for-build guile)))
-    ((and (? string?) (? direct-store-path?) file)
-     file)
-    ((? string? file)
-     (add-to-store store (basename file) #t "sha256" file))))
-
 (define (transitive-inputs inputs)
   (let loop ((inputs  inputs)
              (result '()))


@@ 949,5 919,42 @@ cross-compilation target triplet."
 (define package->cross-derivation
   (store-lift package-cross-derivation))
 
-(define origin->derivation
-  (store-lift package-source-derivation))
+(define patch-and-repack*
+  (store-lift patch-and-repack))
+
+(define* (origin->derivation source
+                             #:optional (system (%current-system)))
+  "When SOURCE is an <origin> object, return its derivation for SYSTEM.  When
+SOURCE is a file name, return either the interned file name (if SOURCE is
+outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
+  (match source
+    (($ <origin> uri method sha256 name () #f)
+     ;; No patches, no snippet: this is a fixed-output derivation.
+     (method uri 'sha256 sha256 name #:system system))
+    (($ <origin> uri method sha256 name (patches ...) snippet
+        (flags ...) inputs (modules ...) (imported-modules ...)
+        guile-for-build)
+     ;; Patches and/or a snippet.
+     (mlet %store-monad ((source (method uri 'sha256 sha256 name
+                                         #:system system))
+                         (guile  (package->derivation (or guile-for-build
+                                                          (default-guile))
+                                                      system
+                                                      #:graft? #f)))
+       (patch-and-repack* source patches
+                          #:inputs inputs
+                          #:snippet snippet
+                          #:flags flags
+                          #:system system
+                          #:modules modules
+                          #:imported-modules modules
+                          #:guile-for-build guile)))
+    ((and (? string?) (? direct-store-path?) file)
+     (with-monad %store-monad
+       (return file)))
+    ((? string? file)
+     (interned-file file (basename file)
+                    #:recursive? #t))))
+
+(define package-source-derivation
+  (store-lower origin->derivation))

@@ 49,23 49,13 @@
   (let ((distro (resolve-interface '(gnu packages version-control))))
     (module-ref distro 'subversion)))
 
-(define* (svn-fetch store ref hash-algo hash
+(define* (svn-fetch ref hash-algo hash
                     #:optional name
-                    #:key (system (%current-system)) guile
+                    #:key (system (%current-system)) (guile (default-guile))
                     (svn (subversion-package)))
-  "Return a fixed-output derivation in STORE that fetches REF, a
-<svn-reference> object.  The output is expected to have recursive hash HASH of
-type HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if
-#f."
-  (define guile-for-build
-    (match guile
-      ((? package?)
-       (package-derivation store guile system))
-      (#f                                         ; the default
-       (let* ((distro (resolve-interface '(gnu packages commencement)))
-              (guile  (module-ref distro 'guile-final)))
-         (package-derivation store guile system)))))
-
+  "Return a fixed-output derivation that fetches REF, a <svn-reference>
+object.  The output is expected to have recursive hash HASH of type
+HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
   (define build
     #~(begin
         (use-modules (guix build svn))


@@ 74,7 64,7 @@ type HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if
                    #$output
                    #:svn-command (string-append #$svn "/bin/svn"))))
 
-  (run-with-store store
+  (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "svn-checkout") build
                       #:system system
                       ;; FIXME: See <https://bugs.gnu.org/18747>.


@@ 84,9 74,7 @@ type HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if
                       #:recursive? #t
                       #:modules '((guix build svn)
                                   (guix build utils))
-                      #:guile-for-build guile-for-build
-                      #:local-build? #t)
-    #:guile-for-build guile-for-build
-    #:system system))
+                      #:guile-for-build guile
+                      #:local-build? #t)))
 
 ;;; svn-download.scm ends here

@@ 1,5 1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;


@@ 59,6 59,9 @@
 (define network-reachable?
   (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)))
 
+(define url-fetch*
+  (store-lower url-fetch))
+
 
 (test-begin "builders")
 


@@ 68,8 71,8 @@
                      "ftp://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz"))
          (hash     (nix-base32-string->bytevector
                     "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6"))
-         (drv      (url-fetch %store url 'sha256 hash
-                              #:guile %bootstrap-guile))
+         (drv      (url-fetch* %store url 'sha256 hash
+                               #:guile %bootstrap-guile))
          (out-path (derivation->output-path drv)))
     (and (build-derivations %store (list drv))
          (file-exists? out-path)


@@ 78,16 81,16 @@
 (test-assert "url-fetch, file"
   (let* ((file (search-path %load-path "guix.scm"))
          (hash (call-with-input-file file port-sha256))
-         (out  (url-fetch %store file 'sha256 hash)))
+         (out  (url-fetch* %store file 'sha256 hash)))
     (and (file-exists? out)
          (valid-path? %store out))))
 
 (test-assert "url-fetch, file URI"
   (let* ((file (search-path %load-path "guix.scm"))
          (hash (call-with-input-file file port-sha256))
-         (out  (url-fetch %store
-                          (string-append "file://" (canonicalize-path file))
-                          'sha256 hash)))
+         (out  (url-fetch* %store
+                           (string-append "file://" (canonicalize-path file))
+                           'sha256 hash)))
     (and (file-exists? out)
          (valid-path? %store out))))
 


@@ 99,8 102,8 @@
   (let* ((url      "http://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz")
          (hash     (nix-base32-string->bytevector
                     "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6"))
-         (tarball  (url-fetch %store url 'sha256 hash
-                              #:guile %bootstrap-guile))
+         (tarball  (url-fetch* %store url 'sha256 hash
+                               #:guile %bootstrap-guile))
          (build    (gnu-build %store "hello-2.8"
                               `(("source" ,tarball)
                                 ,@%bootstrap-inputs)

@@ 1,5 1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;


@@ 178,10 178,10 @@
   (let* ((file   (search-bootstrap-binary "guile-2.0.9.tar.xz"
                                           (%current-system)))
          (sha256 (call-with-input-file file port-sha256))
-         (fetch  (lambda* (store url hash-algo hash
+         (fetch  (lambda* (url hash-algo hash
                            #:optional name #:key system)
                    (pk 'fetch url hash-algo hash name system)
-                   (add-to-store store (basename url) #f "sha256" url)))
+                   (interned-file url)))
          (source (bootstrap-origin
                   (origin
                     (method fetch)