more progress but stalled at regexp acl handling
This commit is contained in:
		@@ -2,7 +2,8 @@ package App::Netdisco::Util::Device;
 | 
			
		||||
 | 
			
		||||
use Dancer qw/:syntax :script/;
 | 
			
		||||
use Dancer::Plugin::DBIC 'schema';
 | 
			
		||||
use App::Netdisco::Util::Permission qw/check_acl_no check_acl_only/;
 | 
			
		||||
use App::Netdisco::Util::Permission
 | 
			
		||||
  qw/check_acl_no check_acl_only acl_to_where_clause/;
 | 
			
		||||
 | 
			
		||||
use base 'Exporter';
 | 
			
		||||
our @EXPORT = ();
 | 
			
		||||
@@ -11,7 +12,7 @@ our @EXPORT_OK = qw/
 | 
			
		||||
  delete_device
 | 
			
		||||
  renumber_device
 | 
			
		||||
  match_to_setting
 | 
			
		||||
  device_ips_matching device_ips_not_matching
 | 
			
		||||
  device_ips_matching
 | 
			
		||||
  is_discoverable is_discoverable_now
 | 
			
		||||
  is_arpnipable   is_arpnipable_now
 | 
			
		||||
  is_macsuckable  is_macsuckable_now
 | 
			
		||||
@@ -145,21 +146,25 @@ sub match_to_setting {
 | 
			
		||||
                        @{setting($setting_name) || []});
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
=head2 device_ips_matching( $setting_name | $acl_entry | \@acl, @IPs? )
 | 
			
		||||
=head2 device_ips_matching( $setting_name | $acl_entry | \@acl, ... )
 | 
			
		||||
 | 
			
		||||
Returns a list of Device IPs that match the given ACL. If the ACL is
 | 
			
		||||
missing then no device IPs will be returned. If the C< @IPs > list is
 | 
			
		||||
provided then it will be used otherwise the current devices in Netdisco's
 | 
			
		||||
database will be used as the source list.
 | 
			
		||||
Returns a list of Device IPs that match the given ACL. If the ACL is missing
 | 
			
		||||
then no device IPs will be returned. If a second ACL is also passed then that
 | 
			
		||||
will work as an exclusion list applied at the same time.
 | 
			
		||||
 | 
			
		||||
=cut
 | 
			
		||||
 | 
			
		||||
sub device_ips_matching {
 | 
			
		||||
    my ($acl, @ips) = @_;
 | 
			
		||||
    return () unless $acl;
 | 
			
		||||
    my $config = (exists config->{"$acl"} ? setting($acl) : $acl);
 | 
			
		||||
    my @startlist = (scalar @ips ? @ips :
 | 
			
		||||
      schema('netdisco')->resultset('Device')->get_column('ip')->all);
 | 
			
		||||
    my ($acl_only, $acl_no) = @_;
 | 
			
		||||
    return () unless $acl_only;
 | 
			
		||||
    my $only = acl_to_where_clause($acl_only);
 | 
			
		||||
    my $no   = acl_to_where_clause($acl_no);
 | 
			
		||||
    my $no_query = schema('netdisco')->resultset('Device')
 | 
			
		||||
      ->search({ $no }, { select => ['ip'] });
 | 
			
		||||
 | 
			
		||||
    return schema('netdisco')->resultset('Device')->search({ $only,
 | 
			
		||||
      ($no ? { ip => { -not_in => $no_query->as_query } } : ()) })
 | 
			
		||||
      ->get_column('ip')->all;
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
sub _bail_msg { debug $_[0]; return 0; }
 | 
			
		||||
 
 | 
			
		||||
@@ -10,7 +10,12 @@ use App::Netdisco::Util::DNS 'hostname_from_ip';
 | 
			
		||||
 | 
			
		||||
use base 'Exporter';
 | 
			
		||||
our @EXPORT = ();
 | 
			
		||||
our @EXPORT_OK = qw/check_acl check_acl_no check_acl_only/;
 | 
			
		||||
our @EXPORT_OK = qw/
 | 
			
		||||
  check_acl
 | 
			
		||||
  check_acl_no 
 | 
			
		||||
  check_acl_only
 | 
			
		||||
  acl_to_where_clause
 | 
			
		||||
/;
 | 
			
		||||
our %EXPORT_TAGS = (all => \@EXPORT_OK);
 | 
			
		||||
 | 
			
		||||
=head1 NAME
 | 
			
		||||
@@ -217,4 +222,135 @@ sub check_acl {
 | 
			
		||||
  return ($all ? 1 : 0);
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
1;
 | 
			
		||||
=head2 acl_to_where_clause( $setting_name | $acl_entry | \@acl )
 | 
			
		||||
 | 
			
		||||
Returns an L<SQL::Abstract> where clause which when applied to the devices
 | 
			
		||||
table should return the matching records only.
 | 
			
		||||
 | 
			
		||||
If C<$setting_name> is a valid setting, then it will be resolved to the access
 | 
			
		||||
control list, else we assume you passed an ACL entry or ACL.
 | 
			
		||||
 | 
			
		||||
A missing parameter will return the C<sqltrue> value (usually C<1=1>).
 | 
			
		||||
 | 
			
		||||
See L<the Netdisco wiki|https://github.com/netdisco/netdisco/wiki/Configuration#access-control-lists>
 | 
			
		||||
for details of what C<$acl> may contain.
 | 
			
		||||
 | 
			
		||||
=cut
 | 
			
		||||
 | 
			
		||||
sub check_acl_only {
 | 
			
		||||
  my ($setting_name) = @_;
 | 
			
		||||
  return (1 => 1) unless $setting_name;
 | 
			
		||||
  my $config = (exists config->{"$setting_name"} ? setting($setting_name)
 | 
			
		||||
                                                 : $setting_name);
 | 
			
		||||
  
 | 
			
		||||
  $config  = [$config] if ref [] ne ref $config;
 | 
			
		||||
  my $all  = (scalar grep {$_ eq 'op:and'} @$config);
 | 
			
		||||
  
 | 
			
		||||
  my $ropt = { retry => 1, retrans => 1, udp_timeout => 1, tcp_timeout => 2 };
 | 
			
		||||
  my $qref = ref qr//;
 | 
			
		||||
  my %where = ();
 | 
			
		||||
  
 | 
			
		||||
  INLIST: foreach (@$config) {
 | 
			
		||||
      my $item = $_; # must copy so that we can modify safely
 | 
			
		||||
      next INLIST if !defined $item or $item eq 'op:and';
 | 
			
		||||
 | 
			
		||||
      if ($qref eq ref $item) {
 | 
			
		||||
          push @{ $where{dns}{
 | 
			
		||||
          $name = ($name || hostname_from_ip($addr->addr, $ropt) || '!!none!!');
 | 
			
		||||
          if ($name =~ $item) {
 | 
			
		||||
            return 1 if not $all;
 | 
			
		||||
          }
 | 
			
		||||
          else {
 | 
			
		||||
            return 0 if $all;
 | 
			
		||||
          }
 | 
			
		||||
          next INLIST;
 | 
			
		||||
      }
 | 
			
		||||
 | 
			
		||||
      my $neg = ($item =~ s/^!//);
 | 
			
		||||
 | 
			
		||||
      if ($item =~ m/^group:(.+)$/) {
 | 
			
		||||
          my $group = $1;
 | 
			
		||||
          setting('host_groups')->{$group} ||= [];
 | 
			
		||||
 | 
			
		||||
          if ($neg xor check_acl($thing, setting('host_groups')->{$group})) {
 | 
			
		||||
            return 1 if not $all;
 | 
			
		||||
          }
 | 
			
		||||
          else {
 | 
			
		||||
            return 0 if $all;
 | 
			
		||||
          }
 | 
			
		||||
          next INLIST;
 | 
			
		||||
      }
 | 
			
		||||
 | 
			
		||||
      if ($item =~ m/^([^:]+):([^:]+)$/) {
 | 
			
		||||
          my $prop  = $1;
 | 
			
		||||
          my $match = $2;
 | 
			
		||||
 | 
			
		||||
          # if not an object, we can't do much with properties
 | 
			
		||||
          next INLIST unless blessed $thing;
 | 
			
		||||
 | 
			
		||||
          # lazy version of vendor: and model:
 | 
			
		||||
          if ($neg xor ($thing->can($prop) and defined eval { $thing->$prop }
 | 
			
		||||
              and $thing->$prop =~ m/^$match$/)) {
 | 
			
		||||
            return 1 if not $all;
 | 
			
		||||
          }
 | 
			
		||||
          else {
 | 
			
		||||
            return 0 if $all;
 | 
			
		||||
          }
 | 
			
		||||
          next INLIST;
 | 
			
		||||
      }
 | 
			
		||||
 | 
			
		||||
      if ($item =~ m/[:.]([a-f0-9]+)-([a-f0-9]+)$/i) {
 | 
			
		||||
          my $first = $1;
 | 
			
		||||
          my $last  = $2;
 | 
			
		||||
 | 
			
		||||
          if ($item =~ m/:/) {
 | 
			
		||||
              next INLIST if $addr->bits != 128 and not $all;
 | 
			
		||||
 | 
			
		||||
              $first = hex $first;
 | 
			
		||||
              $last  = hex $last;
 | 
			
		||||
 | 
			
		||||
              (my $header = $item) =~ s/:[^:]+$/:/;
 | 
			
		||||
              foreach my $part ($first .. $last) {
 | 
			
		||||
                  my $ip = NetAddr::IP::Lite->new($header . sprintf('%x',$part) . '/128')
 | 
			
		||||
                    or next;
 | 
			
		||||
                  if ($neg xor ($ip == $addr)) {
 | 
			
		||||
                    return 1 if not $all;
 | 
			
		||||
                    next INLIST;
 | 
			
		||||
                  }
 | 
			
		||||
              }
 | 
			
		||||
              return 0 if (not $neg and $all);
 | 
			
		||||
              return 1 if ($neg and not $all);
 | 
			
		||||
          }
 | 
			
		||||
          else {
 | 
			
		||||
              next INLIST if $addr->bits != 32 and not $all;
 | 
			
		||||
 | 
			
		||||
              (my $header = $item) =~ s/\.[^.]+$/./;
 | 
			
		||||
              foreach my $part ($first .. $last) {
 | 
			
		||||
                  my $ip = NetAddr::IP::Lite->new($header . $part . '/32')
 | 
			
		||||
                    or next;
 | 
			
		||||
                  if ($neg xor ($ip == $addr)) {
 | 
			
		||||
                    return 1 if not $all;
 | 
			
		||||
                    next INLIST;
 | 
			
		||||
                  }
 | 
			
		||||
              }
 | 
			
		||||
              return 0 if (not $neg and $all);
 | 
			
		||||
              return 1 if ($neg and not $all);
 | 
			
		||||
          }
 | 
			
		||||
          next INLIST;
 | 
			
		||||
      }
 | 
			
		||||
 | 
			
		||||
      my $ip = NetAddr::IP::Lite->new($item)
 | 
			
		||||
        or next INLIST;
 | 
			
		||||
      next INLIST if $ip->bits != $addr->bits and not $all;
 | 
			
		||||
 | 
			
		||||
      if ($neg xor ($ip->contains($addr))) {
 | 
			
		||||
        return 1 if not $all;
 | 
			
		||||
      }
 | 
			
		||||
      else {
 | 
			
		||||
        return 0 if $all;
 | 
			
		||||
      }
 | 
			
		||||
      next INLIST;
 | 
			
		||||
  }
 | 
			
		||||
}
 | 
			
		||||
 | 
			
		||||
true;
 | 
			
		||||
 
 | 
			
		||||
		Reference in New Issue
	
	Block a user