diff options
| -rw-r--r-- | build-aux/pre-inst-env.in | 6 | ||||
| -rw-r--r-- | config-daemon.ac | 3 | ||||
| -rw-r--r-- | doc/guix.texi | 4 | ||||
| -rw-r--r-- | guix/scripts/gc.scm | 15 | ||||
| -rw-r--r-- | guix/store/roots.scm | 129 | ||||
| -rw-r--r-- | nix/libstore/gc.cc | 11 | ||||
| -rw-r--r-- | nix/libstore/globals.cc | 1 | ||||
| -rw-r--r-- | nix/libstore/globals.hh | 3 | ||||
| -rw-r--r-- | nix/local.mk | 1 | ||||
| -rw-r--r-- | nix/scripts/list-runtime-roots.in | 147 |
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)))) |