ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 13:58:15 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

packages: Convert source derivations to monadic style.

Browse source 
* 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:
Ludovic Courtès 2015-01-14 14:42:10 +01:00
parent 023d9892c0
commit f220a83848
7 changed files with 89 additions and 110 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
gnu/packages/bootstrap.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; 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 "Return a variant of SOURCE, an <origin> instance, whose method uses
%BOOTSTRAP-GUILE to do its job." %BOOTSTRAP-GUILE to do its job."
(define (boot fetch) (define (boot fetch)
(lambda* (store url hash-algo hash (lambda* (url hash-algo hash
#:optional name #:key system) #:optional name #:key system)
(fetch store url hash-algo hash (fetch url hash-algo hash
#:guile %bootstrap-guile #:guile %bootstrap-guile
#:system system))) #:system system)))

37
guix/download.scm
View file

@ -197,27 +197,22 @@ (define (gnutls-package)
(let ((module (resolve-interface '(gnu packages gnutls)))) (let ((module (resolve-interface '(gnu packages gnutls))))
(module-ref module 'gnutls))) (module-ref module 'gnutls)))
(define* (url-fetch store url hash-algo hash (define* (url-fetch url hash-algo hash
#:optional name #:optional name
#:key (system (%current-system)) guile #:key (system (%current-system))
(guile (default-guile))
(mirrors %mirrors)) (mirrors %mirrors))
"Return the path of a fixed-output derivation in STORE that fetches "Return a fixed-output derivation that fetches URL (a string, or a list of
URL (a string, or a list of strings denoting alternate URLs), which is strings denoting alternate URLs), which is expected to have hash HASH of type
expected to have hash HASH of type HASH-ALGO (a symbol). By default, HASH-ALGO (a symbol). By default, the file name is the base name of URL;
the file name is the base name of URL; optionally, NAME can specify a optionally, NAME can specify a different file name.
different file name.
When one of the URL starts with mirror://, then its host part is 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 interpreted as the name of a mirror scheme, taken from MIRRORS; MIRRORS
must be a list of symbol/URL-list pairs." 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))
Alternately, when URL starts with file://, return the corresponding file name
in the store."
(define file-name (define file-name
(match url (match url
((head _ ...) ((head _ ...)
@ -254,26 +249,24 @@ (define builder
(let ((uri (and (string? url) (string->uri url)))) (let ((uri (and (string? url) (string->uri url))))
(if (or (and (string? url) (not uri)) (if (or (and (string? url) (not uri))
(and uri (memq (uri-scheme uri) '(#f file)))) (and uri (memq (uri-scheme uri) '(#f file))))
(add-to-store store (or name file-name) (interned-file (if uri (uri-path uri) url)
#f "sha256" (if uri (uri-path uri) url)) (or name file-name))
(run-with-store store (mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name file-name) builder (gexp->derivation (or name file-name) builder
#:guile-for-build guile
#:system system #:system system
#:hash-algo hash-algo #:hash-algo hash-algo
#:hash hash #:hash hash
#:modules '((guix build download) #:modules '((guix build download)
(guix build utils) (guix build utils)
(guix ftp-client)) (guix ftp-client))
#:guile-for-build guile-for-build
;; In general, offloading downloads is not a good idea. ;; In general, offloading downloads is not a good idea.
;;#:local-build? #t ;;#:local-build? #t
;; FIXME: The above would also disable use of ;; FIXME: The above would also disable use of
;; substitutes, so comment it out; see ;; substitutes, so comment it out; see
;; <https://bugs.gnu.org/18747>. ;; <https://bugs.gnu.org/18747>.
) )))))
#:guile-for-build guile-for-build
#:system system))))
(define* (download-to-store store url #:optional (name (basename url)) (define* (download-to-store store url #:optional (name (basename url))
#:key (log (current-error-port))) #:key (log (current-error-port)))

28
guix/git-download.scm
View file

@ -53,23 +53,13 @@ (define (git-package)
(let ((distro (resolve-interface '(gnu packages version-control)))) (let ((distro (resolve-interface '(gnu packages version-control))))
(module-ref distro 'git))) (module-ref distro 'git)))
(define* (git-fetch store ref hash-algo hash (define* (git-fetch ref hash-algo hash
#:optional name #:optional name
#:key (system (%current-system)) guile #:key (system (%current-system)) (guile (default-guile))
(git (git-package))) (git (git-package)))
"Return a fixed-output derivation in STORE that fetches REF, a "Return a fixed-output derivation that fetches REF, a <git-reference>
<git-reference> object. The output is expected to have recursive hash HASH of object. The output is expected to have recursive hash HASH of type
type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
#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)))))
(define inputs (define inputs
;; When doing 'git clone --recursive', we need sed, grep, etc. to be ;; When doing 'git clone --recursive', we need sed, grep, etc. to be
;; available so that 'git submodule' works. ;; available so that 'git submodule' works.
@ -96,7 +86,7 @@ (define build
#:recursive? '#$(git-reference-recursive? ref) #:recursive? '#$(git-reference-recursive? ref)
#:git-command (string-append #$git "/bin/git")))) #: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 (gexp->derivation (or name "git-checkout") build
#:system system #:system system
;; FIXME: See <https://bugs.gnu.org/18747>. ;; FIXME: See <https://bugs.gnu.org/18747>.
@ -106,9 +96,7 @@ (define build
#:recursive? #t #:recursive? #t
#:modules '((guix build git) #:modules '((guix build git)
(guix build utils)) (guix build utils))
#:guile-for-build guile-for-build #:guile-for-build guile
#:local-build? #t) #:local-build? #t)))
#:guile-for-build guile-for-build
#:system system))
;;; git-download.scm ends here ;;; git-download.scm ends here

73
guix/packages.scm
View file

@ -331,6 +331,7 @@ (define (default-guile)
(let ((distro (resolve-interface '(gnu packages commencement)))) (let ((distro (resolve-interface '(gnu packages commencement))))
(module-ref distro 'guile-final))) (module-ref distro 'guile-final)))
;; TODO: Rewrite using %STORE-MONAD and gexps.
(define* (patch-and-repack store source patches (define* (patch-and-repack store source patches
#:key #:key
(inputs '()) (inputs '())
@ -476,37 +477,6 @@ (define (first-file directory)
#:modules modules #:modules modules
#:guile-for-build guile-for-build))) #: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) (define (transitive-inputs inputs)
(let loop ((inputs inputs) (let loop ((inputs inputs)
(result '())) (result '()))
@ -949,5 +919,42 @@ (define package->derivation
(define package->cross-derivation (define package->cross-derivation
(store-lift package-cross-derivation)) (store-lift package-cross-derivation))
(define origin->derivation (define patch-and-repack*
(store-lift package-source-derivation)) (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))

28
guix/svn-download.scm
View file

@ -49,23 +49,13 @@ (define (subversion-package)
(let ((distro (resolve-interface '(gnu packages version-control)))) (let ((distro (resolve-interface '(gnu packages version-control))))
(module-ref distro 'subversion))) (module-ref distro 'subversion)))
(define* (svn-fetch store ref hash-algo hash (define* (svn-fetch ref hash-algo hash
#:optional name #:optional name
#:key (system (%current-system)) guile #:key (system (%current-system)) (guile (default-guile))
(svn (subversion-package))) (svn (subversion-package)))
"Return a fixed-output derivation in STORE that fetches REF, a "Return a fixed-output derivation that fetches REF, a <svn-reference>
<svn-reference> object. The output is expected to have recursive hash HASH of object. The output is expected to have recursive hash HASH of type
type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
#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)))))
(define build (define build
#~(begin #~(begin
(use-modules (guix build svn)) (use-modules (guix build svn))
@ -74,7 +64,7 @@ (define build
#$output #$output
#:svn-command (string-append #$svn "/bin/svn")))) #: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 (gexp->derivation (or name "svn-checkout") build
#:system system #:system system
;; FIXME: See <https://bugs.gnu.org/18747>. ;; FIXME: See <https://bugs.gnu.org/18747>.
@ -84,9 +74,7 @@ (define build
#:recursive? #t #:recursive? #t
#:modules '((guix build svn) #:modules '((guix build svn)
(guix build utils)) (guix build utils))
#:guile-for-build guile-for-build #:guile-for-build guile
#:local-build? #t) #:local-build? #t)))
#:guile-for-build guile-for-build
#:system system))
;;; svn-download.scm ends here ;;; svn-download.scm ends here

21
tests/builders.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -59,6 +59,9 @@ (define %bootstrap-search-paths
(define network-reachable? (define network-reachable?
(false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))) (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)))
(define url-fetch*
(store-lower url-fetch))
(test-begin "builders") (test-begin "builders")
@ -68,8 +71,8 @@ (define network-reachable?
"ftp://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz")) "ftp://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz"))
(hash (nix-base32-string->bytevector (hash (nix-base32-string->bytevector
"0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6")) "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6"))
(drv (url-fetch %store url 'sha256 hash (drv (url-fetch* %store url 'sha256 hash
#:guile %bootstrap-guile)) #:guile %bootstrap-guile))
(out-path (derivation->output-path drv))) (out-path (derivation->output-path drv)))
(and (build-derivations %store (list drv)) (and (build-derivations %store (list drv))
(file-exists? out-path) (file-exists? out-path)
@ -78,16 +81,16 @@ (define network-reachable?
(test-assert "url-fetch, file" (test-assert "url-fetch, file"
(let* ((file (search-path %load-path "guix.scm")) (let* ((file (search-path %load-path "guix.scm"))
(hash (call-with-input-file file port-sha256)) (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) (and (file-exists? out)
(valid-path? %store out)))) (valid-path? %store out))))
(test-assert "url-fetch, file URI" (test-assert "url-fetch, file URI"
(let* ((file (search-path %load-path "guix.scm")) (let* ((file (search-path %load-path "guix.scm"))
(hash (call-with-input-file file port-sha256)) (hash (call-with-input-file file port-sha256))
(out (url-fetch %store (out (url-fetch* %store
(string-append "file://" (canonicalize-path file)) (string-append "file://" (canonicalize-path file))
'sha256 hash))) 'sha256 hash)))
(and (file-exists? out) (and (file-exists? out)
(valid-path? %store 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") (let* ((url "http://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz")
(hash (nix-base32-string->bytevector (hash (nix-base32-string->bytevector
"0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6")) "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6"))
(tarball (url-fetch %store url 'sha256 hash (tarball (url-fetch* %store url 'sha256 hash
#:guile %bootstrap-guile)) #:guile %bootstrap-guile))
(build (gnu-build %store "hello-2.8" (build (gnu-build %store "hello-2.8"
`(("source" ,tarball) `(("source" ,tarball)
,@%bootstrap-inputs) ,@%bootstrap-inputs)

6
tests/packages.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; 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" (let* ((file (search-bootstrap-binary "guile-2.0.9.tar.xz"
(%current-system))) (%current-system)))
(sha256 (call-with-input-file file port-sha256)) (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) #:optional name #:key system)
(pk 'fetch url hash-algo hash name system) (pk 'fetch url hash-algo hash name system)
(add-to-store store (basename url) #f "sha256" url))) (interned-file url)))
(source (bootstrap-origin (source (bootstrap-origin
(origin (origin
(method fetch) (method fetch)