diff options
| -rw-r--r-- | gnu/packages/bootstrap.scm | 6 | ||||
| -rw-r--r-- | guix/download.scm | 37 | ||||
| -rw-r--r-- | guix/git-download.scm | 28 | ||||
| -rw-r--r-- | guix/packages.scm | 73 | ||||
| -rw-r--r-- | guix/svn-download.scm | 28 | ||||
| -rw-r--r-- | tests/builders.scm | 21 | ||||
| -rw-r--r-- | tests/packages.scm | 6 |
7 files changed, 89 insertions, 110 deletions
diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm index 854d97bcfb..56c26eef18 100644 --- a/gnu/packages/bootstrap.scm +++ b/gnu/packages/bootstrap.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))) diff --git a/guix/download.scm b/guix/download.scm index 035d604aa7..9a1897525b 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -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))) diff --git a/guix/git-download.scm b/guix/git-download.scm index 490d8c319a..94a1245480 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -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 diff --git a/guix/packages.scm b/guix/packages.scm index 909aa6d90d..05ba389ad6 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -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)) diff --git a/guix/svn-download.scm b/guix/svn-download.scm index 1c03bb9e76..ee67513e16 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -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 diff --git a/tests/builders.scm b/tests/builders.scm index 579246d04d..e5acc3e038 100644 --- a/tests/builders.scm +++ b/tests/builders.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. ;;; @@ -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) diff --git a/tests/packages.scm b/tests/packages.scm index f7d6155ecc..3ee44adc98 100644 --- a/tests/packages.scm +++ b/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. ;;; @@ -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) |