mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
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.
This commit is contained in:
parent
023d9892c0
commit
f220a83848
7 changed files with 89 additions and 110 deletions
|
@ -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 @@ (define (bootstrap-origin source)
|
|||
"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 @@ (define (gnutls-package)
|
|||
(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 @@ (define builder
|
|||
(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 @@ (define (git-package)
|
|||
(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 @@ (define build
|
|||
#: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 @@ (define build
|
|||
#: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 @@ (define (default-guile)
|
|||
(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 @@ (define (first-file directory)
|
|||
#: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 @@ (define package->derivation
|
|||
(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 @@ (define (subversion-package)
|
|||
(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 @@ (define build
|
|||
#$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 @@ (define build
|
|||
#: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 %bootstrap-search-paths
|
|||
(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 @@ (define network-reachable?
|
|||
"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 @@ (define network-reachable?
|
|||
(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 @@ (define network-reachable?
|
|||
(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 @@ (define read-at
|
|||
(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)
|
||||
|
|
Loading…
Reference in a new issue