mirror of git://git.savannah.gnu.org/guix.git
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
parent
d06fc008bd
commit
c22a1324e6
|
|
@ -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}
|
||||
|
|
|
|||
104
guix/grafts.scm
104
guix/grafts.scm
|
|
@ -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 @@
|
|||
graft-replacement-output
|
||||
|
||||
graft-derivation
|
||||
graft-derivation/shallow
|
||||
|
||||
%graft?
|
||||
set-grafting))
|
||||
|
|
@ -61,13 +65,22 @@
|
|||
|
||||
(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 @@ applied."
|
|||
(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
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@
|
|||
#: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 @@ and return it."
|
|||
(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 @@ and returns #f for other inputs."
|
|||
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 @@ This is an internal procedure."
|
|||
(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))))
|
||||
|
|
|
|||
|
|
@ -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 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n"))
|
|||
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)
|
||||
|
|
|
|||
|
|
@ -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 @@
|
|||
|
||||
(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 @@
|
|||
(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 @@
|
|||
'(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
|
||||
|
|
|
|||
|
|
@ -605,23 +605,27 @@
|
|||
(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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue