aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-10-15 22:47:42 +0200
committerLudovic Courtès <ludo@gnu.org>2016-10-15 23:46:39 +0200
commit7f8fec0fa40951de33822f86c31c32e3f3c5513e (patch)
tree2e3ebc7b65649ae26279cfbaeac97878cbbc33f1
parent783ae212c213d6194ecbbdb13b91d93a6644a1ac (diff)
downloadguix-7f8fec0fa40951de33822f86c31c32e3f3c5513e.tar
guix-7f8fec0fa40951de33822f86c31c32e3f3c5513e.tar.gz
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.
-rw-r--r--doc/guix.texi14
-rw-r--r--guix/scripts/graph.scm53
-rw-r--r--tests/graph.scm22
3 files changed, 74 insertions, 15 deletions
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 @@
%bag-emerged-node-type
%derivation-node-type
%reference-node-type
+ %referrer-node-type
%node-types
guix-graph))
@@ -257,6 +258,24 @@ derivation graph")))))))
;;; 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 @@ substitutes."
(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 @@ reference graph")))))))
%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 @@ edges."
(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 '())))