mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
packages: Implement grafts.
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
parent
50373bab7a
commit
05962f2958
12 changed files with 347 additions and 73 deletions
|
|
@ -2569,6 +2569,10 @@ candidates:
|
|||
guix build guile --with-source=../guile-2.0.9.219-e1bb7.tar.xz
|
||||
@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
|
||||
@itemx -d
|
||||
|
|
@ -3003,6 +3007,7 @@ For information on porting to other architectures or kernels,
|
|||
* System Installation:: Installing the whole operating system.
|
||||
* System Configuration:: Configuring a GNU system.
|
||||
* Installing Debugging Files:: Feeding the debugger.
|
||||
* Security Updates:: Deploying security fixes quickly.
|
||||
* Package Modules:: Packages from the programmer's viewpoint.
|
||||
* Packaging Guidelines:: Growing the distribution.
|
||||
* 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}).
|
||||
|
||||
|
||||
@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
|
||||
@section Package Modules
|
||||
|
||||
|
|
|
|||
|
|
@ -146,7 +146,9 @@ (define rewritten-input
|
|||
(native-inputs (map rewritten-input
|
||||
(package-native-inputs p)))
|
||||
(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
|
||||
#:optional (system (or (and=> (%current-target-system)
|
||||
|
|
|
|||
|
|
@ -125,11 +125,11 @@ (define builder
|
|||
(define guile-for-build
|
||||
(match guile
|
||||
((? package?)
|
||||
(package-derivation store guile system))
|
||||
(package-derivation store guile system #:graft? #f))
|
||||
(#f ; the default
|
||||
(let* ((distro (resolve-interface '(gnu packages commencement)))
|
||||
(guile (module-ref distro 'guile-final)))
|
||||
(package-derivation store guile system)))))
|
||||
(package-derivation store guile system #:graft? #f)))))
|
||||
|
||||
(build-expression->derivation store name builder
|
||||
#:system system
|
||||
|
|
|
|||
|
|
@ -168,11 +168,11 @@ (define builder
|
|||
(define guile-for-build
|
||||
(match guile
|
||||
((? package?)
|
||||
(package-derivation store guile system))
|
||||
(package-derivation store guile system #:graft? #f))
|
||||
(#f ; the default
|
||||
(let* ((distro (resolve-interface '(gnu packages commencement)))
|
||||
(guile (module-ref distro 'guile-final)))
|
||||
(package-derivation store guile system)))))
|
||||
(package-derivation store guile system #:graft? #f)))))
|
||||
|
||||
(build-expression->derivation store name builder
|
||||
#:system system
|
||||
|
|
|
|||
|
|
@ -91,6 +91,13 @@ (define rewritten-input
|
|||
`(#:guile ,guile
|
||||
#:implicit-inputs? #f
|
||||
,@args)))
|
||||
(replacement
|
||||
(let ((replacement (package-replacement p)))
|
||||
(and replacement
|
||||
(package-with-explicit-inputs replacement inputs loc
|
||||
#:native-inputs
|
||||
native-inputs
|
||||
#:guile guile))))
|
||||
(native-inputs
|
||||
(let ((filtered (duplicate-filter native-inputs*)))
|
||||
`(,@(call native-inputs*)
|
||||
|
|
@ -132,6 +139,11 @@ (define (rewritten-inputs inputs)
|
|||
(substring flag ,len))
|
||||
flag))
|
||||
,flags)))))))
|
||||
(replacement
|
||||
(let ((replacement (package-replacement p)))
|
||||
(and replacement
|
||||
(package-with-extra-configure-variable replacement
|
||||
variable value))))
|
||||
(inputs (rewritten-inputs (package-inputs p)))
|
||||
(propagated-inputs (rewritten-inputs (package-propagated-inputs p))))))
|
||||
|
||||
|
|
@ -155,7 +167,8 @@ (define* (static-package p #:optional (loc (current-source-location))
|
|||
((#:strip-flags flags)
|
||||
(if strip-all?
|
||||
''("--strip-all")
|
||||
flags)))))))
|
||||
flags)))))
|
||||
(replacement (and=> (package-replacement p) static-package))))
|
||||
|
||||
(define* (dist-package p source)
|
||||
"Return a package that runs takes source files from the SOURCE directory,
|
||||
|
|
@ -290,9 +303,11 @@ (define* (gnu-build store name input-drvs
|
|||
(define canonicalize-reference
|
||||
(match-lambda
|
||||
((? package? p)
|
||||
(derivation->output-path (package-derivation store p system)))
|
||||
(derivation->output-path (package-derivation store p system
|
||||
#:graft? #f)))
|
||||
(((? package? p) output)
|
||||
(derivation->output-path (package-derivation store p system)
|
||||
(derivation->output-path (package-derivation store p system
|
||||
#:graft? #f)
|
||||
output))
|
||||
((? string? output)
|
||||
output)))
|
||||
|
|
@ -328,11 +343,12 @@ (define builder
|
|||
(define guile-for-build
|
||||
(match guile
|
||||
((? package?)
|
||||
(package-derivation store guile system))
|
||||
(package-derivation store guile system #:graft? #f))
|
||||
(#f ; the default
|
||||
(let* ((distro (resolve-interface '(gnu packages commencement)))
|
||||
(guile (module-ref distro 'guile-final)))
|
||||
(package-derivation store guile system)))))
|
||||
(package-derivation store guile system
|
||||
#:graft? #f)))))
|
||||
|
||||
(build-expression->derivation store name builder
|
||||
#:system system
|
||||
|
|
@ -472,11 +488,11 @@ (define %build-target-inputs
|
|||
(define guile-for-build
|
||||
(match guile
|
||||
((? package?)
|
||||
(package-derivation store guile system))
|
||||
(package-derivation store guile system #:graft? #f))
|
||||
(#f ; the default
|
||||
(let* ((distro (resolve-interface '(gnu packages commencement)))
|
||||
(guile (module-ref distro 'guile-final)))
|
||||
(package-derivation store guile system)))))
|
||||
(package-derivation store guile system #:graft? #f)))))
|
||||
|
||||
(build-expression->derivation store name builder
|
||||
#:system system
|
||||
|
|
|
|||
|
|
@ -114,11 +114,11 @@ (define builder
|
|||
(define guile-for-build
|
||||
(match guile
|
||||
((? package?)
|
||||
(package-derivation store guile system))
|
||||
(package-derivation store guile system #:graft? #f))
|
||||
(#f ; the default
|
||||
(let* ((distro (resolve-interface '(gnu packages commencement)))
|
||||
(guile (module-ref distro 'guile-final)))
|
||||
(package-derivation store guile system)))))
|
||||
(package-derivation store guile system #:graft? #f)))))
|
||||
|
||||
(build-expression->derivation store name builder
|
||||
#:system system
|
||||
|
|
|
|||
|
|
@ -160,11 +160,11 @@ (define builder
|
|||
(define guile-for-build
|
||||
(match guile
|
||||
((? package?)
|
||||
(package-derivation store guile system))
|
||||
(package-derivation store guile system #:graft? #f))
|
||||
(#f ; the default
|
||||
(let* ((distro (resolve-interface '(gnu packages commencement)))
|
||||
(guile (module-ref distro 'guile-final)))
|
||||
(package-derivation store guile system)))))
|
||||
(package-derivation store guile system #:graft? #f)))))
|
||||
|
||||
(build-expression->derivation store name builder
|
||||
#:inputs inputs
|
||||
|
|
|
|||
|
|
@ -99,11 +99,11 @@ (define builder
|
|||
(define guile-for-build
|
||||
(match guile
|
||||
((? package?)
|
||||
(package-derivation store guile system))
|
||||
(package-derivation store guile system #:graft? #f))
|
||||
(#f
|
||||
(let* ((distro (resolve-interface '(gnu packages commencement)))
|
||||
(guile (module-ref distro 'guile-final)))
|
||||
(package-derivation store guile system)))))
|
||||
(package-derivation store guile system #:graft? #f)))))
|
||||
|
||||
(build-expression->derivation store name builder
|
||||
#:inputs inputs
|
||||
|
|
|
|||
|
|
@ -28,11 +28,11 @@ (define-module (guix build-system trivial)
|
|||
(define (guile-for-build store guile system)
|
||||
(match guile
|
||||
((? package?)
|
||||
(package-derivation store guile system))
|
||||
(package-derivation store guile system #:graft? #f))
|
||||
(#f ; the default
|
||||
(let* ((distro (resolve-interface '(gnu packages commencement)))
|
||||
(guile (module-ref distro 'guile-final)))
|
||||
(package-derivation store guile system)))))
|
||||
(package-derivation store guile system #:graft? #f)))))
|
||||
|
||||
(define* (lower name
|
||||
#:key source inputs native-inputs outputs system target
|
||||
|
|
|
|||
|
|
@ -26,6 +26,7 @@ (define-module (guix packages)
|
|||
#: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)
|
||||
|
|
@ -65,6 +66,7 @@ (define-module (guix packages)
|
|||
package-outputs
|
||||
package-native-search-paths
|
||||
package-search-paths
|
||||
package-replacement
|
||||
package-synopsis
|
||||
package-description
|
||||
package-license
|
||||
|
|
@ -85,6 +87,7 @@ (define-module (guix packages)
|
|||
package-derivation
|
||||
package-cross-derivation
|
||||
package-output
|
||||
package-grafts
|
||||
|
||||
%supported-systems
|
||||
|
||||
|
|
@ -97,6 +100,7 @@ (define-module (guix packages)
|
|||
&package-cross-build-system-error
|
||||
package-cross-build-system-error?
|
||||
|
||||
%graft?
|
||||
package->bag
|
||||
bag->derivation
|
||||
bag-transitive-inputs
|
||||
|
|
@ -211,6 +215,8 @@ (define-record-type* <package>
|
|||
; inputs
|
||||
(native-search-paths package-native-search-paths (default '()))
|
||||
(search-paths package-search-paths (default '()))
|
||||
(replacement package-replacement ; package | #f
|
||||
(default #f) (thunked))
|
||||
|
||||
(synopsis package-synopsis) ; one-line description
|
||||
(description package-description) ; one or two paragraphs
|
||||
|
|
@ -445,8 +451,8 @@ (define (first-file directory)
|
|||
(and (member name (cons decompression-type
|
||||
'("tar" "xz" "patch")))
|
||||
(list name
|
||||
(package-derivation store p
|
||||
system)))))
|
||||
(package-derivation store p system
|
||||
#:graft? #f)))))
|
||||
(or inputs (%standard-patch-inputs))))
|
||||
(modules (delete-duplicates (cons '(guix build utils) modules))))
|
||||
|
||||
|
|
@ -472,12 +478,10 @@ (define* (package-source-derivation store source
|
|||
;; Patches and/or a snippet.
|
||||
(let ((source (method store uri 'sha256 sha256 name
|
||||
#:system system))
|
||||
(guile (match (or guile-for-build (%guile-for-build)
|
||||
(default-guile))
|
||||
(guile (match (or guile-for-build (default-guile))
|
||||
((? package? p)
|
||||
(package-derivation store p system))
|
||||
((? derivation? drv)
|
||||
drv))))
|
||||
(package-derivation store p system
|
||||
#:graft? #f)))))
|
||||
(patch-and-repack store source patches
|
||||
#:inputs inputs
|
||||
#:snippet snippet
|
||||
|
|
@ -617,8 +621,9 @@ (define (intern file)
|
|||
|
||||
(define derivation
|
||||
(if cross-system
|
||||
(cut package-cross-derivation store <> cross-system system)
|
||||
(cut package-derivation store <> system)))
|
||||
(cut package-cross-derivation store <> cross-system system
|
||||
#:graft? #f)
|
||||
(cut package-derivation store <> system #:graft? #f)))
|
||||
|
||||
(match input
|
||||
(((? string? name) (? package? package))
|
||||
|
|
@ -643,20 +648,27 @@ (define derivation
|
|||
(package package)
|
||||
(input x)))))))
|
||||
|
||||
(define %graft?
|
||||
;; Whether to honor package grafts by default.
|
||||
(make-parameter #t))
|
||||
|
||||
(define* (package->bag package #:optional
|
||||
(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,
|
||||
and return it."
|
||||
;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked field
|
||||
;; values can refer to it.
|
||||
(parameterize ((%current-system system)
|
||||
(%current-target-system target))
|
||||
(match package
|
||||
(match (if graft?
|
||||
(or (package-replacement package) package)
|
||||
package)
|
||||
(($ <package> name version source build-system
|
||||
args inputs propagated-inputs native-inputs self-native-input?
|
||||
outputs)
|
||||
(or (make-bag build-system (package-full-name package)
|
||||
(or (make-bag build-system (string-append name "-" version)
|
||||
#:system system
|
||||
#:target target
|
||||
#:source source
|
||||
|
|
@ -676,6 +688,77 @@ (define* (package->bag package #:optional
|
|||
(&package-error
|
||||
(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
|
||||
#:optional context)
|
||||
"Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
|
||||
|
|
@ -743,23 +826,47 @@ (define* (bag->cross-derivation store bag
|
|||
(bag-arguments bag))))
|
||||
|
||||
(define* (package-derivation store package
|
||||
#:optional (system (%current-system)))
|
||||
#:optional (system (%current-system))
|
||||
#:key (graft? (%graft?)))
|
||||
"Return the <derivation> 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.
|
||||
(cached package system
|
||||
(bag->derivation store (package->bag package system #f)
|
||||
package)))
|
||||
(cached package (cons system graft?)
|
||||
(let* ((bag (package->bag package system #f #:graft? graft?))
|
||||
(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
|
||||
#:optional (system (%current-system)))
|
||||
#:optional (system (%current-system))
|
||||
#:key (graft? (%graft?)))
|
||||
"Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
|
||||
system identifying string)."
|
||||
(cached package (cons system target)
|
||||
(bag->derivation store (package->bag package system target)
|
||||
package)))
|
||||
(cached package (list system target graft?)
|
||||
(let* ((bag (package->bag package system target #:graft? graft?))
|
||||
(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
|
||||
#:optional (output "out") (system (%current-system)))
|
||||
|
|
|
|||
|
|
@ -202,6 +202,7 @@ (define %standard-build-options
|
|||
(define %default-options
|
||||
;; Alist of default option values.
|
||||
`((system . ,(%current-system))
|
||||
(graft? . #t)
|
||||
(substitutes? . #t)
|
||||
(build-hook? . #t)
|
||||
(print-build-trace? . #t)
|
||||
|
|
@ -222,6 +223,8 @@ (define (show-help)
|
|||
(display (_ "
|
||||
--with-source=SOURCE
|
||||
use SOURCE when building the corresponding package"))
|
||||
(display (_ "
|
||||
--no-grafts do not graft packages"))
|
||||
(display (_ "
|
||||
-d, --derivations return the derivation paths of the given packages"))
|
||||
(display (_ "
|
||||
|
|
@ -278,6 +281,10 @@ (define %options
|
|||
(option '("with-source") #t #f
|
||||
(lambda (opt name 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))
|
||||
|
||||
|
|
@ -290,26 +297,28 @@ (define package->derivation
|
|||
(triplet
|
||||
(cut package-cross-derivation <> <> triplet <>))))
|
||||
|
||||
(define src? (assoc-ref opts 'source?))
|
||||
(define sys (assoc-ref opts 'system))
|
||||
(define src? (assoc-ref opts 'source?))
|
||||
(define sys (assoc-ref opts 'system))
|
||||
(define graft? (assoc-ref opts 'graft?))
|
||||
|
||||
(let ((opts (options/with-source store
|
||||
(options/resolve-packages store opts))))
|
||||
(filter-map (match-lambda
|
||||
(('argument . (? package? p))
|
||||
(if src?
|
||||
(let ((s (package-source p)))
|
||||
(package-source-derivation store s))
|
||||
(package->derivation store p sys)))
|
||||
(('argument . (? derivation? drv))
|
||||
drv)
|
||||
(('argument . (? derivation-path? drv))
|
||||
(call-with-input-file drv read-derivation))
|
||||
(('argument . (? store-path?))
|
||||
;; Nothing to do; maybe for --log-file.
|
||||
#f)
|
||||
(_ #f))
|
||||
opts)))
|
||||
(parameterize ((%graft? graft?))
|
||||
(let ((opts (options/with-source store
|
||||
(options/resolve-packages store opts))))
|
||||
(filter-map (match-lambda
|
||||
(('argument . (? package? p))
|
||||
(if src?
|
||||
(let ((s (package-source p)))
|
||||
(package-source-derivation store s))
|
||||
(package->derivation store p sys)))
|
||||
(('argument . (? derivation? drv))
|
||||
drv)
|
||||
(('argument . (? derivation-path? drv))
|
||||
(call-with-input-file drv read-derivation))
|
||||
(('argument . (? store-path?))
|
||||
;; Nothing to do; maybe for --log-file.
|
||||
#f)
|
||||
(_ #f))
|
||||
opts))))
|
||||
|
||||
(define (options/resolve-packages store opts)
|
||||
"Return OPTS with package specification strings replaced by actual
|
||||
|
|
|
|||
|
|
@ -33,8 +33,9 @@ (define-module (test-packages)
|
|||
#:use-module (guix build-system gnu)
|
||||
#:use-module (gnu packages)
|
||||
#:use-module (gnu packages base)
|
||||
#:use-module (gnu packages guile)
|
||||
#:use-module (gnu packages bootstrap)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-64)
|
||||
|
|
@ -47,10 +48,6 @@ (define-module (test-packages)
|
|||
(define %store
|
||||
(open-connection-for-tests))
|
||||
|
||||
|
||||
|
||||
(test-begin "packages")
|
||||
|
||||
(define-syntax-rule (dummy-package name* extra-fields ...)
|
||||
(package (name name*) (version "0") (source #f)
|
||||
(build-system gnu-build-system)
|
||||
|
|
@ -58,6 +55,9 @@ (define-syntax-rule (dummy-package name* extra-fields ...)
|
|||
(home-page #f) (license #f)
|
||||
extra-fields ...))
|
||||
|
||||
|
||||
(test-begin "packages")
|
||||
|
||||
(test-assert "printer with location"
|
||||
(string-match "^#<package foo-0 foo.scm:42 [[:xdigit:]]+>$"
|
||||
(with-output-to-string
|
||||
|
|
@ -375,6 +375,80 @@ (define read-at
|
|||
(package-cross-derivation %store p "mips64el-linux-gnu")
|
||||
#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"
|
||||
`("foo86-hurd" #f (,(package-source gnu-make))
|
||||
(,(canonical-package glibc)) (,(canonical-package coreutils)))
|
||||
|
|
@ -406,17 +480,20 @@ (define read-at
|
|||
(eq? package dep)))))
|
||||
|
||||
(test-assert "bag->derivation"
|
||||
(let ((bag (package->bag gnu-make))
|
||||
(drv (package-derivation %store gnu-make)))
|
||||
(parameterize ((%current-system "foox86-hurd")) ;should have no effect
|
||||
(equal? drv (bag->derivation %store bag)))))
|
||||
(parameterize ((%graft? #f))
|
||||
(let ((bag (package->bag gnu-make))
|
||||
(drv (package-derivation %store gnu-make)))
|
||||
(parameterize ((%current-system "foox86-hurd")) ;should have no effect
|
||||
(equal? drv (bag->derivation %store bag))))))
|
||||
|
||||
(test-assert "bag->derivation, cross-compilation"
|
||||
(let ((bag (package->bag gnu-make (%current-system) "mips64el-linux-gnu"))
|
||||
(drv (package-cross-derivation %store gnu-make "mips64el-linux-gnu")))
|
||||
(parameterize ((%current-system "foox86-hurd") ;should have no effect
|
||||
(%current-target-system "foo64-linux-gnu"))
|
||||
(equal? drv (bag->derivation %store bag)))))
|
||||
(parameterize ((%graft? #f))
|
||||
(let* ((target "mips64el-linux-gnu")
|
||||
(bag (package->bag gnu-make (%current-system) target))
|
||||
(drv (package-cross-derivation %store gnu-make target)))
|
||||
(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))
|
||||
(test-skip 1))
|
||||
|
|
|
|||
Loading…
Reference in a new issue