# ipdb/cgi-bin/IPDB.pm # Contains functions for IPDB - database access, subnet mangling, block allocation, etc ### # SVN revision info # $Date: 2015-07-28 22:00:43 +0000 (Tue, 28 Jul 2015) $ # SVN revision $Rev: 759 $ # 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 %merge_display %aclmsg %rpcacl $maxfcgi $errstr &initIPDBGlobals &connectDB &finish &checkDBSanity &addMaster &touchMaster &listSummary &listSubs &listContainers &listAllocations &listForMerge &listFree &listPool &getMasterList &getTypeList &getPoolSelect &findAllocateFrom &ipParent &subParent &blockParent &getBreadCrumbs &getRoutedCity &allocateBlock &updateBlock &splitBlock &shrinkBlock &mergeBlocks &deleteBlock &getBlockData &getBlockRDNS &getRDNSbyIP &getNodeList &getNodeName &getNodeInfo &mailNotify ); @EXPORT = (); # Export nothing by default. %EXPORT_TAGS = ( ALL => [qw( %disp_alloctypes %list_alloctypes %def_custids @citylist @poplist %IPDBacl %merge_display %aclmsg %rpcacl $maxfcgi $errstr &initIPDBGlobals &connectDB &finish &checkDBSanity &addMaster &touchMaster &listSummary &listSubs &listContainers &listAllocations &listForMerge &listFree &listPool &getMasterList &getTypeList &getPoolSelect &findAllocateFrom &ipParent &subParent &blockParent &getBreadCrumbs &getRoutedCity &allocateBlock &updateBlock &splitBlock &shrinkBlock &mergeBlocks &deleteBlock &getBlockData &getBlockRDNS &getRDNSbyIP &getNodeList &getNodeName &getNodeInfo &mailNotify )] ); ## ## Global variables ## our %disp_alloctypes; our %list_alloctypes; our %def_custids; our @citylist; our @poplist; our %IPDBacl; # Mapping hash for pooltype -> poolip-as-netblock conversions my %poolmap = (sd => 'en', cd => 'cn', dp => 'cn', mp => 'cn', wp => 'cn', ld => 'in', ad => 'in', bd => 'in'); # Friendly display strings for merge scopes our %merge_display = ( keepall => "Keep mergeable allocations as suballocations of new block", mergepeer => "Keep suballocations of mergeable allocations", clearpeer => "Keep only suballocations of the selected block", clearall => "Clear all suballocations" ); # 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', ); our %rpcacl; our $maxfcgi = 3; # error reporting our $errstr = ''; our $org_name = 'Example Corp'; our $smtphost = 'smtp.example.com'; our $domain = 'example.com'; our $defcustid = '5554242'; our $smtpsender = 'ipdb@example.com'; # 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; # Largest inverse CIDR mask length to show per-IP rDNS list # (eg, NetAddr::IP->bits - NetAddr::IP->masklen) our $maxrevlist = 5; # /27 # UI layout for subblocks/containers our $sublistlayout = 1; # VLAN validation mode. Set to 0 to allow alphanumeric vlan names instead of using the vlan number. our $numeric_vlan = 1; ## ## 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', # must be provided by caller's caller # rpcuser => $args{user}, %args, ); eval { $result = $server->call("dnsdb.$rpcsub", %rpcargs); }; if ($@) { $errstr = $@; $errstr =~ s/\s*$//; $errstr =~ s/Fault returned from XML RPC Server, fault code 4: error executing RPC `dnsdb.$rpcsub'\.\s//; } $rpccount++; return $result if $result; } # end _rpc() ## IPDB::_compactFree() # Utility sub to compact a set of free block entries down to the minimum possible set of CIDR entries # Not to be called outside of an eval{}! sub _compactFree { my $dbh = shift; my $parent = shift; # Rather than having the caller provide all the details my $pinfo = getBlockData($dbh, $parent); my $ftype = (split //, $pinfo->{type})[0]; # 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. ##fixme: vrf ##fixme: simplify since all containers now represent different "layers"/"levels"? # set up the query to get the list of blocks to try to merge. my $sth = $dbh->prepare(q{ SELECT cidr,id FROM freeblocks WHERE parent_id = ? ORDER BY masklen(cidr) DESC }); $sth->execute($parent); my (@rawfb, @combinelist, %rawid); 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 ($fcidr, $fid) = $sth->fetchrow_array) { my $testIP = new NetAddr::IP $fcidr; push @rawfb, $testIP; $rawid{"$testIP"} = $fid; # $data[0] vs "$testIP" *does* make a difference for v6 @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 id = ?"); foreach my $rawfree (@rawfb) { next if grep { $rawfree == $_ } @combinelist; # skip if the raw block is in the compacted list $sth->execute($rawid{$rawfree}); } # 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,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)"); foreach my $cme (@combinelist) { next if grep { $cme == $_ } @rawfb; # skip if the combined block was in the raw list $sth->execute($cme, $pinfo->{city}, $ftype, $pinfo->{vrf}, $parent, $pinfo->{master_id}); } } # end _compactFree() ## IPDB::_toPool() # Convert an allocation or allocation tree to entries in an IP pool # Assumes an incomplete/empty pool # Takes a parent ID for the pool, CIDR range descriptor for the allocation(s) to convert, and the pool type sub _toPool { my $dbh = shift; my $poolparent = shift; my $convblock = shift; # May be smaller than the block referenced by $poolparent my $pooltype = shift; my $retall = shift || 0; # there is probably a way to avoid the temporary $foo here my $foo = $dbh->selectall_arrayref("SELECT master_id,parent_id FROM allocations WHERE id = ?", undef, $poolparent); my ($master,$mainparent) = @{$foo->[0]}; my @retlist; my $iptype = $pooltype; $iptype =~ s/[pd]$/i/; my $poolclass = (split //, $iptype)[0]; my $cidrpool = new NetAddr::IP $convblock; my $asth = $dbh->prepare(q{ SELECT id, cidr, type, parent_id, city, description, notes, circuitid, createstamp, modifystamp, privdata, custid, vrf, vlan, rdns FROM allocations WHERE cidr <<= ? AND master_id = ? ORDER BY masklen(cidr) DESC }); my $inssth = $dbh->prepare(q{ INSERT INTO poolips ( ip,type,parent_id,available, city,description,notes,circuitid,createstamp,modifystamp,privdata,custid,vrf,vlan,rdns ) VALUES (?,?,?,'n',?,?,?,?,?,?,?,?,?,?,?) }); my $updsth = $dbh->prepare("UPDATE poolips SET parent_id = ?, type = ? WHERE parent_id = ?"); my $delsth = $dbh->prepare("DELETE FROM allocations WHERE id = ?"); my $fbdelsth = $dbh->prepare("DELETE FROM freeblocks WHERE parent_id = ?"); $asth->execute($convblock, $master); my %poolcounter; while (my ($oldid, $oldcidr, $oldtype, $oldparent, @oldalloc) = $asth->fetchrow_array) { if ($oldtype =~ /.[enr]/) { # Convert leaf allocations to block of pool IP assignments my $tmpcidr = new NetAddr::IP $oldcidr; my $newtype = $poolclass.'i'; # set up the gateway IP in case we need it my $gw = $cidrpool+1; foreach my $newip ($tmpcidr->split(32)) { my $baseip = $newip->addr; # skip .0 and .255, they are prefectly legitimate but some systems behave # poorly talking to a client using them. next if $baseip =~ /\.(?:0|255)$/; # skip the network, broadcast, and gateway IPs if we're creating a "normal netblock" pool if ($pooltype =~ /d$/) { next if $newip->addr eq $cidrpool->network->addr; next if $newip->addr eq $cidrpool->broadcast->addr; next if $newip->addr eq $gw->addr; } $inssth->execute($newip, $newtype, $poolparent, @oldalloc) if !$poolcounter{"$newip"}; $poolcounter{"$newip"}++; } } elsif ($oldtype =~ /.[dp]/) { # Reparent IPs in an existing pool, and rewrite their type $updsth->execute($poolparent, $poolclass.'i', $oldid); } else { # Containers are mostly "not interesting" in this context since they're # equivalent to the pool allocation on .[dp] types. Clean up the lingering free block(s). $fbdelsth->execute($oldid); } # Clean up - remove the converted block unless it is the "primary" $delsth->execute($oldid) unless $oldid == $poolparent; # Return the converted blocks, but only the immediate peers, not the entire tree push @retlist, { block => $oldcidr, mdisp => $disp_alloctypes{$oldtype}, mtype => $oldtype } if (($oldparent == $mainparent) || $retall) && $oldid != $poolparent; } # while $asth->fetch return \@retlist; } # end _toPool() ## IPDB::_poolToAllocations # Convert pool IPs into allocations, and free IPs into free blocks # Takes a pool ID, original pool CIDR (in case the allocation has been updated before the call here) # and hashref to data for the new parent container for the IPs, # and an optional hash with the new parent ID and allocation type sub _poolToAllocations { my $dbh = shift; my $oldpool = shift; my $parentinfo = shift; my %args = @_; # Default to converting the pool to a container $args{newparent} = $oldpool->{id} if !$args{newparent}; my ($containerclass) = ($parentinfo->{type} =~ /(.)./); # Default type mapping $args{newtype} = $poolmap{$oldpool->{type}} if !$args{newtype}; # Convert a bunch of pool IP allocations into "normal" netblock allocations my $pool2alloc = $dbh->prepare(q{ INSERT INTO allocations ( cidr,type,city, description, notes, circuitid, createstamp, modifystamp, privdata, custid, vrf, vlan, rdns, parent_id, master_id ) SELECT ip, ? AS type, city, description, notes, circuitid, createstamp, modifystamp, privdata, custid, vrf, vlan, rdns, ? AS parent_id, master_id FROM poolips WHERE parent_id = ? AND available = 'n' }); $pool2alloc->execute($args{newtype}, $args{newparent}, $oldpool->{id}); # Snag the whole list of pool IPs my @freeips = @{$dbh->selectall_arrayref("SELECT ip,available FROM poolips WHERE parent_id = ?", undef, $oldpool->{id})}; my @iplist; my %usedips; # Filter out the ones that were used... foreach my $ip (@freeips) { $$ip[0] =~ s{/32$}{}; push @iplist, NetAddr::IP->new($$ip[0]) if $$ip[1] eq 'y'; $usedips{$$ip[0]}++ if $$ip[1] eq 'n'; } # ... so that we can properly decide whether the net, gw, and bcast IPs need to be added to the free list. my $tmpblock = new NetAddr::IP $oldpool->{block}; push @iplist, NetAddr::IP->new($tmpblock->network->addr) if !$usedips{$tmpblock->network->addr} || $tmpblock->network->addr =~ /\.0$/; push @iplist, NetAddr::IP->new($tmpblock->broadcast->addr) if !$usedips{$tmpblock->broadcast->addr} || $tmpblock->broadcast->addr =~ /\.255$/; # only "DHCP"-ish pools have a gw ip removed from the pool if ($oldpool->{type} =~ /.d/) { $tmpblock++; push @iplist, NetAddr::IP->new($tmpblock->addr); } # take the list of /32 IPs, and see what CIDR ranges we get back as free, then insert them. @iplist = Compact(@iplist); my $insfbsth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)"); foreach (@iplist) { $insfbsth->execute($_, $parentinfo->{city}, $containerclass, $parentinfo->{vrf}, $args{newparent}, $parentinfo->{master_id}); } # and finally delete the poolips entries $dbh->do("DELETE FROM poolips WHERE parent_id = ?", undef, $oldpool->{id}); } # end _poolToAllocations() ## IPDB::_deleteCascade() # Internal sub. Deletes an allocation and all subcomponents sub _deleteCascade { my $dbh = shift; my $id = shift; my $createfb = shift; # may be null at this point my $binfo = getBlockData($dbh, $id); # Decide if we're going to add a free block. # Caller is normal block delete -> add freeblock under $binfo->{parent_id} -> pass nothing # Caller is delete for merge to leaf -> do not add freeblock -> pass 0 # Caller is normal master delete -> do not add freeblock -> pass nothing # Caller is merge master -> add freeblock under alternate parent -> pass parent ID if ($binfo->{type} ne 'mm') { # Deleting a non-master block if (!defined($createfb)) { # No createfb flag passed; assuming normal block delete. Add the freeblock # under the parent of the block we're deleting. $createfb = $binfo->{parent_id}; #} else { # Don't need to actually do anything here. The caller has given us an ID, # which is either 0 (causing no free block) or (theoretically) a valid block # ID to add the free block under. } #} else { # Deleting a master block # Don't need to actually do anything here. If the caller passed a parent ID, # that parent will get the new free block. if the caller didn't pass anything, # no free block will be added. } ##fixme: special-case master blocks up here and quickly delete based on master_id, # instead of wasting time tracing parent relations # grab all allocations in the master within the CIDR of the block to be deleted my %parents; my %cidrlist; ##fixme: limit by VRF? my $sth = $dbh->prepare("SELECT cidr,id,parent_id FROM allocations WHERE cidr <<= ? AND master_id = ?"); $sth->execute($binfo->{block}, $binfo->{master_id}); while (my ($cidr, $cid, $pid) = $sth->fetchrow_array) { $parents{$cid} = $pid; $cidrlist{$cid} = $cidr; } # Trace the parent relations up the tree until we either hit parent ID 0 (we've found a master block # but not the parent we're looking for - arguably this is already an error) or the parent ID matches # the passed ID. If the latter, push the whole set into a second flag hash, so we can terminate # further tree-tracing early. my %found; foreach my $cid (keys %parents) { my @tmp; if ($cid == $id) { # "child" is the ID we've been asked to cascade-delete. $found{$cid}++; } elsif ($found{$cid}) { # ID already seen and the chain terminates in our parent. } elsif ($parents{$cid} == $id) { # Immediate parent is the target parent $found{$cid}++; } else { # Immediate parent isn't the one we're looking for. Walk the chain up until we hit our parent, # the nonexistent parent id 0, or undefined (ID is not a child of the target ID at all) # There are probably better ways to structure this loop. while (1) { # cache the ID push @tmp, $cid; # some very particularly defined loop ending conditions if (!defined($parents{$cid}) || $parents{$cid} == $id || $parents{$cid} == 0) { last; } else { # if we haven't found either the desired parent or another limiting condition, # reset the ID to the parent next up the tree $cid = $parents{$cid}; } } # if the current chain of relations ended with our target parent, shuffle the cached IDs into a flag hash if (defined($parents{$cid}) && $parents{$cid} == $id) { foreach (@tmp) { $found{$_}++; } } } # else } # foreach my $cid # Use the keys in the flag hash to determine which allocations to actually delete. # Delete matching freeblocks and pool IPs; their parents are going away so we want # to make sure we don't leave orphaned records lying around loose. my @dellist = keys %found; push @dellist, $id; # Just In Case the target ID didn't make the list earlier. my $b = '?'. (',?' x $#dellist); $dbh->do("DELETE FROM allocations WHERE id IN ($b)", undef, (@dellist) ); $dbh->do("DELETE FROM freeblocks WHERE parent_id IN ($b)", undef, (@dellist) ); $dbh->do("DELETE FROM poolips WHERE parent_id IN ($b)", undef, (@dellist) ); # Insert a new free block if needed if ($createfb) { my $pinfo = getBlockData($dbh, $createfb); my $pt = (split //, $pinfo->{type})[1]; $dbh->do("INSERT INTO freeblocks (cidr,city,routed,parent_id,vrf,master_id) VALUES (?,?,?,?,?,?)", undef, $binfo->{block}, $pinfo->{city}, $pt, $createfb, $pinfo->{vrf}, $binfo->{master_id}); } ##todo: and hey! bonus! we can return @dellist, or something (%cidrlist{@dellist}) } # end _deleteCascade() ## ## Public subs ## ## 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'; my $mid; # 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 { # First check - does the master exist? Ignore VRFs until we can see a sane UI my ($mcontained) = $dbh->selectrow_array("SELECT cidr FROM allocations WHERE cidr >>= ? AND type = 'mm'", undef, ($cidr) ); die "Master block $mcontained already exists and entirely contains $cidr\n" if $mcontained; # Second check - does the new master contain an existing one or ones? my ($mexist) = $dbh->selectrow_array("SELECT cidr FROM allocations WHERE cidr <<= ? AND type = 'mm'", 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 allocations (cidr,type,swip,vrf,rdns) VALUES (?,?,?,?,?)", undef, ($cidr, 'mm', 'y', $args{vrf}, $args{rdns}) ); ($mid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')"); # 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_id,vrf,master_id) VALUES (?,?,?,?,?,?)", undef, ($cidr, '', 'm', $mid, $args{vrf}, $mid) ); # master should be its own master, so deletes directly at the master level work $dbh->do("UPDATE allocations SET master_id = ? WHERE id = ?", undef, ($mid, $mid) ); # 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,id FROM allocations WHERE cidr <<= ? AND type='mm' AND parent_id=0"); $sth->execute($cidr); my @cmasters; my @oldmids; while (my @data = $sth->fetchrow_array) { my $master = new NetAddr::IP $data[0]; push @cmasters, $master; push @oldmids, $data[1]; $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; } ##fixme: master_id # 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); # master $dbh->do("INSERT INTO allocations (cidr,type,swip,vrf,rdns) VALUES (?,?,?,?,?)", undef, ($cidr, 'mm', 'y', $args{vrf}, $args{rdns}) ); ($mid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')"); # master should be its own master, so deletes directly at the master level work $dbh->do("UPDATE allocations SET master_id = ? WHERE id = ?", undef, ($mid, $mid) ); # and now insert the new data. Make sure to delete old masters too. # freeblocks $sth = $dbh->prepare("DELETE FROM freeblocks WHERE cidr <<= ? AND parent_id IN (".join(',', @oldmids).")"); my $sth2 = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,parent_id,vrf,master_id)". " VALUES (?,'','m',?,?,?)"); foreach my $newblock (@blocklist) { $sth->execute($newblock); $sth2->execute($newblock, $mid, $args{vrf}, $mid); } # Update immediate allocations, and remove the old parents $sth = $dbh->prepare("UPDATE allocations SET parent_id = ? WHERE parent_id = ?"); $sth2 = $dbh->prepare("DELETE FROM allocations WHERE id = ?"); foreach my $old (@oldmids) { $sth->execute($mid, $old); $sth2->execute($old); } # *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 my $dasth = $dbh->prepare("INSERT INTO dnsavail (zone,location,parent_alloc) VALUES (?,?,?)"); 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) { if (!_rpc('addRDNS', %rpcargs)) { push @fails, ("$subzone" => $errstr); } else { $dasth->execute($subzone, $args{defloc}, $mid) or push @fails, ("$subzone" => "rDNS added but failed to track locally: ".$dasth->errstr."\n"); } } } if (@fails) { $errstr = "Warning(s) adding $cidr to reverse DNS:\n".join("\n", @fails); return ('WARN',$mid); } } return ('OK',$mid); } } # 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 allocations SET modifystamp=now() WHERE id = ?", 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,id,vrf FROM allocations ". "WHERE type='mm' ORDER BY cidr", { Slice => {} }); foreach (@{$mlist}) { my ($rcnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ? AND type='rm' AND master_id = ?", undef, ($$_{master}, $$_{id})); $$_{routed} = $rcnt; my ($acnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ? ". "AND NOT type='rm' AND NOT type='mm' AND master_id = ?", undef, ($$_{master}, $$_{id})); $$_{allocated} = $acnt; my ($fcnt) = $dbh->selectrow_array("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?", undef, ($$_{master}, $$_{id})); $$_{free} = $fcnt; my ($bigfree) = $dbh->selectrow_array("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?". " AND master_id = ? ORDER BY masklen(cidr) LIMIT 1", undef, ($$_{master}, $$_{id})); ##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}; # Snag the allocations for this block my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description,vrf,id,master_id". " FROM allocations WHERE parent_id = ? ORDER BY cidr"); $sth->execute($args{parent}); # 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 = ?"); # snag some more details my $substh = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ". "AND type ~ '[mc]\$' AND master_id = ? AND NOT cidr = ? "); my $alsth = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ". "AND NOT type='rm' AND NOT type='mm' AND master_id = ? AND NOT id = ?"); my $freesth = $dbh->prepare("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?"); my $lfreesth = $dbh->prepare("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?". " AND master_id = ? ORDER BY masklen(cidr) LIMIT 1"); my @blocklist; while (my ($cidr,$city,$type,$custid,$swip,$desc,$vrf,$id,$mid) = $sth->fetchrow_array()) { $desc .= " - vrf:$vrf" if $desc && $vrf; $desc = "vrf:$vrf" if !$desc && $vrf; $custsth->execute($custid); my ($ncust) = $custsth->fetchrow_array(); $substh->execute($cidr, $mid, $cidr); my ($cont) = $substh->fetchrow_array(); $alsth->execute($cidr, $mid, $id); my ($alloc) = $alsth->fetchrow_array(); $freesth->execute($cidr, $mid); my ($free) = $freesth->fetchrow_array(); $lfreesth->execute($cidr, $mid); my ($lfree) = $lfreesth->fetchrow_array(); $lfree = "/$lfree" if $lfree; $lfree = '' if !$lfree; my %row = ( block => $cidr, subcontainers => $cont, suballocs => $alloc, subfree => $free, lfree => $lfree, 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), id => $id, ); # $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::listContainers() # List all container-type allocations in a given parent # Takes a database handle and a hash: # - parent is the ID of the parent block # Returns an arrayref to a list of hashrefs with the CIDR block, location, type, # description, block ID, and counts for the nmber uf suballocations (all types), # free blocks, and the CIDR size of the largest free block sub listContainers { my $dbh = shift; my %args = @_; # Just In Case $args{vrf} = '' if !$args{vrf}; # Snag the allocations for this block my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description,vrf,id,master_id". " FROM allocations WHERE parent_id = ? AND type ~ '[mc]\$' ORDER BY cidr"); $sth->execute($args{parent}); my $alsth = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ". "AND NOT type='rm' AND NOT type='mm' AND master_id = ? AND NOT id = ?"); my $freesth = $dbh->prepare("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?"); my $lfreesth = $dbh->prepare("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?". " AND master_id = ? ORDER BY masklen(cidr) LIMIT 1"); my @blocklist; while (my ($cidr,$city,$type,$custid,$swip,$desc,$vrf,$id,$mid) = $sth->fetchrow_array()) { $desc .= " - vrf:$vrf" if $desc && $vrf; $desc = "vrf:$vrf" if !$desc && $vrf; $alsth->execute($cidr, $mid, $id); my ($alloc) = $alsth->fetchrow_array(); $freesth->execute($cidr, $mid); my ($free) = $freesth->fetchrow_array(); $lfreesth->execute($cidr, $mid); my ($lfree) = $lfreesth->fetchrow_array(); $lfree = "/$lfree" if $lfree; $lfree = '' if !$lfree; my %row = ( block => $cidr, suballocs => $alloc, subfree => $free, lfree => $lfree, city => $city, type => $disp_alloctypes{$type}, desc => $desc, id => $id, ); push (@blocklist, \%row); } return \@blocklist; } # end listContainers() ## IPDB::listAllocations() # List all end-use allocations in a given parent # Takes a database handle and a hash: # - parent is the ID of the parent block # Returns an arrayref to a list of hashrefs with the CIDR block, location, type, # custID, SWIP flag, description, block ID, and master ID sub listAllocations { my $dbh = shift; my %args = @_; # Snag the allocations for this block my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description,vrf,id,master_id". " FROM allocations WHERE parent_id = ? AND type !~ '[mc]\$' ORDER BY cidr"); $sth->execute($args{parent}); # 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,$vrf,$id,$mid) = $sth->fetchrow_array()) { $desc .= " - vrf:$vrf" if $desc && $vrf; $desc = "vrf:$vrf" if !$desc && $vrf; $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, id => $id, ); # $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 listAllocations() ## IPDB::listForMerge() # Get a list of blocks targetted in a proposed merge sub listForMerge { my $dbh = shift; my $parent = shift; my $newblock = shift; my $btype = shift || 'a'; $btype = 'a' if $btype !~/^[af]$/; my $incsub = shift; $incsub = 1 if !defined($incsub); my $sql; if ($btype eq 'a') { my $ret = $dbh->selectall_arrayref(q( SELECT a.cidr,a.id,t.dispname FROM allocations a JOIN alloctypes t ON a.type=t.type WHERE a.parent_id = ? AND a.cidr <<= ? ORDER BY a.cidr ), { Slice => {} }, $parent, $newblock); return $ret; } else { ##fixme: Not sure about the casting hackery in "SELECT ?::integer AS id", but it works as intended my @dbargs = ($parent, "$newblock"); push @dbargs, $parent, $newblock if $incsub; my $ret = $dbh->selectall_arrayref(q{ SELECT cidr,id FROM freeblocks WHERE parent_id IN ( }.($incsub ? "SELECT id FROM allocations WHERE parent_id = ? AND cidr <<= ? UNION " : '').q{ SELECT ?::integer AS id ) AND cidr <<= ? ORDER BY cidr }, { Slice => {} }, @dbargs); return $ret; } return; } # end listForMerge() ## 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 ID 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}; my $sth = $dbh->prepare(q( SELECT f.cidr,f.id,allocations.cidr FROM freeblocks f LEFT JOIN allocations ON f.reserve_for = allocations.id WHERE f.parent_id = ? ORDER BY f.cidr ) ); # $sth->execute($args{parent}, $args{vrf}); $sth->execute($args{parent}); my @flist; while (my ($cidr,$id,$resv) = $sth->fetchrow_array()) { $cidr = new NetAddr::IP $cidr; my %row = ( fblock => "$cidr", frange => $cidr->range, fbid => $id, fbparent => $args{parent}, resv => $resv, ); push @flist, \%row; } return \@flist; } # end listFree() ## IPDB::listPool() # List the IPs in an IP pool. # Takes a pool/parent ID # Returns an arrayref to a list of hashrefs containing the IP, customer ID, availability flag, # description, backreference to the pool/parent, and the IP ID in the pool. # Also includes a "may be deleted" metaflag mainly useful for allowing the return to be passed # directly to HTML::Template for UI display. sub listPool { my $dbh = shift; my $pool = shift; my $sth = $dbh->prepare("SELECT ip,custid,available,description,type,id". " FROM poolips WHERE parent_id = ? ORDER BY ip"); $sth->execute($pool); my @poolips; while (my ($ip,$custid,$available,$desc,$type,$id) = $sth->fetchrow_array) { my %row = ( ip => $ip, custid => $custid, available => $available, desc => $desc, delme => $available eq 'n', parent => $pool, id => $id, ); 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 id,vrf,cidr AS master".($stampme eq 'm' ? ',modifystamp AS mtime' : ''). " FROM allocations WHERE type='mm' 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 $seltype = shift || ''; my $sql = "SELECT type,listname,type=? AS sel FROM alloctypes WHERE listorder <= 500"; 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. $sql .= " AND type NOT LIKE '_i'"; } elsif ($tgroup eq 'p') { # grouping 'p' - primary allocation types. As with 'n' above but without the _r contained types. $sql .= " AND type NOT LIKE '_i' AND type NOT LIKE '_r'"; } elsif ($tgroup eq 'c') { # grouping 'c' - contained types. These include all static IPs and all _r types. $sql .= " AND (type LIKE '_i' OR type LIKE '_r')"; } elsif ($tgroup eq 'i') { # grouping 'i' - static IP types. $sql .= " AND type LIKE '_i'"; } else { # grouping 'a' - all standard allocation types. This includes everything # but mm (present only as a formality). Make this the default. # ... whee! no extra WHERE clauses } $sql .= " ORDER BY listorder"; my $tlist = $dbh->selectall_arrayref($sql, { Slice => {} }, $seltype); 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 containing the number of available IPs, the CIDR pool, # and the city it's nominally in. sub getPoolSelect { my $dbh = shift; my $iptype = shift; my $pcity = shift; my ($ptype) = ($iptype =~ /^(.)i$/); return if !$ptype; $ptype .= '_'; my $plist = $dbh->selectall_arrayref( q( SELECT count(*) AS poolfree,p.pool AS poolblock, a.city AS poolcit FROM poolips p JOIN allocations a ON p.parent_id=a.id WHERE p.available='y' AND a.city = ? AND p.type LIKE ? GROUP BY p.pool,a.city ), { 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 3-element list with the free block ID, CIDR, and parent ID 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"; my @vallist; my $sql; # Free pool IPs should be easy. if ($type =~ /^.i$/) { # User may get an IP from the wrong VRF. User should not be using admin tools to allocate static IPs. $sql = "SELECT id, ip, parent_id FROM poolips WHERE ip = ?"; @vallist = ($optargs{gimme}); } else { ## 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. @vallist = ($maskbits); $sql = "SELECT id,cidr,parent_id 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 ##fixme: config or UI flag for "Strict" mode # if ($strictmode) { if (0) { 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 master_id = ?"; # 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')"; } } # Keep "reserved" blocks out of automatic assignment. ##fixme: needs a UI flag or a config knob $sql .= " AND reserve_for = 0"; # 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 masklen(cidr) DESC,cidr LIMIT 1"; } # done setting up SQL for free CIDR block my ($fbid,$fbfound,$fbparent) = $dbh->selectrow_array($sql, undef, @vallist); return $fbid,$fbfound,$fbparent; } # 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::getBreadCrumbs() # Retrieve the ID and CIDR of a block's parent(s) up to the master block # Returns an arrayref to a list of hashrefs with CIDR and block ID sub getBreadCrumbs { my $dbh = shift; my $parent = shift; my @result; my $sth = $dbh-> prepare("SELECT cidr,type,id,parent_id FROM allocations WHERE id=?"); while ($parent != 0) { $sth->execute($parent); my ($cidr,$type,$id,$pid) = $sth->fetchrow_array; push @result, {cidr => $cidr, link => $id, ispool => ($type =~ /^.[dp]$/ ? 1 : 0)}; $parent = $pid; } return \@result; } # end getBread() ## 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{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{vlan} = '' if !$args{vlan}; $args{rdns} = '' if !$args{rdns}; # Could arguably allow this for eg /120 allocations, but end users who get a single v4 IP are # usually given a v6 /64, and most v6 addressing schemes need at least half that address space if ($args{cidr}->{isv6} && $args{rdns} =~ /\%/) { return ('FAIL','Reverse DNS template patterns are not supported for IPv6 allocations'); } my $sth; # Snag the "type" of the freeblock and its CIDR my ($alloc_from_type, $alloc_from, $fbparent, $fcity, $fbmaster) = $dbh->selectrow_array("SELECT routed,cidr,parent_id,city,master_id FROM freeblocks WHERE id = ?", undef, $args{fbid}); $alloc_from = new NetAddr::IP $alloc_from; return ('FAIL',"Failed to allocate $args{cidr}; intended free block was used by another allocation.") if ($args{type} !~ /.i/ && !$fbparent); ##fixme: fail here if !$alloc_from # also consider "lock for allocation" due to multistep allocation process # 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 = ? AND parent_id = ?", undef, ($args{custid}, $args{city}, $args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{vrf}, $args{rdns}, $args{cidr}, $args{parent}) ); # 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; # Allocate IP from pool }; if ($@) { $msg .= ": $@"; eval { $dbh->rollback; }; return ('FAIL', $msg); } else { # Snag the pool info my $pinfo = getBlockData($dbh, $args{parent}); # Only try to update rDNS when the pool is flagged as "rDNS available" if ($pinfo->{revavail} || $pinfo->{revpartial}) { _rpc('addOrUpdateRevRec', cidr => "$args{cidr}", name => $args{rdns}, rpcuser => $args{user}); } return ('OK', $args{cidr}); } } else { # end IP-from-pool allocation if ($args{cidr} == $alloc_from) { # Easiest case- insert in one table, delete in the other, and go home. More or less. eval { $msg = "Unable to allocate $args{cidr} as '$disp_alloctypes{$args{type}}'"; # Insert the allocations entry $dbh->do("INSERT INTO allocations ". "(cidr,parent_id,master_id,vrf,vlan,custid,type,city,description,notes,circuitid,privdata,rdns)". " VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)", undef, ($args{cidr}, $fbparent, $fbmaster, $args{vrf}, $args{vlan}, $args{custid}, $args{type}, $args{city}, $args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{rdns}) ); my ($bid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')"); # 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 = ?,city = ?,parent_id = ? WHERE id = ?", undef, ($rtype, $args{city}, $bid, $args{fbid}) ); } else { # "normal" case $dbh->do("DELETE FROM freeblocks WHERE id = ?", undef, ($args{fbid}) ); } # 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", $bid); 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", $bid); 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; # Simple block allocation }; # end of eval if ($@) { $msg .= ": ".$@; eval { $dbh->rollback; }; return ('FAIL',$msg); } } else { # cidr != alloc_from # Hard case. Allocation is smaller than free block. # make sure new allocation is in fact within freeblock. *sigh* return ('FAIL',"Requested allocation $args{cidr} is not within $alloc_from") if !$alloc_from->contains($args{cidr}); my $wantmaskbits = $args{cidr}->masklen; my $maskbits = $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 = $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}}'"; # Delete old freeblocks entry $dbh->do("DELETE FROM freeblocks WHERE id = ?", undef, ($args{fbid}) ); # Insert the allocations entry $dbh->do("INSERT INTO allocations ". "(cidr,parent_id,master_id,vrf,vlan,custid,type,city,description,notes,circuitid,privdata,rdns)". " VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)", undef, ($args{cidr}, $fbparent, $fbmaster, $args{vrf}, $args{vlan}, $args{custid}, $args{type}, $args{city}, $args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{rdns}) ); my ($bid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')"); # Insert new list of smaller free blocks left over. Flag the one that matches the # masklength of the new allocation, if a reserve block was requested. $sth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id,reserve_for) ". "VALUES (?,?,?,?,?,?,?)"); foreach my $block (@newfreeblocks) { $sth->execute($block, $fcity, $alloc_from_type, $args{vrf}, $fbparent, $fbmaster, ($args{reserve} && $block->masklen == $wantmaskbits ? $bid : 0)); } # 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}, $bid, $fbmaster, 0); } # 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", $bid); 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", $bid); 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; # Complex block allocation }; # end eval if ($@) { $msg .= ": ".$@; eval { $dbh->rollback; }; return ('FAIL',$msg); } } # end fullcidr != alloc_from # Snag the parent info my $pinfo = getBlockData($dbh, $fbparent); # Only try to update rDNS when the pool is flagged as "rDNS available" if ($pinfo->{revavail} || $pinfo->{revpartial}) { # 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}; # and the per-IP set, if there is one. _rpc('updateRevSet', %{$args{iprev}}, rpcuser => $args{user}); } 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,$parent) = @_; 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; # Retrieve some odds and ends for defaults on the IPs my ($pcustid) = $dbh->selectrow_array("SELECT def_custid FROM alloctypes WHERE type=?", undef, ($type) ); my ($vrf,$vlan,$master) = $dbh->selectrow_array("SELECT vrf,vlan,master_id FROM allocations WHERE id = ?", undef, ($parent) ); $type =~ s/[pd]$/i/; my $sth; my $msg; eval { # have to insert all pool IPs into poolips table as "unallocated". $sth = $dbh->prepare("INSERT INTO poolips (ip,custid,city,type,parent_id,master_id) VALUES (?,?,?,?,?,?)"); # in case of pool extension by some means, we need to see what IPs were already inserted my $tmp1 = $dbh->selectall_arrayref("SELECT ip FROM poolips WHERE parent_id = ?", undef, $parent); my %foundips; foreach (@{$tmp1}) { $foundips{$_->[0]} = 1; } # Dodge an edge case - pool where IPs have been "stolen" and turned into a netblock assignment. # We can't just "get all the current IPs, and add the missing ones", because some IPs are # legitimately missing (for stretchy values of "legitimately"). my $pdata = getBlockData($dbh, $parent); my $pcidr = new NetAddr::IP $pdata->{block}; if ($pcidr != $pool) { # enumerate the IPs from the *old* pool, flag them as "found", so we can iterate the entire # requested pool and still make sure we skip the IPs in the old pool - even if they've been # "stolen" by legacy netblocks. my @oldips = $pcidr->hostenum; # decide whether to start excluding existing IPs at the "gateway" or "gateway+1" my $ostart = ($pdata->{type} =~ /^.d$/ ? 1 : 0); for (my $i = $ostart; $i<= $#oldips; $i++) { $foundips{$oldips[$i]} = 1; } } # enumerate the hosts in the IP range - everything except the first (net) and last (bcast) IP my @poolip_list = $pool->hostenum; # always check/add IPs from gw+1 through bcast-1: # (but the set won't be in oooorderrrrr! ) for (my $i=1; $i<=$#poolip_list; $i++) { my $baseip = $poolip_list[$i]->addr; if ($baseip !~ /\.(?:0|255)$/ && !$foundips{$poolip_list[$i]}) { $sth->execute($baseip, $pcustid, $city, $type, $parent, $master); } } # now do the special case - DSL/PPP blocks can use the "net", "gw", and "bcast" IPs. # we exclude .0 and .255 anyway, since while they'll mostly work, they *will* behave badly here and there. if ($class eq 'all') { # (DSL-ish block - *all* IPs available if ($pool->addr !~ /\.0$/) { # .0 causes weirdness. $sth->execute($pool->addr, $pcustid, $city, $type, $parent, $master) unless $foundips{$pool->addr."/32"}; } $sth->execute($poolip_list[0]->addr, $pcustid, $city, $type, $parent, $master) unless $foundips{$poolip_list[0]}; $pool--; if ($pool->addr !~ /\.255$/) { # .255 can cause weirdness. $sth->execute($pool->addr, $pcustid, $city, $type, $parent, $master) unless $foundips{$pool->addr."/32"}; } } # don't commit here! the caller may not be done. # $dbh->commit; }; if ($@) { $msg = $@; # Don't roll back! It's up to the caller to handle this. # 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}; # Spaces don't show up well in lots of places. Make sure they don't get into the DB. $args{custid} =~ s/^\s+//; $args{custid} =~ s/\s+$//; # 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', 'vrf', 'vlan') { if ($args{$_}) { push @fieldlist, $_; push @vallist, $args{$_}; } } my $binfo; my $updtable = 'allocations'; my $keyfield = 'id'; if ($args{type} =~ /^(.)i$/) { $updtable = 'poolips'; $binfo = getBlockData($dbh, $args{block}, 'i'); } else { ## fixme: there's got to be a better way... $binfo = getBlockData($dbh, $args{block}); 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; my $sql = "UPDATE $updtable SET "; $sql .= join " = ?, ", @fieldlist; eval { # check for block merge first... if ($args{fbmerge}) { my $cidr = NetAddr::IP->new($binfo->{block}); my $newblock = NetAddr::IP->new($cidr->addr, $cidr->masklen - 1)->network; # safety net? make sure mergeable block passed in is really one or both of # a) reserved for expansion of the block and # b) confirmed CIDR-combinable # "safety? SELECT foo FROM freeblocks WHERE cidr << ? AND masklen(cidr) = ?, $newblock, ".$cidr->masklen."\n"; $dbh->do("DELETE FROM freeblocks WHERE id=?", undef, $args{fbmerge}); # ... so we can append the change in the stored CIDR field to extend the allocation. $sql .= " = ?, cidr"; push @vallist, $newblock; # if we have an IP pool, call initPool to fill in any missing entries in the pool if ($binfo->{type} =~ /^.p$/) { my ($code,$rmsg) = initPool($dbh, "$newblock", $binfo->{type}, $binfo->{city}, 'all', $args{block}); die $rmsg if $code eq 'FAIL'; } elsif ($binfo->{type} =~ /^.d$/) { my ($code,$rmsg) = initPool($dbh, "$newblock", $binfo->{type}, $binfo->{city}, 'normal', $args{block}); die $rmsg if $code eq 'FAIL'; } } # append another SQL fragment push @vallist, $args{block}; $sql .= " = ? WHERE $keyfield = ?"; # 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, ($binfo->{block}) ); $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($binfo->{block}, $args{node}) ) if $args{node} ne '--'; } $dbh->commit; }; if ($@) { my $msg = $@; $dbh->rollback; return ('FAIL', $msg); } # Do RPC rDNS call, if available. # Snag the parent info my $pinfo = getBlockData($dbh, $binfo->{parent_id}); # Return early if rDNS flag(s) are not set return ('OK','OK') unless ($pinfo->{revavail} || $pinfo->{revpartial}); # In case of any container (mainly master block), only update freeblocks so we don't stomp subs # (which would be the wrong thing in pretty much any case except "DELETE ALL EVARYTHING!!1!oneone!") if ($binfo->{type} =~ '.[mc]') { # Not using listFree() as it doesn't return quite all of the blocks wanted. # Retrieve the immediate free blocks my $sth = $dbh->prepare(q( SELECT cidr FROM freeblocks WHERE parent_id = ? UNION SELECT cidr FROM freeblocks f WHERE cidr = (SELECT cidr FROM allocations a WHERE f.cidr = a.cidr) AND master_id = ? ) ); $sth->execute($args{block}, $binfo->{master_id}); my %fbset; while (my ($fb) = $sth->fetchrow_array) { $fbset{"host_$fb"} = $args{rdns}; } # We use this RPC call instead of multiple addOrUpdateRevRec calls, since we don't # know how many records we'll be updating and more than 3-4 is far too slow. This # should be safe to call unconditionally. # Requires dnsadmin >= r678 _rpc('updateRevSet', %fbset, rpcuser => $args{user}); } else { $binfo->{block} =~ s|/32$||; _rpc('addOrUpdateRevRec', cidr => $binfo->{block}, name => $args{rdns}, rpcuser => $args{user}); # and the per-IP set, if there is one. _rpc('updateRevSet', %{$args{iprev}}, rpcuser => $args{user}) if keys (%{$args{iprev}}); } ##fixme: RPC failures? return ('OK','OK'); } # end updateBlock() ## IPDB::splitBlock() # Splits an existing allocation into two or more smaller allocations based on a passed netmask # Duplicates all other data # Returns an arrayref to a list of hashrefs with ID and CIDR keys for the list of new allocations. # Should probably commit DNS magic to realign DNS data # Mostly works but may return Strange Things(TM) if used on a master block sub splitBlock { my $dbh = shift; my %args = @_; # my $id = shift; # my $basetype = shift; # my $newmask = shift; ##fixme: set errstr on errors so caller can suitably clue-by-four the user return if $args{basetype} ne 'b'; # only netblocks allowed! my $binfo = getBlockData($dbh, $args{id}); return if !$binfo; return if $args{newmask} !~ /^\d+$/; my @ret; my $block = new NetAddr::IP $binfo->{block}; my $oldmask = $block->masklen; # Fail if the block to split is "too small" - eg, can't split a v4 /32 at all # failure modes: # difference between $oldmask and $newmask is negative or 0 if ($args{newmask} - $oldmask <= 0) { $errstr = "Can't split a /$oldmask allocation into /$args{newmask} pieces"; return; } # # difference between $oldmask and $newmask is > n, for arbitrary n? # if ($newmask - $oldmask > 42) { # because 42 # } # $oldmask > n, for arbitrary n? At least check limits of data type. if ($block->{isv6}) { if ($args{newmask} - $oldmask > 128) { $errstr = "Impossible IPv6 mask length /$args{newmask} requested"; return; } } else { if ($args{newmask} - $oldmask > 32) { $errstr = "Impossible IPv4 mask length /$args{newmask} requested"; return; } } my @newblocks = $block->split($args{newmask}); local $dbh->{AutoCommit} = 0; local $dbh->{RaiseError} = 1; eval { # line up a list of fields and values. Be nice if there was a handy way to do, # direct in SQL, something like # "INSERT INTO foo (f1,f2,f3) VALUES (newf1,(SELECT oldf2,oldf3 FROM foo WHERE baz))" my @fieldlist = qw(type city description notes circuitid privdata custid swip vrf vlan rdns parent_id master_id); my $fields_sql = join(',', @fieldlist); my @vals; foreach (@fieldlist) { push @vals, $binfo->{$_}; } # note the first block in the split for return push @ret, {nid => $args{id}, nblock => "$newblocks[0]"}; # prepare my $idsth = $dbh->prepare("SELECT currval('allocations_id_seq')"); my $allocsth = $dbh->prepare("INSERT INTO allocations (cidr, $fields_sql)". " VALUES (?".',?'x(scalar(@fieldlist)).")"); my $nbsth = $dbh->prepare("DELETE FROM poolips WHERE parent_id = ? AND ip = ?"); my $upd_psth = $dbh->prepare("UPDATE allocations SET parent_id = ? WHERE parent_id = ? AND cidr <<= ?"); my $upd_msth = $dbh->prepare("UPDATE allocations SET master_id = ? WHERE master_id = ? AND cidr <<= ?"); my $fb_psth = $dbh->prepare("UPDATE freeblocks SET parent_id = ? WHERE parent_id = ? AND cidr <<= ?"); my $fb_msth = $dbh->prepare("UPDATE freeblocks SET master_id = ? WHERE master_id = ? AND cidr <<= ?"); my $pool_psth = $dbh->prepare("UPDATE poolips SET parent_id = ? WHERE parent_id = ? AND ip << ?"); my $pool_msth = $dbh->prepare("UPDATE poolips SET master_id = ? WHERE master_id = ? AND ip <<= ?"); # set up update of existing block $dbh->do("UPDATE allocations SET cidr = ? WHERE id = ?", undef, ("$newblocks[0]", $args{id}) ); # axe the new bcast IP from the smaller pool at the "base" block, if it's a "normal" pool if ($binfo->{type} =~ /.d/) { $newblocks[0]--; $nbsth->execute($args{id}, $newblocks[0]->addr); } # Holder for freeblocks-to-delete. Should be impossible to have more than one... my %fbdel; # Loop over the new blocks that are not the base block for (my $i = 1; $i <= $#newblocks; $i++) { # add the new allocation $allocsth->execute($newblocks[$i], @vals); # fetch the ID of the entry we just added... $idsth->execute(); my ($nid) = $idsth->fetchrow_array(); # ... so we can pass back the list of blocks and IDs... push @ret, {nid => $nid, nblock => "$newblocks[$i]"}; # axe the net, gw, and bcast IPs as necessary when splitting a "normal" pool if ($binfo->{type} =~ /.d/) { # net $nbsth->execute($args{id}, $newblocks[$i]->addr); $newblocks[$i]++; # gw $nbsth->execute($args{id}, $newblocks[$i]->addr); $newblocks[$i]--; $newblocks[$i]--; # bcast $nbsth->execute($args{id}, $newblocks[$i]->addr); $newblocks[$i]++; } # $binfo->{type} =~ /.d/ # Check for free blocks larger than the new mask length, and split those as needed. if ($binfo->{type} =~ /.[cm]/) { # get a "list" of freeblocks bigger than the allocation in the parent. there's only one, right? my $fblist = $dbh->selectall_arrayref("SELECT id FROM freeblocks WHERE cidr >> ? AND parent_id = ? ", {Slice=>{}}, $newblocks[$i], $args{id}); if (@$fblist) { # create a new freeblock for the new block we created earlier $dbh->do(q{ INSERT INTO freeblocks (cidr, parent_id, master_id, city, routed,vrf) SELECT ? AS cidr, ? AS parent_id, master_id, city, routed, vrf FROM freeblocks WHERE id = ? }, undef, ($newblocks[$i], $nid, $fblist->[0]->{id}) ); $fbdel{$fblist->[0]->{id}}++; } } # $binfo->{type} =~ /.[cm]/ # Reparent allocations, freeblocks, and pool IPs. $upd_psth->execute($nid, $args{id}, $newblocks[$i]); $fb_psth->execute($nid, $args{id}, $newblocks[$i]); $pool_psth->execute($nid, $args{id}, $newblocks[$i]); # Update master if we've split a master block if ($binfo->{type} eq 'mm') { $upd_msth->execute($nid, $args{id}, $newblocks[$i]); $fb_msth->execute($nid, $args{id}, $newblocks[$i]); $pool_msth->execute($nid, $args{id}, $newblocks[$i]); } ##fixme: # Still missing one edge case - megasplitting a large block such that "many" children also need to be split. # I'm going to call this "unsupported" because I really can't imagine a sane reason for doing this. # Should probably check and error out at least } # for (... @newblocks) $dbh->do("DELETE FROM freeblocks WHERE id IN (".join(',', keys %fbdel).")"); $dbh->commit; }; if ($@) { $errstr = "Error splitting $binfo->{block}: $@"; $dbh->rollback; return; } # Only try to update rDNS when the original block is flagged as "rDNS available" _rpc('splitTemplate', cidr => $binfo->{block}, newmask => $args{newmask}, rpcuser => $args{user}) if ($binfo->{revavail} || $binfo->{revpartial}); return \@ret; } # end splitBlock() ## IPDB::shrinkBlock() # Shrink an allocation to the passed CIDR block # Takes an allocation ID and a new CIDR # Returns an arrayref to a list of hashrefs with the ID and CIDR of the freed block(s) # Refuses to shrink "real netblock" pool types below /30 sub shrinkBlock { my $dbh = shift; my $id = shift; # just take the new CIDR spec; this way we can shrink eg .16/28 to .20/30 without extra contortions my $newblock = new NetAddr::IP shift; my $user = shift; if (!$newblock) { $errstr = "Can't shrink something that's not a netblock"; return; } my $binfo = getBlockData($dbh, $id); my $pinfo = getBlockData($dbh, $binfo->{parent_id}); if ($binfo->{type} =~ /.d/ && $newblock->masklen > ($newblock->bits+2) ) { $errstr = "Can't shrink a non-PPP pool smaller than ".($newblock->{isv6} ? '/124' : '/30'); return; } my $oldblock = new NetAddr::IP $binfo->{block}; # Don't try to shrink the block outside of itself, Bad Things (probably) Happen. if (!$oldblock->contains($newblock)) { $errstr = "Can't shrink an allocation outside of itself"; return; } local $dbh->{AutoCommit} = 0; local $dbh->{RaiseError} = 1; my $addfbsth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)"); my $idsth = $dbh->prepare("SELECT currval('freeblocks_id_seq')"); my $poolsth = $dbh->prepare("DELETE FROM poolips WHERE parent_id = ? AND ip << ?"); my $netsth = $dbh->prepare("DELETE FROM poolips WHERE parent_id = ? AND ip = ?"); my $allocsth = $dbh->prepare("DELETE FROM allocations WHERE parent_id = ? AND cidr <<= ?"); my $delfbsth = $dbh->prepare("DELETE FROM freeblocks WHERE parent_id = ? AND cidr <<= ?"); ##fixme: turn this into a public/top-level sub? sub getchildren { my $dbh = shift; my $id = shift; my $master = shift; my $retlist = shift; # better than trying to return complex structures recursively. Ow. my $cidr = shift; if (!$cidr) { my $bd = getBlockData($dbh, $id); $cidr = $bd->{cidr}; } my $sth = $dbh->prepare(q( SELECT id,cidr,type FROM allocations WHERE parent_id = ? AND master_id = ? AND cidr <<= ? ) ); $sth->execute($id, $master, $cidr); while (my $row = $sth->fetchrow_hashref) { push @$retlist, $row; getchildren($dbh, $row->{id}, $master, $retlist, $cidr); } } my @ret; my @newfreelist; eval { $dbh->do("UPDATE allocations SET cidr = ? WHERE id = ?", undef, $newblock, $id); # find the netblock(s) that are now free my @workingblocks = $oldblock->split($newblock->masklen); foreach my $newsub (@workingblocks) { next if $newsub == $newblock; push @newfreelist, $newsub; } @newfreelist = Compact(@newfreelist); # set new freeblocks, and clean up any IP pool entries if needed. foreach my $newfree (@newfreelist) { my @clist; # the block we're munging push @clist, { id => $id, type => $binfo->{type}, cidr => $binfo->{block} }; getchildren($dbh, $id, $binfo->{master_id}, \@clist, $newfree); foreach my $goner (@clist) { $poolsth->execute($goner->{id}, $newfree) if $goner->{type} =~ /.[dp]/; $allocsth->execute($goner->{id}, $newfree); $delfbsth->execute($goner->{id}, $newfree); } # No pinfo means we're shrinking a master block, which means the free space is returned outside of IPDB. if ($pinfo) { $addfbsth->execute($newfree, $pinfo->{city}, 'm', $pinfo->{vrf}, $binfo->{parent_id}, $pinfo->{master_id}); $idsth->execute; my ($nid) = $idsth->fetchrow_array(); # add to return list push @ret, {fbid => $nid, newfree => "$newfree", fbparent => $binfo->{parent_id} }; } } # $newfree (@newfreelist) # additional cleanup on net/gw/bcast IPs in pool if ($binfo->{type} =~ /.d/) { $netsth->execute($id, $newblock->addr); $newblock++; $netsth->execute($id, $newblock->addr); $newblock--; $newblock--; $netsth->execute($id, $newblock->addr); } $dbh->commit; }; if ($@) { $errstr = "Error splitting $binfo->{block}: $@"; $dbh->rollback; return; } # Only try to update rDNS when the original block is flagged as "rDNS available" _rpc('resizeTemplate', oldcidr => $binfo->{block}, newcidr => $newblock->network, rpcuser => $user) if ($binfo->{revavail} || $binfo->{revpartial}); return \@ret; } # end shrinkBlock() ## IPDB::mergeBlocks() # Merges two or more adjacent allocations, optionally including relevant # free space, into one allocation. # Takes a "base" block ID and a hash with a mask length and a scope argument to decide # how much existing allocation data to delete. # Returns a list starting with the new merged block, then the merged allocations with comment ## Merge scope: # Merge to container # keepall # Move all mergeable allocations into the new block # Move all mergeable free blocks into the new block # mergepeer # Move subs of mergeable containers into the updated primary. # Reparent free blocks in mergeable containers to the updated primary. # Convert assigned IPs from pools into subs. # Convert unused IPs from pools into free blocks. # Convert leaf allocations into free blocks. # clearpeer # Keep subs of the original (if it was a container). # Convert assigned IPs from the original pool into subs (if it was a pool). # Convert unused IPs from the original pool into free blocks (if it was a pool). # Delete all peers and their subs aside from the original. # clearall # Delete all peers, subs and IPs. # Add single free block for new container. # Merge to pool # keepall # Convert all leaf allocations in the merge range to groups of used IPs # mergepeer # Effectively equal to keepall # clearpeer # Only convert IPs from the original allocation to used IPs # clearall # Delete any existing IPs, and reinitialize the new pool entirely # Merge to leaf type # Remove all subs sub mergeBlocks { my $dbh = shift; my $prime = shift; # "base" block ID to use as a starting point if (!$prime) { $errstr = "Missing block ID to base merge on"; return; } my %args = @_; # check key arguments. if (!$args{scope} || $args{scope} !~ /^(keepall|mergepeer|clearpeer|clearall)$/) { $errstr = "Bad or missing merge scope"; return; } if (!$args{newmask} || $args{newmask} !~ /^\d+$/) { $errstr = "Bad or missing new netmask"; return; } # Retrieve info about the base allocation we're munging my $binfo = getBlockData($dbh, $prime); my $block = new NetAddr::IP $binfo->{block}; my ($basetype) = ($binfo->{type} =~ /^.(.)$/); $binfo->{id} = $prime; # preserve for later, just in case # proposed block my $newblock = new NetAddr::IP $block->addr."/$args{newmask}"; $newblock = $newblock->network; $args{newtype} = $binfo->{type} if !$args{newtype}; # if the "primary" block being changed is a master, it must remain one. # Also force the scope, since otherwise things get ugly. if ($binfo->{type} eq 'mm') { $args{newtype} = 'mm'; # don't want to make a peer master a sub of the existing one; too many special cases go explodey, # but want to retain all other allocations $args{scope} = 'mergepeer'; } my ($newcontainerclass) = ($args{newtype} =~ /^(.).$/); # build an info hash for the "new" allocation we're creating my $pinfo = { id => $prime, block => "$newblock", type => $args{newtype}, parent_id => $binfo->{parent_id}, city => $binfo->{city}, vrf => $binfo->{vrf}, master_id => $binfo->{master_id} }; my @retlist; local $dbh->{AutoCommit} = 0; local $dbh->{RaiseError} = 1; # Want to do all of the DB stuff in a transaction, to minimize data changing underfoot eval { # We always update the "prime" block passed in... my $updsth = $dbh->prepare("UPDATE allocations SET cidr = ?, type = ? WHERE id = ?"); ##fixme: There's still an edge case in the return list where some branches accidentally include # the original block as "additional". Probably due to the ordering of when the prepared update # above gets executed. # For leaf blocks, we may need to create a new parent as the "primary" instead # of updating the existing block my $newparent = $dbh->prepare(q{ INSERT INTO allocations ( cidr, type, city, description, notes, circuitid, createstamp, modifystamp, privdata, custid, swip, vrf, vlan, rdns, parent_id, master_id ) SELECT ? AS cidr, ? AS type, city, description, notes, circuitid, createstamp, modifystamp, privdata, custid, swip, vrf, vlan, rdns, parent_id, master_id FROM allocations WHERE id = ? }); # Common actions my $peersth = $dbh->prepare("SELECT cidr,id,type,master_id FROM allocations WHERE parent_id = ? AND cidr <<= ?"); $peersth->execute($binfo->{parent_id}, "$newblock"); my $reparentsth = $dbh->prepare("UPDATE allocations SET parent_id = ?, master_id = ? WHERE id = ?"); my $insfbsth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)"); my $delsth = $dbh->prepare("DELETE FROM allocations WHERE id = ?"); my $fbreparentsth = $dbh->prepare(q{ UPDATE freeblocks SET parent_id = ?, master_id = ?, city = ?, routed = ?, vrf = ? WHERE parent_id = ? AND cidr <<= ? }); if ($args{newtype} =~ /.[cm]/) { ## Container # In case of merging a master block. Somewhat redundant with calls to $fbreparentsth, # but not *quite* entirely. my $mfbsth = $dbh->prepare("UPDATE freeblocks SET master_id = ? WHERE master_id = ?"); if ($args{scope} eq 'keepall') { # Create a new parent with the same info as the passed "primary". $newparent->execute($newblock, $args{newtype}, $prime); # and now retrieve the new parent ID ($prime) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')"); # snag the new parent info for the return list push @retlist, { block => "$newblock", type => $disp_alloctypes{$args{newtype}}, id => $prime }; # Reparent the free blocks in the new block $fbreparentsth->execute($prime, $binfo->{master_id}, $binfo->{city}, $newcontainerclass, $binfo->{vrf}, $binfo->{parent_id}, $newblock); # keep existing allocations (including the original primary), just push them down a level while (my ($peercidr, $peer_id, $peertype, $m_id) = $peersth->fetchrow_array) { $reparentsth->execute($prime, $binfo->{master_id}, $peer_id); # Fix up master_id on free blocks if we're merging a master block $mfbsth->execute($binfo->{master_id}, $m_id) if $peertype eq 'mm'; # capture block for return push @retlist, { block => $peercidr, mdisp => $disp_alloctypes{$peertype}, mtype => $peertype }; } } elsif ($args{scope} =~ /^clear/) { # clearpeer and clearall share a starting point # snag the new parent info for the return list push @retlist, { block => "$newblock", type => $disp_alloctypes{$args{newtype}}, id => $prime }; # update the primary allocation info $updsth->execute($newblock, $args{newtype}, $prime); # Reparent the free blocks in the new block $fbreparentsth->execute($prime, $binfo->{master_id}, $binfo->{city}, $newcontainerclass, $binfo->{vrf}, $binfo->{parent_id}, $newblock); # Insert a free block if $prime is a leaf if ($binfo->{type} =~ /.[enr]/) { $insfbsth->execute($binfo->{block}, $binfo->{city}, $newcontainerclass, $binfo->{vrf}, $prime, $binfo->{master_id}); } # delete the peers. while (my ($peercidr, $peer_id, $peertype, $m_id) = $peersth->fetchrow_array) { next if $peer_id == $prime; # push existing allocations down a level before deleting, # so that when they're deleted the parent info is correct $reparentsth->execute($prime, $binfo->{master_id}, $peer_id); _deleteCascade($dbh, $peer_id); # insert the freeblock _deleteCascade() (deliberately) didn't when deleting a master block. # aren't special cases fun? $dbh->do("INSERT INTO freeblocks (cidr,routed,parent_id,master_id) values (?,?,?,?)", undef, ($peercidr, 'm', $prime, $prime) ) if $binfo->{type} eq 'mm'; # capture block for return push @retlist, { block => $peercidr, mdisp => $disp_alloctypes{$peertype}, mtype => $peertype }; } if ($args{scope} eq 'clearall') { # delete any subs of $prime as well my $substh = $dbh->prepare("SELECT cidr,id FROM allocations WHERE parent_id = ?"); $substh->execute($prime); while (my ($scidr, $s_id) = $substh->fetchrow_array) { _deleteCascade($dbh, $s_id); } } else { # clearpeer if ($basetype =~ /[dp]/) { # Convert active IP pool entries to allocations if the original was an IP pool _poolToAllocations($dbh, $binfo, $pinfo, newtype => $poolmap{$binfo->{type}}); } } # clearall or clearpeer } elsif ($args{scope} eq 'mergepeer') { # should this just be an else? # Default case. Merge "peer" blocks, but keep all suballocations # snag the new parent info for the return list push @retlist, {block => "$newblock", type => $disp_alloctypes{$args{newtype}}, id => $prime}; my $substh = $dbh->prepare("UPDATE allocations SET parent_id = ? WHERE parent_id = ?"); my $delsth = $dbh->prepare("DELETE FROM allocations WHERE id = ?"); # Reparent freeblocks in parent $fbreparentsth->execute($prime, $binfo->{master_id}, $binfo->{city}, $newcontainerclass, $binfo->{vrf}, $binfo->{parent_id}, $newblock); # Loop over "peer" allocations to be merged while (my ($peercidr, $peer_id, $peertype, $m_id) = $peersth->fetchrow_array) { # Snag existing peer data since we may need it my $peerfull = getBlockData($dbh, $peer_id); # Reparent free blocks from existing containers $fbreparentsth->execute($prime, $binfo->{master_id}, $binfo->{city}, $newcontainerclass, $binfo->{vrf}, $peer_id, $newblock); # Reparent any subblocks from existing containers $substh->execute($prime, $peer_id); # Delete the old container $delsth->execute($peer_id) unless $peer_id == $prime; # Add new freeblocks for merged leaf blocks $insfbsth->execute($peercidr, $binfo->{city}, $newcontainerclass, $binfo->{vrf}, $binfo->{id}, $binfo->{master_id}) if $peertype =~ /.[enr]/; # Convert pool IPs into allocations or aggregated free blocks _poolToAllocations($dbh, $peerfull, $pinfo, newparent => $prime) if $peertype =~ /.[dp]/; # Fix up master_id on free blocks if we're merging a master block $mfbsth->execute($binfo->{master_id}, $m_id) if $peertype eq 'mm'; # capture block for return push @retlist, { block => $peercidr, mdisp => $disp_alloctypes{$peertype}, mtype => $peertype }; } # merge peers # update the primary allocation info. Do this last so we don't stomp extra data-retrieval in the loop above $updsth->execute($newblock, $args{newtype}, $prime); } # scope # Clean up free blocks _compactFree($dbh, $prime); } elsif ($args{newtype} =~ /.[dp]/) { ## Pool # Snag the new parent info for the return list push @retlist, { block => "$newblock", type => $disp_alloctypes{$args{newtype}}, id => $prime }; if ($args{scope} eq 'keepall') { # Convert all mergeable allocations and subs to chunks of pool IP assignments push @retlist, @{ _toPool($dbh, $prime, $newblock, $args{newtype}, 1) }; } elsif ($args{scope} =~ /^clear/) { # Clear it all out for a fresh (mostly?) empty IP pool while (my ($peercidr, $peer_id, $peertype, $m_id) = $peersth->fetchrow_array) { next if $peer_id == $prime; # Push existing allocations down a level before deleting, # so that when they're deleted the parent info is correct $reparentsth->execute($prime, $binfo->{master_id}, $peer_id); _deleteCascade($dbh, $peer_id, 0); # Capture block for return push @retlist, { block => $peercidr, mdisp => $disp_alloctypes{$peertype}, mtype => $peertype }; } if ($args{scope} eq 'clearall') { # Delete any subs of $prime as well my $substh = $dbh->prepare("SELECT cidr,id FROM allocations WHERE parent_id = ?"); $substh->execute($prime); while (my ($scidr, $s_id) = $substh->fetchrow_array) { _deleteCascade($dbh, $s_id); } } else { # Convert (subs of) self if not a leaf. push @retlist, @{ _toPool($dbh, $prime, $newblock, $args{newtype}, 1) } unless $binfo->{type} =~ /.[enr]/; } # scope ne 'clearall' } elsif ($args{scope} eq 'mergepeer') { # Try to match behaviour from (target type == container) by deleting immediate peer leaf allocations while (my ($peercidr, $peer_id, $peertype, $m_id) = $peersth->fetchrow_array) { next if $peer_id == $prime; # don't delete the block we're turning into the pool allocation # Capture block for return push @retlist, { block => $peercidr, mdisp => $disp_alloctypes{$peertype}, mtype => $peertype }; next unless $peertype =~ /.[enr]/; # Don't need _deleteCascade(), since we'll just be deleting the freshly # added free block a little later anyway $delsth->execute($peer_id); } # Convert self if not a leaf, to match behaviour with a container type as target _toPool($dbh, $prime, $newblock, $args{newtype}) unless $binfo->{type} =~ /.[enr]/; } # Update the primary allocation info. $updsth->execute($newblock, $args{newtype}, $prime); # Delete any lingering free blocks $dbh->do("DELETE FROM freeblocks WHERE parent_id = ? AND cidr <<= ?", undef, $binfo->{parent_id}, $newblock); # Fix up the rest of the pool IPs my ($code,$msg) = initPool($dbh, $newblock, $args{newtype}, $binfo->{city}, ($args{newtype} =~ /.p/ ? 'all' : 'normal'), $prime); } elsif ($args{newtype} =~ /.[enr]/) { ## Leaf # Merging to a leaf type of any kind is, pretty much be definition, scope == 'clearall'. # keepall, mergepeer, and clearpeer all imply keeping suballocations, where leaf allocations # by definition do not have suballocations. # Update the old allocation $updsth->execute($newblock, $args{newtype}, $prime); # Snag the new parent info for the return list push @retlist, {block => "$newblock", type => $disp_alloctypes{$args{newtype}}, id => $prime}; while (my ($peercidr, $peer_id, $peertype, $m_id) = $peersth->fetchrow_array) { next if $peer_id == $prime; # Push existing allocations down a level before deleting, # so that when they're deleted the parent info is correct $reparentsth->execute($prime, $binfo->{master_id}, $peer_id); _deleteCascade($dbh, $peer_id, 0); # Capture block for return push @retlist, { block => $peercidr, mdisp => $disp_alloctypes{$peertype}, mtype => $peertype }; } # Delete any subs of $prime as well my $substh = $dbh->prepare("SELECT cidr,id FROM allocations WHERE parent_id = ?"); $substh->execute($prime); while (my ($scidr, $s_id) = $substh->fetchrow_array) { _deleteCascade($dbh, $s_id); } # Clean up lingering free blocks and pool IPs $dbh->do("DELETE FROM freeblocks WHERE cidr <<= ? AND (parent_id = ? OR parent_id = ?)", undef, $newblock, $binfo->{parent_id}, $prime); $dbh->do("DELETE FROM poolips WHERE parent_id = ? AND ip <<= ? ", undef, $prime, $newblock); } # $args{newtype} if() $dbh->commit; }; if ($@) { my $msg = $@; $errstr = $msg; $dbh->rollback; return ('FAIL',$msg); } # Make the assumption that any change crossing /24 or /16 boundaries will not come out right. Reverse DNS # updates for this operation are already complex enough without handling those edge cases. # ... er, how do we detect this? # Return early if the block wasn't flagged as rDNS-able return \@retlist unless $binfo->{revavail} || $binfo->{revpartial}; if ($args{newtype} =~ /.[cm]/) { if ($args{scope} eq 'keepall') { # Add new rDNS for new container _rpc('addOrUpdateRevRec', cidr => $binfo->{block}, name => $binfo->{rdns}, rpcuser => $args{user}); } else { # Resize rDNS template for $prime _rpc('resizeTemplate', oldcidr => "$binfo->{block}", newcidr => $newblock->network.'', rpcuser => $args{user}); # Assemble a list of blocks to delete... my $cidrlist; foreach my $mblock (@retlist) { $cidrlist .= $mblock->{block}."," unless $mblock->{block} =~ $newblock; } # ... then make slight variant batch delete calls depending on the merge scope if ($args{scope} eq 'mergepeer') { # Delete separate rDNS for other peers $cidrlist =~ s/,$//; _rpc('delRevSet', cidrlist => $cidrlist, rpcuser => $args{user}, delforward => 'y', delsubs => 'n', parpatt => $pinfo->{rdns}); } elsif ($args{scope} eq 'clearpeer') { # Delete all rDNS within other peers $cidrlist =~ s/,$//; _rpc('delRevSet', cidrlist => $cidrlist, rpcuser => $args{user}, delforward => 'y', delsubs => 'y', parpatt => $pinfo->{rdns}) } elsif ($args{scope} eq 'clearall') { # Delete all other records within the new block $cidrlist .= $binfo->{block}; _rpc('delRevSet', cidrlist => $cidrlist, rpcuser => $args{user}, delforward => 'y', delsubs => 'y', parpatt => $pinfo->{rdns}); } # scope, second level } # scope, !keepall } elsif ($args{newtype} =~ /.[dp]/) { # Merge to pool # Resize rDNS template for $prime _rpc('resizeTemplate', oldcidr => "$binfo->{block}", newcidr => $newblock->network.'', rpcuser => $args{user}); if ($args{scope} eq 'keepall' || $args{scope} eq 'mergepeer') { # Assemble a list of blocks to convert from template to individual records... my @convlist; my @dellist; foreach my $mblock (@retlist) { next if $mblock->{block} =~ $newblock; if ($mblock->{mtype} =~ /.[cmdp]/) { # Container and pool templates get deleted push @dellist, $mblock->{block}; } else { # Not-containers get converted to per-IP reverse records push @convlist, $mblock->{block}; } } # And do the calls. _rpc('delRevSet', cidrlist => join(',', @dellist), rpcuser => $args{user}, delforward => 'y', delsubs => 'n', parpatt => $pinfo->{rdns}); _rpc('templatesToRecords', templates => \@convlist, rpcuser => $args{user}); } # scope eq 'keepall' || 'mergepeer' else { # Assemble a list of blocks to convert from template to individual records... my @convlist; my @dellist; my @fulldellist; # There may be an impossible edge case that can be optimized away in here... foreach my $mblock (@retlist) { my $checkcidr = new NetAddr::IP $mblock->{block}; next if $mblock->{block} =~ $newblock; if (!$block->contains($checkcidr)) { # Blocks not within the original get deleted push @fulldellist, $mblock->{block}; } elsif ($mblock->{mtype} =~ /.[cmdp]/) { # Containers and pools get deleted push @dellist, $mblock->{block}; } else { # Whatever's left over gets converted push @convlist, $mblock->{block}; } } # foreach @retlist # And do the calls. if ($args{scope} eq 'clearpeer') { # Not happy doing this many, but there isn't really a better way. # We delete ALL EVARYTHING in peer blocks... _rpc('delRevSet', cidrlist => join(',', @fulldellist), rpcuser => $args{user}, delforward => 'y', delsubs => 'y', parpatt => $pinfo->{rdns}) if @fulldellist; # ... and just the template for container or pool templates in $prime... _rpc('delRevSet', cidrlist => join(',', @dellist), rpcuser => $args{user}, delforward => 'y', delsubs => 'n', parpatt => $pinfo->{rdns}) if @dellist; # ... and convert a few to record groups _rpc('templatesToRecords', templates => \@convlist, rpcuser => $args{user}) if @convlist; } if ($args{scope} eq 'clearall') { # consider just doing join(',',$newblock->split($newblock->masklen+1))? _rpc('delRevSet', cidrlist => join(',', @fulldellist, @dellist, @convlist, $binfo->{block}), rpcuser => $args{user}, delforward => 'y', delsubs => 'y', parpatt => $pinfo->{rdns}); } } # scope eq 'clearpeer' || 'clearall' } elsif ($args{newtype} =~ /.[enr]/) { # Merge to leaf type # Resize rDNS template for $prime _rpc('resizeTemplate', oldcidr => "$binfo->{block}", newcidr => $newblock->network.'', rpcuser => $args{user}); # Assemble a list of blocks to delete... my $cidrlist; foreach my $mblock (@retlist) { $cidrlist .= $mblock->{block}."," unless $mblock->{block} =~ $newblock; } # Delete all other records within the new block $cidrlist .= $binfo->{block}; _rpc('delRevSet', cidrlist => $cidrlist, rpcuser => $args{user}, delforward => 'y', delsubs => 'y', parpatt => $pinfo->{rdns}); } # type grouping for rDNS calls return \@retlist; } # end mergeBlocks() ## 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,$id,$basetype,$delfwd,$user) = @_; # Collect info about the block we're going to delete my $binfo = getBlockData($dbh, $id, $basetype); my $cidr = new NetAddr::IP $binfo->{block}; # 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; # 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; if ($binfo->{type} =~ /^.i$/) { # 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 my $pinfo; eval { $msg = "Unable to deallocate $disp_alloctypes{$binfo->{type}} $cidr"; $pinfo = getBlockData($dbh, $binfo->{parent_id}, 'b'); ##fixme: VRF and rdepth $dbh->do("UPDATE poolips SET custid = ?, available = 'y',". "city = (SELECT city FROM allocations WHERE id = ?),". "description = '', notes = '', circuitid = '', vrf = ? WHERE id = ?", undef, ($pinfo->{custid}, $binfo->{parent_id}, $pinfo->{vrf}, $id) ); $dbh->commit; }; if ($@) { $msg .= ": $@"; eval { $dbh->rollback; }; return ('FAIL',$msg); } ##fixme: RPC return code? _rpc('delByCIDR', cidr => "$cidr", user => $user, delforward => $delfwd, rpcuser => $user) if ($pinfo->{revavail} || $pinfo->{revpartial}); return ('OK',"OK"); } elsif ($binfo->{type} eq 'mm') { # end alloctype =~ /.i/ # Second case. The block is a full master block ##fixme: VRF limit $msg = "Unable to delete master block $cidr"; eval { $dbh->do("DELETE FROM allocations WHERE cidr <<= ? AND master_id = ?", undef, ($cidr, $binfo->{master_id}) ); $dbh->do("DELETE FROM freeblocks WHERE cidr <<= ? AND master_id = ?", undef, ($cidr, $binfo->{master_id}) ); $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) { # We don't wrap this call tighter, since there isn't an inherent allocation to check for rDNS-ability. if ($rpc_url && !_rpc('delZone', zone => "$subzone", revrec => 'y', rpcuser => $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,$p_id); eval { ##fixme: add recursive flag to allow "YES DAMMIT DELETE ALL EVARYTHING!!1!!" without # explicitly deleting any suballocations of the block to be deleted. # get parent info of the block we're deleting my $pinfo = getBlockData($dbh, $binfo->{parent_id}); $ptype = $pinfo->{type}; $pcity = $pinfo->{city}; $ppatt = $pinfo->{rdns}; $p_id = $binfo->{parent_id}; # Delete the block $dbh->do("DELETE FROM allocations WHERE id = ?", undef, ($id) ); # munge the parent type a little $ptype = (split //, $ptype)[1]; ##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 # check to see if any container allocations could be the "true" parent my ($tparent,$tpar_id,$trtype,$tcity); $tpar_id = 0; ##fixme: this is far simpler in the strict VRF case; we "know" that any allocation # contained by a container is a part of the same allocation tree when the VRF fields are equal. # logic: # For each possible container of $cidr # note the parent id # walk the chain up the parents # if we intersect $cidr's current parent, break # if we've intersected $cidr's current parent # set some variables to track that block # break # Set up part of "is it in the middle of a pool?" check my $wuzpool = $dbh->selectrow_hashref("SELECT cidr,parent_id,type,city,custid,id FROM allocations ". "WHERE (type LIKE '_d' OR type LIKE '_p') AND cidr >> ? AND master_id = ?", { Slice => {} }, ($cidr, $binfo->{master_id}) ); ##fixme? # edge cases not handled, or handled badly: # -> $cidr managed to get to be the entirety of an IP pool if ($wuzpool && $wuzpool->{id} != $id) { # we have legacy goo to be purified # going to ignore nested pools; not possible to create them via API and no current legacy data includes any. # for convenience my $poolid = $wuzpool->{id}; my $pool = $wuzpool->{cidr}; my $poolcity = $wuzpool->{city}; my $pooltype = $wuzpool->{type}; my $poolcustid = $wuzpool->{custid}; $retcode = 'WARNPOOL'; $goback = "$poolid,$pool"; # We've already deleted the block, now we have to stuff its IPs into the pool. $pooltype =~ s/[dp]$/i/; # change type to static IP my $sth2 = $dbh->prepare("INSERT INTO poolips (ip,city,type,custid,parent_id) VALUES ". "(?,'$poolcity','$pooltype','$poolcustid',$poolid)"); ##fixme: need to not insert net, gateway, and bcast on "real netblock" pools (DHCPish) # don't insert .0 $sth2->execute($cidr->addr) unless $cidr->addr =~ m|\.0$|; $cidr++; my $bcast = $cidr->broadcast; while ($cidr != $bcast) { $sth2->execute($cidr->addr); $cidr++; } # don't insert .255 $sth2->execute($cidr->addr) unless $cidr->addr =~ m|\.255$|; # Weirdness Happens. $cidr goes read-only somewhere (this is a thing?!?), # causing ->split, ->hostenum, and related methods to explode. O_o # foreach my $ip ($cidr->hostenum) { # $sth2->execute($ip); # } } ## important! # ... or IS IT? # we may have undef'ed $wuzpool above, if the allocation tree $cidr is in doesn't intersect the pool we found #if (!$wuzpool) { else { # Edge case: Block is the same size as more than one parent level. Should be rare. # - mainly master + first routing. Sorting on parent_id hides the problem pretty well, # but it's likely still possible to fail in particularly well-mangled databases. # The ultimate fix for this may be to resurrect the "routing depth" atrocity. :/ # Get all possible (and probably a number of impossible) containers for $cidr $sth = $dbh->prepare("SELECT cidr,parent_id,type,city,id FROM allocations ". "WHERE (type LIKE '_m' OR type LIKE '_c') AND cidr >>= ? AND master_id = ? ". "ORDER BY masklen(cidr) DESC,parent_id DESC"); $sth->execute($cidr, $binfo->{master_id}); # Quickly get certain fields (simpler than getBlockData() my $sth2 = $dbh->prepare("SELECT cidr,parent_id,type,city FROM allocations ". "WHERE (type LIKE '_m' OR type LIKE '_c') AND id = ? AND master_id = ?"); # For each possible container of $cidr... while (my @data = $sth->fetchrow_array) { my $i = 0; # Save some state and set a start point - parent ID of container we're checking $tparent = $data[0]; my $ppid = $data[1]; $trtype = $data[2]; $tcity = $data[3]; $tpar_id = $data[4]; last if $data[4] == $binfo->{parent_id}; # Preemptively break if we're already in the right place last if $ppid == $binfo->{parent_id}; # ... or if the parent of the container is the block's parent while (1) { # Retrieve bits on that parent ID $sth2->execute($ppid, $binfo->{master_id}); my @container = $sth2->fetchrow_array; $ppid = $container[1]; last if $container[1] == 0; # Break if we've hit a master block last if $ppid == $binfo->{parent_id}; # Break if we've reached the block $cidr is currently in } last if $ppid == $binfo->{parent_id}; } # found an alternate parent; reset some parent-info bits if ($tpar_id != $binfo->{parent_id}) { $ptype = (split //, $trtype)[1]; $pcity = $tcity; $retcode = 'WARNMERGE'; # may be redundant $p_id = $tpar_id; } $goback = "$p_id,$tparent"; # breadcrumb, currently only used 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 parent_id = ?", undef, ($id) ); } $pinfo = getBlockData($dbh, $p_id); # 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 parent_id = ?, routed = ?, city = ? WHERE parent_id = ?", undef, ($p_id, $ptype, $pcity, $id) ); } else { # ... otherwise, add the freeblock $dbh->do("INSERT INTO freeblocks (cidr, city, routed, parent_id, master_id) VALUES (?,?,?,?,?)", undef, ($cidr, $pcity, $ptype, $p_id, $binfo->{master_id}) ); } # Walk the free blocks in the parent and reduce them to the minimal set of CIDR ranges necessary _compactFree($dbh, $p_id); } # 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); } ##fixme: RPC return code? _rpc('delByCIDR', cidr => "$cidr", rpcuser => $user, delforward => $delfwd, delsubs => 'y', parpatt => $ppatt) if ($binfo->{revavail} || $binfo->{revpartial}); 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 ID or IP to look up and an optional flag to indicate a pool IP lookup # instead of a netblock. # Returns a hashref to the block data sub getBlockData { my $dbh = shift; my $id = shift; my $type = shift || 'b'; # default to netblock for lazy callers # netblocks are in the allocations table; pool IPs are in the poolips table. # If we try to look up a CIDR in an integer field we should just get back nothing. my ($btype) = $dbh->selectrow_array("SELECT type FROM allocations WHERE id=?", undef, ($id) ); # Note city, vrf, parent_id and master_id removed due to JOIN uncertainty for block allocations my $commonfields = q(custid, type, circuitid, description, notes, modifystamp AS lastmod, privdata, vlan, rdns); if ($type eq 'i') { my $binfo = $dbh->selectrow_hashref(qq( SELECT p.id, p.ip AS block, p.city, p.vrf, p.parent_id, p.master_id, $commonfields, d.zone >> p.ip AS revavail FROM poolips p LEFT JOIN dnsavail d ON p.master_id = d.parent_alloc AND p.ip << d.zone WHERE id = ? ), undef, ($id) ); return $binfo; } else { my $binfo = $dbh->selectrow_hashref(qq( SELECT a.id, a.cidr AS block, a.city, a.vrf, a.parent_id, a.master_id, swip, $commonfields, f.cidr AS reserve, f.id as reserve_id, d.zone >>= a.cidr AS revavail, d.zone << a.cidr AS revpartial FROM allocations a LEFT JOIN freeblocks f ON a.id=f.reserve_for LEFT JOIN dnsavail d ON a.master_id = d.parent_alloc AND (a.cidr <<= d.zone OR a.cidr >> d.zone) WHERE a.id = ? ), undef, ($id) ); 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 %args = @_; $args{type} = 'b' if !$args{type}; my $cached = 1; # snag entry from database my ($rdns,$rfrom,$pid); if ($args{type} =~ /.i/) { ($rdns, $rfrom, $pid) = $dbh->selectrow_array("SELECT rdns,ip,parent_id FROM poolips WHERE id = ?", undef, ($args{id}) ); } else { ($rdns, $rfrom, $pid) = $dbh->selectrow_array("SELECT rdns,cidr,parent_id FROM allocations WHERE id = ?", undef, ($args{id}) ); } # Can't see a way this could end up empty, for any case I care about. If the caller # doesn't know an allocation ID to request, then they don't know anything else anyway. my $selfblock = $rfrom; my $type; while (!$rdns && $pid) { ($rdns, $rfrom, $pid, $type) = $dbh->selectrow_array( "SELECT rdns,cidr,parent_id,type FROM allocations WHERE id = ?", undef, ($pid) ); last if $type eq 'mm'; # break loops in unfortunate legacy data } # use the actual allocation to check against the DNS utility; we don't want # to always go chasing up the chain to the master... which may (usually won't) # be present directly in DNS anyway my $cidr = new NetAddr::IP $selfblock; 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", ); my $remote_rdns = _rpc('getRevPattern', %rpcargs); if ($remote_rdns) { $rdns = $remote_rdns; $cached = 0; } } # hmm. do we care about where it actually came from? return $rdns, $cached; } # end getBlockRDNS() ## IPDB::getRDNSbyIP() # Get individual reverse entries for the IP or CIDR IP range passed. Sort of looking the # opposite direction down the netblock tree compared to getBlockRDNS() above. sub getRDNSbyIP { my $dbh = shift; my %args = @_; # We want to accept a variety of call types # key arguments: allocation ID, type unless ($args{id} || $args{type}) { $errstr = 'Missing allocation ID or type'; return; } my @ret = (); # special case: single IP. Check if it's an allocation or in a pool, then do the RPC call for fresh data. if ($args{type} =~ /^.i$/) { my ($ip, $localrev) = $dbh->selectrow_array("SELECT ip, rdns FROM poolips WHERE id = ?", undef, ($args{id}) ); push @ret, { 'r_ip' => $ip, 'iphost' => $localrev }; } else { if ($rpc_url) { my %rpcargs = ( rpcuser => $args{user}, group => $revgroup, # not sure how this could sanely be exposed, tbh... cidr => $args{range}, ); my $remote_rdns = _rpc('getRevSet', %rpcargs); return $remote_rdns; # $rdns = $remote_rdns if $remote_rdns; # $cached = 0; } } return \@ret; } # end getRDNSbyIP() ## 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($smtpsender); $mailer->to($recip); $mailer->data("From: \"$org_name IP Database\" <$smtpsender>\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;