me
/
guix
Archived
1
0
Fork 0
Code

daemon: Invoke 'guix gc --list-busy' instead of 'list-runtime-roots'. 

* 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.
master
Ludovic Courtès 2019-09-03 21:36:29 +02:00
parent 7fcc2f9355
commit 2e3e5d2198
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
10 changed files with 158 additions and 162 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
build-aux/pre-inst-env.in
View File

@ -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

3
config-daemon.ac
View File

@ -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],

4
doc/guix.texi
View File

@ -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.

15
guix/scripts/gc.scm
View File

@ -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)

129
guix/store/roots.scm
View File

@ -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))))

11
nix/libstore/gc.cc
View File

@ -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");

1
nix/libstore/globals.cc
View File

@ -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"));
}

3
nix/libstore/globals.hh
View File

@ -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;

1
nix/local.mk
View File

@ -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

147
nix/scripts/list-runtime-roots.in
View File

@ -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))))