#!/usr/bin/perl # XMLRPC interface to IPDB search # Copyright (C) 2017 Kris Deugau use strict; use warnings; use DBI; use NetAddr::IP; use FCGI; use Frontier::Responder; use Sys::Syslog; # don't remove! required for GNU/FHS-ish install from tarball ##uselib## # push "the directory the script is in" into @INC use FindBin; use lib "$FindBin::RealBin/"; use MyIPDB; use CustIDCK; openlog "IPDB-search-rpc","pid","$IPDB::syslog_facility"; ##fixme: username source? can we leverage some other auth method? # we don't care except for logging here, and Frontier::Client needs # a patch that's not well-distributed to use HTTP AUTH. # Collect the username from HTTP auth. If undefined, we're in # a test environment, or called without a username. my $authuser; if (!defined($ENV{'REMOTE_USER'})) { $authuser = '__temptest'; } else { $authuser = $ENV{'REMOTE_USER'}; } # Why not a global DB handle? (And a global statement handle, as well...) # Use the connectDB function, otherwise we end up confusing ourselves my $ip_dbh; my $sth; my $errstr; ($ip_dbh,$errstr) = connectDB_My; initIPDBGlobals($ip_dbh); my $methods = { 'ipdb.search' => \&rpc_search, }; my $reqcnt = 0; my $req = FCGI::Request(); # main FCGI loop. while ($req->Accept() >= 0) { # done here to a) prevent $ENV{'REMOTE_ADDR'} from being empty and b) to collect # the right user for the individual call (since we may be running with FCGI) syslog "debug", "$authuser active, $ENV{'REMOTE_ADDR'}"; # don't *think* we need any of these... # %disp_alloctypes, %def_custids, %list_alloctypes # @citylist, @poplist # @masterblocks, %allocated, %free, %bigfree, %routed (removed in /trunk) # %IPDBacl #initIPDBGlobals($ip_dbh); my $res = Frontier::Responder->new( methods => $methods ); # "Can't do that" errors if (!$ip_dbh) { print "Content-type: text/xml\n\n".$res->{_decode}->encode_fault(5, $DBI::errstr); } else { print $res->answer; } last if $reqcnt++ > $IPDB::maxfcgi; } # while FCGI::accept exit 0; ## ## Private subs ## # Check RPC ACL sub _aclcheck { my $subsys = shift; return 1 if grep /$ENV{REMOTE_ADDR}/, @{$IPDB::rpcacl{$subsys}}; warn "$subsys/$ENV{REMOTE_ADDR} not in ACL\n"; # a bit of logging return 0; } sub _commoncheck { my $argref = shift; my $needslog = shift; die "Missing remote system name\n" if !$argref->{rpcsystem}; die "Access denied\n" if !_aclcheck($argref->{rpcsystem}); if ($needslog) { die "Missing remote username\n" if !$argref->{rpcuser}; } } # stripped-down copy from from main.cgi. should probably be moved to IPDB.pm sub _validateInput { my $argref = shift; if (!$argref->{block}) { $argref->{block} = $argref->{cidr} if $argref->{cidr}; die "Block/IP is required\n" if !$argref->{block}; } # Alloctype check. chomp $argref->{type}; die "Invalid allocation type\n" if (!grep /$argref->{type}/, keys %disp_alloctypes); # Arguably not quite correct, as the custID won't be checked for # validity if there's a default on the type. if ($def_custids{$argref->{type}} eq '') { # Types without a default custID must have one passed in die "Customer ID is required\n" if !$argref->{custid}; # Crosscheck with billing. my $status = CustIDCK->custid_exist($argref->{custid}); die "Error verifying customer ID: $CustIDCK::ErrMsg\n" if $CustIDCK::Error; die "Customer ID not valid\n" if !$status; } else { # Types that have a default will use it unless one is specified. if ((!$argref->{custid}) || ($argref->{custid} ne 'STAFF')) { $argref->{custid} = $def_custids{$argref->{type}}; } } } # end validateInput() ## ## RPC method subs ## sub rpc_search { my %args = @_; _commoncheck(\%args, 'n'); my @fields; my @vals; my @matchtypes; my %mt = (EXACT => '=', EQUAL => '=', NOT => '!~', # CIDR options MASK => 'MASK', WITHIN => '<<=', CONTAINS => '>>=', ); if ($args{type}) { push @fields, 's.type'; push @vals, $args{type}; push @matchtypes, '='; } ## CIDR query options. if ($args{cidr}) { $args{cidr} =~ s/^\s*(.+)\s*$/$1/g; # strip matching type substring, if any - only applies to full-CIDR my ($mnote) = $args{cidr} =~ /^(\w+):/; $args{cidr} =~ s/^$mnote:// if $mnote; if ($args{cidr} eq '') { # We has a blank CIDR. Ignore it. } elsif ($args{cidr} =~ /\//) { my ($net,$maskbits) = split /\//, $args{cidr}; if ($args{cidr} =~ /^(\d{1,3}\.){3}\d{1,3}\/\d{2}$/) { # Full CIDR match. push @fields, 's.cidr'; push @vals, $args{cidr}; if ($mnote =~ /(EQUAL|EXACT|CONTAINS|WITHIN)/) { push @matchtypes, $mt{$1}; } else { # default to exact match push @matchtypes, '='; } } elsif ($args{cidr} =~ /^(\d{1,3}\.){2}\d{1,3}\/\d{2}$/) { # Partial match; beginning of subnet and maskbits are provided # Show any blocks with the leading octet(s) and that masklength # eg 192.168.179/26 should show all /26 subnets in 192.168.179 # Need some more magic for bare /nn searches: push @fields, 's.cidr','masklen(s.cidr)'; push @vals, "$net.0/24", $maskbits; push @matchtypes, '<<=','='; } } elsif ($args{cidr} =~ /^(\d{1,3}\.){3}\d{1,3}$/) { # Specific IP address match. Will show the parent chain down to the final allocation. push @fields, 's.cidr'; push @vals, $args{cidr}; push @matchtypes, '>>='; } elsif ($args{cidr} =~ /^\d{1,3}(\.(\d{1,3}(\.(\d{1,3}\.?)?)?)?)?$/) { # 1, 2, or 3 leading octets in CIDR push @fields, 'text(s.cidr)'; push @vals, "$args{cidr}\%"; push @matchtypes, 'LIKE'; # hmm } else { # do nothing. ##fixme we'll ignore this to clear out the references to legacy code. } # done with CIDR query options. } # args{cidr} foreach (qw(custid description notes city) ) { if ($args{$_}) { push @fields, "s.$_"; if ($args{$_} =~ /^(EXACT|NOT):/) { push @matchtypes, $mt{$1}; $args{$_} =~ s/^$1://; } else { push @matchtypes, '~*'; } push @vals, $args{$_}; } } my $sql = q(SELECT s.cidr,s.custid,s.type,s.description,s.city,a.dispname FROM searchme s JOIN alloctypes a ON s.type = a.type); my @sqlcriteria; for (my $i = 0; $i <= $#fields; $i++) { push @sqlcriteria, "$fields[$i] $matchtypes[$i] ?"; } $sql .= " WHERE ".join(' AND ', @sqlcriteria) if @sqlcriteria; my $result = $ip_dbh->selectall_arrayref($sql, {Slice=>{}}, @vals); die $ip_dbh->errstr if !$result; return $result; } # rpc_search()