Files
netdisco/lib/App/Netdisco/Util/Port.pm

306 lines
7.5 KiB
Perl
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

package App::Netdisco::Util::Port;
use Dancer qw/:syntax :script/;
use Dancer::Plugin::DBIC 'schema';
use App::Netdisco::Util::Device 'get_device';
use App::Netdisco::Util::Permission qw/acl_matches acl_matches_only/;
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 port_has_wap
/;
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, $device?, $user? )
=over 4
=item *
Permission check that C<portctl_no> and C<portctl_only> pass for the device.
=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.
=item *
Permission check on C<portctl_by_role> if the device and user are provided. A
bare username will be promoted to a user instance.
=back
Will return false if these checks pass OK.
=cut
sub port_reconfig_check {
my ($port, $device, $user) = @_;
my $ip = $port->ip;
my $name = $port->port;
my $has_wap = port_has_wap($port);
my $has_phone = port_has_phone($port);
my $is_vlan = is_vlan_interface($port);
# check for limits on devices
return "forbidden: device [$ip] is in denied ACL"
if acl_matches($ip, 'portctl_no');
return "forbidden: device [$ip] is not in permitted ACL"
unless acl_matches_only($ip, 'portctl_only');
# 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->is_uplink or $port->remote_type)
and not $has_phone and not setting('portctl_uplinks');
# wap check
return "forbidden: port [$name] on [$ip] is a wireless ap"
if $has_wap and setting('portctl_nowaps');
# 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');
# portctl_by_role check
if ($device and ref $device and $user) {
$user = ref $user ? $user :
schema(vars->{'tenant'})->resultset('User')
->find({ username => $user });
my $username = $user->username;
# special case admin user allowed to continue, because
# they can submit port control jobs
return "forbidden: user [$username] has no right to reconfigure ports"
unless ($user->admin or $user->port_control);
my $role = $user->portctl_role;
my $acl = $role ? setting('portctl_by_role')->{$role} : undef;
if ($acl and (ref $acl eq q{} or ref $acl eq ref [])) {
# all ports are permitted when the role acl is a device acl
# but check the device anyway
return "forbidden: user [$username] has no right to reconfigure ports"
unless acl_matches($device, $acl);
}
elsif ($acl and ref $acl eq ref {}) {
my $found = false;
foreach my $key (sort keys %$acl) {
# lhs matches device, rhs matches port
next unless $key and $acl->{$key};
if (acl_matches($device, $key)
and acl_matches($port, $acl->{$key})) {
$found = true;
last;
}
}
return "forbidden: user [$username] role [$role] cannot reconfigure port [$name] on [$ip]"
unless $found;
}
elsif ($role) {
return "forbidden: user [$username] is assigned an unknown role"
unless $user->port_control;
}
}
return false;
}
=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(vars->{'tenant'})->resultset('DevicePort')->with_properties
->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<descr>, 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->descr and $port->descr =~ /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.
=cut
sub port_has_phone {
my $row = shift;
return $row->remote_is_phone if $row->can('remote_is_phone');
my $properties = $row->properties;
return ($properties ? $properties->remote_is_phone : undef);
}
=head2 port_has_wap( $port )
Returns true if the C<$port> L<DBIx::Class> object has a wireless AP connected.
=cut
sub port_has_wap {
my $row = shift;
return $row->remote_is_wap if $row->can('remote_is_wap');
my $properties = $row->properties;
return ($properties ? $properties->remote_is_wap : undef);
}
1;