#!@GUILE@ -ds !# ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014 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 popen) (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))) (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 (lsof-roots) "Return the list of roots as found by calling `lsof'." (define parent (getpid)) (catch 'system-error (lambda () (let ((pipe (catch 'system-error (lambda () (open-pipe* OPEN_READ "lsof" "-n" "-w" "-F" "n")) (lambda args ;; In Guile 2.0.5, when (ice-9 popen) was still written ;; in Scheme, 'open-pipe*' would leave the child process ;; behind it when 'execlp' failed (that was mostly ;; harmless though, because the uncaught exception would ;; cause it to terminate after printing a backtrace.) ;; Make sure that doesn't happen. (if (= (getpid) parent) (apply throw args) (begin (format (current-error-port) "failed to execute 'lsof': ~a~%" (strerror (system-error-errno args))) (primitive-exit 1))))))) (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) (proc-environ-roots proc)) '()))) (append proc-roots (lsof-roots))))))