135/netdisco
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

relocate repo files so ND2 is the only code

Browse Source
This commit is contained in:
Oliver Gorwits
2017-04-14 23:08:55 +01:00
parent 9a016ea6ba
commit d23b32500f
469 changed files with 0 additions and 6920 deletions
Download Patch File Download Diff File Expand all files Collapse all files

183
lib/App/Netdisco/Util/DNS.pm Normal file
View File

@@ -0,0 +1,183 @@
package App::Netdisco::Util::DNS;
use strict;
use warnings;
use Dancer ':script';
use Net::DNS;
use AnyEvent::DNS;
use NetAddr::IP::Lite ':lower';
use base 'Exporter';
our @EXPORT = ();
our @EXPORT_OK = qw/
hostname_from_ip hostnames_resolve_async ipv4_from_hostname
/;
our %EXPORT_TAGS = (all => \@EXPORT_OK);
# AE::DNS::EtcHosts only works for A/AAAA/SRV, but we want PTR.
# this loads+parses /etc/hosts file using AE. dirty hack.
use AnyEvent::Socket 'format_address';
use AnyEvent::DNS::EtcHosts;
AnyEvent::DNS::EtcHosts::_load_hosts_unless(sub{},AE::cv);
no AnyEvent::DNS::EtcHosts; # unimport
our %HOSTS = ();
$HOSTS{$_} = [ map { [ $_ ? (format_address $_->[0]) : '' ] }
@{$AnyEvent::DNS::EtcHosts::HOSTS{$_}} ]
for keys %AnyEvent::DNS::EtcHosts::HOSTS;
=head1 NAME
App::Netdisco::Util::DNS
=head1 DESCRIPTION
A set of helper subroutines to support parts of the Netdisco application.
There are no default exports, however the C<:all> tag will export all
subroutines.
=head1 EXPORT_OK
=head2 hostname_from_ip( $ip )
Given an IP address (either IPv4 or IPv6), return the canonical hostname.
Returns C<undef> if no PTR record exists for the IP.
=cut
sub hostname_from_ip {
my $ip = shift;
return unless $ip;
# check /etc/hosts file and short-circuit if found
foreach my $name (reverse sort keys %HOSTS) {
if ($HOSTS{$name}->[0]->[0] eq $ip) {
return $name;
}
}
my $res = Net::DNS::Resolver->new;
my $query = $res->search($ip);
if ($query) {
foreach my $rr ($query->answer) {
next unless $rr->type eq "PTR";
return $rr->ptrdname;
}
}
return undef;
}
=head2 ipv4_from_hostname( $name )
Given a host name will return the first IPv4 address.
Returns C<undef> if no A record exists for the name.
=cut
sub ipv4_from_hostname {
my $name = shift;
return unless $name;
# check /etc/hosts file and short-circuit if found
if (exists $HOSTS{$name} and $HOSTS{$name}->[0]->[0]) {
my $ip = NetAddr::IP::Lite->new($HOSTS{$name}->[0]->[0]);
return $ip->addr if $ip and $ip->bits == 32;
}
my $res = Net::DNS::Resolver->new;
my $query = $res->search($name);
if ($query) {
foreach my $rr ($query->answer) {
next unless $rr->type eq "A";
return $rr->address;
}
}
return undef;
}
=head2 hostnames_resolve_async( $ips )
This method uses a fully asynchronous and high-performance pure-perl stub
resolver C<AnyEvent::DNS>.
Given a reference to an array of hashes will resolve the C<IPv4> or C<IPv6>
address in the C<ip> or C<alias> key of each hash into its hostname which
will be inserted in the C<dns> key of the hash.
Returns the supplied reference to an array of hashes with dns values for
addresses which resolved.
=cut
sub hostnames_resolve_async {
my $ips = shift;
# Set up the condvar
my $done = AE::cv;
$done->begin( sub { shift->send } );
IP: foreach my $hash_ref (@$ips) {
my $ip = $hash_ref->{'ip'} || $hash_ref->{'alias'};
next IP if no_resolve($ip);
# check /etc/hosts file and short-circuit if found
foreach my $name (reverse sort keys %HOSTS) {
if ($HOSTS{$name}->[0]->[0] eq $ip) {
$hash_ref->{'dns'} = $name;
next IP;
}
}
$done->begin;
AnyEvent::DNS::reverse_lookup $ip,
sub { $hash_ref->{'dns'} = shift; $done->end; };
}
# Decrement the cv counter to cancel out the send declaration
$done->end;
# Wait for the resolver to perform all resolutions
$done->recv;
# Remove reference to resolver so that we close sockets
undef $AnyEvent::DNS::RESOLVER if $AnyEvent::DNS::RESOLVER;
return $ips;
}
=head2 no_resolve( $ip )
Given an IP address, returns true if excluded from DNS resolution by the
C<dns_no> configuration directive, otherwise returns false.
=cut
sub no_resolve {
my $ip = shift;
my $config = setting('dns')->{no} || [];
return 0 if not scalar @$config;
my $addr = NetAddr::IP::Lite->new($ip)
or return 1;
foreach my $item (@$config) {
my $c_ip = NetAddr::IP::Lite->new($item)
or next;
next unless $c_ip->bits == $addr->bits;
return 1 if ($c_ip->contains($addr));
}
return 0;
}
1;

38
lib/App/Netdisco/Util/Daemon.pm Normal file
View File

@@ -0,0 +1,38 @@
package App::Netdisco::Util::Daemon;
use strict;
use warnings;
use MCE::Util ();
# make sure this is already done elsewhere
use if $^O eq 'linux', 'Sys::Proctitle';
use base 'Exporter';
our @EXPORT = qw/prctl parse_max_workers/;
sub prctl {
if ($^O eq 'linux') {
Sys::Proctitle::setproctitle(shift);
}
else {
$0 = shift;
}
}
sub parse_max_workers {
my $max = shift;
return 0 if !defined $max;
if ($max =~ /^auto(?:$|\s*([\-\+\/\*])\s*(.+)$)/i) {
my $ncpu = MCE::Util::get_ncpu() || 0;
if ($1 and $2) {
local $@; $max = eval "int($ncpu $1 $2 + 0.5)";
}
}
return $max || 0;
}
1;

304
lib/App/Netdisco/Util/Device.pm Normal file
View File

@@ -0,0 +1,304 @@
package App::Netdisco::Util::Device;
use Dancer qw/:syntax :script/;
use Dancer::Plugin::DBIC 'schema';
use App::Netdisco::Util::Permission 'check_acl';
use base 'Exporter';
our @EXPORT = ();
our @EXPORT_OK = qw/
get_device
delete_device
renumber_device
match_devicetype
check_device_no
check_device_only
is_discoverable
is_arpnipable
is_macsuckable
/;
our %EXPORT_TAGS = (all => \@EXPORT_OK);
=head1 NAME
App::Netdisco::Util::Device
=head1 DESCRIPTION
A set of helper subroutines to support parts of the Netdisco application.
There are no default exports, however the C<:all> tag will export all
subroutines.
=head1 EXPORT_OK
=head2 get_device( $ip )
Given an IP address, returns a L<DBIx::Class::Row> object for the Device in
the Netdisco database. The IP can be for any interface on the device.
If for any reason C<$ip> is already a C<DBIx::Class> Device object, then it is
simply returned.
If the device or interface IP is not known to Netdisco a new Device object is
created for the IP, and returned. This object is in-memory only and not yet
stored to the database.
=cut
sub get_device {
my $ip = shift;
return unless $ip;
# naive check for existing DBIC object
return $ip if ref $ip;
# in case the management IP of one device is in use on another device,
# we first try to get an exact match for the IP as mgmt interface.
my $alias =
schema('netdisco')->resultset('DeviceIp')->find($ip, $ip)
||
schema('netdisco')->resultset('DeviceIp')->search({alias => $ip})->first;
$ip = $alias->ip if defined $alias;
return schema('netdisco')->resultset('Device')->with_times
->find_or_new({ip => $ip});
}
=head2 delete_device( $ip, $archive? )
Given an IP address, deletes the device from Netdisco, including all related
data such as logs and nodes. If the C<$archive> parameter is true, then nodes
will be maintained in an archive state.
Returns true if the transaction completes, else returns false.
=cut
sub delete_device {
my ($ip, $archive, $log) = @_;
my $device = get_device($ip) or return 0;
return 0 if not $device->in_storage;
my $happy = 0;
schema('netdisco')->txn_do(sub {
# will delete everything related too...
schema('netdisco')->resultset('Device')
->search({ ip => $device->ip })->delete({archive_nodes => $archive});
schema('netdisco')->resultset('UserLog')->create({
username => session('logged_in_user'),
userip => scalar eval {request->remote_address},
event => (sprintf "Delete device %s", $device->ip),
details => $log,
});
$happy = 1;
});
return $happy;
}
=head2 renumber_device( $current_ip, $new_ip )
Will update all records in Netdisco referring to the device with
C<$current_ip> to use C<$new_ip> instead, followed by renumbering the device
iteself.
Returns true if the transaction completes, else returns false.
=cut
sub renumber_device {
my ($ip, $new_ip) = @_;
my $device = get_device($ip) or return 0;
return 0 if not $device->in_storage;
my $happy = 0;
schema('netdisco')->txn_do(sub {
$device->renumber($new_ip)
or die "cannot renumber to: $new_ip"; # rollback
schema('netdisco')->resultset('UserLog')->create({
username => session('logged_in_user'),
userip => scalar eval {request->remote_address},
event => (sprintf "Renumber device %s to %s", $device->ip, $new_ip),
});
$happy = 1;
});
return $happy;
}
=head2 match_devicetype( $type, $setting_name )
Given a C<$type> (which may be any text value), returns true if any of the
list of regular expressions in C<$setting_name> is matched, otherwise returns
false.
=cut
sub match_devicetype {
my ($type, $setting_name) = @_;
return 0 unless $type and $setting_name;
return (scalar grep {$type =~ m/$_/}
@{setting($setting_name) || []});
}
=head2 check_device_no( $ip, $setting_name )
Given the IP address of a device, returns true if the configuration setting
C<$setting_name> matches that device, else returns false. If the setting
is undefined or empty, then C<check_device_no> also returns false.
See L<App::Netdisco::Util::Permission/check_acl> for details of what
C<$setting_name> can contain.
=cut
sub check_device_no {
my ($ip, $setting_name) = @_;
return 0 unless $ip and $setting_name;
my $device = get_device($ip) or return 0;
my $config = setting($setting_name) || [];
return 0 if not scalar @$config;
return check_acl($device, $config);
}
=head2 check_device_only( $ip, $setting_name )
Given the IP address of a device, returns true if the configuration setting
C<$setting_name> matches that device, else returns false. If the setting
is undefined or empty, then C<check_device_only> also returns true.
See L<App::Netdisco::Util::Permission/check_acl> for details of what
C<$setting_name> can contain.
=cut
sub check_device_only {
my ($ip, $setting_name) = @_;
my $device = get_device($ip) or return 0;
my $config = setting($setting_name) || [];
return 1 if not scalar @$config;
return check_acl($device, $config);
}
=head2 is_discoverable( $ip, $device_type? )
Given an IP address, returns C<true> if Netdisco on this host is permitted by
the local configuration to discover the device.
The configuration items C<discover_no> and C<discover_only> are checked
against the given IP.
If C<$device_type> is also given, then C<discover_no_type> will also be
checked.
Returns false if the host is not permitted to discover the target device.
=cut
sub _bail_msg { debug $_[0]; return 0; }
sub is_discoverable {
my ($ip, $remote_type) = @_;
my $device = get_device($ip) or return 0;
if (match_devicetype($remote_type, 'discover_no_type')) {
return _bail_msg("is_discoverable: device matched discover_no_type");
}
return _bail_msg("is_discoverable: device matched discover_no")
if check_device_no($device, 'discover_no');
return _bail_msg("is_discoverable: device failed to match discover_only")
unless check_device_only($device, 'discover_only');
# cannot check last_discover for as yet undiscovered devices :-)
return 1 if not $device->in_storage;
if ($device->since_last_discover and setting('discover_min_age')
and $device->since_last_discover < setting('discover_min_age')) {
return _bail_msg("is_discoverable: time since last discover less than discover_min_age");
}
return 1;
}
=head2 is_arpnipable( $ip )
Given an IP address, returns C<true> if Netdisco on this host is permitted by
the local configuration to arpnip the device.
The configuration items C<arpnip_no> and C<arpnip_only> are checked
against the given IP.
Returns false if the host is not permitted to arpnip the target device.
=cut
sub is_arpnipable {
my $ip = shift;
my $device = get_device($ip) or return 0;
return _bail_msg("is_arpnipable: device matched arpnip_no")
if check_device_no($device, 'arpnip_no');
return _bail_msg("is_arpnipable: device failed to match arpnip_only")
unless check_device_only($device, 'arpnip_only');
return _bail_msg("is_arpnipable: cannot arpnip an undiscovered device")
if not $device->in_storage;
if ($device->since_last_arpnip and setting('arpnip_min_age')
and $device->since_last_arpnip < setting('arpnip_min_age')) {
return _bail_msg("is_arpnipable: time since last arpnip less than arpnip_min_age");
}
return 1;
}
=head2 is_macsuckable( $ip )
Given an IP address, returns C<true> if Netdisco on this host is permitted by
the local configuration to macsuck the device.
The configuration items C<macsuck_no> and C<macsuck_only> are checked
against the given IP.
Returns false if the host is not permitted to macsuck the target device.
=cut
sub is_macsuckable {
my $ip = shift;
my $device = get_device($ip) or return 0;
return _bail_msg("is_macsuckable: device matched macsuck_no")
if check_device_no($device, 'macsuck_no');
return _bail_msg("is_macsuckable: device failed to match macsuck_only")
unless check_device_only($device, 'macsuck_only');
return _bail_msg("is_macsuckable: cannot macsuck an undiscovered device")
if not $device->in_storage;
if ($device->since_last_macsuck and setting('macsuck_min_age')
and $device->since_last_macsuck < setting('macsuck_min_age')) {
return _bail_msg("is_macsuckable: time since last macsuck less than macsuck_min_age");
}
return 1;
}
1;

39
lib/App/Netdisco/Util/ExpandParams.pm Normal file
View File

@@ -0,0 +1,39 @@
package App::Netdisco::Util::ExpandParams;
use base qw/CGI::Expand/;
use strict;
use warnings;
sub max_array {0}
sub separator {'.[]'}
sub split_name {
my $class = shift;
my $name = shift;
$name =~ /^ ([^\[\]\.]+) /xg;
my @segs = $1;
push @segs, ( $name =~ / \G (?: \[ ([^\[\]\.]+) \] ) /xg );
return @segs;
}
sub join_name {
my $class = shift;
my ( $first, @segs ) = @_;
return $first unless @segs;
return "$first\[" . join( '][', @segs ) . "]";
}
1;
__END__
=head1 NAME
App::Netdisco::Util::ExpandParams
=head1 DESCRIPTION
CGI::Expand subclass with Rails like tokenization for parameters passed
during DataTables server-side processing.
=cut

479
lib/App/Netdisco/Util/Graph.pm Normal file
View File

@@ -0,0 +1,479 @@
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;

232
lib/App/Netdisco/Util/Node.pm Normal file
View File

@@ -0,0 +1,232 @@
package App::Netdisco::Util::Node;
use Dancer qw/:syntax :script/;
use Dancer::Plugin::DBIC 'schema';
use NetAddr::MAC;
use App::Netdisco::Util::Permission 'check_acl';
use base 'Exporter';
our @EXPORT = ();
our @EXPORT_OK = qw/
check_mac
check_node_no
check_node_only
is_nbtstatable
/;
our %EXPORT_TAGS = (all => \@EXPORT_OK);
=head1 NAME
App::Netdisco::Util::Node
=head1 DESCRIPTION
A set of helper subroutines to support parts of the Netdisco application.
There are no default exports, however the C<:all> tag will export all
subroutines.
=head1 EXPORT_OK
=head2 check_mac( $device, $node, $port_macs? )
Given a Device database object and a MAC address, perform various sanity
checks which need to be done before writing an ARP/Neighbor entry to the
database storage.
Returns false, and might log a debug level message, if the checks fail.
Returns a true value (the MAC address in IEEE format) if these checks pass:
=over 4
=item *
MAC address is well-formed (according to common formats)
=item *
MAC address is not all-zero, broadcast, CLIP, VRRP or HSRP
=back
Optionally pass a cached set of Device port MAC addresses as the third
argument, in which case an additional check is added:
=over 4
=item *
MAC address does not belong to an interface on any known Device
=back
=cut
sub check_mac {
my ($device, $node, $port_macs) = @_;
my $mac = NetAddr::MAC->new(mac => $node);
my $devip = (ref $device ? $device->ip : '');
$port_macs ||= {};
# incomplete MAC addresses (BayRS frame relay DLCI, etc)
if (!defined $mac or $mac->errstr) {
debug sprintf ' [%s] check_mac - mac [%s] malformed - skipping',
$devip, $node;
return 0;
}
else {
# lower case, hex, colon delimited, 8-bit groups
$node = lc $mac->as_ieee;
}
# broadcast MAC addresses
return 0 if $mac->is_broadcast;
# all-zero MAC addresses
return 0 if $node eq '00:00:00:00:00:00';
# CLIP
return 0 if $node eq '00:00:00:00:00:01';
# multicast
if ($mac->is_multicast and not $mac->is_msnlb) {
debug sprintf ' [%s] check_mac - multicast mac [%s] - skipping',
$devip, $node;
return 0;
}
# VRRP
if ($mac->is_vrrp) {
debug sprintf ' [%s] check_mac - VRRP mac [%s] - skipping',
$devip, $node;
return 0;
}
# HSRP
if ($mac->is_hsrp or $mac->is_hsrp2) {
debug sprintf ' [%s] check_mac - HSRP mac [%s] - skipping',
$devip, $node;
return 0;
}
# device's own MACs
if ($port_macs and exists $port_macs->{$node}) {
debug sprintf ' [%s] check_mac - mac [%s] is device port - skipping',
$devip, $node;
return 0;
}
return $node;
}
=head2 check_node_no( $ip, $setting_name )
Given the IP address of a node, returns true if the configuration setting
C<$setting_name> matches that device, else returns false. If the setting
is undefined or empty, then C<check_node_no> also returns false.
print "rejected!" if check_node_no($ip, 'nbtstat_no');
There are several options for what C<$setting_name> can contain:
=over 4
=item *
Hostname, IP address, IP prefix
=item *
IP address range, using a hyphen and no whitespace
=item *
Regular Expression in YAML format which will match the node DNS name, e.g.:
- !!perl/regexp ^sep0.*$
=back
To simply match all nodes, use "C<any>" or IP Prefix "C<0.0.0.0/0>". All
regular expressions are anchored (that is, they must match the whole string).
To match no nodes we recommend an entry of "C<localhost>" in the setting.
=cut
sub check_node_no {
my ($ip, $setting_name) = @_;
my $config = setting($setting_name) || [];
return 0 if not scalar @$config;
return check_acl($ip, $config);
}
=head2 check_node_only( $ip, $setting_name )
Given the IP address of a node, returns true if the configuration setting
C<$setting_name> matches that node, else returns false. If the setting
is undefined or empty, then C<check_node_only> also returns true.
print "rejected!" unless check_node_only($ip, 'nbtstat_only');
There are several options for what C<$setting_name> can contain:
=over 4
=item *
Hostname, IP address, IP prefix
=item *
IP address range, using a hyphen and no whitespace
=item *
Regular Expression in YAML format which will match the node DNS name, e.g.:
- !!perl/regexp ^sep0.*$
=back
To simply match all nodes, use "C<any>" or IP Prefix "C<0.0.0.0/0>". All
regular expressions are anchored (that is, they must match the whole string).
To match no nodes we recommend an entry of "C<localhost>" in the setting.
=cut
sub check_node_only {
my ($ip, $setting_name) = @_;
my $config = setting($setting_name) || [];
return 1 if not scalar @$config;
return check_acl($ip, $config);
}
=head2 is_nbtstatable( $ip )
Given an IP address, returns C<true> if Netdisco on this host is permitted by
the local configuration to nbtstat the node.
The configuration items C<nbtstat_no> and C<nbtstat_only> are checked
against the given IP.
Returns false if the host is not permitted to nbtstat the target node.
=cut
sub is_nbtstatable {
my $ip = shift;
return if check_node_no($ip, 'nbtstat_no');
return unless check_node_only($ip, 'nbtstat_only');
return 1;
}
1;

52
lib/App/Netdisco/Util/NodeMonitor.pm Normal file
View File

@@ -0,0 +1,52 @@
package App::Netdisco::Util::NodeMonitor;
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 base 'Exporter';
our @EXPORT_OK = qw/
monitor
/;
our %EXPORT_TAGS = (all => \@EXPORT_OK);
sub _email {
my ($to, $subject, $body) = @_;
my $domain = setting('domain_suffix') || 'localhost';
$domain =~ s/^\.//;
my $SENDMAIL = '/usr/sbin/sendmail';
open (SENDMAIL, "| $SENDMAIL -t") or die "Can't open sendmail at $SENDMAIL.\n";
print SENDMAIL "To: $to\n";
print SENDMAIL "From: Netdisco <netdisco\@$domain>\n";
print SENDMAIL "Subject: $subject\n\n";
print SENDMAIL $body;
close (SENDMAIL) or die "Can't send letter. $!\n";
}
sub monitor {
my $monitor = schema('netdisco')->resultset('Virtual::NodeMonitor');
while (my $entry = $monitor->next) {
my $body = <<"end_body";
........ n e t d i s c o .........
Node : @{[$entry->mac]} (@{[$entry->why]})
When : @{[$entry->date]}
Switch : @{[$entry->name]} (@{[$entry->switch]})
Port : @{[$entry->port]} (@{[$entry->portname]})
Location: @{[$entry->location]}
end_body
_email(
$entry->cc,
"Saw mac @{[$entry->mac]} (@{[$entry->why]}) on @{[$entry->name]} @{[$entry->port]}",
$body
);
}
}
1;

8
lib/App/Netdisco/Util/Noop.pm Normal file
View File

@@ -0,0 +1,8 @@
package App::Netdisco::Util::Noop;
use strict;
use warnings;
# used for testing library access.
1;

139
lib/App/Netdisco/Util/Permission.pm Normal file
View File

@@ -0,0 +1,139 @@
package App::Netdisco::Util::Permission;
use Dancer qw/:syntax :script/;
use Dancer::Plugin::DBIC 'schema';
use Scalar::Util 'blessed';
use NetAddr::IP::Lite ':lower';
use App::Netdisco::Util::DNS 'hostname_from_ip';
use base 'Exporter';
our @EXPORT = ();
our @EXPORT_OK = qw/check_acl/;
our %EXPORT_TAGS = (all => \@EXPORT_OK);
=head1 NAME
App::Netdisco::Util::Permission
=head1 DESCRIPTION
Helper subroutines to support parts of the Netdisco application.
There are no default exports, however the C<:all> tag will export all
subroutines.
=head1 EXPORT_OK
=head2 check_acl( $ip, \@config )
Given an IP address, returns true if any of the items in C<< \@config >>
matches that address, otherwise returns false.
Normally you use C<check_device_no> and C<check_device_only>, passing the name of the
configuration setting to load. This helper instead requires not the name of
the setting, but its value.
There are several options for what C<< \@config >> can contain:
=over 4
=item *
Hostname, IP address, IP prefix
=item *
IP address range, using a hyphen and no whitespace
=item *
Regular Expression in YAML format (no enforced anchors) which will match the
device DNS name (using a fresh DNS lookup, so works on new discovery), e.g.:
- !!perl/regexp ^sep0.*$
=item *
C<"property:regex"> - matched against a device property, such as C<model> or
C<vendor> (with enforced begin/end regex anchors)
=back
To simply match all devices, use "C<any>" or IP Prefix "C<0.0.0.0/0>".
Property regular expressions are anchored (that is, they must match the whole
string). To match no devices we recommend an entry of "C<localhost>" in the
setting.
=cut
sub check_acl {
my ($thing, $config) = @_;
my $real_ip = (blessed $thing ? $thing->ip : $thing);
my $addr = NetAddr::IP::Lite->new($real_ip);
foreach my $item (@$config) {
if (ref qr// eq ref $item) {
my $name = hostname_from_ip($addr->addr) or next;
return 1 if $name =~ $item;
next;
}
if ($item =~ m/^([^:]+)\s*:\s*([^:]+)$/) {
my $prop = $1;
my $match = $2;
# if not in storage, we can't do much with device properties
next unless blessed $thing and $thing->in_storage;
# lazy version of vendor: and model:
if ($thing->can($prop) and defined $thing->$prop
and $thing->$prop =~ m/^$match$/) {
return 1;
}
next;
}
if ($item =~ m/([a-f0-9]+)-([a-f0-9]+)$/i) {
my $first = $1;
my $last = $2;
if ($item =~ m/:/) {
next unless $addr->bits == 128;
$first = hex $first;
$last = hex $last;
(my $header = $item) =~ s/:[^:]+$/:/;
foreach my $part ($first .. $last) {
my $ip = NetAddr::IP::Lite->new($header . sprintf('%x',$part) . '/128')
or next;
return 1 if $ip == $addr;
}
}
else {
next unless $addr->bits == 32;
(my $header = $item) =~ s/\.[^.]+$/./;
foreach my $part ($first .. $last) {
my $ip = NetAddr::IP::Lite->new($header . $part . '/32')
or next;
return 1 if $ip == $addr;
}
}
next;
}
my $ip = NetAddr::IP::Lite->new($item)
or next;
next unless $ip->bits == $addr->bits;
return 1 if $ip->contains($addr);
}
return 0;
}
1;

232
lib/App/Netdisco/Util/Port.pm Normal file
View File

@@ -0,0 +1,232 @@
package App::Netdisco::Util::Port;
use Dancer qw/:syntax :script/;
use Dancer::Plugin::DBIC 'schema';
use App::Netdisco::Util::Device 'get_device';
use base 'Exporter';
our @EXPORT = ();
our @EXPORT_OK = qw/
vlan_reconfig_check port_reconfig_check
get_port get_iid get_powerid
is_vlan_interface port_has_phone
/;
our %EXPORT_TAGS = (all => \@EXPORT_OK);
=head1 NAME
App::Netdisco::Util::Port
=head1 DESCRIPTION
A set of helper subroutines to support parts of the Netdisco application.
There are no default exports, however the C<:all> tag will export all
subroutines.
=head1 EXPORT_OK
=head2 vlan_reconfig_check( $port )
=over 4
=item *
Sanity check that C<$port> is not a vlan subinterface.
=item *
Permission check that C<vlanctl> is true in Netdisco config.
=back
Will return nothing if these checks pass OK.
=cut
sub vlan_reconfig_check {
my $port = shift;
my $ip = $port->ip;
my $name = $port->port;
my $is_vlan = is_vlan_interface($port);
# vlan (routed) interface check
return "forbidden: [$name] is a vlan interface on [$ip]"
if $is_vlan;
return "forbidden: not permitted to change native vlan"
if not setting('vlanctl');
return;
}
=head2 port_reconfig_check( $port )
=over 4
=item *
Permission check that C<portctl_nameonly> is false in Netdisco config.
=item *
Permission check that C<portctl_uplinks> is true in Netdisco config, if
C<$port> is an uplink.
=item *
Permission check that C<portctl_nophones> is not true in Netdisco config, if
C<$port> has a phone connected.
=item *
Permission check that C<portctl_vlans> is true if C<$port> is a vlan
subinterface.
=back
Will return nothing if these checks pass OK.
=cut
sub port_reconfig_check {
my $port = shift;
my $ip = $port->ip;
my $name = $port->port;
my $has_phone = port_has_phone($port);
my $is_vlan = is_vlan_interface($port);
# only permitted to change interface name
return "forbidden: not permitted to change port configuration"
if setting('portctl_nameonly');
# uplink check
return "forbidden: port [$name] on [$ip] is an uplink"
if $port->remote_type and not $has_phone and not setting('portctl_uplinks');
# phone check
return "forbidden: port [$name] on [$ip] is a phone"
if $has_phone and setting('portctl_nophones');
# vlan (routed) interface check
return "forbidden: [$name] is a vlan interface on [$ip]"
if $is_vlan and not setting('portctl_vlans');
return;
}
=head2 get_port( $device, $portname )
Given a device IP address and a port name, returns a L<DBIx::Class::Row>
object for the Port on the Device in the Netdisco database.
The device IP can also be passed as a Device C<DBIx::Class> object.
Returns C<undef> if the device or port are not known to Netdisco.
=cut
sub get_port {
my ($device, $portname) = @_;
# accept either ip or dbic object
$device = get_device($device);
my $port = schema('netdisco')->resultset('DevicePort')
->find({ip => $device->ip, port => $portname});
return $port;
}
=head2 get_iid( $info, $port )
Given an L<SNMP::Info> instance for a device, and the name of a port, returns
the current interface table index for that port. This can be used in further
SNMP requests on attributes of the port.
Returns C<undef> if there is no such port name on the device.
=cut
sub get_iid {
my ($info, $port) = @_;
# accept either port name or dbic object
$port = $port->port if ref $port;
my $interfaces = $info->interfaces;
my %rev_if = reverse %$interfaces;
my $iid = $rev_if{$port};
return $iid;
}
=head2 get_powerid( $info, $port )
Given an L<SNMP::Info> instance for a device, and the name of a port, returns
the current PoE table index for the port. This can be used in further SNMP
requests on PoE attributes of the port.
Returns C<undef> if there is no such port name on the device.
=cut
sub get_powerid {
my ($info, $port) = @_;
# accept either port name or dbic object
$port = $port->port if ref $port;
my $iid = get_iid($info, $port)
or return undef;
my $p_interfaces = $info->peth_port_ifindex;
my %rev_p_if = reverse %$p_interfaces;
my $powerid = $rev_p_if{$iid};
return $powerid;
}
=head2 is_vlan_interface( $port )
Returns true if the C<$port> L<DBIx::Class> object represents a vlan
subinterface.
This uses simple checks on the port I<type> and I<name>, and therefore might
sometimes returns a false-negative result.
=cut
sub is_vlan_interface {
my $port = shift;
my $is_vlan = (($port->type and
$port->type =~ /^(53|propVirtual|l2vlan|l3ipvlan|135|136|137)$/i)
or ($port->port and $port->port =~ /vlan/i)
or ($port->name and $port->name =~ /vlan/i)) ? 1 : 0;
return $is_vlan;
}
=head2 port_has_phone( $port )
Returns true if the C<$port> L<DBIx::Class> object has a phone connected.
This uses a simple check on the I<type> of the remote connected device, and
therefore might sometimes return a false-negative result.
=cut
sub port_has_phone {
my $port = shift;
my $has_phone = ($port->remote_type
and $port->remote_type =~ /ip.phone/i) ? 1 : 0;
return $has_phone;
}
1;

59
lib/App/Netdisco/Util/PortMAC.pm Normal file
View File

@@ -0,0 +1,59 @@
package App::Netdisco::Util::PortMAC;
use Dancer qw/:syntax :script/;
use Dancer::Plugin::DBIC 'schema';
use base 'Exporter';
our @EXPORT = ();
our @EXPORT_OK = qw/ get_port_macs /;
our %EXPORT_TAGS = (all => \@EXPORT_OK);
=head1 NAME
App::Netdisco::Util::PortMAC
=head1 DESCRIPTION
Helper subroutine to support parts of the Netdisco application.
There are no default exports, however the C<:all> tag will export all
subroutines.
=head1 EXPORT_OK
=head2 get_port_macs
Returns a Hash reference of C<< { MAC => IP } >> for all interface MAC
addresses on all devices.
If you need to filter for a given device, simply compare the IP (hash value)
to your device's IP.
=cut
sub get_port_macs {
my $port_macs = {};
my $dp_macs
= schema('netdisco')->resultset('DevicePort')
->search( { mac => { '!=' => [ -and => (undef, '00:00:00:00:00:00') ] } },
{ select => [ 'mac', 'ip' ],
group_by => [ 'mac', 'ip' ] } );
my $dp_cursor = $dp_macs->cursor;
while ( my @vals = $dp_cursor->next ) {
$port_macs->{ $vals[0] } = $vals[1];
}
my $d_macs
= schema('netdisco')->resultset('Device')
->search( { mac => { '!=' => undef } },
{ select => [ 'mac', 'ip' ] } );
my $d_cursor = $d_macs->cursor;
while ( my @vals = $d_cursor->next ) {
$port_macs->{ $vals[0] } = $vals[1];
}
return $port_macs;
}
1;

414
lib/App/Netdisco/Util/SNMP.pm Normal file
View File

@@ -0,0 +1,414 @@
package App::Netdisco::Util::SNMP;
use Dancer qw/:syntax :script/;
use App::Netdisco::Util::Device qw/get_device check_device_no/;
use App::Netdisco::Util::Permission qw/check_acl/;
use SNMP::Info;
use Try::Tiny;
use Module::Load ();
use Path::Class 'dir';
use base 'Exporter';
our @EXPORT = ();
our @EXPORT_OK = qw/
snmp_connect snmp_connect_rw snmp_comm_reindex
/;
our %EXPORT_TAGS = (all => \@EXPORT_OK);
=head1 NAME
App::Netdisco::Util::SNMP
=head1 DESCRIPTION
A set of helper subroutines to support parts of the Netdisco application.
There are no default exports, however the C<:all> tag will export all
subroutines.
=head1 EXPORT_OK
=head2 snmp_connect( $ip )
Given an IP address, returns an L<SNMP::Info> instance configured for and
connected to that device. The IP can be any on the device, and the management
interface will be connected to.
If the device is known to Netdisco and there is a cached SNMP community
string, this will be tried first, and then other community string(s) from the
application configuration will be tried.
Returns C<undef> if the connection fails.
=cut
sub snmp_connect { _snmp_connect_generic('read', @_) }
=head2 snmp_connect_rw( $ip )
Same as C<snmp_connect> but uses the read-write community string(s) from the
application configuration file.
Returns C<undef> if the connection fails.
=cut
sub snmp_connect_rw { _snmp_connect_generic('write', @_) }
sub _snmp_connect_generic {
my ($mode, $ip, $useclass) = @_;
$mode ||= 'read';
# get device details from db
my $device = get_device($ip);
my %snmp_args = (
AutoSpecify => 0,
DestHost => $device->ip,
# 0 is falsy. Using || with snmpretries equal to 0 will set retries to 2.
# check if the setting is 0. If not, use the default value of 2.
Retries => (setting('snmpretries') || setting('snmpretries') == 0 ? 0 : 2),
Timeout => (setting('snmptimeout') || 1000000),
NonIncreasing => (setting('nonincreasing') || 0),
BulkWalk => ((defined setting('bulkwalk_off') && setting('bulkwalk_off'))
? 0 : 1),
BulkRepeaters => (setting('bulkwalk_repeaters') || 20),
MibDirs => [ _build_mibdirs() ],
IgnoreNetSNMPConf => 1,
Debug => ($ENV{INFO_TRACE} || 0),
DebugSNMP => ($ENV{SNMP_TRACE} || 0),
);
# an override for bulkwalk
$snmp_args{BulkWalk} = 0 if check_device_no($device, 'bulkwalk_no');
# further protect against buggy Net-SNMP, and disable bulkwalk
if ($snmp_args{BulkWalk}
and ($SNMP::VERSION eq '5.0203' || $SNMP::VERSION eq '5.0301')) {
warning sprintf
"[%s] turning off BulkWalk due to buggy Net-SNMP - please upgrade!",
$device->ip;
$snmp_args{BulkWalk} = 0;
}
# get the community string(s)
my @communities = _build_communities($device, $mode);
# which SNMP versions to try and in what order
my @versions =
( check_device_no($device->ip, 'snmpforce_v3') ? (3)
: check_device_no($device->ip, 'snmpforce_v2') ? (2)
: check_device_no($device->ip, 'snmpforce_v1') ? (1)
: (reverse (1 .. (setting('snmpver') || 3))) );
# use existing or new device class
my @classes = ($useclass || 'SNMP::Info');
if ($device->snmp_class and not $useclass) {
unshift @classes, $device->snmp_class;
}
my $info = undef;
COMMUNITY: foreach my $comm (@communities) {
next unless $comm;
VERSION: foreach my $ver (@versions) {
next unless $ver;
next if $ver eq 3 and exists $comm->{community};
next if $ver ne 3 and !exists $comm->{community};
CLASS: foreach my $class (@classes) {
next unless $class;
my %local_args = (%snmp_args, Version => $ver);
$info = _try_connect($device, $class, $comm, $mode, \%local_args,
($useclass ? 0 : 1) );
last COMMUNITY if $info;
}
}
}
return $info;
}
sub _try_connect {
my ($device, $class, $comm, $mode, $snmp_args, $reclass) = @_;
my %comm_args = _mk_info_commargs($comm);
my $debug_comm = ( $comm->{community}
? $ENV{SHOW_COMMUNITY} ? $comm->{community} : '<hidden>'
: "v3user:$comm->{user}" );
my $info = undef;
try {
debug
sprintf '[%s] try_connect with ver: %s, class: %s, comm: %s',
$snmp_args->{DestHost}, $snmp_args->{Version}, $class, $debug_comm;
Module::Load::load $class;
$info = $class->new(%$snmp_args, %comm_args) or return;
$info = ($mode eq 'read' ? _try_read($info, $device, $comm)
: _try_write($info, $device, $comm));
# first time a device is discovered, re-instantiate into specific class
if ($reclass and $info and $info->device_type ne $class) {
$class = $info->device_type;
debug
sprintf '[%s] try_connect with ver: %s, new class: %s, comm: %s',
$snmp_args->{DestHost}, $snmp_args->{Version}, $class, $debug_comm;
Module::Load::load $class;
$info = $class->new(%$snmp_args, %comm_args);
}
}
catch {
debug $_;
};
return $info;
}
sub _try_read {
my ($info, $device, $comm) = @_;
return undef unless (
(not defined $info->error)
and defined $info->uptime
and ($info->layers or $info->description)
and $info->class
);
$device->in_storage
? $device->update({snmp_ver => $info->snmp_ver})
: $device->set_column(snmp_ver => $info->snmp_ver);
if ($comm->{community}) {
$device->in_storage
? $device->update({snmp_comm => $comm->{community}})
: $device->set_column(snmp_comm => $comm->{community});
}
# regardless of device in storage, save the hint
$device->update_or_create_related('community',
{snmp_auth_tag_read => $comm->{tag}}) if $comm->{tag};
return $info;
}
sub _try_write {
my ($info, $device, $comm) = @_;
my $loc = $info->load_location;
$info->set_location($loc) or return undef;
return undef unless ($loc eq $info->load_location);
$device->in_storage
? $device->update({snmp_ver => $info->snmp_ver})
: $device->set_column(snmp_ver => $info->snmp_ver);
# one of these two cols must be set
$device->update_or_create_related('community', {
($comm->{tag} ? (snmp_auth_tag_write => $comm->{tag}) : ()),
($comm->{community} ? (snmp_comm_rw => $comm->{community}) : ()),
});
return $info;
}
sub _mk_info_commargs {
my $comm = shift;
return () unless ref {} eq ref $comm and scalar keys %$comm;
return (Community => $comm->{community})
if exists $comm->{community};
my $seclevel =
(exists $comm->{auth} ?
(exists $comm->{priv} ? 'authPriv' : 'authNoPriv' )
: 'noAuthNoPriv');
return (
SecName => $comm->{user},
SecLevel => $seclevel,
( exists $comm->{auth} ? (
AuthProto => uc ($comm->{auth}->{proto} || 'MD5'),
AuthPass => ($comm->{auth}->{pass} || ''),
( exists $comm->{priv} ? (
PrivProto => uc ($comm->{priv}->{proto} || 'DES'),
PrivPass => ($comm->{priv}->{pass} || ''),
) : ()),
) : ()),
);
}
sub _build_mibdirs {
my $home = (setting('mibhome') || dir(($ENV{NETDISCO_HOME} || $ENV{HOME}), 'netdisco-mibs'));
return map { dir($home, $_)->stringify }
@{ setting('mibdirs') || _get_mibdirs_content($home) };
}
sub _get_mibdirs_content {
my $home = shift;
# warning 'Netdisco SNMP work will be slow - loading ALL MIBs. Consider setting mibdirs.';
my @list = map {s|$home/||; $_} grep {-d} glob("$home/*");
return \@list;
}
sub _build_communities {
my ($device, $mode) = @_;
$mode ||= 'read';
my $seen_tags = {}; # for cleaning community table
my $config = (setting('snmp_auth') || []);
my $tag_name = 'snmp_auth_tag_'. $mode;
my $stored_tag = eval { $device->community->$tag_name };
my $snmp_comm_rw = eval { $device->community->snmp_comm_rw };
my @communities = ();
# try last-known-good read
push @communities, {read => 1, community => $device->snmp_comm}
if defined $device->snmp_comm and $mode eq 'read';
# try last-known-good write
push @communities, {write => 1, community => $snmp_comm_rw}
if $snmp_comm_rw and $mode eq 'write';
# new style snmp config
foreach my $stanza (@$config) {
# user tagged
my $tag = '';
if (1 == scalar keys %$stanza) {
$tag = (keys %$stanza)[0];
$stanza = $stanza->{$tag};
# corner case: untagged lone community
if ($tag eq 'community') {
$tag = $stanza;
$stanza = {community => $tag};
}
}
# defaults
$stanza->{tag} ||= $tag;
++$seen_tags->{ $stanza->{tag} };
$stanza->{read} = 1 if !exists $stanza->{read};
$stanza->{only} ||= ['any'];
$stanza->{only} = [$stanza->{only}] if ref '' eq ref $stanza->{only};
die "error: config: snmpv3 stanza in snmp_auth must have a tag\n"
if not $stanza->{tag}
and !exists $stanza->{community};
if ($stanza->{$mode} and check_acl($device->ip, $stanza->{only})) {
if ($device->in_storage and
$stored_tag and $stored_tag eq $stanza->{tag}) {
# last known-good by tag
unshift @communities, $stanza
}
else {
push @communities, $stanza
}
}
}
# clean the community table of obsolete tags
if ($stored_tag and !exists $seen_tags->{ $stored_tag }) {
eval { $device->community->update({$tag_name => undef}) };
}
# legacy config (note: read strings tried before write)
if ($mode eq 'read') {
push @communities, map {{
read => 1,
community => $_,
}} @{setting('community') || []};
}
else {
push @communities, map {{
write => 1,
community => $_,
}} @{setting('community_rw') || []};
}
# but first of all, use external command if configured
unshift @communities, _get_external_community($device, $mode)
if setting('get_community') and length setting('get_community');
return @communities;
}
sub _get_external_community {
my ($device, $mode) = @_;
my $cmd = setting('get_community');
my $ip = $device->ip;
my $host = $device->dns || $ip;
if (defined $cmd and length $cmd) {
# replace variables
$cmd =~ s/\%HOST\%/$host/egi;
$cmd =~ s/\%IP\%/$ip/egi;
my $result = `$cmd`; # BACKTICKS
return () unless defined $result and length $result;
my @lines = split (m/\n/, $result);
foreach my $line (@lines) {
if ($line =~ m/^community\s*=\s*(.*)\s*$/i) {
if (length $1 and $mode eq 'read') {
return map {{
read => 1,
community => $_,
}} split(m/\s*,\s*/,$1);
}
}
elsif ($line =~ m/^setCommunity\s*=\s*(.*)\s*$/i) {
if (length $1 and $mode eq 'write') {
return map {{
write => 1,
community => $_,
}} split(m/\s*,\s*/,$1);
}
}
}
}
return ();
}
=head2 snmp_comm_reindex( $snmp, $device, $vlan )
Takes an established L<SNMP::Info> instance and makes a fresh connection using
community indexing, with the given C<$vlan> ID. Works for all SNMP versions.
=cut
sub snmp_comm_reindex {
my ($snmp, $device, $vlan) = @_;
my $ver = $snmp->snmp_ver;
if ($ver == 3) {
my $prefix = '';
my @comms = _build_communities($device, 'read');
foreach my $c (@comms) {
next unless $c->{tag}
and $c->{tag} eq (eval { $device->community->snmp_auth_tag_read } || '');
$prefix = $c->{context_prefix} and last;
}
$prefix ||= 'vlan-';
debug
sprintf '[%s] reindexing to "%s%s" (ver: %s, class: %s)',
$device->ip, $prefix, $vlan, $ver, $snmp->class;
$snmp->update(Context => ($prefix . $vlan));
}
else {
my $comm = $snmp->snmp_comm;
debug sprintf '[%s] reindexing to vlan %s (ver: %s, class: %s)',
$device->ip, $vlan, $ver, $snmp->class;
$snmp->update(Community => $comm . '@' . $vlan);
}
}
1;

220
lib/App/Netdisco/Util/Web.pm Normal file
View File

@@ -0,0 +1,220 @@
package App::Netdisco::Util::Web;
use strict;
use warnings;
use base 'Exporter';
use Time::Piece;
use Time::Seconds;
our @EXPORT = ();
our @EXPORT_OK = qw/
sort_port sort_modules interval_to_daterange sql_match
/;
our %EXPORT_TAGS = (all => \@EXPORT_OK);
=head1 NAME
App::Netdisco::Util::Web
=head1 DESCRIPTION
A set of helper subroutines to support parts of the Netdisco application.
There are no default exports, however the C<:all> tag will export all
subroutines.
=head1 EXPORT_OK
=head2 sql_match( $value, $exact? )
Convert wildcard characters "C<*>" and "C<?>" to "C<%>" and "C<_>"
respectively.
Pass a true value to C<$exact> to only substitute the existing wildcards, and
not also add "C<*>" to each end of the value.
In list context, returns two values, the translated value, and also an
L<SQL::Abstract> LIKE clause.
=cut
sub sql_match {
my ($text, $exact) = @_;
return unless $text;
$text =~ s/^\s+//;
$text =~ s/\s+$//;
$text =~ s/[*]+/%/g;
$text =~ s/[?]/_/g;
$text = '%'. $text . '%' unless $exact;
$text =~ s/\%+/%/g;
return ( wantarray ? ($text, {-ilike => $text}) : $text );
}
=head2 sort_port( $a, $b )
Sort port names of various types used by device vendors. Interface is as
Perl's own C<sort> - two input args and an integer return value.
=cut
sub sort_port {
my ($aval, $bval) = @_;
# hack for foundry "10GigabitEthernet" -> cisco-like "TenGigabitEthernet"
$aval = $1 if $aval =~ qr/^10(GigabitEthernet.+)$/;
$bval = $1 if $bval =~ qr/^10(GigabitEthernet.+)$/;
my $numbers = qr{^(\d+)$};
my $numeric = qr{^([\d\.]+)$};
my $dotted_numeric = qr{^(\d+)[:.](\d+)$};
my $letter_number = qr{^([a-zA-Z]+)(\d+)$};
my $wordcharword = qr{^([^:\/.]+)[-\ :\/\.]+([^:\/.0-9]+)(\d+)?$}; #port-channel45
my $netgear = qr{^Slot: (\d+) Port: (\d+) }; # "Slot: 0 Port: 15 Gigabit - Level"
my $ciscofast = qr{^
# Word Number slash (Gigabit0/)
(\D+)(\d+)[\/:]
# Groups of symbol float (/5.5/5.5/5.5), separated by slash or colon
([\/:\.\d]+)
# Optional dash (-Bearer Channel)
(-.*)?
$}x;
my @a = (); my @b = ();
if ($aval =~ $dotted_numeric) {
@a = ($1,$2);
} elsif ($aval =~ $letter_number) {
@a = ($1,$2);
} elsif ($aval =~ $netgear) {
@a = ($1,$2);
} elsif ($aval =~ $numbers) {
@a = ($1);
} elsif ($aval =~ $ciscofast) {
@a = ($1,$2);
push @a, split(/[:\/]/,$3), $4;
} elsif ($aval =~ $wordcharword) {
@a = ($1,$2,$3);
} else {
@a = ($aval);
}
if ($bval =~ $dotted_numeric) {
@b = ($1,$2);
} elsif ($bval =~ $letter_number) {
@b = ($1,$2);
} elsif ($bval =~ $netgear) {
@b = ($1,$2);
} elsif ($bval =~ $numbers) {
@b = ($1);
} elsif ($bval =~ $ciscofast) {
@b = ($1,$2);
push @b, split(/[:\/]/,$3),$4;
} elsif ($bval =~ $wordcharword) {
@b = ($1,$2,$3);
} else {
@b = ($bval);
}
# Equal until proven otherwise
my $val = 0;
while (scalar(@a) or scalar(@b)){
# carried around from the last find.
last if $val != 0;
my $a1 = shift @a;
my $b1 = shift @b;
# A has more components - loses
unless (defined $b1){
$val = 1;
last;
}
# A has less components - wins
unless (defined $a1) {
$val = -1;
last;
}
if ($a1 =~ $numeric and $b1 =~ $numeric){
$val = $a1 <=> $b1;
} elsif ($a1 ne $b1) {
$val = $a1 cmp $b1;
}
}
return $val;
}
=head2 sort_modules( $modules )
Sort devices modules into tree hierarchy based upon position and parent -
input arg is module list.
=cut
sub sort_modules {
my $input = shift;
my %modules;
foreach my $module (@$input) {
$modules{$module->index}{module} = $module;
if ($module->parent) {
# Example
# index | description | type | parent | class | pos
#-------+----------------------------------------+---------------------+--------+---------+-----
# 1 | Cisco Aironet 1200 Series Access Point | cevChassisAIRAP1210 | 0 | chassis | -1
# 3 | PowerPC405GP Ethernet | cevPortFEIP | 1 | port | -1
# 2 | 802.11G Radio | cevPortUnknown | 1 | port | 0
# Some devices do not implement correctly, so given parent
# can have multiple items within the same class at a single pos
# value. However, the database results are sorted by 1) parent
# 2) class 3) pos 4) index so we should just be able to push onto
# the array and ordering be preserved.
{
no warnings 'uninitialized';
push(@{$modules{$module->parent}{children}{$module->class}}, $module->index);
}
} else {
push(@{$modules{root}}, $module->index);
}
}
return \%modules;
}
=head2 interval_to_daterange( $interval )
Takes an interval in days, weeks, months, or years in a format like '7 days'
and returns a date range in the format 'YYYY-MM-DD to YYYY-MM-DD' by
subtracting the interval from the current date.
=cut
sub interval_to_daterange {
my $interval = shift;
return unless $interval =~ m/^(?:\d+)\s+(?:day|week|month|year)s?$/;
my %const = (
day => ONE_DAY,
week => ONE_WEEK,
month => ONE_MONTH,
year => ONE_YEAR
);
my ( $amt, $factor )
= $interval =~ /^(\d+)\s+(day|week|month|year)s?$/gmx;
$amt-- if $factor eq 'day';
my $start = Time::Piece->new - $const{$factor} * $amt;
return $start->ymd . " to " . Time::Piece->new->ymd;
}
1;