[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
04/04: packages: Convert source derivations to monadic style.
|
From: |
Ludovic Courtès |
|
Subject: |
04/04: packages: Convert source derivations to monadic style. |
|
Date: |
Wed, 14 Jan 2015 13:46:04 +0000 |
civodul pushed a commit to branch master
in repository guix.
commit f220a8384890b2a50f30c62fba56e507333f1a92
Author: Ludovic Courtès <address@hidden>
Date: Wed Jan 14 14:42:10 2015 +0100
packages: Convert source derivations to monadic style.
* guix/packages.scm (origin->derivation): Take body from
'package-source-derivation', and change it to monadic style. Expect
METHOD to a monadic procedure.
(package-source-derivation): Define in terms of 'origin->derivation'.
* guix/download.scm (url-fetch): Remove 'store' argument. Remove
'guile-for-build' variable. Turn into a monadic procedure.
* guix/git-download.scm (git-fetch): Likewise.
* guix/svn-download.scm (svn-fetch): Likewise.
* tests/builders.scm (url-fetch*): New procedure.
Change tests to call 'url-fetch*' instead of 'url-fetch'.
* tests/packages.scm ("package-source-derivation, snippet"): Remove
'store' parameter of 'fetch' and change it to use 'interned-file'
instead of 'add-to-store'.
* gnu/packages/bootstrap.scm (bootstrap-origin)[boot]: Remove 'store'
parameter.
---
gnu/packages/bootstrap.scm | 6 ++--
guix/download.scm | 37 +++++++++-------------
guix/git-download.scm | 28 +++++------------
guix/packages.scm | 73 ++++++++++++++++++++++++--------------------
guix/svn-download.scm | 28 +++++------------
tests/builders.scm | 21 +++++++-----
tests/packages.scm | 6 ++--
7 files changed, 89 insertions(+), 110 deletions(-)
diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm
index 854d97b..56c26ee 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 <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <address@hidden>
;;;
;;; 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 035d604..9a18975 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 490d8c3..94a1245 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 909aa6d..05ba389 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 1c03bb9..ee67513 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 579246d..e5acc3e 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 <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <address@hidden>
;;;
;;; 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 f7d6155..3ee44ad 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 <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <address@hidden>
;;;
;;; 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)