source: trunk/cgi-bin/IPDB.pm@ 936

Last change on this file since 936 was 936, checked in by Kris Deugau, 18 months ago

/trunk

Fix bug with block selection for merge; if the expected resulting block is
the same size as the parent of the "starting" block for the merge, the parent
could be mistakenly included in the merge leaving the result orphaned.

Fix minor bug with listSubs() not tagging master blocks as having subblocks
  • Property svn:keywords set to Date Rev Author
File size: 138.6 KB
Line 
1# ipdb/cgi-bin/IPDB.pm
2# Contains functions for IPDB - database access, subnet mangling, block allocation, etc
3###
4# SVN revision info
5# $Date: 2022-12-09 18:38:37 +0000 (Fri, 09 Dec 2022) $
6# SVN revision $Rev: 936 $
7# Last update by $Author: kdeugau $
8###
9# Copyright (C) 2004-2016 - Kris Deugau
10
11package IPDB;
12
13use strict;
14use warnings;
15use Exporter;
16use DBI;
17use Net::SMTP;
18use NetAddr::IP qw(:lower Compact );
19use Frontier::Client;
20use POSIX;
21use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
22
23$VERSION = 3; ##VERSION##
24@ISA = qw(Exporter);
25@EXPORT_OK = qw(
26 %disp_alloctypes %list_alloctypes %def_custids @citylist @poplist
27 %IPDBacl %merge_display %aclmsg %rpcacl $maxfcgi
28 $errstr
29 &initIPDBGlobals &connectDB &finish &checkDBSanity
30 &addVRF &getVRF &deleteVRF &addMaster &touchMaster
31 &listVRF &listSummary &listSubs &listContainers &listAllocations &listForMerge &listFree &listPool
32 &getMasterList &getTypeList &getPoolSelect &findAllocateFrom
33 &ipParent &subParent &blockParent &getBreadCrumbs &getRoutedCity
34 &allocateBlock &updateBlock &splitBlock &shrinkBlock &mergeBlocks &deleteBlock &getBlockData
35 &getBlockRDNS &getRDNSbyIP &getRevID
36 &getNodeList &getNodeName &getNodeInfo
37 &getBlockNotices
38 &mailNotify
39 );
40
41@EXPORT = (); # Export nothing by default.
42%EXPORT_TAGS = ( ALL => [qw(
43 %disp_alloctypes %list_alloctypes %def_custids @citylist @poplist
44 %IPDBacl %merge_display %aclmsg %rpcacl $maxfcgi
45 $errstr
46 &initIPDBGlobals &connectDB &finish &checkDBSanity
47 &addVRF &getVRF &deleteVRF &addMaster &touchMaster
48 &listVRF &listSummary &listSubs &listContainers &listAllocations &listForMerge &listFree &listPool
49 &getMasterList &getTypeList &getPoolSelect &findAllocateFrom
50 &ipParent &subParent &blockParent &getBreadCrumbs &getRoutedCity
51 &allocateBlock &updateBlock &splitBlock &shrinkBlock &mergeBlocks &deleteBlock &getBlockData
52 &getBlockRDNS &getRDNSbyIP &getRevID
53 &getNodeList &getNodeName &getNodeInfo
54 &getBlockNotices
55 &mailNotify
56 )]
57 );
58
59##
60## Global variables
61##
62our %disp_alloctypes;
63our %list_alloctypes;
64our %def_custids;
65our @citylist;
66our @poplist;
67our %IPDBacl;
68
69# Mapping hash for pooltype -> poolip-as-netblock conversions
70my %poolmap = (sd => 'en', cd => 'cn', dp => 'cn', mp => 'cn', wp => 'cn', ld => 'in', ad => 'in', bd => 'in');
71
72# Backup fields, since we iterate over the set regularly
73our @backupfields = qw(brand model type src user vpass epass port ip);
74
75# Friendly display strings for merge scopes
76our %merge_display = (
77 keepall => "Keep mergeable allocations as suballocations of new block",
78 mergepeer => "Keep suballocations of mergeable allocations",
79 clearpeer => "Keep only suballocations of the selected block",
80 clearall => "Clear all suballocations"
81 );
82
83# mapping table for functional-area => error message
84our %aclmsg = (
85 addmaster => 'add a master block',
86 addblock => 'add an allocation',
87 updateblock => 'update a block',
88 delblock => 'delete an allocation',
89 mergeblock => 'merge allocations',
90 );
91
92our %rpcacl;
93our $maxfcgi = 3;
94
95# error reporting
96our $errstr = '';
97
98our $org_name = 'Example Corp';
99our $smtphost = 'smtp.example.com';
100our $domain = 'example.com';
101our $defcustid = '5554242';
102our $smtpsender = 'ipdb@example.com';
103# mostly for rwhois
104##fixme: leave these blank by default?
105our $rwhoisDataPath = '/usr/local/rwhoisd/etc/rwhoisd'; # to match ./configure defaults from rwhoisd-1.5.9.6
106our $org_street = '123 4th Street';
107our $org_city = 'Anytown';
108our $org_prov_state = 'ON';
109our $org_pocode = 'H0H 0H0';
110our $org_country = 'CA';
111our $org_phone = '000-555-1234';
112our $org_techhandle = 'ISP-ARIN-HANDLE';
113our $org_email = 'noc@example.com';
114our $hostmaster = 'dns@example.com';
115
116our $syslog_facility = 'local2';
117
118our $rpc_url = '';
119our $dnsadmin_url; # needs to be modified later
120our $revgroup = 1; # should probably be configurable somewhere
121our $rpccount = 0;
122
123# Largest inverse CIDR mask length to show per-IP rDNS list
124# (eg, NetAddr::IP->bits - NetAddr::IP->masklen)
125our $maxrevlist = 5; # /27
126
127# Display the per-IP rDNS list on all block types even when it might not
128# make sense (typically for IP pools, where the per-IP entries are available
129# from each IP's edit page)
130our $revlistalltypes = 0;
131
132# UI layout for subblocks/containers
133our $sublistlayout = 1;
134
135# UI layout for VRF/master blocks
136our $masterswithvrfs = 2;
137
138# VLAN validation mode. Set to 0 to allow alphanumeric vlan names instead of using the vlan number.
139our $numeric_vlan = 1;
140
141# Billing system return link
142our $billinglink = 'https://billing.example.com/radius.pl';
143
144# Append the default domain on unqualified DNS names?
145our $append_domain = 1;
146
147# Enable link publishing selected IP pool data as a CSV
148# Not enabled by default due to webserver config required
149our $enablecsv = 0;
150
151##
152## Internal utility functions
153##
154
155## IPDB::_rpc
156# Make an RPC call for DNS changes
157sub _rpc {
158 return if !$rpc_url; # Just In Case
159 my $rpcsub = shift;
160 my %args = @_;
161
162 # Make an object to represent the XML-RPC server.
163 my $server = Frontier::Client->new(url => $rpc_url, debug => 0);
164 my $result;
165
166 my %rpcargs = (
167 rpcsystem => 'ipdb',
168# must be provided by caller's caller
169# rpcuser => $args{user},
170 %args,
171 );
172
173 eval {
174 $result = $server->call("dnsdb.$rpcsub", %rpcargs);
175 };
176 if ($@) {
177 $errstr = $@;
178 $errstr =~ s/\s*$//;
179 $errstr =~ s/Fault returned from XML RPC Server, fault code 4: error executing RPC `dnsdb.$rpcsub'\.\s//;
180 }
181 $rpccount++;
182
183 return $result if $result;
184} # end _rpc()
185
186
187## IPDB::_compactFree()
188# Utility sub to compact a set of free block entries down to the minimum possible set of CIDR entries
189# Not to be called outside of an eval{}!
190sub _compactFree {
191 my $dbh = shift;
192 my $parent = shift;
193
194 # Rather than having the caller provide all the details
195 my $pinfo = getBlockData($dbh, $parent);
196 my $ftype = (split //, $pinfo->{type})[0];
197
198# NetAddr::IP->compact() attempts to produce the smallest inclusive block
199# from the caller and the passed terms.
200# EG: if you call $cidr->compact($ip1,$ip2,$ip3) when $cidr, $ip1, $ip2,
201# and $ip3 are consecutive /27's starting on .0 (.0-.31, .32-.63,
202# .64-.95, and .96-.128), you will get an array containing a single
203# /25 as element 0 (.0-.127). Order is not important; you could have
204# $cidr=.32/27, $ip1=.96/27, $ip2=.0/27, and $ip3=.64/27.
205
206##fixme: vrf
207##fixme: simplify since all containers now represent different "layers"/"levels"?
208
209 # set up the query to get the list of blocks to try to merge.
210 my $sth = $dbh->prepare(q{
211 SELECT cidr,id FROM freeblocks
212 WHERE parent_id = ?
213 ORDER BY masklen(cidr) DESC
214 });
215 $sth->execute($parent);
216
217 my (@rawfb, @combinelist, %rawid);
218 my $i=0;
219 # for each free block under $parent, push a NetAddr::IP object into one list, and
220 # continuously use NetAddr::IP->compact to automagically merge netblocks as possible.
221 while (my ($fcidr, $fid) = $sth->fetchrow_array) {
222 my $testIP = new NetAddr::IP $fcidr;
223 push @rawfb, $testIP;
224 $rawid{"$testIP"} = $fid; # $data[0] vs "$testIP" *does* make a difference for v6
225 @combinelist = $testIP->compact(@combinelist);
226 }
227
228 # now that we have the full list of "compacted" freeblocks, go back over
229 # the list of raw freeblocks, and delete the ones that got merged.
230 $sth = $dbh->prepare("DELETE FROM freeblocks WHERE id = ?");
231 foreach my $rawfree (@rawfb) {
232 next if grep { $rawfree == $_ } @combinelist; # skip if the raw block is in the compacted list
233 $sth->execute($rawid{$rawfree});
234 }
235
236 # now we walk the new list of compacted blocks, and see which ones we need to insert
237 $sth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)");
238 foreach my $cme (@combinelist) {
239 next if grep { $cme == $_ } @rawfb; # skip if the combined block was in the raw list
240 $sth->execute($cme, $pinfo->{city}, $ftype, $pinfo->{vrf}, $parent, $pinfo->{master_id});
241 }
242
243} # end _compactFree()
244
245
246## IPDB::_toPool()
247# Convert an allocation or allocation tree to entries in an IP pool
248# Assumes an incomplete/empty pool
249# Takes a parent ID for the pool, CIDR range descriptor for the allocation(s) to convert, and the pool type
250sub _toPool {
251 my $dbh = shift;
252 my $poolparent = shift;
253 my $convblock = shift; # May be smaller than the block referenced by $poolparent
254 my $pooltype = shift;
255 my $retall = shift || 0;
256
257 # there is probably a way to avoid the temporary $foo here
258 my $foo = $dbh->selectall_arrayref("SELECT master_id,parent_id FROM allocations WHERE id = ?", undef, $poolparent);
259 my ($master,$mainparent) = @{$foo->[0]};
260
261 my @retlist;
262
263 my $iptype = $pooltype;
264 $iptype =~ s/[pd]$/i/;
265 my $poolclass = (split //, $iptype)[0];
266
267 my $cidrpool = new NetAddr::IP $convblock;
268
269 my $asth = $dbh->prepare(q{
270 SELECT id, cidr, type, parent_id, city, description, notes, circuitid,
271 createstamp, modifystamp, privdata, custid, vrf, vlan, rdns
272 FROM allocations
273 WHERE cidr <<= ? AND master_id = ?
274 ORDER BY masklen(cidr) DESC
275 });
276 my $inssth = $dbh->prepare(q{
277 INSERT INTO poolips (
278 ip,type,parent_id,master_id,available,
279 city,description,notes,circuitid,createstamp,modifystamp,privdata,custid,vrf,vlan,rdns
280 )
281 VALUES (?,?,?,?,'n',?,?,?,?,?,?,?,?,?,?,?)
282 });
283 my $updsth = $dbh->prepare("UPDATE poolips SET parent_id = ?, type = ? WHERE parent_id = ?");
284 my $delsth = $dbh->prepare("DELETE FROM allocations WHERE id = ?");
285 my $fbdelsth = $dbh->prepare("DELETE FROM freeblocks WHERE parent_id = ?");
286
287 $asth->execute($convblock, $master);
288 my %poolcounter;
289 while (my ($oldid, $oldcidr, $oldtype, $oldparent, @oldalloc) = $asth->fetchrow_array) {
290 # don't merge the parent of the allocation selected for merge.
291 # if you really want to go there, start the merge *from* that parent.
292 next if $oldid == $mainparent;
293 if ($oldtype =~ /.[enr]/) {
294 # Convert leaf allocations to block of pool IP assignments
295 my $tmpcidr = new NetAddr::IP $oldcidr;
296 my $newtype = $poolclass.'i';
297 # set up the gateway IP in case we need it
298 my $gw = $cidrpool+1;
299 foreach my $newip ($tmpcidr->split(32)) {
300 my $baseip = $newip->addr;
301 # skip .0 and .255, they are prefectly legitimate but some systems behave
302 # poorly talking to a client using them.
303 next if $baseip =~ /\.(?:0|255)$/;
304 # skip the network, broadcast, and gateway IPs if we're creating a "normal netblock" pool
305 if ($pooltype =~ /d$/) {
306 next if $newip->addr eq $cidrpool->network->addr;
307 next if $newip->addr eq $cidrpool->broadcast->addr;
308 next if $newip->addr eq $gw->addr;
309 }
310 $inssth->execute($newip, $newtype, $poolparent, $master, @oldalloc) if !$poolcounter{"$newip"};
311 $poolcounter{"$newip"}++;
312 }
313 } elsif ($oldtype =~ /.[dp]/) {
314 # Reparent IPs in an existing pool, and rewrite their type
315 $updsth->execute($poolparent, $poolclass.'i', $oldid);
316 } else {
317 # Containers are mostly "not interesting" in this context since they're
318 # equivalent to the pool allocation on .[dp] types. Clean up the lingering free block(s).
319 $fbdelsth->execute($oldid);
320 }
321 # Clean up - remove the converted block unless it is the "primary"
322 $delsth->execute($oldid) unless $oldid == $poolparent;
323 # Return the converted blocks, but only the immediate peers, not the entire tree
324 push @retlist, { block => $oldcidr, mdisp => $disp_alloctypes{$oldtype}, mtype => $oldtype }
325 if (($oldparent == $mainparent) || $retall) && $oldid != $poolparent;
326 } # while $asth->fetch
327
328 return \@retlist;
329} # end _toPool()
330
331
332## IPDB::_poolToAllocations
333# Convert pool IPs into allocations, and free IPs into free blocks
334# Takes a pool ID, original pool CIDR (in case the allocation has been updated before the call here)
335# and hashref to data for the new parent container for the IPs,
336# and an optional hash with the new parent ID and allocation type
337sub _poolToAllocations {
338 my $dbh = shift;
339 my $oldpool = shift;
340 my $parentinfo = shift;
341 my %args = @_;
342
343 # Default to converting the pool to a container
344 $args{newparent} = $oldpool->{id} if !$args{newparent};
345
346 my ($containerclass) = ($parentinfo->{type} =~ /(.)./);
347
348 # Default type mapping
349 $args{newtype} = $poolmap{$oldpool->{type}} if !$args{newtype};
350
351 # Convert a bunch of pool IP allocations into "normal" netblock allocations
352 my $pool2alloc = $dbh->prepare(q{
353 INSERT INTO allocations (
354 cidr,type,city, description, notes, circuitid, createstamp, modifystamp,
355 privdata, custid, vrf, vlan, rdns, parent_id, master_id
356 )
357 SELECT
358 ip, ? AS type, city, description, notes, circuitid, createstamp, modifystamp,
359 privdata, custid, vrf, vlan, rdns, ? AS parent_id, master_id
360 FROM poolips
361 WHERE parent_id = ? AND available = 'n'
362 });
363 $pool2alloc->execute($args{newtype}, $args{newparent}, $oldpool->{id});
364
365 # Snag the whole list of pool IPs
366 my @freeips = @{$dbh->selectall_arrayref("SELECT ip,available FROM poolips WHERE parent_id = ?",
367 undef, $oldpool->{id})};
368 my @iplist;
369 my %usedips;
370 # Filter out the ones that were used...
371 foreach my $ip (@freeips) {
372 $$ip[0] =~ s{/32$}{};
373 push @iplist, NetAddr::IP->new($$ip[0]) if $$ip[1] eq 'y';
374 $usedips{$$ip[0]}++ if $$ip[1] eq 'n';
375 }
376 # ... so that we can properly decide whether the net, gw, and bcast IPs need to be added to the free list.
377 my $tmpblock = new NetAddr::IP $oldpool->{block};
378 push @iplist, NetAddr::IP->new($tmpblock->network->addr)
379 if !$usedips{$tmpblock->network->addr} || $tmpblock->network->addr =~ /\.0$/;
380 push @iplist, NetAddr::IP->new($tmpblock->broadcast->addr)
381 if !$usedips{$tmpblock->broadcast->addr} || $tmpblock->broadcast->addr =~ /\.255$/;
382 # only "DHCP"-ish pools have a gw ip removed from the pool
383 if ($oldpool->{type} =~ /.d/) {
384 $tmpblock++;
385 push @iplist, NetAddr::IP->new($tmpblock->addr);
386 }
387
388 # take the list of /32 IPs, and see what CIDR ranges we get back as free, then insert them.
389 @iplist = Compact(@iplist);
390 my $insfbsth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)");
391 foreach (@iplist) {
392 $insfbsth->execute($_, $parentinfo->{city}, $containerclass, $parentinfo->{vrf},
393 $args{newparent}, $parentinfo->{master_id});
394 }
395
396 # and finally delete the poolips entries
397 $dbh->do("DELETE FROM poolips WHERE parent_id = ?", undef, $oldpool->{id});
398
399} # end _poolToAllocations()
400
401
402## IPDB::_deleteCascade()
403# Internal sub. Deletes an allocation and all subcomponents
404sub _deleteCascade {
405 my $dbh = shift;
406 my $id = shift;
407 my $createfb = shift; # may be null at this point
408
409 my $binfo = getBlockData($dbh, $id);
410
411 # Decide if we're going to add a free block.
412
413 # Caller is normal block delete -> add freeblock under $binfo->{parent_id} -> pass nothing
414 # Caller is delete for merge to leaf -> do not add freeblock -> pass 0
415 # Caller is normal master delete -> do not add freeblock -> pass nothing
416 # Caller is merge master -> add freeblock under alternate parent -> pass parent ID
417 if ($binfo->{type} ne 'mm') {
418 # Deleting a non-master block
419 if (!defined($createfb)) {
420 # No createfb flag passed; assuming normal block delete. Add the freeblock
421 # under the parent of the block we're deleting.
422 $createfb = $binfo->{parent_id};
423 #} else {
424 # Don't need to actually do anything here. The caller has given us an ID,
425 # which is either 0 (causing no free block) or (theoretically) a valid block
426 # ID to add the free block under.
427 }
428 #} else {
429 # Deleting a master block
430 # Don't need to actually do anything here. If the caller passed a parent ID,
431 # that parent will get the new free block. if the caller didn't pass anything,
432 # no free block will be added.
433 }
434
435##fixme: special-case master blocks up here and quickly delete based on master_id,
436# instead of wasting time tracing parent relations
437
438 # grab all allocations in the master within the CIDR of the block to be deleted
439 my %parents;
440 my %cidrlist;
441##fixme: limit by VRF?
442 my $sth = $dbh->prepare("SELECT cidr,id,parent_id FROM allocations WHERE cidr <<= ? AND master_id = ?");
443 $sth->execute($binfo->{block}, $binfo->{master_id});
444 while (my ($cidr, $cid, $pid) = $sth->fetchrow_array) {
445 $parents{$cid} = $pid;
446 $cidrlist{$cid} = $cidr;
447 }
448
449 # Trace the parent relations up the tree until we either hit parent ID 0 (we've found a master block
450 # but not the parent we're looking for - arguably this is already an error) or the parent ID matches
451 # the passed ID. If the latter, push the whole set into a second flag hash, so we can terminate
452 # further tree-tracing early.
453 my %found;
454 foreach my $cid (keys %parents) {
455 my @tmp;
456 if ($cid == $id) {
457 # "child" is the ID we've been asked to cascade-delete.
458 $found{$cid}++;
459 } elsif ($found{$cid}) {
460 # ID already seen and the chain terminates in our parent.
461 } elsif ($parents{$cid} == $id) {
462 # Immediate parent is the target parent
463 $found{$cid}++;
464 } else {
465 # Immediate parent isn't the one we're looking for. Walk the chain up until we hit our parent,
466 # the nonexistent parent id 0, or undefined (ID is not a child of the target ID at all)
467 # There are probably better ways to structure this loop.
468 while (1) {
469 # cache the ID
470 push @tmp, $cid;
471 # some very particularly defined loop ending conditions
472 if (!defined($parents{$cid}) || $parents{$cid} == $id || $parents{$cid} == 0) {
473 last;
474 } else {
475 # if we haven't found either the desired parent or another limiting condition,
476 # reset the ID to the parent next up the tree
477 $cid = $parents{$cid};
478 }
479 }
480 # if the current chain of relations ended with our target parent, shuffle the cached IDs into a flag hash
481 if (defined($parents{$cid}) && $parents{$cid} == $id) {
482 foreach (@tmp) { $found{$_}++; }
483 }
484 } # else
485 } # foreach my $cid
486
487 # Use the keys in the flag hash to determine which allocations to actually delete.
488 # Delete matching freeblocks and pool IPs; their parents are going away so we want
489 # to make sure we don't leave orphaned records lying around loose.
490 my @dellist = keys %found;
491 push @dellist, $id; # Just In Case the target ID didn't make the list earlier.
492 my $b = '?'. (',?' x $#dellist);
493 $dbh->do("DELETE FROM allocations WHERE id IN ($b)", undef, (@dellist) );
494 $dbh->do("DELETE FROM freeblocks WHERE parent_id IN ($b)", undef, (@dellist) );
495 $dbh->do("DELETE FROM poolips WHERE parent_id IN ($b)", undef, (@dellist) );
496
497 # Insert a new free block if needed
498 if ($createfb) {
499 my $pinfo = getBlockData($dbh, $createfb);
500 my $pt = (split //, $pinfo->{type})[1];
501 $dbh->do("INSERT INTO freeblocks (cidr,city,routed,parent_id,vrf,master_id) VALUES (?,?,?,?,?,?)", undef,
502 $binfo->{block}, $pinfo->{city}, $pt, $createfb, $pinfo->{vrf}, $binfo->{master_id});
503 }
504
505##todo: and hey! bonus! we can return @dellist, or something (%cidrlist{@dellist})
506
507} # end _deleteCascade()
508
509
510## IPDB::_getChildren()
511# Recursive sub to retrieve a flat list of suballocations
512# Takes the root parent ID, master ID, reference to push results into, and the CIDR
513# range to restrict results to
514sub _getChildren {
515 my $dbh = shift;
516 my $id = shift;
517 my $master = shift;
518 my $retlist = shift; # better than trying to return complex structures recursively. Ow.
519 my $cidr = shift;
520
521 if (!$cidr) {
522 my $bd = getBlockData($dbh, $id);
523 $cidr = $bd->{cidr};
524 }
525
526 my $sth = $dbh->prepare(q(
527 SELECT id,cidr,type FROM allocations
528 WHERE parent_id = ? AND master_id = ? AND cidr <<= ?
529 ) );
530 $sth->execute($id, $master, $cidr);
531 while (my $row = $sth->fetchrow_hashref) {
532 push @$retlist, $row;
533 _getChildren($dbh, $row->{id}, $master, $retlist, $cidr);
534 }
535} # end _getChildren()
536
537
538##
539## Public subs
540##
541
542
543## IPDB::initIPDBGlobals()
544# Initialize all globals. Takes a database handle, returns a success or error code
545sub initIPDBGlobals {
546 my $dbh = $_[0];
547 my $sth;
548
549 # Initialize alloctypes hashes
550 $sth = $dbh->prepare("select type,listname,dispname,listorder,def_custid from alloctypes order by listorder");
551 $sth->execute;
552 while (my @data = $sth->fetchrow_array) {
553 $disp_alloctypes{$data[0]} = $data[2];
554 $def_custids{$data[0]} = $data[4];
555 if ($data[3] < 900) {
556 $list_alloctypes{$data[0]} = $data[1];
557 }
558 }
559
560 # City and POP listings
561 $sth = $dbh->prepare("select city,routing from cities order by city");
562 $sth->execute;
563 return (undef,$sth->errstr) if $sth->err;
564 while (my @data = $sth->fetchrow_array) {
565 push @citylist, $data[0];
566 if ($data[1] eq 'y') {
567 push @poplist, $data[0];
568 }
569 }
570
571 # Load ACL data. Specific username checks are done at a different level.
572 $sth = $dbh->prepare("select username,acl from users");
573 $sth->execute;
574 return (undef,$sth->errstr) if $sth->err;
575 while (my @data = $sth->fetchrow_array) {
576 $IPDBacl{$data[0]} = $data[1];
577 }
578
579##fixme: initialize HTML::Template env var for template path
580# something like $self->path().'/templates' ?
581# $ENV{HTML_TEMPLATE_ROOT} = 'foo/bar';
582
583 # fix up DNSAdmin remote link based on RPC URL
584 if ($rpc_url) {
585 ($dnsadmin_url = $rpc_url) =~ s{/dns-rpc\.f?cgi}{};
586 }
587
588 return (1,"OK");
589} # end initIPDBGlobals
590
591
592## IPDB::connectDB()
593# Creates connection to IPDB.
594# Requires the database name, username, and password.
595# Returns a handle to the db.
596# Set up for a PostgreSQL db; could be any transactional DBMS with the
597# right changes.
598sub connectDB {
599 my $dbname = shift;
600 my $user = shift;
601 my $pass = shift;
602 my $dbhost = shift;
603
604 my $dbh;
605 my $DSN = "DBI:Pg:".($dbhost ? "host=$dbhost;" : '')."dbname=$dbname";
606
607# Note that we want to autocommit by default, and we will turn it off locally as necessary.
608# We may not want to print gobbledygook errors; YMMV. Have to ponder that further.
609 $dbh = DBI->connect($DSN, $user, $pass, {
610 AutoCommit => 1,
611 PrintError => 0
612 })
613 or return (undef, $DBI::errstr) if(!$dbh);
614
615# Return here if we can't select. Note that this indicates a
616# problem executing the select.
617 my $sth = $dbh->prepare("select type from alloctypes");
618 $sth->execute();
619 return (undef,$DBI::errstr) if ($sth->err);
620
621# See if the select returned anything (or null data). This should
622# succeed if the select executed, but...
623 $sth->fetchrow();
624 return (undef,$DBI::errstr) if ($sth->err);
625
626# If we get here, we should be OK.
627 return ($dbh,"DB connection OK");
628} # end connectDB
629
630
631## IPDB::finish()
632# Cleans up after database handles and so on.
633# Requires a database handle
634sub finish {
635 my $dbh = $_[0];
636 $dbh->disconnect if $dbh;
637} # end finish
638
639
640## IPDB::checkDBSanity()
641# Quick check to see if the db is responding. A full integrity
642# check will have to be a separate tool to walk the IP allocation trees.
643sub checkDBSanity {
644 my ($dbh) = $_[0];
645
646 if (!$dbh) {
647 print "No database handle, or connection has been closed.";
648 return -1;
649 } else {
650 # it connects, try a stmt.
651 my $sth = $dbh->prepare("select type from alloctypes");
652 my $err = $sth->execute();
653
654 if ($sth->fetchrow()) {
655 # all is well.
656 return 1;
657 } else {
658 print "Connected to the database, but could not execute test statement. ".$sth->errstr();
659 return -1;
660 }
661 }
662 # Clean up after ourselves.
663# $dbh->disconnect;
664} # end checkDBSanity
665
666
667## IPDB::addVRF()
668#
669sub addVRF {
670 my $dbh = shift;
671 my $newvrf = shift;
672 my %args = @_;
673
674 $args{comment} = '' if !$args{comment};
675 $args{location} = '' if !$args{location};
676
677 # Allow transactions, and raise an exception on errors so we can catch it later.
678 # Use local to make sure these get "reset" properly on exiting this block
679 local $dbh->{AutoCommit} = 0;
680 local $dbh->{RaiseError} = 1;
681
682 eval {
683 # Check if the VRF exists. Arguably should check for "looks similar", but that gets ugly fast.
684 my $vrfex = $dbh->selectrow_array("SELECT vrf FROM vrfs WHERE vrf=?", undef, $newvrf);
685 die "VRF already exists!\n" if $vrfex;
686
687 # Nothing there yet, so we can insert the new VRF
688 $dbh->do("INSERT INTO vrfs (vrf,comment,location) VALUES (?,?,?)", undef,
689 $newvrf, $args{comment}, $args{location});
690
691 $dbh->commit;
692 };
693 if ($@) {
694 my $msg = $@;
695 eval { $dbh->rollback; };
696 return ('FAIL',$msg);
697 }
698 return ('OK',$newvrf);
699} # end addVRF()
700
701
702## IPDB::getVRF()
703# Retrieve additional fields from DB for a VRF
704sub getVRF {
705 my $dbh = shift;
706 my $vrf = shift;
707
708 return $dbh->selectrow_hashref("SELECT comment,location FROM vrfs WHERE vrf = ?", {Slice=>{}}, $vrf);
709} # end getVRF()
710
711
712## IPDB::deleteVRF()
713#
714sub deleteVRF {
715 my $dbh = shift;
716 my $vrf = shift;
717
718 # Allow transactions, and raise an exception on errors so we can catch it later.
719 # Use local to make sure these get "reset" properly on exiting this block
720 local $dbh->{AutoCommit} = 0;
721 local $dbh->{RaiseError} = 1;
722
723 eval {
724 $dbh->do("DELETE FROM vrfs WHERE vrf = ?", undef, $vrf);
725 $dbh->commit;
726 };
727 if ($@) {
728 my $msg = $@; # not much complexity here just yet.
729 return ('FAIL',$msg);
730 }
731
732 return ('OK','OK');
733} # end deleteVRF()
734
735
736## IPDB::addMaster()
737# Does all the magic necessary to sucessfully add a master block
738# Requires database handle, block to add
739# Returns failure code and error message or success code and "message"
740sub addMaster {
741 my $dbh = shift;
742 # warning! during testing, this somehow generated a "Bad file descriptor" error. O_o
743 my $ctext = shift;
744 my $cidr = new NetAddr::IP $ctext;
745
746 return ('FAIL',"$ctext is not a valid CIDR address") if !$cidr;
747
748 my %args = @_;
749
750 $args{vrf} = '' if !$args{vrf};
751 $args{rdns} = '' if !$args{rdns};
752 $args{defloc} = '' if !$args{defloc};
753 $args{rwhois} = 'n' if !$args{rwhois}; # fail "safe", sort of.
754 $args{rwhois} = 'n' if $args{rwhois} ne 'n' and $args{rwhois} ne 'y';
755
756 my $mid;
757
758 # Allow transactions, and raise an exception on errors so we can catch it later.
759 # Use local to make sure these get "reset" properly on exiting this block
760 local $dbh->{AutoCommit} = 0;
761 local $dbh->{RaiseError} = 1;
762
763 # Wrap all the SQL in a transaction
764 eval {
765 # First check - does the master exist in this VRF?
766 my ($mcontained) = $dbh->selectrow_array("SELECT cidr FROM allocations WHERE cidr >>= ? AND type = 'mm' AND vrf = ?",
767 undef, ($cidr, $args{vrf}) );
768 die "Master block $mcontained already exists and entirely contains $cidr\n"
769 if $mcontained;
770
771 # Second check - does the new master contain an existing one or ones?
772 my ($mexist) = $dbh->selectrow_array("SELECT cidr FROM allocations WHERE cidr <<= ? AND type = 'mm' AND vrf = ?",
773 undef, ($cidr, $args{vrf}) );
774
775 if (!$mexist) {
776 # First case - master is brand-spanking-new.
777##fixme: rwhois should be globally-flagable somewhere, much like a number of other things
778## maybe a db table called "config"?
779 $dbh->do("INSERT INTO allocations (cidr,type,swip,vrf,rdns) VALUES (?,?,?,?,?)", undef,
780 ($cidr, 'mm', 'y', $args{vrf}, $args{rdns}) );
781 ($mid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
782
783# Unrouted blocks aren't associated with a city (yet). We don't rely on this
784# elsewhere though; legacy data may have traps and pitfalls in it to break this.
785# Thus the "routed" flag.
786 $dbh->do("INSERT INTO freeblocks (cidr,city,routed,parent_id,vrf,master_id) VALUES (?,?,?,?,?,?)", undef,
787 ($cidr, '<NULL>', 'm', $mid, $args{vrf}, $mid) );
788
789 # master should be its own master, so deletes directly at the master level work
790 $dbh->do("UPDATE allocations SET master_id = ? WHERE id = ?", undef, ($mid, $mid) );
791
792 # If we get here, everything is happy. Commit changes.
793 $dbh->commit;
794
795 } # done new master does not contain existing master(s)
796 else {
797
798 # insert the new master
799 $dbh->do("INSERT INTO allocations (cidr,type,swip,vrf,rdns) VALUES (?,?,?,?,?)", undef,
800 ($cidr, 'mm', 'y', $args{vrf}, $args{rdns}) );
801 ($mid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
802
803 # master should be its own master, so deletes directly at the master level work
804 $dbh->do("UPDATE allocations SET master_id = ? WHERE id = ?", undef, ($mid, $mid) );
805
806 # collect the master(s) we're going to absorb, and snag the longest netmask while we're at it.
807# note << is accurate and complete because our first check just into the eval is "is the new master
808# entirely contained or equal to an existing one?" - so, by definition, if it's not contained, and
809# it's not equal, it's larger. this also lets us insert the new master without picking it up again here.
810 my $smallmask = $cidr->masklen;
811 my $sth = $dbh->prepare("SELECT cidr,id FROM allocations WHERE cidr << ? AND type = 'mm' AND parent_id = 0 AND vrf = ? ");
812 $sth->execute($cidr, $args{vrf});
813 my @cmasters;
814 my @oldmids;
815 while (my @data = $sth->fetchrow_array) {
816 my $master = new NetAddr::IP $data[0];
817 push @cmasters, $master;
818 push @oldmids, $data[1];
819 $smallmask = $master->masklen if $master->masklen > $smallmask;
820 }
821
822 # update existing DNS refs. do this unconditionally Just In Case
823 $dbh->do("UPDATE dnsavail SET parent_alloc = ? WHERE zone << ?".
824 " AND parent_alloc IN (".join(',', @oldmids).")",
825 undef, $mid, $cidr);
826
827 # split the new master, and keep only those blocks not part of an existing master
828 my @blocklist;
829 foreach my $seg ($cidr->split($smallmask)) {
830 my $contained = 0;
831 foreach my $master (@cmasters) {
832 $contained = 1 if $master->contains($seg);
833 }
834 push @blocklist, $seg if !$contained;
835 }
836
837##fixme: master_id
838 # collect the unrouted free blocks within the new master
839 $sth = $dbh->prepare("SELECT cidr FROM freeblocks WHERE masklen(cidr) <= ? AND cidr <<= ? AND routed = 'm' AND master_id IN (".join(',',@oldmids).")");
840 $sth->execute($smallmask, $cidr);
841 while (my @data = $sth->fetchrow_array) {
842 my $freeblock = new NetAddr::IP $data[0];
843 push @blocklist, $freeblock;
844 }
845
846 # combine the set of free blocks we should have now.
847 @blocklist = Compact(@blocklist);
848
849 # delete freeblocks that have been absorbed. this is probably rare.
850 $sth = $dbh->prepare("DELETE FROM freeblocks WHERE cidr <<= ? AND parent_id IN (".join(',', @oldmids).")");
851
852 # insert new combined freeblocks.
853 my $sth2 = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,parent_id,vrf,master_id)".
854 " VALUES (?,'<NULL>','m',?,?,?)");
855 foreach my $newblock (@blocklist) {
856 $sth->execute($newblock);
857 $sth2->execute($newblock, $mid, $args{vrf}, $mid);
858 }
859
860 # Update immediate allocations, and remove the old parents
861 $sth2 = $dbh->prepare("DELETE FROM allocations WHERE id = ?");
862 # sigh. going to have to churn things, since we need to do different updates to different sets of blocks.
863 my $fbfix = $dbh->prepare("UPDATE freeblocks SET master_id = ? WHERE master_id = ?");
864 my $fbfix2 = $dbh->prepare("UPDATE freeblocks SET parent_id = ? WHERE parent_id = ?");
865 my $allocfix = $dbh->prepare("UPDATE allocations SET master_id = ? WHERE master_id = ?");
866 my $allocfix2 = $dbh->prepare("UPDATE allocations SET parent_id = ? WHERE parent_id = ?");
867 foreach my $old (@oldmids) {
868 $sth2->execute($old);
869 $fbfix->execute($mid, $old);
870 $fbfix2->execute($mid, $old);
871 $allocfix->execute($mid, $old);
872 $allocfix2->execute($mid, $old);
873 }
874
875 # *whew* If we got here, we likely suceeded.
876 $dbh->commit;
877
878 } # new master contained existing master(s)
879 }; # end eval
880
881 if ($@) {
882 my $msg = $@;
883 eval { $dbh->rollback; };
884 return ('FAIL',$msg);
885 } else {
886
887 # Only attempt rDNS if the IPDB side succeeded
888 if ($rpc_url) {
889
890# Note *not* splitting reverse zones negates any benefit from caching the exported data.
891# IPv6 address space is far too large to split usefully, and in any case (also due to
892# the large address space) doesn't support the iterated template records v4 zones do
893# that causes the bulk of the slowdown that needs the cache anyway.
894
895 my @zonelist;
896# allow splitting reverse zones to be disabled, maybe, someday
897#if ($splitrevzones && !$cidr->{isv6}) {
898 if (1 && !$cidr->{isv6}) {
899 my $splitpoint = ($cidr->masklen <= 16 ? 16 : 24); # hack pthui
900 @zonelist = $cidr->split($splitpoint);
901 } else {
902 @zonelist = ($cidr);
903 }
904 my @fails;
905 ##fixme: remove hardcoding where possible
906 my $dasth = $dbh->prepare("INSERT INTO dnsavail (zone,location,parent_alloc) VALUES (?,?,?)");
907 foreach my $subzone (@zonelist) {
908 my %rpcargs = (
909 rpcuser => $args{user},
910 revzone => "$subzone",
911 revpatt => $args{rdns},
912 defloc => $args{defloc},
913 group => $revgroup, # not sure how these two could sanely be exposed, tbh...
914 state => 1, # could make them globally configurable maybe
915 );
916 if ($rpc_url) {
917 if (!_rpc('addRDNS', %rpcargs)) {
918 push @fails, ("$subzone" => $errstr);
919 } else {
920 $dasth->execute($subzone, $args{defloc}, $mid)
921 or push @fails, ("$subzone" => "rDNS added but failed to track locally: ".$dasth->errstr."\n");
922 }
923 }
924 }
925 if (@fails) {
926 $errstr = "Warning(s) adding $cidr to reverse DNS:\n".join("\n", @fails);
927 return ('WARN',$mid);
928 }
929 }
930 return ('OK',$mid);
931 }
932} # end addMaster
933
934
935## IPDB::touchMaster()
936# Update last-changed timestamp on a master block.
937sub touchMaster {
938 my $dbh = shift;
939 my $master = shift;
940
941 local $dbh->{AutoCommit} = 0;
942 local $dbh->{RaiseError} = 1;
943
944 eval {
945 $dbh->do("UPDATE allocations SET modifystamp=now() WHERE id = ?", undef, ($master));
946 $dbh->commit;
947 };
948
949 if ($@) {
950 my $msg = $@;
951 eval { $dbh->rollback; };
952 return ('FAIL',$msg);
953 }
954 return ('OK','OK');
955} # end touchMaster()
956
957
958## IPDB::listVRF()
959# Get summary list of all VRFs
960# Returns an arrayref to a list of hashrefs with the VRF name, comment
961sub listVRF {
962 my $dbh = shift;
963 my $vrflist = $dbh->selectall_arrayref("SELECT vrf,comment FROM vrfs ORDER BY vrf", { Slice => {} });
964 return $vrflist;
965} # end listVRF()
966
967
968## IPDB::listSummary()
969# Get summary list of all master blocks
970# Returns an arrayref to a list of hashrefs containing the master block, routed count,
971# allocated count, free count, and largest free block masklength
972sub listSummary {
973 my $dbh = shift;
974 my $vrf = shift;
975
976 my $mlist = $dbh->selectall_arrayref("SELECT cidr AS master,id FROM allocations ".
977 "WHERE type='mm' AND vrf = ? ORDER BY cidr",
978 { Slice => {} }, $vrf);
979
980 foreach (@{$mlist}) {
981 my ($rcnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ? AND type='rm' AND master_id = ?",
982 undef, ($$_{master}, $$_{id}));
983 $$_{routed} = $rcnt;
984 my ($acnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
985 "AND NOT type='rm' AND NOT type='mm' AND master_id = ?",
986 undef, ($$_{master}, $$_{id}));
987 $$_{allocated} = $acnt;
988 my ($fcnt) = $dbh->selectrow_array("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?",
989 undef, ($$_{master}, $$_{id}));
990 $$_{free} = $fcnt;
991 my ($bigfree) = $dbh->selectrow_array("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?".
992 " AND master_id = ? ORDER BY masklen(cidr) LIMIT 1", undef, ($$_{master}, $$_{id}));
993##fixme: should find a way to do this without having to HTMLize the <>
994 $bigfree = "/$bigfree" if $bigfree;
995 $bigfree = '<NONE>' if !$bigfree;
996 $$_{bigfree} = $bigfree;
997 }
998 return $mlist;
999} # end listSummary()
1000
1001
1002## IPDB::listSubs()
1003# Get list of subnets within a specified CIDR block, on a specified VRF.
1004# Returns an arrayref to a list of hashrefs containing the CIDR block, customer location or
1005# city it's routed to, block type, SWIP status, and description
1006sub listSubs {
1007 my $dbh = shift;
1008 my %args = @_;
1009
1010 # Just In Case
1011 $args{vrf} = '' if !$args{vrf};
1012
1013 # Snag the allocations for this block
1014 my $sth = $dbh->prepare("SELECT masklen(cidr),cidr,city,type,custid,swip,description,vrf,id,master_id".
1015 " FROM allocations WHERE parent_id = ? ORDER BY cidr");
1016 $sth->execute($args{parent});
1017
1018 # hack hack hack
1019 # set up to flag swip=y records if they don't actually have supporting data in the customers table
1020 my $custsth = $dbh->prepare("SELECT count(*) FROM customers WHERE custid = ?");
1021
1022 # snag some more details
1023 my $substh = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
1024 "AND type ~ '[mc]\$' AND master_id = ? AND NOT cidr = ? ");
1025 my $alsth = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
1026 "AND NOT type='rm' AND NOT type='mm' AND master_id = ? AND NOT id = ?");
1027 my $freesth = $dbh->prepare("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?");
1028 my $lfreesth = $dbh->prepare("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?".
1029 " AND master_id = ? ORDER BY masklen(cidr)");
1030
1031 my @blocklist;
1032 while (my ($blockmask,$cidr,$city,$type,$custid,$swip,$desc,$vrf,$id,$mid) = $sth->fetchrow_array()) {
1033 $desc .= " - vrf:$vrf" if $desc && $vrf;
1034 $desc = "vrf:$vrf" if !$desc && $vrf;
1035 $custsth->execute($custid);
1036 my ($ncust) = $custsth->fetchrow_array();
1037 $substh->execute($cidr, $mid, $cidr);
1038 my ($cont) = $substh->fetchrow_array();
1039 $alsth->execute($cidr, $mid, $id);
1040 my ($alloc) = $alsth->fetchrow_array();
1041 $freesth->execute($cidr, $mid);
1042 my ($free) = $freesth->fetchrow_array();
1043 $lfreesth->execute($cidr, $mid);
1044
1045 # make sure we capture the first one separately...
1046 my ($lfree) = $lfreesth->fetchrow_array();
1047 my $num_ipfree = ($lfree ? 2**(32-$lfree) : 0);
1048 # ... so this can proceed without accidentally whacking it
1049 while (my ($freemask) = $lfreesth->fetchrow_array) {
1050 $num_ipfree += 2**(32-$freemask);
1051 }
1052 if ($type =~ /^.[dp]$/) {
1053 ($num_ipfree) = $dbh->selectrow_array("SELECT count(*) FROM poolips WHERE parent_id = ? AND available = 'y'", undef, $id);
1054 }
1055 my $pctfree = sprintf "%0.1f", $num_ipfree / 2**(32-$blockmask) * 100;
1056 $lfree = "/$lfree" if $lfree;
1057 $lfree = '<NONE>' if !$lfree;
1058
1059 my %row = (
1060 block => $cidr,
1061 subfree => $free,
1062 lfree => $lfree,
1063 city => $city,
1064 type => $disp_alloctypes{$type},
1065 custid => $custid,
1066 desc => $desc,
1067 hassubs => ($type eq 'rm' || $type eq 'mm' || $type =~ /.c/ ? 1 : 0),
1068 id => $id,
1069 );
1070# $row{subblock} = ($type =~ /^.r$/); # hmf. wonder why these won't work in the hash declaration...
1071 $row{listpool} = ($type =~ /^.[pd]$/);
1072 # only set this on suitable types (pools, containers)
1073 $row{pctfree} = "$num_ipfree IPs, $pctfree" if $type =~ /^.[cpdm]/;
1074 push (@blocklist, \%row);
1075 }
1076 return \@blocklist;
1077} # end listSubs()
1078
1079
1080## IPDB::listContainers()
1081# List all container-type allocations in a given parent
1082# Takes a database handle and a hash:
1083# - parent is the ID of the parent block
1084# Returns an arrayref to a list of hashrefs with the CIDR block, location, type,
1085# description, block ID, and counts for the nmber uf suballocations (all types),
1086# free blocks, and the CIDR size of the largest free block
1087sub listContainers {
1088 my $dbh = shift;
1089 my %args = @_;
1090
1091 # Just In Case
1092 $args{vrf} = '' if !$args{vrf};
1093
1094 # Snag the allocations for this block
1095 my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description,vrf,id,master_id".
1096 " FROM allocations WHERE parent_id = ? AND type ~ '[mc]\$' ORDER BY cidr");
1097 $sth->execute($args{parent});
1098
1099 my $alsth = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
1100 "AND NOT type='rm' AND NOT type='mm' AND master_id = ? AND NOT id = ?");
1101 my $freesth = $dbh->prepare("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?");
1102 my $lfreesth = $dbh->prepare("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?".
1103 " AND master_id = ? ORDER BY masklen(cidr) LIMIT 1");
1104
1105 my @blocklist;
1106 while (my ($cidr,$city,$type,$custid,$swip,$desc,$vrf,$id,$mid) = $sth->fetchrow_array()) {
1107 $desc .= " - vrf:$vrf" if $desc && $vrf;
1108 $desc = "vrf:$vrf" if !$desc && $vrf;
1109 $alsth->execute($cidr, $mid, $id);
1110 my ($alloc) = $alsth->fetchrow_array();
1111 $freesth->execute($cidr, $mid);
1112 my ($free) = $freesth->fetchrow_array();
1113 $lfreesth->execute($cidr, $mid);
1114 my ($lfree) = $lfreesth->fetchrow_array();
1115 $lfree = "/$lfree" if $lfree;
1116 $lfree = '<NONE>' if !$lfree;
1117 my %row = (
1118 block => $cidr,
1119 suballocs => $alloc,
1120 subfree => $free,
1121 lfree => $lfree,
1122 city => $city,
1123 type => $disp_alloctypes{$type},
1124 desc => $desc,
1125 id => $id,
1126 );
1127 push (@blocklist, \%row);
1128 }
1129 return \@blocklist;
1130} # end listContainers()
1131
1132
1133## IPDB::listAllocations()
1134# List all end-use allocations in a given parent
1135# Takes a database handle and a hash:
1136# - parent is the ID of the parent block
1137# Returns an arrayref to a list of hashrefs with the CIDR block, location, type,
1138# custID, SWIP flag, description, block ID, and master ID
1139sub listAllocations {
1140 my $dbh = shift;
1141 my %args = @_;
1142
1143 # Snag the allocations for this block
1144 my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description,vrf,id,master_id".
1145 " FROM allocations WHERE parent_id = ? AND type !~ '[mc]\$' ORDER BY cidr");
1146 $sth->execute($args{parent});
1147
1148 # hack hack hack
1149 # set up to flag swip=y records if they don't actually have supporting data in the customers table
1150 my $custsth = $dbh->prepare("SELECT count(*) FROM customers WHERE custid = ?");
1151
1152 my @blocklist;
1153 while (my ($cidr,$city,$type,$custid,$swip,$desc,$vrf,$id,$mid) = $sth->fetchrow_array()) {
1154 $desc .= " - vrf:$vrf" if $desc && $vrf;
1155 $desc = "vrf:$vrf" if !$desc && $vrf;
1156 $custsth->execute($custid);
1157 my ($ncust) = $custsth->fetchrow_array();
1158 my %row = (
1159 block => $cidr,
1160 city => $city,
1161 type => $disp_alloctypes{$type},
1162 custid => $custid,
1163 swip => ($swip eq 'y' ? 'Yes' : 'No'),
1164 partswip => ($swip eq 'y' && $ncust == 0 ? 1 : 0),
1165 desc => $desc,
1166 id => $id,
1167 );
1168# $row{subblock} = ($type =~ /^.r$/); # hmf. wonder why these won't work in the hash declaration...
1169 $row{listpool} = ($type =~ /^.[pd]$/);
1170 push (@blocklist, \%row);
1171 }
1172 return \@blocklist;
1173} # end listAllocations()
1174
1175
1176## IPDB::listForMerge()
1177# Get a list of blocks targetted in a proposed merge
1178sub listForMerge {
1179 my $dbh = shift;
1180 my $parent = shift;
1181 my $newblock = shift;
1182 my $btype = shift || 'a';
1183 $btype = 'a' if $btype !~/^[af]$/;
1184 my $incsub = shift;
1185 $incsub = 1 if !defined($incsub);
1186
1187 my $sql;
1188 if ($btype eq 'a') {
1189 my $ret = $dbh->selectall_arrayref(q(
1190 SELECT a.cidr,a.id,t.dispname FROM allocations a
1191 JOIN alloctypes t ON a.type=t.type
1192 WHERE a.parent_id = ? AND a.cidr <<= ?
1193 ORDER BY a.cidr
1194 ),
1195 { Slice => {} }, $parent, $newblock);
1196 return $ret;
1197 } else {
1198##fixme: Not sure about the casting hackery in "SELECT ?::integer AS id", but it works as intended
1199 my @dbargs = ($parent, "$newblock");
1200 push @dbargs, $parent, $newblock if $incsub;
1201 my $ret = $dbh->selectall_arrayref(q{
1202 SELECT cidr,id FROM freeblocks
1203 WHERE parent_id IN (
1204 }.($incsub ? "SELECT id FROM allocations WHERE parent_id = ? AND cidr <<= ? UNION " : '').q{
1205 SELECT ?::integer AS id
1206 ) AND cidr <<= ?
1207 ORDER BY cidr
1208 },
1209 { Slice => {} }, @dbargs);
1210 return $ret;
1211 }
1212 return;
1213} # end listForMerge()
1214
1215
1216## IPDB::listFree()
1217# Gets a list of free blocks in the requested parent/master and VRF instance in both CIDR and range notation
1218# Takes a parent/master ID and an optional VRF specifier that defaults to empty.
1219# Returns an arrayref to a list of hashrefs containing the CIDR and range-notation blocks
1220# Returns some extra flags in the hashrefs for routed blocks, since those can have several subtypes
1221sub listFree {
1222 my $dbh = shift;
1223
1224 my %args = @_;
1225 # Just In Case
1226 $args{vrf} = '' if !$args{vrf};
1227
1228 my $sth = $dbh->prepare(q(
1229 SELECT f.cidr,f.id,allocations.cidr
1230 FROM freeblocks f
1231 LEFT JOIN allocations ON f.reserve_for = allocations.id
1232 WHERE f.parent_id = ?
1233 ORDER BY f.cidr
1234 ) );
1235# $sth->execute($args{parent}, $args{vrf});
1236 $sth->execute($args{parent});
1237 my @flist;
1238 while (my ($cidr,$id,$resv) = $sth->fetchrow_array()) {
1239 $cidr = new NetAddr::IP $cidr;
1240 my %row = (
1241 fblock => "$cidr",
1242 frange => $cidr->range,
1243 fbid => $id,
1244 fbparent => $args{parent},
1245 resv => $resv,
1246 );
1247 push @flist, \%row;
1248 }
1249 return \@flist;
1250} # end listFree()
1251
1252
1253## IPDB::listPool()
1254# List the IPs in an IP pool.
1255# Takes a pool/parent ID
1256# Returns an arrayref to a list of hashrefs containing the IP, customer ID, availability flag,
1257# description, backreference to the pool/parent, and the IP ID in the pool.
1258# Also includes a "may be deleted" metaflag mainly useful for allowing the return to be passed
1259# directly to HTML::Template for UI display.
1260sub listPool {
1261 my $dbh = shift;
1262 my $pool = shift;
1263 my $incdesc = shift;
1264 $incdesc = 1 if !defined($incdesc); # extra flag to include description and "deleteme" flag
1265
1266 my $sth = $dbh->prepare("SELECT ip,custid,available,description,type,id".
1267 " FROM poolips WHERE parent_id = ? ORDER BY ip");
1268 $sth->execute($pool);
1269 my @poolips;
1270 while (my ($ip,$custid,$available,$desc,$type,$id) = $sth->fetchrow_array) {
1271 my %row = (
1272 ip => $ip,
1273 custid => $custid,
1274 available => $available,
1275 parent => $pool,
1276 id => $id,
1277 );
1278 if ($incdesc) {
1279 $row{desc} = $desc;
1280 $row{delme} = ($available eq 'n');
1281 }
1282 push @poolips, \%row;
1283 }
1284 return \@poolips;
1285} # end listPool()
1286
1287
1288## IPDB::getMasterList()
1289# Get a list of master blocks, optionally including last-modified timestamps
1290# Takes an optional flag to indicate whether to include timestamps;
1291# 'm' includes ctime, all others (suggest 'c') do not.
1292# Returns an arrayref to a list of hashrefs
1293sub getMasterList {
1294 my $dbh = shift;
1295 my $stampme = shift || 'm'; # optional but should be set by caller for clarity
1296
1297 my $mlist = $dbh->selectall_arrayref("SELECT id,vrf,cidr AS master".($stampme eq 'm' ? ',modifystamp AS mtime' : '').
1298 " FROM allocations WHERE type='mm' ORDER BY cidr", { Slice => {} });
1299 return $mlist;
1300} # end getMasterList()
1301
1302
1303## IPDB::getTypeList()
1304# Get an alloctype/description pair list suitable for dropdowns
1305# Takes a flag to determine which general groups of types are returned
1306# Returns an reference to an array of hashrefs
1307sub getTypeList {
1308 my $dbh = shift;
1309 my $tgroup = shift || 'a'; # technically optional, like this, but should
1310 # really be specified in the call for clarity
1311 my $seltype = shift || '';
1312
1313 my $sql = "SELECT type,listname,type=? AS sel FROM alloctypes WHERE listorder <= 500";
1314 if ($tgroup eq 'n') {
1315 # grouping 'n' - all netblock types. These include routed blocks, containers (_c)
1316 # and contained (_r) types, dynamic-allocation ranges (_e), static IP pools (_d and _p),
1317 # and the "miscellaneous" cn, in, and en types.
1318 # Or in other words, everything but master and static IP types.
1319 $sql .= " AND type NOT LIKE '_i'";
1320 } elsif ($tgroup eq 'p') {
1321 # grouping 'p' - primary allocation types. As with 'n' above but without the _r contained types.
1322 $sql .= " AND type NOT LIKE '_i' AND type NOT LIKE '_r'";
1323 } elsif ($tgroup eq 'c') {
1324 # grouping 'c' - contained types. These include all static IPs and all _r types.
1325 $sql .= " AND (type LIKE '_i' OR type LIKE '_r')";
1326 } elsif ($tgroup eq 'i') {
1327 # grouping 'i' - static IP types.
1328 $sql .= " AND type LIKE '_i'";
1329 } else {
1330 # grouping 'a' - all standard allocation types. This includes everything
1331 # but mm (present only as a formality). Make this the default.
1332 # ... whee! no extra WHERE clauses
1333 }
1334 $sql .= " ORDER BY listorder";
1335 my $tlist = $dbh->selectall_arrayref($sql, { Slice => {} }, $seltype);
1336 return $tlist;
1337}
1338
1339
1340## IPDB::getPoolSelect()
1341# Get a list of pools matching the passed city and type that have 1 or more free IPs
1342# Returns an arrayref to a list of hashrefs containing the number of available IPs, the CIDR pool,
1343# and the city it's nominally in.
1344sub getPoolSelect {
1345 my $dbh = shift;
1346 my $iptype = shift;
1347 my $pcity = shift;
1348
1349 my $rangelimit = shift;
1350 if ($rangelimit) {
1351 if ($rangelimit !~ /^[\d\.\/]+$/) {
1352 # Just skip limiting on ridiculous range limits
1353 $rangelimit = '';
1354 } else {
1355 # now check for sanity
1356 $rangelimit = new NetAddr::IP $rangelimit;
1357 $rangelimit = '' if !$rangelimit;
1358 }
1359 }
1360
1361 my ($ptype) = ($iptype =~ /^(.)i$/);
1362 return if !$ptype;
1363 $ptype .= '_';
1364
1365 my @qargs = ($pcity, $ptype);
1366 push @qargs, "$rangelimit" if $rangelimit;
1367
1368 my $plist = $dbh->selectall_arrayref( q(
1369 SELECT a.id as poolid,count(*) AS poolfree,a.cidr AS poolblock, a.city AS poolcit
1370 FROM poolips p
1371 JOIN allocations a ON p.parent_id=a.id
1372 WHERE p.available='y' AND a.city = ? AND p.type LIKE ?).
1373 ($rangelimit ? ' AND a.cidr << ?' : '').q(
1374 GROUP BY a.id,a.cidr,a.city
1375 ORDER BY a.cidr
1376 ),
1377 { Slice => {} }, @qargs );
1378 return $plist;
1379} # end getPoolSelect()
1380
1381
1382## IPDB::findAllocateFrom()
1383# Find free block to add a new allocation from. (CIDR block version of pool select above, more or less)
1384# Takes
1385# - mask length
1386# - allocation type
1387# - POP city "parent"
1388# - optional master-block restriction
1389# - optional flag to allow automatic pick-from-private-network-ranges
1390# Returns a 3-element list with the free block ID, CIDR, and parent ID matching the criteria, if any
1391sub findAllocateFrom {
1392 my $dbh = shift;
1393 my $maskbits = shift;
1394 my $type = shift;
1395 my $city = shift;
1396 my $pop = shift;
1397 my %optargs = @_;
1398
1399 my $failmsg = "No suitable free block found\n";
1400
1401 my @vallist;
1402 my $sql;
1403
1404 # Free pool IPs should be easy.
1405 if ($type =~ /^.i$/) {
1406 # User may get an IP from the wrong VRF. User should not be using admin tools to allocate static IPs.
1407 $sql = "SELECT id, ip, parent_id FROM poolips WHERE ip = ?";
1408 @vallist = ($optargs{gimme});
1409 } else {
1410
1411## Set up the SQL to find out what freeblock we can (probably) use for an allocation.
1412## Very large systems will require development of a reserve system (possibly an extension
1413## of the reserve-for-expansion concept in https://secure.deepnet.cx/trac/ipdb/ticket/24?)
1414## Also populate a value list for the DBI call.
1415
1416 @vallist = ($maskbits);
1417 $sql = "SELECT id,cidr,parent_id FROM freeblocks WHERE masklen(cidr) <= ?";
1418
1419# cases, strict rules
1420# .c -> container type
1421# requires a routing container, fbtype r
1422# .d -> DHCP/"normal-routing" static pool
1423# requires a routing container, fbtype r
1424# .e -> Dynamic-assignment connectivity
1425# requires a routing container, fbtype r
1426# .i -> error, can't allocate static IPs this way?
1427# mm -> error, master block
1428# rm -> routed block
1429# requires master block, fbtype m
1430# .n -> Miscellaneous usage
1431# requires a routing container, fbtype r
1432# .p -> PPP(oE) static pool
1433# requires a routing container, fbtype r
1434# .r -> contained type
1435# requires a matching container, fbtype $1
1436##fixme: strict-or-not flag
1437
1438##fixme: config or UI flag for "Strict" mode
1439# if ($strictmode) {
1440if (0) {
1441 if ($type =~ /^(.)r$/) {
1442 push @vallist, $1;
1443 $sql .= " AND routed = ?";
1444 } elsif ($type eq 'rm') {
1445 $sql .= " AND routed = 'm'";
1446 } else {
1447 $sql .= " AND routed = 'r'";
1448 }
1449}
1450
1451 # for PPP(oE) and container types, the POP city is the one attached to the pool.
1452 # individual allocations get listed with the customer city site.
1453 ##fixme: chain cities to align roughly with a full layer-2 node graph
1454 $city = $pop if $type !~ /^.[pc]$/;
1455 if ($type ne 'rm' && $city) {
1456 $sql .= " AND city = ?";
1457 push @vallist, $city;
1458 }
1459 # Allow specifying an arbitrary full block, instead of a master
1460 if ($optargs{gimme}) {
1461 $sql .= " AND cidr >>= ?";
1462 push @vallist, $optargs{gimme};
1463 }
1464 # if a specific master was requested, allow the requestor to self->shoot(foot)
1465 if ($optargs{master} && $optargs{master} ne '-') {
1466 $sql .= " AND master_id = ?";
1467# if $optargs{master} ne '-';
1468 push @vallist, $optargs{master};
1469 } else {
1470 # if a specific master was NOT requested, filter out the RFC 1918 private networks
1471 if (!$optargs{allowpriv}) {
1472 $sql .= " AND NOT (cidr <<= '192.168.0.0/16' OR cidr <<= '10.0.0.0/8' OR cidr <<= '172.16.0.0/12')";
1473 }
1474 }
1475 # Keep "reserved" blocks out of automatic assignment.
1476##fixme: needs a UI flag or a config knob
1477 $sql .= " AND reserve_for = 0";
1478 # Sorting and limiting, since we don't (currently) care to provide a selection of
1479 # blocks to carve up. This preserves something resembling optimal usage of the IP
1480 # space by forcing contiguous allocations and free blocks as much as possible.
1481 $sql .= " ORDER BY masklen(cidr) DESC,cidr LIMIT 1";
1482 } # done setting up SQL for free CIDR block
1483
1484 my ($fbid,$fbfound,$fbparent) = $dbh->selectrow_array($sql, undef, @vallist);
1485 return $fbid,$fbfound,$fbparent;
1486} # end findAllocateFrom()
1487
1488
1489## IPDB::ipParent()
1490# Get an IP's parent pool's details
1491# Takes a database handle and IP
1492# Returns a hashref to the parent pool block, if any
1493sub ipParent {
1494 my $dbh = shift;
1495 my $block = shift;
1496
1497 my $pinfo = $dbh->selectrow_hashref("SELECT cidr,custid,type,city,description FROM allocations".
1498 " WHERE cidr >>= ? AND (type LIKE '_p' OR type LIKE '_d')", undef, ($block) );
1499 return $pinfo;
1500} # end ipParent()
1501
1502
1503## IPDB::subParent()
1504# Get a block's parent's details
1505# Takes a database handle and CIDR block
1506# Returns a hashref to the parent container block, if any
1507sub subParent {
1508 my $dbh = shift;
1509 my $block = shift;
1510
1511 my $pinfo = $dbh->selectrow_hashref("SELECT cidr,custid,type,city,description FROM allocations".
1512 " WHERE cidr >>= ?", undef, ($block) );
1513 return $pinfo;
1514} # end subParent()
1515
1516
1517## IPDB::blockParent()
1518# Get a block's parent's details
1519# Takes a database handle and CIDR block
1520# Returns a hashref to the parent container block, if any
1521sub blockParent {
1522 my $dbh = shift;
1523 my $block = shift;
1524
1525 my $pinfo = $dbh->selectrow_hashref("SELECT cidr,city FROM routed".
1526 " WHERE cidr >>= ?", undef, ($block) );
1527 return $pinfo;
1528} # end blockParent()
1529
1530
1531## IPDB::getBreadCrumbs()
1532# Retrieve the ID and CIDR of a block's parent(s) up to the master block
1533# Returns an arrayref to a list of hashrefs with CIDR and block ID
1534sub getBreadCrumbs {
1535 my $dbh = shift;
1536 my $parent = shift || 0;
1537 my $vrf = shift; # if we're not browsing into netblocks yet, caller can pass the VRF for breadcrumbs
1538 my @result;
1539
1540 my $sth = $dbh-> prepare("SELECT cidr,type,id,parent_id,vrf FROM allocations WHERE id=?");
1541
1542 while ($parent != 0) {
1543 $sth->execute($parent);
1544 my ($cidr,$type,$id,$pid,$bvrf) = $sth->fetchrow_array;
1545 $vrf = $bvrf;
1546 push @result, { cidr => $cidr, link => $id, ispool => ($type =~ /^.[dp]$/ ? 1 : 0) };
1547 $parent = $pid;
1548 }
1549
1550 push @result, { cidr => "vrf:$vrf", link => $vrf, isvrf => 1 }
1551 if $vrf;
1552
1553 return \@result;
1554} # end getBreadCrumbs()
1555
1556
1557## IPDB::getRoutedCity()
1558# Get the city for a routed block.
1559sub getRoutedCity {
1560 my $dbh = shift;
1561 my $block = shift;
1562
1563 my ($rcity) = $dbh->selectrow_array("SELECT city FROM routed WHERE cidr = ?", undef, ($block) );
1564 return $rcity;
1565} # end getRoutedCity()
1566
1567
1568## IPDB::allocateBlock()
1569# Does all of the magic of actually allocating a netblock
1570# Requires a database handle, and a hash containing the block to allocate, routing depth, custid,
1571# type, city, block to allocate from, and optionally a description, notes, circuit ID,
1572# and private data
1573# Returns a success code and optional error message.
1574sub allocateBlock {
1575 my $dbh = shift;
1576
1577 my %args = @_;
1578
1579 if ($args{cidr} eq 'Single static IP') {
1580 $args{cidr} = '';
1581 } else {
1582 $args{cidr} = new NetAddr::IP $args{cidr};
1583 }
1584
1585 # Spaces don't show up well in lots of places. Make sure they don't get into the DB.
1586 $args{custid} =~ s/^\s+//;
1587 $args{custid} =~ s/\s+$//;
1588
1589 $args{desc} = $args{description} if $args{description};
1590 $args{desc} = '' if !$args{desc};
1591 $args{notes} = '' if !$args{notes};
1592 $args{circid} = '' if !$args{circid};
1593 $args{privdata} = '' if !$args{privdata};
1594##fixme: VRF should trickle down like master_id
1595 $args{vrf} = '' if !$args{vrf};
1596 $args{vlan} = '' if !$args{vlan};
1597 $args{rdns} = '' if !$args{rdns};
1598
1599 # munge the reverse name to include the default domain if there are no dots. Don't append if
1600 # there's no DNS argument though, that would likely cause Big Problems
1601 $args{rdns} .= ".$IPDB::domain" if $IPDB::append_domain && $args{rdns} && $args{rdns} !~ /\./;
1602
1603 $args{user} = $args{rpcuser} if !$args{user};
1604
1605 # Could arguably allow this for eg /120 allocations, but end users who get a single v4 IP are
1606 # usually given a v6 /64, and most v6 addressing schemes need at least half that address space
1607 if ($args{cidr} && $args{cidr}->{isv6} && $args{rdns} =~ /\%/) {
1608 return ('FAIL','Reverse DNS template patterns are not supported for IPv6 allocations');
1609 }
1610
1611 my $sth;
1612
1613 # Snag the "type" of the freeblock and its CIDR
1614 my ($alloc_from_type, $alloc_from, $fbparent, $fcity, $fbmaster) =
1615 $dbh->selectrow_array("SELECT routed,cidr,parent_id,city,master_id FROM freeblocks WHERE id = ?",
1616 undef, $args{fbid});
1617 $alloc_from = new NetAddr::IP $alloc_from;
1618 return ('FAIL',"Failed to allocate $args{cidr}; intended free block was used by another allocation.")
1619 if ($args{type} !~ /.i/ && !$fbparent);
1620##fixme: fail here if !$alloc_from
1621# also consider "lock for allocation" due to multistep allocation process
1622
1623 # To contain the error message, if any.
1624 my $msg = "Unknown error allocating $args{cidr} as '$disp_alloctypes{$args{type}}'";
1625
1626 # Enable transactions and error handling
1627 local $dbh->{AutoCommit} = 0; # These need to be local so we don't
1628 local $dbh->{RaiseError} = 1; # step on our toes by accident.
1629
1630 if ($args{type} =~ /^.i$/) {
1631 $msg = "Unable to assign static IP $args{cidr} to $args{custid}";
1632 eval {
1633##fixme: IP pools across VRFs, need to use the IP ID instead of the CIDR
1634# ... or the VRF itself?
1635 if ($args{cidr}) {
1636 # IP specified
1637 my $availsql = "SELECT available FROM poolips WHERE ";
1638 my @availargs;
1639 if ($args{cidr} =~ /^\d+$/) {
1640 # IP passed as ID
1641 $availsql .= "id = ?";
1642 push @availargs, $args{cidr};
1643 } else {
1644 # IP passed as IP address
1645 $availsql .= "ip = ?";
1646 push @availargs, $args{cidr};
1647 }
1648 if ($args{parent}) {
1649 # Limit by parent ID
1650 $availsql .= " AND parent_id = ?";
1651 push @availargs, $args{parent};
1652 } elsif ($args{vfr}) {
1653 # Limit by VRF, but only if the parent ID isn't available
1654 $availsql .= " AND vrf = ?";
1655 push @availargs, $args{vrf};
1656 } else {
1657 # Fail if we don't have a handle for the pool
1658 die "Missing parent ID or VRF.\n";
1659 }
1660 my ($isavail) = $dbh->selectrow_array($availsql, undef, @availargs);
1661 die "IP is not in an IP pool.\n"
1662 if !$isavail;
1663 die "IP already allocated. Deallocate and reallocate, or update the entry\n"
1664 if $isavail eq 'n';
1665 } else { # IP not specified, take first available
1666 ($args{cidr}) = $dbh->selectrow_array("SELECT ip FROM poolips WHERE parent_id=? AND available='y' ORDER BY ip",
1667 undef, ($args{parent}) );
1668 }
1669
1670 # backup
1671 my $backupid = 0;
1672 if ($args{backup}) {
1673 my $bksql = "INSERT INTO backuplist (";
1674 my @bkvals;
1675 my @bkfields;
1676 for my $bk (@backupfields) {
1677 if ($args{"bk$bk"}) {
1678 push @bkfields, "bk$bk";
1679 push @bkvals, $args{"bk$bk"};
1680 }
1681 }
1682 $bksql .= join(',',@bkfields).") VALUES (".join(',', map {'?'} @bkfields).")";
1683 $dbh->do($bksql, undef, @bkvals);
1684 ($backupid) = $dbh->selectrow_array("SELECT currval('backuplist_backup_id_seq')");
1685 }
1686
1687 # finally assign the IP
1688 $dbh->do("UPDATE poolips SET custid = ?, city = ?, available='n', description = ?, notes = ?, ".
1689 "circuitid = ?, privdata = ?, rdns = ?, backup_id = ? ".
1690 "WHERE ip = ? AND parent_id = ?", undef,
1691 ($args{custid}, $args{city}, $args{desc}, $args{notes},
1692 $args{circid}, $args{privdata}, $args{rdns}, $backupid,
1693 $args{cidr}, $args{parent}) );
1694
1695# node hack
1696 if ($args{nodeid} && $args{nodeid} ne '') {
1697 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
1698 }
1699# end node hack
1700
1701 $dbh->commit; # Allocate IP from pool
1702 };
1703 if ($@) {
1704 $msg .= ": $@";
1705 eval { $dbh->rollback; };
1706 return ('FAIL', $msg);
1707 } else {
1708 # Snag the pool info
1709 my $pinfo = getBlockData($dbh, $args{parent});
1710 # Only try to update rDNS when the pool is flagged as "rDNS available"
1711 if ($pinfo->{revavail} || $pinfo->{revpartial}) {
1712 _rpc('addOrUpdateRevRec', cidr => "$args{cidr}", name => $args{rdns}, rpcuser => $args{user},
1713 location => $pinfo->{location});
1714 }
1715 return ('OK', $args{cidr});
1716 }
1717
1718 } else { # end IP-from-pool allocation
1719
1720 if ($args{cidr} == $alloc_from) {
1721 # Easiest case- insert in one table, delete in the other, and go home. More or less.
1722
1723 eval {
1724 $msg = "Unable to allocate $args{cidr} as '$disp_alloctypes{$args{type}}'";
1725
1726 # backup
1727 my $backupid = 0;
1728 if ($args{backup}) {
1729 if (!$args{bkip}) {
1730 # check for /32-ness. no point in skipping /32 "netblocks", because they already single IPs
1731 die "Backup data set on a netblock requires a backup IP\n" unless $args{cidr} =~ m{/32$};
1732 $args{bkip} = $args{cidr};
1733 }
1734 my $bksql = "INSERT INTO backuplist (";
1735 my @bkfields;
1736 my @bkvals;
1737 for my $bk (@backupfields) {
1738 if ($args{"bk$bk"}) {
1739 push @bkfields, "bk$bk";
1740 push @bkvals, $args{"bk$bk"};
1741 }
1742 }
1743 $bksql .= join(',',@bkfields).") VALUES (".join(',',map {'?'} @bkfields).")";
1744 $dbh->do($bksql, undef, @bkvals);
1745 ($backupid) = $dbh->selectrow_array("SELECT currval('backuplist_backup_id_seq')");
1746 } # $args{backup}
1747
1748 # Insert the allocations entry
1749 $dbh->do("INSERT INTO allocations ".
1750 "(cidr,parent_id,master_id,vrf,vlan,custid,type,city,description,notes,circuitid,privdata,rdns,backup_id)".
1751 " VALUES (?,?,?,(SELECT vrf FROM allocations WHERE id=?),?,?,?,?,?,?,?,?,?,?)", undef,
1752 ($args{cidr}, $fbparent, $fbmaster, $fbmaster, $args{vlan}, $args{custid}, $args{type}, $args{city},
1753 $args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{rdns}, $backupid) );
1754 my ($bid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
1755
1756 # Munge freeblocks
1757 if ($args{type} =~ /^(.)[mc]$/) {
1758 # special case - block is a routed or container/"reserve" block
1759 my $rtype = $1;
1760 $dbh->do("UPDATE freeblocks SET routed = ?,city = ?,parent_id = ? WHERE id = ?",
1761 undef, ($rtype, $args{city}, $bid, $args{fbid}) );
1762 } else {
1763 # "normal" case
1764 $dbh->do("DELETE FROM freeblocks WHERE id = ?", undef, ($args{fbid}) );
1765 }
1766
1767 # And initialize the pool, if necessary
1768 # PPPoE pools (currently dialup, DSL, and WiFi) get all IPs made available
1769 # "DHCP" or "real-subnet" pools have the net, gw, and bcast IPs removed.
1770 if ($args{type} =~ /^.p$/) {
1771 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1772 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "all", $bid);
1773 die $rmsg if $code eq 'FAIL';
1774 } elsif ($args{type} =~ /^.d$/) {
1775 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1776 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "normal", $bid);
1777 die $rmsg if $code eq 'FAIL';
1778 }
1779
1780# node hack
1781 if ($args{nodeid} && $args{nodeid} ne '') {
1782 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
1783 }
1784# end node hack
1785
1786 $dbh->commit; # Simple block allocation
1787 }; # end of eval
1788 if ($@) {
1789 $msg .= ": ".$@;
1790 eval { $dbh->rollback; };
1791 return ('FAIL',$msg);
1792 }
1793
1794 } else { # cidr != alloc_from
1795
1796 # Hard case. Allocation is smaller than free block.
1797
1798 # make sure new allocation is in fact within freeblock. *sigh*
1799 return ('FAIL',"Requested allocation $args{cidr} is not within $alloc_from")
1800 if !$alloc_from->contains($args{cidr});
1801 my $wantmaskbits = $args{cidr}->masklen;
1802 my $maskbits = $alloc_from->masklen;
1803
1804 my @newfreeblocks; # Holds free blocks generated from splitting the source freeblock.
1805
1806 # This determines which blocks will be left "free" after allocation. We take the
1807 # block we're allocating from, and split it in half. We see which half the wanted
1808 # block is in, and repeat until the wanted block is equal to one of the halves.
1809 my $i=0;
1810 my $tmp_from = $alloc_from; # So we don't munge $args{alloc_from}
1811 while ($maskbits++ < $wantmaskbits) {
1812 my @subblocks = $tmp_from->split($maskbits);
1813 $newfreeblocks[$i++] = (($args{cidr}->within($subblocks[0])) ? $subblocks[1] : $subblocks[0]);
1814 $tmp_from = ( ($args{cidr}->within($subblocks[0])) ? $subblocks[0] : $subblocks[1] );
1815 } # while
1816
1817 # Begin SQL transaction block
1818 eval {
1819 $msg = "Unable to allocate $args{cidr} as '$disp_alloctypes{$args{type}}'";
1820
1821 # Delete old freeblocks entry
1822 $dbh->do("DELETE FROM freeblocks WHERE id = ?", undef, ($args{fbid}) );
1823
1824 # Insert the allocations entry
1825 $dbh->do("INSERT INTO allocations ".
1826 "(cidr,parent_id,master_id,vrf,vlan,custid,type,city,description,notes,circuitid,privdata,rdns)".
1827 " VALUES (?,?,?,(SELECT vrf FROM allocations WHERE id=?),?,?,?,?,?,?,?,?,?)", undef,
1828 ($args{cidr}, $fbparent, $fbmaster, $fbmaster, $args{vlan}, $args{custid}, $args{type}, $args{city},
1829 $args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{rdns}) );
1830 my ($bid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
1831
1832 # Insert new list of smaller free blocks left over. Flag the one that matches the
1833 # masklength of the new allocation, if a reserve block was requested.
1834 $sth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id,reserve_for) ".
1835 "VALUES (?,?,?,?,?,?,?)");
1836 foreach my $block (@newfreeblocks) {
1837 $sth->execute($block, $fcity, $alloc_from_type, $args{vrf}, $fbparent, $fbmaster,
1838 ($args{reserve} && $block->masklen == $wantmaskbits ? $bid : 0));
1839 }
1840
1841 # For routed/container types, add a freeblock within the allocated block so we can subdivide it further
1842 if ($args{type} =~ /(.)[mc]/) { # rm and .c types - containers
1843 my $rtype = $1;
1844 $sth->execute($args{cidr}, $args{city}, $rtype, $args{vrf}, $bid, $fbmaster, 0);
1845 }
1846
1847 # And initialize the pool, if necessary
1848 # PPPoE pools (currently dialup, DSL, and WiFi) get all IPs made available
1849 # "DHCP" or "real-subnet" pools have the net, gw, and bcast IPs removed.
1850 if ($args{type} =~ /^.p$/) {
1851 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1852 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "all", $bid);
1853 die $rmsg if $code eq 'FAIL';
1854 } elsif ($args{type} =~ /^.d$/) {
1855 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1856 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "normal", $bid);
1857 die $rmsg if $code eq 'FAIL';
1858 }
1859
1860# node hack
1861 if ($args{nodeid} && $args{nodeid} ne '') {
1862 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
1863 }
1864# end node hack
1865
1866 $dbh->commit; # Complex block allocation
1867 }; # end eval
1868 if ($@) {
1869 $msg .= ": ".$@;
1870 eval { $dbh->rollback; };
1871 return ('FAIL',$msg);
1872 }
1873
1874 } # end fullcidr != alloc_from
1875
1876 # Snag the parent info
1877 my $pinfo = getBlockData($dbh, $fbparent);
1878 # Only try to update rDNS when the block is flagged as "rDNS available"
1879 if (($pinfo->{revavail} || $pinfo->{revpartial}) && ($args{rdns} || $args{iprev})) {
1880 # the netblock/allocation...
1881 _rpc('addOrUpdateRevRec', cidr => "$args{cidr}", name => $args{rdns}, rpcuser => $args{user},
1882 location => $pinfo->{location});
1883 # ...and the per-IP set, if there is one.
1884 _rpc('updateRevSet', %{$args{iprev}}, rpcuser => $args{user}, location => $pinfo->{location})
1885 if keys (%{$args{iprev}});
1886 }
1887
1888 return ('OK', 'OK');
1889
1890 } # end static-IP vs netblock allocation
1891
1892} # end allocateBlock()
1893
1894
1895## IPDB::initPool()
1896# Initializes a pool
1897# Requires a database handle, the pool CIDR, type, city, and a parameter
1898# indicating whether the pool should allow allocation of literally every
1899# IP, or if it should reserve network/gateway/broadcast IPs
1900# Note that this is NOT done in a transaction, that's why it's a private
1901# function and should ONLY EVER get called from allocateBlock()
1902sub initPool {
1903 my ($dbh,undef,$type,$city,$class,$parent) = @_;
1904 my $pool = new NetAddr::IP $_[1];
1905
1906 # IPv6 does not lend itself to IP pools as supported
1907 return ('FAIL',"Refusing to create IPv6 static IP pool\n") if $pool->{isv6};
1908 # IPv4 pools don't make much sense beyond even /24. Allow up to 4096-host footshooting anyway.
1909 # NetAddr::IP won't allow more than a /16 (65k hosts).
1910 return ('FAIL',"Refusing to create oversized static IP pool\n") if $pool->masklen <= 20;
1911
1912 # Retrieve some odds and ends for defaults on the IPs
1913 my ($pcustid) = $dbh->selectrow_array("SELECT def_custid FROM alloctypes WHERE type=?", undef, ($type) );
1914 my ($vrf,$vlan,$master) = $dbh->selectrow_array("SELECT vrf,vlan,master_id FROM allocations WHERE id = ?",
1915 undef, ($parent) );
1916
1917 $type =~ s/[pd]$/i/;
1918 my $sth;
1919 my $msg;
1920
1921 eval {
1922 # have to insert all pool IPs into poolips table as "unallocated".
1923 $sth = $dbh->prepare("INSERT INTO poolips (ip,custid,city,type,parent_id,master_id,vrf) VALUES (?,?,?,?,?,?,?)");
1924
1925 # in case of pool extension by some means, we need to see what IPs were already inserted
1926 my $tmp1 = $dbh->selectall_arrayref("SELECT ip FROM poolips WHERE parent_id = ?", undef, $parent);
1927 my %foundips;
1928 foreach (@{$tmp1}) {
1929 $foundips{$_->[0]} = 1;
1930 }
1931
1932# Dodge an edge case - pool where IPs have been "stolen" and turned into a netblock assignment.
1933# We can't just "get all the current IPs, and add the missing ones", because some IPs are
1934# legitimately missing (for stretchy values of "legitimately").
1935
1936 my $pdata = getBlockData($dbh, $parent);
1937 my $pcidr = new NetAddr::IP $pdata->{block};
1938
1939 if ($pcidr != $pool) {
1940 # enumerate the IPs from the *old* pool, flag them as "found", so we can iterate the entire
1941 # requested pool and still make sure we skip the IPs in the old pool - even if they've been
1942 # "stolen" by legacy netblocks.
1943 my @oldips = $pcidr->hostenum;
1944 # decide whether to start excluding existing IPs at the "gateway" or "gateway+1"
1945 my $ostart = ($pdata->{type} =~ /^.d$/ ? 1 : 0);
1946 for (my $i = $ostart; $i<= $#oldips; $i++) {
1947 $foundips{$oldips[$i]} = 1;
1948 }
1949 }
1950
1951 # enumerate the hosts in the IP range - everything except the first (net) and last (bcast) IP
1952 my @poolip_list = $pool->hostenum;
1953
1954 # always check/add IPs from gw+1 through bcast-1:
1955 # (but the set won't be in oooorderrrrr! <pout>)
1956 for (my $i=1; $i<=$#poolip_list; $i++) {
1957 my $baseip = $poolip_list[$i]->addr;
1958 if ($baseip !~ /\.(?:0|255)$/ && !$foundips{$poolip_list[$i]}) {
1959 $sth->execute($baseip, $pcustid, $city, $type, $parent, $master, $vrf);
1960 }
1961 }
1962
1963 # now do the special case - DSL/PPP blocks can use the "net", "gw", and "bcast" IPs.
1964 # we exclude .0 and .255 anyway, since while they'll mostly work, they *will* behave badly here and there.
1965 if ($class eq 'all') { # (DSL-ish block - *all* IPs available
1966 if ($pool->addr !~ /\.0$/) { # .0 causes weirdness.
1967 $sth->execute($pool->addr, $pcustid, $city, $type, $parent, $master, $vrf)
1968 unless $foundips{$pool->addr."/32"};
1969 }
1970 $sth->execute($poolip_list[0]->addr, $pcustid, $city, $type, $parent, $master, $vrf)
1971 unless $foundips{$poolip_list[0]};
1972 $pool--;
1973 if ($pool->addr !~ /\.255$/) { # .255 can cause weirdness.
1974 $sth->execute($pool->addr, $pcustid, $city, $type, $parent, $master, $vrf)
1975 unless $foundips{$pool->addr."/32"};
1976 }
1977 }
1978# don't commit here! the caller may not be done.
1979# $dbh->commit;
1980 };
1981 if ($@) {
1982 $msg = $@;
1983# Don't roll back! It's up to the caller to handle this.
1984# eval { $dbh->rollback; };
1985 return ('FAIL',$msg);
1986 } else {
1987 return ('OK',"OK");
1988 }
1989} # end initPool()
1990
1991
1992## IPDB::updateBlock()
1993# Update an allocation
1994# Takes all allocation fields in a hash
1995sub updateBlock {
1996 my $dbh = shift;
1997 my %args = @_;
1998
1999 return ('FAIL', 'Missing block to update') if !$args{block};
2000
2001 # Spaces don't show up well in lots of places. Make sure they don't get into the DB.
2002 $args{custid} =~ s/^\s+//;
2003 $args{custid} =~ s/\s+$//;
2004
2005 # do it all in a transaction
2006 local $dbh->{AutoCommit} = 0;
2007 local $dbh->{RaiseError} = 1;
2008
2009 my @fieldlist;
2010 my @vallist;
2011 foreach ('custid', 'city', 'description', 'notes', 'circuitid', 'privdata', 'rdns', 'vrf', 'vlan') {
2012 if ($args{$_}) {
2013 push @fieldlist, $_;
2014 push @vallist, $args{$_};
2015 }
2016 }
2017
2018 my $binfo;
2019 my $updtable = 'allocations';
2020 my $keyfield = 'id';
2021 if ($args{type} =~ /^(.)i$/) {
2022 $updtable = 'poolips';
2023 $binfo = getBlockData($dbh, $args{block}, 'i');
2024 # allow allocating an IP by update. mainly for RPC, may simplify matters for caller
2025 if ($args{assignIP_on_update}) {
2026 push @fieldlist, 'available';
2027 push @vallist, 'n';
2028 }
2029 } else {
2030## fixme: there's got to be a better way...
2031 $binfo = getBlockData($dbh, $args{block});
2032 if ($args{swip}) {
2033 if ($args{swip} eq 'on' || $args{swip} eq '1' || $args{swip} eq 'y') {
2034 $args{swip} = 'y';
2035 } else {
2036 $args{swip} = 'n';
2037 }
2038 }
2039 foreach ('type', 'swip') {
2040 if ($args{$_}) {
2041 push @fieldlist, $_;
2042 push @vallist, $args{$_};
2043 }
2044 }
2045 }
2046
2047 return ('FAIL', 'No fields to update') if !@fieldlist;
2048
2049 my $sql = "UPDATE $updtable SET ";
2050 $sql .= join " = ?, ", @fieldlist;
2051
2052 # create these here so we can use the expanded CIDR in the rDNS update after the eval,
2053 # if we're expanding the block into a "reserved" freeblock
2054 my $cidr = NetAddr::IP->new($binfo->{block});
2055 my $newblock = NetAddr::IP->new($cidr->addr, $cidr->masklen - 1)->network;
2056
2057 eval {
2058 # check for block merge first...
2059 if ($args{fbmerge}) {
2060 # safety net? make sure mergeable block passed in is really one or both of
2061 # a) reserved for expansion of the block and
2062 # b) confirmed CIDR-combinable
2063 # "safety? SELECT foo FROM freeblocks WHERE cidr << ? AND masklen(cidr) = ?, $newblock, ".$cidr->masklen."\n";
2064 $dbh->do("DELETE FROM freeblocks WHERE id=?", undef, $args{fbmerge});
2065 # ... so we can append the change in the stored CIDR field to extend the allocation.
2066 $sql .= " = ?, cidr";
2067 push @vallist, $newblock;
2068 # if we have an IP pool, call initPool to fill in any missing entries in the pool
2069 if ($binfo->{type} =~ /^.p$/) {
2070 my ($code,$rmsg) = initPool($dbh, "$newblock", $binfo->{type}, $binfo->{city}, 'all', $args{block});
2071 die $rmsg if $code eq 'FAIL';
2072 } elsif ($binfo->{type} =~ /^.d$/) {
2073 my ($code,$rmsg) = initPool($dbh, "$newblock", $binfo->{type}, $binfo->{city}, 'normal', $args{block});
2074 die $rmsg if $code eq 'FAIL';
2075 }
2076 }
2077
2078 # backup
2079 if (!defined($args{ignorebk})) {
2080 # backup data considered "restricted"; caller should set this flag if user does not have 's' permission
2081
2082 my $backupid = $binfo->{hasbk};
2083 if (!$binfo->{hasbk}) {
2084 if ($args{backup}) {
2085 # failure mode: backup data on netblock with no IP set
2086 if (!$args{bkip}) {
2087 # check for /32-ness. no point in skipping /32 "netblocks", because they already single IPs
2088 die "Backup data set on a netblock requires a backup IP\n" unless $binfo->{block} =~ m{/32$};
2089 $args{bkip} = $binfo->{block};
2090 }
2091 # insert new backup record since we don't have one
2092 my $bksql = "INSERT INTO backuplist (";
2093 my @bkfields;
2094 my @bkvals;
2095 for my $bk (@backupfields) {
2096 if ($args{"bk$bk"}) {
2097 push @bkfields, "bk$bk";
2098 push @bkvals, $args{"bk$bk"};
2099 }
2100 }
2101 $bksql .= join(',',@bkfields).") VALUES (".join(',', map {'?'} @bkfields).")";
2102 $dbh->do($bksql, undef, @bkvals);
2103 ($backupid) = $dbh->selectrow_array("SELECT currval('backuplist_backup_id_seq')");
2104 # add the backup ID to the update
2105 push @vallist, $backupid;
2106 $sql .= " = ?, backup_id";
2107 }
2108
2109 } else { # !$binfo->{hasbk}
2110
2111 # allocation already has backup data
2112 if ($args{backup}) {
2113 if (!$args{bkip}) {
2114 # check for /32-ness. no point in skipping /32 "netblocks", because they are already single IPs
2115 die "Backup data set on a netblock requires a backup IP\n" unless $binfo->{block} =~ m{/32$};
2116 $args{bkip} = $binfo->{block};
2117 }
2118 my @bkfields;
2119 my @bkvals;
2120 for my $bk (@backupfields) {
2121 no warnings qw( uninitialized );
2122 if ($binfo->{"bk$bk"} ne $args{"bk$bk"}) {
2123 push @bkfields, "bk$bk = ?";
2124 push @bkvals, $args{"bk$bk"};
2125 }
2126 }
2127
2128 $dbh->do("UPDATE backuplist SET ".join(',', @bkfields)." WHERE backup_id = ?",
2129 undef, @bkvals, $binfo->{hasbk})
2130 if @bkfields;
2131##todo: keep historic changes for $timeperiod, by adding a backref ID field, and on updates adding a new backup
2132# record instead of updating the existing one. should probably check if new==old so we don't do needless updates
2133# in that case...
2134 } else {
2135 if ($binfo->{hasbk}) {
2136 # had backup data, no longer checked - delete backup entry
2137 $dbh->do("DELETE FROM backuplist WHERE backup_id = ?", undef, $binfo->{hasbk});
2138 $sql .= " = ?, backup_id";
2139 push @vallist, 0;
2140 }
2141 }
2142 } # $binfo->{hasbk} defined
2143 } # if !args{ignorebk}
2144
2145 # append another SQL fragment
2146 push @vallist, $args{block};
2147 $sql .= " = ? WHERE $keyfield = ?";
2148
2149##fixme: don't do the update on pool IPs if the IP is available and assignIP_on_update is not set
2150 # do the update
2151 $dbh->do($sql, undef, @vallist);
2152
2153 if ($args{node}) {
2154 # done with delete/insert so we don't have to worry about funkyness updating a node ref that isn't there
2155 $dbh->do("DELETE FROM noderef WHERE block = ?", undef, ($binfo->{block}) );
2156 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($binfo->{block}, $args{node}) )
2157 if $args{node} ne '--';
2158 }
2159
2160 $dbh->commit;
2161 };
2162 if ($@) {
2163 my $msg = $@;
2164 $dbh->rollback;
2165 return ('FAIL', $msg);
2166 }
2167
2168 # Do RPC rDNS call, if available.
2169 # Snag the parent info
2170 my $pinfo = getBlockData($dbh, $binfo->{parent_id});
2171 # Return early if rDNS flag(s) are not set
2172 return ('OK','OK') unless ($pinfo->{revavail} || $pinfo->{revpartial});
2173
2174 # munge the reverse name to include the default domain if there are no dots. Don't append if
2175 # there's no DNS argument though, that would likely cause Big Problems
2176 $args{rdns} .= ".$IPDB::domain" if $IPDB::append_domain && $args{rdns} && $args{rdns} !~ /\./;
2177
2178 # In case of any container (mainly master block), only update freeblocks so we don't stomp subs
2179 # (which would be the wrong thing in pretty much any case except "DELETE ALL EVARYTHING!!1!oneone!")
2180 if ($binfo->{type} =~ '.[mc]') {
2181 # Not using listFree() as it doesn't return quite all of the blocks wanted.
2182 # Retrieve the immediate free blocks
2183 my $sth = $dbh->prepare(q(
2184 SELECT cidr FROM freeblocks WHERE parent_id = ?
2185 UNION
2186 SELECT cidr FROM freeblocks f WHERE
2187 cidr = (SELECT cidr FROM allocations a WHERE f.cidr = a.cidr)
2188 AND master_id = ?
2189 ) );
2190 $sth->execute($args{block}, $binfo->{master_id});
2191 my %fbset;
2192 while (my ($fb) = $sth->fetchrow_array) {
2193 $fbset{"host_$fb"} = $args{rdns};
2194 }
2195 # We use this RPC call instead of multiple addOrUpdateRevRec calls, since we don't
2196 # know how many records we'll be updating and more than 3-4 is far too slow. This
2197 # should be safe to call unconditionally.
2198 # Requires dnsadmin >= r678
2199 _rpc('updateRevSet', %fbset, rpcuser => $args{user}, location => $pinfo->{location});
2200
2201 } else {
2202 $binfo->{block} =~ s{/(?:32|128)$}{};
2203 # Only insert a record for IPv4, or actual single v6 IPs
2204 _rpc('addOrUpdateRevRec', cidr => $binfo->{block}, name => $args{rdns}, rpcuser => $args{user},
2205 location => $pinfo->{location})
2206 if !$cidr->{isv6} || ($cidr->{isv6} && $cidr->masklen == 128);
2207
2208 # and the per-IP set, if there is one.
2209 _rpc('updateRevSet', cidr => $binfo->{block}, %{$args{iprev}}, rpcuser => $args{user},
2210 location => $pinfo->{location})
2211 if keys (%{$args{iprev}});
2212
2213 # and fix up the template's CIDR if required
2214 _rpc('resizeTemplate', oldcidr => "$binfo->{block}", newcidr => $newblock->network.'',
2215 rpcuser => $args{user}, location => $pinfo->{location})
2216 if $args{fbmerge};
2217 }
2218
2219##fixme: RPC failures?
2220 return ('OK','OK');
2221} # end updateBlock()
2222
2223
2224## IPDB::splitBlock()
2225# Splits an existing allocation into two or more smaller allocations based on a passed netmask
2226# Duplicates all other data
2227# Returns an arrayref to a list of hashrefs with ID and CIDR keys for the list of new allocations.
2228# Should probably commit DNS magic to realign DNS data
2229# Mostly works but may return Strange Things(TM) if used on a master block
2230sub splitBlock {
2231 my $dbh = shift;
2232 my %args = @_;
2233
2234##fixme: set errstr on errors so caller can suitably clue-by-four the user
2235 return if $args{basetype} ne 'b'; # only netblocks allowed!
2236
2237 my $binfo = getBlockData($dbh, $args{id});
2238 return if !$binfo;
2239
2240 return if $args{newmask} !~ /^\d+$/;
2241
2242 my @ret;
2243 my $block = new NetAddr::IP $binfo->{block};
2244 my $oldmask = $block->masklen;
2245
2246 # Fail if the block to split is "too small" - eg, can't split a v4 /32 at all
2247 # failure modes:
2248 # difference between $oldmask and $newmask is negative or 0
2249 if ($args{newmask} - $oldmask <= 0) {
2250 $errstr = "Can't split a /$oldmask allocation into /$args{newmask} pieces";
2251 return;
2252 }
2253# # difference between $oldmask and $newmask is > n, for arbitrary n?
2254# if ($newmask - $oldmask > 42) { # because 42
2255# }
2256 # $oldmask > n, for arbitrary n? At least check limits of data type.
2257 if ($block->{isv6}) {
2258 if ($args{newmask} - $oldmask > 128) {
2259 $errstr = "Impossible IPv6 mask length /$args{newmask} requested";
2260 return;
2261 }
2262 } else {
2263 if ($args{newmask} - $oldmask > 32) {
2264 $errstr = "Impossible IPv4 mask length /$args{newmask} requested";
2265 return;
2266 }
2267 }
2268
2269 my @newblocks = $block->split($args{newmask});
2270
2271 local $dbh->{AutoCommit} = 0;
2272 local $dbh->{RaiseError} = 1;
2273
2274 eval {
2275 # line up a list of fields and values. Be nice if there was a handy way to do,
2276 # direct in SQL, something like
2277 # "INSERT INTO foo (f1,f2,f3) VALUES (newf1,(SELECT oldf2,oldf3 FROM foo WHERE baz))"
2278 my @fieldlist = qw(type city description notes circuitid privdata custid swip vrf vlan rdns parent_id master_id);
2279 my $fields_sql = join(',', @fieldlist);
2280 my @vals;
2281 foreach (@fieldlist) {
2282 push @vals, $binfo->{$_};
2283 }
2284 # note the first block in the split for return
2285 push @ret, {nid => $args{id}, nblock => "$newblocks[0]"};
2286
2287 # prepare
2288 my $idsth = $dbh->prepare("SELECT currval('allocations_id_seq')");
2289 my $allocsth = $dbh->prepare("INSERT INTO allocations (cidr, $fields_sql)".
2290 " VALUES (?".',?'x(scalar(@fieldlist)).")");
2291 my $allocsth2 = $dbh->prepare(qq(
2292 INSERT INTO allocations (cidr, $fields_sql)
2293 SELECT ? AS cidr, $fields_sql
2294 FROM allocations
2295 WHERE id = ?
2296 ) );
2297 my $nbsth = $dbh->prepare("DELETE FROM poolips WHERE parent_id = ? AND ip = ?");
2298 my $upd_psth = $dbh->prepare("UPDATE allocations SET parent_id = ? WHERE parent_id = ? AND cidr <<= ?");
2299 my $upd_msth = $dbh->prepare("UPDATE allocations SET master_id = ? WHERE master_id = ? AND cidr <<= ?");
2300 my $fb_psth = $dbh->prepare("UPDATE freeblocks SET parent_id = ? WHERE parent_id = ? AND cidr <<= ?");
2301 my $fb_msth = $dbh->prepare("UPDATE freeblocks SET master_id = ? WHERE master_id = ? AND cidr <<= ?");
2302 my $pool_psth = $dbh->prepare("UPDATE poolips SET parent_id = ? WHERE parent_id = ? AND ip << ?");
2303 my $pool_msth = $dbh->prepare("UPDATE poolips SET master_id = ? WHERE master_id = ? AND ip <<= ?");
2304
2305 my @clist;
2306 _getChildren($dbh, $args{id}, $binfo->{master_id}, \@clist, $block);
2307
2308 my @processlist;
2309 push @processlist, { id => $args{id}, cidr => $block, mask => $block->masklen, type => $binfo->{type} };
2310 foreach (@clist) {
2311 $_->{cidr} = new NetAddr::IP $_->{cidr};
2312 if ($_->{cidr}->masklen < $args{newmask}) {
2313 $_->{mask} = $_->{cidr}->masklen;
2314 push @processlist, $_;
2315 }
2316 }
2317
2318 # Sort on masklen, crudely break ties by pushing container blocks down the stack. Multiple-nested containers
2319 # of the same size are virtually guaranteed to produce strange results, but should be rare enough to not matter
2320 @processlist = sort { $b->{cidr}->masklen <=> $a->{cidr}->masklen || $a->{type} =~ /^.m$/ } @processlist;
2321
2322 foreach my $pr (@processlist) {
2323 my @nbset = $pr->{cidr}->split($args{newmask});
2324
2325 # update existing block
2326 $dbh->do("UPDATE allocations SET cidr = ? WHERE id = ?", undef, ("$nbset[0]", $pr->{id}) );
2327
2328 # axe the new bcast IP from the smaller pool at the "base" block, if it's a "normal" pool
2329 if ($pr->{type} =~ /.d/) {
2330 $nbset[0]--;
2331 $nbsth->execute($pr->{id}, $nbset[0]->addr);
2332 }
2333
2334 # Holder for freeblocks-to-delete. Should be impossible to have more than one...
2335 my %fbdel;
2336
2337 # Loop over the new blocks that are not the base block
2338 for (my $i = 1; $i <= $#nbset; $i++) {
2339 # add the new allocation
2340 $allocsth2->execute($nbset[$i], $pr->{id});
2341
2342 # fetch the ID of the entry we just added...
2343 $idsth->execute();
2344 my ($nid) = $idsth->fetchrow_array();
2345 # ... so we can pass back the list of blocks and IDs...
2346 push @ret, {nid => $nid, nblock => "$nbset[$i]"};
2347 # axe the net, gw, and bcast IPs as necessary when splitting a "normal" pool
2348 if ($pr->{type} =~ /.d/) {
2349 # net
2350 $nbsth->execute($pr->{id}, $nbset[$i]->addr);
2351 $nbset[$i]++;
2352 # gw
2353 $nbsth->execute($pr->{id}, $nbset[$i]->addr);
2354 $nbset[$i]--;
2355 $nbset[$i]--;
2356 # bcast
2357 $nbsth->execute($pr->{id}, $nbset[$i]->addr);
2358 $nbset[$i]++;
2359 } # $binfo->{type} =~ /.d/
2360
2361 # Check for free blocks larger than the new mask length, and split those as needed.
2362 if ($pr->{type} =~ /.[cm]/) {
2363 # get a "list" of freeblocks bigger than the allocation in the parent. there's only one, right?
2364 my $fblist = $dbh->selectall_arrayref("SELECT id FROM freeblocks WHERE cidr >> ? AND parent_id = ? ",
2365 {Slice=>{}}, $nbset[$i], $pr->{id});
2366 if (@$fblist) {
2367 # create a new freeblock for the new block we created earlier
2368 $dbh->do(q{
2369 INSERT INTO freeblocks (cidr, parent_id, master_id, city, routed,vrf)
2370 SELECT ? AS cidr, ? AS parent_id, master_id, city, routed, vrf FROM freeblocks
2371 WHERE id = ?
2372 }, undef, ($nbset[$i], $nid, $fblist->[0]->{id}) );
2373 $fbdel{$fblist->[0]->{id}}++;
2374 }
2375 } # $binfo->{type} =~ /.[cm]/
2376
2377 # Reparent allocations, freeblocks, and pool IPs.
2378 $upd_psth->execute($nid, $pr->{id}, $nbset[$i]);
2379 $fb_psth->execute($nid, $pr->{id}, $nbset[$i]);
2380 $pool_psth->execute($nid, $pr->{id}, $nbset[$i]);
2381
2382 # Update master if we've split a master block
2383 if ($pr->{type} eq 'mm') {
2384 $upd_msth->execute($nid, $pr->{id}, $nbset[$i]);
2385 $fb_msth->execute($nid, $pr->{id}, $nbset[$i]);
2386 $pool_msth->execute($nid, $pr->{id}, $nbset[$i]);
2387 }
2388
2389##fixme:
2390# 2015/09/09 not sure if the latest rewrite has covered this case complete or not
2391# Still missing one edge case - megasplitting a large block such that "many" children also need to be split.
2392# I'm going to call this "unsupported" because I really can't imagine a sane reason for doing this.
2393# Should probably check and error out at least
2394
2395 } # for (... @nbset)
2396
2397 if (%fbdel) {
2398 # pretty sure this SELECT result isn't used...
2399 my $delfblist = $dbh->selectall_arrayref(q{
2400 SELECT cidr,parent_id,id FROM freeblocks
2401 WHERE id in (
2402 }.join(',', keys %fbdel).")", {Slice=>{}} );
2403 foreach my $fbd (keys %fbdel) {
2404 $dbh->do("UPDATE freeblocks SET cidr = set_masklen(cidr, ?) WHERE id = ?", undef, $args{newmask}, $fbd);
2405 }
2406 }
2407
2408 } # foreach @processlist
2409
2410 $dbh->commit;
2411 };
2412 if ($@) {
2413 $errstr = "Error splitting $binfo->{block}: $@";
2414 $dbh->rollback;
2415 return;
2416 }
2417
2418 # Only try to update rDNS when the original block is flagged as "rDNS available"
2419 _rpc('splitTemplate', cidr => $binfo->{block}, newmask => $args{newmask}, rpcuser => $args{user},
2420 location => $binfo->{location})
2421 if ($binfo->{revavail} || $binfo->{revpartial});
2422
2423 return \@ret;
2424} # end splitBlock()
2425
2426
2427## IPDB::shrinkBlock()
2428# Shrink an allocation to the passed CIDR block
2429# Takes an allocation ID and a new CIDR
2430# Returns an arrayref to a list of hashrefs with the ID and CIDR of the freed block(s)
2431# Refuses to shrink "real netblock" pool types below /30
2432sub shrinkBlock {
2433 my $dbh = shift;
2434 my $id = shift;
2435
2436 # just take the new CIDR spec; this way we can shrink eg .16/28 to .20/30 without extra contortions
2437 my $newblock = new NetAddr::IP shift;
2438
2439 my $user = shift;
2440
2441 if (!$newblock) {
2442 $errstr = "Can't shrink something that's not a netblock";
2443 return;
2444 }
2445
2446 my $binfo = getBlockData($dbh, $id);
2447 my $pinfo = getBlockData($dbh, $binfo->{parent_id});
2448
2449 if ($binfo->{type} =~ /.d/ && $newblock->masklen > ($newblock->bits+2) ) {
2450 $errstr = "Can't shrink a non-PPP pool smaller than ".($newblock->{isv6} ? '/124' : '/30');
2451 return;
2452 }
2453
2454 my $oldblock = new NetAddr::IP $binfo->{block};
2455
2456 # Don't try to shrink the block outside of itself, Bad Things (probably) Happen.
2457 if (!$oldblock->contains($newblock)) {
2458 $errstr = "Can't shrink an allocation outside of itself";
2459 return;
2460 }
2461
2462 local $dbh->{AutoCommit} = 0;
2463 local $dbh->{RaiseError} = 1;
2464
2465 my $addfbsth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)");
2466 my $idsth = $dbh->prepare("SELECT currval('freeblocks_id_seq')");
2467 my $poolsth = $dbh->prepare("DELETE FROM poolips WHERE parent_id = ? AND ip << ?");
2468 my $netsth = $dbh->prepare("DELETE FROM poolips WHERE parent_id = ? AND ip = ?");
2469 my $allocsth = $dbh->prepare("DELETE FROM allocations WHERE parent_id = ? AND cidr <<= ?");
2470 my $delfbsth = $dbh->prepare("DELETE FROM freeblocks WHERE parent_id = ? AND cidr <<= ?");
2471
2472 my @ret;
2473 my @newfreelist;
2474 eval {
2475 $dbh->do("UPDATE allocations SET cidr = ? WHERE id = ?", undef, $newblock, $id);
2476
2477 # find the netblock(s) that are now free
2478 my @workingblocks = $oldblock->split($newblock->masklen);
2479 foreach my $newsub (@workingblocks) {
2480 next if $newsub == $newblock;
2481 push @newfreelist, $newsub;
2482 }
2483 @newfreelist = Compact(@newfreelist);
2484
2485 # set new freeblocks, and clean up any IP pool entries if needed.
2486 foreach my $newfree (@newfreelist) {
2487 my @clist;
2488 # the block we're munging
2489 push @clist, { id => $id, type => $binfo->{type}, cidr => $binfo->{block} };
2490 _getChildren($dbh, $id, $binfo->{master_id}, \@clist, $newfree);
2491
2492 foreach my $goner (@clist) {
2493 $poolsth->execute($goner->{id}, $newfree) if $goner->{type} =~ /.[dp]/;
2494 $allocsth->execute($goner->{id}, $newfree);
2495 $delfbsth->execute($goner->{id}, $newfree);
2496 }
2497
2498 # No pinfo means we're shrinking a master block, which means the free space is returned outside of IPDB.
2499 if ($pinfo) {
2500 $addfbsth->execute($newfree, $pinfo->{city}, 'm', $pinfo->{vrf}, $binfo->{parent_id}, $pinfo->{master_id});
2501 $idsth->execute;
2502 my ($nid) = $idsth->fetchrow_array();
2503 # add to return list
2504 push @ret, {fbid => $nid, newfree => "$newfree", fbparent => $binfo->{parent_id} };
2505 }
2506
2507 } # $newfree (@newfreelist)
2508
2509 # additional cleanup on net/gw/bcast IPs in pool
2510 if ($binfo->{type} =~ /.d/) {
2511 $netsth->execute($id, $newblock->addr);
2512 $newblock++;
2513 $netsth->execute($id, $newblock->addr);
2514 $newblock--;
2515 $newblock--;
2516 $netsth->execute($id, $newblock->addr);
2517 }
2518
2519 $dbh->commit;
2520 };
2521 if ($@) {
2522 $errstr = "Error splitting $binfo->{block}: $@";
2523 $dbh->rollback;
2524 return;
2525 }
2526
2527 # Only try to update rDNS when the original block is flagged as "rDNS available"
2528 _rpc('resizeTemplate', oldcidr => $binfo->{block}, newcidr => $newblock->network, rpcuser => $user,
2529 location => $binfo->{location})
2530 if ($binfo->{revavail} || $binfo->{revpartial});
2531
2532 return \@ret;
2533} # end shrinkBlock()
2534
2535
2536## IPDB::mergeBlocks()
2537# Merges two or more adjacent allocations, optionally including relevant
2538# free space, into one allocation.
2539# Takes a "base" block ID and a hash with a mask length and a scope argument to decide
2540# how much existing allocation data to delete.
2541# Returns a list starting with the new merged block, then the merged allocations with comment
2542## Merge scope:
2543# Merge to container
2544# keepall
2545# Move all mergeable allocations into the new block
2546# Move all mergeable free blocks into the new block
2547# mergepeer
2548# Move subs of mergeable containers into the updated primary.
2549# Reparent free blocks in mergeable containers to the updated primary.
2550# Convert assigned IPs from pools into subs.
2551# Convert unused IPs from pools into free blocks.
2552# Convert leaf allocations into free blocks.
2553# clearpeer
2554# Keep subs of the original (if it was a container).
2555# Convert assigned IPs from the original pool into subs (if it was a pool).
2556# Convert unused IPs from the original pool into free blocks (if it was a pool).
2557# Delete all peers and their subs aside from the original.
2558# clearall
2559# Delete all peers, subs and IPs.
2560# Add single free block for new container.
2561# Merge to pool
2562# keepall
2563# Convert all leaf allocations in the merge range to groups of used IPs
2564# mergepeer
2565# Effectively equal to keepall
2566# clearpeer
2567# Only convert IPs from the original allocation to used IPs
2568# clearall
2569# Delete any existing IPs, and reinitialize the new pool entirely
2570# Merge to leaf type
2571# Remove all subs
2572sub mergeBlocks {
2573 my $dbh = shift;
2574 my $prime = shift; # "base" block ID to use as a starting point
2575 if (!$prime) {
2576 $errstr = "Missing block ID to base merge on";
2577 return;
2578 }
2579
2580 my %args = @_;
2581
2582 # check key arguments.
2583 if (!$args{scope} || $args{scope} !~ /^(keepall|mergepeer|clearpeer|clearall)$/) {
2584 $errstr = "Bad or missing merge scope";
2585 return;
2586 }
2587 if (!$args{newmask} || $args{newmask} !~ /^\d+$/) {
2588 $errstr = "Bad or missing new netmask";
2589 return;
2590 }
2591
2592 # Retrieve info about the base allocation we're munging
2593 my $binfo = getBlockData($dbh, $prime);
2594 my $block = new NetAddr::IP $binfo->{block};
2595 my ($basetype) = ($binfo->{type} =~ /^.(.)$/);
2596 $binfo->{id} = $prime; # preserve for later, just in case
2597
2598 # proposed block
2599 my $newblock = new NetAddr::IP $block->addr."/$args{newmask}";
2600 $newblock = $newblock->network;
2601 $args{newtype} = $binfo->{type} if !$args{newtype};
2602 # if the "primary" block being changed is a master, it must remain one.
2603 # Also force the scope, since otherwise things get ugly.
2604 if ($binfo->{type} eq 'mm') {
2605 $args{newtype} = 'mm';
2606 # don't want to make a peer master a sub of the existing one; too many special cases go explodey,
2607 # but want to retain all other allocations
2608 $args{scope} = 'mergepeer';
2609 }
2610 my ($newcontainerclass) = ($args{newtype} =~ /^(.).$/);
2611
2612 # build an info hash for the "new" allocation we're creating
2613 my $pinfo = {
2614 id => $prime,
2615 block => "$newblock",
2616 type => $args{newtype},
2617 parent_id =>
2618 $binfo->{parent_id},
2619 city => $binfo->{city},
2620 vrf => $binfo->{vrf},
2621 master_id => $binfo->{master_id}
2622 };
2623
2624 my @retlist;
2625
2626 local $dbh->{AutoCommit} = 0;
2627 local $dbh->{RaiseError} = 1;
2628
2629 # Want to do all of the DB stuff in a transaction, to minimize data changing underfoot
2630 eval {
2631
2632 # We always update the "prime" block passed in...
2633 my $updsth = $dbh->prepare("UPDATE allocations SET cidr = ?, type = ? WHERE id = ?");
2634
2635##fixme: There's still an edge case in the return list where some branches accidentally include
2636# the original block as "additional". Probably due to the ordering of when the prepared update
2637# above gets executed.
2638
2639 # For leaf blocks, we may need to create a new parent as the "primary" instead
2640 # of updating the existing block
2641 my $newparent = $dbh->prepare(q{
2642 INSERT INTO allocations (
2643 cidr, type, city, description, notes, circuitid, createstamp, modifystamp,
2644 privdata, custid, swip, vrf, vlan, rdns, parent_id, master_id
2645 )
2646 SELECT
2647 ? AS cidr, ? AS type, city, description, notes, circuitid, createstamp, modifystamp,
2648 privdata, custid, swip, vrf, vlan, rdns, parent_id, master_id
2649 FROM allocations
2650 WHERE id = ?
2651 });
2652
2653 # Common actions
2654 my $peersth = $dbh->prepare("SELECT cidr,id,type,master_id FROM allocations WHERE parent_id = ? AND cidr <<= ?");
2655 $peersth->execute($binfo->{parent_id}, "$newblock");
2656 my $reparentsth = $dbh->prepare("UPDATE allocations SET parent_id = ?, master_id = ? WHERE id = ?");
2657 my $insfbsth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)");
2658 my $delsth = $dbh->prepare("DELETE FROM allocations WHERE id = ?");
2659
2660 my $fbreparentsth = $dbh->prepare(q{
2661 UPDATE freeblocks
2662 SET parent_id = ?, master_id = ?, city = ?, routed = ?, vrf = ?
2663 WHERE parent_id = ? AND cidr <<= ?
2664 });
2665
2666 if ($args{newtype} =~ /.[cm]/) {
2667 ## Container
2668
2669 # In case of merging a master block. Somewhat redundant with calls to $fbreparentsth,
2670 # but not *quite* entirely.
2671 my $mfbsth = $dbh->prepare("UPDATE freeblocks SET master_id = ? WHERE master_id = ?");
2672
2673 if ($args{scope} eq 'keepall') {
2674 # Create a new parent with the same info as the passed "primary".
2675 $newparent->execute($newblock, $args{newtype}, $prime);
2676 # and now retrieve the new parent ID
2677 ($prime) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
2678 # snag the new parent info for the return list
2679 push @retlist, { block => "$newblock", type => $disp_alloctypes{$args{newtype}}, id => $prime };
2680 # Reparent the free blocks in the new block
2681 $fbreparentsth->execute($prime, $binfo->{master_id}, $binfo->{city}, $newcontainerclass, $binfo->{vrf},
2682 $binfo->{parent_id}, $newblock);
2683 # keep existing allocations (including the original primary), just push them down a level
2684 while (my ($peercidr, $peer_id, $peertype, $m_id) = $peersth->fetchrow_array) {
2685 $reparentsth->execute($prime, $binfo->{master_id}, $peer_id);
2686 # Fix up master_id on free blocks if we're merging a master block
2687 $mfbsth->execute($binfo->{master_id}, $m_id) if $peertype eq 'mm';
2688 # capture block for return
2689 push @retlist, { block => $peercidr, mdisp => $disp_alloctypes{$peertype}, mtype => $peertype };
2690 }
2691
2692 } elsif ($args{scope} =~ /^clear/) {
2693 # clearpeer and clearall share a starting point
2694 # snag the new parent info for the return list
2695 push @retlist, { block => "$newblock", type => $disp_alloctypes{$args{newtype}}, id => $prime };
2696 # update the primary allocation info
2697 $updsth->execute($newblock, $args{newtype}, $prime);
2698 # Reparent the free blocks in the new block
2699 $fbreparentsth->execute($prime, $binfo->{master_id}, $binfo->{city}, $newcontainerclass, $binfo->{vrf},
2700 $binfo->{parent_id}, $newblock);
2701 # Insert a free block if $prime is a leaf
2702 if ($binfo->{type} =~ /.[enr]/) {
2703 $insfbsth->execute($binfo->{block}, $binfo->{city}, $newcontainerclass, $binfo->{vrf}, $prime,
2704 $binfo->{master_id});
2705 }
2706 # delete the peers.
2707 while (my ($peercidr, $peer_id, $peertype, $m_id) = $peersth->fetchrow_array) {
2708 next if $peer_id == $prime;
2709 # push existing allocations down a level before deleting,
2710 # so that when they're deleted the parent info is correct
2711 $reparentsth->execute($prime, $binfo->{master_id}, $peer_id);
2712 _deleteCascade($dbh, $peer_id);
2713 # insert the freeblock _deleteCascade() (deliberately) didn't when deleting a master block.
2714 # aren't special cases fun?
2715 $dbh->do("INSERT INTO freeblocks (cidr,routed,parent_id,master_id) values (?,?,?,?)",
2716 undef, ($peercidr, 'm', $prime, $prime) ) if $binfo->{type} eq 'mm';
2717 # capture block for return
2718 push @retlist, { block => $peercidr, mdisp => $disp_alloctypes{$peertype}, mtype => $peertype };
2719 }
2720 if ($args{scope} eq 'clearall') {
2721 # delete any subs of $prime as well
2722 my $substh = $dbh->prepare("SELECT cidr,id FROM allocations WHERE parent_id = ?");
2723 $substh->execute($prime);
2724 while (my ($scidr, $s_id) = $substh->fetchrow_array) {
2725 _deleteCascade($dbh, $s_id);
2726 }
2727 } else {
2728 # clearpeer
2729 if ($basetype =~ /[dp]/) {
2730 # Convert active IP pool entries to allocations if the original was an IP pool
2731 _poolToAllocations($dbh, $binfo, $pinfo, newtype => $poolmap{$binfo->{type}});
2732 }
2733 } # clearall or clearpeer
2734
2735 } elsif ($args{scope} eq 'mergepeer') { # should this just be an else?
2736 # Default case. Merge "peer" blocks, but keep all suballocations
2737 # snag the new parent info for the return list
2738 push @retlist, {block => "$newblock", type => $disp_alloctypes{$args{newtype}}, id => $prime};
2739 my $substh = $dbh->prepare("UPDATE allocations SET parent_id = ? WHERE parent_id = ?");
2740 my $delsth = $dbh->prepare("DELETE FROM allocations WHERE id = ?");
2741 # Reparent freeblocks in parent
2742 $fbreparentsth->execute($prime, $binfo->{master_id}, $binfo->{city}, $newcontainerclass, $binfo->{vrf},
2743 $binfo->{parent_id}, $newblock);
2744 # Loop over "peer" allocations to be merged
2745 while (my ($peercidr, $peer_id, $peertype, $m_id) = $peersth->fetchrow_array) {
2746 # Snag existing peer data since we may need it
2747 my $peerfull = getBlockData($dbh, $peer_id);
2748 # Reparent free blocks from existing containers
2749 $fbreparentsth->execute($prime, $binfo->{master_id}, $binfo->{city}, $newcontainerclass,
2750 $binfo->{vrf}, $peer_id, $newblock);
2751 # Reparent any subblocks from existing containers
2752 $substh->execute($prime, $peer_id);
2753 # Delete the old container
2754 $delsth->execute($peer_id) unless $peer_id == $prime;
2755 # Add new freeblocks for merged leaf blocks
2756 $insfbsth->execute($peercidr, $binfo->{city}, $newcontainerclass, $binfo->{vrf}, $binfo->{id},
2757 $binfo->{master_id}) if $peertype =~ /.[enr]/;
2758 # Convert pool IPs into allocations or aggregated free blocks
2759 _poolToAllocations($dbh, $peerfull, $pinfo, newparent => $prime) if $peertype =~ /.[dp]/;
2760 # Fix up master_id on free blocks if we're merging a master block
2761 $mfbsth->execute($binfo->{master_id}, $m_id) if $peertype eq 'mm';
2762 # capture block for return
2763 push @retlist, { block => $peercidr, mdisp => $disp_alloctypes{$peertype}, mtype => $peertype };
2764 } # merge peers
2765 # update the primary allocation info. Do this last so we don't stomp extra data-retrieval in the loop above
2766 $updsth->execute($newblock, $args{newtype}, $prime);
2767
2768 } # scope
2769
2770 # Clean up free blocks
2771 _compactFree($dbh, $prime);
2772
2773 } elsif ($args{newtype} =~ /.[dp]/) {
2774 ## Pool
2775 # Snag the new parent info for the return list
2776 push @retlist, { block => "$newblock", type => $disp_alloctypes{$args{newtype}}, id => $prime };
2777
2778 if ($args{scope} eq 'keepall') {
2779 # Convert all mergeable allocations and subs to chunks of pool IP assignments
2780 push @retlist, @{ _toPool($dbh, $prime, $newblock, $args{newtype}, 1) };
2781
2782 } elsif ($args{scope} =~ /^clear/) {
2783 # Clear it all out for a fresh (mostly?) empty IP pool
2784 while (my ($peercidr, $peer_id, $peertype, $m_id) = $peersth->fetchrow_array) {
2785 next if $peer_id == $prime;
2786 # Push existing allocations down a level before deleting,
2787 # so that when they're deleted the parent info is correct
2788 $reparentsth->execute($prime, $binfo->{master_id}, $peer_id);
2789 _deleteCascade($dbh, $peer_id, 0);
2790 # Capture block for return
2791 push @retlist, { block => $peercidr, mdisp => $disp_alloctypes{$peertype}, mtype => $peertype };
2792 }
2793 if ($args{scope} eq 'clearall') {
2794 # Delete any subs of $prime as well
2795 my $substh = $dbh->prepare("SELECT cidr,id FROM allocations WHERE parent_id = ?");
2796 $substh->execute($prime);
2797 while (my ($scidr, $s_id) = $substh->fetchrow_array) {
2798 _deleteCascade($dbh, $s_id);
2799 }
2800 } else {
2801 # Convert (subs of) self if not a leaf.
2802 push @retlist, @{ _toPool($dbh, $prime, $newblock, $args{newtype}, 1) }
2803 unless $binfo->{type} =~ /.[enr]/;
2804 } # scope ne 'clearall'
2805
2806 } elsif ($args{scope} eq 'mergepeer') {
2807 # Try to match behaviour from (target type == container) by deleting immediate peer leaf allocations
2808 while (my ($peercidr, $peer_id, $peertype, $m_id) = $peersth->fetchrow_array) {
2809 next if $peer_id == $prime; # don't delete the block we're turning into the pool allocation
2810 # Capture block for return
2811 push @retlist, { block => $peercidr, mdisp => $disp_alloctypes{$peertype}, mtype => $peertype };
2812 next unless $peertype =~ /.[enr]/;
2813 # Don't need _deleteCascade(), since we'll just be deleting the freshly
2814 # added free block a little later anyway
2815 $delsth->execute($peer_id);
2816 }
2817 # Convert self if not a leaf, to match behaviour with a container type as target
2818 _toPool($dbh, $prime, $newblock, $args{newtype}) unless $binfo->{type} =~ /.[enr]/;
2819 }
2820 # Update the primary allocation info.
2821 $updsth->execute($newblock, $args{newtype}, $prime);
2822 # Delete any lingering free blocks
2823 $dbh->do("DELETE FROM freeblocks WHERE parent_id = ? AND cidr <<= ?", undef, $binfo->{parent_id}, $newblock);
2824 # Fix up the rest of the pool IPs
2825 my ($code,$msg) = initPool($dbh, $newblock, $args{newtype}, $binfo->{city},
2826 ($args{newtype} =~ /.p/ ? 'all' : 'normal'), $prime);
2827
2828 } elsif ($args{newtype} =~ /.[enr]/) {
2829 ## Leaf
2830 # Merging to a leaf type of any kind is, pretty much be definition, scope == 'clearall'.
2831 # keepall, mergepeer, and clearpeer all imply keeping suballocations, where leaf allocations
2832 # by definition do not have suballocations.
2833 # Update the old allocation
2834 $updsth->execute($newblock, $args{newtype}, $prime);
2835 # Snag the new parent info for the return list
2836 push @retlist, {block => "$newblock", type => $disp_alloctypes{$args{newtype}}, id => $prime};
2837 while (my ($peercidr, $peer_id, $peertype, $m_id) = $peersth->fetchrow_array) {
2838 next if $peer_id == $prime;
2839 # Push existing allocations down a level before deleting,
2840 # so that when they're deleted the parent info is correct
2841 $reparentsth->execute($prime, $binfo->{master_id}, $peer_id);
2842 _deleteCascade($dbh, $peer_id, 0);
2843 # Capture block for return
2844 push @retlist, { block => $peercidr, mdisp => $disp_alloctypes{$peertype}, mtype => $peertype };
2845 }
2846 # Delete any subs of $prime as well
2847 my $substh = $dbh->prepare("SELECT cidr,id FROM allocations WHERE parent_id = ?");
2848 $substh->execute($prime);
2849 while (my ($scidr, $s_id) = $substh->fetchrow_array) {
2850 _deleteCascade($dbh, $s_id);
2851 }
2852 # Clean up lingering free blocks and pool IPs
2853 $dbh->do("DELETE FROM freeblocks WHERE cidr <<= ? AND (parent_id = ? OR parent_id = ?)", undef,
2854 $newblock, $binfo->{parent_id}, $prime);
2855 $dbh->do("DELETE FROM poolips WHERE parent_id = ? AND ip <<= ? ", undef,
2856 $prime, $newblock);
2857
2858 } # $args{newtype} if()
2859
2860 $dbh->commit;
2861 };
2862 if ($@) {
2863 my $msg = $@;
2864 $errstr = $msg;
2865 $dbh->rollback;
2866 return ('FAIL',$msg);
2867 }
2868
2869# Make the assumption that any change crossing /24 or /16 boundaries will not come out right. Reverse DNS
2870# updates for this operation are already complex enough without handling those edge cases.
2871# ... er, how do we detect this?
2872
2873 # Return early if the block wasn't flagged as rDNS-able
2874 return \@retlist unless $binfo->{revavail} || $binfo->{revpartial};
2875
2876 if ($args{newtype} =~ /.[cm]/) {
2877
2878 if ($args{scope} eq 'keepall') {
2879 # Add new rDNS for new container
2880 _rpc('addOrUpdateRevRec', cidr => $binfo->{block}, name => $binfo->{rdns}, rpcuser => $args{user},
2881 location => $binfo->{location});
2882
2883 } else {
2884 # Resize rDNS template for $prime
2885 _rpc('resizeTemplate', oldcidr => "$binfo->{block}", newcidr => $newblock->network.'',
2886 rpcuser => $args{user}, location => $binfo->{location});
2887
2888 # Assemble a list of blocks to delete...
2889 my $cidrlist;
2890 foreach my $mblock (@retlist) {
2891 $cidrlist .= $mblock->{block}."," unless $mblock->{block} =~ $newblock;
2892 }
2893
2894 # ... then make slight variant batch delete calls depending on the merge scope
2895 if ($args{scope} eq 'mergepeer') {
2896 # Delete separate rDNS for other peers
2897 $cidrlist =~ s/,$//;
2898 _rpc('delRevSet', cidrlist => $cidrlist, rpcuser => $args{user}, delforward => 'y', delsubs => 'n',
2899 parpatt => $pinfo->{rdns}, location => $binfo->{location});
2900
2901 } elsif ($args{scope} eq 'clearpeer') {
2902 # Delete all rDNS within other peers
2903 $cidrlist =~ s/,$//;
2904 _rpc('delRevSet', cidrlist => $cidrlist, rpcuser => $args{user}, delforward => 'y', delsubs => 'y',
2905 parpatt => $pinfo->{rdns}, location => $binfo->{location});
2906
2907 } elsif ($args{scope} eq 'clearall') {
2908 # Delete all other records within the new block
2909 $cidrlist .= $binfo->{block};
2910 _rpc('delRevSet', cidrlist => $cidrlist, rpcuser => $args{user}, delforward => 'y', delsubs => 'y',
2911 parpatt => $pinfo->{rdns}, location => $binfo->{location});
2912
2913 } # scope, second level
2914 } # scope, !keepall
2915
2916 } elsif ($args{newtype} =~ /.[dp]/) {
2917 # Merge to pool
2918
2919 # Resize rDNS template for $prime
2920 _rpc('resizeTemplate', oldcidr => "$binfo->{block}", newcidr => $newblock->network.'',
2921 rpcuser => $args{user}, location => $binfo->{location});
2922
2923 if ($args{scope} eq 'keepall' || $args{scope} eq 'mergepeer') {
2924 # Assemble a list of blocks to convert from template to individual records...
2925 my @convlist;
2926 my @dellist;
2927 foreach my $mblock (@retlist) {
2928 next if $mblock->{block} =~ $newblock;
2929 if ($mblock->{mtype} =~ /.[cmdp]/) {
2930 # Container and pool templates get deleted
2931 push @dellist, $mblock->{block};
2932 } else {
2933 # Not-containers get converted to per-IP reverse records
2934 push @convlist, $mblock->{block};
2935 }
2936 }
2937 # And do the calls.
2938 _rpc('delRevSet', cidrlist => join(',', @dellist), rpcuser => $args{user}, delforward => 'y', delsubs => 'n',
2939 parpatt => $pinfo->{rdns}, location => $binfo->{location});
2940 _rpc('templatesToRecords', templates => \@convlist, rpcuser => $args{user}, location => $binfo->{location});
2941
2942 } # scope eq 'keepall' || 'mergepeer'
2943 else {
2944
2945 # Assemble a list of blocks to convert from template to individual records...
2946 my @convlist;
2947 my @dellist;
2948 my @fulldellist;
2949# There may be an impossible edge case that can be optimized away in here...
2950 foreach my $mblock (@retlist) {
2951 my $checkcidr = new NetAddr::IP $mblock->{block};
2952 next if $mblock->{block} =~ $newblock;
2953 if (!$block->contains($checkcidr)) {
2954 # Blocks not within the original get deleted
2955 push @fulldellist, $mblock->{block};
2956 }
2957 elsif ($mblock->{mtype} =~ /.[cmdp]/) {
2958 # Containers and pools get deleted
2959 push @dellist, $mblock->{block};
2960 } else {
2961 # Whatever's left over gets converted
2962 push @convlist, $mblock->{block};
2963 }
2964 } # foreach @retlist
2965 # And do the calls.
2966 if ($args{scope} eq 'clearpeer') {
2967 # Not happy doing this many, but there isn't really a better way.
2968 # We delete ALL EVARYTHING in peer blocks...
2969 _rpc('delRevSet', cidrlist => join(',', @fulldellist), rpcuser => $args{user}, delforward => 'y',
2970 delsubs => 'y', parpatt => $pinfo->{rdns}, location => $binfo->{location})
2971 if @fulldellist;
2972 # ... and just the template for container or pool templates in $prime...
2973 _rpc('delRevSet', cidrlist => join(',', @dellist), rpcuser => $args{user}, delforward => 'y',
2974 delsubs => 'n', parpatt => $pinfo->{rdns}, location => $binfo->{location})
2975 if @dellist;
2976 # ... and convert a few to record groups
2977 _rpc('templatesToRecords', templates => \@convlist, rpcuser => $args{user},
2978 location => $binfo->{location})
2979 if @convlist;
2980 }
2981 if ($args{scope} eq 'clearall') {
2982# consider just doing join(',',$newblock->split($newblock->masklen+1))?
2983 _rpc('delRevSet', cidrlist => join(',', @fulldellist, @dellist, @convlist, $binfo->{block}),
2984 rpcuser => $args{user}, delforward => 'y', delsubs => 'y', parpatt => $pinfo->{rdns},
2985 location => $binfo->{location});
2986 }
2987
2988 } # scope eq 'clearpeer' || 'clearall'
2989
2990 } elsif ($args{newtype} =~ /.[enr]/) {
2991 # Merge to leaf type
2992
2993 # Resize rDNS template for $prime
2994 _rpc('resizeTemplate', oldcidr => "$binfo->{block}", newcidr => $newblock->network.'',
2995 rpcuser => $args{user}, location => $binfo->{location});
2996
2997 # Assemble a list of blocks to delete...
2998 my $cidrlist;
2999 foreach my $mblock (@retlist) {
3000 $cidrlist .= $mblock->{block}."," unless $mblock->{block} =~ $newblock;
3001 }
3002 # Delete all other records within the new block
3003 $cidrlist .= $binfo->{block};
3004 _rpc('delRevSet', cidrlist => $cidrlist, rpcuser => $args{user}, delforward => 'y', delsubs => 'y',
3005 parpatt => $pinfo->{rdns}, location => $binfo->{location});
3006
3007 } # type grouping for rDNS calls
3008
3009 return \@retlist;
3010
3011} # end mergeBlocks()
3012
3013
3014## IPDB::deleteBlock()
3015# Removes an allocation from the database, including deleting IPs
3016# from poolips and recombining entries in freeblocks if possible
3017# Also handles "deleting" a static IP allocation, and removal of a master
3018# Requires a database handle, the block to delete, the routing depth (if applicable),
3019# the VRF ID, and a flag to indicate whether to delete associated forward DNS entries
3020# as well as the reverse entry
3021sub deleteBlock {
3022 my ($dbh,$id,$basetype,$delfwd,$user) = @_;
3023
3024 # reset $basetype so caller can just pass the complete allocation type
3025 if ($basetype =~ /^.?i$/) {
3026 $basetype = 'i';
3027 } else {
3028 $basetype = 'b';
3029 }
3030
3031 # Collect info about the block we're going to delete
3032 my $binfo = getBlockData($dbh, $id, $basetype);
3033 my $cidr = new NetAddr::IP $binfo->{block};
3034
3035# For possible auto-VRF-ignoring (since public IPs shouldn't usually be present in more than one VRF)
3036# is_rfc1918 requires NetAddr::IP >= 4.059
3037# rather than doing this over and over and over.....
3038 my $tmpnum = $cidr->numeric;
3039# 192.168.0.0/16 -> 192.168.255.255 => 3232235520 -> 3232301055
3040# 172.16.0.0/12 -> 172.31.255.255 => 2886729728 -> 2887778303
3041# 10.0.0.0/8 -> 10.255.255.255 => 167772160 -> 184549375
3042 my $isprivnet = (3232235520 <= $tmpnum && $tmpnum <= 3232301055) ||
3043 (2886729728 <= $tmpnum && $tmpnum <= 2887778303) ||
3044 (167772160 <= $tmpnum && $tmpnum <= 184549375);
3045
3046 my $sth;
3047
3048 # Magic variables used for odd allocation cases.
3049 my $container;
3050 my $con_type;
3051
3052
3053 # temporarily forced null, until a sane UI for VRF tracking can be found.
3054# $vrf = '';# if !$vrf; # as with SQL, the null value is not equal to ''. *sigh*
3055
3056 # To contain the error message, if any.
3057 my $msg = "Unknown error deallocating $binfo->{type} $cidr";
3058 my $goback; # to put the parent in so we can link back where the deallocate started
3059
3060 # Enable transactions and exception-on-errors... but only for this sub
3061 local $dbh->{AutoCommit} = 0;
3062 local $dbh->{RaiseError} = 1;
3063
3064 if ($binfo->{type} =~ /^.i$/) {
3065 # First case. The "block" is a static IP
3066 # Note that we still need some additional code in the odd case
3067 # of a netblock-aligned contiguous group of static IPs
3068 my $pinfo;
3069
3070 eval {
3071 $msg = "Unable to deallocate $disp_alloctypes{$binfo->{type}} $cidr";
3072 $pinfo = getBlockData($dbh, $binfo->{parent_id}, 'b');
3073 $dbh->do("UPDATE poolips SET custid = ?, available = 'y',".
3074 "city = (SELECT city FROM allocations WHERE id = ?),".
3075 "description = '', notes = '', circuitid = '', vrf = ?, backup_id = 0".
3076 " WHERE id = ?", undef,
3077 ($pinfo->{custid}, $binfo->{parent_id}, $pinfo->{vrf}, $id) );
3078 $dbh->do("DELETE FROM backuplist WHERE backup_id = ?", undef, $binfo->{hasbk})
3079 if $binfo->{hasbk};
3080 $dbh->commit;
3081 };
3082 if ($@) {
3083 $msg .= ": $@";
3084 eval { $dbh->rollback; };
3085 return ('FAIL',$msg);
3086 }
3087
3088##fixme: RPC return code?
3089 _rpc('delByCIDR', cidr => "$cidr", user => $user, delforward => $delfwd, rpcuser => $user,
3090 location => $binfo->{location})
3091 if ($pinfo->{revavail} || $pinfo->{revpartial});
3092
3093 return ('OK',"OK");
3094
3095 } elsif ($binfo->{type} eq 'mm') { # end alloctype =~ /.i/
3096 # Second case. The block is a full master block
3097
3098##fixme: VRF limit
3099 $msg = "Unable to delete master block $cidr";
3100 eval {
3101 $dbh->do("DELETE FROM allocations WHERE cidr <<= ? AND master_id = ?", undef, ($cidr, $binfo->{master_id}) );
3102 $dbh->do("DELETE FROM freeblocks WHERE cidr <<= ? AND master_id = ?", undef, ($cidr, $binfo->{master_id}) );
3103 $dbh->do("DELETE FROM dnsavail WHERE location = ? AND parent_alloc = ?", undef,
3104 ($binfo->{location}, $binfo->{master_id}) );
3105 $dbh->do("DELETE FROM backuplist WHERE backup_id = ?", undef, $binfo->{hasbk})
3106 if $binfo->{hasbk};
3107 $dbh->commit;
3108 };
3109 if ($@) {
3110 $msg .= ": $@";
3111 eval { $dbh->rollback; };
3112 return ('FAIL', $msg);
3113 }
3114
3115 # Have to handle potentially split reverse zones. Assume they *are* split,
3116 # since if we added them here, they would have been added split.
3117# allow splitting reverse zones to be disabled, maybe, someday
3118#if ($splitrevzones && !$cidr->{isv6}) {
3119 my @zonelist;
3120 if (1 && !$cidr->{isv6}) {
3121 my $splitpoint = ($cidr->masklen <= 16 ? 16 : 24); # hack pthui
3122 @zonelist = $cidr->split($splitpoint);
3123 } else {
3124 @zonelist = ($cidr);
3125 }
3126 my @fails;
3127 foreach my $subzone (@zonelist) {
3128 # We don't wrap this call tighter, since there isn't an inherent allocation to check for rDNS-ability.
3129 if ($rpc_url && !_rpc('delZone', zone => "$subzone", revrec => 'y', rpcuser => $user, delforward => $delfwd) ) {
3130 push @fails, ("$subzone" => $errstr);
3131 }
3132 }
3133 if (@fails) {
3134 return ('WARN',"Warning(s) deleting $cidr from reverse DNS:\n".join("\n", @fails));
3135 }
3136 return ('OK','OK');
3137
3138 } else { # end alloctype master block case
3139
3140 ## This is a big block; but it HAS to be done in a chunk. Any removal
3141 ## of a netblock allocation may result in a larger chunk of free
3142 ## contiguous IP space - which may in turn be combined into a single
3143 ## netblock rather than a number of smaller netblocks.
3144
3145 my $retcode = 'OK';
3146 my ($ptype,$pcity,$ppatt,$p_id);
3147
3148 eval {
3149
3150##fixme: add recursive flag to allow "YES DAMMIT DELETE ALL EVARYTHING!!1!!" without
3151# explicitly deleting any suballocations of the block to be deleted.
3152
3153 # See if we have child allocations. Fail for now.
3154 my ($childcount) = $dbh->selectrow_array("SELECT count(*) from allocations where parent_id = ?", undef, $id);
3155 if ($childcount) {
3156 $msg = '';
3157 die "$binfo->{block} still has suballocations\n";
3158 }
3159
3160 # get parent info of the block we're deleting
3161 my $pinfo = getBlockData($dbh, $binfo->{parent_id});
3162 $ptype = $pinfo->{type};
3163 $pcity = $pinfo->{city};
3164 $ppatt = $pinfo->{rdns};
3165 $p_id = $binfo->{parent_id};
3166
3167 # Delete the block
3168 $dbh->do("DELETE FROM allocations WHERE id = ?", undef, ($id) );
3169
3170 # munge the parent type a little
3171 $ptype = (split //, $ptype)[1];
3172
3173##fixme: you can't... CAN NOT.... assign the same public IP to multiple things.
3174# 'Net don't work like that, homey. Restrict VRF-uniqueness to private IPs?
3175# -> $isprivnet flag from start of sub
3176
3177 # check to see if any container allocations could be the "true" parent
3178 my ($tparent,$tpar_id,$trtype,$tcity);
3179 $tpar_id = 0;
3180
3181##fixme: this is far simpler in the strict VRF case; we "know" that any allocation
3182# contained by a container is a part of the same allocation tree when the VRF fields are equal.
3183
3184# logic:
3185# For each possible container of $cidr
3186# note the parent id
3187# walk the chain up the parents
3188# if we intersect $cidr's current parent, break
3189# if we've intersected $cidr's current parent
3190# set some variables to track that block
3191# break
3192
3193# Set up part of "is it in the middle of a pool?" check
3194 my $wuzpool = $dbh->selectrow_hashref("SELECT cidr,parent_id,type,city,custid,id FROM allocations ".
3195 "WHERE (type LIKE '_d' OR type LIKE '_p') AND cidr >> ? AND master_id = ?", { Slice => {} },
3196 ($cidr, $binfo->{master_id}) );
3197
3198##fixme?
3199# edge cases not handled, or handled badly:
3200# -> $cidr managed to get to be the entirety of an IP pool
3201
3202 if ($wuzpool && $wuzpool->{id} != $id) {
3203 # we have legacy goo to be purified
3204 # going to ignore nested pools; not possible to create them via API and no current legacy data includes any.
3205
3206 # for convenience
3207 my $poolid = $wuzpool->{id};
3208 my $pool = $wuzpool->{cidr};
3209 my $poolcity = $wuzpool->{city};
3210 my $pooltype = $wuzpool->{type};
3211 my $poolcustid = $wuzpool->{custid};
3212
3213 $retcode = 'WARNPOOL';
3214 $goback = "$poolid,$pool";
3215 # We've already deleted the block, now we have to stuff its IPs into the pool.
3216 $pooltype =~ s/[dp]$/i/; # change type to static IP
3217 my $sth2 = $dbh->prepare("INSERT INTO poolips (ip,city,type,custid,parent_id) VALUES ".
3218 "(?,'$poolcity','$pooltype','$poolcustid',$poolid)");
3219
3220##fixme: need to not insert net, gateway, and bcast on "real netblock" pools (DHCPish)
3221 # don't insert .0
3222 $sth2->execute($cidr->addr) unless $cidr->addr =~ m|\.0$|;
3223 $cidr++;
3224 my $bcast = $cidr->broadcast;
3225 while ($cidr != $bcast) {
3226 $sth2->execute($cidr->addr);
3227 $cidr++;
3228 }
3229 # don't insert .255
3230 $sth2->execute($cidr->addr) unless $cidr->addr =~ m|\.255$|;
3231
3232# Weirdness Happens. $cidr goes read-only somewhere (this is a thing?!?),
3233# causing ->split, ->hostenum, and related methods to explode. O_o
3234# foreach my $ip ($cidr->hostenum) {
3235# $sth2->execute($ip);
3236# }
3237
3238 }
3239
3240## important!
3241# ... or IS IT?
3242# we may have undef'ed $wuzpool above, if the allocation tree $cidr is in doesn't intersect the pool we found
3243#if (!$wuzpool) {
3244
3245 else {
3246
3247# Edge case: Block is the same size as more than one parent level. Should be rare.
3248# - mainly master + first routing. Sorting on parent_id hides the problem pretty well,
3249# but it's likely still possible to fail in particularly well-mangled databases.
3250# The ultimate fix for this may be to resurrect the "routing depth" atrocity. :/
3251 # Get all possible (and probably a number of impossible) containers for $cidr
3252 $sth = $dbh->prepare("SELECT cidr,parent_id,type,city,id FROM allocations ".
3253 "WHERE (type LIKE '_m' OR type LIKE '_c') AND cidr >>= ? AND master_id = ? ".
3254 "ORDER BY masklen(cidr) DESC,parent_id DESC");
3255 $sth->execute($cidr, $binfo->{master_id});
3256
3257 # Quickly get certain fields (simpler than getBlockData()
3258 my $sth2 = $dbh->prepare("SELECT cidr,parent_id,type,city FROM allocations ".
3259 "WHERE (type LIKE '_m' OR type LIKE '_c') AND id = ? AND master_id = ?");
3260
3261 # For each possible container of $cidr...
3262 while (my @data = $sth->fetchrow_array) {
3263 my $i = 0;
3264 # Save some state and set a start point - parent ID of container we're checking
3265 $tparent = $data[0];
3266 my $ppid = $data[1];
3267 $trtype = $data[2];
3268 $tcity = $data[3];
3269 $tpar_id = $data[4];
3270 last if $data[4] == $binfo->{parent_id}; # Preemptively break if we're already in the right place
3271 last if $ppid == $binfo->{parent_id}; # ... or if the parent of the container is the block's parent
3272 while (1) {
3273 # Retrieve bits on that parent ID
3274 $sth2->execute($ppid, $binfo->{master_id});
3275 my @container = $sth2->fetchrow_array;
3276 $ppid = $container[1];
3277 last if $container[1] == 0; # Break if we've hit a master block
3278 last if $ppid == $binfo->{parent_id}; # Break if we've reached the block $cidr is currently in
3279 }
3280 last if $ppid == $binfo->{parent_id};
3281 }
3282
3283 # found an alternate parent; reset some parent-info bits
3284 if ($tpar_id != $binfo->{parent_id}) {
3285 $ptype = (split //, $trtype)[1];
3286 $pcity = $tcity;
3287 $retcode = 'WARNMERGE'; # may be redundant
3288 $p_id = $tpar_id;
3289 }
3290
3291 $goback = "$p_id,$tparent"; # breadcrumb, currently only used in case of live-parent-is-not-true-parent
3292
3293 # Special case - delete pool IPs
3294 if ($binfo->{type} =~ /^.[pd]$/) {
3295 # We have to delete the IPs from the pool listing.
3296##fixme: rdepth? vrf?
3297 $dbh->do("DELETE FROM poolips WHERE parent_id = ?", undef, ($id) );
3298 }
3299
3300 $pinfo = getBlockData($dbh, $p_id);
3301
3302 # If the block wasn't legacy goo embedded in a static pool, we check the
3303 # freeblocks in the identified parent to see if we can combine any of them.
3304
3305 # if the block to be deleted is a container, move its freeblock(s) up a level, and reset their parenting info
3306 if ($binfo->{type} =~ /^.[mc]/) {
3307 # move the freeblocks into the parent
3308 # we don't insert a new freeblock because there could be a live reparented sub.
3309 $dbh->do("UPDATE freeblocks SET parent_id = ?, routed = ?, city = ? WHERE parent_id = ?", undef,
3310 ($p_id, $ptype, $pcity, $id) );
3311 } else {
3312 # ... otherwise, add the freeblock
3313 $dbh->do("INSERT INTO freeblocks (cidr, city, routed, parent_id, master_id) VALUES (?,?,?,?,?)", undef,
3314 ($cidr, $pcity, $ptype, $p_id, $binfo->{master_id}) );
3315 }
3316
3317 # Walk the free blocks in the parent and reduce them to the minimal set of CIDR ranges necessary
3318 _compactFree($dbh, $p_id);
3319
3320 } # done returning IPs to the appropriate place
3321
3322 # If we got here, we've succeeded. Whew!
3323 $dbh->commit;
3324 }; # end eval
3325 if ($@) {
3326 if ($msg) { $msg .= ": $@"; } else { $msg = $@; }
3327 eval { $dbh->rollback; };
3328 return ('FAIL', $msg);
3329 }
3330
3331##fixme: RPC return code?
3332 _rpc('delByCIDR', cidr => "$cidr", rpcuser => $user, delforward => $delfwd, delsubs => 'y',
3333 parpatt => $ppatt, location => $binfo->{location})
3334 if ($binfo->{revavail} || $binfo->{revpartial});
3335
3336 return ($retcode, $goback);
3337
3338 } # end alloctype != netblock
3339
3340} # end deleteBlock()
3341
3342
3343## IPDB::getBlockData()
3344# Get CIDR or IP, custid, type, city, circuit ID, description, notes, modification time,
3345# private/restricted data, and backup fields, for a CIDR block or pool IP
3346# Also returns SWIP status flag for CIDR blocks or pool netblock for IPs
3347# Takes the block ID or IP to look up and an optional flag to indicate a pool IP lookup
3348# instead of a netblock.
3349# Returns a hashref to the block data
3350sub getBlockData {
3351 my $dbh = shift;
3352 my $id = shift;
3353 my $type = shift || 'b'; # default to netblock for lazy callers
3354
3355 # reset $type so caller can just pass the complete allocation type
3356 if ($type =~ /^.?i$/) {
3357 $type = 'i';
3358 } else {
3359 $type = 'b';
3360 }
3361
3362# catch some errors, someday
3363# if (!$id || $id !~ /^\d+$/) {
3364# $errstr = "Allocation ID must be numeric
3365# }
3366
3367 # Note city, vrf, parent_id and master_id removed due to JOIN uncertainty for block allocations
3368 my $commonfields = q(a.custid, a.type, a.circuitid, a.description, a.notes, a.modifystamp AS lastmod,
3369 a.privdata, a.vlan, a.rdns);
3370 my $bkfields = q(b.backup_id AS hasbk, b.bkbrand, b.bkmodel, b.bktype, b.bkport, b.bksrc,
3371 b.bkuser, b.bkvpass, b.bkepass, b.bkip);
3372
3373 if ($type eq 'i') {
3374 my $binfo = $dbh->selectrow_hashref(qq(
3375 SELECT a.id, a.ip AS block, a.city, a.vrf, a.parent_id, a.master_id, $commonfields,
3376 d.zone >> a.ip AS revavail, d.location,
3377 $bkfields,
3378 v.location AS vrfloc
3379 FROM poolips a
3380 LEFT JOIN dnsavail d ON a.master_id = d.parent_alloc AND a.ip << d.zone
3381 LEFT JOIN backuplist b ON a.backup_id = b.backup_id
3382 JOIN allocations m ON a.master_id = m.id JOIN vrfs v ON m.vrf = v.vrf
3383 WHERE a.id = ?
3384 ), undef, ($id) );
3385 return $binfo;
3386 } else {
3387 my $binfo = $dbh->selectrow_hashref(qq(
3388 SELECT a.id, masklen(a.cidr), a.cidr AS block, a.city, a.vrf, a.parent_id, a.master_id, a.swip, $commonfields,
3389 f.cidr AS reserve, f.id as reserve_id,
3390 d.zone >>= a.cidr AS revavail, d.zone << a.cidr AS revpartial, d.location,
3391 $bkfields,
3392 v.location AS vrfloc
3393 FROM allocations a
3394 LEFT JOIN freeblocks f ON a.id=f.reserve_for
3395 LEFT JOIN dnsavail d ON a.master_id = d.parent_alloc AND (a.cidr <<= d.zone OR a.cidr >> d.zone)
3396 LEFT JOIN backuplist b ON a.backup_id = b.backup_id
3397 JOIN allocations m ON a.master_id = m.id JOIN vrfs v ON m.vrf = v.vrf
3398 WHERE a.id = ?
3399 ), undef, ($id) );
3400
3401 if ($binfo->{type} =~ /^.[dp]$/) {
3402 ($binfo->{nfree}) = $dbh->selectrow_array("SELECT count(*) FROM poolips WHERE parent_id = ? AND available = 'y'", undef, $id);
3403 } else {
3404 # assemble free IP count
3405 my $tmp = $dbh->prepare("SELECT 2^(32-masklen(cidr)) AS fc FROM freeblocks WHERE parent_id = ?");
3406 $tmp->execute($id);
3407 my $nfree = 0;
3408 while (my ($fc) = $tmp->fetchrow_array) {
3409 $nfree += $fc;
3410 }
3411 $binfo->{nfree} = $nfree;
3412 }
3413
3414 return $binfo;
3415 }
3416} # end getBlockData()
3417
3418
3419## IPDB::getBlockRDNS()
3420# Gets reverse DNS pattern for a block or IP. Note that this will also
3421# retrieve any default pattern following the parent chain up, and check via
3422# RPC (if available) to see what the narrowest pattern for the requested block is
3423# Returns the current pattern for the block or IP.
3424sub getBlockRDNS {
3425 my $dbh = shift;
3426 my %args = @_;
3427
3428 $args{type} = 'b' if !$args{type};
3429 my $cached = 1;
3430
3431 # snag entry from database
3432 my ($rdns,$rfrom,$pid,$mid);
3433 if ($args{type} =~ /.i/) {
3434 ($rdns, $rfrom, $pid, $mid) = $dbh->selectrow_array("SELECT rdns,ip,parent_id,master_id FROM poolips WHERE id = ?",
3435 undef, ($args{id}) );
3436 } else {
3437 ($rdns, $rfrom, $pid, $mid) = $dbh->selectrow_array("SELECT rdns,cidr,parent_id,master_id FROM allocations WHERE id = ?",
3438 undef, ($args{id}) );
3439 }
3440
3441 # Can't see a way this could end up empty, for any case I care about. If the caller
3442 # doesn't know an allocation ID to request, then they don't know anything else anyway.
3443 my $selfblock = $rfrom;
3444
3445 my $type;
3446 while (!$rdns && $pid) {
3447 ($rdns, $rfrom, $pid, $type) = $dbh->selectrow_array(
3448 "SELECT rdns,cidr,parent_id,type FROM allocations WHERE id = ?",
3449 undef, ($pid) );
3450 last if $type eq 'mm'; # break loops in unfortunate legacy data
3451 }
3452
3453 # use the actual allocation to check against the DNS utility; we don't want
3454 # to always go chasing up the chain to the master... which may (usually won't)
3455 # be present directly in DNS anyway
3456 my $cidr = new NetAddr::IP $selfblock;
3457
3458 if ($rpc_url) {
3459 # Use the first /16 or /24, rather than dithering over which sub-/14 /16
3460 # or sub-/19 /24 to retrieve - it's the least-wrong way to do things.
3461
3462 my ($rpcblock) = ($cidr->masklen <= 24 ? $cidr->split( ($cidr->masklen <= 16 ? 16 : 24) ) : $cidr);
3463 my %rpcargs = (
3464 rpcuser => $args{user},
3465 group => $revgroup, # not sure how this could sanely be exposed, tbh...
3466 cidr => "$rpcblock",
3467 );
3468
3469# # Retrieve the VRF's location by way of the master block
3470# ($rpcargs{location}) = $dbh->selectrow_array("SELECT v.location FROM vrfs v".
3471# " JOIN allocations a ON a.vrf = v.vrf".
3472# " WHERE a.id = ?", undef, $mid);
3473
3474## ... is there something more needed here?
3475# order by so that we get the narrowest entry
3476 ($rpcargs{location}) = $dbh->selectrow_array("SELECT d.location FROM dnsavail d".
3477 " WHERE d.parent_alloc = ? ORDER BY zone DESC", undef, $mid);
3478
3479 $errstr = '';
3480 my $remote_rdns = _rpc('getRevPattern', %rpcargs);
3481 if ($remote_rdns) {
3482 $rdns = $remote_rdns;
3483 $cached = 0;
3484 } else {
3485 if (!$errstr) {
3486 # no error, but no data
3487 $cached = 0;
3488 }
3489 }
3490 }
3491
3492 # hmm. do we care about where it actually came from?
3493 return $rdns, $cached;
3494} # end getBlockRDNS()
3495
3496
3497## IPDB::getRDNSbyIP()
3498# Get individual reverse entries for the IP or CIDR IP range passed. Sort of looking the
3499# opposite direction down the netblock tree compared to getBlockRDNS() above.
3500sub getRDNSbyIP {
3501 my $dbh = shift;
3502 my %args = @_; # We want to accept a variety of call types
3503
3504 # key arguments: allocation ID, type
3505 unless ($args{id} || $args{type}) {
3506 $errstr = 'Missing allocation ID or type';
3507 return;
3508 }
3509
3510 my $binfo = getBlockData($dbh, $args{id}, $args{type});
3511
3512 my @ret = ();
3513 # special case: single IP. Check if it's an allocation or in a pool, then do the RPC call for fresh data.
3514 if ($args{type} =~ /^.i$/) {
3515 my ($ip, $localrev) = $dbh->selectrow_array("SELECT ip, rdns FROM poolips WHERE id = ?", undef, ($args{id}) );
3516 push @ret, { 'r_ip' => $ip, 'iphost' => $localrev };
3517##fixme: rpc call?
3518 } else {
3519 if ($rpc_url) {
3520 my %rpcargs = (
3521 rpcuser => $args{user},
3522 group => $revgroup, # not sure how this could sanely be exposed, tbh...
3523 cidr => $args{range},
3524 );
3525
3526# # Retrieve the VRF's DNS location by way of the master block
3527# ($rpcargs{location}) = $dbh->selectrow_array("SELECT v.location FROM vrfs v".
3528# " JOIN allocations a ON a.vrf = v.vrf JOIN allocations b ON a.id = b.master_id".
3529# " WHERE b.id = ?", undef, $args{id});
3530
3531## ... is there something more needed here?
3532# order by so that we get the narrowest entry
3533 ($rpcargs{location}) = $dbh->selectrow_array("SELECT d.location FROM dnsavail d".
3534 " WHERE d.parent_alloc = ? ORDER BY zone DESC", undef, $binfo->{master_id});
3535
3536 my $remote_rdns = _rpc('getRevSet', %rpcargs);
3537 return $remote_rdns;
3538# $rdns = $remote_rdns if $remote_rdns;
3539# $cached = 0;
3540 }
3541 }
3542 return \@ret;
3543} # end getRDNSbyIP()
3544
3545
3546## IPDB::getRevID()
3547# Get the reverse zone ID(s) for an allocation
3548# Takes a hash with cidr, location and user elements
3549# Returns a hashref to a list of zones and zone IDs (in case of large
3550# allocations effectively split across multiple DNS zones)
3551##fixme: arguably should be integrated in some other related sub that
3552# does RPC to minimize the number of RPC calls somehow
3553sub getRevID {
3554 my $dbh = shift;
3555 my %args = @_;
3556
3557##fixme: build a local cache for mapping allocations to DNS zone IDs
3558# my ($revlocal) = $dbh->selectrow_array("SELECT revzones[0] AS zone,revzones[1] AS revid FROM dnsavail WHERE
3559#zone >>= ? AND location = ?", undef, $args{cidr}, $args{location});
3560#use Data::Dumper;
3561#print "rezone array?<pre>".Dumper($revlocal)."</pre>\n";
3562
3563 my $revzones = _rpc('getZonesByCIDR', rpcuser => $args{user},
3564 cidr => $args{cidr},
3565 return_location => 0,
3566 location => $args{location},
3567 );
3568 return $revzones;
3569} # end getRevID()
3570
3571
3572## IPDB::getNodeList()
3573# Gets a list of node ID+name pairs as an arrayref to a list of hashrefs
3574sub getNodeList {
3575 my $dbh = shift;
3576
3577 my $ret = $dbh->selectall_arrayref("SELECT node_id, node_name FROM nodes ORDER BY node_type,node_id",
3578 { Slice => {} });
3579 return $ret;
3580} # end getNodeList()
3581
3582
3583## IPDB::getNodeName()
3584# Get node name from the ID
3585sub getNodeName {
3586 my $dbh = shift;
3587 my $nid = shift;
3588
3589 my ($nname) = $dbh->selectrow_array("SELECT node_name FROM nodes WHERE node_id = ?", undef, ($nid) );
3590 return $nname;
3591} # end getNodeName()
3592
3593
3594## IPDB::getNodeInfo()
3595# Get node name and ID associated with a block
3596sub getNodeInfo {
3597 my $dbh = shift;
3598 my $block = shift;
3599
3600 my ($nid, $nname) = $dbh->selectrow_array("SELECT nodes.node_id,node_name FROM nodes INNER JOIN noderef".
3601 " ON nodes.node_id=noderef.node_id WHERE noderef.block = ?", undef, ($block) );
3602 return ($nid, $nname);
3603} # end getNodeInfo()
3604
3605
3606## IPDB::getBlockNotices()
3607# Retrieve any infonotes for a block and all of its parents
3608# Takes the block ID to trace down the stack
3609# Returns an arrayref to the block and all of its parents, containing the CIDR,
3610# description, and notice (if any) associated to each block.
3611sub getBlockNotices {
3612 my $dbh = shift;
3613 my $bid = shift;
3614 my $nlist = $dbh->selectall_arrayref(q(
3615 WITH RECURSIVE blockparents (id, cidr, description, parent_id, notice, depth) AS (
3616 SELECT a.id, a.cidr, a.description, a.parent_id, bn.notice, 1 AS depth FROM allocations a
3617 LEFT JOIN blocknotices bn ON a.id = bn.alloc_id
3618 WHERE a.id = ?
3619 UNION
3620 SELECT b.id, b.cidr, b.description, b.parent_id, bn2.notice, t.depth AS depth FROM allocations b
3621 JOIN blockparents t ON t.parent_id = b.id
3622 LEFT JOIN blocknotices bn2 ON b.id = bn2.alloc_id
3623 ) SELECT id, cidr, description, parent_id, notice FROM blockparents ORDER BY depth DESC;
3624), {Slice=>{}}, $bid);
3625
3626 return $nlist;
3627} # end getBlockNotices()
3628
3629
3630## IPDB::mailNotify()
3631# Sends notification mail to recipients regarding an IPDB operation
3632sub mailNotify {
3633 my $dbh = shift;
3634 my ($action,$subj,$message) = @_;
3635
3636 return if $smtphost eq 'smtp.example.com'; # do nothing if still using default SMTP host.
3637
3638##fixme: need to redesign the breakdown/processing for $action for proper handling of all cases
3639
3640# split action into parts for fiddlement. nb: there are almost certainly better ways to do this.
3641 my @actionbits = split //, $action;
3642
3643 # want to notify anyone who has specifically requested notify on *this* type ($action as passed),
3644 # on "all static IP types" or "all pool types" (and other last-char-in-type groupings), on eg "all DSL types",
3645 # and "all events with this action"
3646 my @actionsets = ($action);
3647##fixme: ick, eww. really gotta find a better way to handle this...
3648 push @actionsets, ($actionbits[0].'.'.$actionbits[2],
3649 $actionbits[0].$actionbits[1].'.', $actionbits[0].'a') if $action =~ /^.{3}$/;
3650
3651 my $mailer = Net::SMTP->new($smtphost, Hello => "ipdb.$domain");
3652
3653 # get recip list from db
3654 my $sth = $dbh->prepare("SELECT reciplist FROM notify WHERE action=?");
3655
3656 my %reciplist;
3657 foreach (@actionsets) {
3658 $sth->execute($_);
3659##fixme - need to handle db errors
3660 my ($recipsub) = $sth->fetchrow_array;
3661 next if !$recipsub;
3662 foreach (split(/,/, $recipsub)) {
3663 $reciplist{$_}++;
3664 }
3665 }
3666
3667 return if !%reciplist;
3668
3669 # dodge a bullet with module version "numbers"
3670 my ($ver) = ($IPDB::VERSION =~ /^(\d+(?:\.\d+)?)/);
3671
3672 foreach my $recip (keys %reciplist) {
3673 $mailer->mail($smtpsender);
3674 $mailer->to($recip);
3675 $mailer->data("From: \"$org_name IP Database\" <$smtpsender>\n",
3676 "To: $recip\n",
3677 "Date: ".strftime("%a, %d %b %Y %H:%M:%S %z",localtime)."\n",
3678 "Subject: {IPDB} $subj\n",
3679 "X-Mailer: IPDB Notify v".sprintf("%.1d",$ver)."\n",
3680 "Organization: $org_name\n",
3681 "\n$message\n");
3682 }
3683 $mailer->quit;
3684}
3685
3686# Indicates module loaded OK. Required by Perl.
36871;
Note: See TracBrowser for help on using the repository browser.