summaryrefslogtreecommitdiff
path: root/read-proc.scm
blob: a09463ef21076cd34a20de80c866df2d38da1244 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
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 "sfdp")
(gv.render g "svg" "out.svg")
;; (gv.render g "png" "out.png")