grafts: Graft recursively.

Fixes <http://bugs.gnu.org/22139>.

* guix/grafts.scm (graft-derivation): Rename to...
(graft-derivation/shallow): ... this.
(graft-origin-file-name, item->deriver, non-self-references)
(cumulative-grafts, graft-derivation): New procedures
* tests/grafts.scm ("graft-derivation, grafted item is a direct
dependency"): Clarify title.  Use 'grafted' instead of 'graft' to refer
to the grafted derivation.
("graft-derivation, grafted item is an indirect dependency")
("graft-derivation, no dependencies on grafted output"): New tests.
* guix/packages.scm (input-graft): Change to take a package instead of
an input.
(input-cross-graft): Likewise.
(fold-bag-dependencies): New procedure.
(bag-grafts): Rewrite in terms of 'fold-bag-dependencies'.
* tests/packages.scm ("package-derivation, indirect grafts"): Comment out.
* doc/guix.texi (Security Updates): Mention run-time dependencies and
recursive grafting.
This commit is contained in:
Ludovic Courtès 2016-02-27 23:06:50 +01:00
parent d06fc008bd
commit c22a1324e6
6 changed files with 287 additions and 82 deletions

View file

@ -10244,11 +10244,14 @@ Packages}). Then, the original package definition is augmented with a
(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
From there on, any package depending directly or indirectly on Bash---as
reported by @command{guix gc --requisites} (@pxref{Invoking guix
gc})---that is installed is automatically ``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.
minute for an ``average'' package on a recent machine. Grafting is
recursive: when an indirect dependency requires grafting, then grafting
``propagates'' up to the package that the user is installing.
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}

View file

@ -17,11 +17,14 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix grafts)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix derivations)
#:use-module ((guix utils) #:select (%current-system))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (graft?
@ -32,6 +35,7 @@ (define-module (guix grafts)
graft-replacement-output
graft-derivation
graft-derivation/shallow
%graft?
set-grafting))
@ -61,13 +65,22 @@ (define (->string thing output)
(set-record-type-printer! <graft> write-graft)
(define* (graft-derivation store drv grafts
#:key
(name (derivation-name drv))
(guile (%guile-for-build))
(system (%current-system)))
(define (graft-origin-file-name graft)
"Return the output file name of the origin of GRAFT."
(match graft
(($ <graft> (? derivation? origin) output)
(derivation->output-path origin output))
(($ <graft> (? string? item))
item)))
(define* (graft-derivation/shallow store drv grafts
#:key
(name (derivation-name drv))
(guile (%guile-for-build))
(system (%current-system)))
"Return a derivation called NAME, based on DRV but with all the GRAFTS
applied."
applied. This procedure performs \"shallow\" grafting in that GRAFTS are not
recursively applied to dependencies of DRV."
;; XXX: Someday rewrite using gexps.
(define mapping
;; List of store item pairs.
@ -133,6 +146,85 @@ (define add-label
(map add-label targets)))
#:outputs output-names
#:local-build? #t)))))
(define (item->deriver store item)
"Return two values: the derivation that led to ITEM (a store item), and the
name of the output of that derivation ITEM corresponds to (for example
\"out\"). When ITEM has no deriver, for instance because it is a plain file,
#f and #f are returned."
(match (valid-derivers store item)
(() ;ITEM is a plain file
(values #f #f))
((drv-file _ ...)
(let ((drv (call-with-input-file drv-file read-derivation)))
(values drv
(any (match-lambda
((name . path)
(and (string=? item path) name)))
(derivation->output-paths drv)))))))
(define (non-self-references store drv outputs)
"Return the list of references of the OUTPUTS of DRV, excluding self
references."
(let ((refs (append-map (lambda (output)
(references store
(derivation->output-path drv output)))
outputs))
(self (match (derivation->output-paths drv)
(((names . items) ...)
items))))
(remove (cut member <> self) refs)))
(define* (cumulative-grafts store drv grafts
#:key
(outputs (derivation-output-names drv))
(guile (%guile-for-build))
(system (%current-system)))
"Augment GRAFTS with additional grafts resulting from the application of
GRAFTS to the dependencies of DRV. Return the resulting list of grafts."
(define (dependency-grafts item)
(let-values (((drv output) (item->deriver store item)))
(if drv
(cumulative-grafts store drv grafts
#:outputs (list output)
#:guile guile
#:system system)
grafts)))
;; TODO: Memoize.
(match (non-self-references store drv outputs)
(() ;no dependencies
grafts)
(deps ;one or more dependencies
(let* ((grafts (delete-duplicates (append-map dependency-grafts deps)
eq?))
(origins (map graft-origin-file-name grafts)))
(if (find (cut member <> deps) origins)
(let ((new (graft-derivation/shallow store drv grafts
#:guile guile
#:system system)))
(cons (graft (origin drv) (replacement new))
grafts))
grafts)))))
(define* (graft-derivation store drv grafts
#:key (guile (%guile-for-build))
(system (%current-system)))
"Applied GRAFTS to DRV and all its dependencies, recursively. That is, if
GRAFTS apply only indirectly to DRV, graft the dependencies of DRV, and graft
DRV itself to refer to those grafted dependencies."
;; First, we need to build the ungrafted DRV so we can query its run-time
;; dependencies in 'cumulative-grafts'.
(build-derivations store (list drv))
(match (cumulative-grafts store drv grafts
#:guile guile #:system system)
((first . rest)
;; If FIRST is not a graft for DRV, it means that GRAFTS are not
;; applicable to DRV and nothing needs to be done.
(if (equal? drv (graft-origin first))
(graft-replacement first)
drv))))
;; The following might feel more at home in (guix packages) but since (guix

View file

@ -30,6 +30,7 @@ (define-module (guix packages)
#:use-module (guix build-system)
#:use-module (guix search-paths)
#:use-module (guix gexp)
#:use-module (guix sets)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
@ -831,30 +832,25 @@ (define* (package->bag package #:optional
(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."
"Return a procedure that, given a package with a graft, returns a graft, and
#f otherwise."
(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)))
((? package? package)
(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))))))
(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 ...)
((? package? package)
(let ((replacement (package-replacement package)))
(and replacement
(let ((orig (package-cross-derivation store package target system
@ -863,34 +859,75 @@ (define (input-cross-graft store target system)
target system)))
(graft
(origin orig)
(replacement new)
(origin-output (match sub-drv
(() "out")
((output) output)))
(replacement-output origin-output))))))
(replacement new))))))
(_
#f)))
(define* (fold-bag-dependencies proc seed bag
#:key (native? #t))
"Fold PROC over the packages BAG depends on. Each package is visited only
once, in depth-first order. If NATIVE? is true, restrict to native
dependencies; otherwise, restrict to target dependencies."
(define nodes
(match (if native?
(append (bag-build-inputs bag)
(bag-target-inputs bag)
(if (bag-target bag)
'()
(bag-host-inputs bag)))
(bag-host-inputs bag))
(((labels things _ ...) ...)
things)))
(let loop ((nodes nodes)
(result seed)
(visited (setq)))
(match nodes
(()
result)
(((? package? head) . tail)
(if (set-contains? visited head)
(loop tail result visited)
(let ((inputs (bag-direct-inputs (package->bag head))))
(loop (match inputs
(((labels things _ ...) ...)
(append things tail)))
(proc head result)
(set-insert head visited)))))
((head . tail)
(loop tail result visited)))))
(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)))))
"Return the list of grafts potentially applicable to BAG. Potentially
applicable grafts are collected by looking at direct or indirect dependencies
of BAG that have a 'replacement'. Whether a graft is actually applicable
depends on whether the outputs of BAG depend on the items the grafts refer
to (see 'graft-derivation'.)"
(define system (bag-system bag))
(define target (bag-target bag))
(define target-grafts
(if target
(filter-map (input-cross-graft store target system)
(bag-transitive-host-inputs bag))
'()))
(define native-grafts
(let ((->graft (input-graft store system)))
(fold-bag-dependencies (lambda (package grafts)
(match (->graft package)
(#f grafts)
(graft (cons graft grafts))))
'()
bag)))
(append native-grafts target-grafts)))
(define target-grafts
(if target
(let ((->graft (input-cross-graft store target system)))
(fold-bag-dependencies (lambda (package grafts)
(match (->graft package)
(#f grafts)
(graft (cons graft grafts))))
'()
bag
#:native? #f))
'()))
(append native-grafts target-grafts))
(define* (package-grafts store package
#:optional (system (%current-system))
@ -985,6 +1022,9 @@ (define* (package-derivation store package
(grafts
(let ((guile (package-derivation store (default-guile)
system #:graft? #f)))
;; TODO: As an optimization, we can simply graft the tip
;; of the derivation graph since 'graft-derivation'
;; recurses anyway.
(graft-derivation store drv grafts
#:system system
#:guile guile))))

View file

@ -19,6 +19,7 @@
(define-module (guix scripts graph)
#:use-module (guix ui)
#:use-module (guix graph)
#:use-module (guix grafts)
#:use-module (guix scripts)
#:use-module (guix utils)
#:use-module (guix packages)
@ -352,7 +353,9 @@ (define (guix-graph . args)
opts)))
(with-store store
(run-with-store store
(mlet %store-monad ((nodes (mapm %store-monad
;; XXX: Since grafting can trigger unsolicited builds, disable it.
(mlet %store-monad ((_ (set-grafting #f))
(nodes (mapm %store-monad
(node-type-convert type)
packages)))
(export-graph (concatenate nodes)

View file

@ -17,12 +17,16 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-grafts)
#:use-module (guix gexp)
#:use-module (guix monads)
#:use-module (guix derivations)
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix grafts)
#:use-module (guix tests)
#:use-module ((gnu packages) #:select (search-bootstrap-binary))
#:use-module (gnu packages bootstrap)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-64)
#:use-module (rnrs io ports))
@ -42,7 +46,7 @@ (define %mkdir
(test-begin "grafts")
(test-assert "graft-derivation"
(test-assert "graft-derivation, grafted item is a direct dependency"
(let* ((build `(begin
(mkdir %output)
(chdir %output)
@ -51,7 +55,7 @@ (define %mkdir
(lambda (output)
(format output "foo/~a/bar" ,%mkdir)))
(symlink ,%bash "sh")))
(orig (build-expression->derivation %store "graft" build
(orig (build-expression->derivation %store "grafted" build
#:inputs `(("a" ,%bash)
("b" ,%mkdir))))
(one (add-text-to-store %store "bash" "fake bash"))
@ -59,21 +63,80 @@ (define %mkdir
'(call-with-output-file %output
(lambda (port)
(display "fake mkdir" port)))))
(graft (graft-derivation %store orig
(list (graft
(origin %bash)
(replacement one))
(graft
(origin %mkdir)
(replacement two))))))
(and (build-derivations %store (list graft))
(let ((two (derivation->output-path two))
(graft (derivation->output-path graft)))
(grafted (graft-derivation %store orig
(list (graft
(origin %bash)
(replacement one))
(graft
(origin %mkdir)
(replacement two))))))
(and (build-derivations %store (list grafted))
(let ((two (derivation->output-path two))
(grafted (derivation->output-path grafted)))
(and (string=? (format #f "foo/~a/bar" two)
(call-with-input-file (string-append graft "/text")
(call-with-input-file (string-append grafted "/text")
get-string-all))
(string=? (readlink (string-append graft "/sh")) one)
(string=? (readlink (string-append graft "/self")) graft))))))
(string=? (readlink (string-append grafted "/sh")) one)
(string=? (readlink (string-append grafted "/self"))
grafted))))))
;; Make sure 'derivation-file-name' always gets to see an absolute file name.
(fluid-set! %file-port-name-canonicalization 'absolute)
(test-assert "graft-derivation, grafted item is an indirect dependency"
(let* ((build `(begin
(mkdir %output)
(chdir %output)
(symlink %output "self")
(call-with-output-file "text"
(lambda (output)
(format output "foo/~a/bar" ,%mkdir)))
(symlink ,%bash "sh")))
(dep (build-expression->derivation %store "dep" build
#:inputs `(("a" ,%bash)
("b" ,%mkdir))))
(orig (build-expression->derivation %store "thing"
'(symlink
(assoc-ref %build-inputs
"dep")
%output)
#:inputs `(("dep" ,dep))))
(one (add-text-to-store %store "bash" "fake bash"))
(two (build-expression->derivation %store "mkdir"
'(call-with-output-file %output
(lambda (port)
(display "fake mkdir" port)))))
(grafted (graft-derivation %store orig
(list (graft
(origin %bash)
(replacement one))
(graft
(origin %mkdir)
(replacement two))))))
(and (build-derivations %store (list grafted))
(let* ((two (derivation->output-path two))
(grafted (derivation->output-path grafted))
(dep (readlink grafted)))
(and (string=? (format #f "foo/~a/bar" two)
(call-with-input-file (string-append dep "/text")
get-string-all))
(string=? (readlink (string-append dep "/sh")) one)
(string=? (readlink (string-append dep "/self")) dep)
(equal? (references %store grafted) (list dep))
(lset= string=?
(list one two dep)
(references %store dep)))))))
(test-assert "graft-derivation, no dependencies on grafted output"
(run-with-store %store
(mlet* %store-monad ((fake (text-file "bash" "Fake bash."))
(graft -> (graft
(origin %bash)
(replacement fake)))
(drv (gexp->derivation "foo" #~(mkdir #$output)))
(grafted ((store-lift graft-derivation) drv
(list graft))))
(return (eq? grafted drv)))))
(test-assert "graft-derivation, multiple outputs"
(let* ((build `(begin

View file

@ -605,23 +605,27 @@ (define read-at
(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
(package-derivation %store dummy #:graft? #f)
(package-grafts %store dummy)
;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
;;; find out about their run-time dependencies, so this test is no longer
;;; applicable since it would trigger a full rebuild.
;;
;; (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
;; (package-derivation %store dummy #:graft? #f)
;; (package-grafts %store dummy)
;; Use the same Guile as 'package-derivation'.
#:guile guile))))
;; ;; Use the same Guile as 'package-derivation'.
;; #:guile guile))))
(test-equal "package->bag"
`("foo86-hurd" #f (,(package-source gnu-make))