diff options
| -rw-r--r-- | doc/guix.texi | 63 | ||||
| -rw-r--r-- | gnu/packages/bootstrap.scm | 4 | ||||
| -rw-r--r-- | guix/build-system/cmake.scm | 4 | ||||
| -rw-r--r-- | guix/build-system/glib-or-gtk.scm | 4 | ||||
| -rw-r--r-- | guix/build-system/gnu.scm | 30 | ||||
| -rw-r--r-- | guix/build-system/perl.scm | 4 | ||||
| -rw-r--r-- | guix/build-system/python.scm | 4 | ||||
| -rw-r--r-- | guix/build-system/ruby.scm | 4 | ||||
| -rw-r--r-- | guix/build-system/trivial.scm | 4 | ||||
| -rw-r--r-- | guix/packages.scm | 147 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 47 | ||||
| -rw-r--r-- | tests/packages.scm | 105 |
12 files changed, 347 insertions, 73 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index d3ab9676ee..fbf5bac9b4 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -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 diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm index e617093fb3..33b61aa0be 100644 --- a/gnu/packages/bootstrap.scm +++ b/gnu/packages/bootstrap.scm @@ -146,7 +146,9 @@ check whether everything is alright." (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) diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index 85acc2d0b3..0425e9fb39 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -125,11 +125,11 @@ provides a 'CMakeLists.txt' file as its build system." (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 diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm index 078d5f6e8a..51e0c419e3 100644 --- a/guix/build-system/glib-or-gtk.scm +++ b/guix/build-system/glib-or-gtk.scm @@ -168,11 +168,11 @@ (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 diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 3cb9f6ae94..c675155a6a 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -91,6 +91,13 @@ builder, or the distro's final Guile when GUILE is #f." `(#: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 @@ flags for VARIABLE, the associated value is augmented." (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 @@ use `--strip-all' as the arguments to `strip'." ((#: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 @@ are allowed to refer to." (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 @@ are allowed to refer to." (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 @@ platform." (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 diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 1a968f4150..c488adb500 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -114,11 +114,11 @@ provides a `Makefile.PL' file as its build system." (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 diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index 3cd537c752..78348e9cf7 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -160,11 +160,11 @@ provides a 'setup.py' file as its build system." (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 diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm index e4e115f657..d2dd6a48cc 100644 --- a/guix/build-system/ruby.scm +++ b/guix/build-system/ruby.scm @@ -99,11 +99,11 @@ (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 diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm index 07adbe75fa..350b1df553 100644 --- a/guix/build-system/trivial.scm +++ b/guix/build-system/trivial.scm @@ -28,11 +28,11 @@ (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 diff --git a/guix/packages.scm b/guix/packages.scm index 97a82a4682..698a4c8097 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -26,6 +26,7 @@ #: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 @@ package-outputs package-native-search-paths package-search-paths + package-replacement package-synopsis package-description package-license @@ -85,6 +87,7 @@ package-derivation package-cross-derivation package-output + package-grafts %supported-systems @@ -97,6 +100,7 @@ &package-cross-build-system-error package-cross-build-system-error? + %graft? package->bag bag->derivation bag-transitive-inputs @@ -211,6 +215,8 @@ corresponds to the arguments expected by `set-path-environment-variable'." ; 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 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET." (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 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET." ;; 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 @@ information in exceptions." (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 @@ information in exceptions." (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 @@ and return it." (&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 @@ This is an internal procedure." (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))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index cde2a25613..7b7f419f3a 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -202,6 +202,7 @@ options handled by 'set-build-options-from-command-line', and listed in (define %default-options ;; Alist of default option values. `((system . ,(%current-system)) + (graft? . #t) (substitutes? . #t) (build-hook? . #t) (print-build-trace? . #t) @@ -223,6 +224,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) --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 (_ " -r, --root=FILE make FILE a symlink to the result, and register it @@ -278,6 +281,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (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 @@ build." (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 diff --git a/tests/packages.scm b/tests/packages.scm index 44cdb35c4b..4f700b712f 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -33,8 +33,9 @@ #: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 %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 @@ (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 @@ (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 @@ (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)) |