daemon: Add `list-runtime-roots' script.

* nix/scripts/list-runtime-roots.in: New file.
* config-daemon.ac: Add `AC_CONFIG_FILES' invocation for it.
* daemon.am (nodist_pkglibexec_SCRIPTS): New variable.
  (AM_TESTS_ENVIRONMENT): Define `top_builddir'.
* tests/guix-daemon.sh: Export `NIX_ROOT_FINDER'.
* nix/sync-with-upstream: Substitute the path to the root finder in
  libstore/gc.cc.

6 files changed, 131 insertions, 1 deletions

diff --git a/.gitignore b/.gitignore
index d39ad6ed96..3ef17152ba 100644
--- a/.gitignore
+++ b/.gitignore
@@ -61,3 +61,4 @@ stamp-h[0-9]
 /libutil.a
 /guix-daemon
 /test-tmp
+/nix/scripts/list-runtime-roots
diff --git a/config-daemon.ac b/config-daemon.ac
index a10be14632..946f6e453d 100644
--- a/config-daemon.ac
+++ b/config-daemon.ac
@@ -91,6 +91,9 @@ if test "x$guix_build_daemon" = "xyes"; then
 
   dnl Check for <linux/fs.h> (for immutable file support).
   AC_CHECK_HEADERS([linux/fs.h])
+
+  AC_CONFIG_FILES([nix/scripts/list-runtime-roots],
+    [chmod +x nix/scripts/list-runtime-roots])
 fi
 
 AM_CONDITIONAL([BUILD_DAEMON], [test "x$guix_build_daemon" = "xyes"])
diff --git a/daemon.am b/daemon.am
index 48b0871a97..f5d58ea275 100644
--- a/daemon.am
+++ b/daemon.am
@@ -146,6 +146,9 @@ nix/libstore/schema.sql.hh: nix/libstore/schema.sql
 	         (lambda (in)					\
 	           (write (get-string-all in) out)))))"
 
+nodist_pkglibexec_SCRIPTS =			\
+  nix/scripts/list-runtime-roots
+
 EXTRA_DIST +=					\
   nix/sync-with-upstream			\
   nix/libstore/schema.sql			\
@@ -156,6 +159,7 @@ EXTRA_DIST +=					\
 test_root = $(abs_top_builddir)/test-tmp
 
 AM_TESTS_ENVIRONMENT +=				\
+  top_builddir="$(abs_top_builddir)"		\
   TEST_ROOT="$(test_root)"
 
 TESTS +=					\
diff --git a/nix/scripts/list-runtime-roots.in b/nix/scripts/list-runtime-roots.in
new file mode 100644
index 0000000000..5c21ae543d
--- /dev/null
+++ b/nix/scripts/list-runtime-roots.in
@@ -0,0 +1,116 @@
+#!@GUILE@ -ds
+!#
+;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
+;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of Guix.
+;;;
+;;; 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.
+;;;
+;;; 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 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 popen)
+             (srfi srfi-1)
+             (srfi srfi-26))
+
+(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)))
+                (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 (lsof-roots)
+  "Return the list of roots as found by calling `lsof'."
+  (catch 'system
+    (lambda ()
+      (let ((pipe (open-pipe* OPEN_READ "lsof" "-n" "-w" "-F" "n")))
+        (define %file-rx
+          (make-regexp "^n/(.*)$"))
+
+        (let loop ((line  (read-line pipe))
+                   (roots '()))
+          (cond ((eof-object? line)
+                 (begin
+                   (close-pipe pipe)
+                   roots))
+                ((regexp-exec %file-rx line)
+                 =>
+                 (lambda (match)
+                   (loop (read-line pipe)
+                         (cons (string-append "/"
+                                              (match:substring match 1))
+                               roots))))
+                (else
+                 (loop (read-line pipe) roots))))))
+    (lambda _
+      '())))
+
+(let ((proc (format #f "~a/~a" %proc-directory (getpid))))
+  (for-each (cut simple-format #t "~a~%" <>)
+            (delete-duplicates
+             (let ((proc-roots (if (file-exists? proc)
+                                   (append (proc-exe-roots proc)
+                                           (proc-cwd-roots proc)
+                                           (proc-fd-roots proc)
+                                           (proc-maps-roots proc))
+                                   '())))
+               (append proc-roots (lsof-roots))))))
diff --git a/nix/sync-with-upstream b/nix/sync-with-upstream
index 324dcb27c9..69bd1fbee7 100755
--- a/nix/sync-with-upstream
+++ b/nix/sync-with-upstream
@@ -62,3 +62,7 @@ do
 done
 
 cp -v "$top_srcdir/nix-upstream/"{COPYING,AUTHORS} "$top_srcdir/nix"
+
+# Substitutions.
+sed -i "$top_srcdir/nix/libstore/gc.cc"					\
+    -e 's|/nix/find-runtime-roots\.pl|/guix/list-runtime-roots|g'
diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh
index d7926b2376..b6b92a78d4 100644
--- a/tests/guix-daemon.sh
+++ b/tests/guix-daemon.sh
@@ -29,8 +29,10 @@ NIX_LOCALSTATE_DIR="$TEST_ROOT/var"
 NIX_LOG_DIR="$TEST_ROOT/var/log/nix"
 NIX_STATE_DIR="$TEST_ROOT/var/nix"
 NIX_DB_DIR="$TEST_ROOT/db"
+NIX_ROOT_FINDER="$top_builddir/nix/scripts/list-runtime-roots"
 export NIX_SUBSTITUTERS NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR	\
-    NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR
+    NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR	\
+    NIX_ROOT_FINDER
 
 guix-daemon --version
 guix-build --version