[bug#37302] [PATCH 1/7] daemon: Invoke 'guix gc --list-busy' instead of 'list-runtime-roots'.

[Ludovic Courtès]

* nix/scripts/list-runtime-roots.in: Remove.
* guix/store/roots.scm (%proc-directory): New variable.
(proc-file-roots, proc-exe-roots, proc-cwd-roots)
(proc-fd-roots, proc-maps-roots, proc-environ-roots)
(referenced-files, canonicalize-store-item, busy-store-items): New
procedures, taken from 'list-runtime-roots.in'.
* nix/libstore/globals.hh (Settings)[guixProgram]: New field.
* nix/libstore/globals.cc (Settings::processEnvironment): Initialize
'guixProgram'.
* nix/libstore/gc.cc (addAdditionalRoots): Drop code related to
'NIX_ROOT_FINDER'.  Run "guix gc --list-busy".
* nix/local.mk (nodist_pkglibexec_SCRIPTS): Remove
'scripts/list-runtime-roots'.
* config-daemon.ac: Don't output nix/scripts/list-runtime-roots.
* build-aux/pre-inst-env.in: Don't set 'NIX_ROOT_FINDER'.
Set 'GUIX'.
* doc/guix.texi (Invoking guix gc): Document '--list-busy'.
* guix/scripts/gc.scm (show-help, %options): Add "--list-busy".
(guix-gc)[list-busy]: New procedure.
Handle the 'list-busy' action.
---
 build-aux/pre-inst-env.in         |   6 +-
 config-daemon.ac                  |   3 -
 doc/guix.texi                     |   4 +
 guix/scripts/gc.scm               |  15 +++
 guix/store/roots.scm              | 129 +++++++++++++++++++++++++-
 nix/libstore/gc.cc                |  11 +--
 nix/libstore/globals.cc           |   1 +
 nix/libstore/globals.hh           |   3 +
 nix/local.mk                      |   1 -
 nix/scripts/list-runtime-roots.in | 147 ------------------------------
 10 files changed, 158 insertions(+), 162 deletions(-)
 delete mode 100644 nix/scripts/list-runtime-roots.in

diff --git a/build-aux/pre-inst-env.in b/build-aux/pre-inst-env.in
index 3efab69e7d..ab1c519d70 100644
--- a/build-aux/pre-inst-env.in
+++ b/build-aux/pre-inst-env.in
@@ -44,15 +44,17 @@ export PATH
 
 # Daemon helpers.
 
-NIX_ROOT_FINDER="$abs_top_builddir/nix/scripts/list-runtime-roots"
 NIX_LIBEXEC_DIR="@abs_top_builddir@/nix/scripts" # for 'authenticate', etc.
 
-export NIX_ROOT_FINDER NIX_LIBEXEC_DIR
+export NIX_LIBEXEC_DIR
 
 NIX_BUILD_HOOK="$abs_top_builddir/nix/scripts/offload"
 @BUILD_DAEMON_OFFLOAD_TRUE@export NIX_BUILD_HOOK
 @BUILD_DAEMON_OFFLOAD_FALSE@# No offloading support.
 @BUILD_DAEMON_OFFLOAD_FALSE@unset NIX_BUILD_HOOK
+# The daemon invokes 'guix'; tell it which one to use.
+GUIX="$abs_top_builddir/scripts/guix"
+export GUIX
 
 # The following variables need only be defined when compiling Guix
 # modules, but we define them to be on the safe side in case of
diff --git a/config-daemon.ac b/config-daemon.ac
index f1ad10acff..f1d26af3a7 100644
--- a/config-daemon.ac
+++ b/config-daemon.ac
@@ -148,9 +148,6 @@ if test "x$guix_build_daemon" = "xyes"; then
   AC_SUBST([GUIX_TEST_ROOT])
 
   GUIX_CHECK_LOCALSTATEDIR
-
-  AC_CONFIG_FILES([nix/scripts/list-runtime-roots],
-    [chmod +x nix/scripts/list-runtime-roots])
   AC_CONFIG_FILES([nix/scripts/download],
     [chmod +x nix/scripts/download])
   AC_CONFIG_FILES([nix/scripts/substitute],
diff --git a/doc/guix.texi b/doc/guix.texi
index de02ad8687..afbeb00f94 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3496,6 +3496,10 @@ This prints nothing unless the daemon was started with
 List the GC roots owned by the user; when run as root, list @emph{all} the GC
 roots.
 
+@item --list-busy
+List store items in use by currently running processes.  These store
+items are effectively considered GC roots: they cannot be deleted.
+
 @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 31657326b6..3f20a2e192 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -56,6 +56,8 @@ Invoke the garbage collector.\n"))
   -D, --delete           attempt to delete PATHS"))
   (display (G_ "
       --list-roots       list the user's garbage collector roots"))
+  (display (G_ "
+      --list-busy        list store items used by running processes"))
   (display (G_ "
       --optimize         optimize the store by deduplicating identical files"))
   (display (G_ "
@@ -174,6 +176,10 @@ is deprecated; use '-D'~%"))
                 (lambda (opt name arg result)
                   (alist-cons 'action 'list-roots
                               (alist-delete 'action result))))
+        (option '("list-busy") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'action 'list-busy
+                              (alist-delete 'action result))))
         (option '("list-dead") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'action 'list-dead
@@ -265,6 +271,12 @@ is deprecated; use '-D'~%"))
                   (newline))
                 roots)))
 
+  (define (list-busy)
+    ;; List store items used by running processes.
+    (for-each (lambda (item)
+                (display item) (newline))
+              (busy-store-items)))
+
   (with-error-handling
     (let* ((opts  (parse-options))
            (store (open-connection))
@@ -305,6 +317,9 @@ is deprecated; use '-D'~%"))
         ((list-roots)
          (assert-no-extra-arguments)
          (list-roots))
+        ((list-busy)
+         (assert-no-extra-arguments)
+         (list-busy))
         ((delete)
          (delete-paths store (map direct-store-path paths)))
         ((list-references)
diff --git a/guix/store/roots.scm b/guix/store/roots.scm
index 4f23ae34e8..58653507f8 100644
--- a/guix/store/roots.scm
+++ b/guix/store/roots.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2017, 2019 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,9 +26,13 @@
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 ftw)
+  #:use-module (rnrs io ports)
   #:re-export (%gc-roots-directory)
   #:export (gc-roots
-            user-owned?))
+            user-owned?
+            busy-store-items))
 
 ;;; Commentary:
 ;;;
@@ -118,3 +122,124 @@ are user-controlled symlinks stored anywhere on the file 
system."
 
       (= (stat:uid stat) uid))
     (const #f)))
+
+
+;;;
+;;; Listing "busy" store items: those referenced by currently running
+;;; processes.
+;;;
+
+(define %proc-directory
+  ;; Mount point of Linuxish /proc file system.
+  "/proc")
+
+(define (proc-file-roots dir file)
+  "Return a one-element list containing the file pointed to by DIR/FILE,
+or the empty list."
+  (or (and=> (false-if-exception (readlink (string-append dir "/" file)))
+             list)
+      '()))
+
+(define proc-exe-roots (cut proc-file-roots <> "exe"))
+(define proc-cwd-roots (cut proc-file-roots <> "cwd"))
+
+(define (proc-fd-roots dir)
+  "Return the list of store files referenced by DIR, which is a
+/proc/XYZ directory."
+  (let ((dir (string-append dir "/fd")))
+    (filter-map (lambda (file)
+                  (let ((target (false-if-exception
+                                 (readlink (string-append dir "/" file)))))
+                    (and target
+                         (string-prefix? "/" target)
+                         target)))
+                (or (scandir dir string->number) '()))))
+
+(define (proc-maps-roots dir)
+  "Return the list of store files referenced by DIR, which is a
+/proc/XYZ directory."
+  (define %file-mapping-line
+    (make-regexp "^.*[[:blank:]]+/([^ ]+)$"))
+
+  (call-with-input-file (string-append dir "/maps")
+    (lambda (maps)
+      (let loop ((line  (read-line maps))
+                 (roots '()))
+        (cond ((eof-object? line)
+               roots)
+              ((regexp-exec %file-mapping-line line)
+               =>
+               (lambda (match)
+                 (let ((file (string-append "/"
+                                            (match:substring match 1))))
+                   (loop (read-line maps)
+                         (cons file roots)))))
+              (else
+               (loop (read-line maps) roots)))))))
+
+(define (proc-environ-roots dir)
+  "Return the list of store files referenced by DIR/environ, where DIR is a
+/proc/XYZ directory."
+  (define split-on-nul
+    (cute string-tokenize <>
+          (char-set-complement (char-set #\nul))))
+
+  (define (rhs-file-names str)
+    (let ((equal (string-index str #\=)))
+      (if equal
+          (let* ((str (substring str (+ 1 equal)))
+                 (rx  (string-append (regexp-quote %store-directory)
+                                     "/[0-9a-z]{32}-[a-zA-Z0-9\\._+-]+")))
+            (map match:substring (list-matches rx str)))
+          '())))
+
+  (define environ
+    (string-append dir "/environ"))
+
+  (append-map rhs-file-names
+              (split-on-nul
+               (call-with-input-file environ
+                 get-string-all))))
+
+(define (referenced-files)
+  "Return the list of referenced store items."
+  (append-map (lambda (pid)
+                (let ((proc (string-append %proc-directory "/" pid)))
+                  (catch 'system-error
+                    (lambda ()
+                      (append (proc-exe-roots proc)
+                              (proc-cwd-roots proc)
+                              (proc-fd-roots proc)
+                              (proc-maps-roots proc)
+                              (proc-environ-roots proc)))
+                    (lambda args
+                      (let ((err (system-error-errno args)))
+                        (if (or (= ENOENT err)    ;TOCTTOU race
+                                (= ESRCH err)     ;ditto
+                                (= EACCES err))   ;not running as root
+                            '()
+                            (apply throw args)))))))
+              (scandir %proc-directory string->number
+                       (lambda (a b)
+                         (< (string->number a) (string->number b))))))
+
+(define canonicalize-store-item
+  (let* ((store  (string-append %store-directory "/"))
+         (prefix (string-length store)))
+    (lambda (file)
+      "Return #f if FILE is not a store item; otherwise, return the store file
+name without any sub-directory components."
+      (and (string-prefix? store file)
+           (string-append store
+                          (let ((base (string-drop file prefix)))
+                            (match (string-index base #\/)
+                              (#f    base)
+                              (slash (string-take base slash)))))))))
+
+(define (busy-store-items)
+  "Return the list of store items used by the currently running processes.
+
+This code should typically run as root; it allows the garbage collector to
+determine which store items must not be deleted."
+  (delete-duplicates
+   (filter-map canonicalize-store-item (referenced-files))))
diff --git a/nix/libstore/gc.cc b/nix/libstore/gc.cc
index 46171e116c..c466996668 100644
--- a/nix/libstore/gc.cc
+++ b/nix/libstore/gc.cc
@@ -339,14 +339,11 @@ Roots LocalStore::findRoots()
 
 static void addAdditionalRoots(StoreAPI & store, PathSet & roots)
 {
-    Path rootFinder = getEnv("NIX_ROOT_FINDER",
-        settings.nixLibexecDir + "/list-runtime-roots");
+    debug(format("executing `%1% gc --list-busy' to find additional roots")
+         % settings.guixProgram);
 
-    if (rootFinder.empty()) return;
-
-    debug(format("executing `%1%' to find additional roots") % rootFinder);
-
-    string result = runProgram(rootFinder);
+    const Strings args = { "gc", "--list-busy" };
+    string result = runProgram(settings.guixProgram, false, args);
 
     StringSet paths = tokenizeString<StringSet>(result, "\n");
 
diff --git a/nix/libstore/globals.cc b/nix/libstore/globals.cc
index 6df20e7a52..8f7c976fcb 100644
--- a/nix/libstore/globals.cc
+++ b/nix/libstore/globals.cc
@@ -73,6 +73,7 @@ void Settings::processEnvironment()
     nixLibexecDir = canonPath(getEnv("NIX_LIBEXEC_DIR", NIX_LIBEXEC_DIR));
     nixBinDir = canonPath(getEnv("NIX_BIN_DIR", NIX_BIN_DIR));
     nixDaemonSocketFile = canonPath(nixStateDir + DEFAULT_SOCKET_PATH);
+    guixProgram = canonPath(getEnv("GUIX", nixBinDir + "/guix"));
 }
 
 
diff --git a/nix/libstore/globals.hh b/nix/libstore/globals.hh
index b073f724b6..0d9315a41a 100644
--- a/nix/libstore/globals.hh
+++ b/nix/libstore/globals.hh
@@ -66,6 +66,9 @@ struct Settings {
     /* File name of the socket the daemon listens to.  */
     Path nixDaemonSocketFile;
 
+    /* Absolute file name of the 'guix' program.  */
+    Path guixProgram;
+
     /* Whether to keep temporary directories of failed builds. */
     bool keepFailed;
 
diff --git a/nix/local.mk b/nix/local.mk
index 6d7e60e9fb..fd7379b5ff 100644
--- a/nix/local.mk
+++ b/nix/local.mk
@@ -155,7 +155,6 @@ noinst_HEADERS =                                            
\
                   (write (get-string-all in) out)))))"
 
 nodist_pkglibexec_SCRIPTS =                    \
-  %D%/scripts/list-runtime-roots               \
   %D%/scripts/substitute                       \
   %D%/scripts/download
 
diff --git a/nix/scripts/list-runtime-roots.in 
b/nix/scripts/list-runtime-roots.in
deleted file mode 100644
index 5f2660fb5e..0000000000
--- a/nix/scripts/list-runtime-roots.in
+++ /dev/null
@@ -1,147 +0,0 @@
-#!@GUILE@ -ds
-!#
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2017 Ludovic Courtès <address@hidden>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-;;;
-;;; List files being used at run time; these files are garbage collector
-;;; roots.  This is equivalent to `find-runtime-roots.pl' in Nix.
-;;;
-
-(use-modules (ice-9 ftw)
-             (ice-9 regex)
-             (ice-9 rdelim)
-             (ice-9 match)
-             (srfi srfi-1)
-             (srfi srfi-26)
-             (rnrs io ports))
-
-(define %proc-directory
-  ;; Mount point of Linuxish /proc file system.
-  "/proc")
-
-(define %store-directory
-  (or (getenv "NIX_STORE_DIR")
-      "@storedir@"))
-
-(define (proc-file-roots dir file)
-  "Return a one-element list containing the file pointed to by DIR/FILE,
-or the empty list."
-  (or (and=> (false-if-exception (readlink (string-append dir "/" file)))
-             list)
-      '()))
-
-(define proc-exe-roots (cut proc-file-roots <> "exe"))
-(define proc-cwd-roots (cut proc-file-roots <> "cwd"))
-
-(define (proc-fd-roots dir)
-  "Return the list of store files referenced by DIR, which is a
-/proc/XYZ directory."
-  (let ((dir (string-append dir "/fd")))
-    (filter-map (lambda (file)
-                  (let ((target (false-if-exception
-                                 (readlink (string-append dir "/" file)))))
-                    (and target
-                         (string-prefix? "/" target)
-                         target)))
-                (or (scandir dir string->number) '()))))
-
-(define (proc-maps-roots dir)
-  "Return the list of store files referenced by DIR, which is a
-/proc/XYZ directory."
-  (define %file-mapping-line
-    (make-regexp "^.*[[:blank:]]+/([^ ]+)$"))
-
-  (call-with-input-file (string-append dir "/maps")
-    (lambda (maps)
-      (let loop ((line  (read-line maps))
-                 (roots '()))
-        (cond ((eof-object? line)
-               roots)
-              ((regexp-exec %file-mapping-line line)
-               =>
-               (lambda (match)
-                 (let ((file (string-append "/"
-                                            (match:substring match 1))))
-                   (loop (read-line maps)
-                         (cons file roots)))))
-              (else
-               (loop (read-line maps) roots)))))))
-
-(define (proc-environ-roots dir)
-  "Return the list of store files referenced by DIR/environ, where DIR is a
-/proc/XYZ directory."
-  (define split-on-nul
-    (cute string-tokenize <>
-          (char-set-complement (char-set #\nul))))
-
-  (define (rhs-file-names str)
-    (let ((equal (string-index str #\=)))
-      (if equal
-          (let* ((str (substring str (+ 1 equal)))
-                 (rx  (string-append (regexp-quote %store-directory)
-                                     "/[0-9a-z]{32}-[a-zA-Z0-9\\._+-]+")))
-            (map match:substring (list-matches rx str)))
-          '())))
-
-  (define environ
-    (string-append dir "/environ"))
-
-  (append-map rhs-file-names
-              (split-on-nul
-               (call-with-input-file environ
-                 get-string-all))))
-
-(define (referenced-files)
-  "Return the list of referenced store items."
-  (append-map (lambda (pid)
-                (let ((proc (string-append %proc-directory "/" pid)))
-                  (catch 'system-error
-                    (lambda ()
-                      (append (proc-exe-roots proc)
-                              (proc-cwd-roots proc)
-                              (proc-fd-roots proc)
-                              (proc-maps-roots proc)
-                              (proc-environ-roots proc)))
-                    (lambda args
-                      (let ((err (system-error-errno args)))
-                        (if (or (= ENOENT err)    ;TOCTTOU race
-                                (= ESRCH err)     ;ditto
-                                (= EACCES err))   ;not running as root
-                            '()
-                            (apply throw args)))))))
-              (scandir %proc-directory string->number
-                       (lambda (a b)
-                         (< (string->number a) (string->number b))))))
-
-(define canonicalize-store-item
-  (let* ((store  (string-append %store-directory "/"))
-         (prefix (string-length store)))
-    (lambda (file)
-      "Return #f if FILE is not a store item; otherwise, return the store file
-name without any sub-directory components."
-      (and (string-prefix? store file)
-           (string-append store
-                          (let ((base (string-drop file prefix)))
-                            (match (string-index base #\/)
-                              (#f    base)
-                              (slash (string-take base slash)))))))))
-
-(for-each (cut simple-format #t "~a~%" <>)
-          (delete-duplicates
-           (filter-map canonicalize-store-item (referenced-files))))
-- 
2.23.0