480 lines
14 KiB
Perl
480 lines
14 KiB
Perl
package App::Netdisco::Util::Graph;
|
|
|
|
use App::Netdisco;
|
|
|
|
use Dancer qw/:syntax :script/;
|
|
use Dancer::Plugin::DBIC 'schema';
|
|
|
|
use App::Netdisco::Util::DNS qw/hostname_from_ip ipv4_from_hostname/;
|
|
use Graph::Undirected ();
|
|
use GraphViz ();
|
|
|
|
use base 'Exporter';
|
|
our @EXPORT = ('graph');
|
|
our @EXPORT_OK = qw/
|
|
graph_each
|
|
graph_addnode
|
|
make_graph
|
|
/;
|
|
our %EXPORT_TAGS = (all => \@EXPORT_OK);
|
|
|
|
# nothing to see here, please move along...
|
|
our ($ip, $label, $isdev, $devloc, %GRAPH, %GRAPH_SPEED);
|
|
|
|
=head1 NAME
|
|
|
|
App::Netdisco::Util::Graph
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
$ brew install graphviz <-- install graphviz on your system
|
|
|
|
$ ~/bin/localenv bash
|
|
$ cpanm --notest Graph GraphViz
|
|
$ mkdir ~/graph
|
|
|
|
use App::Netdisco::Util::Graph;
|
|
graph;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Generate GraphViz output from Netdisco data. Requires that the L<Graph> and
|
|
L<GraphViz> distributions be installed.
|
|
|
|
Requires the same config as for Netdisco 1, but within a C<graph> key. See
|
|
C<share/config.yml> in the source distribution for an example.
|
|
|
|
The C<graph> subroutine is exported by default. The C<:all> tag will export
|
|
all subroutines.
|
|
|
|
=head1 EXPORT
|
|
|
|
=over 4
|
|
|
|
=item graph()
|
|
|
|
Creates netmap of network.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub graph {
|
|
my %CONFIG = %{ setting('graph') };
|
|
|
|
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
|
|
my $month = sprintf("%d%02d",$year+1900,$mon+1);
|
|
|
|
info "graph() - Creating Graphs";
|
|
my $G = make_graph();
|
|
|
|
unless (defined $G){
|
|
print "graph() - make_graph() failed. Try running with debug (-D).\n";
|
|
return;
|
|
}
|
|
|
|
my @S = $G->connected_components;
|
|
|
|
# Count number of nodes in each subgraph
|
|
my %S_count;
|
|
for (my $i=0;$i< scalar @S;$i++){
|
|
$S_count{$i} = scalar @{$S[$i]};
|
|
}
|
|
|
|
foreach my $subgraph (sort { $S_count{$b} <=> $S_count{$a} } keys %S_count){
|
|
my $SUBG = $G->copy;
|
|
print "\$S[$subgraph] has $S_count{$subgraph} nodes.\n";
|
|
|
|
# Remove other subgraphs from this one
|
|
my %S_notme = %S_count;
|
|
delete $S_notme{$subgraph};
|
|
foreach my $other (keys %S_notme){
|
|
print "Removing Non-connected nodes: ",join(',',@{$S[$other]}),"\n";
|
|
$SUBG->delete_vertices(@{$S[$other]})
|
|
}
|
|
|
|
# Create the subgraph
|
|
my $timeout = defined $CONFIG{graph_timeout} ? $CONFIG{graph_timeout} : 60;
|
|
|
|
eval {
|
|
alarm($timeout*60);
|
|
graph_each($SUBG,'');
|
|
alarm(0);
|
|
};
|
|
if ($@) {
|
|
if ($@ =~ /timeout/){
|
|
print "! Creating Graph timed out!\n";
|
|
} else {
|
|
print "\n$@\n";
|
|
}
|
|
}
|
|
|
|
# Facility to create subgraph for each non-connected network segment.
|
|
# Right now, let's just make the biggest one only.
|
|
last;
|
|
}
|
|
}
|
|
|
|
=head1 EXPORT_OK
|
|
|
|
=over 4
|
|
|
|
=item graph_each($graph_obj, $name)
|
|
|
|
Generates subgraph. Does actual GraphViz calls.
|
|
|
|
=cut
|
|
|
|
sub graph_each {
|
|
my ($G, $name) = @_;
|
|
my %CONFIG = %{ setting('graph') };
|
|
info "Creating new Graph";
|
|
|
|
my $graph_defs = {
|
|
'bgcolor' => $CONFIG{graph_bg} || 'black',
|
|
'color' => $CONFIG{graph_color} || 'white',
|
|
'overlap' => $CONFIG{graph_overlap} || 'scale',
|
|
'fontpath'=> _homepath('graph_fontpath',''),
|
|
'ranksep' => $CONFIG{graph_ranksep} || 0.3,
|
|
'nodesep' => $CONFIG{graph_nodesep} || 2,
|
|
'ratio' => $CONFIG{graph_ratio} || 'compress',
|
|
'splines' => ($CONFIG{graph_splines} ? 'true' : 'false'),
|
|
'fontcolor' => $CONFIG{node_fontcolor} || 'white',
|
|
'fontname' => $CONFIG{node_font} || 'lucon',
|
|
'fontsize' => $CONFIG{node_fontsize} || 12,
|
|
};
|
|
my $edge_defs = {
|
|
'color' => $CONFIG{edge_color} || 'wheat',
|
|
};
|
|
my $node_defs = {
|
|
'shape' => $CONFIG{node_shape} || 'box',
|
|
'fillcolor' => $CONFIG{node_fillcolor} || 'dimgrey',
|
|
'fontcolor' => $CONFIG{node_fontcolor} || 'white',
|
|
'style' => $CONFIG{node_style} || 'filled',
|
|
'fontname' => $CONFIG{node_font} || 'lucon',
|
|
'fontsize' => $CONFIG{node_fontsize} || 12,
|
|
'fixedsize' => ($CONFIG{node_fixedsize} ? 'true' : 'false'),
|
|
};
|
|
$node_defs->{height} = $CONFIG{node_height} if defined $CONFIG{node_height};
|
|
$node_defs->{width} = $CONFIG{node_width} if defined $CONFIG{node_width};
|
|
|
|
my $epsilon = undef;
|
|
if (defined $CONFIG{graph_epsilon}){
|
|
$epsilon = "0." . '0' x $CONFIG{graph_epsilon} . '1';
|
|
}
|
|
|
|
my %gv = (
|
|
directed => 0,
|
|
layout => $CONFIG{graph_layout} || 'twopi',
|
|
graph => $graph_defs,
|
|
node => $node_defs,
|
|
edge => $edge_defs,
|
|
width => $CONFIG{graph_x} || 30,
|
|
height => $CONFIG{graph_y} || 30,
|
|
epsilon => $epsilon,
|
|
);
|
|
|
|
my $gv = GraphViz->new(%gv);
|
|
|
|
my %node_map = ();
|
|
my @nodes = $G->vertices;
|
|
|
|
foreach my $dev (@nodes){
|
|
my $node_name = graph_addnode($gv,$dev);
|
|
$node_map{$dev} = $node_name;
|
|
}
|
|
|
|
my $root_ip = defined $CONFIG{root_device}
|
|
? (ipv4_from_hostname($CONFIG{root_device}) || $CONFIG{root_device})
|
|
: undef;
|
|
|
|
if (defined $root_ip and defined $node_map{$root_ip}){
|
|
my $gv_root_name = $gv->_quote_name($root_ip);
|
|
if (defined $gv_root_name){
|
|
$gv->{GRAPH_ATTRS}->{root}=$gv_root_name;
|
|
}
|
|
}
|
|
|
|
my @edges = $G->edges;
|
|
|
|
while (my $e = shift @edges){
|
|
my $link = $e->[0];
|
|
my $dest = $e->[1];
|
|
my $speed = $GRAPH_SPEED{$link}->{$dest}->{speed};
|
|
|
|
if (!defined($speed)) {
|
|
info " ! No link speed for $link -> $dest";
|
|
$speed = 0;
|
|
}
|
|
|
|
my %edge = ();
|
|
my $val = ''; my $suffix = '';
|
|
|
|
if ($speed =~ /^([\d.]+)\s+([a-z])bps$/i) {
|
|
$val = $1; $suffix = $2;
|
|
}
|
|
|
|
if ( ($suffix eq 'k') or ($speed =~ m/(t1|ds3)/i) ){
|
|
$edge{color} = 'green';
|
|
$edge{style} = 'dotted';
|
|
}
|
|
|
|
if ($suffix eq 'M'){
|
|
if ($val < 10.0){
|
|
$edge{color} = 'green';
|
|
#$edge{style} = 'dotted';
|
|
$edge{style} = 'dashed';
|
|
} elsif ($val < 100.0){
|
|
$edge{color} = '#8b7e66';
|
|
#$edge{style} = 'normal';
|
|
$edge{style} = 'solid';
|
|
} else {
|
|
$edge{color} = '#ffe7ba';
|
|
$edge{style} = 'solid';
|
|
}
|
|
}
|
|
|
|
if ($suffix eq 'G'){
|
|
#$edge{style} = 'bold';
|
|
$edge{color} = 'cyan1';
|
|
}
|
|
|
|
# Add extra styles to edges (mainly for modifying width)
|
|
if(defined $CONFIG{edge_style}) {
|
|
$edge{style} .= "," . $CONFIG{edge_style};
|
|
}
|
|
|
|
$gv->add_edge($link => $dest, %edge );
|
|
}
|
|
|
|
info "Ignore all warnings about node size";
|
|
|
|
if (defined $CONFIG{graph_raw} and $CONFIG{graph_raw}){
|
|
my $graph_raw = _homepath('graph_raw');
|
|
info " Creating raw graph: $graph_raw";
|
|
$gv->as_canon($graph_raw);
|
|
}
|
|
|
|
if (defined $CONFIG{graph} and $CONFIG{graph}){
|
|
my $graph_gif = _homepath('graph');
|
|
info " Creating graph: $graph_gif";
|
|
$gv->as_gif($graph_gif);
|
|
}
|
|
|
|
if (defined $CONFIG{graph_png} and $CONFIG{graph_png}){
|
|
my $graph_png = _homepath('graph_png');
|
|
info " Creating png graph: $graph_png";
|
|
$gv->as_png($graph_png);
|
|
}
|
|
|
|
if (defined $CONFIG{graph_map} and $CONFIG{graph_map}){
|
|
my $graph_map = _homepath('graph_map');
|
|
info " Creating CMAP : $graph_map";
|
|
$gv->as_cmap($graph_map);
|
|
}
|
|
|
|
if (defined $CONFIG{graph_svg} and $CONFIG{graph_svg}){
|
|
my $graph_svg = _homepath('graph_svg');
|
|
info " Creating SVG : $graph_svg";
|
|
$gv->as_svg($graph_svg);
|
|
}
|
|
}
|
|
|
|
=item graph_addnode($graphviz_obj, $node_ip)
|
|
|
|
Checks for mapping settings in config file and adds node to the GraphViz
|
|
object.
|
|
|
|
=cut
|
|
|
|
sub graph_addnode {
|
|
my $gv = shift;
|
|
my %CONFIG = %{ setting('graph') };
|
|
my %node = ();
|
|
|
|
$ip = shift;
|
|
$label = $GRAPH{$ip}->{dns};
|
|
$isdev = $GRAPH{$ip}->{isdev};
|
|
$devloc = $GRAPH{$ip}->{location};
|
|
|
|
$label = "($ip)" unless defined $label;
|
|
my $domain_suffix = setting('domain_suffix') || '';
|
|
$label =~ s/$domain_suffix$//;
|
|
$node{label} = $label;
|
|
|
|
# Dereferencing the scalar by name below
|
|
# requires that the variable be non-lexical (not my)
|
|
# we'll create some local non-lexical versions
|
|
# that will expire at the end of this block
|
|
# Node Mappings
|
|
foreach my $map (@{ $CONFIG{'node_map'} || [] }){
|
|
my ($var, $regex, $attr, $val) = split(':', $map);
|
|
|
|
{ no strict 'refs';
|
|
$var = ${"$var"};
|
|
}
|
|
next unless defined $var;
|
|
|
|
if ($var =~ /$regex/) {
|
|
debug " graph_addnode - Giving node $ip $attr = $val";
|
|
$node{$attr} = $val;
|
|
}
|
|
}
|
|
|
|
# URL for image maps FIXME for non-root hosting
|
|
if ($isdev) {
|
|
$node{URL} = "/device?&q=$ip";
|
|
}
|
|
else {
|
|
$node{URL} = "/search?tab=node&q=$ip";
|
|
# Overrides any colors given to nodes above. Bug 1094208
|
|
$node{fillcolor} = $CONFIG{'node_problem'} || 'red';
|
|
}
|
|
|
|
if ($CONFIG{'graph_clusters'} && $devloc) {
|
|
# This odd construct works around a bug in GraphViz.pm's
|
|
# quoting of cluster names. If it has a name with spaces,
|
|
# it'll just quote it, resulting in creating a subgraph name
|
|
# of cluster_"location with spaces". This is an illegal name
|
|
# according to the dot grammar, so if the name matches the
|
|
# problematic regexp we make GraphViz.pm generate an internal
|
|
# name by using a leading space in the name.
|
|
#
|
|
# This is bug ID 16912 at rt.cpan.org -
|
|
# http://rt.cpan.org/NoAuth/Bug.html?id=16912
|
|
#
|
|
# Another bug, ID 11514, prevents us from using a combination
|
|
# of name and label attributes to hide the extra space from
|
|
# the user. However, since it's just a space, hopefully it
|
|
# won't be too noticable.
|
|
my($loc) = $devloc;
|
|
$loc = " " . $loc if ($loc =~ /^[a-zA-Z](\w| )*$/);
|
|
$node{cluster} = { name => $loc };
|
|
}
|
|
|
|
my $rv = $gv->add_node($ip, %node);
|
|
return $rv;
|
|
}
|
|
|
|
=item make_graph()
|
|
|
|
Returns C<Graph::Undirected> object that represents the discovered network.
|
|
|
|
Graph is made by loading all the C<device_port> entries that have a neighbor,
|
|
using them as edges. Then each device seen in those entries is added as a
|
|
vertex.
|
|
|
|
Nodes without topology information are not included.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub make_graph {
|
|
my $G = Graph::Undirected->new();
|
|
|
|
my $devices = schema('netdisco')->resultset('Device')
|
|
->search({}, { columns => [qw/ip dns location /] });
|
|
my $links = schema('netdisco')->resultset('DevicePort')
|
|
->search({remote_ip => { -not => undef }},
|
|
{ columns => [qw/ip remote_ip speed remote_type/]});
|
|
my %aliases = map {$_->alias => $_->ip}
|
|
schema('netdisco')->resultset('DeviceIp')
|
|
->search({}, { columns => [qw/ip alias/] })->all;
|
|
|
|
my %devs = ( map {($_->ip => $_->dns)} $devices->all );
|
|
my %locs = ( map {($_->ip => $_->location)} $devices->all );
|
|
|
|
# Check for no topology info
|
|
unless ($links->count > 0) {
|
|
debug "make_graph() - No topology information. skipping.";
|
|
return undef;
|
|
}
|
|
|
|
my %link_seen = ();
|
|
my %linkmap = ();
|
|
|
|
while (my $link = $links->next) {
|
|
my $source = $link->ip;
|
|
my $dest = $link->remote_ip;
|
|
my $speed = $link->speed;
|
|
my $type = $link->remote_type;
|
|
|
|
# Check for Aliases
|
|
if (defined $aliases{$dest}) {
|
|
# Set to root device
|
|
$dest = $aliases{$dest};
|
|
}
|
|
|
|
# Remove loopback - After alias check (bbaetz)
|
|
if ($source eq $dest) {
|
|
debug " make_graph() - Loopback on $source";
|
|
next;
|
|
}
|
|
|
|
# Skip IP Phones
|
|
if (defined $type and $type =~ /ip.phone/i) {
|
|
debug " make_graph() - Skipping IP Phone. $source -> $dest ($type)";
|
|
next;
|
|
}
|
|
next if exists $link_seen{$source}->{$dest};
|
|
|
|
push(@{ $linkmap{$source} }, $dest);
|
|
|
|
# take care of reverse too
|
|
$link_seen{$source}->{$dest}++;
|
|
$link_seen{$dest}->{$source}++;
|
|
|
|
$GRAPH_SPEED{$source}->{$dest}->{speed}=$speed;
|
|
$GRAPH_SPEED{$dest}->{$source}->{speed}=$speed;
|
|
}
|
|
|
|
foreach my $link (keys %linkmap) {
|
|
foreach my $dest (@{ $linkmap{$link} }) {
|
|
|
|
foreach my $side ($link, $dest) {
|
|
unless (defined $GRAPH{$side}) {
|
|
my $is_dev = exists $devs{$side};
|
|
my $dns = $is_dev ?
|
|
$devs{$side} :
|
|
hostname_from_ip($side);
|
|
|
|
# Default to IP if no dns
|
|
$dns = defined $dns ? $dns : "($side)";
|
|
|
|
$G->add_vertex($side);
|
|
debug " make_graph() - add_vertex('$side')";
|
|
|
|
$GRAPH{$side}->{dns} = $dns;
|
|
$GRAPH{$side}->{isdev} = $is_dev;
|
|
$GRAPH{$side}->{seen}++;
|
|
$GRAPH{$side}->{location} = $locs{$side};
|
|
}
|
|
}
|
|
|
|
$G->add_edge($link,$dest);
|
|
debug " make_graph - add_edge('$link','$dest')";
|
|
}
|
|
}
|
|
|
|
return $G;
|
|
}
|
|
|
|
sub _homepath {
|
|
my ($path, $default) = @_;
|
|
|
|
my $home = $ENV{NETDISCO_HOME};
|
|
my $item = setting('graph')->{$path} || $default;
|
|
return undef unless defined($item);
|
|
|
|
if ($item =~ m,^/,) {
|
|
return $item;
|
|
}
|
|
else {
|
|
$home =~ s,/*$,,;
|
|
return $home . "/" . $item;
|
|
}
|
|
}
|
|
|
|
1;
|