# ipdb/cgi-bin/IPDB.pm # Contains functions for IPDB - database access, subnet mangling, block allocation, etc ### # SVN revision info # $Date: 2013-01-25 21:16:04 +0000 (Fri, 25 Jan 2013) $ # SVN revision $Rev: 591 $ # Last update by $Author: kdeugau $ ### # Copyright (C) 2004-2010 - Kris Deugau package IPDB; use strict; use warnings; use Exporter; use DBI; use Net::SMTP; use NetAddr::IP qw(:lower Compact ); use Frontier::Client; use POSIX; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); $VERSION = 2; ##VERSION## @ISA = qw(Exporter); @EXPORT_OK = qw( %disp_alloctypes %list_alloctypes %def_custids @citylist @poplist %IPDBacl %aclmsg $errstr &initIPDBGlobals &connectDB &finish &checkDBSanity &addMaster &touchMaster &listSummary &listSubs &listFree &listPool &getMasterList &getTypeList &getPoolSelect &findAllocateFrom &ipParent &subParent &blockParent &getRoutedCity &allocateBlock &updateBlock &deleteBlock &getBlockData &getBlockRDNS &getNodeList &getNodeName &getNodeInfo &mailNotify ); @EXPORT = (); # Export nothing by default. %EXPORT_TAGS = ( ALL => [qw( %disp_alloctypes %list_alloctypes %def_custids @citylist @poplist %IPDBacl %aclmsg $errstr &initIPDBGlobals &connectDB &finish &checkDBSanity &addMaster &touchMaster &listSummary &listSubs &listFree &listPool &getMasterList &getTypeList &getPoolSelect &findAllocateFrom &ipParent &subParent &blockParent &getRoutedCity &allocateBlock &updateBlock &deleteBlock &getBlockData &getBlockRDNS &getNodeList &getNodeName &getNodeInfo &mailNotify )] ); ## ## Global variables ## our %disp_alloctypes; our %list_alloctypes; our %def_custids; our @citylist; our @poplist; our %IPDBacl; # mapping table for functional-area => error message our %aclmsg = ( addmaster => 'add a master block', addblock => 'add an allocation', updateblock => 'update a block', delblock => 'delete an allocation', ); # error reporting our $errstr = ''; our $org_name = 'Example Corp'; our $smtphost = 'smtp.example.com'; our $domain = 'example.com'; our $defcustid = '5554242'; # mostly for rwhois ##fixme: leave these blank by default? our $rwhoisDataPath = '/usr/local/rwhoisd/etc/rwhoisd'; # to match ./configure defaults from rwhoisd-1.5.9.6 our $org_street = '123 4th Street'; our $org_city = 'Anytown'; our $org_prov_state = 'ON'; our $org_pocode = 'H0H 0H0'; our $org_country = 'CA'; our $org_phone = '000-555-1234'; our $org_techhandle = 'ISP-ARIN-HANDLE'; our $org_email = 'noc@example.com'; our $hostmaster = 'dns@example.com'; our $syslog_facility = 'local2'; our $rpc_url = ''; our $revgroup = 1; # should probably be configurable somewhere our $rpccount = 0; ## ## Internal utility functions ## ## IPDB::_rpc # Make an RPC call for DNS changes sub _rpc { return if !$rpc_url; # Just In Case my $rpcsub = shift; my %args = @_; # Make an object to represent the XML-RPC server. my $server = Frontier::Client->new(url => $rpc_url, debug => 0); my $result; my %rpcargs = ( rpcsystem => 'ipdb', rpcuser => $args{user}, ); eval { $result = $server->call("dnsdb.$rpcsub", %rpcargs, %args); }; if ($@) { $errstr = $@; $errstr =~ s/Fault returned from XML RPC Server, fault code 4: error executing RPC `dnsdb.$rpcsub'\.\s//; } $rpccount++; return $result if $result; } # end _rpc() # Let's initialize the globals. ## IPDB::initIPDBGlobals() # Initialize all globals. Takes a database handle, returns a success or error code sub initIPDBGlobals { my $dbh = $_[0]; my $sth; # Initialize alloctypes hashes $sth = $dbh->prepare("select type,listname,dispname,listorder,def_custid from alloctypes order by listorder"); $sth->execute; while (my @data = $sth->fetchrow_array) { $disp_alloctypes{$data[0]} = $data[2]; $def_custids{$data[0]} = $data[4]; if ($data[3] < 900) { $list_alloctypes{$data[0]} = $data[1]; } } # City and POP listings $sth = $dbh->prepare("select city,routing from cities order by city"); $sth->execute; return (undef,$sth->errstr) if $sth->err; while (my @data = $sth->fetchrow_array) { push @citylist, $data[0]; if ($data[1] eq 'y') { push @poplist, $data[0]; } } # Load ACL data. Specific username checks are done at a different level. $sth = $dbh->prepare("select username,acl from users"); $sth->execute; return (undef,$sth->errstr) if $sth->err; while (my @data = $sth->fetchrow_array) { $IPDBacl{$data[0]} = $data[1]; } ##fixme: initialize HTML::Template env var for template path # something like $self->path().'/templates' ? # $ENV{HTML_TEMPLATE_ROOT} = 'foo/bar'; return (1,"OK"); } # end initIPDBGlobals ## IPDB::connectDB() # Creates connection to IPDB. # Requires the database name, username, and password. # Returns a handle to the db. # Set up for a PostgreSQL db; could be any transactional DBMS with the # right changes. sub connectDB { my $dbname = shift; my $user = shift; my $pass = shift; my $dbhost = shift; my $dbh; my $DSN = "DBI:Pg:".($dbhost ? "host=$dbhost;" : '')."dbname=$dbname"; # Note that we want to autocommit by default, and we will turn it off locally as necessary. # We may not want to print gobbledygook errors; YMMV. Have to ponder that further. $dbh = DBI->connect($DSN, $user, $pass, { AutoCommit => 1, PrintError => 0 }) or return (undef, $DBI::errstr) if(!$dbh); # Return here if we can't select. Note that this indicates a # problem executing the select. my $sth = $dbh->prepare("select type from alloctypes"); $sth->execute(); return (undef,$DBI::errstr) if ($sth->err); # See if the select returned anything (or null data). This should # succeed if the select executed, but... $sth->fetchrow(); return (undef,$DBI::errstr) if ($sth->err); # If we get here, we should be OK. return ($dbh,"DB connection OK"); } # end connectDB ## IPDB::finish() # Cleans up after database handles and so on. # Requires a database handle sub finish { my $dbh = $_[0]; $dbh->disconnect if $dbh; } # end finish ## IPDB::checkDBSanity() # Quick check to see if the db is responding. A full integrity # check will have to be a separate tool to walk the IP allocation trees. sub checkDBSanity { my ($dbh) = $_[0]; if (!$dbh) { print "No database handle, or connection has been closed."; return -1; } else { # it connects, try a stmt. my $sth = $dbh->prepare("select type from alloctypes"); my $err = $sth->execute(); if ($sth->fetchrow()) { # all is well. return 1; } else { print "Connected to the database, but could not execute test statement. ".$sth->errstr(); return -1; } } # Clean up after ourselves. # $dbh->disconnect; } # end checkDBSanity ## IPDB::addMaster() # Does all the magic necessary to sucessfully add a master block # Requires database handle, block to add # Returns failure code and error message or success code and "message" sub addMaster { my $dbh = shift; # warning! during testing, this somehow generated a "Bad file descriptor" error. O_o my $cidr = new NetAddr::IP shift; my %args = @_; $args{vrf} = '' if !$args{vrf}; $args{rdns} = '' if !$args{rdns}; $args{defloc} = '' if !$args{defloc}; $args{rwhois} = 'n' if !$args{rwhois}; # fail "safe", sort of. $args{rwhois} = 'n' if $args{rwhois} ne 'n' and $args{rwhois} ne 'y'; # Allow transactions, and raise an exception on errors so we can catch it later. # Use local to make sure these get "reset" properly on exiting this block local $dbh->{AutoCommit} = 0; local $dbh->{RaiseError} = 1; # Wrap all the SQL in a transaction eval { my ($mexist) = $dbh->selectrow_array("SELECT cidr FROM masterblocks WHERE cidr <<= ?", undef, ($cidr) ); if (!$mexist) { # First case - master is brand-spanking-new. ##fixme: rwhois should be globally-flagable somewhere, much like a number of other things ## maybe a db table called "config"? $dbh->do("INSERT INTO masterblocks (cidr,rwhois,vrf,rdns) VALUES (?,?,?,?)", undef, ($cidr, 'y', $args{vrf}, $args{rdns}) ); # Unrouted blocks aren't associated with a city (yet). We don't rely on this # elsewhere though; legacy data may have traps and pitfalls in it to break this. # Thus the "routed" flag. $dbh->do("INSERT INTO freeblocks (cidr,city,routed,parent,rdepth,vrf) VALUES (?,?,?,?,?,?)", undef, ($cidr, '', 'm', $cidr, 1, $args{vrf}) ); # If we get here, everything is happy. Commit changes. $dbh->commit; } # done new master does not contain existing master(s) else { # collect the master(s) we're going to absorb, and snag the longest netmask while we're at it. my $smallmask = $cidr->masklen; my $sth = $dbh->prepare("SELECT cidr FROM masterblocks WHERE cidr <<= ?"); $sth->execute($cidr); my @cmasters; while (my @data = $sth->fetchrow_array) { my $master = new NetAddr::IP $data[0]; push @cmasters, $master; $smallmask = $master->masklen if $master->masklen > $smallmask; } # split the new master, and keep only those blocks not part of an existing master my @blocklist; foreach my $seg ($cidr->split($smallmask)) { my $contained = 0; foreach my $master (@cmasters) { $contained = 1 if $master->contains($seg); } push @blocklist, $seg if !$contained; } # collect the unrouted free blocks within the new master $sth = $dbh->prepare("SELECT cidr FROM freeblocks WHERE masklen(cidr) <= ? AND cidr <<= ? AND routed = 'm'"); $sth->execute($smallmask, $cidr); while (my @data = $sth->fetchrow_array) { my $freeblock = new NetAddr::IP $data[0]; push @blocklist, $freeblock; } # combine the set of free blocks we should have now. @blocklist = Compact(@blocklist); # and now insert the new data. Make sure to delete old masters too. # freeblocks $sth = $dbh->prepare("DELETE FROM freeblocks WHERE cidr <<= ?"); my $sth2 = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,parent,rdepth,vrf)". " VALUES (?,'','m',?,1,?)"); foreach my $newblock (@blocklist) { $sth->execute($newblock); $sth2->execute($newblock, $cidr, $args{vrf}); } # update parent relations at rdepth=1 $dbh->do("UPDATE allocations SET parent = ? WHERE parent << ? AND rdepth=1", undef, ($cidr, $cidr) ); $dbh->do("UPDATE freeblocks SET parent = ? WHERE parent << ? AND rdepth=1", undef, ($cidr, $cidr) ); # master $dbh->do("DELETE FROM masterblocks WHERE cidr <<= ?", undef, ($cidr) ); $dbh->do("INSERT INTO masterblocks (cidr,rwhois,vrf,rdns) VALUES (?,?,?,?)", undef, ($cidr, 'y', $args{vrf}, $args{rdns}) ); # *whew* If we got here, we likely suceeded. $dbh->commit; } # new master contained existing master(s) }; # end eval if ($@) { my $msg = $@; eval { $dbh->rollback; }; return ('FAIL',$msg); } else { # Only attempt rDNS if the IPDB side succeeded if ($rpc_url) { # Note *not* splitting reverse zones negates any benefit from caching the exported data. # IPv6 address space is far too large to split usefully, and in any case (also due to # the large address space) doesn't support the iterated template records v4 zones do # that causes the bulk of the slowdown that needs the cache anyway. my @zonelist; # allow splitting reverse zones to be disabled, maybe, someday #if ($splitrevzones && !$cidr->{isv6}) { if (1 && !$cidr->{isv6}) { my $splitpoint = ($cidr->masklen <= 16 ? 16 : 24); # hack pthui @zonelist = $cidr->split($splitpoint); } else { @zonelist = ($cidr); } my @fails; ##fixme: remove hardcoding where possible foreach my $subzone (@zonelist) { my %rpcargs = ( rpcuser => $args{user}, revzone => "$subzone", revpatt => $args{rdns}, defloc => $args{defloc}, group => $revgroup, # not sure how these two could sanely be exposed, tbh... state => 1, # could make them globally configurable maybe ); if ($rpc_url && !_rpc('addRDNS', %rpcargs)) { push @fails, ("$subzone" => $errstr); } } if (@fails) { return ('WARN',"Warning(s) adding $cidr to reverse DNS:\n".join("\n", @fails)); } } return ('OK','OK'); } } # end addMaster ## IPDB::touchMaster() # Update last-changed timestamp on a master block. sub touchMaster { my $dbh = shift; my $master = shift; local $dbh->{AutoCommit} = 0; local $dbh->{RaiseError} = 1; eval { $dbh->do("UPDATE masterblocks SET mtime=now() WHERE cidr = ?", undef, ($master)); $dbh->commit; }; if ($@) { my $msg = $@; eval { $dbh->rollback; }; return ('FAIL',$msg); } return ('OK','OK'); } # end touchMaster() ## IPDB::listSummary() # Get summary list of all master blocks # Returns an arrayref to a list of hashrefs containing the master block, routed count, # allocated count, free count, and largest free block masklength sub listSummary { my $dbh = shift; my $mlist = $dbh->selectall_arrayref("SELECT cidr AS master FROM masterblocks ORDER BY cidr", { Slice => {} }); foreach (@{$mlist}) { my ($rcnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ? AND type='rm'", undef, ($$_{master})); $$_{routed} = $rcnt; my ($acnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ? AND NOT type='rm'", undef, ($$_{master})); $$_{allocated} = $acnt; my ($fcnt) = $dbh->selectrow_array("SELECT count(*) FROM freeblocks WHERE cidr <<= ?", undef, ($$_{master})); $$_{free} = $fcnt; my ($bigfree) = $dbh->selectrow_array("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?". " AND parent = ? ORDER BY masklen(cidr) LIMIT 1", undef, ($$_{master}, $$_{master})); ##fixme: should find a way to do this without having to HTMLize the <> $bigfree = "/$bigfree" if $bigfree; $bigfree = '' if !$bigfree; $$_{bigfree} = $bigfree; } return $mlist; } # end listSummary() ## IPDB::listSubs() # Get list of subnets within a specified CIDR block, on a specified VRF. # Returns an arrayref to a list of hashrefs containing the CIDR block, customer location or # city it's routed to, block type, SWIP status, and description sub listSubs { my $dbh = shift; my %args = @_; # Just In Case $args{vrf} = '' if !$args{vrf}; $args{rdepth} = 1 if !$args{rdepth}; # Snag the allocations for this block my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description". " FROM allocations WHERE parent = ? AND rdepth = ? ORDER BY cidr"); $sth->execute($args{block},$args{rdepth}); # hack hack hack # set up to flag swip=y records if they don't actually have supporting data in the customers table my $custsth = $dbh->prepare("SELECT count(*) FROM customers WHERE custid = ?"); my @blocklist; while (my ($cidr,$city,$type,$custid,$swip,$desc) = $sth->fetchrow_array()) { $custsth->execute($custid); my ($ncust) = $custsth->fetchrow_array(); my %row = ( block => $cidr, city => $city, type => $disp_alloctypes{$type}, custid => $custid, swip => ($swip eq 'y' ? 'Yes' : 'No'), partswip => ($swip eq 'y' && $ncust == 0 ? 1 : 0), desc => $desc, hassubs => ($type eq 'rm' || $type =~ /.c/ ? 1 : 0), ); # $row{subblock} = ($type =~ /^.r$/); # hmf. wonder why these won't work in the hash declaration... $row{listpool} = ($type =~ /^.[pd]$/); push (@blocklist, \%row); } return \@blocklist; } # end listSubs() ## IPDB::listMaster() # Get list of routed blocks in the requested master # Returns an arrayref to a list of hashrefs containing the routed block, POP/city the block is routed to, # allocated count, free count, and largest free block masklength sub listMaster { my $dbh = shift; my $master = shift; my $rlist = $dbh->selectall_arrayref("SELECT cidr AS block,city FROM routed WHERE cidr <<= ? ORDER BY cidr", { Slice => {} }, ($master) ); foreach (@{$rlist}) { my ($acnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ?", undef, ($$_{block})); $$_{nsubs} = $acnt; my ($fcnt) = $dbh->selectrow_array("SELECT count(*) FROM freeblocks WHERE cidr <<= ?". " AND (routed='y' OR routed='n')", undef, ($$_{block})); $$_{nfree} = $fcnt; my ($bigfree) = $dbh->selectrow_array("SELECT maskbits FROM freeblocks WHERE cidr <<= ?". " AND (routed='y' OR routed='n') ORDER BY maskbits LIMIT 1", undef, ($$_{block})); ##fixme: should find a way to do this without having to HTMLize the <> $bigfree = "/$bigfree" if $bigfree; $bigfree = '' if !$bigfree; $$_{lfree} = $bigfree; } return $rlist; } # end listMaster() ## IPDB::listRBlock() # Gets a list of free blocks in the requested parent/master in both CIDR and range notation # Takes a parent/master and an optional flag to look at routed or unrouted blocks, depending # on whether the master is a direct master or a routed block # Returns an arrayref to a list of hashrefs containing the CIDR and range-notation blocks sub listRBlock { my $dbh = shift; my $routed = shift; # Snag the allocations for this block my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description". " FROM allocations WHERE cidr <<= ? ORDER BY cidr"); $sth->execute($routed); # hack hack hack # set up to flag swip=y records if they don't actually have supporting data in the customers table my $custsth = $dbh->prepare("SELECT count(*) FROM customers WHERE custid = ?"); my @blocklist; while (my ($cidr,$city,$type,$custid,$swip,$desc) = $sth->fetchrow_array()) { $custsth->execute($custid); my ($ncust) = $custsth->fetchrow_array(); my %row = ( block => $cidr, city => $city, type => $disp_alloctypes{$type}, custid => $custid, swip => ($swip eq 'y' ? 'Yes' : 'No'), partswip => ($swip eq 'y' && $ncust == 0 ? 1 : 0), desc => $desc ); $row{subblock} = ($type =~ /^.r$/); # hmf. wonder why these won't work in the hash declaration... $row{listpool} = ($type =~ /^.[pd]$/); push (@blocklist, \%row); } return \@blocklist; } # end listRBlock() ## IPDB::listFree() # Gets a list of free blocks in the requested parent/master and VRF instance in both CIDR and range notation # Takes a parent/master and an optional VRF specifier that defaults to empty. # Returns an arrayref to a list of hashrefs containing the CIDR and range-notation blocks # Returns some extra flags in the hashrefs for routed blocks, since those can have several subtypes sub listFree { my $dbh = shift; my %args = @_; # Just In Case $args{vrf} = '' if !$args{vrf}; $args{rdepth} = 1 if !$args{rdepth}; # do it this way so we can waste a little less time iterating # my $sth = $dbh->prepare("SELECT cidr FROM freeblocks WHERE parent = ? AND rdepth = ? AND vrf = ? ". my $sth = $dbh->prepare("SELECT cidr FROM freeblocks WHERE parent = ? AND rdepth = ? ". "ORDER BY cidr"); # $sth->execute($args{master}, $args{rdepth}, $args{vrf}); $sth->execute($args{master}, $args{rdepth}); my @flist; while (my ($cidr) = $sth->fetchrow_array()) { $cidr = new NetAddr::IP $cidr; my %row = ( fblock => "$cidr", frange => $cidr->range, ); push @flist, \%row; } return \@flist; } # end listFree() ## IPDB::listPool() # sub listPool { my $dbh = shift; my $pool = shift; my $sth = $dbh->prepare("SELECT ip,custid,available,description,type,rdepth". " FROM poolips WHERE pool = ? ORDER BY ip"); $sth->execute($pool); my @poolips; while (my ($ip,$custid,$available,$desc,$type,$rdepth) = $sth->fetchrow_array) { my %row = ( ip => $ip, custid => $custid, available => $available, desc => $desc, delme => $available eq 'n', ipdepth => $rdepth, ); push @poolips, \%row; } return \@poolips; } # end listPool() ## IPDB::getMasterList() # Get a list of master blocks, optionally including last-modified timestamps # Takes an optional flag to indicate whether to include timestamps; # 'm' includes ctime, all others (suggest 'c') do not. # Returns an arrayref to a list of hashrefs sub getMasterList { my $dbh = shift; my $stampme = shift || 'm'; # optional but should be set by caller for clarity my $mlist = $dbh->selectall_arrayref("SELECT cidr AS master".($stampme eq 'm' ? ',mtime' : ''). " FROM masterblocks ORDER BY cidr", { Slice => {} }); return $mlist; } # end getMasterList() ## IPDB::getTypeList() # Get an alloctype/description pair list suitable for dropdowns # Takes a flag to determine which general groups of types are returned # Returns an reference to an array of hashrefs sub getTypeList { my $dbh = shift; my $tgroup = shift || 'a'; # technically optional, like this, but should # really be specified in the call for clarity my $tlist; if ($tgroup eq 'n') { # grouping 'p' - all netblock types. These include routed blocks, containers (_c) # and contained (_r) types, dynamic-allocation ranges (_e), static IP pools (_d and _p), # and the "miscellaneous" cn, in, and en types. $tlist = $dbh->selectall_arrayref("SELECT type,listname FROM alloctypes WHERE listorder <= 500 ". "AND type NOT LIKE '_i' ORDER BY listorder", { Slice => {} }); } elsif ($tgroup eq 'p') { # grouping 'p' - primary allocation types. As with 'n' above but without the _r contained types. $tlist = $dbh->selectall_arrayref("SELECT type,listname FROM alloctypes WHERE listorder <= 500 ". "AND type NOT LIKE '_i' AND type NOT LIKE '_r' ORDER BY listorder", { Slice => {} }); } elsif ($tgroup eq 'c') { # grouping 'c' - contained types. These include all static IPs and all _r types. $tlist = $dbh->selectall_arrayref("SELECT type,listname FROM alloctypes WHERE listorder <= 500 ". " AND (type LIKE '_i' OR type LIKE '_r') ORDER BY listorder", { Slice => {} }); } else { # grouping 'a' - all standard allocation types. This includes everything # but mm (present only as a formality). Make this the default. $tlist = $dbh->selectall_arrayref("SELECT type,listname FROM alloctypes WHERE listorder <= 500 ". " ORDER BY listorder", { Slice => {} }); } return $tlist; } ## IPDB::getPoolSelect() # Get a list of pools matching the passed city and type that have 1 or more free IPs # Returns an arrayref to a list of hashrefs sub getPoolSelect { my $dbh = shift; my $iptype = shift; my $pcity = shift; my ($ptype) = ($iptype =~ /^(.)i$/); return if !$ptype; $ptype .= '_'; my $plist = $dbh->selectall_arrayref( "SELECT count(*) AS poolfree,p.pool AS poolblock, a.city AS poolcit, a.rdepth AS poolrdepth ". "FROM poolips p ". "JOIN allocations a ON p.pool=a.cidr ". "WHERE p.available='y' AND a.city = ? AND p.type LIKE ? ". "GROUP BY p.pool,a.city,a.rdepth", { Slice => {} }, ($pcity, $ptype) ); return $plist; } # end getPoolSelect() ## IPDB::findAllocateFrom() # Find free block to add a new allocation from. (CIDR block version of pool select above, more or less) # Takes # - mask length # - allocation type # - POP city "parent" # - optional master-block restriction # - optional flag to allow automatic pick-from-private-network-ranges # Returns a string with the first CIDR block matching the criteria, if any sub findAllocateFrom { my $dbh = shift; my $maskbits = shift; my $type = shift; my $city = shift; my $pop = shift; my %optargs = @_; my $failmsg = "No suitable free block found\n"; ## Set up the SQL to find out what freeblock we can (probably) use for an allocation. ## Very large systems will require development of a reserve system (possibly an extension ## of the reserve-for-expansion concept in https://secure.deepnet.cx/trac/ipdb/ticket/24?) ## Also populate a value list for the DBI call. my @vallist = ($maskbits); my $sql = "SELECT cidr,rdepth FROM freeblocks WHERE masklen(cidr) <= ?"; # cases, strict rules # .c -> container type # requires a routing container, fbtype r # .d -> DHCP/"normal-routing" static pool # requires a routing container, fbtype r # .e -> Dynamic-assignment connectivity # requires a routing container, fbtype r # .i -> error, can't allocate static IPs this way? # mm -> error, master block # rm -> routed block # requires master block, fbtype m # .n -> Miscellaneous usage # requires a routing container, fbtype r # .p -> PPP(oE) static pool # requires a routing container, fbtype r # .r -> contained type # requires a matching container, fbtype $1 ##fixme: strict-or-not flag if ($type =~ /^(.)r$/) { push @vallist, $1; $sql .= " AND routed = ?"; } elsif ($type eq 'rm') { $sql .= " AND routed = 'm'"; } else { $sql .= " AND routed = 'r'"; } # for PPP(oE) and container types, the POP city is the one attached to the pool. # individual allocations get listed with the customer city site. ##fixme: chain cities to align roughly with a full layer-2 node graph $city = $pop if $type !~ /^.[pc]$/; if ($type ne 'rm' && $city) { $sql .= " AND city = ?"; push @vallist, $city; } # Allow specifying an arbitrary full block, instead of a master if ($optargs{gimme}) { $sql .= " AND cidr >>= ?"; push @vallist, $optargs{gimme}; } # if a specific master was requested, allow the requestor to self->shoot(foot) if ($optargs{master} && $optargs{master} ne '-') { $sql .= " AND cidr <<= ?" if $optargs{master} ne '-'; push @vallist, $optargs{master}; } else { # if a specific master was NOT requested, filter out the RFC 1918 private networks if (!$optargs{allowpriv}) { $sql .= " AND NOT (cidr <<= '192.168.0.0/16' OR cidr <<= '10.0.0.0/8' OR cidr <<= '172.16.0.0/12')"; } } # Sorting and limiting, since we don't (currently) care to provide a selection of # blocks to carve up. This preserves something resembling optimal usage of the IP # space by forcing contiguous allocations and free blocks as much as possible. $sql .= " ORDER BY maskbits DESC,cidr LIMIT 1"; my ($fbfound,$fbdepth) = $dbh->selectrow_array($sql, undef, @vallist); return $fbfound,$fbdepth; } # end findAllocateFrom() ## IPDB::ipParent() # Get an IP's parent pool's details # Takes a database handle and IP # Returns a hashref to the parent pool block, if any sub ipParent { my $dbh = shift; my $block = shift; my $pinfo = $dbh->selectrow_hashref("SELECT cidr,custid,type,city,description FROM allocations". " WHERE cidr >>= ? AND (type LIKE '_p' OR type LIKE '_d')", undef, ($block) ); return $pinfo; } # end ipParent() ## IPDB::subParent() # Get a block's parent's details # Takes a database handle and CIDR block # Returns a hashref to the parent container block, if any sub subParent { my $dbh = shift; my $block = shift; my $pinfo = $dbh->selectrow_hashref("SELECT cidr,custid,type,city,description FROM allocations". " WHERE cidr >>= ?", undef, ($block) ); return $pinfo; } # end subParent() ## IPDB::blockParent() # Get a block's parent's details # Takes a database handle and CIDR block # Returns a hashref to the parent container block, if any sub blockParent { my $dbh = shift; my $block = shift; my $pinfo = $dbh->selectrow_hashref("SELECT cidr,city FROM routed". " WHERE cidr >>= ?", undef, ($block) ); return $pinfo; } # end blockParent() ## IPDB::getRoutedCity() # Get the city for a routed block. sub getRoutedCity { my $dbh = shift; my $block = shift; my ($rcity) = $dbh->selectrow_array("SELECT city FROM routed WHERE cidr = ?", undef, ($block) ); return $rcity; } # end getRoutedCity() ## IPDB::allocateBlock() # Does all of the magic of actually allocating a netblock # Requires a database handle, and a hash containing the block to allocate, routing depth, custid, # type, city, block to allocate from, and optionally a description, notes, circuit ID, # and private data # Returns a success code and optional error message. sub allocateBlock { my $dbh = shift; my %args = @_; $args{cidr} = new NetAddr::IP $args{cidr}; $args{alloc_from} = new NetAddr::IP $args{alloc_from}; $args{desc} = '' if !$args{desc}; $args{notes} = '' if !$args{notes}; $args{circid} = '' if !$args{circid}; $args{privdata} = '' if !$args{privdata}; $args{vrf} = '' if !$args{vrf}; $args{rdns} = '' if !$args{rdns}; my $sth; # Snag the "type" of the freeblock (alloc_from) "just in case" $sth = $dbh->prepare("select routed from freeblocks where cidr='$args{alloc_from}'"); $sth->execute; my ($alloc_from_type) = $sth->fetchrow_array; # To contain the error message, if any. my $msg = "Unknown error allocating $args{cidr} as '$disp_alloctypes{$args{type}}'"; # Enable transactions and error handling local $dbh->{AutoCommit} = 0; # These need to be local so we don't local $dbh->{RaiseError} = 1; # step on our toes by accident. if ($args{type} =~ /^.i$/) { $msg = "Unable to assign static IP $args{cidr} to $args{custid}"; eval { if ($args{cidr}) { # IP specified my ($isavail) = $dbh->selectrow_array("SELECT available FROM poolips WHERE ip=?", undef, ($args{cidr}) ); die "IP is not in an IP pool.\n" if !$isavail; die "IP already allocated. Deallocate and reallocate, or update the entry\n" if $isavail eq 'n'; } else { # IP not specified, take first available ($args{cidr}) = $dbh->selectrow_array("SELECT ip FROM poolips WHERE pool=? AND available='y' ORDER BY ip", undef, ($args{alloc_from}) ); } $dbh->do("UPDATE poolips SET custid=?,city=?,available='n',description=?,notes=?,circuitid=?,privdata=?,vrf=?,rdns=? ". "WHERE ip=?", undef, ($args{custid}, $args{city}, $args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{vrf}, $args{rdns}, $args{cidr}) ); # node hack if ($args{nodeid} && $args{nodeid} ne '') { $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) ); } # end node hack $dbh->commit; }; if ($@) { $msg .= ": $@"; eval { $dbh->rollback; }; return ('FAIL', $msg); } else { _rpc('addOrUpdateRevRec', cidr => "$args{cidr}", name => $args{rdns}, rpcuser => $args{user}); return ('OK', $args{cidr}); } } else { # end IP-from-pool allocation if ($args{cidr} == $args{alloc_from}) { # Easiest case- insert in one table, delete in the other, and go home. More or less. # insert into allocations values (cidr,custid,type,city,desc) and # delete from freeblocks where cidr='cidr' # For data safety on non-transaction DBs, we delete first. eval { $msg = "Unable to allocate $args{cidr} as '$disp_alloctypes{$args{type}}'"; # Get old freeblocks parent/depth/routed for new entries... before we delete it. my ($fparent) = $dbh->selectrow_array("SELECT parent FROM freeblocks WHERE cidr=? AND rdepth=?", undef, ($args{alloc_from}, $args{rdepth}) ); # Munge freeblocks if ($args{type} =~ /^(.)[mc]$/) { # special case - block is a routed or container/"reserve" block my $rtype = $1; $dbh->do("UPDATE freeblocks SET routed=?,rdepth=rdepth+1,city=?,parent=? WHERE cidr=? AND rdepth=?", undef, ($rtype, $args{city}, $args{cidr}, $args{cidr}, $args{rdepth}) ); } else { # "normal" case $dbh->do("DELETE FROM freeblocks WHERE cidr=? AND rdepth=?", undef, ($args{cidr}, $args{rdepth})); } # Insert the allocations entry $dbh->do("INSERT INTO allocations ". "(cidr,parent,vrf,rdepth,custid,type,city,description,notes,circuitid,privdata,rdns)". " VALUES (?,?,?,?,?,?,?,?,?,?,?,?)", undef, ($args{cidr}, $fparent, $args{vrf}, $args{rdepth}, $args{custid}, $args{type}, $args{city}, $args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{rdns}) ); # And initialize the pool, if necessary # PPPoE pools (currently dialup, DSL, and WiFi) get all IPs made available # "DHCP" or "real-subnet" pools have the net, gw, and bcast IPs removed. if ($args{type} =~ /^.p$/) { $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}"; my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "all", $args{rdepth}+1); die $rmsg if $code eq 'FAIL'; } elsif ($args{type} =~ /^.d$/) { $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}"; my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "normal", $args{rdepth}+1); die $rmsg if $code eq 'FAIL'; } # node hack if ($args{nodeid} && $args{nodeid} ne '') { $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) ); } # end node hack $dbh->commit; }; # end of eval if ($@) { $msg .= ": ".$@; eval { $dbh->rollback; }; return ('FAIL',$msg); } } else { # cidr != alloc_from # Hard case. Allocation is smaller than free block. my $wantmaskbits = $args{cidr}->masklen; my $maskbits = $args{alloc_from}->masklen; my @newfreeblocks; # Holds free blocks generated from splitting the source freeblock. # This determines which blocks will be left "free" after allocation. We take the # block we're allocating from, and split it in half. We see which half the wanted # block is in, and repeat until the wanted block is equal to one of the halves. my $i=0; my $tmp_from = $args{alloc_from}; # So we don't munge $args{alloc_from} while ($maskbits++ < $wantmaskbits) { my @subblocks = $tmp_from->split($maskbits); $newfreeblocks[$i++] = (($args{cidr}->within($subblocks[0])) ? $subblocks[1] : $subblocks[0]); $tmp_from = ( ($args{cidr}->within($subblocks[0])) ? $subblocks[0] : $subblocks[1] ); } # while # Begin SQL transaction block eval { $msg = "Unable to allocate $args{cidr} as '$disp_alloctypes{$args{type}}'"; # Get old freeblocks parent/depth/routed for new entries my ($fparent,$fcity,$wasrouted) = $dbh->selectrow_array("SELECT parent,city,routed FROM freeblocks". " WHERE cidr=? AND rdepth=?", undef, ($args{alloc_from}, $args{rdepth}) ); # Delete old freeblocks entry $dbh->do("DELETE FROM freeblocks WHERE cidr=? AND rdepth=?", undef, ($args{alloc_from}, $args{rdepth}) ); # Insert new list of smaller free blocks left over $sth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent,rdepth) VALUES (?,?,?,?,?,?)"); foreach my $block (@newfreeblocks) { $sth->execute($block, $fcity, $wasrouted, $args{vrf}, $fparent, $args{rdepth}); } # For routed/container types, add a freeblock within the allocated block so we can subdivide it further if ($args{type} =~ /(.)[mc]/) { # rm and .c types - containers my $rtype = $1; $sth->execute($args{cidr}, $args{city}, $rtype, $args{vrf}, $args{cidr}, $args{rdepth}+1); } # Insert the allocations entry $dbh->do("INSERT INTO allocations ". "(cidr,parent,vrf,rdepth,custid,type,city,description,notes,circuitid,privdata,rdns)". " VALUES (?,?,?,?,?,?,?,?,?,?,?,?)", undef, ($args{cidr}, $fparent, $args{vrf}, $args{rdepth}, $args{custid}, $args{type}, $args{city}, $args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{rdns}) ); # And initialize the pool, if necessary # PPPoE pools (currently dialup, DSL, and WiFi) get all IPs made available # "DHCP" or "real-subnet" pools have the net, gw, and bcast IPs removed. if ($args{type} =~ /^.p$/) { $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}"; my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "all", $args{rdepth}+1); die $rmsg if $code eq 'FAIL'; } elsif ($args{type} =~ /^.d$/) { $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}"; my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "normal", $args{rdepth}+1); die $rmsg if $code eq 'FAIL'; } # node hack if ($args{nodeid} && $args{nodeid} ne '') { $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) ); } # end node hack $dbh->commit; }; # end eval if ($@) { $msg .= ": ".$@; eval { $dbh->rollback; }; return ('FAIL',$msg); } } # end fullcidr != alloc_from # now we do the DNS dance for netblocks, if we have an RPC server to do it with and a pattern to use. _rpc('addOrUpdateRevRec', cidr => "$args{cidr}", name => $args{rdns}, rpcuser => $args{user}) if $args{rdns}; return ('OK', 'OK'); } # end static-IP vs netblock allocation } # end allocateBlock() ## IPDB::initPool() # Initializes a pool # Requires a database handle, the pool CIDR, type, city, and a parameter # indicating whether the pool should allow allocation of literally every # IP, or if it should reserve network/gateway/broadcast IPs # Note that this is NOT done in a transaction, that's why it's a private # function and should ONLY EVER get called from allocateBlock() sub initPool { my ($dbh,undef,$type,$city,$class,$rdepth) = @_; my $pool = new NetAddr::IP $_[1]; # IPv6 does not lend itself to IP pools as supported return ('FAIL',"Refusing to create IPv6 static IP pool") if $pool->{isv6}; # IPv4 pools don't make much sense beyond even /24. Allow up to 4096-host footshooting anyway. # NetAddr::IP won't allow more than a /16 (65k hosts). return ('FAIL',"Refusing to create oversized static IP pool") if $pool->masklen <= 20; ##fixme Need to just replace 2nd char of type with i rather than capturing 1st char of type $type =~ s/[pd]$/i/; my $sth; my $msg; # Trap errors so we can pass them back to the caller. Even if the # caller is only ever supposed to be local, and therefore already # trapping errors. >:( local $dbh->{AutoCommit} = 0; # These need to be local so we don't local $dbh->{RaiseError} = 1; # step on our toes by accident. eval { # have to insert all pool IPs into poolips table as "unallocated". $sth = $dbh->prepare("INSERT INTO poolips (pool,ip,custid,city,type,rdepth)". " VALUES ('$pool', ?, '$defcustid', ?, '$type', $rdepth)"); my @poolip_list = $pool->hostenum; if ($class eq 'all') { # (DSL-ish block - *all* IPs available if ($pool->addr !~ /\.0$/) { # .0 causes weirdness. $sth->execute($pool->addr, $city); } for (my $i=0; $i<=$#poolip_list; $i++) { $sth->execute($poolip_list[$i]->addr, $city); } $pool--; if ($pool->addr !~ /\.255$/) { # .255 can cause weirdness. $sth->execute($pool->addr, $city); } } else { # (real netblock) for (my $i=1; $i<=$#poolip_list; $i++) { $sth->execute($poolip_list[$i]->addr, $city); } } $dbh->commit; }; if ($@) { $msg = $@; eval { $dbh->rollback; }; return ('FAIL',$msg); } else { return ('OK',"OK"); } } # end initPool() ## IPDB::updateBlock() # Update an allocation # Takes all allocation fields in a hash sub updateBlock { my $dbh = shift; my %args = @_; return ('FAIL', 'Missing block to update') if !$args{block}; # do it all in a transaction local $dbh->{AutoCommit} = 0; local $dbh->{RaiseError} = 1; my @fieldlist; my @vallist; foreach ('custid', 'city', 'description', 'notes', 'circuitid', 'privdata', 'rdns') { if ($args{$_}) { push @fieldlist, $_; push @vallist, $args{$_}; } } my $updtable = 'allocations'; my $keyfield = 'cidr'; if ($args{type} =~ /^(.)i$/) { $updtable = 'poolips'; $keyfield = 'ip'; } else { ## fixme: there's got to be a better way... if ($args{swip}) { if ($args{swip} eq 'on' || $args{swip} eq '1' || $args{swip} eq 'y') { $args{swip} = 'y'; } else { $args{swip} = 'n'; } } foreach ('type', 'swip') { if ($args{$_}) { push @fieldlist, $_; push @vallist, $args{$_}; } } } return ('FAIL', 'No fields to update') if !@fieldlist; # push @vallist, $args{block}, $args{rdepth}, $args{vrf}; push @vallist, $args{block}, $args{rdepth}; my $sql = "UPDATE $updtable SET "; $sql .= join " = ?, ", @fieldlist; # $sql .= " = ? WHERE $keyfield = ? AND rdepth = ? AND vrf = ?"; $sql .= " = ? WHERE $keyfield = ? AND rdepth = ? "; eval { # do the update $dbh->do($sql, undef, @vallist); if ($args{node}) { # done with delete/insert so we don't have to worry about funkyness updating a node ref that isn't there $dbh->do("DELETE FROM noderef WHERE block = ?", undef, ($args{block}) ); $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{block}, $args{node}) ); } $dbh->commit; }; if ($@) { my $msg = $@; $dbh->rollback; return ('FAIL', $msg); } _rpc('addOrUpdateRevRec', cidr => $args{block}, name => $args{rdns}, rpcuser => $args{user}); return ('OK','OK'); } # end updateBlock() ## IPDB::deleteBlock() # Removes an allocation from the database, including deleting IPs # from poolips and recombining entries in freeblocks if possible # Also handles "deleting" a static IP allocation, and removal of a master # Requires a database handle, the block to delete, the routing depth (if applicable), # the VRF ID, and a flag to indicate whether to delete associated forward DNS entries # as well as the reverse entry sub deleteBlock { my ($dbh,undef,$rdepth,$vrf,$delfwd,$user) = @_; my $cidr = new NetAddr::IP $_[1]; # For possible auto-VRF-ignoring (since public IPs shouldn't usually be present in more than one VRF) # is_rfc1918 requires NetAddr::IP >= 4.059 # rather than doing this over and over and over..... my $tmpnum = $cidr->numeric; # 192.168.0.0/16 -> 192.168.255.255 => 3232235520 -> 3232301055 # 172.16.0.0/12 -> 172.31.255.255 => 2886729728 -> 2887778303 # 10.0.0.0/8 -> 10.255.255.255 => 167772160 -> 184549375 my $isprivnet = (3232235520 <= $tmpnum && $tmpnum <= 3232301055) || (2886729728 <= $tmpnum && $tmpnum <= 2887778303) || (167772160 <= $tmpnum && $tmpnum <= 184549375); my $sth; # Magic variables used for odd allocation cases. my $container; my $con_type; # Collect info about the block we're going to delete my $binfo = getBlockData($dbh, $cidr, $rdepth, $vrf); # temporarily forced null, until a sane UI for VRF tracking can be found. $vrf = '';# if !$vrf; # as with SQL, the null value is not equal to ''. *sigh* # To contain the error message, if any. my $msg = "Unknown error deallocating $binfo->{type} $cidr"; my $goback; # to put the parent in so we can link back where the deallocate started # Enable transactions and exception-on-errors... but only for this sub local $dbh->{AutoCommit} = 0; local $dbh->{RaiseError} = 1; # First case. The "block" is a static IP # Note that we still need some additional code in the odd case # of a netblock-aligned contiguous group of static IPs if ($binfo->{type} =~ /^.i$/) { eval { $msg = "Unable to deallocate $disp_alloctypes{$binfo->{type}} $cidr"; my ($pool,$pcust,$pvrf) = $dbh->selectrow_array("SELECT pool,custid,vrf FROM poolips WHERE ip=?", undef, ($cidr) ); ##fixme: VRF and rdepth $dbh->do("UPDATE poolips SET custid=?,available='y',". "city=(SELECT city FROM allocations WHERE cidr=?),". "description='',notes='',circuitid='',vrf=? WHERE ip=?", undef, ($pcust, $pool, $pvrf, $cidr) ); $goback = $pool; $dbh->commit; }; if ($@) { $msg .= ": $@"; eval { $dbh->rollback; }; return ('FAIL',$msg); } else { ##fixme: RPC return code? _rpc('delByCIDR', cidr => "$cidr", user => $user, delforward => $delfwd); return ('OK',"OK"); } } elsif ($binfo->{type} eq 'mm') { # end alloctype =~ /.i/ ##fixme: VRF limit $msg = "Unable to delete master block $cidr"; eval { $dbh->do("DELETE FROM masterblocks WHERE cidr = ?", undef, ($cidr) ); $dbh->do("DELETE FROM allocations WHERE cidr <<= ?", undef, ($cidr) ); $dbh->do("DELETE FROM freeblocks WHERE cidr <<= ?", undef, ($cidr) ); $dbh->commit; }; if ($@) { $msg .= ": $@"; eval { $dbh->rollback; }; return ('FAIL', $msg); } # Have to handle potentially split reverse zones. Assume they *are* split, # since if we added them here, they would have been added split. # allow splitting reverse zones to be disabled, maybe, someday #if ($splitrevzones && !$cidr->{isv6}) { my @zonelist; if (1 && !$cidr->{isv6}) { my $splitpoint = ($cidr->masklen <= 16 ? 16 : 24); # hack pthui @zonelist = $cidr->split($splitpoint); } else { @zonelist = ($cidr); } my @fails; foreach my $subzone (@zonelist) { if ($rpc_url && !_rpc('delZone', zone => "$subzone", revrec => 'y', user => $user, delforward => $delfwd) ) { push @fails, ("$subzone" => $errstr); } } if (@fails) { return ('WARN',"Warning(s) deleting $cidr from reverse DNS:\n".join("\n", @fails)); } return ('OK','OK'); } else { # end alloctype master block case ## This is a big block; but it HAS to be done in a chunk. Any removal ## of a netblock allocation may result in a larger chunk of free ## contiguous IP space - which may in turn be combined into a single ## netblock rather than a number of smaller netblocks. my $retcode = 'OK'; my ($ptype,$pcity,$ppatt); eval { ##fixme: add recursive flag to allow "YES DAMMIT DELETE ALL EVARYTHING!!1!!" without # explicitly deleting any suballocations of the block to be deleted. # find the current parent of the block we're deleting my ($parent) = $dbh->selectrow_array("SELECT parent FROM allocations WHERE cidr=? AND rdepth=?", undef, ($cidr, $rdepth) ); # Delete the block $dbh->do("DELETE FROM allocations WHERE cidr=? AND rdepth=?", undef, ($cidr, $rdepth) ); ##fixme: we could maybe eliminate a special case if we put masterblocks in the allocations table...? if ($rdepth == 1) { # parent is a master block. $ptype = 'mm'; $pcity = ''; $ppatt = $dbh->selectrow_array("SELECT rdns FROM masterblocks WHERE cidr=?", undef, ($parent) ); } else { # get that parent's details ($ptype,$pcity,$ppatt) = $dbh->selectrow_array("SELECT type,city,rdns FROM allocations ". "WHERE cidr=? AND rdepth=?", undef, ($parent, $rdepth-1) ); } # munge the parent type a little $ptype = (split //, $ptype)[0]; ##fixme: you can't... CAN NOT.... assign the same public IP to multiple things. # 'Net don't work like that, homey. Restrict VRF-uniqueness to private IPs? # -> $isprivnet flag from start of sub my $fbrdepth = $rdepth; # check to see if any container allocations could be the "true" parent my ($tparent,$trdepth,$trtype,$tcity) = $dbh->selectrow_array("SELECT cidr,rdepth,type,city FROM allocations ". "WHERE (type='rm' OR type LIKE '_c') AND cidr >> ? ". "ORDER BY masklen(cidr) DESC", undef, ($cidr) ); my $fparent; if ($tparent && $tparent ne $parent) { # found an alternate parent; reset some parent-info bits $parent = $tparent; $ptype = (split //, $trtype)[0]; $pcity = $tcity; ##fixme: hmm. collect $rdepth into $goback here before vanishing? $retcode = 'WARNMERGE'; # may be redundant $goback = $tparent; # munge freeblock rdepth and parent to match true parent $dbh->do("UPDATE freeblocks SET rdepth = ?, parent = ?, routed = ? WHERE cidr <<= ? AND rdepth = ?", undef, ($trdepth+1, $parent, $ptype, $cidr, $rdepth) ); $rdepth = $trdepth; $fbrdepth = $trdepth+1; } $parent = new NetAddr::IP $parent; $goback = "$parent,$fbrdepth"; # breadcrumb in case of live-parent-is-not-true-parent # Special case - delete pool IPs if ($binfo->{type} =~ /^.[pd]$/) { # We have to delete the IPs from the pool listing. ##fixme: rdepth? vrf? $dbh->do("DELETE FROM poolips WHERE pool = ?", undef, ($cidr) ); } # Find out if the block we're deallocating is within a DSL pool (legacy goo) my ($pool,$poolcity,$pooltype,$pooldepth) = $dbh->selectrow_array( "SELECT cidr,city,type,rdepth FROM allocations WHERE type LIKE '_p' AND cidr >>= ?", undef, ($cidr) ); # If so, return the block's IPs to the pool, instead of to freeblocks ## NB: not possible to currently cause this even via admin tools, only legacy data. if ($pool) { ## Deallocate legacy blocks stashed in the middle of a static IP pool ## This may be expandable to an even more general case of contained netblock, or other pool types. $retcode = 'WARNPOOL'; $goback = "$pool,$pooldepth"; # We've already deleted the block, now we have to stuff its IPs into the pool. $pooltype =~ s/p$/i/; # change type to static IP my $sth2 = $dbh->prepare("INSERT INTO poolips (pool,ip,city,type,custid) VALUES ". "('$pool',?,'$poolcity','$pooltype','$defcustid')"); # don't insert .0 ##fixme: need to not insert net, gateway, and bcast on "real netblock" pools (DHCPish) $sth2->execute($cidr->addr) unless $cidr->addr =~ m|\.0$|; foreach my $ip ($cidr->hostenum) { $sth2->execute($ip); } $cidr--; # don't insert .255 $sth2->execute($cidr->addr) unless $cidr->addr =~ m|\.255$|; } else { # done returning IPs from a block to a static DSL pool # If the block wasn't legacy goo embedded in a static pool, we check the # freeblocks in the identified parent to see if we can combine any of them. # if the block to be deleted is a container, move its freeblock(s) up a level, and reset their parenting info if ($binfo->{type} =~ /^.[mc]/) { # move the freeblocks into the parent # we don't insert a new freeblock because there could be a live reparented sub. $dbh->do("UPDATE freeblocks SET rdepth=rdepth-1,parent=?,routed=?,city=? ". "WHERE parent=? AND rdepth=?", undef, ($parent, $ptype, $pcity, $cidr, $rdepth+1) ); } else { # ... otherwise, add the freeblock $dbh->do("INSERT INTO freeblocks (cidr, city, routed, parent, rdepth) VALUES (?,?,?,?,?)", undef, ($cidr, $pcity, $ptype, $parent, $rdepth) ); } ##fixme: vrf # set up the query to get the list of blocks to try to merge. $sth = $dbh->prepare("SELECT cidr FROM freeblocks ". "WHERE parent = ? AND routed = ? AND rdepth = ? ". "ORDER BY masklen(cidr) DESC"); $sth->execute($parent, $ptype, $fbrdepth); # NetAddr::IP->compact() attempts to produce the smallest inclusive block # from the caller and the passed terms. # EG: if you call $cidr->compact($ip1,$ip2,$ip3) when $cidr, $ip1, $ip2, # and $ip3 are consecutive /27's starting on .0 (.0-.31, .32-.63, # .64-.95, and .96-.128), you will get an array containing a single # /25 as element 0 (.0-.127). Order is not important; you could have # $cidr=.32/27, $ip1=.96/27, $ip2=.0/27, and $ip3=.64/27. my (@rawfb, @combinelist); my $i=0; # for each free block under $parent, push a NetAddr::IP object into one list, and # continuously use NetAddr::IP->compact to automagically merge netblocks as possible. while (my @data = $sth->fetchrow_array) { my $testIP = new NetAddr::IP $data[0]; push @rawfb, $testIP; @combinelist = $testIP->compact(@combinelist); } # now that we have the full list of "compacted" freeblocks, go back over # the list of raw freeblocks, and delete the ones that got merged. $sth = $dbh->prepare("DELETE FROM freeblocks WHERE cidr=? AND parent=? AND rdepth=?"); foreach my $rawfree (@rawfb) { next if grep { $rawfree == $_ } @combinelist; # skip if the raw block is in the compacted list $sth->execute($rawfree, $parent, $fbrdepth); } # now we walk the new list of compacted blocks, and see which ones we need to insert $sth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,parent,rdepth) VALUES (?,?,?,?,?)"); foreach my $cme (@combinelist) { next if grep { $cme == $_ } @rawfb; # skip if the combined block was in the raw list $sth->execute($cme, $pcity, $ptype, $parent, $fbrdepth); } } # done returning IPs to the appropriate place # If we got here, we've succeeded. Whew! $dbh->commit; }; # end eval if ($@) { $msg .= ": $@"; eval { $dbh->rollback; }; return ('FAIL', $msg); } else { ##fixme: RPC return code? _rpc('delByCIDR', cidr => "$cidr", user => $user, delforward => $delfwd, delsubs => 'y', parpatt => $ppatt); return ($retcode, $goback); } } # end alloctype != netblock } # end deleteBlock() ## IPDB::getBlockData() # Get CIDR or IP, custid, type, city, circuit ID, description, notes, modification time, # private/restricted data, for a CIDR block or pool IP # Also returns SWIP status flag for CIDR blocks or pool netblock for IPs # Takes the block/IP to look up, routing depth, and VRF identifier # Returns a hashref to the block data sub getBlockData { my $dbh = shift; my $block = shift; my $rdepth = shift; my $vrf = shift || ''; my $cidr = new NetAddr::IP $block; # better way to find IP allocations vs /32 "netblocks" my $btype = $dbh->selectrow_array("SELECT type FROM searchme WHERE cidr=?", undef, ($block) ); if (defined($rdepth) && $rdepth == 0) { # Only master blocks exist at rdepth 0 my $binfo = $dbh->selectrow_hashref("SELECT cidr AS block, 'mm' AS type, 0 AS parent, cidr,". " ctime, mtime, rwhois, vrf". " FROM masterblocks WHERE cidr = ?", undef, ($block) ); # " FROM masterblocks WHERE cidr = ? AND vrf = ?", undef, ($block, $vrf) ); return $binfo; } elsif ($btype =~ /^.i$/) { my $binfo = $dbh->selectrow_hashref("SELECT ip AS block, custid, type, city, circuitid, description,". " notes, modifystamp AS lastmod, privdata, vrf, pool, rdepth, rdns". " FROM poolips WHERE ip = ?", undef, ($block) ); # " FROM poolips WHERE ip = ? AND vrf = ?", undef, ($block, $vrf) ); return $binfo; } else { my $binfo = $dbh->selectrow_hashref("SELECT cidr AS block, parent, custid, type, city, circuitid, ". "description, notes, modifystamp AS lastmod, privdata, vrf, swip, rdepth, rdns". " FROM allocations WHERE cidr = ? AND rdepth = ?", undef, ($block, $rdepth) ); # " FROM allocations WHERE cidr = ? AND rdepth = ? AND vrf = ?", undef, ($block, $rdepth, $vrf) ); return $binfo; } } # end getBlockData() ## IPDB::getBlockRDNS() # Gets reverse DNS pattern for a block or IP. Note that this will also # retrieve any default pattern following the parent chain up, and check via # RPC (if available) to see what the narrowest pattern for the requested block is # Returns the current pattern for the block or IP. sub getBlockRDNS { my $dbh = shift; my $block = shift; my $rdepth = shift; # do we really need this? my %args = @_; $args{vrf} = '' if !$args{vrf}; my $cidr = new NetAddr::IP $block; my ($rdns,$rfrom) = $dbh->selectrow_array("SELECT rdns,cidr FROM allocations WHERE cidr >>= ? UNION ". "SELECT rdns,cidr FROM masterblocks WHERE cidr >>= ? ORDER BY cidr", undef, ($cidr,$cidr) ); if ($rpc_url) { # Use the first /16 or /24, rather than dithering over which sub-/14 /16 # or sub-/19 /24 to retrieve - it's the least-wrong way to do things. my ($rpcblock) = ($cidr->masklen <= 24 ? $cidr->split( ($cidr->masklen <= 16 ? 16 : 24) ) : $cidr); my %rpcargs = ( rpcuser => $args{user}, group => $revgroup, # not sure how this could sanely be exposed, tbh... cidr => "$rpcblock", ); $rdns = _rpc('getRevPattern', %rpcargs); } # hmm. do we care about where it actually came from? return $rdns; } # end getBlockRDNS() ## IPDB::getNodeList() # Gets a list of node ID+name pairs as an arrayref to a list of hashrefs sub getNodeList { my $dbh = shift; my $ret = $dbh->selectall_arrayref("SELECT node_id, node_name FROM nodes ORDER BY node_type,node_id", { Slice => {} }); return $ret; } # end getNodeList() ## IPDB::getNodeName() # Get node name from the ID sub getNodeName { my $dbh = shift; my $nid = shift; my ($nname) = $dbh->selectrow_array("SELECT node_name FROM nodes WHERE node_id = ?", undef, ($nid) ); return $nname; } # end getNodeName() ## IPDB::getNodeInfo() # Get node name and ID associated with a block sub getNodeInfo { my $dbh = shift; my $block = shift; my ($nid, $nname) = $dbh->selectrow_array("SELECT nodes.node_id,node_name FROM nodes INNER JOIN noderef". " ON nodes.node_id=noderef.node_id WHERE noderef.block = ?", undef, ($block) ); return ($nid, $nname); } # end getNodeInfo() ## IPDB::mailNotify() # Sends notification mail to recipients regarding an IPDB operation sub mailNotify { my $dbh = shift; my ($action,$subj,$message) = @_; return if $smtphost eq 'smtp.example.com'; # do nothing if still using default SMTP host. ##fixme: need to redesign the breakdown/processing for $action for proper handling of all cases # split action into parts for fiddlement. nb: there are almost certainly better ways to do this. my @actionbits = split //, $action; # want to notify anyone who has specifically requested notify on *this* type ($action as passed), # on "all static IP types" or "all pool types" (and other last-char-in-type groupings), on eg "all DSL types", # and "all events with this action" my @actionsets = ($action); ##fixme: ick, eww. really gotta find a better way to handle this... push @actionsets, ($actionbits[0].'.'.$actionbits[2], $actionbits[0].$actionbits[1].'.', $actionbits[0].'a') if $action =~ /^.{3}$/; my $mailer = Net::SMTP->new($smtphost, Hello => "ipdb.$domain"); # get recip list from db my $sth = $dbh->prepare("SELECT reciplist FROM notify WHERE action=?"); my %reciplist; foreach (@actionsets) { $sth->execute($_); ##fixme - need to handle db errors my ($recipsub) = $sth->fetchrow_array; next if !$recipsub; foreach (split(/,/, $recipsub)) { $reciplist{$_}++; } } return if !%reciplist; foreach my $recip (keys %reciplist) { $mailer->mail("ipdb\@$domain"); $mailer->to($recip); $mailer->data("From: \"$org_name IP Database\" \n", "To: $recip\n", "Date: ".strftime("%a, %d %b %Y %H:%M:%S %z",localtime)."\n", "Subject: {IPDB} $subj\n", "X-Mailer: IPDB Notify v".sprintf("%.1d",$IPDB::VERSION)."\n", "Organization: $org_name\n", "\n$message\n"); } $mailer->quit; } # Indicates module loaded OK. Required by Perl. 1;