#!/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);

  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 my $sfield (qw(custid description notes city) ) {
    if ($args{$sfield}) {
      push @fields, "s.$sfield";
      if ($args{$sfield} =~ /^(EXACT|NOT):/) {
        push @matchtypes, $mt{$1};
        $args{$sfield} =~ s/^$1://;
      } else {
        push @matchtypes, '~*';
      }
      push @vals, $args{$sfield};
    }
  }

  if ($args{parent_id}) {
    # parent_id is always exact.  default to positive match
    if ($args{parent_id} =~ /^NOT:/) {
      $args{parent_id} =~ s/^NOT://;
      push @matchtypes, '<>';
    } else {
      push @matchtypes, '=';
    }
    push @fields, 's.parent_id';
    push @vals, $args{parent_id};
  }

  # 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, a.vrf, at.dispname";

  # Validation and SQL field name mapping all in one!
  my %validcols = (cidr => 's.cidr', custid => 's.custid', oldcustid => 's.oldcustid', type => 's.type', city => 's.city',
    description => 's.description', notes => 's.notes', circuitid => 's.circuitid', vrf => 'a.vrf', vlan => 's.vlan',
    id => 's.id', parent_id => 's.parent_id', master_id => 's.master_id', available => 's.available');
  my @usercols;

  if ($args{retfields}) {
    # caller wants a custom set of returned fields
    if (ref($args{retfields}) eq ref([])) {
      # field list passed as list/array
      foreach (@{$args{retfields}}) {
        push @usercols, $validcols{$_} if $validcols{$_};
      }
    } elsif (not ref $args{retfields}) {
      # field list passed as simple string
      foreach (split /\s+/, $args{retfields}) {
        push @usercols, $validcols{$_} if $validcols{$_};
      }
    } else {
      # nonfatal fail.  only accepts array or string.  fall back to default list
    }
  }

  # only replace the default set if a custom set was passed in
  $cols = join ', ', @usercols if @usercols;

  my $sql = qq(SELECT $cols FROM searchme s JOIN alloctypes at ON s.type = at.type JOIN allocations a ON s.master_id=a.id);
  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()


__END__

=pod

=head1 IPDB XMLRPC Search

This is a general-purpose search API for IPDB.  It is currently being extended based on requirements from other tools needing to 
search for data in IPDB.

It supports one XMLRPC sub, "search".

The calling URL for this API should end with "/search-rpc.cgi".  If you are doing many requests, you should use the FastCGI variant 
with .fcgi instead of .cgi.

=head2 Calling conventions

IPDB RPC services use "XMLRPC", http://xmlrpc.com, for data exchange.

Arguments are passed in as a key-value list, and data is returned as an array of hashes in some form.

=over 4

=item Perl

 use Frontier::Client;
 my $server = Frontier::Client->new(
   url => "http://server/path/search-rpc.cgi",
 );
 my %args = (
   rpcsystem => 'somesystem',
   rpcuser => 'someuser',
   arg1 => 'val1',
   arg2 => 'val2',
 );
 my $result = $server->call('ipdb.search', %args);

=item Python 2

 import xmlrpclib
 server = xmlrpclib.Server("http://server/path/search-rpc.cgi")
 result = server.ipdb.search(
     'rpcsystem', 'comesystems',
     'rpcuser', 'someuser',
     'arg1', 'val1',
     'arg2', 'val2',
     )

=item Python 3

 import xmlrpc.client
 server = xmlrpc.client.ServerProxy("http://server/path/search-rpc.cgi")
 result = server.ipdb.search(
     'rpcsystem', 'somesystem',
     'rpcuser', 'someuser',
     'arg1', 'val1',
     'arg2', 'val2',
     )

=back

=head3 Standard arguments

The C<rpcsystem> argument is required, and C<rpcuser> is strongly recommended as it may be used for access control in some future 
updates.

C<rpcsystem> must match a configuration entry in the IPDB configuration, and a given string may only be used from an IP listed under 
that configuration entry.

=head2 Search fields and metaoperators

Not all fields are exposed for search.  For most purposes these should be sufficient.

Most fields support EXACT: or NOT: prefixes on the search term to restrict the matches.

=over 4

=item cidr

A full or partial CIDR network or IP address.  Valid formats include:

=over 4

=item Complete CIDR network, eg 192.168.2.0/24

Returns an exact match for the passed CIDR network.

If prefixed with "CONTAINS:", the containing netblocks up to the master block 
will also be returned.

If prefixed with "WITHIN:", any suballocations in that IP range will be returned.

=item Partial/short CIDR specification with mask length, eg 192.168.3/27

Returns all /27 assignments within 192.168.3.0/24.

=item Partial/short CIDR specification, eg 192.168.4

Returns all assignments matching that leading partial string.  Note that 192.168.4 will also return 192.168.40.0/24 through 
192.168.49.0/24 as well as the obvious 192.168.4.0/24.

=item Bare IP address with no mask, eg 192.168.5.42

Returns all assignments containing that IP.

=back

=item custid

Match on a customer ID.  Defaults to a partial match.

=item type

Match the two-character internal allocation type identifier.

Defaults to an exact match.  Replace the first character with a dot or underscore, or leave it off, to match all subtypes of a 
class;  eg .i will return all types of static IP assignments.

A full list of current allocation types is available from the main RPC API's getTypeList sub.

=item city

Matches in the city string.

=item description

Matches in the description string.

=item notes

Matches in the notes field.

=item available

Only useful for static IPs.  For historic and architectural reasons, unallocated static IPs are included in general search results.  
Specify 'y' or 'n' to return only unallocated or allocated static IPs respectively.

To search for a free block, use the main RPC API's listFree or findAllocateFrom subs.

=item parent_id

Restrict to allocations in the given parent.

=item order

Sort order specification.  Send a string of comma-separated field names for subsorting.  Valid sort fields are cidr, custid, type, 
city, and description.

=item fields

Specify the fields to return from the search.  By default, these are returned:

=over 4

cidr
custid
type
city
description
id
parent_id
available
vrf
dispname  (the "display name" for the type)

=back

The following are available from this interface:

=over 4

cidr
custid
oldcustid
type
city
description
notes
circuitid
vrf
vlan
id
parent_id
master_id
available

=back

The list may be sent as a space-separated string or as an array.  Unknown field names will be ignored.

=back