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

Last change on this file since 914 was 913, checked in by Kris Deugau, 7 years ago

/trunk

Add IP count and percent-free to the heading and showsubs layout 2 by request

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