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