aboutsummaryrefslogtreecommitdiff
path: root/read-proc.scm
diff options
context:
space:
mode:
authorHugo Hörnquist <hugo@lysator.liu.se>2021-02-11 01:06:15 +0100
committerHugo Hörnquist <hugo@lysator.liu.se>2021-02-11 01:06:15 +0100
commit9eead9118dabe93d4958ae6caf81ef9871c6c62f (patch)
tree446ae31dd7f29e286d6365d2d3c81fafbc483fbd /read-proc.scm
downloadfile-descriptor-graph-9eead9118dabe93d4958ae6caf81ef9871c6c62f.tar.gz
file-descriptor-graph-9eead9118dabe93d4958ae6caf81ef9871c6c62f.tar.xz
Initial commit.
Diffstat (limited to 'read-proc.scm')
-rw-r--r--read-proc.scm129
1 files changed, 129 insertions, 0 deletions
diff --git a/read-proc.scm b/read-proc.scm
new file mode 100644
index 0000000..9eda8d1
--- /dev/null
+++ b/read-proc.scm
@@ -0,0 +1,129 @@
+(use-modules (ice-9 ftw)
+ (srfi srfi-1)
+ ((graphviz) :prefix gv.))
+
+(define g (gv.graph "test-graph"))
+
+(define (show g)
+ (gv.layout g "dot")
+ (let* ((filename (tmpnam)))
+ (gv.render g "png" filename)
+ (display (format #f "#<Image: ~a>~%" filename))))
+
+(define (numeric-string< a b)
+ (< (string->number a) (string->number b)))
+
+(use-modules (ice-9 pretty-print))
+(define pp pretty-print)
+
+(define processes (scandir "/proc" string->number numeric-string<))
+(define (fds pid) (scandir (format #f "/proc/~a/fd" pid) string->number numeric-string<))
+(define (fd-link pid fd) (catch 'system-error (lambda () (readlink (format #f "/proc/~a/fd/~a" pid fd)))
+ (lambda args "#f")))
+(define (process-attribute pid field)
+ (call-with-input-file (format #f "/proc/~a/~a" pid field)
+ (@ (ice-9 rdelim) read-line)))
+
+(define (process-cmd pid)
+ (cond ((process-attribute pid "cmdline")
+ (negate eof-object?) => identity)
+ (else (process-attribute pid "comm"))))
+
+
+(use-modules (ice-9 hash-table))
+(define freqs (make-hash-table))
+
+;; (gv.setv g "nodesep" "1")
+(gv.setv g "overlap" "false")
+;; (gv.setv g "splines" "line")
+(gv.setv g "K" "10.0")
+;; (gv.setv g "sep" "+1")
+;; (gv.setv g "pack" "true")
+
+(use-modules (rnrs records syntactic))
+
+(define-record-type proc-node
+ (fields (immutable name)
+ (mutable files)))
+(define-record-type file-node
+ (fields (immutable name)
+ (mutable procs)))
+
+(define file-nodes (make-hash-table))
+
+(define (get-file-node proc name)
+ (define fn (hash-ref file-nodes name (make-file-node name '())))
+ (file-node-procs-set! fn (cons proc (file-node-procs fn)))
+ (hash-set! file-nodes name fn)
+ fn)
+
+(define next-color
+ (let ((lst (circular-list "cyan" "red" "green" "blue" "orange" "purple" "pink" "yellow")))
+ (lambda () (set! lst (cdr lst)) (car lst))))
+
+(define proc-nodes
+ (map (lambda (pid)
+ (define pn (make-proc-node (format #f "~a: ~a" pid (process-cmd pid)) '()))
+ (proc-node-files-set!
+ pn
+ (cond ((fds pid)
+ => (lambda (lst)
+ (map (lambda (fd)
+ (define target (fd-link pid fd))
+ (hash-set! freqs target (1+ (hash-ref freqs target 0)))
+ (get-file-node pn target))
+ lst)))
+ (else '()))))
+ processes))
+
+(define colored (make-hash-table))
+
+;;; Split file nodes into those that many have open, and those that only a few have open
+
+(define-values (popular-files loser-files)
+ (span (lambda (fn) (< 30 (length (file-node-procs fn))))
+ (map (lambda (name) (hash-ref file-nodes name))
+ (map car
+ (sort (hash-map->list cons freqs)
+ (lambda (a b) (> (cdr a) (cdr b))))))))
+
+;;; This allows us to focus on the "popular" nodes, and given them a subpgrah and color each
+
+(for-each (lambda (fn)
+ (define c (next-color))
+ (let ((sg (gv.graph g (symbol->string (gensym "graph")))))
+ ;; (gv.setv sg "layout" "circo")
+ (gv.setv sg "style" "dotted")
+ (let ((fn-node (gv.node sg (file-node-name fn))))
+ (gv.setv fn-node "fillcolor" c)
+ (gv.setv fn-node "style" "filled")
+ (for-each (lambda (proc)
+ (define gn-node (gv.node sg (proc-node-name proc)))
+ (define edge (gv.edge fn-node gn-node))
+ (gv.setv edge "color" c)
+ (gv.setv gn-node "shape" "box")
+ )
+ (file-node-procs fn)))))
+ popular-files)
+
+;;; Then just place the impopular nodes anywhere.
+
+;;; Note that this fails to account for busy programs, opening ALL THE FILES!
+
+(for-each (lambda (fn)
+ (let ((fn-node (gv.node g (file-node-name fn))))
+ (for-each (lambda (proc)
+ (define gn-node (gv.node g (proc-node-name proc)))
+ (define edge (gv.edge fn-node gn-node))
+ (gv.setv gn-node "shape" "box")
+ )
+ (file-node-procs fn)))
+
+ )
+ loser-files)
+
+(gv.layout g "neato")
+(gv.render g "dot" "out.dot")
+;; (gv.render g "png" "out.png")
+
+