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