From cfbf916045c180c8f77f90e9c910012f18447dc9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Sep 2013 22:36:41 +0200 Subject: store: The 'references' parameter of 'add-text-to-store' is now optional. * guix/store.scm (add-text-to-store): Make 'references' optional. * tests/store.scm ("dead-paths", "references"): Use 'add-text-to-store' with no optional argument. * doc/guix.texi (The Store): Adjust accordingly. --- doc/guix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 5b91bc2982..5d1b780144 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1061,7 +1061,7 @@ argument. Return @code{#t} when @var{path} is a valid store path. @end deffn -@deffn {Scheme Procedure} add-text-to-store @var{server} @var{name} @var{text} @var{references} +@deffn {Scheme Procedure} add-text-to-store @var{server} @var{name} @var{text} [@var{references}] Add @var{text} under file @var{name} in the store, and return its store path. @var{references} is the list of store paths referred to by the resulting store path. -- cgit v1.2.3 From 59688fc4b5cfac3e05610195a47795f5cc15f338 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Sep 2013 17:01:40 +0200 Subject: 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. --- doc/guix.texi | 37 ++++---- gnu/system/grub.scm | 6 +- gnu/system/vm.scm | 12 +-- guix/build-system/cmake.scm | 6 +- guix/build-system/gnu.scm | 20 ++-- guix/build-system/perl.scm | 4 +- guix/build-system/python.scm | 4 +- guix/derivations.scm | 79 +++++++++++----- guix/download.scm | 32 +++---- guix/packages.scm | 11 +-- guix/scripts/build.scm | 23 +++-- guix/scripts/package.scm | 19 ++-- guix/ui.scm | 34 +++---- tests/builders.scm | 8 +- tests/derivations.scm | 219 ++++++++++++++++++++----------------------- tests/packages.scm | 38 ++++---- tests/store.scm | 31 +++--- tests/union.scm | 2 +- 18 files changed, 295 insertions(+), 290 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 5d1b780144..92c163c608 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -987,8 +987,8 @@ The build actions it prescribes may then be realized by using the @code{build-derivations} procedure (@pxref{The Store}). @deffn {Scheme Procedure} package-derivation @var{store} @var{package} [@var{system}] -Return the derivation path and corresponding @code{} object -of @var{package} for @var{system} (@pxref{Derivations}). +Return the @code{} object of @var{package} for @var{system} +(@pxref{Derivations}). @var{package} must be a valid @code{} object, and @var{system} 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} @ @var{package} @var{target} [@var{system}] -Return the derivation path and corresponding @code{} object -of @var{package} cross-built from @var{system} to @var{target}. +Return the @code{} object of @var{package} cross-built from +@var{system} to @var{target}. @var{target} must be a valid GNU triplet denoting the target hardware and operating system, such as @code{"mips64el-linux-gnu"} @@ -1068,8 +1068,9 @@ resulting store path. @end deffn @deffn {Scheme Procedure} build-derivations @var{server} @var{derivations} -Build @var{derivations} (a list of derivation paths), and return when -the worker is done building them. Return @code{#t} on success. +Build @var{derivations} (a list of @code{} objects or +derivation paths), and return when the worker is done building them. +Return @code{#t} on success. @end deffn @c FIXME @@ -1119,8 +1120,8 @@ otherwise manipulate derivations. The lowest-level primitive to create 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] -Build a derivation with the given arguments. Return the resulting store -path and @code{} object. +Build a derivation with the given arguments, and return the resulting +@code{} object. 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 @@ -1142,16 +1143,13 @@ to a Bash executable in the store: (guix store) (guix derivations)) -(call-with-values - (lambda () - (let ((builder ; add the Bash script to the store - (add-text-to-store store "my-builder.sh" - "echo hello world > $out\n" '()))) - (derivation store "foo" - bash `("-e" ,builder) - #:env-vars '(("HOME" . "/homeless"))))) - list) -@result{} ("/nix/store/@dots{}-foo.drv" #< @dots{}>) +(let ((builder ; add the Bash script to the store + (add-text-to-store store "my-builder.sh" + "echo hello world > $out\n" '()))) + (derivation store "foo" + bash `("-e" ,builder) + #:env-vars '(("HOME" . "/homeless")))) +@result{} # /nix/store/@dots{}-foo> @end lisp 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) builder '())) -@result{} "/nix/store/@dots{}-goo.drv" -@result{} #< @dots{}> +@result{} # @dots{}> @end lisp @cindex strata of code diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index 695a044bfa..b2438b9c5b 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -56,7 +56,7 @@ search.file ~a~%" (any (match-lambda (($ _ linux) (let* ((drv (package-derivation store linux system)) - (out (derivation-path->output-path drv))) + (out (derivation->output-path drv))) (string-append out "/bzImage")))) entries))) @@ -71,9 +71,9 @@ search.file ~a~%" initrd ~a/initrd }~%" label - (derivation-path->output-path linux-drv) + (derivation->output-path linux-drv) (string-join arguments) - (derivation-path->output-path initrd-drv)))))) + (derivation->output-path initrd-drv)))))) (add-text-to-store store "grub.cfg" (string-append prologue diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 192ed1d5a3..68d205d82a 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -206,10 +206,10 @@ It can be used to provide additional files, such as /etc files." (define input->name+derivation (match-lambda ((name (? package? package)) - `(,name . ,(derivation-path->output-path + `(,name . ,(derivation->output-path (package-derivation store package system)))) ((name (? package? package) sub-drv) - `(,name . ,(derivation-path->output-path + `(,name . ,(derivation->output-path (package-derivation store package system) sub-drv))) ((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))) (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")) (accounts (list (vector "root" "" 0 0 "System administrator" "/" bash-file))) (passwd (passwd-file store accounts)) (shadow (passwd-file store accounts #:shadow? #t)) (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 (add-text-to-store store "populate-qemu-image" (object->string @@ -381,11 +381,11 @@ It can be used to provide additional files, such as /etc files." (symlink ,pam.d "etc/pam.d") (mkdir-p "var/run"))) (list passwd))) - (out (derivation-path->output-path + (out (derivation->output-path (package-derivation store mingetty))) (getty (string-append out "/sbin/mingetty")) (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")) (boot (add-text-to-store store "boot" (object->string diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index 76a9a3befe..9461b19a2e 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -72,9 +72,9 @@ provides a 'CMakeLists.txt' file as its build system." (define builder `(begin (use-modules ,@modules) - (cmake-build #:source ,(if (and source (derivation-path? source)) - (derivation-path->output-path source) - source) + (cmake-build #:source ,(if (derivation? source) + (derivation->output-path source) + source) #:system ,system #:outputs %outputs #:inputs %build-inputs diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 03d56edadf..5f13f8ee29 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -291,8 +291,8 @@ which could lead to gratuitous input divergence." (define builder `(begin (use-modules ,@modules) - (gnu-build #:source ,(if (and source (derivation-path? source)) - (derivation-path->output-path source) + (gnu-build #:source ,(if (derivation? source) + (derivation->output-path source) source) #:system ,system #:outputs %outputs @@ -319,8 +319,8 @@ which could lead to gratuitous input divergence." (match guile ((? package?) (package-derivation store guile system)) - ((and (? string?) (? derivation-path?)) - guile) + ;; ((and (? string?) (? derivation-path?)) + ;; guile) (#f ; the default (let* ((distro (resolve-interface '(gnu packages base))) (guile (module-ref distro 'guile-final))) @@ -438,6 +438,8 @@ platform." (let () (define %build-host-inputs ',(map (match-lambda + ((name (? derivation? drv) sub ...) + `(,name . ,(apply derivation->output-path drv sub))) ((name (? derivation-path? drv-path) sub ...) `(,name . ,(apply derivation-path->output-path drv-path sub))) @@ -447,6 +449,8 @@ platform." (define %build-target-inputs ',(map (match-lambda + ((name (? derivation? drv) sub ...) + `(,name . ,(apply derivation->output-path drv sub))) ((name (? derivation-path? drv-path) sub ...) `(,name . ,(apply derivation-path->output-path drv-path sub))) @@ -454,8 +458,8 @@ platform." `(,name . ,path))) (append (or implicit-target-inputs '()) inputs))) - (gnu-build #:source ,(if (and source (derivation-path? source)) - (derivation-path->output-path source) + (gnu-build #:source ,(if (derivation? source) + (derivation->output-path source) source) #:system ,system #:target ,target @@ -488,8 +492,8 @@ platform." (match guile ((? package?) (package-derivation store guile system)) - ((and (? string?) (? derivation-path?)) - guile) + ;; ((and (? string?) (? derivation-path?)) + ;; guile) (#f ; the default (let* ((distro (resolve-interface '(gnu packages base))) (guile (module-ref distro 'guile-final))) diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 1ff9fd2674..6661689efb 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -62,8 +62,8 @@ provides a `Makefile.PL' file as its build system." `(begin (use-modules ,@modules) (perl-build #:name ,name - #:source ,(if (and source (derivation-path? source)) - (derivation-path->output-path source) + #:source ,(if (derivation? source) + (derivation->output-path source) source) #:search-paths ',(map search-path-specification->sexp (append perl-search-paths diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index 03e587ba01..cf7ca7d3e1 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -120,8 +120,8 @@ provides a 'setup.py' file as its build system." `(begin (use-modules ,@modules) (python-build #:name ,name - #:source ,(if (and source (derivation-path? source)) - (derivation-path->output-path source) + #:source ,(if (derivation? source) + (derivation->output-path source) source) #:configure-flags ,configure-flags #:system ,system diff --git a/guix/derivations.scm b/guix/derivations.scm index 43ea328b0e..433a8f145e 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -58,6 +58,8 @@ read-derivation write-derivation + derivation->output-path + derivation->output-paths derivation-path->output-path derivation-path->output-paths derivation @@ -66,7 +68,8 @@ imported-modules compiled-modules build-expression->derivation - imported-files)) + imported-files) + #:replace (build-derivations)) ;;; ;;; Nix derivations, as implemented in Nix's `derivations.cc'. @@ -420,25 +423,30 @@ that form." 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 ;; This procedure is called frequently, so memoize it. (memoize (lambda* (path #:optional (output "out")) "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store path of its output OUTPUT." - (let* ((drv (call-with-input-file path read-derivation)) - (outputs (derivation-outputs drv))) - (and=> (assoc-ref outputs output) derivation-output-path))))) + (derivation->output-path (call-with-input-file path read-derivation))))) (define (derivation-path->output-paths path) "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the list of name/path pairs of its outputs." - (let* ((drv (call-with-input-file path read-derivation)) - (outputs (derivation-outputs drv))) - (map (match-lambda - ((name . output) - (cons name (derivation-output-path output)))) - outputs))) + (derivation->output-paths (call-with-input-file path read-derivation))) ;;; @@ -522,10 +530,10 @@ the derivation called NAME with hash HASH." (inputs '()) (outputs '("out")) hash hash-algo hash-mode references-graphs) - "Build a derivation with the given arguments. Return the resulting -store path and object. When HASH, HASH-ALGO, and HASH-MODE -are given, a fixed-output derivation is created---i.e., one whose result is -known in advance, such as a file download. + "Build a derivation with the given arguments, and return the resulting + object. When HASH, HASH-ALGO, and HASH-MODE are given, a +fixed-output derivation is created---i.e., one whose result is known in +advance, such as a file download. 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 @@ -610,6 +618,12 @@ the build environment in the corresponding file, in a simple text format." (make-derivation-output "" hash-algo hash))) outputs)) (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)) (make-derivation-input input '("out"))) (((? 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 <>)) (map derivation-input-path 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 objects or .drv file names." + (let ((build (@ (guix store) build-derivations))) + (build store (map (match-lambda + ((? string? file) file) + ((and drv ($ )) + (derivation-file-name drv))) + derivations)))) ;;; @@ -730,7 +758,7 @@ they can refer to each other." #:system system #:guile guile #:module-path module-path)) - (module-dir (derivation-path->output-path module-drv)) + (module-dir (derivation->output-path module-drv)) (files (map (lambda (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))) (define guile - (string-append (derivation-path->output-path guile-drv) + (string-append (derivation->output-path guile-drv) "/bin/guile")) (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 ;; return #f. (match-lambda + ((_ (? derivation?) _ ...) + #f) ((_ path _ ...) (and (not (derivation-path? path)) path)))) @@ -830,10 +860,13 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS." (() "out") ((x) x)))) (cons name - (if (derivation-path? drv) - (derivation-path->output-path drv - sub) - drv))))) + (cond + ((derivation? drv) + (derivation->output-path drv sub)) + ((derivation-path? drv) + (derivation-path->output-path drv + sub)) + (else drv)))))) inputs)) ,@(if (null? modules) @@ -878,13 +911,13 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS." #:guile guile-drv #:system system))) (mod-dir (and mod-drv - (derivation-path->output-path mod-drv))) + (derivation->output-path mod-drv))) (go-drv (and (pair? modules) (compiled-modules store modules #:guile guile-drv #:system system))) (go-dir (and go-drv - (derivation-path->output-path go-drv)))) + (derivation->output-path go-drv)))) (derivation store name guile `("--no-auto-compile" ,@(if mod-dir `("-L" ,mod-dir) '()) diff --git a/guix/download.scm b/guix/download.scm index fa76615ef2..8b1d15f273 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -25,7 +25,6 @@ #:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:)) #:use-module (guix utils) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:export (%mirrors url-fetch @@ -212,27 +211,22 @@ must be a list of symbol/URL-list pairs." ((url ...) (any https? url))))) - (let*-values (((gnutls-drv-path gnutls-drv) - (if need-gnutls? - (gnutls-derivation store system) - (values #f #f))) - ((gnutls) - (and gnutls-drv - (derivation-output-path - (assoc-ref (derivation-outputs gnutls-drv) - "out")))) - ((env-vars) - (if gnutls - (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))) - '()))) + (let* ((gnutls-drv (if need-gnutls? + (gnutls-derivation store system) + (values #f #f))) + (gnutls (and gnutls-drv + (derivation->output-path gnutls-drv "out"))) + (env-vars (if gnutls + (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 builder (if gnutls-drv - `(("gnutls" ,gnutls-drv-path)) + `(("gnutls" ,gnutls-drv)) '()) #:hash-algo hash-algo #:hash hash diff --git a/guix/packages.scm b/guix/packages.scm index f63727dd32..efec414675 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -26,7 +26,6 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -370,8 +369,8 @@ information in exceptions." (define* (package-derivation store package #:optional (system (%current-system))) - "Return the derivation path and corresponding object of -PACKAGE for SYSTEM." + "Return the object of PACKAGE for SYSTEM." + ;; Compute the derivation and cache the result. Caching is important ;; because some derivations, such as the implicit inputs of the GNU build ;; 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 symbolic output name, such as \"out\". Note that this procedure calls `package-derivation', which is costly." - (let-values (((_ drv) - (package-derivation store package system))) - (derivation-output-path - (assoc-ref (derivation-outputs drv) output)))) + (let ((drv (package-derivation store package system))) + (derivation->output-path drv output))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 26cd28215e..a06755dc7a 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -250,7 +250,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (derivations-from-package-expressions str package->derivation sys src?)) (('argument . (? derivation-path? drv)) - drv) + (call-with-input-file drv read-derivation)) (('argument . (? string? x)) (let ((p (find-package x))) (if src? @@ -280,24 +280,23 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (if (assoc-ref opts 'derivations-only?) (begin - (format #t "~{~a~%~}" drv) + (format #t "~{~a~%~}" (map derivation-file-name drv)) (for-each (cut register-root <> <>) - (map list drv) roots)) + (map (compose list derivation-file-name) drv) + roots)) (or (assoc-ref opts 'dry-run?) (and (build-derivations (%store) drv) (for-each (lambda (d) - (let ((drv (call-with-input-file d - read-derivation))) - (format #t "~{~a~%~}" - (map (match-lambda - ((out-name . out) - (derivation-path->output-path - d out-name))) - (derivation-outputs drv))))) + (format #t "~{~a~%~}" + (map (match-lambda + ((out-name . out) + (derivation->output-path + d out-name))) + (derivation-outputs d)))) drv) (for-each (cut register-root <> <>) (map (lambda (drv) (map cdr - (derivation-path->output-paths drv))) + (derivation->output-paths drv))) drv) roots))))))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 1393ca3180..862b82612a 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -234,12 +234,9 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (_ "nothing to do: already at the empty profile~%"))) ((or (zero? previous-number) ; going to emptiness (not (file-exists? previous-generation))) - (let*-values (((drv-path drv) - (profile-derivation (%store) '())) - ((prof) - (derivation-output-path - (assoc-ref (derivation-outputs drv) "out")))) - (when (not (build-derivations (%store) (list drv-path))) + (let* ((drv (profile-derivation (%store) '())) + (prof (derivation->output-path drv "out"))) + (when (not (build-derivations (%store) (list drv))) (leave (_ "failed to build the empty profile~%"))) (switch-symlinks previous-generation prof) @@ -558,7 +555,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (define (guile-missing?) ;; 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)))) (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) ((>) #t) ((<) #f) - ((=) (let ((candidate-path (derivation-path->output-path + ((=) (let ((candidate-path (derivation->output-path (package-derivation (%store) pkg)))) (not (string=? current-path candidate-path)))))) (#f #f))) @@ -808,7 +805,7 @@ more information.~%")) (match tuple ((name version sub-drv _ (deps ...)) (let ((output-path - (derivation-path->output-path + (derivation->output-path drv sub-drv))) `(,name ,version ,sub-drv ,output-path ,(canonicalize-deps deps)))))) @@ -841,11 +838,11 @@ more information.~%")) (or dry-run? (and (build-derivations (%store) drv) (let* ((prof-drv (profile-derivation (%store) packages)) - (prof (derivation-path->output-path prof-drv)) + (prof (derivation->output-path prof-drv)) (old-drv (profile-derivation (%store) (manifest-packages (profile-manifest profile)))) - (old-prof (derivation-path->output-path old-drv)) + (old-prof (derivation->output-path old-drv)) (number (generation-number profile)) ;; Always use NUMBER + 1 for the new profile, diff --git a/guix/ui.scm b/guix/ui.scm index 720d01be02..293730308e 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -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 available for download." (let*-values (((build download) - (fold2 (lambda (drv-path build download) - (let ((drv (call-with-input-file drv-path - read-derivation))) - (let-values (((b d) - (derivation-prerequisites-to-build - store drv - #:use-substitutes? - use-substitutes?))) - (values (append b build) - (append d download))))) + (fold2 (lambda (drv build download) + (let-values (((b d) + (derivation-prerequisites-to-build + store drv + #:use-substitutes? + use-substitutes?))) + (values (append b build) + (append d download)))) '() '() drv)) ((build) ; add the DRV themselves (delete-duplicates - (append (remove (compose (lambda (out) - (or (valid-path? store out) - (and use-substitutes? - (has-substitutes? store - out)))) - derivation-path->output-path) - drv) + (append (map derivation-file-name + (remove (lambda (drv) + (let ((out (derivation->output-path + drv))) + (or (valid-path? store out) + (and use-substitutes? + (has-substitutes? store + out))))) + drv)) (map derivation-input-path build)))) ((download) ; add the references of DOWNLOAD (if use-substitutes? diff --git a/tests/builders.scm b/tests/builders.scm index 1e6b62ee6a..0ed5d74a22 100644 --- a/tests/builders.scm +++ b/tests/builders.scm @@ -70,10 +70,10 @@ "ftp://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz")) (hash (nix-base32-string->bytevector "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6")) - (drv-path (url-fetch %store url 'sha256 hash + (drv (url-fetch %store url 'sha256 hash #:guile %bootstrap-guile)) - (out-path (derivation-path->output-path drv-path))) - (and (build-derivations %store (list drv-path)) + (out-path (derivation->output-path drv))) + (and (build-derivations %store (list drv)) (file-exists? out-path) (valid-path? %store out-path)))) @@ -93,7 +93,7 @@ #:implicit-inputs? #f #:guile %bootstrap-guile #: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))) (valid-path? %store out) (file-exists? (string-append out "/bin/hello"))))) diff --git a/tests/derivations.scm b/tests/derivations.scm index e69dd0db31..4756fb9cba 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -110,31 +110,27 @@ (let* ((builder (add-text-to-store %store "my-builder.sh" "echo hello, world\n" '())) - (drv-path (derivation %store "foo" + (drv (derivation %store "foo" %bash `("-e" ,builder) #:env-vars '(("HOME" . "/homeless"))))) - (and (store-path? drv-path) - (valid-path? %store drv-path)))) + (and (store-path? (derivation-file-name drv)) + (valid-path? %store (derivation-file-name drv))))) (test-assert "build derivation with 1 source" - (let*-values (((builder) - (add-text-to-store %store "my-builder.sh" - "echo hello, world > \"$out\"\n" - '())) - ((drv-path drv) - (derivation %store "foo" - %bash `(,builder) - #:env-vars '(("HOME" . "/homeless") - ("zzz" . "Z!") - ("AAA" . "A!")) - #:inputs `((,builder)))) - ((succeeded?) - (build-derivations %store (list drv-path)))) + (let* ((builder (add-text-to-store %store "my-builder.sh" + "echo hello, world > \"$out\"\n" + '())) + (drv (derivation %store "foo" + %bash `(,builder) + #:env-vars '(("HOME" . "/homeless") + ("zzz" . "Z!") + ("AAA" . "A!")) + #:inputs `((,builder)))) + (succeeded? + (build-derivations %store (list drv)))) (and succeeded? - (let ((path (derivation-output-path - (assoc-ref (derivation-outputs drv) "out")))) + (let ((path (derivation->output-path drv))) (and (valid-path? %store path) - (string=? (derivation-file-name drv) drv-path) (string=? (call-with-input-file path read-line) "hello, world")))))) @@ -146,7 +142,7 @@ (input (search-path %load-path "ice-9/boot-9.scm")) (input* (add-to-store %store (basename input) #t "sha256" input)) - (drv-path (derivation %store "derivation-with-input-file" + (drv (derivation %store "derivation-with-input-file" %bash `(,builder) ;; Cheat to pass the actual file name to the @@ -155,22 +151,22 @@ #:inputs `((,builder) (,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 ;; the contents. - (valid-path? %store (derivation-path->output-path drv-path))))) + (valid-path? %store (derivation->output-path drv))))) (test-assert "fixed-output derivation" (let* ((builder (add-text-to-store %store "my-fixed-builder.sh" "echo -n hello > $out" '())) (hash (sha256 (string->utf8 "hello"))) - (drv-path (derivation %store "fixed" + (drv (derivation %store "fixed" %bash `(,builder) #:inputs `((,builder)) ; optional #:hash hash #:hash-algo 'sha256)) - (succeeded? (build-derivations %store (list drv-path)))) + (succeeded? (build-derivations %store (list drv)))) (and succeeded? - (let ((p (derivation-path->output-path drv-path))) + (let ((p (derivation->output-path drv))) (and (equal? (string->utf8 "hello") (call-with-input-file p get-bytevector-all)) (bytevector? (query-path-hash %store p))))))) @@ -181,17 +177,16 @@ (builder2 (add-text-to-store %store "fixed-builder2.sh" "echo hey; echo -n hello > $out" '())) (hash (sha256 (string->utf8 "hello"))) - (drv-path1 (derivation %store "fixed" + (drv1 (derivation %store "fixed" %bash `(,builder1) #:hash hash #:hash-algo 'sha256)) - (drv-path2 (derivation %store "fixed" + (drv2 (derivation %store "fixed" %bash `(,builder2) #:hash hash #:hash-algo 'sha256)) - (succeeded? (build-derivations %store - (list drv-path1 drv-path2)))) + (succeeded? (build-derivations %store (list drv1 drv2)))) (and succeeded? - (equal? (derivation-path->output-path drv-path1) - (derivation-path->output-path drv-path2))))) + (equal? (derivation->output-path drv1) + (derivation->output-path drv2))))) (test-assert "derivation with a fixed-output input" ;; A derivation D using a fixed-output derivation F doesn't has the same @@ -208,7 +203,7 @@ (fixed2 (derivation %store "fixed" %bash `(,builder2) #:hash hash #:hash-algo 'sha256)) - (fixed-out (derivation-path->output-path fixed1)) + (fixed-out (derivation->output-path fixed1)) (builder3 (add-text-to-store %store "final-builder.sh" ;; Use Bash hackery to avoid Coreutils. @@ -224,26 +219,26 @@ (succeeded? (build-derivations %store (list final1 final2)))) (and succeeded? - (equal? (derivation-path->output-path final1) - (derivation-path->output-path final2))))) + (equal? (derivation->output-path final1) + (derivation->output-path final2))))) (test-assert "multiple-output derivation" (let* ((builder (add-text-to-store %store "my-fixed-builder.sh" "echo one > $out ; echo two > $second" '())) - (drv-path (derivation %store "fixed" + (drv (derivation %store "fixed" %bash `(,builder) #:env-vars '(("HOME" . "/homeless") ("zzz" . "Z!") ("AAA" . "A!")) #:inputs `((,builder)) #:outputs '("out" "second"))) - (succeeded? (build-derivations %store (list drv-path)))) + (succeeded? (build-derivations %store (list drv)))) (and succeeded? - (let ((one (derivation-path->output-path drv-path "out")) - (two (derivation-path->output-path drv-path "second"))) + (let ((one (derivation->output-path drv "out")) + (two (derivation->output-path drv "second"))) (and (lset= equal? - (derivation-path->output-paths drv-path) + (derivation->output-paths drv) `(("out" . ,one) ("second" . ,two))) (eq? 'one (call-with-input-file one read)) (eq? 'two (call-with-input-file two read))))))) @@ -254,14 +249,14 @@ (let* ((builder (add-text-to-store %store "my-fixed-builder.sh" "echo one > $out ; echo two > $AAA" '())) - (drv-path (derivation %store "fixed" + (drv (derivation %store "fixed" %bash `(,builder) #:inputs `((,builder)) #:outputs '("out" "AAA"))) - (succeeded? (build-derivations %store (list drv-path)))) + (succeeded? (build-derivations %store (list drv)))) (and succeeded? - (let ((one (derivation-path->output-path drv-path "out")) - (two (derivation-path->output-path drv-path "AAA"))) + (let ((one (derivation->output-path drv "out")) + (two (derivation->output-path drv "AAA"))) (and (eq? 'one (call-with-input-file one read)) (eq? 'two (call-with-input-file two read))))))) @@ -283,17 +278,17 @@ (udrv (derivation %store "multiple-output-user" %bash `(,builder2) #:env-vars `(("one" - . ,(derivation-path->output-path + . ,(derivation->output-path mdrv "out")) ("two" - . ,(derivation-path->output-path + . ,(derivation->output-path mdrv "two"))) #:inputs `((,builder2) ;; two occurrences of MDRV: (,mdrv) (,mdrv "two"))))) (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) (equal? '(one two) (call-with-input-file p read))))))) @@ -318,7 +313,7 @@ ("input1" . ,input1) ("input2" . ,input2)) #:inputs `((,%bash) (,builder)))) - (out (derivation-path->output-path drv))) + (out (derivation->output-path drv))) (define (deps path . deps) (let ((count (length deps))) (string-append path "\n\n" (number->string count) "\n" @@ -361,31 +356,30 @@ (add-text-to-store %store "build-with-coreutils.sh" "echo $PATH ; mkdir --version ; mkdir $out ; touch $out/good" '())) - (drv-path + (drv (derivation %store "foo" %bash `(,builder) #:env-vars `(("PATH" . ,(string-append - (derivation-path->output-path %coreutils) + (derivation->output-path %coreutils) "/bin"))) #:inputs `((,builder) (,%coreutils)))) (succeeded? - (build-derivations %store (list drv-path)))) + (build-derivations %store (list drv)))) (and succeeded? - (let ((p (derivation-path->output-path drv-path))) + (let ((p (derivation->output-path drv))) (and (valid-path? %store p) (file-exists? (string-append p "/good"))))))) (test-skip (if (%guile-for-build) 0 8)) (test-assert "build-expression->derivation and derivation-prerequisites" - (let-values (((drv-path drv) - (build-expression->derivation %store "fail" (%current-system) - #f '()))) + (let ((drv (build-expression->derivation %store "fail" (%current-system) + #f '()))) (any (match-lambda (($ path) - (string=? path (%guile-for-build)))) + (string=? path (derivation-file-name (%guile-for-build))))) (derivation-prerequisites drv)))) (test-assert "build-expression->derivation without inputs" @@ -394,11 +388,11 @@ (call-with-output-file (string-append %output "/test") (lambda (p) (display '(hello guix) p))))) - (drv-path (build-expression->derivation %store "goo" (%current-system) + (drv (build-expression->derivation %store "goo" (%current-system) builder '())) - (succeeded? (build-derivations %store (list drv-path)))) + (succeeded? (build-derivations %store (list drv)))) (and succeeded? - (let ((p (derivation-path->output-path drv-path))) + (let ((p (derivation->output-path drv))) (equal? '(hello guix) (call-with-input-file (string-append p "/test") read)))))) @@ -407,43 +401,35 @@ (set-build-options s #:max-silent-time 1) s)) (builder '(sleep 100)) - (drv-path (build-expression->derivation %store "silent" + (drv (build-expression->derivation %store "silent" (%current-system) builder '())) - (out-path (derivation-path->output-path drv-path))) + (out-path (derivation->output-path drv))) (guard (c ((nix-protocol-error? c) (and (string-contains (nix-protocol-error-message c) "failed") (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" - (let-values (((drv-path drv) - (build-expression->derivation %store "fail" (%current-system) - #f '()))) + (let ((drv (build-expression->derivation %store "fail" (%current-system) + #f '()))) ;; The only direct dependency is (%guile-for-build) and it's already ;; built. (null? (derivation-prerequisites-to-build %store drv)))) (test-assert "derivation-prerequisites-to-build when outputs already present" - (let*-values (((builder) - '(begin (mkdir %output) #t)) - ((input-drv-path input-drv) - (build-expression->derivation %store "input" - (%current-system) - builder '())) - ((input-path) - (derivation-output-path - (assoc-ref (derivation-outputs input-drv) - "out"))) - ((drv-path drv) - (build-expression->derivation %store "something" - (%current-system) - builder - `(("i" ,input-drv-path)))) - ((output) - (derivation-output-path - (assoc-ref (derivation-outputs drv) "out")))) + (let* ((builder '(begin (mkdir %output) #t)) + (input-drv (build-expression->derivation %store "input" + (%current-system) + builder '())) + (input-path (derivation-output-path + (assoc-ref (derivation-outputs input-drv) + "out"))) + (drv (build-expression->derivation %store "something" + (%current-system) builder + `(("i" ,input-drv)))) + (output (derivation->output-path drv))) ;; Make sure these things are not already built. (when (valid-path? %store input-path) (delete-paths %store (list input-path))) @@ -452,10 +438,10 @@ (and (equal? (map derivation-input-path (derivation-prerequisites-to-build %store drv)) - (list input-drv-path)) + (list (derivation-file-name input-drv))) ;; Build DRV and delete its input. - (build-derivations %store (list drv-path)) + (build-derivations %store (list drv)) (delete-paths %store (list input-path)) (not (valid-path? %store input-path)) @@ -465,17 +451,12 @@ (test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1)) (test-assert "derivation-prerequisites-to-build and substitutes" - (let*-values (((store) - (open-connection)) - ((drv-path drv) - (build-expression->derivation store "prereq-subst" + (let* ((store (open-connection)) + (drv (build-expression->derivation store "prereq-subst" (%current-system) (random 1000) '())) - ((output) - (derivation-output-path - (assoc-ref (derivation-outputs drv) "out"))) - ((dir) - (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") + (output (derivation->output-path drv)) + (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL") (compose uri-path string->uri)))) ;; Create fake substituter data, to be read by `substitute-binary'. (call-with-output-file (string-append dir "/nix-cache-info") @@ -495,7 +476,8 @@ Deriver: ~a~%" output ; StorePath (string-append dir "/example.nar") ; URL (%current-system) ; System - (basename drv-path)))) ; Deriver + (basename + (derivation-file-name drv))))) ; Deriver (let-values (((build download) (derivation-prerequisites-to-build store drv)) @@ -512,16 +494,16 @@ Deriver: ~a~%" (let* ((builder '(begin (mkdir %output) #f)) ; fail! - (drv-path (build-expression->derivation %store "fail" (%current-system) + (drv (build-expression->derivation %store "fail" (%current-system) builder '())) - (out-path (derivation-path->output-path drv-path))) + (out-path (derivation->output-path drv))) (guard (c ((nix-protocol-error? c) ;; Note that the output path may exist at this point, but it ;; is invalid. (and (string-match "build .* failed" (nix-protocol-error-message c)) (not (valid-path? %store out-path))))) - (build-derivations %store (list drv-path)) + (build-derivations %store (list drv)) #f))) (test-assert "build-expression->derivation with two outputs" @@ -532,15 +514,15 @@ Deriver: ~a~%" (call-with-output-file (assoc-ref %outputs "second") (lambda (p) (display '(world) p))))) - (drv-path (build-expression->derivation %store "double" + (drv (build-expression->derivation %store "double" (%current-system) builder '() #:outputs '("out" "second"))) - (succeeded? (build-derivations %store (list drv-path)))) + (succeeded? (build-derivations %store (list drv)))) (and succeeded? - (let ((one (derivation-path->output-path drv-path)) - (two (derivation-path->output-path drv-path "second"))) + (let ((one (derivation->output-path drv)) + (two (derivation->output-path drv "second"))) (and (equal? '(hello) (call-with-input-file one read)) (equal? '(world) (call-with-input-file two read))))))) @@ -553,12 +535,12 @@ Deriver: ~a~%" (dup2 (port->fdes p) 1) (execl (string-append cu "/bin/uname") "uname" "-a"))))) - (drv-path (build-expression->derivation %store "uname" (%current-system) + (drv (build-expression->derivation %store "uname" (%current-system) builder `(("cu" ,%coreutils)))) - (succeeded? (build-derivations %store (list drv-path)))) + (succeeded? (build-derivations %store (list drv)))) (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"))))) (test-assert "imported-files" @@ -567,9 +549,9 @@ Deriver: ~a~%" "guix/derivations.scm")) ("p/q" . ,(search-path %load-path "guix.scm")) ("p/z" . ,(search-path %load-path "guix/store.scm")))) - (drv-path (imported-files %store files))) - (and (build-derivations %store (list drv-path)) - (let ((dir (derivation-path->output-path drv-path))) + (drv (imported-files %store files))) + (and (build-derivations %store (list drv)) + (let ((dir (derivation->output-path drv))) (every (match-lambda ((path . source) (equal? (call-with-input-file (string-append dir "/" path) @@ -584,14 +566,13 @@ Deriver: ~a~%" (let ((out (assoc-ref %outputs "out"))) (mkdir-p (string-append out "/guile/guix/nix")) #t))) - (drv-path (build-expression->derivation %store - "test-with-modules" + (drv (build-expression->derivation %store "test-with-modules" (%current-system) builder '() #:modules '((guix build utils))))) - (and (build-derivations %store (list drv-path)) - (let* ((p (derivation-path->output-path drv-path)) + (and (build-derivations %store (list drv)) + (let* ((p (derivation->output-path drv)) (s (stat (string-append p "/guile/guix/nix")))) (eq? (stat:type s) 'directory))))) @@ -615,9 +596,10 @@ Deriver: ~a~%" #:hash-algo 'sha256)) (succeeded? (build-derivations %store (list input1 input2)))) (and succeeded? - (not (string=? input1 input2)) - (string=? (derivation-path->output-path input1) - (derivation-path->output-path input2))))) + (not (string=? (derivation-file-name input1) + (derivation-file-name input2))) + (string=? (derivation->output-path input1) + (derivation->output-path input2))))) (test-assert "build-expression->derivation with a fixed-output input" (let* ((builder1 '(call-with-output-file %output @@ -649,8 +631,11 @@ Deriver: ~a~%" (%current-system) builder3 `(("input" ,input2))))) - (and (string=? (derivation-path->output-path final1) - (derivation-path->output-path final2)) + (and (string=? (derivation->output-path final1) + (derivation->output-path final2)) + (string=? (derivation->output-path final1) + (derivation-path->output-path + (derivation-file-name final1))) (build-derivations %store (list final1 final2))))) (test-assert "build-expression->derivation with #:references-graphs" @@ -662,7 +647,7 @@ Deriver: ~a~%" builder '() #:references-graphs `(("input" . ,input)))) - (out (derivation-path->output-path drv))) + (out (derivation->output-path drv))) (define (deps path . deps) (let ((count (length deps))) (string-append path "\n\n" (number->string count) "\n" diff --git a/tests/packages.scm b/tests/packages.scm index 8619011f59..706739fb70 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -121,17 +121,16 @@ (package-source package)))) (string=? file source))) -(test-assert "return values" - (let-values (((drv-path drv) - (package-derivation %store (dummy-package "p")))) - (and (derivation-path? drv-path) - (derivation? drv)))) +(test-assert "return value" + (let ((drv (package-derivation %store (dummy-package "p")))) + (and (derivation? drv) + (file-exists? (derivation-file-name drv))))) (test-assert "package-output" (let* ((package (dummy-package "p")) - (drv-path (package-derivation %store package))) - (and (derivation-path? drv-path) - (string=? (derivation-path->output-path drv-path) + (drv (package-derivation %store package))) + (and (derivation? drv) + (string=? (derivation->output-path drv) (package-output %store package "out"))))) (test-assert "trivial" @@ -148,7 +147,7 @@ (display '(hello guix) p)))))))) (d (package-derivation %store p))) (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) (call-with-input-file (string-append p "/test") read)))))) @@ -164,7 +163,7 @@ (inputs `(("input" ,i))))) (d (package-derivation %store p))) (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) (call-with-input-file i get-bytevector-all)))))) @@ -183,7 +182,7 @@ (%current-system))))))) (d (package-derivation %store p))) (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)))))) (test-assert "search paths" @@ -222,20 +221,17 @@ (equal? x (collect (package-derivation %store c))))))) (test-assert "package-cross-derivation" - (let-values (((drv-path drv) - (package-cross-derivation %store (dummy-package "p") - "mips64el-linux-gnu"))) - (and (derivation-path? drv-path) - (derivation? drv)))) + (let ((drv (package-cross-derivation %store (dummy-package "p") + "mips64el-linux-gnu"))) + (and (derivation? drv) + (file-exists? (derivation-file-name drv))))) (test-assert "package-cross-derivation, trivial-build-system" (let ((p (package (inherit (dummy-package "p")) (build-system trivial-build-system) (arguments '(#:builder (exit 1)))))) - (let-values (((drv-path drv) - (package-cross-derivation %store p "mips64el-linux-gnu"))) - (and (derivation-path? drv-path) - (derivation? drv))))) + (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu"))) + (derivation? drv)))) (test-assert "package-cross-derivation, no cross builder" (let* ((b (build-system (inherit trivial-build-system) @@ -257,7 +253,7 @@ (or (location? (package-location gnu-make)) (not (package-location 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)) (file-exists? (string-append out "/bin/make"))))))) diff --git a/tests/store.scm b/tests/store.scm index 0280713191..b5e0cb0eab 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -82,7 +82,7 @@ ;; (d1 (derivation %store "link" ;; "/bin/sh" `("-e" ,b) ;; #:inputs `((,b) (,p1)))) -;; (p2 (derivation-path->output-path d1))) +;; (p2 (derivation->output-path d1))) ;; (and (add-temp-root %store p2) ;; (build-derivations %store (list d1)) ;; (valid-path? %store p1) @@ -133,21 +133,21 @@ s `("-e" ,b) #:env-vars `(("foo" . ,(random-text))) #:inputs `((,b) (,s)))) - (o (derivation-path->output-path d))) + (o (derivation->output-path d))) (and (build-derivations %store (list d)) - (equal? (query-derivation-outputs %store d) + (equal? (query-derivation-outputs %store (derivation-file-name d)) (list o)) (equal? (valid-derivers %store o) - (list d))))) + (list (derivation-file-name d)))))) (test-assert "no substitutes" (let* ((s (open-connection)) (d1 (package-derivation s %bootstrap-guile (%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) - (and (not (has-substitutes? s d1)) - (not (has-substitutes? s d2)) + (and (not (has-substitutes? s (derivation-file-name d1))) + (not (has-substitutes? s (derivation-file-name d2))) (null? (substitutable-paths s o)) (null? (substitutable-path-info s o))))) @@ -156,7 +156,7 @@ (test-assert "substitute query" (let* ((s (open-connection)) (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") (compose uri-path string->uri)))) ;; Create fake substituter data, to be read by `substitute-binary'. @@ -177,7 +177,8 @@ Deriver: ~a~%" o ; StorePath (string-append dir "/example.nar") ; URL (%current-system) ; System - (basename d)))) ; Deriver + (basename + (derivation-file-name d))))) ; Deriver ;; Remove entry from the local cache. (false-if-exception @@ -191,7 +192,7 @@ Deriver: ~a~%" (equal? (list o) (substitutable-paths s (list o))) (match (pk 'spi (substitutable-path-info s (list o))) (((? substitutable? s)) - (and (equal? (substitutable-deriver s) d) + (and (string=? (substitutable-deriver s) (derivation-file-name d)) (null? (substitutable-references s)) (equal? (substitutable-nar-size s) 1234))))))) @@ -207,7 +208,7 @@ Deriver: ~a~%" '() #:guile-for-build (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") (compose uri-path string->uri)))) ;; Create fake substituter data, to be read by `substitute-binary'. @@ -238,7 +239,8 @@ Deriver: ~a~%" (compose bytevector->nix-base32-string sha256 get-bytevector-all)) (%current-system) ; System - (basename d)))) ; Deriver + (basename + (derivation-file-name d))))) ; Deriver ;; Make sure we use `substitute-binary'. (set-build-options s #:use-substitutes? #t) @@ -257,7 +259,7 @@ Deriver: ~a~%" '() #:guile-for-build (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") (compose uri-path string->uri)))) ;; Create fake substituter data, to be read by `substitute-binary'. @@ -279,7 +281,8 @@ Deriver: ~a~%" o ; StorePath "does-not-exist.nar" ; relative URL (%current-system) ; System - (basename d)))) ; Deriver + (basename + (derivation-file-name d))))) ; Deriver ;; Make sure we use `substitute-binary'. (set-build-options s #:use-substitutes? #t) diff --git a/tests/union.scm b/tests/union.scm index 6287cffc38..cb110c3b1e 100644 --- a/tests/union.scm +++ b/tests/union.scm @@ -108,7 +108,7 @@ builder inputs #:modules '((guix build union))))) (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") (file-exists? "bin/gcc") (file-exists? "bin/ld") -- cgit v1.2.3 From 2cd09108c9b316c9c8aa1c1b87b85a1c32cef089 Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov Date: Thu, 19 Sep 2013 11:07:39 +0000 Subject: guix package: Add '--list-generations'. * guix/scripts/package.scm: Import (srfi srfi-19). (generation-time, matching-generations): New functions. (show-help): Add '--list-generations'. (%options): Likewise. (guix-package)[process-query]: Add support for '--list-generations'. * guix/ui.scm: Import (srfi srfi-19) and (ice-9 regex). (string->generations, string->duration): New functions. * tests/guix-package.sh: Test '--list-generations'. * tests/ui.scm: Import (srfi srfi-19). Test 'string->generations' and 'string->duration'. * doc/guix.texi (Invoking guix-package): Document '--list-generations'. --- doc/guix.texi | 33 +++++++++++++++ guix/scripts/package.scm | 107 +++++++++++++++++++++++++++++++++++++++++++++++ guix/ui.scm | 68 ++++++++++++++++++++++++++++++ tests/guix-package.sh | 4 ++ tests/ui.scm | 85 +++++++++++++++++++++++++++++++++++++ 5 files changed, 297 insertions(+) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 92c163c608..fdddcc52c3 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -606,6 +606,39 @@ library are installed in the profile, then @code{--search-paths} will suggest setting these variables to @code{@var{profile}/include} and @code{@var{profile}/lib}, respectively. +@item --list-generations[=@var{pattern}] +@itemx -l [@var{pattern}] +Return a list of generations along with their creation dates. + +For each installed package, print the following items, separated by +tabs: the name of a package, its version string, the part of the package +that is installed (@pxref{Packages with Multiple Outputs}), and the +location of this package in the store. + +When @var{pattern} is used, the command returns only matching +generations. Valid patterns include: + +@itemize +@item @emph{Integers and comma-separated integers}. Both patterns denote +generation numbers. For instance, @code{--list-generations=1} returns +the first one. + +And @code{--list-generations=1,8,2} outputs three generations in the +specified order. Neither spaces nor trailing commas are allowed. + +@item @emph{Ranges}. @code{--list-generations=2..9} prints the +specified generations and everything in between. Note that the start of +a range must be lesser than its end. + +It is also possible to omit the endpoint. For example, +@code{--list-generations=2..}, returns all generations starting from the +second one. + +@item @emph{Durations}. You can also get the last @emph{N}@tie{}days, weeks, +or months by passing an integer along with the first letter of the +duration, e.g., @code{--list-generations=20d}. +@end itemize + @item --profile=@var{profile} @itemx -p @var{profile} Use @var{profile} instead of the user's default profile. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 862b82612a..98b8aedfc9 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -34,6 +34,7 @@ #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) @@ -243,6 +244,74 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (switch-link))) (else (switch-link))))) ; anything else +(define (generation-time profile number) + "Return the creation time of a generation in the UTC format." + (make-time time-utc 0 + (stat:ctime (stat (format #f "~a-~a-link" profile number))))) + +(define* (matching-generations str #:optional (profile %current-profile)) + "Return the list of available generations matching a pattern in STR. See +'string->generations' and 'string->duration' for the list of valid patterns." + (define (valid-generations lst) + (define (valid-generation? n) + (any (cut = n <>) (generation-numbers profile))) + + (fold-right (lambda (x acc) + (if (valid-generation? x) + (cons x acc) + acc)) + '() + lst)) + + (define (filter-generations generations) + (match generations + (() '()) + (('>= n) + (drop-while (cut > n <>) + (generation-numbers profile))) + (('<= n) + (valid-generations (iota n 1))) + ((lst ..1) + (valid-generations lst)) + (_ #f))) + + (define (filter-by-duration duration) + (define (time-at-midnight time) + ;; Return TIME at midnight by setting nanoseconds, seconds, minutes, and + ;; hours to zeros. + (let ((d (time-utc->date time))) + (date->time-utc + (make-date 0 0 0 0 + (date-day d) (date-month d) + (date-year d) (date-zone-offset d))))) + + (define generation-ctime-alist + (map (lambda (number) + (cons number + (time-second + (time-at-midnight + (generation-time profile number))))) + (generation-numbers profile))) + + (match duration + (#f #f) + (res + (let ((s (time-second + (subtract-duration (time-at-midnight (current-time)) + duration)))) + (delete #f (map (lambda (x) + (and (<= s (cdr x)) + (first x))) + generation-ctime-alist)))))) + + (cond ((string->generations str) + => + filter-generations) + ((string->duration str) + => + filter-by-duration) + (else #f))) + (define (find-packages-by-description rx) "Search in SYNOPSIS and DESCRIPTION using RX. Return a list of matching packages." @@ -438,6 +507,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) --roll-back roll back to the previous generation")) (display (_ " --search-paths display needed environment variable definitions")) + (display (_ " + -l, --list-generations[=PATTERN] + list generations matching PATTERN")) (newline) (display (_ " -p, --profile=PROFILE use PROFILE instead of the user's default profile")) @@ -497,6 +569,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (option '("roll-back") #f #f (lambda (opt name arg result) (alist-cons 'roll-back? #t result))) + (option '(#\l "list-generations") #f #t + (lambda (opt name arg result) + (cons `(query list-generations ,(or arg "")) + result))) (option '("search-paths") #f #f (lambda (opt name arg result) (cons `(query search-paths) result))) @@ -876,6 +952,37 @@ more information.~%")) ;; actually processed, #f otherwise. (let ((profile (assoc-ref opts 'profile))) (match (assoc-ref opts 'query) + (('list-generations pattern) + (define (list-generation number) + (begin + (format #t "Generation ~a\t~a~%" number + (date->string + (time-utc->date + (generation-time profile number)) + "~b ~d ~Y ~T")) + (for-each (match-lambda + ((name version output location _) + (format #t " ~a\t~a\t~a\t~a~%" + name version output location))) + (manifest-packages + (profile-manifest + (format #f "~a-~a-link" profile number)))) + (newline))) + + (cond ((not (file-exists? profile)) ; XXX: race condition + (leave (_ "profile '~a' does not exist~%") + profile)) + ((string-null? pattern) + (for-each list-generation + (generation-numbers profile))) + ((matching-generations pattern profile) + => + (cut for-each list-generation <>)) + (else + (leave (_ "invalid syntax: ~a~%") + pattern))) + #t) + (('list-installed regexp) (let* ((regexp (and regexp (make-regexp regexp))) (manifest (profile-manifest profile)) diff --git a/guix/ui.scm b/guix/ui.scm index 293730308e..4415997252 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -28,12 +28,14 @@ #:use-module ((guix licenses) #:select (license? license-name)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) #:autoload (ice-9 ftw) (scandir) #:use-module (ice-9 match) #:use-module (ice-9 format) + #:use-module (ice-9 regex) #:export (_ N_ leave @@ -50,6 +52,8 @@ fill-paragraph string->recutils package->recutils + string->generations + string->duration args-fold* run-guix-command program-name @@ -404,6 +408,70 @@ WIDTH columns." (and=> (package-description p) description->recutils)) (newline port)) +(define (string->generations str) + "Return the list of generations matching a pattern in STR. This function +accepts the following patterns: \"1\", \"1,2,3\", \"1..9\", \"1..\", \"..9\"." + (define (maybe-integer) + (let ((x (string->number str))) + (and (integer? x) + x))) + + (define (maybe-comma-separated-integers) + (let ((lst (delete-duplicates + (map string->number + (string-split str #\,))))) + (and (every integer? lst) + lst))) + + (cond ((maybe-integer) + => + list) + ((maybe-comma-separated-integers) + => + identity) + ((string-match "^([0-9]+)\\.\\.([0-9]+)$" str) + => + (lambda (match) + (let ((s (string->number (match:substring match 1))) + (e (string->number (match:substring match 2)))) + (and (every integer? (list s e)) + (<= s e) + (iota (1+ (- e s)) s))))) + ((string-match "^([0-9]+)\\.\\.$" str) + => + (lambda (match) + (let ((s (string->number (match:substring match 1)))) + (and (integer? s) + `(>= ,s))))) + ((string-match "^\\.\\.([0-9]+)$" str) + => + (lambda (match) + (let ((e (string->number (match:substring match 1)))) + (and (integer? e) + `(<= ,e))))) + (else #f))) + +(define (string->duration str) + "Return the duration matching a pattern in STR. This function accepts the +following patterns: \"1d\", \"1w\", \"1m\"." + (define (hours->duration hours match) + (make-time time-duration 0 + (* 3600 hours (string->number (match:substring match 1))))) + + (cond ((string-match "^([0-9]+)d$" str) + => + (lambda (match) + (hours->duration 24 match))) + ((string-match "^([0-9]+)w$" str) + => + (lambda (match) + (hours->duration (* 24 7) match))) + ((string-match "^([0-9]+)m$" str) + => + (lambda (match) + (hours->duration (* 24 30) match))) + (else #f))) + (define (args-fold* options unrecognized-option-proc operand-proc . seeds) "A wrapper on top of `args-fold' that does proper user-facing error reporting." diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 60b42907a8..b09a9c0173 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -81,6 +81,10 @@ then "name: hello" test "`guix package -s "n0t4r341p4ck4g3"`" = "" + # List generations. + test "`guix package -p "$profile" -l | cut -f1 | grep guile | head -n1`" \ + = " guile-bootstrap" + # Remove a package. guix package --bootstrap -p "$profile" -r "guile-bootstrap" test -L "$profile-3-link" diff --git a/tests/ui.scm b/tests/ui.scm index 0b6f3c5815..3d5c3e7969 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -20,6 +20,7 @@ (define-module (test-ui) #:use-module (guix ui) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-64)) ;; Test the (guix ui) module. @@ -64,6 +65,90 @@ interface, and powerful string processing.") 10) #\newline)) +(test-equal "integer" + '(1) + (string->generations "1")) + +(test-equal "comma-separated integers" + '(3 7 1 4 6) + (string->generations "3,7,1,4,6")) + +(test-equal "closed range" + '(4 5 6 7 8 9 10 11 12) + (string->generations "4..12")) + +(test-equal "closed range, equal endpoints" + '(3) + (string->generations "3..3")) + +(test-equal "indefinite end range" + '(>= 7) + (string->generations "7..")) + +(test-equal "indefinite start range" + '(<= 42) + (string->generations "..42")) + +(test-equal "integer, char" + #f + (string->generations "a")) + +(test-equal "comma-separated integers, consecutive comma" + #f + (string->generations "1,,2")) + +(test-equal "comma-separated integers, trailing comma" + #f + (string->generations "1,2,")) + +(test-equal "comma-separated integers, chars" + #f + (string->generations "a,b")) + +(test-equal "closed range, start > end" + #f + (string->generations "9..2")) + +(test-equal "closed range, chars" + #f + (string->generations "a..b")) + +(test-equal "indefinite end range, char" + #f + (string->generations "a..")) + +(test-equal "indefinite start range, char" + #f + (string->generations "..a")) + +(test-equal "duration, 1 day" + (make-time time-duration 0 (* 3600 24)) + (string->duration "1d")) + +(test-equal "duration, 1 week" + (make-time time-duration 0 (* 3600 24 7)) + (string->duration "1w")) + +(test-equal "duration, 1 month" + (make-time time-duration 0 (* 3600 24 30)) + (string->duration "1m")) + +(test-equal "duration, 1 week == 7 days" + (string->duration "1w") + (string->duration "7d")) + +(test-equal "duration, 1 month == 30 days" + (string->duration "1m") + (string->duration "30d")) + +(test-equal "duration, integer" + #f + (string->duration "1")) + +(test-equal "duration, char" + #f + (string->duration "d")) + (test-end "ui") -- cgit v1.2.3 From bd9bde1cba7190ed8b87aefbd09b1e25c5acbf31 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Sep 2013 21:50:11 +0200 Subject: guix package: Show most recently installed packages last. Suggested by Andreas Enge . * guix/scripts/package.scm (guix-package)[list-generations, list-installed]: Reverse the result of 'manifest-packages'. * doc/guix.texi (Invoking guix package): Document the order of packages for '--list-generations' and '--list-installed'. --- doc/guix.texi | 10 ++++++---- guix/scripts/package.scm | 13 +++++++++---- 2 files changed, 15 insertions(+), 8 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index fdddcc52c3..9eb67ecd01 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -608,7 +608,9 @@ suggest setting these variables to @code{@var{profile}/include} and @item --list-generations[=@var{pattern}] @itemx -l [@var{pattern}] -Return a list of generations along with their creation dates. +Return a list of generations along with their creation dates; for each +generation, show the installed packages, with the most recently +installed packages shown last. For each installed package, print the following items, separated by tabs: the name of a package, its version string, the part of the package @@ -692,9 +694,9 @@ version: 7.2alpha6 @item --list-installed[=@var{regexp}] @itemx -I [@var{regexp}] -List currently installed packages in the specified profile. When -@var{regexp} is specified, list only installed packages whose name -matches @var{regexp}. +List the currently installed packages in the specified profile, with the +most recently installed packages shown last. When @var{regexp} is +specified, list only installed packages whose name matches @var{regexp}. For each installed package, print the following items, separated by tabs: the package name, its version string, the part of the package that diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index c0cedcd4a8..1d00e39540 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -965,9 +965,12 @@ more information.~%")) ((name version output location _) (format #t " ~a\t~a\t~a\t~a~%" name version output location))) - (manifest-packages - (profile-manifest - (format #f "~a-~a-link" profile number)))) + + ;; Show most recently installed packages last. + (reverse + (manifest-packages + (profile-manifest + (format #f "~a-~a-link" profile number))))) (newline))) (cond ((not (file-exists? profile)) ; XXX: race condition @@ -994,7 +997,9 @@ more information.~%")) (regexp-exec regexp name)) (format #t "~a\t~a\t~a\t~a~%" name (or version "?") output path)))) - installed) + + ;; Show most recently installed packages last. + (reverse installed)) #t)) (('list-available regexp) -- cgit v1.2.3 From f566d765a1494e6c1194a5d7c84f4f16ae8fb81b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Sep 2013 22:03:15 +0200 Subject: doc: Document '--list-generations' among the query options. * doc/guix.texi (Invoking guix package): Move '--list-generations' below "In addition to these actions". --- doc/guix.texi | 70 +++++++++++++++++++++++++++++------------------------------ 1 file changed, 35 insertions(+), 35 deletions(-) (limited to 'doc/guix.texi') diff --git a/doc/guix.texi b/doc/guix.texi index 9eb67ecd01..90016a4496 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -606,41 +606,6 @@ library are installed in the profile, then @code{--search-paths} will suggest setting these variables to @code{@var{profile}/include} and @code{@var{profile}/lib}, respectively. -@item --list-generations[=@var{pattern}] -@itemx -l [@var{pattern}] -Return a list of generations along with their creation dates; for each -generation, show the installed packages, with the most recently -installed packages shown last. - -For each installed package, print the following items, separated by -tabs: the name of a package, its version string, the part of the package -that is installed (@pxref{Packages with Multiple Outputs}), and the -location of this package in the store. - -When @var{pattern} is used, the command returns only matching -generations. Valid patterns include: - -@itemize -@item @emph{Integers and comma-separated integers}. Both patterns denote -generation numbers. For instance, @code{--list-generations=1} returns -the first one. - -And @code{--list-generations=1,8,2} outputs three generations in the -specified order. Neither spaces nor trailing commas are allowed. - -@item @emph{Ranges}. @code{--list-generations=2..9} prints the -specified generations and everything in between. Note that the start of -a range must be lesser than its end. - -It is also possible to omit the endpoint. For example, -@code{--list-generations=2..}, returns all generations starting from the -second one. - -@item @emph{Durations}. You can also get the last @emph{N}@tie{}days, weeks, -or months by passing an integer along with the first letter of the -duration, e.g., @code{--list-generations=20d}. -@end itemize - @item --profile=@var{profile} @itemx -p @var{profile} Use @var{profile} instead of the user's default profile. @@ -714,6 +679,41 @@ For each package, print the following items separated by tabs: its name, its version string, the parts of the package (@pxref{Packages with Multiple Outputs}), and the source location of its definition. +@item --list-generations[=@var{pattern}] +@itemx -l [@var{pattern}] +Return a list of generations along with their creation dates; for each +generation, show the installed packages, with the most recently +installed packages shown last. + +For each installed package, print the following items, separated by +tabs: the name of a package, its version string, the part of the package +that is installed (@pxref{Packages with Multiple Outputs}), and the +location of this package in the store. + +When @var{pattern} is used, the command returns only matching +generations. Valid patterns include: + +@itemize +@item @emph{Integers and comma-separated integers}. Both patterns denote +generation numbers. For instance, @code{--list-generations=1} returns +the first one. + +And @code{--list-generations=1,8,2} outputs three generations in the +specified order. Neither spaces nor trailing commas are allowed. + +@item @emph{Ranges}. @code{--list-generations=2..9} prints the +specified generations and everything in between. Note that the start of +a range must be lesser than its end. + +It is also possible to omit the endpoint. For example, +@code{--list-generations=2..}, returns all generations starting from the +second one. + +@item @emph{Durations}. You can also get the last @emph{N}@tie{}days, weeks, +or months by passing an integer along with the first letter of the +duration, e.g., @code{--list-generations=20d}. +@end itemize + @end table @node Packages with Multiple Outputs -- cgit v1.2.3