From 9eead9118dabe93d4958ae6caf81ef9871c6c62f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 11 Feb 2021 01:06:15 +0100 Subject: Initial commit. --- graphviz.scm | 84 ++++++++++++++++++++++++++++++++++++++ read-proc.scm | 129 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ run.sh | 3 ++ 3 files changed, 216 insertions(+) create mode 100644 graphviz.scm create mode 100644 read-proc.scm create mode 100755 run.sh diff --git a/graphviz.scm b/graphviz.scm new file mode 100644 index 0000000..0c75f3f --- /dev/null +++ b/graphviz.scm @@ -0,0 +1,84 @@ +;;; Copyright © 2016 Roel Janssen +;;; +;;; This program 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. +;;; +;;; This program 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 this program. If not, see . + +;;; https://github.com/roelj/graphviz-guile/blob/master/graphviz.scm + +(define-module (graphviz) + #:export (;; New graphs + graph + digraph + strictgraph + strictdigraph + readstring + read + + ;; New nodes/edges + node + edge + + ;; Setting/getting attribute values + setv + getv + + ;; Finding and obtaining names + nameof + findsubg + findnode + findedge + findattr + + ;; Graph navigators + headof + tailof + graphof + rootof + + ;; Obtain handles of proto node/edge for setting attribute values + protonode + protoedge + + ;; Iterators + ok + firstsubg + nextsubg + firstsupg + nextsupg + firstedge + nextedge + firstout + nextout + firsthead + nexthead + firstin + nextin + firstnode + nextnode + firstattr + nextattr + + ;; Remove graph objects + rm + + ;; Layout + layout + render + renderresult + renderchannel + renderdata + write)) + +;; (load-extension "libgv_guile.so" "SWIG_init") + +(load-extension "/usr/lib/graphviz/guile/libgv_guile.so" "SWIG_init") 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 "#~%" 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") + + diff --git a/run.sh b/run.sh new file mode 100755 index 0000000..bdb475c --- /dev/null +++ b/run.sh @@ -0,0 +1,3 @@ +#!/bin/bash +sudo GUILE_LOAD_PATH=. guile -s read-proc.scm +neato -Tsvg out.dot > out.svg -- cgit v1.2.3