1package App::Netdisco::Util::Port; 2 3use Dancer qw/:syntax :script/; 4use Dancer::Plugin::DBIC 'schema'; 5 6use App::Netdisco::Util::Device 'get_device'; 7 8use base 'Exporter'; 9our @EXPORT = (); 10our @EXPORT_OK = qw/ 11 vlan_reconfig_check port_reconfig_check 12 get_port get_iid get_powerid 13 is_vlan_interface port_has_phone 14/; 15our %EXPORT_TAGS = (all => \@EXPORT_OK); 16 17=head1 NAME 18 19App::Netdisco::Util::Port 20 21=head1 DESCRIPTION 22 23A set of helper subroutines to support parts of the Netdisco application. 24 25There are no default exports, however the C<:all> tag will export all 26subroutines. 27 28=head1 EXPORT_OK 29 30=head2 vlan_reconfig_check( $port ) 31 32=over 4 33 34=item * 35 36Sanity check that C<$port> is not a vlan subinterface. 37 38=item * 39 40Permission check that C<vlanctl> is true in Netdisco config. 41 42=back 43 44Will return nothing if these checks pass OK. 45 46=cut 47 48sub vlan_reconfig_check { 49 my $port = shift; 50 my $ip = $port->ip; 51 my $name = $port->port; 52 53 my $is_vlan = is_vlan_interface($port); 54 55 # vlan (routed) interface check 56 return "forbidden: [$name] is a vlan interface on [$ip]" 57 if $is_vlan; 58 59 return "forbidden: not permitted to change native vlan" 60 if not setting('vlanctl'); 61 62 return; 63} 64 65=head2 port_reconfig_check( $port ) 66 67=over 4 68 69=item * 70 71Permission check that C<portctl_nameonly> is false in Netdisco config. 72 73=item * 74 75Permission check that C<portctl_uplinks> is true in Netdisco config, if 76C<$port> is an uplink. 77 78=item * 79 80Permission check that C<portctl_nophones> is not true in Netdisco config, if 81C<$port> has a phone connected. 82 83=item * 84 85Permission check that C<portctl_vlans> is true if C<$port> is a vlan 86subinterface. 87 88=back 89 90Will return nothing if these checks pass OK. 91 92=cut 93 94sub port_reconfig_check { 95 my $port = shift; 96 my $ip = $port->ip; 97 my $name = $port->port; 98 99 my $has_phone = port_has_phone($port); 100 my $is_vlan = is_vlan_interface($port); 101 102 # only permitted to change interface name 103 return "forbidden: not permitted to change port configuration" 104 if setting('portctl_nameonly'); 105 106 # uplink check 107 return "forbidden: port [$name] on [$ip] is an uplink" 108 if ($port->is_uplink or $port->remote_type) 109 and not $has_phone and not setting('portctl_uplinks'); 110 111 # phone check 112 return "forbidden: port [$name] on [$ip] is a phone" 113 if $has_phone and setting('portctl_nophones'); 114 115 # vlan (routed) interface check 116 return "forbidden: [$name] is a vlan interface on [$ip]" 117 if $is_vlan and not setting('portctl_vlans'); 118 119 return; 120} 121 122=head2 get_port( $device, $portname ) 123 124Given a device IP address and a port name, returns a L<DBIx::Class::Row> 125object for the Port on the Device in the Netdisco database. 126 127The device IP can also be passed as a Device C<DBIx::Class> object. 128 129Returns C<undef> if the device or port are not known to Netdisco. 130 131=cut 132 133sub get_port { 134 my ($device, $portname) = @_; 135 136 # accept either ip or dbic object 137 $device = get_device($device); 138 139 my $port = schema('netdisco')->resultset('DevicePort') 140 ->find({ip => $device->ip, port => $portname}); 141 142 return $port; 143} 144 145=head2 get_iid( $info, $port ) 146 147Given an L<SNMP::Info> instance for a device, and the name of a port, returns 148the current interface table index for that port. This can be used in further 149SNMP requests on attributes of the port. 150 151Returns C<undef> if there is no such port name on the device. 152 153=cut 154 155sub get_iid { 156 my ($info, $port) = @_; 157 158 # accept either port name or dbic object 159 $port = $port->port if ref $port; 160 161 my $interfaces = $info->interfaces; 162 my %rev_if = reverse %$interfaces; 163 my $iid = $rev_if{$port}; 164 165 return $iid; 166} 167 168=head2 get_powerid( $info, $port ) 169 170Given an L<SNMP::Info> instance for a device, and the name of a port, returns 171the current PoE table index for the port. This can be used in further SNMP 172requests on PoE attributes of the port. 173 174Returns C<undef> if there is no such port name on the device. 175 176=cut 177 178sub get_powerid { 179 my ($info, $port) = @_; 180 181 # accept either port name or dbic object 182 $port = $port->port if ref $port; 183 184 my $iid = get_iid($info, $port) 185 or return undef; 186 187 my $p_interfaces = $info->peth_port_ifindex; 188 my %rev_p_if = reverse %$p_interfaces; 189 my $powerid = $rev_p_if{$iid}; 190 191 return $powerid; 192} 193 194=head2 is_vlan_interface( $port ) 195 196Returns true if the C<$port> L<DBIx::Class> object represents a vlan 197subinterface. 198 199This uses simple checks on the port I<type> and I<descr>, and therefore might 200sometimes returns a false-negative result. 201 202=cut 203 204sub is_vlan_interface { 205 my $port = shift; 206 207 my $is_vlan = (($port->type and 208 $port->type =~ /^(53|propVirtual|l2vlan|l3ipvlan|135|136|137)$/i) 209 or ($port->port and $port->port =~ /vlan/i) 210 or ($port->descr and $port->descr =~ /vlan/i)) ? 1 : 0; 211 212 return $is_vlan; 213} 214 215=head2 port_has_phone( $port ) 216 217Returns true if the C<$port> L<DBIx::Class> object has a phone connected. 218 219=cut 220 221sub port_has_phone { 222 my $properties = (shift)->properties; 223 return ($properties ? $properties->remote_is_phone : undef); 224} 225 2261; 227