1package App::Netdisco::Util::Graph;
2
3use App::Netdisco;
4
5use Dancer qw/:syntax :script/;
6use Dancer::Plugin::DBIC 'schema';
7
8use App::Netdisco::Util::DNS qw/hostname_from_ip ipv4_from_hostname/;
9use Graph::Undirected ();
10use GraphViz ();
11
12use base 'Exporter';
13our @EXPORT = ('graph');
14our @EXPORT_OK = qw/
15  graph_each
16  graph_addnode
17  make_graph
18/;
19our %EXPORT_TAGS = (all => \@EXPORT_OK);
20
21# nothing to see here, please move along...
22our ($ip, $label, $isdev, $devloc, %GRAPH, %GRAPH_SPEED);
23
24=head1 NAME
25
26App::Netdisco::Util::Graph
27
28=head1 SYNOPSIS
29
30 $ brew install graphviz   <-- install graphviz on your system
31
32 $ ~/bin/localenv bash
33 $ cpanm --notest Graph GraphViz
34 $ mkdir ~/graph
35
36 use App::Netdisco::Util::Graph;
37 graph;
38
39=head1 DESCRIPTION
40
41Generate GraphViz output from Netdisco data. Requires that the L<Graph> and
42L<GraphViz> distributions be installed.
43
44Requires the same config as for Netdisco 1, but within a C<graph> key.  See
45C<share/config.yml> in the source distribution for an example.
46
47The C<graph> subroutine is exported by default. The C<:all> tag will export
48all subroutines.
49
50=head1 EXPORT
51
52=over 4
53
54=item graph()
55
56Creates netmap of network.
57
58=back
59
60=cut
61
62sub graph {
63    my %CONFIG = %{ setting('graph') };
64
65    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
66    my $month = sprintf("%d%02d",$year+1900,$mon+1);
67
68    info "graph() - Creating Graphs";
69    my $G = make_graph();
70
71    unless (defined $G){
72        print "graph() - make_graph() failed.  Try running with debug (-D).\n";
73        return;
74    }
75
76    my @S = $G->connected_components;
77
78    # Count number of nodes in each subgraph
79    my %S_count;
80    for (my $i=0;$i< scalar @S;$i++){
81        $S_count{$i} = scalar @{$S[$i]};
82    }
83
84    foreach my $subgraph (sort { $S_count{$b} <=> $S_count{$a} } keys %S_count){
85        my $SUBG = $G->copy;
86        print "\$S[$subgraph] has $S_count{$subgraph} nodes.\n";
87
88        # Remove other subgraphs from this one
89        my %S_notme = %S_count;
90        delete $S_notme{$subgraph};
91        foreach my $other (keys %S_notme){
92            print "Removing Non-connected nodes: ",join(',',@{$S[$other]}),"\n";
93            $SUBG->delete_vertices(@{$S[$other]})
94        }
95
96        # Create the subgraph
97        my $timeout = defined $CONFIG{graph_timeout} ? $CONFIG{graph_timeout} : 60;
98
99        eval {
100            alarm($timeout*60);
101            graph_each($SUBG,'');
102            alarm(0);
103        };
104        if ($@) {
105            if ($@ =~ /timeout/){
106                print "! Creating Graph timed out!\n";
107            } else {
108                print "\n$@\n";
109            }
110        }
111
112        # Facility to create subgraph for each non-connected network segment.
113        # Right now, let's just make the biggest one only.
114        last;
115    }
116}
117
118=head1 EXPORT_OK
119
120=over 4
121
122=item graph_each($graph_obj, $name)
123
124Generates subgraph. Does actual GraphViz calls.
125
126=cut
127
128sub graph_each  {
129    my ($G, $name) = @_;
130    my %CONFIG = %{ setting('graph') };
131    info "Creating new Graph";
132
133    my $graph_defs = {
134                     'bgcolor' => $CONFIG{graph_bg}         || 'black',
135                     'color'   => $CONFIG{graph_color}      || 'white',
136                     'overlap' => $CONFIG{graph_overlap}    || 'scale',
137                     'fontpath'=> _homepath('graph_fontpath',''),
138                     'ranksep' => $CONFIG{graph_ranksep}    || 0.3,
139                     'nodesep' => $CONFIG{graph_nodesep}    || 2,
140                     'ratio'   => $CONFIG{graph_ratio}      || 'compress',
141                     'splines' => ($CONFIG{graph_splines} ? 'true' : 'false'),
142                     'fontcolor' => $CONFIG{node_fontcolor} || 'white',
143                     'fontname'  => $CONFIG{node_font}      || 'lucon',
144                     'fontsize'  => $CONFIG{node_fontsize}  || 12,
145                     };
146    my $edge_defs  = {
147                     'color' => $CONFIG{edge_color}         || 'wheat',
148                     };
149    my $node_defs  = {
150                     'shape'     => $CONFIG{node_shape}     || 'box',
151                     'fillcolor' => $CONFIG{node_fillcolor} || 'dimgrey',
152                     'fontcolor' => $CONFIG{node_fontcolor} || 'white',
153                     'style'     => $CONFIG{node_style}     || 'filled',
154                     'fontname'  => $CONFIG{node_font}      || 'lucon',
155                     'fontsize'  => $CONFIG{node_fontsize}  || 12,
156                     'fixedsize' => ($CONFIG{node_fixedsize} ? 'true' : 'false'),
157                     };
158    $node_defs->{height} = $CONFIG{node_height} if defined $CONFIG{node_height};
159    $node_defs->{width}  = $CONFIG{node_width}  if defined $CONFIG{node_width};
160
161    my $epsilon = undef;
162    if (defined $CONFIG{graph_epsilon}){
163        $epsilon = "0." . '0' x $CONFIG{graph_epsilon} . '1';
164    }
165
166    my %gv = (
167               directed => 0,
168               layout   => $CONFIG{graph_layout} || 'twopi',
169               graph    => $graph_defs,
170               node     => $node_defs,
171               edge     => $edge_defs,
172               width    => $CONFIG{graph_x}      || 30,
173               height   => $CONFIG{graph_y}      || 30,
174               epsilon  => $epsilon,
175              );
176
177    my $gv = GraphViz->new(%gv);
178
179    my %node_map = ();
180    my @nodes = $G->vertices;
181
182    foreach my $dev (@nodes){
183        my $node_name = graph_addnode($gv,$dev);
184        $node_map{$dev} = $node_name;
185    }
186
187    my $root_ip = defined $CONFIG{root_device}
188      ? (ipv4_from_hostname($CONFIG{root_device}) || $CONFIG{root_device})
189      : undef;
190
191    if (defined $root_ip and defined $node_map{$root_ip}){
192        my $gv_root_name = $gv->_quote_name($root_ip);
193        if (defined $gv_root_name){
194            $gv->{GRAPH_ATTRS}->{root}=$gv_root_name;
195        }
196    }
197
198    my @edges = $G->edges;
199
200    while (my $e = shift @edges){
201        my $link = $e->[0];
202        my $dest = $e->[1];
203        my $speed = $GRAPH_SPEED{$link}->{$dest}->{speed};
204
205        if (!defined($speed)) {
206            info "  ! No link speed for $link -> $dest";
207            $speed = 0;
208        }
209
210        my %edge = ();
211        my $val = ''; my $suffix = '';
212
213        if ($speed =~ /^([\d.]+)\s+([a-z])bps$/i) {
214            $val = $1; $suffix = $2;
215        }
216
217        if ( ($suffix eq 'k') or ($speed =~ m/(t1|ds3)/i) ){
218            $edge{color} = 'green';
219            $edge{style} = 'dotted';
220        }
221
222        if ($suffix eq 'M'){
223            if ($val < 10.0){
224                $edge{color} = 'green';
225                #$edge{style} = 'dotted';
226                $edge{style} = 'dashed';
227            } elsif ($val < 100.0){
228                $edge{color} = '#8b7e66';
229                #$edge{style} = 'normal';
230                $edge{style} = 'solid';
231            } else {
232                $edge{color} = '#ffe7ba';
233                $edge{style} = 'solid';
234            }
235        }
236
237        if ($suffix eq 'G'){
238            #$edge{style} = 'bold';
239            $edge{color} = 'cyan1';
240        }
241
242        # Add extra styles to edges (mainly for modifying width)
243        if(defined $CONFIG{edge_style}) {
244            $edge{style} .= "," . $CONFIG{edge_style};
245        }
246
247        $gv->add_edge($link => $dest, %edge );
248    }
249
250    info "Ignore all warnings about node size";
251
252    if (defined $CONFIG{graph_raw} and $CONFIG{graph_raw}){
253        my $graph_raw = _homepath('graph_raw');
254        info "  Creating raw graph: $graph_raw";
255        $gv->as_canon($graph_raw);
256    }
257
258    if (defined $CONFIG{graph} and $CONFIG{graph}){
259        my $graph_gif = _homepath('graph');
260        info "  Creating graph: $graph_gif";
261        $gv->as_gif($graph_gif);
262    }
263
264    if (defined $CONFIG{graph_png} and $CONFIG{graph_png}){
265        my $graph_png = _homepath('graph_png');
266        info "  Creating png graph: $graph_png";
267        $gv->as_png($graph_png);
268    }
269
270    if (defined $CONFIG{graph_map} and $CONFIG{graph_map}){
271        my $graph_map = _homepath('graph_map');
272        info "  Creating CMAP : $graph_map";
273        $gv->as_cmap($graph_map);
274    }
275
276    if (defined $CONFIG{graph_svg} and $CONFIG{graph_svg}){
277        my $graph_svg = _homepath('graph_svg');
278        info "  Creating SVG : $graph_svg";
279        $gv->as_svg($graph_svg);
280    }
281}
282
283=item graph_addnode($graphviz_obj, $node_ip)
284
285Checks for mapping settings in config file and adds node to the GraphViz
286object.
287
288=cut
289
290sub graph_addnode {
291    my $gv = shift;
292    my %CONFIG = %{ setting('graph') };
293    my %node = ();
294
295    $ip     = shift;
296    $label  = $GRAPH{$ip}->{dns};
297    $isdev  = $GRAPH{$ip}->{isdev};
298    $devloc = $GRAPH{$ip}->{location};
299
300    $label = "($ip)" unless defined $label;
301    my $domain_suffix = setting('domain_suffix');
302    $label =~ s/$domain_suffix//;
303    $node{label} = $label;
304
305    # Dereferencing the scalar by name below
306    #   requires that the variable be non-lexical (not my)
307    #   we'll create some local non-lexical versions
308    #   that will expire at the end of this block
309    # Node Mappings
310    foreach my $map (@{ $CONFIG{'node_map'} || [] }){
311        my ($var, $regex, $attr, $val) = split(':', $map);
312
313        { no strict 'refs';
314           $var = ${"$var"};
315        }
316        next unless defined $var;
317
318        if ($var =~ /$regex/) {
319            debug "  graph_addnode - Giving node $ip $attr = $val";
320            $node{$attr} = $val;
321        }
322    }
323
324    # URL for image maps FIXME for non-root hosting
325    if ($isdev) {
326        $node{URL} = "/device?&q=$ip";
327    }
328    else {
329        $node{URL} = "/search?tab=node&q=$ip";
330        # Overrides any colors given to nodes above. Bug 1094208
331        $node{fillcolor} = $CONFIG{'node_problem'} || 'red';
332    }
333
334    if ($CONFIG{'graph_clusters'} && $devloc) {
335        # This odd construct works around a bug in GraphViz.pm's
336        # quoting of cluster names.  If it has a name with spaces,
337        # it'll just quote it, resulting in creating a subgraph name
338        # of cluster_"location with spaces".  This is an illegal name
339        # according to the dot grammar, so if the name matches the
340        # problematic regexp we make GraphViz.pm generate an internal
341        # name by using a leading space in the name.
342        #
343        # This is bug ID 16912 at rt.cpan.org -
344        # http://rt.cpan.org/NoAuth/Bug.html?id=16912
345        #
346        # Another bug, ID 11514, prevents us from using a combination
347        # of name and label attributes to hide the extra space from
348        # the user.  However, since it's just a space, hopefully it
349        # won't be too noticable.
350        my($loc) = $devloc;
351        $loc = " " . $loc if ($loc =~ /^[a-zA-Z](\w| )*$/);
352        $node{cluster} = { name => $loc };
353    }
354
355    my $rv = $gv->add_node($ip, %node);
356    return $rv;
357}
358
359=item make_graph()
360
361Returns C<Graph::Undirected> object that represents the discovered network.
362
363Graph is made by loading all the C<device_port> entries that have a neighbor,
364using them as edges. Then each device seen in those entries is added as a
365vertex.
366
367Nodes without topology information are not included.
368
369=back
370
371=cut
372
373sub make_graph {
374    my $G = Graph::Undirected->new();
375
376    my $devices = schema('netdisco')->resultset('Device')
377        ->search({}, { columns => [qw/ip dns location /] });
378    my $links = schema('netdisco')->resultset('DevicePort')
379        ->search({remote_ip => { -not => undef }},
380                 { columns => [qw/ip remote_ip speed remote_type/]});
381    my %aliases = map {$_->alias => $_->ip}
382        schema('netdisco')->resultset('DeviceIp')
383          ->search({}, { columns => [qw/ip alias/] })->all;
384
385    my %devs = ( map {($_->ip => $_->dns)}      $devices->all );
386    my %locs = ( map {($_->ip => $_->location)} $devices->all );
387
388    # Check for no topology info
389    unless ($links->count > 0) {
390        debug "make_graph() - No topology information. skipping.";
391        return undef;
392    }
393
394    my %link_seen = ();
395    my %linkmap   = ();
396
397    while (my $link = $links->next) {
398        my $source = $link->ip;
399        my $dest   = $link->remote_ip;
400        my $speed  = $link->speed;
401        my $type   = $link->remote_type;
402
403        # Check for Aliases
404        if (defined $aliases{$dest}) {
405            # Set to root device
406            $dest = $aliases{$dest};
407        }
408
409        # Remove loopback - After alias check (bbaetz)
410        if ($source eq $dest) {
411            debug "  make_graph() - Loopback on $source";
412            next;
413        }
414
415        # Skip IP Phones
416        if (defined $type and $type =~ /ip.phone/i) {
417            debug "  make_graph() - Skipping IP Phone. $source -> $dest ($type)";
418            next;
419        }
420        next if exists $link_seen{$source}->{$dest};
421
422        push(@{ $linkmap{$source} }, $dest);
423
424        # take care of reverse too
425        $link_seen{$source}->{$dest}++;
426        $link_seen{$dest}->{$source}++;
427
428        $GRAPH_SPEED{$source}->{$dest}->{speed}=$speed;
429        $GRAPH_SPEED{$dest}->{$source}->{speed}=$speed;
430    }
431
432    foreach my $link (keys %linkmap) {
433        foreach my $dest (@{ $linkmap{$link} }) {
434
435            foreach my $side ($link, $dest) {
436                unless (defined $GRAPH{$side}) {
437                    my $is_dev = exists $devs{$side};
438                    my $dns = $is_dev ?
439                              $devs{$side} :
440                              hostname_from_ip($side);
441
442                    # Default to IP if no dns
443                    $dns = defined $dns ? $dns : "($side)";
444
445                    $G->add_vertex($side);
446                    debug "  make_graph() - add_vertex('$side')";
447
448                    $GRAPH{$side}->{dns} = $dns;
449                    $GRAPH{$side}->{isdev} = $is_dev;
450                    $GRAPH{$side}->{seen}++;
451                    $GRAPH{$side}->{location} = $locs{$side};
452                }
453            }
454
455            $G->add_edge($link,$dest);
456            debug "  make_graph - add_edge('$link','$dest')";
457        }
458    }
459
460    return $G;
461}
462
463sub _homepath {
464    my ($path, $default) = @_;
465
466    my $home = $ENV{NETDISCO_HOME};
467    my $item = setting('graph')->{$path} || $default;
468    return undef unless defined($item);
469
470    if ($item =~ m,^/,) {
471        return $item;
472    }
473    else {
474        $home =~ s,/*$,,;
475        return $home . "/" . $item;
476    }
477}
478
4791;
480