#!/usr/bin/perl
# XMLRPC interface to IPDB search
# Copyright (C) 2017 Kris Deugau <kdeugau@deepnet.cx>

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 => '!~',	# text only?
	# CIDR options
	MASK => 'MASK',
	WITHIN => '<<=',
	CONTAINS => '>>=',
	);

  if ($args{type}) {
    # assume alloctype class if we only get one letter
    $args{type} = "_$args{type}" if $args{type} =~ /^.$/;
    my $notflag = '';
    if ($args{type} =~ /^NOT:/) {
      $args{type} =~ s/^NOT://;
      $notflag = 'NOT ';
    }
    if ($args{type} =~ /\./) {
      $args{type} =~ s/\./_/;
      push @matchtypes, $notflag.'LIKE';
    } else {
      push @matchtypes, ($notflag ? '<>' : '=');
    }
    push @fields, 's.type';
    push @vals, $args{type};
  }

  ## 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{$_};
    }
  }

  # Filter on "available", because we can.
  if ($args{available} && $args{available} =~ /^[yn]$/) {
    push @fields, "s.available";
    push @matchtypes, '=';
    push @vals, $args{available};
  }

  my $cols = "s.cidr, s.custid, s.type, s.city, s.description, s.id, s.parent_id, s.available, s.vrf, a.dispname";
  my $sql = qq(SELECT $cols 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;

  # multifield sorting!
  if ($args{order}) {
    my @ordfields = split /,/, $args{order};
    # there are probably better ways to do this
    my %omap = (cidr => 's.cidr', net => 's.cidr', network => 's.cidr', ip => 's.cidr',
      custid => 's.custid', type => 's.type', city => 's.city',
      desc => 's.description', description => 's.description');
    my @ordlist;
    # only pass sort field values from the list of acceptable field names or aliases as per %omap
    foreach my $ord (@ordfields) {
      push @ordlist, $omap{$ord}
        if grep /^$ord$/, (keys %omap);
    }
    if (@ordlist) {
      $sql .= " ORDER BY ". join(',', @ordlist);
    }
  }

  my $result = $ip_dbh->selectall_arrayref($sql, {Slice=>{}}, @vals);
  die $ip_dbh->errstr if !$result;

  return $result;
} # rpc_search()