summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore1
-rw-r--r--config-daemon.ac3
-rw-r--r--daemon.am4
-rw-r--r--nix/scripts/list-runtime-roots.in116
-rwxr-xr-xnix/sync-with-upstream4
-rw-r--r--tests/guix-daemon.sh4
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