TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

derivations: 'derivation' and related procedures return a single value. 

* guix/derivations.scm (derivation->output-path,
  derivation->output-paths): New procedures.
  (derivation-path->output-path): Use 'derivation->output-path'.
  (derivation-path->output-paths): Use 'derivation->output-paths'.
  (derivation): Accept 'derivation?' objects as inputs.  Return a single
  value.
  (build-derivations): New procedure.
  (compiled-modules): Use 'derivation->output-paths'.
  (build-expression->derivation)[source-path]: Add case for when the
  input matches 'derivation?'.
  [prologue]: Accept 'derivation?' objects in INPUTS.
  [mod-dir, go-dir]: Use 'derivation->output-path'.
* guix/download.scm (url-fetch): Adjust to the single-value return.
* guix/packages.scm (package-output): Use 'derivation->output-path'.
* guix/scripts/build.scm (guix-build): When the argument is
  'derivation-path?', pass it through 'read-derivation'.
  Use 'derivation-file-name' to print out the .drv file names, and to
  register them.  Use 'derivation->output-path' instead of
  'derivation-path->output-path'.
* guix/scripts/package.scm (roll-back): Adjust to the single-value
  return.
  (guix-package): Use 'derivation->output-path'.
* guix/ui.scm (show-what-to-build): Adjust to deal with 'derivation?'
  objects instead of .drv file names.
* gnu/system/grub.scm (grub-configuration-file): Use
  'derivation->output-path' instead of 'derivation-path->output-path'.
* gnu/system/vm.scm (qemu-image, system-qemu-image): Likewise.
* tests/builders.scm, tests/derivations.scm, tests/packages.scm,
  tests/store.scm, tests/union.scm: Adjust to the new calling
  convention.
* doc/guix.texi (Defining Packages, The Store, Derivations): Adjust
  accordingly.
This commit is contained in:
Ludovic Courtès 2013-09-18 17:01:40 +02:00
parent 81b66f8567
commit 59688fc4b5
18 changed files with 295 additions and 290 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
doc/guix.texi
View File

@ -987,8 +987,8 @@ The build actions it prescribes may then be realized by using the
@code{build-derivations} procedure (@pxref{The Store}). @code{build-derivations} procedure (@pxref{The Store}).
@deffn {Scheme Procedure} package-derivation @var{store} @var{package} [@var{system}] @deffn {Scheme Procedure} package-derivation @var{store} @var{package} [@var{system}]
Return the derivation path and corresponding @code{<derivation>} object Return the @code{<derivation>} object of @var{package} for @var{system}
of @var{package} for @var{system} (@pxref{Derivations}). (@pxref{Derivations}).
@var{package} must be a valid @code{<package>} object, and @var{system} @var{package} must be a valid @code{<package>} object, and @var{system}
must be a string denoting the target system type---e.g., must be a string denoting the target system type---e.g.,
@ -1004,8 +1004,8 @@ package for some other system:
@deffn {Scheme Procedure} package-cross-derivation @var{store} @ @deffn {Scheme Procedure} package-cross-derivation @var{store} @
@var{package} @var{target} [@var{system}] @var{package} @var{target} [@var{system}]
Return the derivation path and corresponding @code{<derivation>} object Return the @code{<derivation>} object of @var{package} cross-built from
of @var{package} cross-built from @var{system} to @var{target}. @var{system} to @var{target}.
@var{target} must be a valid GNU triplet denoting the target hardware @var{target} must be a valid GNU triplet denoting the target hardware
and operating system, such as @code{"mips64el-linux-gnu"} and operating system, such as @code{"mips64el-linux-gnu"}
@ -1068,8 +1068,9 @@ resulting store path.
@end deffn @end deffn
@deffn {Scheme Procedure} build-derivations @var{server} @var{derivations} @deffn {Scheme Procedure} build-derivations @var{server} @var{derivations}
Build @var{derivations} (a list of derivation paths), and return when Build @var{derivations} (a list of @code{<derivation>} objects or
the worker is done building them. Return @code{#t} on success. derivation paths), and return when the worker is done building them.
Return @code{#t} on success.
@end deffn @end deffn
@c FIXME @c FIXME
@ -1119,8 +1120,8 @@ otherwise manipulate derivations. The lowest-level primitive to create
a derivation is the @code{derivation} procedure: a derivation is the @code{derivation} procedure:
@deffn {Scheme Procedure} derivation @var{store} @var{name} @var{builder} @var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] [#:hash-mode #f] [#:inputs '()] [#:env-vars '()] [#:system (%current-system)] [#:references-graphs #f] @deffn {Scheme Procedure} derivation @var{store} @var{name} @var{builder} @var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] [#:hash-mode #f] [#:inputs '()] [#:env-vars '()] [#:system (%current-system)] [#:references-graphs #f]
Build a derivation with the given arguments. Return the resulting store Build a derivation with the given arguments, and return the resulting
path and @code{<derivation>} object. @code{<derivation>} object.
When @var{hash}, @var{hash-algo}, and @var{hash-mode} are given, a When @var{hash}, @var{hash-algo}, and @var{hash-mode} are given, a
@dfn{fixed-output derivation} is created---i.e., one whose result is @dfn{fixed-output derivation} is created---i.e., one whose result is
@ -1142,16 +1143,13 @@ to a Bash executable in the store:
(guix store) (guix store)
(guix derivations)) (guix derivations))
(call-with-values (let ((builder ; add the Bash script to the store
(lambda () (add-text-to-store store "my-builder.sh"
(let ((builder ; add the Bash script to the store "echo hello world > $out\n" '())))
(add-text-to-store store "my-builder.sh" (derivation store "foo"
"echo hello world > $out\n" '()))) bash `("-e" ,builder)
(derivation store "foo" #:env-vars '(("HOME" . "/homeless"))))
bash `("-e" ,builder) @result{} #<derivation /nix/store/@dots{}-foo.drv => /nix/store/@dots{}-foo>
#:env-vars '(("HOME" . "/homeless")))))
list)
@result{} ("/nix/store/@dots{}-foo.drv" #<<derivation> @dots{}>)
@end lisp @end lisp
As can be guessed, this primitive is cumbersome to use directly. An As can be guessed, this primitive is cumbersome to use directly. An
@ -1196,8 +1194,7 @@ containing one file:
(build-expression->derivation store "goo" (%current-system) (build-expression->derivation store "goo" (%current-system)
builder '())) builder '()))
@result{} "/nix/store/@dots{}-goo.drv" @result{} #<derivation /nix/store/@dots{}-goo.drv => @dots{}>
@result{} #<<derivation> @dots{}>
@end lisp @end lisp
@cindex strata of code @cindex strata of code

6
gnu/system/grub.scm
View File

@ -56,7 +56,7 @@ search.file ~a~%"
(any (match-lambda (any (match-lambda
(($ <menu-entry> _ linux) (($ <menu-entry> _ linux)
(let* ((drv (package-derivation store linux system)) (let* ((drv (package-derivation store linux system))
(out (derivation-path->output-path drv))) (out (derivation->output-path drv)))
(string-append out "/bzImage")))) (string-append out "/bzImage"))))
entries))) entries)))
@ -71,9 +71,9 @@ search.file ~a~%"
initrd ~a/initrd initrd ~a/initrd
}~%" }~%"
label label
(derivation-path->output-path linux-drv) (derivation->output-path linux-drv)
(string-join arguments) (string-join arguments)
(derivation-path->output-path initrd-drv)))))) (derivation->output-path initrd-drv))))))
(add-text-to-store store "grub.cfg" (add-text-to-store store "grub.cfg"
(string-append prologue (string-append prologue

12
gnu/system/vm.scm
View File

@ -206,10 +206,10 @@ It can be used to provide additional files, such as /etc files."
(define input->name+derivation (define input->name+derivation
(match-lambda (match-lambda
((name (? package? package)) ((name (? package? package))
`(,name . ,(derivation-path->output-path `(,name . ,(derivation->output-path
(package-derivation store package system)))) (package-derivation store package system))))
((name (? package? package) sub-drv) ((name (? package? package) sub-drv)
`(,name . ,(derivation-path->output-path `(,name . ,(derivation->output-path
(package-derivation store package system) (package-derivation store package system)
sub-drv))) sub-drv)))
((input (and (? string?) (? store-path?) file)) ((input (and (? string?) (? store-path?) file))
@ -361,14 +361,14 @@ It can be used to provide additional files, such as /etc files."
(parameterize ((%guile-for-build (package-derivation store guile-final))) (parameterize ((%guile-for-build (package-derivation store guile-final)))
(let* ((bash-drv (package-derivation store bash)) (let* ((bash-drv (package-derivation store bash))
(bash-file (string-append (derivation-path->output-path bash-drv) (bash-file (string-append (derivation->output-path bash-drv)
"/bin/bash")) "/bin/bash"))
(accounts (list (vector "root" "" 0 0 "System administrator" (accounts (list (vector "root" "" 0 0 "System administrator"
"/" bash-file))) "/" bash-file)))
(passwd (passwd-file store accounts)) (passwd (passwd-file store accounts))
(shadow (passwd-file store accounts #:shadow? #t)) (shadow (passwd-file store accounts #:shadow? #t))
(pam.d-drv (pam-services->directory store %pam-services)) (pam.d-drv (pam-services->directory store %pam-services))
(pam.d (derivation-path->output-path pam.d-drv)) (pam.d (derivation->output-path pam.d-drv))
(populate (populate
(add-text-to-store store "populate-qemu-image" (add-text-to-store store "populate-qemu-image"
(object->string (object->string
@ -381,11 +381,11 @@ It can be used to provide additional files, such as /etc files."
(symlink ,pam.d "etc/pam.d") (symlink ,pam.d "etc/pam.d")
(mkdir-p "var/run"))) (mkdir-p "var/run")))
(list passwd))) (list passwd)))
(out (derivation-path->output-path (out (derivation->output-path
(package-derivation store mingetty))) (package-derivation store mingetty)))
(getty (string-append out "/sbin/mingetty")) (getty (string-append out "/sbin/mingetty"))
(iu-drv (package-derivation store inetutils)) (iu-drv (package-derivation store inetutils))
(syslogd (string-append (derivation-path->output-path iu-drv) (syslogd (string-append (derivation->output-path iu-drv)
"/libexec/syslogd")) "/libexec/syslogd"))
(boot (add-text-to-store store "boot" (boot (add-text-to-store store "boot"
(object->string (object->string

6
guix/build-system/cmake.scm
View File

@ -72,9 +72,9 @@ provides a 'CMakeLists.txt' file as its build system."
(define builder (define builder
`(begin `(begin
(use-modules ,@modules) (use-modules ,@modules)
(cmake-build #:source ,(if (and source (derivation-path? source)) (cmake-build #:source ,(if (derivation? source)
(derivation-path->output-path source) (derivation->output-path source)
source) source)
#:system ,system #:system ,system
#:outputs %outputs #:outputs %outputs
#:inputs %build-inputs #:inputs %build-inputs

20
guix/build-system/gnu.scm
View File

@ -291,8 +291,8 @@ which could lead to gratuitous input divergence."
(define builder (define builder
`(begin `(begin
(use-modules ,@modules) (use-modules ,@modules)
(gnu-build #:source ,(if (and source (derivation-path? source)) (gnu-build #:source ,(if (derivation? source)
(derivation-path->output-path source) (derivation->output-path source)
source) source)
#:system ,system #:system ,system
#:outputs %outputs #:outputs %outputs
@ -319,8 +319,8 @@ which could lead to gratuitous input divergence."
(match guile (match guile
((? package?) ((? package?)
(package-derivation store guile system)) (package-derivation store guile system))
((and (? string?) (? derivation-path?)) ;; ((and (? string?) (? derivation-path?))
guile) ;; guile)
(#f ; the default (#f ; the default
(let* ((distro (resolve-interface '(gnu packages base))) (let* ((distro (resolve-interface '(gnu packages base)))
(guile (module-ref distro 'guile-final))) (guile (module-ref distro 'guile-final)))
@ -438,6 +438,8 @@ platform."
(let () (let ()
(define %build-host-inputs (define %build-host-inputs
',(map (match-lambda ',(map (match-lambda
((name (? derivation? drv) sub ...)
`(,name . ,(apply derivation->output-path drv sub)))
((name (? derivation-path? drv-path) sub ...) ((name (? derivation-path? drv-path) sub ...)
`(,name . ,(apply derivation-path->output-path `(,name . ,(apply derivation-path->output-path
drv-path sub))) drv-path sub)))
@ -447,6 +449,8 @@ platform."
(define %build-target-inputs (define %build-target-inputs
',(map (match-lambda ',(map (match-lambda
((name (? derivation? drv) sub ...)
`(,name . ,(apply derivation->output-path drv sub)))
((name (? derivation-path? drv-path) sub ...) ((name (? derivation-path? drv-path) sub ...)
`(,name . ,(apply derivation-path->output-path `(,name . ,(apply derivation-path->output-path
drv-path sub))) drv-path sub)))
@ -454,8 +458,8 @@ platform."
`(,name . ,path))) `(,name . ,path)))
(append (or implicit-target-inputs '()) inputs))) (append (or implicit-target-inputs '()) inputs)))
(gnu-build #:source ,(if (and source (derivation-path? source)) (gnu-build #:source ,(if (derivation? source)
(derivation-path->output-path source) (derivation->output-path source)
source) source)
#:system ,system #:system ,system
#:target ,target #:target ,target
@ -488,8 +492,8 @@ platform."
(match guile (match guile
((? package?) ((? package?)
(package-derivation store guile system)) (package-derivation store guile system))
((and (? string?) (? derivation-path?)) ;; ((and (? string?) (? derivation-path?))
guile) ;; guile)
(#f ; the default (#f ; the default
(let* ((distro (resolve-interface '(gnu packages base))) (let* ((distro (resolve-interface '(gnu packages base)))
(guile (module-ref distro 'guile-final))) (guile (module-ref distro 'guile-final)))

4
guix/build-system/perl.scm
View File

@ -62,8 +62,8 @@ provides a `Makefile.PL' file as its build system."
`(begin `(begin
(use-modules ,@modules) (use-modules ,@modules)
(perl-build #:name ,name (perl-build #:name ,name
#:source ,(if (and source (derivation-path? source)) #:source ,(if (derivation? source)
(derivation-path->output-path source) (derivation->output-path source)
source) source)
#:search-paths ',(map search-path-specification->sexp #:search-paths ',(map search-path-specification->sexp
(append perl-search-paths (append perl-search-paths

4
guix/build-system/python.scm
View File

@ -120,8 +120,8 @@ provides a 'setup.py' file as its build system."
`(begin `(begin
(use-modules ,@modules) (use-modules ,@modules)
(python-build #:name ,name (python-build #:name ,name
#:source ,(if (and source (derivation-path? source)) #:source ,(if (derivation? source)
(derivation-path->output-path source) (derivation->output-path source)
source) source)
#:configure-flags ,configure-flags #:configure-flags ,configure-flags
#:system ,system #:system ,system

79
guix/derivations.scm
View File

@ -58,6 +58,8 @@
read-derivation read-derivation
write-derivation write-derivation
derivation->output-path
derivation->output-paths
derivation-path->output-path derivation-path->output-path
derivation-path->output-paths derivation-path->output-paths
derivation derivation
@ -66,7 +68,8 @@
imported-modules imported-modules
compiled-modules compiled-modules
build-expression->derivation build-expression->derivation
imported-files)) imported-files)
#:replace (build-derivations))
;;; ;;;
;;; Nix derivations, as implemented in Nix's `derivations.cc'. ;;; Nix derivations, as implemented in Nix's `derivations.cc'.
@ -420,25 +423,30 @@ that form."
port) port)
(display ")" port)))) (display ")" port))))
(define* (derivation->output-path drv #:optional (output "out"))
"Return the store path of its output OUTPUT."
(let ((outputs (derivation-outputs drv)))
(and=> (assoc-ref outputs output) derivation-output-path)))
(define (derivation->output-paths drv)
"Return the list of name/path pairs of the outputs of DRV."
(map (match-lambda
((name . output)
(cons name (derivation-output-path output))))
(derivation-outputs drv)))
(define derivation-path->output-path (define derivation-path->output-path
;; This procedure is called frequently, so memoize it. ;; This procedure is called frequently, so memoize it.
(memoize (memoize
(lambda* (path #:optional (output "out")) (lambda* (path #:optional (output "out"))
"Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store
path of its output OUTPUT." path of its output OUTPUT."
(let* ((drv (call-with-input-file path read-derivation)) (derivation->output-path (call-with-input-file path read-derivation)))))
(outputs (derivation-outputs drv)))
(and=> (assoc-ref outputs output) derivation-output-path)))))
(define (derivation-path->output-paths path) (define (derivation-path->output-paths path)
"Read the derivation from PATH (`/nix/store/xxx.drv'), and return the "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the
list of name/path pairs of its outputs." list of name/path pairs of its outputs."
(let* ((drv (call-with-input-file path read-derivation)) (derivation->output-paths (call-with-input-file path read-derivation)))
(outputs (derivation-outputs drv)))
(map (match-lambda
((name . output)
(cons name (derivation-output-path output))))
outputs)))
;;; ;;;
@ -522,10 +530,10 @@ the derivation called NAME with hash HASH."
(inputs '()) (outputs '("out")) (inputs '()) (outputs '("out"))
hash hash-algo hash-mode hash hash-algo hash-mode
references-graphs) references-graphs)
"Build a derivation with the given arguments. Return the resulting "Build a derivation with the given arguments, and return the resulting
store path and <derivation> object. When HASH, HASH-ALGO, and HASH-MODE <derivation> object. When HASH, HASH-ALGO, and HASH-MODE are given, a
are given, a fixed-output derivation is created---i.e., one whose result is fixed-output derivation is created---i.e., one whose result is known in
known in advance, such as a file download. advance, such as a file download.
When REFERENCES-GRAPHS is true, it must be a list of file name/store path When REFERENCES-GRAPHS is true, it must be a list of file name/store path
pairs. In that case, the reference graph of each store path is exported in pairs. In that case, the reference graph of each store path is exported in
@ -610,6 +618,12 @@ the build environment in the corresponding file, in a simple text format."
(make-derivation-output "" hash-algo hash))) (make-derivation-output "" hash-algo hash)))
outputs)) outputs))
(inputs (map (match-lambda (inputs (map (match-lambda
(((? derivation? drv))
(make-derivation-input (derivation-file-name drv)
'("out")))
(((? derivation? drv) sub-drvs ...)
(make-derivation-input (derivation-file-name drv)
sub-drvs))
(((? direct-store-path? input)) (((? direct-store-path? input))
(make-derivation-input input '("out"))) (make-derivation-input input '("out")))
(((? direct-store-path? input) sub-drvs ...) (((? direct-store-path? input) sub-drvs ...)
@ -638,7 +652,21 @@ the build environment in the corresponding file, in a simple text format."
(cut write-derivation drv <>)) (cut write-derivation drv <>))
(map derivation-input-path (map derivation-input-path
inputs)))) inputs))))
(values file (set-file-name drv file))))) (set-file-name drv file))))
;;;
;;; Store compatibility layer.
;;;
(define (build-derivations store derivations)
"Build DERIVATIONS, a list of <derivation> objects or .drv file names."
(let ((build (@ (guix store) build-derivations)))
(build store (map (match-lambda
((? string? file) file)
((and drv ($ <derivation>))
(derivation-file-name drv)))
derivations))))
;;; ;;;
@ -730,7 +758,7 @@ they can refer to each other."
#:system system #:system system
#:guile guile #:guile guile
#:module-path module-path)) #:module-path module-path))
(module-dir (derivation-path->output-path module-drv)) (module-dir (derivation->output-path module-drv))
(files (map (lambda (m) (files (map (lambda (m)
(let ((f (string-join (map symbol->string m) (let ((f (string-join (map symbol->string m)
"/"))) "/")))
@ -794,7 +822,7 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS."
(or guile-for-build (%guile-for-build))) (or guile-for-build (%guile-for-build)))
(define guile (define guile
(string-append (derivation-path->output-path guile-drv) (string-append (derivation->output-path guile-drv)
"/bin/guile")) "/bin/guile"))
(define module-form? (define module-form?
@ -806,6 +834,8 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS."
;; When passed an input that is a source, return its path; otherwise ;; When passed an input that is a source, return its path; otherwise
;; return #f. ;; return #f.
(match-lambda (match-lambda
((_ (? derivation?) _ ...)
#f)
((_ path _ ...) ((_ path _ ...)
(and (not (derivation-path? path)) (and (not (derivation-path? path))
path)))) path))))
@ -830,10 +860,13 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS."
(() "out") (() "out")
((x) x)))) ((x) x))))
(cons name (cons name
(if (derivation-path? drv) (cond
(derivation-path->output-path drv ((derivation? drv)
sub) (derivation->output-path drv sub))
drv))))) ((derivation-path? drv)
(derivation-path->output-path drv
sub))
(else drv))))))
inputs)) inputs))
,@(if (null? modules) ,@(if (null? modules)
@ -878,13 +911,13 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS."
#:guile guile-drv #:guile guile-drv
#:system system))) #:system system)))
(mod-dir (and mod-drv (mod-dir (and mod-drv
(derivation-path->output-path mod-drv))) (derivation->output-path mod-drv)))
(go-drv (and (pair? modules) (go-drv (and (pair? modules)
(compiled-modules store modules (compiled-modules store modules
#:guile guile-drv #:guile guile-drv
#:system system))) #:system system)))
(go-dir (and go-drv (go-dir (and go-drv
(derivation-path->output-path go-drv)))) (derivation->output-path go-drv))))
(derivation store name guile (derivation store name guile
`("--no-auto-compile" `("--no-auto-compile"
,@(if mod-dir `("-L" ,mod-dir) '()) ,@(if mod-dir `("-L" ,mod-dir) '())

32
guix/download.scm
View File

@ -25,7 +25,6 @@
#:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:)) #:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:))
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:export (%mirrors #:export (%mirrors
url-fetch url-fetch
@ -212,27 +211,22 @@ must be a list of symbol/URL-list pairs."
((url ...) ((url ...)
(any https? url))))) (any https? url)))))
(let*-values (((gnutls-drv-path gnutls-drv) (let* ((gnutls-drv (if need-gnutls?
(if need-gnutls? (gnutls-derivation store system)
(gnutls-derivation store system) (values #f #f)))
(values #f #f))) (gnutls (and gnutls-drv
((gnutls) (derivation->output-path gnutls-drv "out")))
(and gnutls-drv (env-vars (if gnutls
(derivation-output-path (let ((dir (string-append gnutls "/share/guile/site")))
(assoc-ref (derivation-outputs gnutls-drv) ;; XXX: `GUILE_LOAD_COMPILED_PATH' is overridden
"out")))) ;; by `build-expression->derivation', so we can't
((env-vars) ;; set it here.
(if gnutls `(("GUILE_LOAD_PATH" . ,dir)))
(let ((dir (string-append gnutls "/share/guile/site"))) '())))
;; XXX: `GUILE_LOAD_COMPILED_PATH' is overridden
;; by `build-expression->derivation', so we can't
;; set it here.
`(("GUILE_LOAD_PATH" . ,dir)))
'())))
(build-expression->derivation store (or name file-name) system (build-expression->derivation store (or name file-name) system
builder builder
(if gnutls-drv (if gnutls-drv
`(("gnutls" ,gnutls-drv-path)) `(("gnutls" ,gnutls-drv))
'()) '())
#:hash-algo hash-algo #:hash-algo hash-algo
#:hash hash #:hash hash

11
guix/packages.scm
View File

@ -26,7 +26,6 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
@ -370,8 +369,8 @@ information in exceptions."
(define* (package-derivation store package (define* (package-derivation store package
#:optional (system (%current-system))) #:optional (system (%current-system)))
"Return the derivation path and corresponding <derivation> object of "Return the <derivation> object of PACKAGE for SYSTEM."
PACKAGE for SYSTEM."
;; Compute the derivation and cache the result. Caching is important ;; Compute the derivation and cache the result. Caching is important
;; because some derivations, such as the implicit inputs of the GNU build ;; because some derivations, such as the implicit inputs of the GNU build
;; system, will be queried many, many times in a row. ;; system, will be queried many, many times in a row.
@ -468,7 +467,5 @@ system identifying string)."
"Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
symbolic output name, such as \"out\". Note that this procedure calls symbolic output name, such as \"out\". Note that this procedure calls
`package-derivation', which is costly." `package-derivation', which is costly."
(let-values (((_ drv) (let ((drv (package-derivation store package system)))
(package-derivation store package system))) (derivation->output-path drv output)))
(derivation-output-path
(assoc-ref (derivation-outputs drv) output))))

23
guix/scripts/build.scm
View File

@ -250,7 +250,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(derivations-from-package-expressions (derivations-from-package-expressions
str package->derivation sys src?)) str package->derivation sys src?))
(('argument . (? derivation-path? drv)) (('argument . (? derivation-path? drv))
drv) (call-with-input-file drv read-derivation))
(('argument . (? string? x)) (('argument . (? string? x))
(let ((p (find-package x))) (let ((p (find-package x)))
(if src? (if src?
@ -280,24 +280,23 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(if (assoc-ref opts 'derivations-only?) (if (assoc-ref opts 'derivations-only?)
(begin (begin
(format #t "~{~a~%~}" drv) (format #t "~{~a~%~}" (map derivation-file-name drv))
(for-each (cut register-root <> <>) (for-each (cut register-root <> <>)
(map list drv) roots)) (map (compose list derivation-file-name) drv)
roots))
(or (assoc-ref opts 'dry-run?) (or (assoc-ref opts 'dry-run?)
(and (build-derivations (%store) drv) (and (build-derivations (%store) drv)
(for-each (lambda (d) (for-each (lambda (d)
(let ((drv (call-with-input-file d (format #t "~{~a~%~}"
read-derivation))) (map (match-lambda
(format #t "~{~a~%~}" ((out-name . out)
(map (match-lambda (derivation->output-path
((out-name . out) d out-name)))
(derivation-path->output-path (derivation-outputs d))))
d out-name)))
(derivation-outputs drv)))))
drv) drv)
(for-each (cut register-root <> <>) (for-each (cut register-root <> <>)
(map (lambda (drv) (map (lambda (drv)
(map cdr (map cdr
(derivation-path->output-paths drv))) (derivation->output-paths drv)))
drv) drv)
roots))))))))) roots)))))))))

19
guix/scripts/package.scm
View File

@ -234,12 +234,9 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(_ "nothing to do: already at the empty profile~%"))) (_ "nothing to do: already at the empty profile~%")))
((or (zero? previous-number) ; going to emptiness ((or (zero? previous-number) ; going to emptiness
(not (file-exists? previous-generation))) (not (file-exists? previous-generation)))
(let*-values (((drv-path drv) (let* ((drv (profile-derivation (%store) '()))
(profile-derivation (%store) '())) (prof (derivation->output-path drv "out")))
((prof) (when (not (build-derivations (%store) (list drv)))
(derivation-output-path
(assoc-ref (derivation-outputs drv) "out"))))
(when (not (build-derivations (%store) (list drv-path)))
(leave (_ "failed to build the empty profile~%"))) (leave (_ "failed to build the empty profile~%")))
(switch-symlinks previous-generation prof) (switch-symlinks previous-generation prof)
@ -558,7 +555,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(define (guile-missing?) (define (guile-missing?)
;; Return #t if %GUILE-FOR-BUILD is not available yet. ;; Return #t if %GUILE-FOR-BUILD is not available yet.
(let ((out (derivation-path->output-path (%guile-for-build)))) (let ((out (derivation->output-path (%guile-for-build))))
(not (valid-path? (%store) out)))) (not (valid-path? (%store) out))))
(define newest-available-packages (define newest-available-packages
@ -617,7 +614,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(case (version-compare candidate-version current-version) (case (version-compare candidate-version current-version)
((>) #t) ((>) #t)
((<) #f) ((<) #f)
((=) (let ((candidate-path (derivation-path->output-path ((=) (let ((candidate-path (derivation->output-path
(package-derivation (%store) pkg)))) (package-derivation (%store) pkg))))
(not (string=? current-path candidate-path)))))) (not (string=? current-path candidate-path))))))
(#f #f))) (#f #f)))
@ -808,7 +805,7 @@ more information.~%"))
(match tuple (match tuple
((name version sub-drv _ (deps ...)) ((name version sub-drv _ (deps ...))
(let ((output-path (let ((output-path
(derivation-path->output-path (derivation->output-path
drv sub-drv))) drv sub-drv)))
`(,name ,version ,sub-drv ,output-path `(,name ,version ,sub-drv ,output-path
,(canonicalize-deps deps)))))) ,(canonicalize-deps deps))))))
@ -841,11 +838,11 @@ more information.~%"))
(or dry-run? (or dry-run?
(and (build-derivations (%store) drv) (and (build-derivations (%store) drv)
(let* ((prof-drv (profile-derivation (%store) packages)) (let* ((prof-drv (profile-derivation (%store) packages))
(prof (derivation-path->output-path prof-drv)) (prof (derivation->output-path prof-drv))
(old-drv (profile-derivation (old-drv (profile-derivation
(%store) (manifest-packages (%store) (manifest-packages
(profile-manifest profile)))) (profile-manifest profile))))
(old-prof (derivation-path->output-path old-drv)) (old-prof (derivation->output-path old-drv))
(number (generation-number profile)) (number (generation-number profile))
;; Always use NUMBER + 1 for the new profile, ;; Always use NUMBER + 1 for the new profile,

34
guix/ui.scm
View File

@ -210,27 +210,27 @@ derivations listed in DRV. Return #t if there's something to build, #f
otherwise. When USE-SUBSTITUTES?, check and report what is prerequisites are otherwise. When USE-SUBSTITUTES?, check and report what is prerequisites are
available for download." available for download."
(let*-values (((build download) (let*-values (((build download)
(fold2 (lambda (drv-path build download) (fold2 (lambda (drv build download)
(let ((drv (call-with-input-file drv-path (let-values (((b d)
read-derivation))) (derivation-prerequisites-to-build
(let-values (((b d) store drv
(derivation-prerequisites-to-build #:use-substitutes?
store drv use-substitutes?)))
#:use-substitutes? (values (append b build)
use-substitutes?))) (append d download))))
(values (append b build)
(append d download)))))
'() '() '() '()
drv)) drv))
((build) ; add the DRV themselves ((build) ; add the DRV themselves
(delete-duplicates (delete-duplicates
(append (remove (compose (lambda (out) (append (map derivation-file-name
(or (valid-path? store out) (remove (lambda (drv)
(and use-substitutes? (let ((out (derivation->output-path
(has-substitutes? store drv)))
out)))) (or (valid-path? store out)
derivation-path->output-path) (and use-substitutes?
drv) (has-substitutes? store
out)))))
drv))
(map derivation-input-path build)))) (map derivation-input-path build))))
((download) ; add the references of DOWNLOAD ((download) ; add the references of DOWNLOAD
(if use-substitutes? (if use-substitutes?

8
tests/builders.scm
View File

@ -70,10 +70,10 @@
"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-path (url-fetch %store url 'sha256 hash (drv (url-fetch %store url 'sha256 hash
#:guile %bootstrap-guile)) #:guile %bootstrap-guile))
(out-path (derivation-path->output-path drv-path))) (out-path (derivation->output-path drv)))
(and (build-derivations %store (list drv-path)) (and (build-derivations %store (list drv))
(file-exists? out-path) (file-exists? out-path)
(valid-path? %store out-path)))) (valid-path? %store out-path))))
@ -93,7 +93,7 @@
#:implicit-inputs? #f #:implicit-inputs? #f
#:guile %bootstrap-guile #:guile %bootstrap-guile
#:search-paths %bootstrap-search-paths)) #:search-paths %bootstrap-search-paths))
(out (derivation-path->output-path build))) (out (derivation->output-path build)))
(and (build-derivations %store (list (pk 'hello-drv build))) (and (build-derivations %store (list (pk 'hello-drv build)))
(valid-path? %store out) (valid-path? %store out)
(file-exists? (string-append out "/bin/hello"))))) (file-exists? (string-append out "/bin/hello")))))

219
tests/derivations.scm
View File

@ -110,31 +110,27 @@
(let* ((builder (add-text-to-store %store "my-builder.sh" (let* ((builder (add-text-to-store %store "my-builder.sh"
"echo hello, world\n" "echo hello, world\n"
'())) '()))
(drv-path (derivation %store "foo" (drv (derivation %store "foo"
%bash `("-e" ,builder) %bash `("-e" ,builder)
#:env-vars '(("HOME" . "/homeless"))))) #:env-vars '(("HOME" . "/homeless")))))
(and (store-path? drv-path) (and (store-path? (derivation-file-name drv))
(valid-path? %store drv-path)))) (valid-path? %store (derivation-file-name drv)))))
(test-assert "build derivation with 1 source" (test-assert "build derivation with 1 source"
(let*-values (((builder) (let* ((builder (add-text-to-store %store "my-builder.sh"
(add-text-to-store %store "my-builder.sh" "echo hello, world > \"$out\"\n"
"echo hello, world > \"$out\"\n" '()))
'())) (drv (derivation %store "foo"
((drv-path drv) %bash `(,builder)
(derivation %store "foo" #:env-vars '(("HOME" . "/homeless")
%bash `(,builder) ("zzz" . "Z!")
#:env-vars '(("HOME" . "/homeless") ("AAA" . "A!"))
("zzz" . "Z!") #:inputs `((,builder))))
("AAA" . "A!")) (succeeded?
#:inputs `((,builder)))) (build-derivations %store (list drv))))
((succeeded?)
(build-derivations %store (list drv-path))))
(and succeeded? (and succeeded?
(let ((path (derivation-output-path (let ((path (derivation->output-path drv)))
(assoc-ref (derivation-outputs drv) "out"))))
(and (valid-path? %store path) (and (valid-path? %store path)
(string=? (derivation-file-name drv) drv-path)
(string=? (call-with-input-file path read-line) (string=? (call-with-input-file path read-line)
"hello, world")))))) "hello, world"))))))
@ -146,7 +142,7 @@
(input (search-path %load-path "ice-9/boot-9.scm")) (input (search-path %load-path "ice-9/boot-9.scm"))
(input* (add-to-store %store (basename input) (input* (add-to-store %store (basename input)
#t "sha256" input)) #t "sha256" input))
(drv-path (derivation %store "derivation-with-input-file" (drv (derivation %store "derivation-with-input-file"
%bash `(,builder) %bash `(,builder)
;; Cheat to pass the actual file name to the ;; Cheat to pass the actual file name to the
@ -155,22 +151,22 @@
#:inputs `((,builder) #:inputs `((,builder)
(,input))))) ; ← local file name (,input))))) ; ← local file name
(and (build-derivations %store (list drv-path)) (and (build-derivations %store (list drv))
;; Note: we can't compare the files because the above trick alters ;; Note: we can't compare the files because the above trick alters
;; the contents. ;; the contents.
(valid-path? %store (derivation-path->output-path drv-path))))) (valid-path? %store (derivation->output-path drv)))))
(test-assert "fixed-output derivation" (test-assert "fixed-output derivation"
(let* ((builder (add-text-to-store %store "my-fixed-builder.sh" (let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
"echo -n hello > $out" '())) "echo -n hello > $out" '()))
(hash (sha256 (string->utf8 "hello"))) (hash (sha256 (string->utf8 "hello")))
(drv-path (derivation %store "fixed" (drv (derivation %store "fixed"
%bash `(,builder) %bash `(,builder)
#:inputs `((,builder)) ; optional #:inputs `((,builder)) ; optional
#:hash hash #:hash-algo 'sha256)) #:hash hash #:hash-algo 'sha256))
(succeeded? (build-derivations %store (list drv-path)))) (succeeded? (build-derivations %store (list drv))))
(and succeeded? (and succeeded?
(let ((p (derivation-path->output-path drv-path))) (let ((p (derivation->output-path drv)))
(and (equal? (string->utf8 "hello") (and (equal? (string->utf8 "hello")
(call-with-input-file p get-bytevector-all)) (call-with-input-file p get-bytevector-all))
(bytevector? (query-path-hash %store p))))))) (bytevector? (query-path-hash %store p)))))))
@ -181,17 +177,16 @@
(builder2 (add-text-to-store %store "fixed-builder2.sh" (builder2 (add-text-to-store %store "fixed-builder2.sh"
"echo hey; echo -n hello > $out" '())) "echo hey; echo -n hello > $out" '()))
(hash (sha256 (string->utf8 "hello"))) (hash (sha256 (string->utf8 "hello")))
(drv-path1 (derivation %store "fixed" (drv1 (derivation %store "fixed"
%bash `(,builder1) %bash `(,builder1)
#:hash hash #:hash-algo 'sha256)) #:hash hash #:hash-algo 'sha256))
(drv-path2 (derivation %store "fixed" (drv2 (derivation %store "fixed"
%bash `(,builder2) %bash `(,builder2)
#:hash hash #:hash-algo 'sha256)) #:hash hash #:hash-algo 'sha256))
(succeeded? (build-derivations %store (succeeded? (build-derivations %store (list drv1 drv2))))
(list drv-path1 drv-path2))))
(and succeeded? (and succeeded?
(equal? (derivation-path->output-path drv-path1) (equal? (derivation->output-path drv1)
(derivation-path->output-path drv-path2))))) (derivation->output-path drv2)))))
(test-assert "derivation with a fixed-output input" (test-assert "derivation with a fixed-output input"
;; A derivation D using a fixed-output derivation F doesn't has the same ;; A derivation D using a fixed-output derivation F doesn't has the same
@ -208,7 +203,7 @@
(fixed2 (derivation %store "fixed" (fixed2 (derivation %store "fixed"
%bash `(,builder2) %bash `(,builder2)
#:hash hash #:hash-algo 'sha256)) #:hash hash #:hash-algo 'sha256))
(fixed-out (derivation-path->output-path fixed1)) (fixed-out (derivation->output-path fixed1))
(builder3 (add-text-to-store (builder3 (add-text-to-store
%store "final-builder.sh" %store "final-builder.sh"
;; Use Bash hackery to avoid Coreutils. ;; Use Bash hackery to avoid Coreutils.
@ -224,26 +219,26 @@
(succeeded? (build-derivations %store (succeeded? (build-derivations %store
(list final1 final2)))) (list final1 final2))))
(and succeeded? (and succeeded?
(equal? (derivation-path->output-path final1) (equal? (derivation->output-path final1)
(derivation-path->output-path final2))))) (derivation->output-path final2)))))
(test-assert "multiple-output derivation" (test-assert "multiple-output derivation"
(let* ((builder (add-text-to-store %store "my-fixed-builder.sh" (let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
"echo one > $out ; echo two > $second" "echo one > $out ; echo two > $second"
'())) '()))
(drv-path (derivation %store "fixed" (drv (derivation %store "fixed"
%bash `(,builder) %bash `(,builder)
#:env-vars '(("HOME" . "/homeless") #:env-vars '(("HOME" . "/homeless")
("zzz" . "Z!") ("zzz" . "Z!")
("AAA" . "A!")) ("AAA" . "A!"))
#:inputs `((,builder)) #:inputs `((,builder))
#:outputs '("out" "second"))) #:outputs '("out" "second")))
(succeeded? (build-derivations %store (list drv-path)))) (succeeded? (build-derivations %store (list drv))))
(and succeeded? (and succeeded?
(let ((one (derivation-path->output-path drv-path "out")) (let ((one (derivation->output-path drv "out"))
(two (derivation-path->output-path drv-path "second"))) (two (derivation->output-path drv "second")))
(and (lset= equal? (and (lset= equal?
(derivation-path->output-paths drv-path) (derivation->output-paths drv)
`(("out" . ,one) ("second" . ,two))) `(("out" . ,one) ("second" . ,two)))
(eq? 'one (call-with-input-file one read)) (eq? 'one (call-with-input-file one read))
(eq? 'two (call-with-input-file two read))))))) (eq? 'two (call-with-input-file two read)))))))
@ -254,14 +249,14 @@
(let* ((builder (add-text-to-store %store "my-fixed-builder.sh" (let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
"echo one > $out ; echo two > $AAA" "echo one > $out ; echo two > $AAA"
'())) '()))
(drv-path (derivation %store "fixed" (drv (derivation %store "fixed"
%bash `(,builder) %bash `(,builder)
#:inputs `((,builder)) #:inputs `((,builder))
#:outputs '("out" "AAA"))) #:outputs '("out" "AAA")))
(succeeded? (build-derivations %store (list drv-path)))) (succeeded? (build-derivations %store (list drv))))
(and succeeded? (and succeeded?
(let ((one (derivation-path->output-path drv-path "out")) (let ((one (derivation->output-path drv "out"))
(two (derivation-path->output-path drv-path "AAA"))) (two (derivation->output-path drv "AAA")))
(and (eq? 'one (call-with-input-file one read)) (and (eq? 'one (call-with-input-file one read))
(eq? 'two (call-with-input-file two read))))))) (eq? 'two (call-with-input-file two read)))))))
@ -283,17 +278,17 @@
(udrv (derivation %store "multiple-output-user" (udrv (derivation %store "multiple-output-user"
%bash `(,builder2) %bash `(,builder2)
#:env-vars `(("one" #:env-vars `(("one"
. ,(derivation-path->output-path . ,(derivation->output-path
mdrv "out")) mdrv "out"))
("two" ("two"
. ,(derivation-path->output-path . ,(derivation->output-path
mdrv "two"))) mdrv "two")))
#:inputs `((,builder2) #:inputs `((,builder2)
;; two occurrences of MDRV: ;; two occurrences of MDRV:
(,mdrv) (,mdrv)
(,mdrv "two"))))) (,mdrv "two")))))
(and (build-derivations %store (list (pk 'udrv udrv))) (and (build-derivations %store (list (pk 'udrv udrv)))
(let ((p (derivation-path->output-path udrv))) (let ((p (derivation->output-path udrv)))
(and (valid-path? %store p) (and (valid-path? %store p)
(equal? '(one two) (call-with-input-file p read))))))) (equal? '(one two) (call-with-input-file p read)))))))
@ -318,7 +313,7 @@
("input1" . ,input1) ("input1" . ,input1)
("input2" . ,input2)) ("input2" . ,input2))
#:inputs `((,%bash) (,builder)))) #:inputs `((,%bash) (,builder))))
(out (derivation-path->output-path drv))) (out (derivation->output-path drv)))
(define (deps path . deps) (define (deps path . deps)
(let ((count (length deps))) (let ((count (length deps)))
(string-append path "\n\n" (number->string count) "\n" (string-append path "\n\n" (number->string count) "\n"
@ -361,31 +356,30 @@
(add-text-to-store %store "build-with-coreutils.sh" (add-text-to-store %store "build-with-coreutils.sh"
"echo $PATH ; mkdir --version ; mkdir $out ; touch $out/good" "echo $PATH ; mkdir --version ; mkdir $out ; touch $out/good"
'())) '()))
(drv-path (drv
(derivation %store "foo" (derivation %store "foo"
%bash `(,builder) %bash `(,builder)
#:env-vars `(("PATH" . #:env-vars `(("PATH" .
,(string-append ,(string-append
(derivation-path->output-path %coreutils) (derivation->output-path %coreutils)
"/bin"))) "/bin")))
#:inputs `((,builder) #:inputs `((,builder)
(,%coreutils)))) (,%coreutils))))
(succeeded? (succeeded?
(build-derivations %store (list drv-path)))) (build-derivations %store (list drv))))
(and succeeded? (and succeeded?
(let ((p (derivation-path->output-path drv-path))) (let ((p (derivation->output-path drv)))
(and (valid-path? %store p) (and (valid-path? %store p)
(file-exists? (string-append p "/good"))))))) (file-exists? (string-append p "/good")))))))
(test-skip (if (%guile-for-build) 0 8)) (test-skip (if (%guile-for-build) 0 8))
(test-assert "build-expression->derivation and derivation-prerequisites" (test-assert "build-expression->derivation and derivation-prerequisites"
(let-values (((drv-path drv) (let ((drv (build-expression->derivation %store "fail" (%current-system)
(build-expression->derivation %store "fail" (%current-system) #f '())))
#f '())))
(any (match-lambda (any (match-lambda
(($ <derivation-input> path) (($ <derivation-input> path)
(string=? path (%guile-for-build)))) (string=? path (derivation-file-name (%guile-for-build)))))
(derivation-prerequisites drv)))) (derivation-prerequisites drv))))
(test-assert "build-expression->derivation without inputs" (test-assert "build-expression->derivation without inputs"
@ -394,11 +388,11 @@
(call-with-output-file (string-append %output "/test") (call-with-output-file (string-append %output "/test")
(lambda (p) (lambda (p)
(display '(hello guix) p))))) (display '(hello guix) p)))))
(drv-path (build-expression->derivation %store "goo" (%current-system) (drv (build-expression->derivation %store "goo" (%current-system)
builder '())) builder '()))
(succeeded? (build-derivations %store (list drv-path)))) (succeeded? (build-derivations %store (list drv))))
(and succeeded? (and succeeded?
(let ((p (derivation-path->output-path drv-path))) (let ((p (derivation->output-path drv)))
(equal? '(hello guix) (equal? '(hello guix)
(call-with-input-file (string-append p "/test") read)))))) (call-with-input-file (string-append p "/test") read))))))
@ -407,43 +401,35 @@
(set-build-options s #:max-silent-time 1) (set-build-options s #:max-silent-time 1)
s)) s))
(builder '(sleep 100)) (builder '(sleep 100))
(drv-path (build-expression->derivation %store "silent" (drv (build-expression->derivation %store "silent"
(%current-system) (%current-system)
builder '())) builder '()))
(out-path (derivation-path->output-path drv-path))) (out-path (derivation->output-path drv)))
(guard (c ((nix-protocol-error? c) (guard (c ((nix-protocol-error? c)
(and (string-contains (nix-protocol-error-message c) (and (string-contains (nix-protocol-error-message c)
"failed") "failed")
(not (valid-path? store out-path))))) (not (valid-path? store out-path)))))
(build-derivations %store (list drv-path))))) (build-derivations %store (list drv)))))
(test-assert "build-expression->derivation and derivation-prerequisites-to-build" (test-assert "build-expression->derivation and derivation-prerequisites-to-build"
(let-values (((drv-path drv) (let ((drv (build-expression->derivation %store "fail" (%current-system)
(build-expression->derivation %store "fail" (%current-system) #f '())))
#f '())))
;; The only direct dependency is (%guile-for-build) and it's already ;; The only direct dependency is (%guile-for-build) and it's already
;; built. ;; built.
(null? (derivation-prerequisites-to-build %store drv)))) (null? (derivation-prerequisites-to-build %store drv))))
(test-assert "derivation-prerequisites-to-build when outputs already present" (test-assert "derivation-prerequisites-to-build when outputs already present"
(let*-values (((builder) (let* ((builder '(begin (mkdir %output) #t))
'(begin (mkdir %output) #t)) (input-drv (build-expression->derivation %store "input"
((input-drv-path input-drv) (%current-system)
(build-expression->derivation %store "input" builder '()))
(%current-system) (input-path (derivation-output-path
builder '())) (assoc-ref (derivation-outputs input-drv)
((input-path) "out")))
(derivation-output-path (drv (build-expression->derivation %store "something"
(assoc-ref (derivation-outputs input-drv) (%current-system) builder
"out"))) `(("i" ,input-drv))))
((drv-path drv) (output (derivation->output-path drv)))
(build-expression->derivation %store "something"
(%current-system)
builder
`(("i" ,input-drv-path))))
((output)
(derivation-output-path
(assoc-ref (derivation-outputs drv) "out"))))
;; Make sure these things are not already built. ;; Make sure these things are not already built.
(when (valid-path? %store input-path) (when (valid-path? %store input-path)
(delete-paths %store (list input-path))) (delete-paths %store (list input-path)))
@ -452,10 +438,10 @@
(and (equal? (map derivation-input-path (and (equal? (map derivation-input-path
(derivation-prerequisites-to-build %store drv)) (derivation-prerequisites-to-build %store drv))
(list input-drv-path)) (list (derivation-file-name input-drv)))
;; Build DRV and delete its input. ;; Build DRV and delete its input.
(build-derivations %store (list drv-path)) (build-derivations %store (list drv))
(delete-paths %store (list input-path)) (delete-paths %store (list input-path))
(not (valid-path? %store input-path)) (not (valid-path? %store input-path))
@ -465,17 +451,12 @@
(test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1)) (test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
(test-assert "derivation-prerequisites-to-build and substitutes" (test-assert "derivation-prerequisites-to-build and substitutes"
(let*-values (((store) (let* ((store (open-connection))
(open-connection)) (drv (build-expression->derivation store "prereq-subst"
((drv-path drv)
(build-expression->derivation store "prereq-subst"
(%current-system) (%current-system)
(random 1000) '())) (random 1000) '()))
((output) (output (derivation->output-path drv))
(derivation-output-path (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
(assoc-ref (derivation-outputs drv) "out")))
((dir)
(and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
(compose uri-path string->uri)))) (compose uri-path string->uri))))
;; Create fake substituter data, to be read by `substitute-binary'. ;; Create fake substituter data, to be read by `substitute-binary'.
(call-with-output-file (string-append dir "/nix-cache-info") (call-with-output-file (string-append dir "/nix-cache-info")
@ -495,7 +476,8 @@ Deriver: ~a~%"
output ; StorePath output ; StorePath
(string-append dir "/example.nar") ; URL (string-append dir "/example.nar") ; URL
(%current-system) ; System (%current-system) ; System
(basename drv-path)))) ; Deriver (basename
(derivation-file-name drv))))) ; Deriver
(let-values (((build download) (let-values (((build download)
(derivation-prerequisites-to-build store drv)) (derivation-prerequisites-to-build store drv))
@ -512,16 +494,16 @@ Deriver: ~a~%"
(let* ((builder '(begin (let* ((builder '(begin
(mkdir %output) (mkdir %output)
#f)) ; fail! #f)) ; fail!
(drv-path (build-expression->derivation %store "fail" (%current-system) (drv (build-expression->derivation %store "fail" (%current-system)
builder '())) builder '()))
(out-path (derivation-path->output-path drv-path))) (out-path (derivation->output-path drv)))
(guard (c ((nix-protocol-error? c) (guard (c ((nix-protocol-error? c)
;; Note that the output path may exist at this point, but it ;; Note that the output path may exist at this point, but it
;; is invalid. ;; is invalid.
(and (string-match "build .* failed" (and (string-match "build .* failed"
(nix-protocol-error-message c)) (nix-protocol-error-message c))
(not (valid-path? %store out-path))))) (not (valid-path? %store out-path)))))
(build-derivations %store (list drv-path)) (build-derivations %store (list drv))
#f))) #f)))
(test-assert "build-expression->derivation with two outputs" (test-assert "build-expression->derivation with two outputs"
@ -532,15 +514,15 @@ Deriver: ~a~%"
(call-with-output-file (assoc-ref %outputs "second") (call-with-output-file (assoc-ref %outputs "second")
(lambda (p) (lambda (p)
(display '(world) p))))) (display '(world) p)))))
(drv-path (build-expression->derivation %store "double" (drv (build-expression->derivation %store "double"
(%current-system) (%current-system)
builder '() builder '()
#:outputs '("out" #:outputs '("out"
"second"))) "second")))
(succeeded? (build-derivations %store (list drv-path)))) (succeeded? (build-derivations %store (list drv))))
(and succeeded? (and succeeded?
(let ((one (derivation-path->output-path drv-path)) (let ((one (derivation->output-path drv))
(two (derivation-path->output-path drv-path "second"))) (two (derivation->output-path drv "second")))
(and (equal? '(hello) (call-with-input-file one read)) (and (equal? '(hello) (call-with-input-file one read))
(equal? '(world) (call-with-input-file two read))))))) (equal? '(world) (call-with-input-file two read)))))))
@ -553,12 +535,12 @@ Deriver: ~a~%"
(dup2 (port->fdes p) 1) (dup2 (port->fdes p) 1)
(execl (string-append cu "/bin/uname") (execl (string-append cu "/bin/uname")
"uname" "-a"))))) "uname" "-a")))))
(drv-path (build-expression->derivation %store "uname" (%current-system) (drv (build-expression->derivation %store "uname" (%current-system)
builder builder
`(("cu" ,%coreutils)))) `(("cu" ,%coreutils))))
(succeeded? (build-derivations %store (list drv-path)))) (succeeded? (build-derivations %store (list drv))))
(and succeeded? (and succeeded?
(let ((p (derivation-path->output-path drv-path))) (let ((p (derivation->output-path drv)))
(string-contains (call-with-input-file p read-line) "GNU"))))) (string-contains (call-with-input-file p read-line) "GNU")))))
(test-assert "imported-files" (test-assert "imported-files"
@ -567,9 +549,9 @@ Deriver: ~a~%"
"guix/derivations.scm")) "guix/derivations.scm"))
("p/q" . ,(search-path %load-path "guix.scm")) ("p/q" . ,(search-path %load-path "guix.scm"))
("p/z" . ,(search-path %load-path "guix/store.scm")))) ("p/z" . ,(search-path %load-path "guix/store.scm"))))
(drv-path (imported-files %store files))) (drv (imported-files %store files)))
(and (build-derivations %store (list drv-path)) (and (build-derivations %store (list drv))
(let ((dir (derivation-path->output-path drv-path))) (let ((dir (derivation->output-path drv)))
(every (match-lambda (every (match-lambda
((path . source) ((path . source)
(equal? (call-with-input-file (string-append dir "/" path) (equal? (call-with-input-file (string-append dir "/" path)
@ -584,14 +566,13 @@ Deriver: ~a~%"
(let ((out (assoc-ref %outputs "out"))) (let ((out (assoc-ref %outputs "out")))
(mkdir-p (string-append out "/guile/guix/nix")) (mkdir-p (string-append out "/guile/guix/nix"))
#t))) #t)))
(drv-path (build-expression->derivation %store (drv (build-expression->derivation %store "test-with-modules"
"test-with-modules"
(%current-system) (%current-system)
builder '() builder '()
#:modules #:modules
'((guix build utils))))) '((guix build utils)))))
(and (build-derivations %store (list drv-path)) (and (build-derivations %store (list drv))
(let* ((p (derivation-path->output-path drv-path)) (let* ((p (derivation->output-path drv))
(s (stat (string-append p "/guile/guix/nix")))) (s (stat (string-append p "/guile/guix/nix"))))
(eq? (stat:type s) 'directory))))) (eq? (stat:type s) 'directory)))))
@ -615,9 +596,10 @@ Deriver: ~a~%"
#:hash-algo 'sha256)) #:hash-algo 'sha256))
(succeeded? (build-derivations %store (list input1 input2)))) (succeeded? (build-derivations %store (list input1 input2))))
(and succeeded? (and succeeded?
(not (string=? input1 input2)) (not (string=? (derivation-file-name input1)
(string=? (derivation-path->output-path input1) (derivation-file-name input2)))
(derivation-path->output-path input2))))) (string=? (derivation->output-path input1)
(derivation->output-path input2)))))
(test-assert "build-expression->derivation with a fixed-output input" (test-assert "build-expression->derivation with a fixed-output input"
(let* ((builder1 '(call-with-output-file %output (let* ((builder1 '(call-with-output-file %output
@ -649,8 +631,11 @@ Deriver: ~a~%"
(%current-system) (%current-system)
builder3 builder3
`(("input" ,input2))))) `(("input" ,input2)))))
(and (string=? (derivation-path->output-path final1) (and (string=? (derivation->output-path final1)
(derivation-path->output-path final2)) (derivation->output-path final2))
(string=? (derivation->output-path final1)
(derivation-path->output-path
(derivation-file-name final1)))
(build-derivations %store (list final1 final2))))) (build-derivations %store (list final1 final2)))))
(test-assert "build-expression->derivation with #:references-graphs" (test-assert "build-expression->derivation with #:references-graphs"
@ -662,7 +647,7 @@ Deriver: ~a~%"
builder '() builder '()
#:references-graphs #:references-graphs
`(("input" . ,input)))) `(("input" . ,input))))
(out (derivation-path->output-path drv))) (out (derivation->output-path drv)))
(define (deps path . deps) (define (deps path . deps)
(let ((count (length deps))) (let ((count (length deps)))
(string-append path "\n\n" (number->string count) "\n" (string-append path "\n\n" (number->string count) "\n"

38
tests/packages.scm
View File

@ -121,17 +121,16 @@
(package-source package)))) (package-source package))))
(string=? file source))) (string=? file source)))
(test-assert "return values" (test-assert "return value"
(let-values (((drv-path drv) (let ((drv (package-derivation %store (dummy-package "p"))))
(package-derivation %store (dummy-package "p")))) (and (derivation? drv)
(and (derivation-path? drv-path) (file-exists? (derivation-file-name drv)))))
(derivation? drv))))
(test-assert "package-output" (test-assert "package-output"
(let* ((package (dummy-package "p")) (let* ((package (dummy-package "p"))
(drv-path (package-derivation %store package))) (drv (package-derivation %store package)))
(and (derivation-path? drv-path) (and (derivation? drv)
(string=? (derivation-path->output-path drv-path) (string=? (derivation->output-path drv)
(package-output %store package "out"))))) (package-output %store package "out")))))
(test-assert "trivial" (test-assert "trivial"
@ -148,7 +147,7 @@
(display '(hello guix) p)))))))) (display '(hello guix) p))))))))
(d (package-derivation %store p))) (d (package-derivation %store p)))
(and (build-derivations %store (list d)) (and (build-derivations %store (list d))
(let ((p (pk 'drv d (derivation-path->output-path d)))) (let ((p (pk 'drv d (derivation->output-path d))))
(equal? '(hello guix) (equal? '(hello guix)
(call-with-input-file (string-append p "/test") read)))))) (call-with-input-file (string-append p "/test") read))))))
@ -164,7 +163,7 @@
(inputs `(("input" ,i))))) (inputs `(("input" ,i)))))
(d (package-derivation %store p))) (d (package-derivation %store p)))
(and (build-derivations %store (list d)) (and (build-derivations %store (list d))
(let ((p (pk 'drv d (derivation-path->output-path d)))) (let ((p (pk 'drv d (derivation->output-path d))))
(equal? (call-with-input-file p get-bytevector-all) (equal? (call-with-input-file p get-bytevector-all)
(call-with-input-file i get-bytevector-all)))))) (call-with-input-file i get-bytevector-all))))))
@ -183,7 +182,7 @@
(%current-system))))))) (%current-system)))))))
(d (package-derivation %store p))) (d (package-derivation %store p)))
(and (build-derivations %store (list d)) (and (build-derivations %store (list d))
(let ((p (pk 'drv d (derivation-path->output-path d)))) (let ((p (pk 'drv d (derivation->output-path d))))
(eq? 'hello (call-with-input-file p read)))))) (eq? 'hello (call-with-input-file p read))))))
(test-assert "search paths" (test-assert "search paths"
@ -222,20 +221,17 @@
(equal? x (collect (package-derivation %store c))))))) (equal? x (collect (package-derivation %store c)))))))
(test-assert "package-cross-derivation" (test-assert "package-cross-derivation"
(let-values (((drv-path drv) (let ((drv (package-cross-derivation %store (dummy-package "p")
(package-cross-derivation %store (dummy-package "p") "mips64el-linux-gnu")))
"mips64el-linux-gnu"))) (and (derivation? drv)
(and (derivation-path? drv-path) (file-exists? (derivation-file-name drv)))))
(derivation? drv))))
(test-assert "package-cross-derivation, trivial-build-system" (test-assert "package-cross-derivation, trivial-build-system"
(let ((p (package (inherit (dummy-package "p")) (let ((p (package (inherit (dummy-package "p"))
(build-system trivial-build-system) (build-system trivial-build-system)
(arguments '(#:builder (exit 1)))))) (arguments '(#:builder (exit 1))))))
(let-values (((drv-path drv) (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu")))
(package-cross-derivation %store p "mips64el-linux-gnu"))) (derivation? drv))))
(and (derivation-path? drv-path)
(derivation? drv)))))
(test-assert "package-cross-derivation, no cross builder" (test-assert "package-cross-derivation, no cross builder"
(let* ((b (build-system (inherit trivial-build-system) (let* ((b (build-system (inherit trivial-build-system)
@ -257,7 +253,7 @@
(or (location? (package-location gnu-make)) (or (location? (package-location gnu-make))
(not (package-location gnu-make))) (not (package-location gnu-make)))
(let* ((drv (package-derivation %store gnu-make)) (let* ((drv (package-derivation %store gnu-make))
(out (derivation-path->output-path drv))) (out (derivation->output-path drv)))
(and (build-derivations %store (list drv)) (and (build-derivations %store (list drv))
(file-exists? (string-append out "/bin/make"))))))) (file-exists? (string-append out "/bin/make")))))))

31
tests/store.scm
View File

@ -82,7 +82,7 @@
;; (d1 (derivation %store "link" ;; (d1 (derivation %store "link"
;; "/bin/sh" `("-e" ,b) ;; "/bin/sh" `("-e" ,b)
;; #:inputs `((,b) (,p1)))) ;; #:inputs `((,b) (,p1))))
;; (p2 (derivation-path->output-path d1))) ;; (p2 (derivation->output-path d1)))
;; (and (add-temp-root %store p2) ;; (and (add-temp-root %store p2)
;; (build-derivations %store (list d1)) ;; (build-derivations %store (list d1))
;; (valid-path? %store p1) ;; (valid-path? %store p1)
@ -133,21 +133,21 @@
s `("-e" ,b) s `("-e" ,b)
#:env-vars `(("foo" . ,(random-text))) #:env-vars `(("foo" . ,(random-text)))
#:inputs `((,b) (,s)))) #:inputs `((,b) (,s))))
(o (derivation-path->output-path d))) (o (derivation->output-path d)))
(and (build-derivations %store (list d)) (and (build-derivations %store (list d))
(equal? (query-derivation-outputs %store d) (equal? (query-derivation-outputs %store (derivation-file-name d))
(list o)) (list o))
(equal? (valid-derivers %store o) (equal? (valid-derivers %store o)
(list d))))) (list (derivation-file-name d))))))
(test-assert "no substitutes" (test-assert "no substitutes"
(let* ((s (open-connection)) (let* ((s (open-connection))
(d1 (package-derivation s %bootstrap-guile (%current-system))) (d1 (package-derivation s %bootstrap-guile (%current-system)))
(d2 (package-derivation s %bootstrap-glibc (%current-system))) (d2 (package-derivation s %bootstrap-glibc (%current-system)))
(o (map derivation-path->output-path (list d1 d2)))) (o (map derivation->output-path (list d1 d2))))
(set-build-options s #:use-substitutes? #f) (set-build-options s #:use-substitutes? #f)
(and (not (has-substitutes? s d1)) (and (not (has-substitutes? s (derivation-file-name d1)))
(not (has-substitutes? s d2)) (not (has-substitutes? s (derivation-file-name d2)))
(null? (substitutable-paths s o)) (null? (substitutable-paths s o))
(null? (substitutable-path-info s o))))) (null? (substitutable-path-info s o)))))
@ -156,7 +156,7 @@
(test-assert "substitute query" (test-assert "substitute query"
(let* ((s (open-connection)) (let* ((s (open-connection))
(d (package-derivation s %bootstrap-guile (%current-system))) (d (package-derivation s %bootstrap-guile (%current-system)))
(o (derivation-path->output-path d)) (o (derivation->output-path d))
(dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
(compose uri-path string->uri)))) (compose uri-path string->uri))))
;; Create fake substituter data, to be read by `substitute-binary'. ;; Create fake substituter data, to be read by `substitute-binary'.
@ -177,7 +177,8 @@ Deriver: ~a~%"
o ; StorePath o ; StorePath
(string-append dir "/example.nar") ; URL (string-append dir "/example.nar") ; URL
(%current-system) ; System (%current-system) ; System
(basename d)))) ; Deriver (basename
(derivation-file-name d))))) ; Deriver
;; Remove entry from the local cache. ;; Remove entry from the local cache.
(false-if-exception (false-if-exception
@ -191,7 +192,7 @@ Deriver: ~a~%"
(equal? (list o) (substitutable-paths s (list o))) (equal? (list o) (substitutable-paths s (list o)))
(match (pk 'spi (substitutable-path-info s (list o))) (match (pk 'spi (substitutable-path-info s (list o)))
(((? substitutable? s)) (((? substitutable? s))
(and (equal? (substitutable-deriver s) d) (and (string=? (substitutable-deriver s) (derivation-file-name d))
(null? (substitutable-references s)) (null? (substitutable-references s))
(equal? (substitutable-nar-size s) 1234))))))) (equal? (substitutable-nar-size s) 1234)))))))
@ -207,7 +208,7 @@ Deriver: ~a~%"
'() '()
#:guile-for-build #:guile-for-build
(package-derivation s %bootstrap-guile (%current-system)))) (package-derivation s %bootstrap-guile (%current-system))))
(o (derivation-path->output-path d)) (o (derivation->output-path d))
(dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
(compose uri-path string->uri)))) (compose uri-path string->uri))))
;; Create fake substituter data, to be read by `substitute-binary'. ;; Create fake substituter data, to be read by `substitute-binary'.
@ -238,7 +239,8 @@ Deriver: ~a~%"
(compose bytevector->nix-base32-string sha256 (compose bytevector->nix-base32-string sha256
get-bytevector-all)) get-bytevector-all))
(%current-system) ; System (%current-system) ; System
(basename d)))) ; Deriver (basename
(derivation-file-name d))))) ; Deriver
;; Make sure we use `substitute-binary'. ;; Make sure we use `substitute-binary'.
(set-build-options s #:use-substitutes? #t) (set-build-options s #:use-substitutes? #t)
@ -257,7 +259,7 @@ Deriver: ~a~%"
'() '()
#:guile-for-build #:guile-for-build
(package-derivation s %bootstrap-guile (%current-system)))) (package-derivation s %bootstrap-guile (%current-system))))
(o (derivation-path->output-path d)) (o (derivation->output-path d))
(dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
(compose uri-path string->uri)))) (compose uri-path string->uri))))
;; Create fake substituter data, to be read by `substitute-binary'. ;; Create fake substituter data, to be read by `substitute-binary'.
@ -279,7 +281,8 @@ Deriver: ~a~%"
o ; StorePath o ; StorePath
"does-not-exist.nar" ; relative URL "does-not-exist.nar" ; relative URL
(%current-system) ; System (%current-system) ; System
(basename d)))) ; Deriver (basename
(derivation-file-name d))))) ; Deriver
;; Make sure we use `substitute-binary'. ;; Make sure we use `substitute-binary'.
(set-build-options s #:use-substitutes? #t) (set-build-options s #:use-substitutes? #t)

2
tests/union.scm
View File

@ -108,7 +108,7 @@
builder inputs builder inputs
#:modules '((guix build union))))) #:modules '((guix build union)))))
(and (build-derivations %store (list (pk 'drv drv))) (and (build-derivations %store (list (pk 'drv drv)))
(with-directory-excursion (derivation-path->output-path drv) (with-directory-excursion (derivation->output-path drv)
(and (file-exists? "bin/touch") (and (file-exists? "bin/touch")
(file-exists? "bin/gcc") (file-exists? "bin/gcc")
(file-exists? "bin/ld") (file-exists? "bin/ld")