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

make an App::Netdisco dist using Module::Install

Browse Source
This commit is contained in:
Oliver Gorwits
2012-12-17 18:31:16 +00:00
parent 6a0aa7864e
commit 05086e8b78
125 changed files with 428 additions and 127 deletions
Download Patch File Download Diff File Expand all files Collapse all files

151
Netdisco/lib/App/Netdisco/Util/Connect.pm Normal file
View File

@@ -0,0 +1,151 @@
package App::Netdisco::Util::Connect;
use Dancer qw/:syntax :script/;
use Dancer::Plugin::DBIC 'schema';
use SNMP::Info;
use Try::Tiny;
use base 'Exporter';
our @EXPORT = ();
our @EXPORT_OK = qw/
get_device get_port get_iid get_powerid snmp_connect
/;
our %EXPORT_TAGS = (
all => [qw/
get_device get_port get_iid get_powerid snmp_connect
/],
);
=head1 App::Netdisco::Util::Connect
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.
=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.
Returns C<undef> if the device or interface IP is not known to Netdisco.
=cut
sub get_device {
my $ip = shift;
my $alias = schema('netdisco')->resultset('DeviceIp')
->search({alias => $ip})->first;
return if not eval { $alias->ip };
return schema('netdisco')->resultset('Device')
->find({ip => $alias->ip});
}
=head2 get_port( $device, $portname )
=cut
sub get_port {
my ($device, $portname) = @_;
# accept either ip or dbic object
$device = get_device($device)
if not ref $device;
my $port = schema('netdisco')->resultset('DevicePort')
->find({ip => $device->ip, port => $portname});
return $port;
}
=head2 get_iid( $info, $port )
=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 )
=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 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.
Returns C<undef> if the connection fails.
=cut
sub snmp_connect {
my $ip = shift;
# get device details from db
my $device = get_device($ip)
or return ();
# TODO: really only supporing v2c at the moment
my %snmp_args = (
DestHost => $device->ip,
Version => ($device->snmp_ver || setting('snmpver') || 2),
Retries => (setting('snmpretries') || 2),
Timeout => (setting('snmptimeout') || 1000000),
MibDirs => [ _build_mibdirs() ],
AutoSpecify => 1,
IgnoreNetSNMPConf => 1,
Debug => ($ENV{INFO_TRACE} || 0),
);
my $info = undef;
COMMUNITY: foreach my $c (@{ setting('community_rw') || []}) {
try {
$info = SNMP::Info->new(%snmp_args, Community => $c);
last COMMUNITY if (
$info
and (not defined $info->error)
and length $info->uptime
);
};
}
return $info;
}
sub _build_mibdirs {
# FIXME: make this cross-platform (Path::Class?)
return map { setting('mibhome') .'/'. $_ }
@{ setting('mibdirs') || [] };
}
1;

94
Netdisco/lib/App/Netdisco/Util/DeviceProperties.pm Normal file
View File

@@ -0,0 +1,94 @@
package App::Netdisco::Util::DeviceProperties;
use Dancer qw/:syntax :script/;
use Dancer::Plugin::DBIC 'schema';
use NetAddr::IP::Lite;
use base 'Exporter';
our @EXPORT = ();
our @EXPORT_OK = qw/
is_discoverable
is_vlan_interface port_has_phone
/;
our %EXPORT_TAGS = (
all => [qw/
is_discoverable
is_vlan_interface port_has_phone
/],
);
=head1 App::Netdisco::Util::DeviceProperties;
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.
=head2 is_discoverable( $ip )
Given an IP address, returns C<true> if Netdisco on this host is permitted to
discover its configuration by the local configuration.
The configuration items C<discover_no> and C<discover_only> are checked
against the given IP.
Returns false if the host is not permitted to discover the target device.
=cut
sub is_discoverable {
my $ip = shift;
my $device = NetAddr::IP::Lite->new($ip) or return 0;
my $discover_no = setting('discover_no') || [];
my $discover_only = setting('discover_only') || [];
if (scalar @$discover_no) {
foreach my $item (@$discover_no) {
my $ip = NetAddr::IP::Lite->new($item) or return 0;
return 0 if $ip->contains($device);
}
}
if (scalar @$discover_only) {
my $okay = 0;
foreach my $item (@$discover_only) {
my $ip = NetAddr::IP::Lite->new($item) or return 0;
++$okay if $ip->contains($device);
}
return 0 if not $okay;
}
return 1;
}
=head2 is_vlan_interface( $port )
=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 )
=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;

74
Netdisco/lib/App/Netdisco/Util/Permissions.pm Normal file
View File

@@ -0,0 +1,74 @@
package App::Netdisco::Util::Permissions;
use Dancer qw/:syntax :script/;
use Dancer::Plugin::DBIC 'schema';
use App::Netdisco::Util::DeviceProperties ':all';
use base 'Exporter';
our @EXPORT = ();
our @EXPORT_OK = qw/
vlan_reconfig_check port_reconfig_check
/;
our %EXPORT_TAGS = (
all => [qw/
vlan_reconfig_check port_reconfig_check
/],
);
=head1 App::Netdisco::Util::Permissions
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.
=head2 vlan_reconfig_check( $port )
=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 )
=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);
# uplink check
return "forbidden: port [$name] on [$ip] is an uplink"
if $port->remote_type and not $has_phone and not setting('allow_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;
}
1;

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

@@ -0,0 +1,117 @@
package App::Netdisco::Util::Web;
use base 'Exporter';
our @EXPORT = ();
our @EXPORT_OK = qw/
sort_port
/;
our %EXPORT_TAGS = (
all => [qw/
sort_port
/],
);
=head1 App::Netdisco::Util::Web
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.
=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 = "Ten$1" if $aval =~ qr/^10(GigabitEthernet.+)$/;
$bval = "Ten$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{^([^:\/.]+)[\ :\/\.]+([^:\/.]+)(\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 = ($2,$1);
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 = ($2,$1);
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;
}
1;