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