aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--build-aux/pre-inst-env.in6
-rw-r--r--config-daemon.ac3
-rw-r--r--doc/guix.texi4
-rw-r--r--guix/scripts/gc.scm15
-rw-r--r--guix/store/roots.scm129
-rw-r--r--nix/libstore/gc.cc11
-rw-r--r--nix/libstore/globals.cc1
-rw-r--r--nix/libstore/globals.hh3
-rw-r--r--nix/local.mk1
-rw-r--r--nix/scripts/list-runtime-roots.in147
10 files changed, 158 insertions, 162 deletions
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 83f791d71d..31f7890fe9 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
@@ -57,6 +57,8 @@ Invoke the garbage collector.\n"))
(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_ "
--list-dead list dead paths"))
@@ -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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 <ludo@gnu.org>
-;;;
-;;; 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))))