From bacf980c76c94e7bda86220ca4bf662d0e34a45a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 6 Apr 2019 22:29:18 +0200
Subject: [PATCH] guix gc: Add '--list-roots'.

* guix/scripts/gc.scm (show-help, %options): Add '--list-roots'.
(guix-gc)[list-roots]: New procedure.
Handle '--list-roots'.
* tests/guix-gc.sh: Test it.
* doc/guix.texi (Invoking guix gc): Document it.
---
 doc/guix.texi       |  6 +++++-
 guix/scripts/gc.scm | 21 ++++++++++++++++++++-
 tests/guix-gc.sh    |  6 ++++--
 3 files changed, 29 insertions(+), 4 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 2f9fcbe3bf..2345617b2e 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3385,7 +3385,7 @@ deleted.  The set of garbage collector roots (``GC roots'' for short)
 includes default user profiles; by default, the symlinks under
 @file{/var/guix/gcroots} represent these GC roots.  New GC roots can be
 added with @command{guix build --root}, for example (@pxref{Invoking
-guix build}).
+guix build}).  The @command{guix gc --list-roots} command lists them.
 
 Prior to running @code{guix gc --collect-garbage} to make space, it is
 often useful to remove old generations from user profiles; that way, old
@@ -3451,6 +3451,10 @@ This prints nothing unless the daemon was started with
 @option{--cache-failures} (@pxref{Invoking guix-daemon,
 @option{--cache-failures}}).
 
+@item --list-roots
+List the GC roots owned by the user; when run as root, list @emph{all} the GC
+roots.
+
 @item --clear-failures
 Remove the specified store items from the failed-build cache.
 
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 6f37b767ff..2606e20deb 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,6 +20,7 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix store)
+  #:use-module (guix store roots)
   #:autoload   (guix build syscalls) (free-disk-space)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
@@ -48,6 +49,8 @@ Invoke the garbage collector.\n"))
   -F, --free-space=FREE  attempt to reach FREE available space in the store"))
   (display (G_ "
   -d, --delete           attempt to delete PATHS"))
+  (display (G_ "
+      --list-roots       list the user's garbage collector roots"))
   (display (G_ "
       --optimize         optimize the store by deduplicating identical files"))
   (display (G_ "
@@ -135,6 +138,10 @@ Invoke the garbage collector.\n"))
                                 (alist-cons 'verify-options options
                                             (alist-delete 'action
                                                           result))))))
+        (option '("list-roots") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'action 'list-roots
+                              (alist-delete 'action result))))
         (option '("list-dead") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'action 'list-dead
@@ -205,6 +212,15 @@ Invoke the garbage collector.\n"))
             (info (G_ "freeing ~h MiBs~%") (/ to-free 1024. 1024.))
             (collect-garbage store to-free)))))
 
+  (define (list-roots)
+    ;; List all the user-owned GC roots.
+    (let ((roots (filter (if (zero? (getuid)) (const #t) user-owned?)
+                         (gc-roots))))
+      (for-each (lambda (root)
+                  (display root)
+                  (newline))
+                roots)))
+
   (with-error-handling
     (let* ((opts  (parse-options))
            (store (open-connection))
@@ -238,6 +254,9 @@ Invoke the garbage collector.\n"))
             (else
              (let-values (((paths freed) (collect-garbage store)))
               (info (G_ "freed ~h MiBs~%") (/ freed 1024. 1024.)))))))
+        ((list-roots)
+         (assert-no-extra-arguments)
+         (list-roots))
         ((delete)
          (delete-paths store (map direct-store-path paths)))
         ((list-references)
diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh
index ef2d9543b7..8284287730 100644
--- a/tests/guix-gc.sh
+++ b/tests/guix-gc.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2013, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2013, 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -34,7 +34,7 @@ unset drv
 unset out
 
 # For some operations, passing extra arguments is an error.
-for option in "" "-C 500M" "--verify" "--optimize"
+for option in "" "-C 500M" "--verify" "--optimize" "--list-roots"
 do
     if guix gc $option whatever; then false; else true; fi
 done
@@ -69,6 +69,8 @@ guix gc --delete "$drv"
 drv="`guix build --root=guix-gc-root lsh -d`"
 test -f "$drv" && test -L guix-gc-root
 
+guix gc --list-roots | grep "$PWD/guix-gc-root"
+
 guix gc --list-live | grep "$drv"
 if guix gc --delete "$drv";
 then false; else true; fi