diff options
author | Marius Bakke <mbakke@fastmail.com> | 2017-11-19 15:01:00 +0100 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2017-11-19 15:01:00 +0100 |
commit | 2dd12924cf4a30a96262b6d392fcde58c9f10d4b (patch) | |
tree | 3f74f5426ff214a02b8f6652f6516979657a7f98 /nix/scripts | |
parent | 259b4f34ba2eaefeafdb7c9f9eb56ee77f16010c (diff) | |
parent | a93447b89a5b132221072e729d13a3f17391b8c2 (diff) | |
download | guix-patches-2dd12924cf4a30a96262b6d392fcde58c9f10d4b.tar guix-patches-2dd12924cf4a30a96262b6d392fcde58c9f10d4b.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'nix/scripts')
-rw-r--r-- | nix/scripts/list-runtime-roots.in | 94 |
1 files changed, 36 insertions, 58 deletions
diff --git a/nix/scripts/list-runtime-roots.in b/nix/scripts/list-runtime-roots.in index a6938087b5..511789a539 100644 --- a/nix/scripts/list-runtime-roots.in +++ b/nix/scripts/list-runtime-roots.in @@ -26,7 +26,7 @@ (use-modules (ice-9 ftw) (ice-9 regex) (ice-9 rdelim) - (ice-9 popen) + (ice-9 match) (srfi srfi-1) (srfi srfi-26) (rnrs io ports)) @@ -59,7 +59,7 @@ or the empty list." (and target (string-prefix? "/" target) target))) - (scandir dir string->number)))) + (or (scandir dir string->number) '())))) (define (proc-maps-roots dir) "Return the list of store files referenced by DIR, which is a @@ -107,61 +107,39 @@ or the empty list." (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 +(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 () - (open-pipe* OPEN_READ "lsof" "-n" "-w" "-F" "n")) + (append (proc-exe-roots proc) + (proc-cwd-roots proc) + (proc-fd-roots proc) + (proc-maps-roots proc) + (proc-environ-roots proc))) (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/(.*)$")) - - ;; We're going to read it all. - (setvbuf pipe _IOFBF 16384) - - (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)))))) + (let ((err (system-error-errno args))) + (if (or (= ENOENT err) ;TOCTTOU race + (= 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 ((prefix (+ 1 (string-length %store-directory)))) + (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-directory file) + (string-append %store-directory "/" + (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)))) |