futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

packages: Implement grafts.

Browse Source 
Thanks to Mark H. Weaver <mhw@netris.org> for insightful discussions
and suggestions.

* guix/packages.scm (<package>)[graft]: New field.
  (patch-and-repack): Invoke 'package-derivation' with #:graft? #f.
  (package-source-derivation): Likewise.  Do not use (%guile-for-build)
  in call to 'patch-and-repack', and we could end up using a grafted
  Guile.
  (expand-input): Likewise, also for 'package-cross-derivation' call.
  (package->bag): Add #:graft? parameter.  Honor it.  Use 'strip-append'
  instead of 'package-full-name'.
  (input-graft, input-cross-graft, bag-grafts, package-grafts): New
  procedures.
  (package-derivation, package-cross-derivation): Add #:graft? parameter
  and honor it.
* gnu/packages/bootstrap.scm (package-with-bootstrap-guile): Add
  recursive call on 'graft'.
* guix/build-system/gnu.scm (package-with-explicit-inputs,
  package-with-extra-configure-variable, static-package): Likewise.
  (gnu-build): Use the ungrafted Guile to avoid full rebuilds.
  (gnu-cross-build): Likewise.
* guix/build-system/cmake.scm (cmake-build): Likewise.
* guix/build-system/glib-or-gtk.scm (glib-or-gtk-build): Likewise.
* guix/build-system/perl.scm (perl-build): Likewise.
* guix/build-system/python.scm (python-build): Likewise.
* guix/build-system/ruby.scm (ruby-build): Likewise.
* guix/build-system/trivial.scm (guile-for-build): Likewise.
* tests/packages.scm ("package-derivation, direct graft",
  "package-cross-derivation, direct graft", "package-grafts,
  indirect grafts", "package-grafts, indirect grafts, cross",
  "package-grafts, indirect grafts, propagated inputs",
  "package-derivation, indirect grafts"): New tests.
  ("bag->derivation", "bag->derivation, cross-compilation"): Wrap in
  'parameterize'.
* doc/guix.texi (Security Updates): New node.
  (Invoking guix build): Document --no-graft.
This commit is contained in:
Ludovic Courtès 2014-10-27 18:09:00 +01:00
parent 50373bab7a
commit 05962f2958
12 changed files with 347 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
doc/guix.texi
View File

@ -2569,6 +2569,10 @@ candidates:
guix build guile --with-source=../guile-2.0.9.219-e1bb7.tar.xz guix build guile --with-source=../guile-2.0.9.219-e1bb7.tar.xz
@end example @end example
@item --no-grafts
Do not ``graft'' packages. In practice, this means that package updates
available as grafts are not applied. @xref{Security Updates}, for more
information on grafts.
@item --derivations @item --derivations
@itemx -d @itemx -d
@ -3003,6 +3007,7 @@ For information on porting to other architectures or kernels,
* System Installation:: Installing the whole operating system. * System Installation:: Installing the whole operating system.
* System Configuration:: Configuring a GNU system. * System Configuration:: Configuring a GNU system.
* Installing Debugging Files:: Feeding the debugger. * Installing Debugging Files:: Feeding the debugger.
* Security Updates:: Deploying security fixes quickly.
* Package Modules:: Packages from the programmer's viewpoint. * Package Modules:: Packages from the programmer's viewpoint.
* Packaging Guidelines:: Growing the distribution. * Packaging Guidelines:: Growing the distribution.
* Bootstrapping:: GNU/Linux built from scratch. * Bootstrapping:: GNU/Linux built from scratch.
@ -4280,6 +4285,64 @@ the load. To check whether a package has a @code{debug} output, use
@command{guix package --list-available} (@pxref{Invoking guix package}). @command{guix package --list-available} (@pxref{Invoking guix package}).
@node Security Updates
@section Security Updates
@indentedblock
Note: As of version @value{VERSION}, the feature described in this
section is experimental.
@end indentedblock
@cindex security updates
Occasionally, important security vulnerabilities are discovered in core
software packages and must be patched. Guix follows a functional
package management discipline (@pxref{Introduction}), which implies
that, when a package is changed, @emph{every package that depends on it}
must be rebuilt. This can significantly slow down the deployment of
fixes in core packages such as libc or Bash, since basically the whole
distribution would need to be rebuilt. Using pre-built binaries helps
(@pxref{Substitutes}), but deployment may still take more time than
desired.
@cindex grafts
To address that, Guix implements @dfn{grafts}, a mechanism that allows
for fast deployment of critical updates without the costs associated
with a whole-distribution rebuild. The idea is to rebuild only the
package that needs to be patched, and then to ``graft'' it onto packages
explicitly installed by the user and that were previously referring to
the original package. The cost of grafting is typically very low, and
order of magnitudes lower than a full rebuild of the dependency chain.
@cindex replacements of packages, for grafts
For instance, suppose a security update needs to be applied to Bash.
Guix developers will provide a package definition for the ``fixed''
Bash, say @var{bash-fixed}, in the usual way (@pxref{Defining
Packages}). Then, the original package definition is augmented with a
@code{replacement} field pointing to the package containing the bug fix:
@example
(define bash
(package
(name "bash")
;; @dots{}
(replacement bash-fixed)))
@end example
From there on, any package depending directly or indirectly on Bash that
is installed will automatically be ``rewritten'' to refer to
@var{bash-fixed} instead of @var{bash}. This grafting process takes
time proportional to the size of the package, but expect less than a
minute for an ``average'' package on a recent machine.
Currently, the graft and the package it replaces (@var{bash-fixed} and
@var{bash} in the example above) must have the exact same @code{name}
and @code{version} fields. This restriction mostly comes from the fact
that grafting works by patching files, including binary files, directly.
Other restrictions may apply: for instance, when adding a graft to a
package providing a shared library, the original shared library and its
replacement must have the same @code{SONAME} and be binary-compatible.
@node Package Modules @node Package Modules
@section Package Modules @section Package Modules

4
gnu/packages/bootstrap.scm
View File

@ -146,7 +146,9 @@ check whether everything is alright."
(native-inputs (map rewritten-input (native-inputs (map rewritten-input
(package-native-inputs p))) (package-native-inputs p)))
(propagated-inputs (map rewritten-input (propagated-inputs (map rewritten-input
(package-propagated-inputs p))))))) (package-propagated-inputs p)))
(replacement (and=> (package-replacement p)
package-with-bootstrap-guile))))))
(define* (glibc-dynamic-linker (define* (glibc-dynamic-linker
#:optional (system (or (and=> (%current-target-system) #:optional (system (or (and=> (%current-target-system)

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

@ -125,11 +125,11 @@ provides a 'CMakeLists.txt' file as its build system."
(define guile-for-build (define guile-for-build
(match guile (match guile
((? package?) ((? package?)
(package-derivation store guile system)) (package-derivation store guile system #:graft? #f))
(#f ; the default (#f ; the default
(let* ((distro (resolve-interface '(gnu packages commencement))) (let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final))) (guile (module-ref distro 'guile-final)))
(package-derivation store guile system))))) (package-derivation store guile system #:graft? #f)))))
(build-expression->derivation store name builder (build-expression->derivation store name builder
#:system system #:system system

4
guix/build-system/glib-or-gtk.scm
View File

@ -168,11 +168,11 @@
(define guile-for-build (define guile-for-build
(match guile (match guile
((? package?) ((? package?)
(package-derivation store guile system)) (package-derivation store guile system #:graft? #f))
(#f ; the default (#f ; the default
(let* ((distro (resolve-interface '(gnu packages commencement))) (let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final))) (guile (module-ref distro 'guile-final)))
(package-derivation store guile system))))) (package-derivation store guile system #:graft? #f)))))
(build-expression->derivation store name builder (build-expression->derivation store name builder
#:system system #:system system

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

@ -91,6 +91,13 @@ builder, or the distro's final Guile when GUILE is #f."
`(#:guile ,guile `(#:guile ,guile
#:implicit-inputs? #f #:implicit-inputs? #f
,@args))) ,@args)))
(replacement
(let ((replacement (package-replacement p)))
(and replacement
(package-with-explicit-inputs replacement inputs loc
#:native-inputs
native-inputs
#:guile guile))))
(native-inputs (native-inputs
(let ((filtered (duplicate-filter native-inputs*))) (let ((filtered (duplicate-filter native-inputs*)))
`(,@(call native-inputs*) `(,@(call native-inputs*)
@ -132,6 +139,11 @@ flags for VARIABLE, the associated value is augmented."
(substring flag ,len)) (substring flag ,len))
flag)) flag))
,flags))))))) ,flags)))))))
(replacement
(let ((replacement (package-replacement p)))
(and replacement
(package-with-extra-configure-variable replacement
variable value))))
(inputs (rewritten-inputs (package-inputs p))) (inputs (rewritten-inputs (package-inputs p)))
(propagated-inputs (rewritten-inputs (package-propagated-inputs p)))))) (propagated-inputs (rewritten-inputs (package-propagated-inputs p))))))
@ -155,7 +167,8 @@ use `--strip-all' as the arguments to `strip'."
((#:strip-flags flags) ((#:strip-flags flags)
(if strip-all? (if strip-all?
''("--strip-all") ''("--strip-all")
flags))))))) flags)))))
(replacement (and=> (package-replacement p) static-package))))
(define* (dist-package p source) (define* (dist-package p source)
"Return a package that runs takes source files from the SOURCE directory, "Return a package that runs takes source files from the SOURCE directory,
@ -290,9 +303,11 @@ are allowed to refer to."
(define canonicalize-reference (define canonicalize-reference
(match-lambda (match-lambda
((? package? p) ((? package? p)
(derivation->output-path (package-derivation store p system))) (derivation->output-path (package-derivation store p system
#:graft? #f)))
(((? package? p) output) (((? package? p) output)
(derivation->output-path (package-derivation store p system) (derivation->output-path (package-derivation store p system
#:graft? #f)
output)) output))
((? string? output) ((? string? output)
output))) output)))
@ -328,11 +343,12 @@ are allowed to refer to."
(define guile-for-build (define guile-for-build
(match guile (match guile
((? package?) ((? package?)
(package-derivation store guile system)) (package-derivation store guile system #:graft? #f))
(#f ; the default (#f ; the default
(let* ((distro (resolve-interface '(gnu packages commencement))) (let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final))) (guile (module-ref distro 'guile-final)))
(package-derivation store guile system))))) (package-derivation store guile system
#:graft? #f)))))
(build-expression->derivation store name builder (build-expression->derivation store name builder
#:system system #:system system
@ -472,11 +488,11 @@ platform."
(define guile-for-build (define guile-for-build
(match guile (match guile
((? package?) ((? package?)
(package-derivation store guile system)) (package-derivation store guile system #:graft? #f))
(#f ; the default (#f ; the default
(let* ((distro (resolve-interface '(gnu packages commencement))) (let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final))) (guile (module-ref distro 'guile-final)))
(package-derivation store guile system))))) (package-derivation store guile system #:graft? #f)))))
(build-expression->derivation store name builder (build-expression->derivation store name builder
#:system system #:system system

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

@ -114,11 +114,11 @@ provides a `Makefile.PL' file as its build system."
(define guile-for-build (define guile-for-build
(match guile (match guile
((? package?) ((? package?)
(package-derivation store guile system)) (package-derivation store guile system #:graft? #f))
(#f ; the default (#f ; the default
(let* ((distro (resolve-interface '(gnu packages commencement))) (let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final))) (guile (module-ref distro 'guile-final)))
(package-derivation store guile system))))) (package-derivation store guile system #:graft? #f)))))
(build-expression->derivation store name builder (build-expression->derivation store name builder
#:system system #:system system

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

@ -160,11 +160,11 @@ provides a 'setup.py' file as its build system."
(define guile-for-build (define guile-for-build
(match guile (match guile
((? package?) ((? package?)
(package-derivation store guile system)) (package-derivation store guile system #:graft? #f))
(#f ; the default (#f ; the default
(let* ((distro (resolve-interface '(gnu packages commencement))) (let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final))) (guile (module-ref distro 'guile-final)))
(package-derivation store guile system))))) (package-derivation store guile system #:graft? #f)))))
(build-expression->derivation store name builder (build-expression->derivation store name builder
#:inputs inputs #:inputs inputs

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

@ -99,11 +99,11 @@
(define guile-for-build (define guile-for-build
(match guile (match guile
((? package?) ((? package?)
(package-derivation store guile system)) (package-derivation store guile system #:graft? #f))
(#f (#f
(let* ((distro (resolve-interface '(gnu packages commencement))) (let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final))) (guile (module-ref distro 'guile-final)))
(package-derivation store guile system))))) (package-derivation store guile system #:graft? #f)))))
(build-expression->derivation store name builder (build-expression->derivation store name builder
#:inputs inputs #:inputs inputs

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

@ -28,11 +28,11 @@
(define (guile-for-build store guile system) (define (guile-for-build store guile system)
(match guile (match guile
((? package?) ((? package?)
(package-derivation store guile system)) (package-derivation store guile system #:graft? #f))
(#f ; the default (#f ; the default
(let* ((distro (resolve-interface '(gnu packages commencement))) (let* ((distro (resolve-interface '(gnu packages commencement)))
(guile (module-ref distro 'guile-final))) (guile (module-ref distro 'guile-final)))
(package-derivation store guile system))))) (package-derivation store guile system #:graft? #f)))))
(define* (lower name (define* (lower name
#:key source inputs native-inputs outputs system target #:key source inputs native-inputs outputs system target

147
guix/packages.scm
View File

@ -26,6 +26,7 @@
#: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)
@ -65,6 +66,7 @@
package-outputs package-outputs
package-native-search-paths package-native-search-paths
package-search-paths package-search-paths
package-replacement
package-synopsis package-synopsis
package-description package-description
package-license package-license
@ -85,6 +87,7 @@
package-derivation package-derivation
package-cross-derivation package-cross-derivation
package-output package-output
package-grafts
%supported-systems %supported-systems
@ -97,6 +100,7 @@
&package-cross-build-system-error &package-cross-build-system-error
package-cross-build-system-error? package-cross-build-system-error?
%graft?
package->bag package->bag
bag->derivation bag->derivation
bag-transitive-inputs bag-transitive-inputs
@ -211,6 +215,8 @@ corresponds to the arguments expected by `set-path-environment-variable'."
; inputs ; inputs
(native-search-paths package-native-search-paths (default '())) (native-search-paths package-native-search-paths (default '()))
(search-paths package-search-paths (default '())) (search-paths package-search-paths (default '()))
(replacement package-replacement ; package | #f
(default #f) (thunked))
(synopsis package-synopsis) ; one-line description (synopsis package-synopsis) ; one-line description
(description package-description) ; one or two paragraphs (description package-description) ; one or two paragraphs
@ -445,8 +451,8 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
(and (member name (cons decompression-type (and (member name (cons decompression-type
'("tar" "xz" "patch"))) '("tar" "xz" "patch")))
(list name (list name
(package-derivation store p (package-derivation store p system
system))))) #:graft? #f)))))
(or inputs (%standard-patch-inputs)))) (or inputs (%standard-patch-inputs))))
(modules (delete-duplicates (cons '(guix build utils) modules)))) (modules (delete-duplicates (cons '(guix build utils) modules))))
@ -472,12 +478,10 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
;; Patches and/or a snippet. ;; Patches and/or a snippet.
(let ((source (method store uri 'sha256 sha256 name (let ((source (method store uri 'sha256 sha256 name
#:system system)) #:system system))
(guile (match (or guile-for-build (%guile-for-build) (guile (match (or guile-for-build (default-guile))
(default-guile))
((? package? p) ((? package? p)
(package-derivation store p system)) (package-derivation store p system
((? derivation? drv) #:graft? #f)))))
drv))))
(patch-and-repack store source patches (patch-and-repack store source patches
#:inputs inputs #:inputs inputs
#:snippet snippet #:snippet snippet
@ -617,8 +621,9 @@ information in exceptions."
(define derivation (define derivation
(if cross-system (if cross-system
(cut package-cross-derivation store <> cross-system system) (cut package-cross-derivation store <> cross-system system
(cut package-derivation store <> system))) #:graft? #f)
(cut package-derivation store <> system #:graft? #f)))
(match input (match input
(((? string? name) (? package? package)) (((? string? name) (? package? package))
@ -643,20 +648,27 @@ information in exceptions."
(package package) (package package)
(input x))))))) (input x)))))))
(define %graft?
;; Whether to honor package grafts by default.
(make-parameter #t))
(define* (package->bag package #:optional (define* (package->bag package #:optional
(system (%current-system)) (system (%current-system))
(target (%current-target-system))) (target (%current-target-system))
#:key (graft? (%graft?)))
"Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET, "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
and return it." and return it."
;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked field ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked field
;; values can refer to it. ;; values can refer to it.
(parameterize ((%current-system system) (parameterize ((%current-system system)
(%current-target-system target)) (%current-target-system target))
(match package (match (if graft?
(or (package-replacement package) package)
package)
(($ <package> name version source build-system (($ <package> name version source build-system
args inputs propagated-inputs native-inputs self-native-input? args inputs propagated-inputs native-inputs self-native-input?
outputs) outputs)
(or (make-bag build-system (package-full-name package) (or (make-bag build-system (string-append name "-" version)
#:system system #:system system
#:target target #:target target
#:source source #:source source
@ -676,6 +688,77 @@ and return it."
(&package-error (&package-error
(package package)))))))))) (package package))))))))))
(define (input-graft store system)
"Return a procedure that, given an input referring to a package with a
graft, returns a pair with the original derivation and the graft's derivation,
and returns #f for other inputs."
(match-lambda
((label (? package? package) sub-drv ...)
(let ((replacement (package-replacement package)))
(and replacement
(let ((orig (package-derivation store package system
#:graft? #f))
(new (package-derivation store replacement system)))
(graft
(origin orig)
(replacement new)
(origin-output (match sub-drv
(() "out")
((output) output)))
(replacement-output origin-output))))))
(x
#f)))
(define (input-cross-graft store target system)
"Same as 'input-graft', but for cross-compilation inputs."
(match-lambda
((label (? package? package) sub-drv ...)
(let ((replacement (package-replacement package)))
(and replacement
(let ((orig (package-cross-derivation store package target system
#:graft? #f))
(new (package-cross-derivation store replacement
target system)))
(graft
(origin orig)
(replacement new)
(origin-output (match sub-drv
(() "out")
((output) output)))
(replacement-output origin-output))))))
(_
#f)))
(define* (bag-grafts store bag)
"Return the list of grafts applicable to BAG. Each graft is a <graft>
record."
(let ((target (bag-target bag))
(system (bag-system bag)))
(define native-grafts
(filter-map (input-graft store system)
(append (bag-transitive-build-inputs bag)
(bag-transitive-target-inputs bag)
(if target
'()
(bag-transitive-host-inputs bag)))))
(define target-grafts
(if target
(filter-map (input-cross-graft store target system)
(bag-transitive-host-inputs bag))
'()))
(append native-grafts target-grafts)))
(define* (package-grafts store package
#:optional (system (%current-system))
#:key target)
"Return the list of grafts applicable to PACKAGE as built for SYSTEM and
TARGET."
(let* ((package (or (package-replacement package) package))
(bag (package->bag package system target)))
(bag-grafts store bag)))
(define* (bag->derivation store bag (define* (bag->derivation store bag
#:optional context) #:optional context)
"Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be "Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
@ -743,23 +826,47 @@ This is an internal procedure."
(bag-arguments bag)))) (bag-arguments bag))))
(define* (package-derivation store package (define* (package-derivation store package
#:optional (system (%current-system))) #:optional (system (%current-system))
#:key (graft? (%graft?)))
"Return the <derivation> object of PACKAGE for SYSTEM." "Return the <derivation> object of 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.
(cached package system (cached package (cons system graft?)
(bag->derivation store (package->bag package system #f) (let* ((bag (package->bag package system #f #:graft? graft?))
package))) (drv (bag->derivation store bag package)))
(if graft?
(match (bag-grafts store bag)
(()
drv)
(grafts
(let ((guile (package-derivation store (default-guile)
system #:graft? #f)))
(graft-derivation store (bag-name bag) drv grafts
#:system system
#:guile guile))))
drv))))
(define* (package-cross-derivation store package target (define* (package-cross-derivation store package target
#:optional (system (%current-system))) #:optional (system (%current-system))
#:key (graft? (%graft?)))
"Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
system identifying string)." system identifying string)."
(cached package (cons system target) (cached package (list system target graft?)
(bag->derivation store (package->bag package system target) (let* ((bag (package->bag package system target #:graft? graft?))
package))) (drv (bag->derivation store bag package)))
(if graft?
(match (bag-grafts store bag)
(()
drv)
(grafts
(graft-derivation store (bag-name bag) drv grafts
#:system system
#:guile
(package-derivation store (default-guile)
system #:graft? #f))))
drv))))
(define* (package-output store package (define* (package-output store package
#:optional (output "out") (system (%current-system))) #:optional (output "out") (system (%current-system)))

47
guix/scripts/build.scm
View File

@ -202,6 +202,7 @@ options handled by 'set-build-options-from-command-line', and listed in
(define %default-options (define %default-options
;; Alist of default option values. ;; Alist of default option values.
`((system . ,(%current-system)) `((system . ,(%current-system))
(graft? . #t)
(substitutes? . #t) (substitutes? . #t)
(build-hook? . #t) (build-hook? . #t)
(print-build-trace? . #t) (print-build-trace? . #t)
@ -222,6 +223,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(display (_ " (display (_ "
--with-source=SOURCE --with-source=SOURCE
use SOURCE when building the corresponding package")) use SOURCE when building the corresponding package"))
(display (_ "
--no-grafts do not graft packages"))
(display (_ " (display (_ "
-d, --derivations return the derivation paths of the given packages")) -d, --derivations return the derivation paths of the given packages"))
(display (_ " (display (_ "
@ -278,6 +281,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(option '("with-source") #t #f (option '("with-source") #t #f
(lambda (opt name arg result) (lambda (opt name arg result)
(alist-cons 'with-source arg result))) (alist-cons 'with-source arg result)))
(option '("no-grafts") #f #f
(lambda (opt name arg result)
(alist-cons 'graft? #f
(alist-delete 'graft? result eq?))))
%standard-build-options)) %standard-build-options))
@ -290,26 +297,28 @@ build."
(triplet (triplet
(cut package-cross-derivation <> <> triplet <>)))) (cut package-cross-derivation <> <> triplet <>))))
(define src? (assoc-ref opts 'source?)) (define src? (assoc-ref opts 'source?))
(define sys (assoc-ref opts 'system)) (define sys (assoc-ref opts 'system))
(define graft? (assoc-ref opts 'graft?))
(let ((opts (options/with-source store (parameterize ((%graft? graft?))
(options/resolve-packages store opts)))) (let ((opts (options/with-source store
(filter-map (match-lambda (options/resolve-packages store opts))))
(('argument . (? package? p)) (filter-map (match-lambda
(if src? (('argument . (? package? p))
(let ((s (package-source p))) (if src?
(package-source-derivation store s)) (let ((s (package-source p)))
(package->derivation store p sys))) (package-source-derivation store s))
(('argument . (? derivation? drv)) (package->derivation store p sys)))
drv) (('argument . (? derivation? drv))
(('argument . (? derivation-path? drv)) drv)
(call-with-input-file drv read-derivation)) (('argument . (? derivation-path? drv))
(('argument . (? store-path?)) (call-with-input-file drv read-derivation))
;; Nothing to do; maybe for --log-file. (('argument . (? store-path?))
#f) ;; Nothing to do; maybe for --log-file.
(_ #f)) #f)
opts))) (_ #f))
opts))))
(define (options/resolve-packages store opts) (define (options/resolve-packages store opts)
"Return OPTS with package specification strings replaced by actual "Return OPTS with package specification strings replaced by actual

105
tests/packages.scm
View File

@ -33,8 +33,9 @@
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module (gnu packages base) #:use-module (gnu packages base)
#:use-module (gnu packages guile)
#:use-module (gnu packages bootstrap) #:use-module (gnu packages bootstrap)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-64) #:use-module (srfi srfi-64)
@ -47,10 +48,6 @@
(define %store (define %store
(open-connection-for-tests)) (open-connection-for-tests))
(test-begin "packages")
(define-syntax-rule (dummy-package name* extra-fields ...) (define-syntax-rule (dummy-package name* extra-fields ...)
(package (name name*) (version "0") (source #f) (package (name name*) (version "0") (source #f)
(build-system gnu-build-system) (build-system gnu-build-system)
@ -58,6 +55,9 @@
(home-page #f) (license #f) (home-page #f) (license #f)
extra-fields ...)) extra-fields ...))
(test-begin "packages")
(test-assert "printer with location" (test-assert "printer with location"
(string-match "^#<package foo-0 foo.scm:42 [[:xdigit:]]+>$" (string-match "^#<package foo-0 foo.scm:42 [[:xdigit:]]+>$"
(with-output-to-string (with-output-to-string
@ -375,6 +375,80 @@
(package-cross-derivation %store p "mips64el-linux-gnu") (package-cross-derivation %store p "mips64el-linux-gnu")
#f))) #f)))
(test-equal "package-derivation, direct graft"
(package-derivation %store gnu-make)
(let ((p (package (inherit coreutils)
(replacement gnu-make))))
(package-derivation %store p)))
(test-equal "package-cross-derivation, direct graft"
(package-cross-derivation %store gnu-make "mips64el-linux-gnu")
(let ((p (package (inherit coreutils)
(replacement gnu-make))))
(package-cross-derivation %store p "mips64el-linux-gnu")))
(test-assert "package-grafts, indirect grafts"
(let* ((new (dummy-package "dep"
(arguments '(#:implicit-inputs? #f))))
(dep (package (inherit new) (version "0.0")))
(dep* (package (inherit dep) (replacement new)))
(dummy (dummy-package "dummy"
(arguments '(#:implicit-inputs? #f))
(inputs `(("dep" ,dep*))))))
(equal? (package-grafts %store dummy)
(list (graft
(origin (package-derivation %store dep))
(replacement (package-derivation %store new)))))))
(test-assert "package-grafts, indirect grafts, cross"
(let* ((new (dummy-package "dep"
(arguments '(#:implicit-inputs? #f))))
(dep (package (inherit new) (version "0.0")))
(dep* (package (inherit dep) (replacement new)))
(dummy (dummy-package "dummy"
(arguments '(#:implicit-inputs? #f))
(inputs `(("dep" ,dep*)))))
(target "mips64el-linux-gnu"))
(equal? (package-grafts %store dummy #:target target)
(list (graft
(origin (package-cross-derivation %store dep target))
(replacement
(package-cross-derivation %store new target)))))))
(test-assert "package-grafts, indirect grafts, propagated inputs"
(let* ((new (dummy-package "dep"
(arguments '(#:implicit-inputs? #f))))
(dep (package (inherit new) (version "0.0")))
(dep* (package (inherit dep) (replacement new)))
(prop (dummy-package "propagated"
(propagated-inputs `(("dep" ,dep*)))
(arguments '(#:implicit-inputs? #f))))
(dummy (dummy-package "dummy"
(arguments '(#:implicit-inputs? #f))
(inputs `(("prop" ,prop))))))
(equal? (package-grafts %store dummy)
(list (graft
(origin (package-derivation %store dep))
(replacement (package-derivation %store new)))))))
(test-assert "package-derivation, indirect grafts"
(let* ((new (dummy-package "dep"
(arguments '(#:implicit-inputs? #f))))
(dep (package (inherit new) (version "0.0")))
(dep* (package (inherit dep) (replacement new)))
(dummy (dummy-package "dummy"
(arguments '(#:implicit-inputs? #f))
(inputs `(("dep" ,dep*)))))
(guile (package-derivation %store (canonical-package guile-2.0)
#:graft? #f)))
(equal? (package-derivation %store dummy)
(graft-derivation %store "dummy-0"
(package-derivation %store dummy #:graft? #f)
(package-grafts %store dummy)
;; Use the same Guile as 'package-derivation'.
#:guile guile))))
(test-equal "package->bag" (test-equal "package->bag"
`("foo86-hurd" #f (,(package-source gnu-make)) `("foo86-hurd" #f (,(package-source gnu-make))
(,(canonical-package glibc)) (,(canonical-package coreutils))) (,(canonical-package glibc)) (,(canonical-package coreutils)))
@ -406,17 +480,20 @@
(eq? package dep))))) (eq? package dep)))))
(test-assert "bag->derivation" (test-assert "bag->derivation"
(let ((bag (package->bag gnu-make)) (parameterize ((%graft? #f))
(drv (package-derivation %store gnu-make))) (let ((bag (package->bag gnu-make))
(parameterize ((%current-system "foox86-hurd")) ;should have no effect (drv (package-derivation %store gnu-make)))
(equal? drv (bag->derivation %store bag))))) (parameterize ((%current-system "foox86-hurd")) ;should have no effect
(equal? drv (bag->derivation %store bag))))))
(test-assert "bag->derivation, cross-compilation" (test-assert "bag->derivation, cross-compilation"
(let ((bag (package->bag gnu-make (%current-system) "mips64el-linux-gnu")) (parameterize ((%graft? #f))
(drv (package-cross-derivation %store gnu-make "mips64el-linux-gnu"))) (let* ((target "mips64el-linux-gnu")
(parameterize ((%current-system "foox86-hurd") ;should have no effect (bag (package->bag gnu-make (%current-system) target))
(%current-target-system "foo64-linux-gnu")) (drv (package-cross-derivation %store gnu-make target)))
(equal? drv (bag->derivation %store bag))))) (parameterize ((%current-system "foox86-hurd") ;should have no effect
(%current-target-system "foo64-linux-gnu"))
(equal? drv (bag->derivation %store bag))))))
(unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)) (unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))
(test-skip 1)) (test-skip 1))