1package App::Netdisco::Util::Permission; 2 3use strict; 4use warnings; 5use Dancer qw/:syntax :script/; 6 7use Scalar::Util qw/blessed reftype/; 8use NetAddr::IP::Lite ':lower'; 9use App::Netdisco::Util::DNS 'hostname_from_ip'; 10 11use base 'Exporter'; 12our @EXPORT = (); 13our @EXPORT_OK = qw/check_acl check_acl_no check_acl_only/; 14our %EXPORT_TAGS = (all => \@EXPORT_OK); 15 16=head1 NAME 17 18App::Netdisco::Util::Permission 19 20=head1 DESCRIPTION 21 22Helper subroutines to support parts of the Netdisco application. 23 24There are no default exports, however the C<:all> tag will export all 25subroutines. 26 27=head1 EXPORT_OK 28 29=head2 check_acl_no( $ip | $instance, $setting_name | $acl_entry | \@acl ) 30 31Given an IP address or object instance, returns true if the configuration 32setting C<$setting_name> matches, else returns false. If the content of the 33setting is undefined or empty, then C<check_acl_no> also returns false. 34 35If C<$setting_name> is a valid setting, then it will be resolved to the access 36control list, else we assume you passed an ACL entry or ACL. 37 38See L<the Netdisco wiki|https://github.com/netdisco/netdisco/wiki/Configuration#access-control-lists> 39for details of what C<$acl> may contain. 40 41=cut 42 43sub check_acl_no { 44 my ($thing, $setting_name) = @_; 45 return 1 unless $thing and $setting_name; 46 my $config = (exists config->{"$setting_name"} ? setting($setting_name) 47 : $setting_name); 48 return check_acl($thing, $config); 49} 50 51=head2 check_acl_only( $ip | $instance, $setting_name | $acl_entry | \@acl ) 52 53Given an IP address or object instance, returns true if the configuration 54setting C<$setting_name> matches, else returns false. If the content of the 55setting is undefined or empty, then C<check_acl_only> also returns true. 56 57If C<$setting_name> is a valid setting, then it will be resolved to the access 58control list, else we assume you passed an ACL entry or ACL. 59 60See L<the Netdisco wiki|https://github.com/netdisco/netdisco/wiki/Configuration#access-control-lists> 61for details of what C<$acl> may contain. 62 63=cut 64 65sub check_acl_only { 66 my ($thing, $setting_name) = @_; 67 return 0 unless $thing and $setting_name; 68 # logic to make an empty config be equivalent to 'any' (i.e. a match) 69 my $config = (exists config->{"$setting_name"} ? setting($setting_name) 70 : $setting_name); 71 return 1 if not $config # undef or empty string 72 or ((ref [] eq ref $config) and not scalar @$config); 73 return check_acl($thing, $config); 74} 75 76=head2 check_acl( $ip | $instance, $acl_entry | \@acl ) 77 78Given 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 80all must match, and items can be negated to invert the match logic. 81 82Accepts instances of classes representing Netdisco Devices, Netdisco Device 83IPs, and L<NetAddr::IP> family objects. 84 85There are several options for what C<< \@acl >> may contain. See 86L<the Netdisco wiki|https://github.com/netdisco/netdisco/wiki/Configuration#access-control-lists> 87for the details. 88 89=cut 90 91sub check_acl { 92 my ($thing, $config) = @_; 93 return 0 unless defined $thing and defined $config; 94 95 my $real_ip = $thing; 96 if (blessed $thing) { 97 $real_ip = ($thing->can('alias') ? $thing->alias : ( 98 $thing->can('ip') ? $thing->ip : ( 99 $thing->can('addr') ? $thing->addr : $thing ))); 100 } 101 return 0 if !defined $real_ip 102 or blessed $real_ip; # class we do not understand 103 104 $config = [$config] if ref '' eq ref $config; 105 if (ref [] ne ref $config) { 106 error "error: acl is not a single item or list (cannot compare to $real_ip)"; 107 return 0; 108 } 109 my $all = (scalar grep {$_ eq 'op:and'} @$config); 110 111 # common case of using plain IP in ACL, so string compare for speed 112 my $find = (scalar grep {not reftype $_ and $_ eq $real_ip} @$config); 113 return 1 if $find and not $all; 114 115 my $addr = NetAddr::IP::Lite->new($real_ip) or return 0; 116 my $name = undef; # only look up once, and only if qr// is used 117 my $ropt = { retry => 1, retrans => 1, udp_timeout => 1, tcp_timeout => 2 }; 118 my $qref = ref qr//; 119 120 INLIST: foreach (@$config) { 121 my $item = $_; # must copy so that we can modify safely 122 next INLIST if !defined $item or $item eq 'op:and'; 123 124 if ($qref eq ref $item) { 125 $name = ($name || hostname_from_ip($addr->addr, $ropt) || '!!none!!'); 126 if ($name =~ $item) { 127 return 1 if not $all; 128 } 129 else { 130 return 0 if $all; 131 } 132 next INLIST; 133 } 134 135 my $neg = ($item =~ s/^!//); 136 137 if ($item =~ m/^group:(.+)$/) { 138 my $group = $1; 139 setting('host_groups')->{$group} ||= []; 140 141 if ($neg xor check_acl($thing, setting('host_groups')->{$group})) { 142 return 1 if not $all; 143 } 144 else { 145 return 0 if $all; 146 } 147 next INLIST; 148 } 149 150 if ($item =~ m/^([^:]+):([^:]+)$/) { 151 my $prop = $1; 152 my $match = $2; 153 154 # if not an object, we can't do much with properties 155 next INLIST unless blessed $thing; 156 157 # lazy version of vendor: and model: 158 if ($neg xor ($thing->can($prop) and defined eval { $thing->$prop } 159 and $thing->$prop =~ m/^$match$/)) { 160 return 1 if not $all; 161 } 162 else { 163 return 0 if $all; 164 } 165 next INLIST; 166 } 167 168 if ($item =~ m/[:.]([a-f0-9]+)-([a-f0-9]+)$/i) { 169 my $first = $1; 170 my $last = $2; 171 172 if ($item =~ m/:/) { 173 next INLIST if $addr->bits != 128 and not $all; 174 175 $first = hex $first; 176 $last = hex $last; 177 178 (my $header = $item) =~ s/:[^:]+$/:/; 179 foreach my $part ($first .. $last) { 180 my $ip = NetAddr::IP::Lite->new($header . sprintf('%x',$part) . '/128') 181 or next; 182 if ($neg xor ($ip == $addr)) { 183 return 1 if not $all; 184 next INLIST; 185 } 186 } 187 return 0 if (not $neg and $all); 188 return 1 if ($neg and not $all); 189 } 190 else { 191 next INLIST if $addr->bits != 32 and not $all; 192 193 (my $header = $item) =~ s/\.[^.]+$/./; 194 foreach my $part ($first .. $last) { 195 my $ip = NetAddr::IP::Lite->new($header . $part . '/32') 196 or next; 197 if ($neg xor ($ip == $addr)) { 198 return 1 if not $all; 199 next INLIST; 200 } 201 } 202 return 0 if (not $neg and $all); 203 return 1 if ($neg and not $all); 204 } 205 next INLIST; 206 } 207 208 # could be something in error, and IP/host is only option left 209 next INLIST if ref $item; 210 211 my $ip = NetAddr::IP::Lite->new($item) 212 or next INLIST; 213 next INLIST if $ip->bits != $addr->bits and not $all; 214 215 if ($neg xor ($ip->contains($addr))) { 216 return 1 if not $all; 217 } 218 else { 219 return 0 if $all; 220 } 221 next INLIST; 222 } 223 224 return ($all ? 1 : 0); 225} 226 2271; 228