source: trunk/cgi-bin/ipdb-rpc.cgi@ 866

#!/usr/bin/perl
# XMLRPC interface to manipulate most DNS DB entities
###
# $Id: ipdb-rpc.cgi 866 2016-05-02 21:59:07Z kdeugau $
###
# Copyright (C) 2013,2014,2016 Kris Deugau <kdeugau@deepnet.cx>

use strict;
use warnings;

use DBI;
use CustIDCK;
use NetAddr::IP;
use FCGI;
use Frontier::Responder;

use Sys::Syslog;

# don't remove!  required for GNU/FHS-ish install from tarball
##uselib##

use MyIPDB;

openlog "IPDB-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 = {
        # Internal core IPDB subs;  no value in exposing them since the DB handle can't be used by the caller
        #'ipdb._rpc'
        # This one could be exposed, but the globals aren't automatically
        # inherited by the caller anyway, and we call it just above locally.
        #'ipdb.initIPDBGlobals'
        #'ipdb.connectDB'
        #'ipdb.finish'
        #'ipdb.checkDBSanity'
        'ipdb.addMaster'        =>      \&rpc_addMaster,
        'ipdb.touchMaster'      =>      \&rpc_touchMaster,
        'ipdb.listSummary'      =>      \&rpc_listSummary,
        'ipdb.listSubs' =>      \&rpc_listSubs,
        'ipdb.listContainers'   =>      \&rpc_listContainers,
        'ipdb.listAllocations'  =>      \&rpc_listAllocations,
        'ipdb.listFree' =>      \&rpc_listFree,
        'ipdb.listPool' =>      \&rpc_listPool,
        'ipdb.getMasterList'    =>      \&rpc_getMasterList,
        'ipdb.getTypeList'      =>      \&rpc_getTypeList,
        'ipdb.getPoolSelect'    =>      \&rpc_getPoolSelect,
        'ipdb.findAllocateFrom' =>      \&rpc_findAllocateFrom,
        'ipdb.ipParent' =>      \&rpc_ipParent,
        'ipdb.subParent'        =>      \&rpc_subParent,
        'ipdb.blockParent'      =>      \&rpc_blockParent,
        'ipdb.getRoutedCity'    =>      \&rpc_getRoutedCity,
        'ipdb.allocateBlock'    =>      \&rpc_allocateBlock,
        # another internal sub;  mainly a sub to make allocateBlock() a lot smaller
        #'ipdb.initPool'        =>      \&rpc_initPool
        'ipdb.updateBlock'      =>      \&rpc_updateBlock,
        'ipdb.deleteBlock'      =>      \&rpc_deleteBlock,
        'ipdb.getBlockData'     =>      \&rpc_getBlockData,
        'ipdb.getBlockRDNS'     =>      \&rpc_getBlockRDNS,
        'ipdb.getNodeList'      =>      \&rpc_getNodeList,
        'ipdb.getNodeName'      =>      \&rpc_getNodeName,
        'ipdb.getNodeInfo'      =>      \&rpc_getNodeInfo,
        'ipdb.mailNotify'       =>      \&rpc_mailNotify,

# Subs not part of the core IPDB
        'ipdb.getDispAlloctypes'        => \&rpc_getDispAlloctypes,
        'ipdb.getListAlloctypes'        => \&rpc_getListAlloctypes,
        'ipdb.getDefCustIDs'    => \&rpc_getDefCustIDs,
        'ipdb.getCityList'      => \&rpc_getCityList,
        'ipdb.getAvailableStatics'      => \&rpc_getAvailableStatics,
        'ipdb.getBackupList'    => \&rpc_getBackupList,
};

my $reqcnt = 0;

# main FCGI loop.
while (FCGI::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
##

# Core IPDB subs
# Prefixed with rpc_ to not conflict with subs in IPDB.pm

# These are deep internals and don't make much sense to expose, since RPC
# by definition does not access the backing DB directly.
#sub _rpc {}
#sub initIPDBGlobals {}
#sub connectDB {}
#sub finish {}
#sub checkDBSanity {}

sub rpc_addMaster {}
sub rpc_touchMaster {}
sub rpc_listSummary {}
sub rpc_listSubs {}
sub rpc_listContainers {}
sub rpc_listAllocations {}
sub rpc_listFree {}


sub rpc_listPool {
  my %args = @_;

  _commoncheck(\%args, 'y');

  $args{include_desc} = 0 if !$args{include_desc};

  # convert passed pool from CIDR to an ID, maybe
  if ($args{pool} !~ /^\d+$/) {
    die "Invalid pool argument" if $args{pool} !~ m{^\d+\.\d+\.\d+\.\d+/\d+$};
    die "VRF is required\n" if !$args{vrf};  # VRF name may not be empty
    ($pid) = $ip_dbh->selectrow_array("SELECT a.id FROM allocations a JOIN allocations m ON a.master_id=m.id".
        " WHERE a.cidr = ? AND m.vrf = ?", undef, $args{pool}, $args{vrf});
  }

  return listPool($ip_dbh, $pid, $args{include_desc});
} # rpc_listPool()


sub rpc_getMasterList {}
sub rpc_getTypeList {}
sub rpc_getPoolSelect {}
sub rpc_findAllocateFrom {}
sub rpc_ipParent {}
sub rpc_subParent {}
sub rpc_blockParent {}
sub rpc_getRoutedCity {}

sub rpc_allocateBlock {
  my %args = @_;

  _commoncheck(\%args, 'y');

  _validateInput(\%args);

  # Not required for update, delete
  die "City is required\n" if !$args{city};
  die "Customer ID is required\n" if !$args{custid};
  die "Allocation type is required\n" if !$args{type};

  if ($args{type} =~ /^.i$/) {
    die "Pool ID or VRF to allocate from is required\n" if !$args{parent} && !$args{vrf};
  } else {
    die "Free block to allocate from is required\n" if !$args{fbid};
  }

  my ($code,$msg) = allocateBlock($ip_dbh, %args);

  if ($code eq 'OK' || $code eq 'WARN') {
    if ($args{type} =~ /^.i$/) {
      $msg =~ s|/32||;
      mailNotify($ip_dbh, "a$args{type}", "ADDED: $disp_alloctypes{$args{type}} allocation",
        "$disp_alloctypes{$args{type}} $msg allocated to customer $args{custid}\n".
        "Description: $args{desc}\n\nAllocated by: $args{rpcsystem}/$args{rpcuser}\n");
    } else {
      my $netblock = new NetAddr::IP $args{block};
      mailNotify($ip_dbh, "a$args{type}", "ADDED: $disp_alloctypes{$args{type}} allocation",
        "$disp_alloctypes{$args{type}} $args{block} allocated to customer $args{custid}\n".
        "Description: $args{desc}\n\nAllocated by: $args{rpcsystem}/$args{rpcuser}\n");
    }
    syslog "notice", "$args{rpcsystem}/$args{rpcuser} allocated '$args{block}' to '$args{custid}' as ".
        "'$args{type}' ($msg)";
  } else {
    syslog "err", "Allocation of '$args{block}' to '$args{custid}' as ".
        "'$args{type}' by $args{rpcsystem}/$args{rpcuser} failed: '$msg'";
    die "$msg\n";
  }
  return $msg;
} # rpc_allocateBlock()

# another internal sub;  mainly a sub to make allocateBlock() a lot smaller
#sub rpc_initPool {}


sub rpc_updateBlock {
  my %args = @_;

  _commoncheck(\%args, 'y');

  _validateInput(\%args);

  # Allow caller to send a CIDR instead of the block ID.
  $args{origblock} = $args{block};
  if ($args{block} =~ m{^(?:\d+\.){3}\d+(?:/32)?$}) {
    # updating a static IP.  retrieve the IP ID based on either the parent or VRF.
    die "Pool ID or VRF is required\n" if !$args{parent} && !$args{vrf};
    ($args{block}) = $ip_dbh->selectrow_array(
        "SELECT id FROM poolips WHERE ip = ? AND ".($args{parent} ? "parent_id = ?" : "vrf = ?"),
        undef, $args{block}, ($args{parent} ? $args{parent} : $args{vrf}) );
  }

  my $binfo = getBlockData($ip_dbh, $args{block}, $args{type});

  # set assignIP_on_update to simplify some calling situations.  better to use allocateBlock if possible though.
  my ($code,$msg) = updateBlock($ip_dbh, %args, assignIP_on_update => 1);
  if ($code eq 'FAIL') {
    syslog "err", "$args{rpcsystem}/$args{rpcuser} could not update block/IP $args{block} ($binfo->{block}): '$msg'";
    die "$msg\n";
  }
  syslog "notice", "$args{rpcsystem}/$args{rpcuser} updated $args{block} ($binfo->{block})";

  return $msg;
} # rpc_updateBlock()


sub rpc_deleteBlock {
  my %args = @_;

  _commoncheck(\%args, 'y');

  if (!$args{block}) {
    $args{block} = $args{cidr} if $args{cidr};
    die "Block/IP is required\n" if !$args{block};
  }

  if ($args{block} =~ m{^(?:\d+\.){3}\d+(?:/32)?$}) {
    # deleting a static IP.  retrieve the IP ID based on either the parent or VRF.
    die "Pool ID or VRF is required\n" if !$args{parent} && !$args{vrf};
    ($args{block}) = $ip_dbh->selectrow_array(
        "SELECT id FROM poolips WHERE ip = ? AND ".($args{parent} ? "parent_id = ?" : "vrf = ?"),
        undef, $args{block}, ($args{parent} ? $args{parent} : $args{vrf}) );
    warn "passed block $args{block} guessed as $args{block}\n";
  }

  # snag block info for log
  my $blockinfo = getBlockData($ip_dbh, $args{block}, $args{type});
  my ($code,$msg) = deleteBlock($ip_dbh, $args{block}, $args{type}, $args{delfwd}, $args{rpcuser});

  my $authuser = "$args{rpcsystem}/$args{rpcuser}";
  if ($code eq 'OK' || $code =~ /^WARN/) {
    syslog "notice", "$authuser deallocated '$blockinfo->{type}'-type netblock ID $args{block} ".
        "($blockinfo->{block}), $blockinfo->{custid}, $blockinfo->{city}, desc='$blockinfo->{description}'";
    mailNotify($ip_dbh, 'da', "REMOVED: $disp_alloctypes{$blockinfo->{type}} $blockinfo->{block}",
# $args{block} useful?  do we care about the block ID here?
        "$disp_alloctypes{$blockinfo->{type}} $blockinfo->{block} deallocated by $authuser\n".
        "CustID: $blockinfo->{custid}\nCity: $blockinfo->{city}\n".
        "Description: $blockinfo->{description}\n");
  } else {
    if ($args{type} =~ /^.i$/) {
      syslog "err", "$authuser could not deallocate static IP ID $args{block} ($blockinfo->{block}): '$msg'";
    } else {
      syslog "err", "$authuser could not deallocate netblock ID $args{block} ($blockinfo->{block}): '$msg'";
    }
  }

   return $msg;
} # rpc_deleteBlock()


sub rpc_getBlockData {}
sub rpc_getBlockRDNS {}
sub rpc_getNodeList {}
sub rpc_getNodeName {}
sub rpc_getNodeInfo {}
sub rpc_mailNotify {}


##
## Subs not part of the core IPDB
##

# Subs to send back IPDB globals

#our %disp_alloctypes;
sub rpc_getDispAlloctypes {
  my %args = @_;
  _commoncheck(\%args, 'n');
  return \%disp_alloctypes;
}

#our %list_alloctypes;
sub rpc_getListAlloctypes {
  my %args = @_;
  _commoncheck(\%args, 'n');
  return \%list_alloctypes;
}

#our %def_custids;
sub rpc_getDefCustIDs {
  my %args = @_;
  _commoncheck(\%args, 'n');
  return \%def_custids;
}

#our @citylist;
sub rpc_getCityList {
  my %args = @_;
  _commoncheck(\%args, 'n');
  return \@citylist;
}

#our @poplist;
sub rpc_getPOPList {
  my %args = @_;
  _commoncheck(\%args, 'n');
  return \@poplist;
}

# not sure how useful it is to expose this on RPC
#our %IPDBacl;
sub rpc_getIPDBacl {
  my %args = @_;
  _commoncheck(\%args, 'n');
  return \%IPDBacl;
}

# Operations not provided directly by the core IPDB

# Get a list of available static IPs of the given type
# Not a core IPDB sub since there's little use for this format.
sub rpc_getAvailableStatics {
  my %args = @_;

  _commoncheck(\%args, 'n');

  my ($base,undef) = split //, $args{type};
  $base .= "_";
  my @params = ($base);

  my $sql = "SELECT poolips.id,poolips.ip,poolips.parent_id,poolips.pool ".
        "FROM poolips JOIN allocations ON poolips.parent_id=allocations.id WHERE poolips.type LIKE ?";
  if ($base ne 'd_' && $args{city}) {
    $sql .= " AND allocations.city=?";
    push @params, $args{city};
  }
  $sql .= " AND poolips.available='y'";

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

  return $ret;
} # rpc_getAvailableStatics()


sub rpc_getBackupList {
  my %args = @_;

  _commoncheck(\%args, 'n');

  # grab the whole waffle.
  my $sql = "SELECT backup_id, bkbrand, bkmodel, bktype, bkport, bksrc, bkuser, bkvpass, bkepass, ip FROM backuplist";
  my $result = $ip_dbh->selectall_arrayref($sql, { Slice => {} });
  die $ip_dbh->errstr if !$result;

  return $result;
} # rpc_getBackupList()