Profile of App/Netdisco/Util/Permission.pm

Filename	/appl/netdisco/netdisco_github_official/lib/App/Netdisco/Util/Permission.pm
Statements	Executed 4345659 statements in 5.91s

Subroutines
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
342	2	1	7.92s	31.5s	App::Netdisco::Util::Permission::check_acl
757746	3	1	103ms	103ms	App::Netdisco::Util::Permission::CORE:match (opcode)
252582	1	1	56.5ms	56.5ms	App::Netdisco::Util::Permission::CORE:subst (opcode)
171	3	1	1.83ms	31.5s	App::Netdisco::Util::Permission::check_acl_only
171	3	1	1.59ms	31.2ms	App::Netdisco::Util::Permission::check_acl_no
204	1	1	328µs	328µs	App::Netdisco::Util::Permission::CORE:qr (opcode)
0	0	0	0s	0s	App::Netdisco::Util::Permission::BEGIN

Call graph for these subroutines as a Graphviz dot language file.

Line	State ments	Time on line	Calls	Time in subs	Code
1					package App::Netdisco::Util::Permission;
2
3					use strict;
4					use warnings;
5					use Dancer qw/:syntax :script/;
6
7					use Scalar::Util qw/blessed reftype/;
8					use NetAddr::IP::Lite ':lower';
9					use App::Netdisco::Util::DNS 'hostname_from_ip';
10
11					use base 'Exporter';
12					our @EXPORT = ();
13					our @EXPORT_OK = qw/check_acl check_acl_no check_acl_only/;
14					our %EXPORT_TAGS = (all => \@EXPORT_OK);
15
16					=head1 NAME
17
18					App::Netdisco::Util::Permission
19
20					=head1 DESCRIPTION
21
22					Helper subroutines to support parts of the Netdisco application.
23
24					There are no default exports, however the C<:all> tag will export all
25					subroutines.
26
27					=head1 EXPORT_OK
28
29					=head2 check_acl_no( $ip \| $instance, $setting_name \| $acl_entry \| \@acl )
30
31					Given an IP address or object instance, returns true if the configuration
32					setting C<$setting_name> matches, else returns false. If the setting is
33					undefined or empty, then C<check_acl_no> also returns false.
34
35					If C<$setting_name> is a valid setting, then it will be resolved to the access
36					control list, else we assume you passed an ACL entry or ACL.
37
38					See L<App::Netdisco::Manual::Configuration> for details of what C<$acl> may
39					contain.
40
41					=cut
42
43					# spent 31.2ms (1.59+29.6) within App::Netdisco::Util::Permission::check_acl_no which was called 171 times, avg 183µs/call: # 57 times (527µs+11.2ms) by App::Netdisco::Util::Device::is_discoverable at line 184 of App/Netdisco/Util/Device.pm, avg 205µs/call # 57 times (542µs+9.40ms) by App::Netdisco::Util::Device::is_arpnipable at line 233 of App/Netdisco/Util/Device.pm, avg 174µs/call # 57 times (523µs+9.04ms) by App::Netdisco::Util::Device::is_macsuckable at line 282 of App/Netdisco/Util/Device.pm, avg 168µs/call sub check_acl_no {
44	171	71µs			my ($thing, $setting_name) = @_;
45	171	148µs	171	657µs	return 1 unless $thing and $setting_name; # spent 657µs making 171 calls to App::Netdisco::DB::Result::Device::__ANON__[App/Netdisco/DB/Result/Device.pm:13], avg 4µs/call
46	171	602µs	342	2.16ms	my $config = (exists config->{"$setting_name"} ? setting($setting_name) # spent 1.48ms making 171 calls to Dancer::setting, avg 9µs/call # spent 678µs making 171 calls to Dancer::config, avg 4µs/call
47					: $setting_name);
48	171	439µs	171	26.8ms	return check_acl($thing, $config); # spent 26.8ms making 171 calls to App::Netdisco::Util::Permission::check_acl, avg 157µs/call
49					}
50
51					=head2 check_acl_only( $ip \| $instance, $setting_name \| $acl_entry \| \@acl )
52
53					Given an IP address or object instance, returns true if the configuration
54					setting C<$setting_name> matches, else returns false. If the setting is
55					undefined or empty, then C<check_acl_only> also returns true.
56
57					If C<$setting_name> is a valid setting, then it will be resolved to the access
58					control list, else we assume you passed an ACL entry or ACL.
59
60					See L<App::Netdisco::Manual::Configuration> for details of what C<$acl> may
61					contain.
62
63					=cut
64
65					# spent 31.5s (1.83ms+31.5) within App::Netdisco::Util::Permission::check_acl_only which was called 171 times, avg 184ms/call: # 57 times (613µs+10.5s) by App::Netdisco::Util::Device::is_macsuckable at line 285 of App/Netdisco/Util/Device.pm, avg 184ms/call # 57 times (610µs+10.5s) by App::Netdisco::Util::Device::is_arpnipable at line 236 of App/Netdisco/Util/Device.pm, avg 184ms/call # 57 times (609µs+10.5s) by App::Netdisco::Util::Device::is_discoverable at line 187 of App/Netdisco/Util/Device.pm, avg 184ms/call sub check_acl_only {
66	171	80µs			my ($thing, $setting_name) = @_;
67	171	221µs	171	1.07ms	return 0 unless $thing and $setting_name; # spent 1.07ms making 171 calls to App::Netdisco::DB::Result::Device::__ANON__[App/Netdisco/DB/Result/Device.pm:13], avg 6µs/call
68					# logic to make an empty config be equivalent to 'any' (i.e. a match)
69	171	415µs	342	1.58ms	my $config = (exists config->{"$setting_name"} ? setting($setting_name) # spent 1.19ms making 171 calls to Dancer::setting, avg 7µs/call # spent 384µs making 171 calls to Dancer::config, avg 2µs/call
70					: $setting_name);
71	171	231µs			return 1 if not $config # undef or empty string
72					or ((ref [] eq ref $config) and not scalar @$config);
73	171	552µs	171	31.5s	return check_acl($thing, $config); # spent 31.5s making 171 calls to App::Netdisco::Util::Permission::check_acl, avg 184ms/call
74					}
75
76					=head2 check_acl( $ip \| $instance, $acl_entry \| \@acl )
77
78					Given an IP address or object instance, compares it to the items in C<< \@acl
79					>> then returns true or false. You can control whether any item must match or
80					all must match, and items can be negated to invert the match logic.
81
82					Accepts instances of classes representing Netdisco Devices, Netdisco Device
83					IPs, and L<NetAddr::IP> family objects.
84
85					There are several options for what C<< \@acl >> may contain. See
86					L<App::Netdisco::Manual::Configuration> for the details.
87
88					=cut
89
90					# spent 31.5s (7.92+23.6) within App::Netdisco::Util::Permission::check_acl which was called 342 times, avg 92.1ms/call: # 171 times (7.92s+23.5s) by App::Netdisco::Util::Permission::check_acl_only at line 73, avg 184ms/call # 171 times (4.53ms+22.3ms) by App::Netdisco::Util::Permission::check_acl_no at line 48, avg 157µs/call sub check_acl {
91	342	91µs			my ($thing, $config) = @_;
92	342	102µs			return 0 unless defined $thing and defined $config;
93
94	342	83µs			my $real_ip = $thing;
95	342	2.59ms	1368	1.88ms	if (blessed $thing) { # spent 926µs making 342 calls to App::Netdisco::DB::Result::Device::ip, avg 3µs/call # spent 523µs making 684 calls to UNIVERSAL::can, avg 764ns/call # spent 433µs making 342 calls to Scalar::Util::blessed, avg 1µs/call
96					$real_ip = ($thing->can('alias') ? $thing->alias : (
97					$thing->can('ip') ? $thing->ip : (
98					$thing->can('addr') ? $thing->addr : $thing )));
99					}
100	342	554µs	342	97µs	return 0 if !defined $real_ip # spent 97µs making 342 calls to Scalar::Util::blessed, avg 285ns/call
101					or blessed $real_ip; # class we do not understand
102
103	342	240µs			$config = [$config] if ref [] ne ref $config;
104	342	61.0ms			my $all = (scalar grep {$_ eq 'op:and'} @$config);
105
106					# common case of using plain IP in ACL, so string compare for speed
107	1309176	2.09s	1308834	155ms	my $find = (scalar grep {not reftype $_ and $_ eq $real_ip} @$config); # spent 155ms making 1308834 calls to Scalar::Util::reftype, avg 119ns/call
108	342	529µs			return 1 if $find and not $all;
109
110	204	869µs	408	11.2ms	my $addr = NetAddr::IP::Lite->new($real_ip) or return 0; # spent 10.6ms making 204 calls to NetAddr::IP::Lite::__ANON__[NetAddr/IP/Lite.pm:238], avg 52µs/call # spent 627µs making 204 calls to NetAddr::IP::Lite::new, avg 3µs/call
111	204	61µs			my $name = undef; # only look up once, and only if qr// is used
112	204	578µs			my $ropt = { retry => 1, retrans => 1, udp_timeout => 1, tcp_timeout => 2 };
113	204	858µs	204	328µs	my $qref = ref qr//; # spent 328µs making 204 calls to App::Netdisco::Util::Permission::CORE:qr, avg 2µs/call
114
115	204	58.5ms			INLIST: foreach (@$config) {
116	252582	68.0ms			my $item = $_; # must copy so that we can modify safely
117	252582	79.8ms			next INLIST if !defined $item or $item eq 'op:and';
118
119	252582	55.3ms			if ($qref eq ref $item) {
120					$name = ($name \|\| hostname_from_ip($addr->addr, $ropt) \|\| '!!none!!');
121					if ($name =~ $item) {
122					return 1 if not $all;
123					}
124					else {
125					return 0 if $all;
126					}
127					next INLIST;
128					}
129
130	252582	605ms	252582	56.5ms	my $neg = ($item =~ s/^!//); # spent 56.5ms making 252582 calls to App::Netdisco::Util::Permission::CORE:subst, avg 224ns/call
131
132	252582	537ms	252582	32.5ms	if ($item =~ m/^group:(.+)$/) { # spent 32.5ms making 252582 calls to App::Netdisco::Util::Permission::CORE:match, avg 128ns/call
133					my $group = $1;
134					setting('host_groups')->{$group} \|\|= [];
135
136					if ($neg xor check_acl($thing, setting('host_groups')->{$group})) {
137					return 1 if not $all;
138					}
139					else {
140					return 0 if $all;
141					}
142					next INLIST;
143					}
144
145	252582	492ms	252582	41.8ms	if ($item =~ m/^([^:]+):([^:]+)$/) { # spent 41.8ms making 252582 calls to App::Netdisco::Util::Permission::CORE:match, avg 165ns/call
146					my $prop = $1;
147					my $match = $2;
148
149					# if not an object, we can't do much with properties
150					next INLIST unless blessed $thing;
151
152					# lazy version of vendor: and model:
153					if ($neg xor ($thing->can($prop) and defined eval { $thing->$prop }
154					and $thing->$prop =~ m/^$match$/)) {
155					return 1 if not $all;
156					}
157					else {
158					return 0 if $all;
159					}
160					next INLIST;
161					}
162
163	252582	506ms	252582	28.3ms	if ($item =~ m/[:.]([a-f0-9]+)-([a-f0-9]+)$/i) { # spent 28.3ms making 252582 calls to App::Netdisco::Util::Permission::CORE:match, avg 112ns/call
164					my $first = $1;
165					my $last = $2;
166
167					if ($item =~ m/:/) {
168					next INLIST if $addr->bits != 128 and not $all;
169
170					$first = hex $first;
171					$last = hex $last;
172
173					(my $header = $item) =~ s/:[^:]+$/:/;
174					foreach my $part ($first .. $last) {
175					my $ip = NetAddr::IP::Lite->new($header . sprintf('%x',$part) . '/128')
176					or next;
177					if ($neg xor ($ip == $addr)) {
178					return 1 if not $all;
179					next INLIST;
180					}
181					}
182					return 0 if (not $neg and $all);
183					return 1 if ($neg and not $all);
184					}
185					else {
186					next INLIST if $addr->bits != 32 and not $all;
187
188					(my $header = $item) =~ s/\.[^.]+$/./;
189					foreach my $part ($first .. $last) {
190					my $ip = NetAddr::IP::Lite->new($header . $part . '/32')
191					or next;
192					if ($neg xor ($ip == $addr)) {
193					return 1 if not $all;
194					next INLIST;
195					}
196					}
197					return 0 if (not $neg and $all);
198					return 1 if ($neg and not $all);
199					}
200					next INLIST;
201					}
202
203	252582	543ms	505164	9.26s	my $ip = NetAddr::IP::Lite->new($item) # spent 8.91s making 252582 calls to NetAddr::IP::Lite::__ANON__[NetAddr/IP/Lite.pm:238], avg 35µs/call # spent 349ms making 252582 calls to NetAddr::IP::Lite::new, avg 1µs/call
204					or next INLIST;
205	252582	286ms	505164	258ms	next INLIST if $ip->bits != $addr->bits and not $all; # spent 258ms making 505164 calls to NetAddr::IP::Lite::bits, avg 511ns/call
206
207	252582	250ms	252582	2.49s	if ($neg xor ($ip->contains($addr))) { # spent 2.49s making 252582 calls to NetAddr::IP::Lite::contains, avg 10µs/call
208					return 1 if not $all;
209					}
210					else {
211	252582	45.6ms			return 0 if $all;
212					}
213	252582	219ms			next INLIST;
214					}
215
216	204	751µs			return ($all ? 1 : 0);
217					}
218
219					1;

					# spent 103ms within App::Netdisco::Util::Permission::CORE:match which was called 757746 times, avg 135ns/call: # 252582 times (41.8ms+0s) by App::Netdisco::Util::Permission::check_acl at line 145, avg 165ns/call # 252582 times (32.5ms+0s) by App::Netdisco::Util::Permission::check_acl at line 132, avg 128ns/call # 252582 times (28.3ms+0s) by App::Netdisco::Util::Permission::check_acl at line 163, avg 112ns/call sub App::Netdisco::Util::Permission::CORE:match; # opcode
					# spent 328µs within App::Netdisco::Util::Permission::CORE:qr which was called 204 times, avg 2µs/call: # 204 times (328µs+0s) by App::Netdisco::Util::Permission::check_acl at line 113, avg 2µs/call sub App::Netdisco::Util::Permission::CORE:qr; # opcode
					# spent 56.5ms within App::Netdisco::Util::Permission::CORE:subst which was called 252582 times, avg 224ns/call: # 252582 times (56.5ms+0s) by App::Netdisco::Util::Permission::check_acl at line 130, avg 224ns/call sub App::Netdisco::Util::Permission::CORE:subst; # opcode