From d0025d01445ff271ececea20cfa6a2346593d1d6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 14 Oct 2016 10:36:37 +0200 Subject: packages: 'package-grafts' applies grafts on replacement. Partly fixes . * guix/packages.scm (input-graft): Compute 'new' with #:graft? #t. (input-cross-graft): Likewise. * tests/packages.scm ("package-grafts, indirect grafts, cross"): Comment out. ("replacement also grafted"): New test. --- tests/packages.scm | 106 +++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 90 insertions(+), 16 deletions(-) (limited to 'tests') diff --git a/tests/packages.scm b/tests/packages.scm index b8e1f111cd..5f5fb5de87 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -662,22 +662,25 @@ (define read-at (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")) - ;; XXX: There might be additional grafts, for instance if the distro - ;; defines replacements for core packages like Perl. - (member (graft - (origin (package-cross-derivation %store dep target)) - (replacement - (package-cross-derivation %store new target))) - (package-grafts %store dummy #:target target)))) +;; XXX: This test would require building the cross toolchain just to see if it +;; needs grafting, which is obviously too expensive, and thus disabled. +;; +;; (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")) +;; ;; XXX: There might be additional grafts, for instance if the distro +;; ;; defines replacements for core packages like Perl. +;; (member (graft +;; (origin (package-cross-derivation %store dep target)) +;; (replacement +;; (package-cross-derivation %store new target))) +;; (package-grafts %store dummy #:target target)))) (test-assert "package-grafts, indirect grafts, propagated inputs" (let* ((new (dummy-package "dep" @@ -719,6 +722,77 @@ (define read-at (replacement #f)))) (replacement (package-derivation %store new))))))) +(test-assert "replacement also grafted" + ;; We build a DAG as below, where dotted arrows represent replacements and + ;; solid arrows represent dependencies: + ;; + ;; P1 ·············> P1R + ;; |\__________________. + ;; v v + ;; P2 ·············> P2R + ;; | + ;; v + ;; P3 + ;; + ;; We want to make sure that: + ;; grafts(P3) = (P1,P1R) + (P2, grafted(P2R, (P1,P1R))) + ;; where: + ;; (A,B) is a graft to replace A by B + ;; grafted(DRV,G) denoted DRV with graft G applied + (let* ((p1r (dummy-package "P1" + (build-system trivial-build-system) + (arguments + `(#:guile ,%bootstrap-guile + #:builder (let ((out (assoc-ref %outputs "out"))) + (mkdir out) + (call-with-output-file + (string-append out "/replacement") + (const #t))))))) + (p1 (package + (inherit p1r) (name "p1") (replacement p1r) + (arguments + `(#:guile ,%bootstrap-guile + #:builder (mkdir (assoc-ref %outputs "out")))))) + (p2r (dummy-package "P2" + (build-system trivial-build-system) + (inputs `(("p1" ,p1))) + (arguments + `(#:guile ,%bootstrap-guile + #:builder (let ((out (assoc-ref %outputs "out"))) + (mkdir out) + (chdir out) + (symlink (assoc-ref %build-inputs "p1") "p1") + (call-with-output-file (string-append out "/replacement") + (const #t))))))) + (p2 (package + (inherit p2r) (name "p2") (replacement p2r) + (arguments + `(#:guile ,%bootstrap-guile + #:builder (let ((out (assoc-ref %outputs "out"))) + (mkdir out) + (chdir out) + (symlink (assoc-ref %build-inputs "p1") + "p1")))))) + (p3 (dummy-package "p3" + (build-system trivial-build-system) + (inputs `(("p2" ,p2))) + (arguments + `(#:guile ,%bootstrap-guile + #:builder (let ((out (assoc-ref %outputs "out"))) + (mkdir out) + (chdir out) + (symlink (assoc-ref %build-inputs "p2") + "p2"))))))) + (lset= equal? + (package-grafts %store p3) + (list (graft + (origin (package-derivation %store p1 #:graft? #f)) + (replacement (package-derivation %store p1r))) + (graft + (origin (package-derivation %store p2 #:graft? #f)) + (replacement + (package-derivation %store p2r #:graft? #t))))))) + ;;; 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. -- cgit v1.2.3 From b013c33f6f060c14ca7d1f3cfcb5d8ce3ef1c53c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 14 Oct 2016 18:56:48 +0200 Subject: grafts: 'graft-derivation' does now introduce grafts that shadow other grafts. Partly fixes . * guix/grafts.scm (cumulative-grafts)[graft-origin?]: New procedure. [dependency-grafts]: Use it in new 'if' around recursive call. * tests/grafts.scm ("graft-derivation, grafts are not shadowed"): New test. --- guix/grafts.scm | 24 ++++++++++++++++++---- tests/grafts.scm | 62 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 82 insertions(+), 4 deletions(-) (limited to 'tests') diff --git a/guix/grafts.scm b/guix/grafts.scm index 53e697688a..3e7a81a4c7 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -227,13 +227,29 @@ (define* (cumulative-grafts store drv grafts This is a monadic procedure in %STATE-MONAD where the state is a vhash mapping derivations to the corresponding set of grafts." + (define (graft-origin? drv graft) + ;; Return true if DRV corresponds to the origin of GRAFT. + (match graft + (($ (? derivation? origin) output) + (match (assoc-ref (derivation->output-paths drv) output) + ((? string? result) + (string=? result + (derivation->output-path origin output))) + (_ + #f))) + (_ + #f))) + (define (dependency-grafts item) (let-values (((drv output) (item->deriver store item))) (if drv - (cumulative-grafts store drv grafts references - #:outputs (list output) - #:guile guile - #:system system) + ;; If GRAFTS already contains a graft from DRV, do not override it. + (if (find (cut graft-origin? drv <>) grafts) + (state-return grafts) + (cumulative-grafts store drv grafts references + #:outputs (list output) + #:guile guile + #:system system)) (state-return grafts)))) (define (return/cache cache value) diff --git a/tests/grafts.scm b/tests/grafts.scm index f2ff839fd8..4eff06b4b3 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -218,4 +218,66 @@ (define %mkdir (let ((out (derivation->output-path grafted))) (file-is-directory? (string-append out "/" repl)))))) +(test-assert "graft-derivation, grafts are not shadowed" + ;; We build a DAG as below, where dotted arrows represent replacements and + ;; solid arrows represent dependencies: + ;; + ;; P1 ·············> P1R + ;; |\__________________. + ;; v v + ;; P2 ·············> P2R + ;; | + ;; v + ;; P3 + ;; + ;; We want to make sure that the two grafts we want to apply to P3 are + ;; honored and not shadowed by other computed grafts. + (let* ((p1 (build-expression->derivation + %store "p1" + '(mkdir (assoc-ref %outputs "out")))) + (p1r (build-expression->derivation + %store "P1" + '(let ((out (assoc-ref %outputs "out"))) + (mkdir out) + (call-with-output-file (string-append out "/replacement") + (const #t))))) + (p2 (build-expression->derivation + %store "p2" + `(let ((out (assoc-ref %outputs "out"))) + (mkdir out) + (chdir out) + (symlink (assoc-ref %build-inputs "p1") "p1")) + #:inputs `(("p1" ,p1)))) + (p2r (build-expression->derivation + %store "P2" + `(let ((out (assoc-ref %outputs "out"))) + (mkdir out) + (chdir out) + (symlink (assoc-ref %build-inputs "p1") "p1") + (call-with-output-file (string-append out "/replacement") + (const #t))) + #:inputs `(("p1" ,p1)))) + (p3 (build-expression->derivation + %store "p3" + `(let ((out (assoc-ref %outputs "out"))) + (mkdir out) + (chdir out) + (symlink (assoc-ref %build-inputs "p2") "p2")) + #:inputs `(("p2" ,p2)))) + (p1g (graft + (origin p1) + (replacement p1r))) + (p2g (graft + (origin p2) + (replacement (graft-derivation %store p2r (list p1g))))) + (p3d (graft-derivation %store p3 (list p1g p2g)))) + (and (build-derivations %store (list p3d)) + (let ((out (derivation->output-path (pk p3d)))) + ;; Make sure OUT refers to the replacement of P2, which in turn + ;; refers to the replacement of P1, as specified by P1G and P2G. + ;; It used to be the case that P2G would be shadowed by a simple + ;; P2->P2R graft, which is not what we want. + (and (file-exists? (string-append out "/p2/replacement")) + (file-exists? (string-append out "/p2/p1/replacement"))))))) + (test-end) -- cgit v1.2.3 From 7f8fec0fa40951de33822f86c31c32e3f3c5513e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 15 Oct 2016 22:47:42 +0200 Subject: graph: Add '%referrer-node-type'. * guix/scripts/graph.scm (ensure-store-items): New procedure. (%reference-node-type)[convert]: Use it. (non-derivation-referrers): New procedure. (%referrer-node-type): New variable. (%node-types): Add it. * tests/graph.scm ("referrer DAG"): New test. * doc/guix.texi (Invoking guix graph): Document it. --- doc/guix.texi | 14 +++++++++++++ guix/scripts/graph.scm | 53 ++++++++++++++++++++++++++++++++++++-------------- tests/graph.scm | 22 +++++++++++++++++++++ 3 files changed, 74 insertions(+), 15 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 74733f4fd1..47fc199c6c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5546,6 +5546,20 @@ example, the command below produces the reference graph of your profile @example guix graph -t references `readlink -f ~/.guix-profile` @end example + +@item referrers +This is the graph of the @dfn{referrers} of a store item, as returned by +@command{guix gc --referrers} (@pxref{Invoking guix gc}). + +This relies exclusively on local information from your store. For +instance, let us suppose that the current Inkscape is available in 10 +profiles on your machine; @command{guix graph -t referrers inkscape} +will show a graph rooted at Inkscape and with those 10 profiles linked +to it. + +It can help determine what is preventing a store item from being garbage +collected. + @end table The available options are the following: diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 782fca5d63..2f70d64c90 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -42,6 +42,7 @@ (define-module (guix scripts graph) %bag-emerged-node-type %derivation-node-type %reference-node-type + %referrer-node-type %node-types guix-graph)) @@ -257,6 +258,24 @@ (define %derivation-node-type ;;; DAG of residual references (aka. run-time dependencies). ;;; +(define ensure-store-items + ;; Return a list of store items as a monadic value based on the given + ;; argument, which may be a store item or a package. + (match-lambda + ((? package? package) + ;; Return the output file names of PACKAGE. + (mlet %store-monad ((drv (package->derivation package))) + (return (match (derivation->output-paths drv) + (((_ . file-names) ...) + file-names))))) + ((? store-path? item) + (with-monad %store-monad + (return (list item)))) + (x + (raise + (condition (&message (message "unsupported argument for \ +this type of graph"))))))) + (define (references* item) "Return as a monadic value the references of ITEM, based either on the information available in the local store or using information about @@ -275,24 +294,27 @@ (define %reference-node-type (node-type (name "references") (description "the DAG of run-time dependencies (store references)") - (convert (match-lambda - ((? package? package) - ;; Return the output file names of PACKAGE. - (mlet %store-monad ((drv (package->derivation package))) - (return (match (derivation->output-paths drv) - (((_ . file-names) ...) - file-names))))) - ((? store-path? item) - (with-monad %store-monad - (return (list item)))) - (x - (raise - (condition (&message (message "unsupported argument for \ -reference graph"))))))) + (convert ensure-store-items) (identifier (lift1 identity %store-monad)) (label store-path-package-name) (edges references*))) +(define non-derivation-referrers + (let ((referrers (store-lift referrers))) + (lambda (item) + "Return the referrers of ITEM, except '.drv' files." + (mlet %store-monad ((items (referrers item))) + (return (remove derivation-path? items)))))) + +(define %referrer-node-type + (node-type + (name "referrers") + (description "the DAG of referrers in the store") + (convert ensure-store-items) + (identifier (lift1 identity %store-monad)) + (label store-path-package-name) + (edges non-derivation-referrers))) + ;;; ;;; List of node types. @@ -305,7 +327,8 @@ (define %node-types %bag-with-origins-node-type %bag-emerged-node-type %derivation-node-type - %reference-node-type)) + %reference-node-type + %referrer-node-type)) (define (lookup-node-type name) "Return the node type called NAME. Raise an error if it is not found." diff --git a/tests/graph.scm b/tests/graph.scm index 1ce06cc817..f2e441cee6 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -232,6 +232,28 @@ (define (edge->tuple source target) (list out txt)) (equal? edges `((,out ,txt))))))))))) +(test-assert "referrer DAG" + (let-values (((backend nodes+edges) (make-recording-backend))) + (run-with-store %store + (mlet* %store-monad ((txt (text-file "referrer-node" (random-text))) + (drv (gexp->derivation "referrer" + #~(symlink #$txt #$output))) + (out -> (derivation->output-path drv))) + ;; We should see only TXT and OUT, with an edge from the former to the + ;; latter. + (mbegin %store-monad + (built-derivations (list drv)) + (export-graph (list txt) 'port + #:node-type %referrer-node-type + #:backend backend) + (let-values (((nodes edges) (nodes+edges))) + (return + (and (equal? (match nodes + (((ids labels) ...) + ids)) + (list txt out)) + (equal? edges `((,txt ,out))))))))))) + (test-assert "node-edges" (run-with-store %store (let ((packages (fold-packages cons '()))) -- cgit v1.2.3