netdisco/lib/App/Netdisco/Util/Graph.pm

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;