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

Last change on this file since 726 was 726, checked in by Kris Deugau, 9 years ago

/trunk

(Re)?add the block ID back to the hashref returned by getBlockData(),
since there are in fact cases where we may pass the hashref around and
lose track of the original ID.
  • Property svn:keywords set to Date Rev Author
File size: 89.8 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: 2015-05-20 19:52:19 +0000 (Wed, 20 May 2015) $
6# SVN revision $Rev: 726 $
7# Last update by $Author: kdeugau $
8###
9# Copyright (C) 2004-2010 - 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 = 2; ##VERSION##
24@ISA = qw(Exporter);
25@EXPORT_OK = qw(
26 %disp_alloctypes %list_alloctypes %def_custids @citylist @poplist
27 %IPDBacl %aclmsg %rpcacl $maxfcgi
28 $errstr
29 &initIPDBGlobals &connectDB &finish &checkDBSanity
30 &addMaster &touchMaster
31 &listSummary &listSubs &listContainers &listAllocations &listForMerge &listFree &listPool
32 &getMasterList &getTypeList &getPoolSelect &findAllocateFrom
33 &ipParent &subParent &blockParent &getBreadCrumbs &getRoutedCity
34 &allocateBlock &updateBlock &splitBlock &shrinkBlock &deleteBlock &getBlockData
35 &getBlockRDNS &getRDNSbyIP
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 %aclmsg %rpcacl $maxfcgi
44 $errstr
45 &initIPDBGlobals &connectDB &finish &checkDBSanity
46 &addMaster &touchMaster
47 &listSummary &listSubs &listContainers &listAllocations &listForMerge &listFree &listPool
48 &getMasterList &getTypeList &getPoolSelect &findAllocateFrom
49 &ipParent &subParent &blockParent &getBreadCrumbs &getRoutedCity
50 &allocateBlock &updateBlock &splitBlock &shrinkBlock &deleteBlock &getBlockData
51 &getBlockRDNS &getRDNSbyIP
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# mapping table for functional-area => error message
71our %aclmsg = (
72 addmaster => 'add a master block',
73 addblock => 'add an allocation',
74 updateblock => 'update a block',
75 delblock => 'delete an allocation',
76 );
77
78our %rpcacl;
79our $maxfcgi = 3;
80
81# error reporting
82our $errstr = '';
83
84our $org_name = 'Example Corp';
85our $smtphost = 'smtp.example.com';
86our $domain = 'example.com';
87our $defcustid = '5554242';
88our $smtpsender = 'ipdb@example.com';
89# mostly for rwhois
90##fixme: leave these blank by default?
91our $rwhoisDataPath = '/usr/local/rwhoisd/etc/rwhoisd'; # to match ./configure defaults from rwhoisd-1.5.9.6
92our $org_street = '123 4th Street';
93our $org_city = 'Anytown';
94our $org_prov_state = 'ON';
95our $org_pocode = 'H0H 0H0';
96our $org_country = 'CA';
97our $org_phone = '000-555-1234';
98our $org_techhandle = 'ISP-ARIN-HANDLE';
99our $org_email = 'noc@example.com';
100our $hostmaster = 'dns@example.com';
101
102our $syslog_facility = 'local2';
103
104our $rpc_url = '';
105our $revgroup = 1; # should probably be configurable somewhere
106our $rpccount = 0;
107
108# Largest inverse CIDR mask length to show per-IP rDNS list
109# (eg, NetAddr::IP->bits - NetAddr::IP->masklen)
110our $maxrevlist = 5; # /27
111
112# UI layout for subblocks/containers
113our $sublistlayout = 1;
114
115# VLAN validation mode. Set to 0 to allow alphanumeric vlan names instead of using the vlan number.
116our $numeric_vlan = 1;
117
118
119##
120## Internal utility functions
121##
122
123## IPDB::_rpc
124# Make an RPC call for DNS changes
125sub _rpc {
126 return if !$rpc_url; # Just In Case
127 my $rpcsub = shift;
128 my %args = @_;
129
130 # Make an object to represent the XML-RPC server.
131 my $server = Frontier::Client->new(url => $rpc_url, debug => 0);
132 my $result;
133
134 my %rpcargs = (
135 rpcsystem => 'ipdb',
136# must be provided by caller's caller
137# rpcuser => $args{user},
138 %args,
139 );
140
141 eval {
142 $result = $server->call("dnsdb.$rpcsub", %rpcargs);
143 };
144 if ($@) {
145 $errstr = $@;
146 $errstr =~ s/\s*$//;
147 $errstr =~ s/Fault returned from XML RPC Server, fault code 4: error executing RPC `dnsdb.$rpcsub'\.\s//;
148 }
149 $rpccount++;
150
151 return $result if $result;
152} # end _rpc()
153
154
155## IPDB::_compactFree()
156# Utility sub to compact a set of free block entries down to the minimum possible set of CIDR entries
157# Not to be called outside of an eval{}!
158sub _compactFree {
159 my $dbh = shift;
160 my $parent = shift;
161
162 # Rather than having the caller provide all the details
163 my $pinfo = getBlockData($dbh, $parent);
164 my $ftype = (split //, $pinfo->{type})[0];
165
166# NetAddr::IP->compact() attempts to produce the smallest inclusive block
167# from the caller and the passed terms.
168# EG: if you call $cidr->compact($ip1,$ip2,$ip3) when $cidr, $ip1, $ip2,
169# and $ip3 are consecutive /27's starting on .0 (.0-.31, .32-.63,
170# .64-.95, and .96-.128), you will get an array containing a single
171# /25 as element 0 (.0-.127). Order is not important; you could have
172# $cidr=.32/27, $ip1=.96/27, $ip2=.0/27, and $ip3=.64/27.
173
174##fixme: vrf
175##fixme: simplify since all containers now represent different "layers"/"levels"?
176
177 # set up the query to get the list of blocks to try to merge.
178 my $sth = $dbh->prepare(q{
179 SELECT cidr,id FROM freeblocks
180 WHERE parent_id = ?
181 ORDER BY masklen(cidr) DESC
182 });
183 $sth->execute($parent);
184
185 my (@rawfb, @combinelist, %rawid);
186 my $i=0;
187 # for each free block under $parent, push a NetAddr::IP object into one list, and
188 # continuously use NetAddr::IP->compact to automagically merge netblocks as possible.
189 while (my ($fcidr, $fid) = $sth->fetchrow_array) {
190 my $testIP = new NetAddr::IP $fcidr;
191 push @rawfb, $testIP;
192 $rawid{"$testIP"} = $fid; # $data[0] vs "$testIP" *does* make a difference for v6
193 @combinelist = $testIP->compact(@combinelist);
194 }
195
196 # now that we have the full list of "compacted" freeblocks, go back over
197 # the list of raw freeblocks, and delete the ones that got merged.
198 $sth = $dbh->prepare("DELETE FROM freeblocks WHERE id = ?");
199 foreach my $rawfree (@rawfb) {
200 next if grep { $rawfree == $_ } @combinelist; # skip if the raw block is in the compacted list
201 $sth->execute($rawid{$rawfree});
202 }
203
204 # now we walk the new list of compacted blocks, and see which ones we need to insert
205 $sth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)");
206 foreach my $cme (@combinelist) {
207 next if grep { $cme == $_ } @rawfb; # skip if the combined block was in the raw list
208 $sth->execute($cme, $pinfo->{city}, $ftype, $pinfo->{vrf}, $parent, $pinfo->{master_id});
209 }
210
211} # end _compactFree()
212
213
214## IPDB::_poolToAllocations
215# Convert pool IPs into allocations, and free IPs into free blocks
216# Takes a pool ID, original pool CIDR (in case the allocation has been updated before the call here)
217# and hashref to data for the new parent container for the IPs,
218# and an optional hash with the new parent ID and allocation type
219sub _poolToAllocations {
220 my $dbh = shift;
221 my $oldpool = shift;
222 my $parentinfo = shift;
223 my %args = @_;
224
225 # Default to converting the pool to a container
226 $args{newparent} = $oldpool->{id} if !$args{newparent};
227
228 my ($containerclass) = ($parentinfo->{type} =~ /(.)./);
229
230 # Default type mapping
231 $args{newtype} = $poolmap{$oldpool->{type}} if !$args{newtype};
232
233 # Convert a bunch of pool IP allocations into "normal" netblock allocations
234 my $pool2alloc = $dbh->prepare(q{
235 INSERT INTO allocations (
236 cidr,type,city, description, notes, circuitid, createstamp, modifystamp,
237 privdata, custid, vrf, vlan, rdns, parent_id, master_id
238 )
239 SELECT
240 ip, ? AS type, city, description, notes, circuitid, createstamp, modifystamp,
241 privdata, custid, vrf, vlan, rdns, ? AS parent_id, master_id
242 FROM poolips
243 WHERE parent_id = ? AND available = 'n'
244 });
245 $pool2alloc->execute($args{newtype}, $args{newparent}, $oldpool->{id});
246
247 # Snag the whole list of pool IPs
248 my @freeips = @{$dbh->selectall_arrayref("SELECT ip,available FROM poolips WHERE parent_id = ?",
249 undef, $oldpool->{id})};
250 my @iplist;
251 my %usedips;
252 # Filter out the ones that were used...
253 foreach my $ip (@freeips) {
254 $$ip[0] =~ s{/32$}{};
255 push @iplist, NetAddr::IP->new($$ip[0]) if $$ip[1] eq 'y';
256 $usedips{$$ip[0]}++ if $$ip[1] eq 'n';
257 }
258 # ... so that we can properly decide whether the net, gw, and bcast IPs need to be added to the free list.
259 my $tmpblock = new NetAddr::IP $oldpool->{block};
260 push @iplist, NetAddr::IP->new($tmpblock->network->addr)
261 if !$usedips{$tmpblock->network->addr} || $tmpblock->network->addr =~ /\.0$/;
262 push @iplist, NetAddr::IP->new($tmpblock->broadcast->addr)
263 if !$usedips{$tmpblock->broadcast->addr} || $tmpblock->broadcast->addr =~ /\.255$/;
264 # only "DHCP"-ish pools have a gw ip removed from the pool
265 if ($oldpool->{type} =~ /.d/) {
266 $tmpblock++;
267 push @iplist, NetAddr::IP->new($tmpblock->addr);
268 }
269
270 # take the list of /32 IPs, and see what CIDR ranges we get back as free, then insert them.
271 @iplist = Compact(@iplist);
272 my $insfbsth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)");
273 foreach (@iplist) {
274 $insfbsth->execute($_, $parentinfo->{city}, $containerclass, $parentinfo->{vrf},
275 $args{newparent}, $parentinfo->{master_id});
276 }
277
278 # and finally delete the poolips entries
279 $dbh->do("DELETE FROM poolips WHERE parent_id = ?", undef, $oldpool->{id});
280
281} # end _poolToAllocations()
282
283
284## IPDB::_deleteCascade()
285# Internal sub. Deletes an allocation and all subcomponents
286sub _deleteCascade {
287 my $dbh = shift;
288 my $id = shift;
289 my $createfb = shift; # may be null at this point
290
291 my $binfo = getBlockData($dbh, $id);
292
293 # Decide if we're going to add a free block.
294
295 # Caller is normal block delete -> add freeblock under $binfo->{parent_id} -> pass nothing
296 # Caller is delete for merge to leaf -> do not add freeblock -> pass 0
297 # Caller is normal master delete -> do not add freeblock -> pass nothing
298 # Caller is merge master -> add freeblock under alternate parent -> pass parent ID
299 if ($binfo->{type} ne 'mm') {
300 # Deleting a non-master block
301 if (!defined($createfb)) {
302 # No createfb flag passed; assuming normal block delete. Add the freeblock
303 # under the parent of the block we're deleting.
304 $createfb = $binfo->{parent_id};
305 #} else {
306 # Don't need to actually do anything here. The caller has given us an ID,
307 # which is either 0 (causing no free block) or (theoretically) a valid block
308 # ID to add the free block under.
309 }
310 #} else {
311 # Deleting a master block
312 # Don't need to actually do anything here. If the caller passed a parent ID,
313 # that parent will get the new free block. if the caller didn't pass anything,
314 # no free block will be added.
315 }
316
317##fixme: special-case master blocks up here and quickly delete based on master_id,
318# instead of wasting time tracing parent relations
319
320 # grab all allocations in the master within the CIDR of the block to be deleted
321 my %parents;
322 my %cidrlist;
323##fixme: limit by VRF?
324 my $sth = $dbh->prepare("SELECT cidr,id,parent_id FROM allocations WHERE cidr <<= ? AND master_id = ?");
325 $sth->execute($binfo->{block}, $binfo->{master_id});
326 while (my ($cidr, $cid, $pid) = $sth->fetchrow_array) {
327 $parents{$cid} = $pid;
328 $cidrlist{$cid} = $cidr;
329 }
330
331 # Trace the parent relations up the tree until we either hit parent ID 0 (we've found a master block
332 # but not the parent we're looking for - arguably this is already an error) or the parent ID matches
333 # the passed ID. If the latter, push the whole set into a second flag hash, so we can terminate
334 # further tree-tracing early.
335 my %found;
336 foreach my $cid (keys %parents) {
337 my @tmp;
338 if ($cid == $id) {
339 # "child" is the ID we've been asked to cascade-delete.
340 $found{$cid}++;
341 } elsif ($found{$cid}) {
342 # ID already seen and the chain terminates in our parent.
343 } elsif ($parents{$cid} == $id) {
344 # Immediate parent is the target parent
345 $found{$cid}++;
346 } else {
347 # Immediate parent isn't the one we're looking for. Walk the chain up until we hit our parent,
348 # the nonexistent parent id 0, or undefined (ID is not a child of the target ID at all)
349 # There are probably better ways to structure this loop.
350 while (1) {
351 # cache the ID
352 push @tmp, $cid;
353 # some very particularly defined loop ending conditions
354 if (!defined($parents{$cid}) || $parents{$cid} == $id || $parents{$cid} == 0) {
355 last;
356 } else {
357 # if we haven't found either the desired parent or another limiting condition,
358 # reset the ID to the parent next up the tree
359 $cid = $parents{$cid};
360 }
361 }
362 # if the current chain of relations ended with our target parent, shuffle the cached IDs into a flag hash
363 if (defined($parents{$cid}) && $parents{$cid} == $id) {
364 foreach (@tmp) { $found{$_}++; }
365 }
366 } # else
367 } # foreach my $cid
368
369 # Use the keys in the flag hash to determine which allocations to actually delete.
370 # Delete matching freeblocks and pool IPs; their parents are going away so we want
371 # to make sure we don't leave orphaned records lying around loose.
372 my @dellist = keys %found;
373 push @dellist, $id; # Just In Case the target ID didn't make the list earlier.
374 my $b = '?'. (',?' x $#dellist);
375 $dbh->do("DELETE FROM allocations WHERE id IN ($b)", undef, (@dellist) );
376 $dbh->do("DELETE FROM freeblocks WHERE parent_id IN ($b)", undef, (@dellist) );
377 $dbh->do("DELETE FROM poolips WHERE parent_id IN ($b)", undef, (@dellist) );
378
379 # Insert a new free block if needed
380 if ($createfb) {
381 my $pinfo = getBlockData($dbh, $createfb);
382 my $pt = (split //, $pinfo->{type})[1];
383 $dbh->do("INSERT INTO freeblocks (cidr,city,routed,parent_id,vrf,master_id) VALUES (?,?,?,?,?,?)", undef,
384 $binfo->{block}, $pinfo->{city}, $pt, $createfb, $pinfo->{vrf}, $binfo->{master_id});
385 }
386
387##todo: and hey! bonus! we can return @dellist, or something (%cidrlist{@dellist})
388
389} # end _deleteCascade()
390
391
392##
393## Public subs
394##
395
396
397## IPDB::initIPDBGlobals()
398# Initialize all globals. Takes a database handle, returns a success or error code
399sub initIPDBGlobals {
400 my $dbh = $_[0];
401 my $sth;
402
403 # Initialize alloctypes hashes
404 $sth = $dbh->prepare("select type,listname,dispname,listorder,def_custid from alloctypes order by listorder");
405 $sth->execute;
406 while (my @data = $sth->fetchrow_array) {
407 $disp_alloctypes{$data[0]} = $data[2];
408 $def_custids{$data[0]} = $data[4];
409 if ($data[3] < 900) {
410 $list_alloctypes{$data[0]} = $data[1];
411 }
412 }
413
414 # City and POP listings
415 $sth = $dbh->prepare("select city,routing from cities order by city");
416 $sth->execute;
417 return (undef,$sth->errstr) if $sth->err;
418 while (my @data = $sth->fetchrow_array) {
419 push @citylist, $data[0];
420 if ($data[1] eq 'y') {
421 push @poplist, $data[0];
422 }
423 }
424
425 # Load ACL data. Specific username checks are done at a different level.
426 $sth = $dbh->prepare("select username,acl from users");
427 $sth->execute;
428 return (undef,$sth->errstr) if $sth->err;
429 while (my @data = $sth->fetchrow_array) {
430 $IPDBacl{$data[0]} = $data[1];
431 }
432
433##fixme: initialize HTML::Template env var for template path
434# something like $self->path().'/templates' ?
435# $ENV{HTML_TEMPLATE_ROOT} = 'foo/bar';
436
437 return (1,"OK");
438} # end initIPDBGlobals
439
440
441## IPDB::connectDB()
442# Creates connection to IPDB.
443# Requires the database name, username, and password.
444# Returns a handle to the db.
445# Set up for a PostgreSQL db; could be any transactional DBMS with the
446# right changes.
447sub connectDB {
448 my $dbname = shift;
449 my $user = shift;
450 my $pass = shift;
451 my $dbhost = shift;
452
453 my $dbh;
454 my $DSN = "DBI:Pg:".($dbhost ? "host=$dbhost;" : '')."dbname=$dbname";
455
456# Note that we want to autocommit by default, and we will turn it off locally as necessary.
457# We may not want to print gobbledygook errors; YMMV. Have to ponder that further.
458 $dbh = DBI->connect($DSN, $user, $pass, {
459 AutoCommit => 1,
460 PrintError => 0
461 })
462 or return (undef, $DBI::errstr) if(!$dbh);
463
464# Return here if we can't select. Note that this indicates a
465# problem executing the select.
466 my $sth = $dbh->prepare("select type from alloctypes");
467 $sth->execute();
468 return (undef,$DBI::errstr) if ($sth->err);
469
470# See if the select returned anything (or null data). This should
471# succeed if the select executed, but...
472 $sth->fetchrow();
473 return (undef,$DBI::errstr) if ($sth->err);
474
475# If we get here, we should be OK.
476 return ($dbh,"DB connection OK");
477} # end connectDB
478
479
480## IPDB::finish()
481# Cleans up after database handles and so on.
482# Requires a database handle
483sub finish {
484 my $dbh = $_[0];
485 $dbh->disconnect if $dbh;
486} # end finish
487
488
489## IPDB::checkDBSanity()
490# Quick check to see if the db is responding. A full integrity
491# check will have to be a separate tool to walk the IP allocation trees.
492sub checkDBSanity {
493 my ($dbh) = $_[0];
494
495 if (!$dbh) {
496 print "No database handle, or connection has been closed.";
497 return -1;
498 } else {
499 # it connects, try a stmt.
500 my $sth = $dbh->prepare("select type from alloctypes");
501 my $err = $sth->execute();
502
503 if ($sth->fetchrow()) {
504 # all is well.
505 return 1;
506 } else {
507 print "Connected to the database, but could not execute test statement. ".$sth->errstr();
508 return -1;
509 }
510 }
511 # Clean up after ourselves.
512# $dbh->disconnect;
513} # end checkDBSanity
514
515
516## IPDB::addMaster()
517# Does all the magic necessary to sucessfully add a master block
518# Requires database handle, block to add
519# Returns failure code and error message or success code and "message"
520sub addMaster {
521 my $dbh = shift;
522 # warning! during testing, this somehow generated a "Bad file descriptor" error. O_o
523 my $cidr = new NetAddr::IP shift;
524 my %args = @_;
525
526 $args{vrf} = '' if !$args{vrf};
527 $args{rdns} = '' if !$args{rdns};
528 $args{defloc} = '' if !$args{defloc};
529 $args{rwhois} = 'n' if !$args{rwhois}; # fail "safe", sort of.
530 $args{rwhois} = 'n' if $args{rwhois} ne 'n' and $args{rwhois} ne 'y';
531
532 my $mid;
533
534 # Allow transactions, and raise an exception on errors so we can catch it later.
535 # Use local to make sure these get "reset" properly on exiting this block
536 local $dbh->{AutoCommit} = 0;
537 local $dbh->{RaiseError} = 1;
538
539 # Wrap all the SQL in a transaction
540 eval {
541 # First check - does the master exist? Ignore VRFs until we can see a sane UI
542 my ($mcontained) = $dbh->selectrow_array("SELECT cidr FROM allocations WHERE cidr >>= ? AND type = 'mm'",
543 undef, ($cidr) );
544 die "Master block $mcontained already exists and entirely contains $cidr\n"
545 if $mcontained;
546
547 # Second check - does the new master contain an existing one or ones?
548 my ($mexist) = $dbh->selectrow_array("SELECT cidr FROM allocations WHERE cidr <<= ? AND type = 'mm'",
549 undef, ($cidr) );
550
551 if (!$mexist) {
552 # First case - master is brand-spanking-new.
553##fixme: rwhois should be globally-flagable somewhere, much like a number of other things
554## maybe a db table called "config"?
555 $dbh->do("INSERT INTO allocations (cidr,type,swip,vrf,rdns) VALUES (?,?,?,?,?)", undef,
556 ($cidr, 'mm', 'y', $args{vrf}, $args{rdns}) );
557 ($mid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
558
559# Unrouted blocks aren't associated with a city (yet). We don't rely on this
560# elsewhere though; legacy data may have traps and pitfalls in it to break this.
561# Thus the "routed" flag.
562 $dbh->do("INSERT INTO freeblocks (cidr,city,routed,parent_id,vrf,master_id) VALUES (?,?,?,?,?,?)", undef,
563 ($cidr, '<NULL>', 'm', $mid, $args{vrf}, $mid) );
564
565 # master should be its own master, so deletes directly at the master level work
566 $dbh->do("UPDATE allocations SET master_id = ? WHERE id = ?", undef, ($mid, $mid) );
567
568 # If we get here, everything is happy. Commit changes.
569 $dbh->commit;
570
571 } # done new master does not contain existing master(s)
572 else {
573
574 # collect the master(s) we're going to absorb, and snag the longest netmask while we're at it.
575 my $smallmask = $cidr->masklen;
576 my $sth = $dbh->prepare("SELECT cidr,id FROM allocations WHERE cidr <<= ? AND type='mm' AND parent_id=0");
577 $sth->execute($cidr);
578 my @cmasters;
579 my @oldmids;
580 while (my @data = $sth->fetchrow_array) {
581 my $master = new NetAddr::IP $data[0];
582 push @cmasters, $master;
583 push @oldmids, $data[1];
584 $smallmask = $master->masklen if $master->masklen > $smallmask;
585 }
586
587 # split the new master, and keep only those blocks not part of an existing master
588 my @blocklist;
589 foreach my $seg ($cidr->split($smallmask)) {
590 my $contained = 0;
591 foreach my $master (@cmasters) {
592 $contained = 1 if $master->contains($seg);
593 }
594 push @blocklist, $seg if !$contained;
595 }
596
597##fixme: master_id
598 # collect the unrouted free blocks within the new master
599 $sth = $dbh->prepare("SELECT cidr FROM freeblocks WHERE masklen(cidr) <= ? AND cidr <<= ? AND routed = 'm'");
600 $sth->execute($smallmask, $cidr);
601 while (my @data = $sth->fetchrow_array) {
602 my $freeblock = new NetAddr::IP $data[0];
603 push @blocklist, $freeblock;
604 }
605
606 # combine the set of free blocks we should have now.
607 @blocklist = Compact(@blocklist);
608
609 # master
610 $dbh->do("INSERT INTO allocations (cidr,type,swip,vrf,rdns) VALUES (?,?,?,?,?)", undef,
611 ($cidr, 'mm', 'y', $args{vrf}, $args{rdns}) );
612 ($mid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
613
614 # master should be its own master, so deletes directly at the master level work
615 $dbh->do("UPDATE allocations SET master_id = ? WHERE id = ?", undef, ($mid, $mid) );
616
617 # and now insert the new data. Make sure to delete old masters too.
618
619 # freeblocks
620 $sth = $dbh->prepare("DELETE FROM freeblocks WHERE cidr <<= ? AND parent_id IN (".join(',', @oldmids).")");
621 my $sth2 = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,parent_id,vrf,master_id)".
622 " VALUES (?,'<NULL>','m',?,?,?)");
623 foreach my $newblock (@blocklist) {
624 $sth->execute($newblock);
625 $sth2->execute($newblock, $mid, $args{vrf}, $mid);
626 }
627
628 # Update immediate allocations, and remove the old parents
629 $sth = $dbh->prepare("UPDATE allocations SET parent_id = ? WHERE parent_id = ?");
630 $sth2 = $dbh->prepare("DELETE FROM allocations WHERE id = ?");
631 foreach my $old (@oldmids) {
632 $sth->execute($mid, $old);
633 $sth2->execute($old);
634 }
635
636 # *whew* If we got here, we likely suceeded.
637 $dbh->commit;
638
639 } # new master contained existing master(s)
640 }; # end eval
641
642 if ($@) {
643 my $msg = $@;
644 eval { $dbh->rollback; };
645 return ('FAIL',$msg);
646 } else {
647
648 # Only attempt rDNS if the IPDB side succeeded
649 if ($rpc_url) {
650
651# Note *not* splitting reverse zones negates any benefit from caching the exported data.
652# IPv6 address space is far too large to split usefully, and in any case (also due to
653# the large address space) doesn't support the iterated template records v4 zones do
654# that causes the bulk of the slowdown that needs the cache anyway.
655
656 my @zonelist;
657# allow splitting reverse zones to be disabled, maybe, someday
658#if ($splitrevzones && !$cidr->{isv6}) {
659 if (1 && !$cidr->{isv6}) {
660 my $splitpoint = ($cidr->masklen <= 16 ? 16 : 24); # hack pthui
661 @zonelist = $cidr->split($splitpoint);
662 } else {
663 @zonelist = ($cidr);
664 }
665 my @fails;
666 ##fixme: remove hardcoding where possible
667 foreach my $subzone (@zonelist) {
668 my %rpcargs = (
669 rpcuser => $args{user},
670 revzone => "$subzone",
671 revpatt => $args{rdns},
672 defloc => $args{defloc},
673 group => $revgroup, # not sure how these two could sanely be exposed, tbh...
674 state => 1, # could make them globally configurable maybe
675 );
676 if ($rpc_url && !_rpc('addRDNS', %rpcargs)) {
677 push @fails, ("$subzone" => $errstr);
678 }
679 }
680 if (@fails) {
681 $errstr = "Warning(s) adding $cidr to reverse DNS:\n".join("\n", @fails);
682 return ('WARN',$mid);
683 }
684 }
685 return ('OK',$mid);
686 }
687} # end addMaster
688
689
690## IPDB::touchMaster()
691# Update last-changed timestamp on a master block.
692sub touchMaster {
693 my $dbh = shift;
694 my $master = shift;
695
696 local $dbh->{AutoCommit} = 0;
697 local $dbh->{RaiseError} = 1;
698
699 eval {
700 $dbh->do("UPDATE allocations SET modifystamp=now() WHERE id = ?", undef, ($master));
701 $dbh->commit;
702 };
703
704 if ($@) {
705 my $msg = $@;
706 eval { $dbh->rollback; };
707 return ('FAIL',$msg);
708 }
709 return ('OK','OK');
710} # end touchMaster()
711
712
713## IPDB::listSummary()
714# Get summary list of all master blocks
715# Returns an arrayref to a list of hashrefs containing the master block, routed count,
716# allocated count, free count, and largest free block masklength
717sub listSummary {
718 my $dbh = shift;
719
720 my $mlist = $dbh->selectall_arrayref("SELECT cidr AS master,id,vrf FROM allocations ".
721 "WHERE type='mm' ORDER BY cidr",
722 { Slice => {} });
723
724 foreach (@{$mlist}) {
725 my ($rcnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ? AND type='rm' AND master_id = ?",
726 undef, ($$_{master}, $$_{id}));
727 $$_{routed} = $rcnt;
728 my ($acnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
729 "AND NOT type='rm' AND NOT type='mm' AND master_id = ?",
730 undef, ($$_{master}, $$_{id}));
731 $$_{allocated} = $acnt;
732 my ($fcnt) = $dbh->selectrow_array("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?",
733 undef, ($$_{master}, $$_{id}));
734 $$_{free} = $fcnt;
735 my ($bigfree) = $dbh->selectrow_array("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?".
736 " AND master_id = ? ORDER BY masklen(cidr) LIMIT 1", undef, ($$_{master}, $$_{id}));
737##fixme: should find a way to do this without having to HTMLize the <>
738 $bigfree = "/$bigfree" if $bigfree;
739 $bigfree = '<NONE>' if !$bigfree;
740 $$_{bigfree} = $bigfree;
741 }
742 return $mlist;
743} # end listSummary()
744
745
746## IPDB::listSubs()
747# Get list of subnets within a specified CIDR block, on a specified VRF.
748# Returns an arrayref to a list of hashrefs containing the CIDR block, customer location or
749# city it's routed to, block type, SWIP status, and description
750sub listSubs {
751 my $dbh = shift;
752 my %args = @_;
753
754 # Just In Case
755 $args{vrf} = '' if !$args{vrf};
756
757 # Snag the allocations for this block
758 my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description,vrf,id,master_id".
759 " FROM allocations WHERE parent_id = ? ORDER BY cidr");
760 $sth->execute($args{parent});
761
762 # hack hack hack
763 # set up to flag swip=y records if they don't actually have supporting data in the customers table
764 my $custsth = $dbh->prepare("SELECT count(*) FROM customers WHERE custid = ?");
765
766 # snag some more details
767 my $substh = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
768 "AND type ~ '[mc]\$' AND master_id = ? AND NOT cidr = ? ");
769 my $alsth = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
770 "AND NOT type='rm' AND NOT type='mm' AND master_id = ? AND NOT id = ?");
771 my $freesth = $dbh->prepare("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?");
772 my $lfreesth = $dbh->prepare("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?".
773 " AND master_id = ? ORDER BY masklen(cidr) LIMIT 1");
774
775 my @blocklist;
776 while (my ($cidr,$city,$type,$custid,$swip,$desc,$vrf,$id,$mid) = $sth->fetchrow_array()) {
777 $desc .= " - vrf:$vrf" if $desc && $vrf;
778 $desc = "vrf:$vrf" if !$desc && $vrf;
779 $custsth->execute($custid);
780 my ($ncust) = $custsth->fetchrow_array();
781 $substh->execute($cidr, $mid, $cidr);
782 my ($cont) = $substh->fetchrow_array();
783 $alsth->execute($cidr, $mid, $id);
784 my ($alloc) = $alsth->fetchrow_array();
785 $freesth->execute($cidr, $mid);
786 my ($free) = $freesth->fetchrow_array();
787 $lfreesth->execute($cidr, $mid);
788 my ($lfree) = $lfreesth->fetchrow_array();
789 $lfree = "/$lfree" if $lfree;
790 $lfree = '<NONE>' if !$lfree;
791 my %row = (
792 block => $cidr,
793 subcontainers => $cont,
794 suballocs => $alloc,
795 subfree => $free,
796 lfree => $lfree,
797 city => $city,
798 type => $disp_alloctypes{$type},
799 custid => $custid,
800 swip => ($swip eq 'y' ? 'Yes' : 'No'),
801 partswip => ($swip eq 'y' && $ncust == 0 ? 1 : 0),
802 desc => $desc,
803 hassubs => ($type eq 'rm' || $type =~ /.c/ ? 1 : 0),
804 id => $id,
805 );
806# $row{subblock} = ($type =~ /^.r$/); # hmf. wonder why these won't work in the hash declaration...
807 $row{listpool} = ($type =~ /^.[pd]$/);
808 push (@blocklist, \%row);
809 }
810 return \@blocklist;
811} # end listSubs()
812
813
814## IPDB::listContainers()
815# List all container-type allocations in a given parent
816# Takes a database handle and a hash:
817# - parent is the ID of the parent block
818# Returns an arrayref to a list of hashrefs with the CIDR block, location, type,
819# description, block ID, and counts for the nmber uf suballocations (all types),
820# free blocks, and the CIDR size of the largest free block
821sub listContainers {
822 my $dbh = shift;
823 my %args = @_;
824
825 # Just In Case
826 $args{vrf} = '' if !$args{vrf};
827
828 # Snag the allocations for this block
829 my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description,vrf,id,master_id".
830 " FROM allocations WHERE parent_id = ? AND type ~ '[mc]\$' ORDER BY cidr");
831 $sth->execute($args{parent});
832
833 my $alsth = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
834 "AND NOT type='rm' AND NOT type='mm' AND master_id = ? AND NOT id = ?");
835 my $freesth = $dbh->prepare("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?");
836 my $lfreesth = $dbh->prepare("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?".
837 " AND master_id = ? ORDER BY masklen(cidr) LIMIT 1");
838
839 my @blocklist;
840 while (my ($cidr,$city,$type,$custid,$swip,$desc,$vrf,$id,$mid) = $sth->fetchrow_array()) {
841 $desc .= " - vrf:$vrf" if $desc && $vrf;
842 $desc = "vrf:$vrf" if !$desc && $vrf;
843 $alsth->execute($cidr, $mid, $id);
844 my ($alloc) = $alsth->fetchrow_array();
845 $freesth->execute($cidr, $mid);
846 my ($free) = $freesth->fetchrow_array();
847 $lfreesth->execute($cidr, $mid);
848 my ($lfree) = $lfreesth->fetchrow_array();
849 $lfree = "/$lfree" if $lfree;
850 $lfree = '<NONE>' if !$lfree;
851 my %row = (
852 block => $cidr,
853 suballocs => $alloc,
854 subfree => $free,
855 lfree => $lfree,
856 city => $city,
857 type => $disp_alloctypes{$type},
858 desc => $desc,
859 id => $id,
860 );
861 push (@blocklist, \%row);
862 }
863 return \@blocklist;
864} # end listContainers()
865
866
867## IPDB::listAllocations()
868# List all end-use allocations in a given parent
869# Takes a database handle and a hash:
870# - parent is the ID of the parent block
871# Returns an arrayref to a list of hashrefs with the CIDR block, location, type,
872# custID, SWIP flag, description, block ID, and master ID
873sub listAllocations {
874 my $dbh = shift;
875 my %args = @_;
876
877 # Snag the allocations for this block
878 my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description,vrf,id,master_id".
879 " FROM allocations WHERE parent_id = ? AND type !~ '[mc]\$' ORDER BY cidr");
880 $sth->execute($args{parent});
881
882 # hack hack hack
883 # set up to flag swip=y records if they don't actually have supporting data in the customers table
884 my $custsth = $dbh->prepare("SELECT count(*) FROM customers WHERE custid = ?");
885
886 my @blocklist;
887 while (my ($cidr,$city,$type,$custid,$swip,$desc,$vrf,$id,$mid) = $sth->fetchrow_array()) {
888 $desc .= " - vrf:$vrf" if $desc && $vrf;
889 $desc = "vrf:$vrf" if !$desc && $vrf;
890 $custsth->execute($custid);
891 my ($ncust) = $custsth->fetchrow_array();
892 my %row = (
893 block => $cidr,
894 city => $city,
895 type => $disp_alloctypes{$type},
896 custid => $custid,
897 swip => ($swip eq 'y' ? 'Yes' : 'No'),
898 partswip => ($swip eq 'y' && $ncust == 0 ? 1 : 0),
899 desc => $desc,
900 id => $id,
901 );
902# $row{subblock} = ($type =~ /^.r$/); # hmf. wonder why these won't work in the hash declaration...
903 $row{listpool} = ($type =~ /^.[pd]$/);
904 push (@blocklist, \%row);
905 }
906 return \@blocklist;
907} # end listAllocations()
908
909
910## IPDB::listForMerge()
911# Get a list of blocks targetted in a proposed merge
912sub listForMerge {
913 my $dbh = shift;
914 my $parent = shift;
915 my $newblock = shift;
916 my $btype = shift || 'a';
917 $btype = 'a' if $btype !~/^[af]$/;
918
919 my $sql;
920 if ($btype eq 'a') {
921 my $ret = $dbh->selectall_arrayref(q(
922 SELECT a.cidr,a.id,t.dispname FROM allocations a
923 JOIN alloctypes t ON a.type=t.type
924 WHERE a.parent_id = ? AND a.cidr <<= ?
925 ORDER BY a.cidr
926 ),
927 { Slice => {} }, $parent, $newblock);
928 return $ret;
929 } else {
930##fixme: Not sure about the casting hackery in "SELECT ?::integer AS id", but it works as intended
931 my $ret = $dbh->selectall_arrayref(q(
932 SELECT cidr,id FROM freeblocks
933 WHERE parent_id IN (SELECT ?::integer AS id UNION
934 SELECT id FROM allocations WHERE parent_id = ? AND cidr <<= ?
935 ) AND cidr <<= ?
936 ORDER BY cidr
937 ),
938 { Slice => {} }, $parent, $parent, $newblock, $newblock) or print $dbh->errstr;
939 return $ret;
940 }
941} # end listForMerge()
942
943
944## IPDB::listFree()
945# Gets a list of free blocks in the requested parent/master and VRF instance in both CIDR and range notation
946# Takes a parent/master ID and an optional VRF specifier that defaults to empty.
947# Returns an arrayref to a list of hashrefs containing the CIDR and range-notation blocks
948# Returns some extra flags in the hashrefs for routed blocks, since those can have several subtypes
949sub listFree {
950 my $dbh = shift;
951
952 my %args = @_;
953 # Just In Case
954 $args{vrf} = '' if !$args{vrf};
955
956 my $sth = $dbh->prepare(q(
957 SELECT f.cidr,f.id,allocations.cidr
958 FROM freeblocks f
959 LEFT JOIN allocations ON f.reserve_for = allocations.id
960 WHERE f.parent_id = ?
961 ORDER BY f.cidr
962 ) );
963# $sth->execute($args{parent}, $args{vrf});
964 $sth->execute($args{parent});
965 my @flist;
966 while (my ($cidr,$id,$resv) = $sth->fetchrow_array()) {
967 $cidr = new NetAddr::IP $cidr;
968 my %row = (
969 fblock => "$cidr",
970 frange => $cidr->range,
971 fbid => $id,
972 fbparent => $args{parent},
973 resv => $resv,
974 );
975 push @flist, \%row;
976 }
977 return \@flist;
978} # end listFree()
979
980
981## IPDB::listPool()
982#
983sub listPool {
984 my $dbh = shift;
985 my $pool = shift;
986
987 my $sth = $dbh->prepare("SELECT ip,custid,available,description,type,id".
988 " FROM poolips WHERE parent_id = ? ORDER BY ip");
989 $sth->execute($pool);
990 my @poolips;
991 while (my ($ip,$custid,$available,$desc,$type,$id) = $sth->fetchrow_array) {
992 my %row = (
993 ip => $ip,
994 custid => $custid,
995 available => $available,
996 desc => $desc,
997 delme => $available eq 'n',
998 parent => $pool,
999 id => $id,
1000 );
1001 push @poolips, \%row;
1002 }
1003 return \@poolips;
1004} # end listPool()
1005
1006
1007## IPDB::getMasterList()
1008# Get a list of master blocks, optionally including last-modified timestamps
1009# Takes an optional flag to indicate whether to include timestamps;
1010# 'm' includes ctime, all others (suggest 'c') do not.
1011# Returns an arrayref to a list of hashrefs
1012sub getMasterList {
1013 my $dbh = shift;
1014 my $stampme = shift || 'm'; # optional but should be set by caller for clarity
1015
1016 my $mlist = $dbh->selectall_arrayref("SELECT id,vrf,cidr AS master".($stampme eq 'm' ? ',modifystamp AS mtime' : '').
1017 " FROM allocations WHERE type='mm' ORDER BY cidr", { Slice => {} });
1018 return $mlist;
1019} # end getMasterList()
1020
1021
1022## IPDB::getTypeList()
1023# Get an alloctype/description pair list suitable for dropdowns
1024# Takes a flag to determine which general groups of types are returned
1025# Returns an reference to an array of hashrefs
1026sub getTypeList {
1027 my $dbh = shift;
1028 my $tgroup = shift || 'a'; # technically optional, like this, but should
1029 # really be specified in the call for clarity
1030 my $seltype = shift || '';
1031
1032 my $sql = "SELECT type,listname,type=? AS sel FROM alloctypes WHERE listorder <= 500";
1033 if ($tgroup eq 'n') {
1034 # grouping 'p' - all netblock types. These include routed blocks, containers (_c)
1035 # and contained (_r) types, dynamic-allocation ranges (_e), static IP pools (_d and _p),
1036 # and the "miscellaneous" cn, in, and en types.
1037 $sql .= " AND type NOT LIKE '_i'";
1038 } elsif ($tgroup eq 'p') {
1039 # grouping 'p' - primary allocation types. As with 'n' above but without the _r contained types.
1040 $sql .= " AND type NOT LIKE '_i' AND type NOT LIKE '_r'";
1041 } elsif ($tgroup eq 'c') {
1042 # grouping 'c' - contained types. These include all static IPs and all _r types.
1043 $sql .= " AND (type LIKE '_i' OR type LIKE '_r')";
1044 } elsif ($tgroup eq 'i') {
1045 # grouping 'i' - static IP types.
1046 $sql .= " AND type LIKE '_i'";
1047 } else {
1048 # grouping 'a' - all standard allocation types. This includes everything
1049 # but mm (present only as a formality). Make this the default.
1050 # ... whee! no extra WHERE clauses
1051 }
1052 $sql .= " ORDER BY listorder";
1053 my $tlist = $dbh->selectall_arrayref($sql, { Slice => {} }, $seltype);
1054 return $tlist;
1055}
1056
1057
1058## IPDB::getPoolSelect()
1059# Get a list of pools matching the passed city and type that have 1 or more free IPs
1060# Returns an arrayref to a list of hashrefs
1061sub getPoolSelect {
1062 my $dbh = shift;
1063 my $iptype = shift;
1064 my $pcity = shift;
1065
1066 my ($ptype) = ($iptype =~ /^(.)i$/);
1067 return if !$ptype;
1068 $ptype .= '_';
1069
1070 my $plist = $dbh->selectall_arrayref( q(
1071 SELECT count(*) AS poolfree,p.pool AS poolblock, a.city AS poolcit
1072 FROM poolips p
1073 JOIN allocations a ON p.parent_id=a.id
1074 WHERE p.available='y' AND a.city = ? AND p.type LIKE ?
1075 GROUP BY p.pool,a.city
1076 ),
1077 { Slice => {} }, ($pcity, $ptype) );
1078 return $plist;
1079} # end getPoolSelect()
1080
1081
1082## IPDB::findAllocateFrom()
1083# Find free block to add a new allocation from. (CIDR block version of pool select above, more or less)
1084# Takes
1085# - mask length
1086# - allocation type
1087# - POP city "parent"
1088# - optional master-block restriction
1089# - optional flag to allow automatic pick-from-private-network-ranges
1090# Returns a string with the first CIDR block matching the criteria, if any
1091sub findAllocateFrom {
1092 my $dbh = shift;
1093 my $maskbits = shift;
1094 my $type = shift;
1095 my $city = shift;
1096 my $pop = shift;
1097 my %optargs = @_;
1098
1099 my $failmsg = "No suitable free block found\n";
1100
1101 my @vallist;
1102 my $sql;
1103
1104 # Free pool IPs should be easy.
1105 if ($type =~ /^.i$/) {
1106 # User may get an IP from the wrong VRF. User should not be using admin tools to allocate static IPs.
1107 $sql = "SELECT id, ip, parent_id FROM poolips WHERE ip = ?";
1108 @vallist = ($optargs{gimme});
1109 } else {
1110
1111## Set up the SQL to find out what freeblock we can (probably) use for an allocation.
1112## Very large systems will require development of a reserve system (possibly an extension
1113## of the reserve-for-expansion concept in https://secure.deepnet.cx/trac/ipdb/ticket/24?)
1114## Also populate a value list for the DBI call.
1115
1116 @vallist = ($maskbits);
1117 $sql = "SELECT id,cidr,parent_id FROM freeblocks WHERE masklen(cidr) <= ?";
1118
1119# cases, strict rules
1120# .c -> container type
1121# requires a routing container, fbtype r
1122# .d -> DHCP/"normal-routing" static pool
1123# requires a routing container, fbtype r
1124# .e -> Dynamic-assignment connectivity
1125# requires a routing container, fbtype r
1126# .i -> error, can't allocate static IPs this way?
1127# mm -> error, master block
1128# rm -> routed block
1129# requires master block, fbtype m
1130# .n -> Miscellaneous usage
1131# requires a routing container, fbtype r
1132# .p -> PPP(oE) static pool
1133# requires a routing container, fbtype r
1134# .r -> contained type
1135# requires a matching container, fbtype $1
1136##fixme: strict-or-not flag
1137
1138##fixme: config or UI flag for "Strict" mode
1139# if ($strictmode) {
1140if (0) {
1141 if ($type =~ /^(.)r$/) {
1142 push @vallist, $1;
1143 $sql .= " AND routed = ?";
1144 } elsif ($type eq 'rm') {
1145 $sql .= " AND routed = 'm'";
1146 } else {
1147 $sql .= " AND routed = 'r'";
1148 }
1149}
1150
1151 # for PPP(oE) and container types, the POP city is the one attached to the pool.
1152 # individual allocations get listed with the customer city site.
1153 ##fixme: chain cities to align roughly with a full layer-2 node graph
1154 $city = $pop if $type !~ /^.[pc]$/;
1155 if ($type ne 'rm' && $city) {
1156 $sql .= " AND city = ?";
1157 push @vallist, $city;
1158 }
1159 # Allow specifying an arbitrary full block, instead of a master
1160 if ($optargs{gimme}) {
1161 $sql .= " AND cidr >>= ?";
1162 push @vallist, $optargs{gimme};
1163 }
1164 # if a specific master was requested, allow the requestor to self->shoot(foot)
1165 if ($optargs{master} && $optargs{master} ne '-') {
1166 $sql .= " AND master_id = ?";
1167# if $optargs{master} ne '-';
1168 push @vallist, $optargs{master};
1169 } else {
1170 # if a specific master was NOT requested, filter out the RFC 1918 private networks
1171 if (!$optargs{allowpriv}) {
1172 $sql .= " AND NOT (cidr <<= '192.168.0.0/16' OR cidr <<= '10.0.0.0/8' OR cidr <<= '172.16.0.0/12')";
1173 }
1174 }
1175 # Keep "reserved" blocks out of automatic assignment.
1176##fixme: needs a UI flag or a config knob
1177 $sql .= " AND reserve_for = 0";
1178 # Sorting and limiting, since we don't (currently) care to provide a selection of
1179 # blocks to carve up. This preserves something resembling optimal usage of the IP
1180 # space by forcing contiguous allocations and free blocks as much as possible.
1181 $sql .= " ORDER BY masklen(cidr) DESC,cidr LIMIT 1";
1182 } # done setting up SQL for free CIDR block
1183
1184 my ($fbid,$fbfound,$fbparent) = $dbh->selectrow_array($sql, undef, @vallist);
1185 return $fbid,$fbfound,$fbparent;
1186} # end findAllocateFrom()
1187
1188
1189## IPDB::ipParent()
1190# Get an IP's parent pool's details
1191# Takes a database handle and IP
1192# Returns a hashref to the parent pool block, if any
1193sub ipParent {
1194 my $dbh = shift;
1195 my $block = shift;
1196
1197 my $pinfo = $dbh->selectrow_hashref("SELECT cidr,custid,type,city,description FROM allocations".
1198 " WHERE cidr >>= ? AND (type LIKE '_p' OR type LIKE '_d')", undef, ($block) );
1199 return $pinfo;
1200} # end ipParent()
1201
1202
1203## IPDB::subParent()
1204# Get a block's parent's details
1205# Takes a database handle and CIDR block
1206# Returns a hashref to the parent container block, if any
1207sub subParent {
1208 my $dbh = shift;
1209 my $block = shift;
1210
1211 my $pinfo = $dbh->selectrow_hashref("SELECT cidr,custid,type,city,description FROM allocations".
1212 " WHERE cidr >>= ?", undef, ($block) );
1213 return $pinfo;
1214} # end subParent()
1215
1216
1217## IPDB::blockParent()
1218# Get a block's parent's details
1219# Takes a database handle and CIDR block
1220# Returns a hashref to the parent container block, if any
1221sub blockParent {
1222 my $dbh = shift;
1223 my $block = shift;
1224
1225 my $pinfo = $dbh->selectrow_hashref("SELECT cidr,city FROM routed".
1226 " WHERE cidr >>= ?", undef, ($block) );
1227 return $pinfo;
1228} # end blockParent()
1229
1230
1231## IPDB::getBreadCrumbs()
1232# Retrieve the ID and CIDR of a block's parent(s) up to the master block
1233# Returns an arrayref to a list of hashrefs with CIDR and block ID
1234sub getBreadCrumbs {
1235 my $dbh = shift;
1236 my $parent = shift;
1237 my @result;
1238
1239 my $sth = $dbh-> prepare("SELECT cidr,type,id,parent_id FROM allocations WHERE id=?");
1240
1241 while ($parent != 0) {
1242 $sth->execute($parent);
1243 my ($cidr,$type,$id,$pid) = $sth->fetchrow_array;
1244 push @result, {cidr => $cidr, link => $id, ispool => ($type =~ /^.[dp]$/ ? 1 : 0)};
1245 $parent = $pid;
1246 }
1247
1248 return \@result;
1249} # end getBread()
1250
1251
1252## IPDB::getRoutedCity()
1253# Get the city for a routed block.
1254sub getRoutedCity {
1255 my $dbh = shift;
1256 my $block = shift;
1257
1258 my ($rcity) = $dbh->selectrow_array("SELECT city FROM routed WHERE cidr = ?", undef, ($block) );
1259 return $rcity;
1260} # end getRoutedCity()
1261
1262
1263## IPDB::allocateBlock()
1264# Does all of the magic of actually allocating a netblock
1265# Requires a database handle, and a hash containing the block to allocate, routing depth, custid,
1266# type, city, block to allocate from, and optionally a description, notes, circuit ID,
1267# and private data
1268# Returns a success code and optional error message.
1269sub allocateBlock {
1270 my $dbh = shift;
1271
1272 my %args = @_;
1273
1274 $args{cidr} = new NetAddr::IP $args{cidr};
1275
1276 $args{desc} = '' if !$args{desc};
1277 $args{notes} = '' if !$args{notes};
1278 $args{circid} = '' if !$args{circid};
1279 $args{privdata} = '' if !$args{privdata};
1280 $args{vrf} = '' if !$args{vrf};
1281 $args{vlan} = '' if !$args{vlan};
1282 $args{rdns} = '' if !$args{rdns};
1283
1284 # Could arguably allow this for eg /120 allocations, but end users who get a single v4 IP are
1285 # usually given a v6 /64, and most v6 addressing schemes need at least half that address space
1286 if ($args{cidr}->{isv6} && $args{rdns} =~ /\%/) {
1287 return ('FAIL','Reverse DNS template patterns are not supported for IPv6 allocations');
1288 }
1289
1290 my $sth;
1291
1292 # Snag the "type" of the freeblock and its CIDR
1293 my ($alloc_from_type, $alloc_from, $fbparent, $fcity, $fbmaster) =
1294 $dbh->selectrow_array("SELECT routed,cidr,parent_id,city,master_id FROM freeblocks WHERE id = ?",
1295 undef, $args{fbid});
1296 $alloc_from = new NetAddr::IP $alloc_from;
1297 return ('FAIL',"Failed to allocate $args{cidr}; intended free block was used by another allocation.")
1298 if !$fbparent;
1299##fixme: fail here if !$alloc_from
1300# also consider "lock for allocation" due to multistep allocation process
1301
1302 # To contain the error message, if any.
1303 my $msg = "Unknown error allocating $args{cidr} as '$disp_alloctypes{$args{type}}'";
1304
1305 # Enable transactions and error handling
1306 local $dbh->{AutoCommit} = 0; # These need to be local so we don't
1307 local $dbh->{RaiseError} = 1; # step on our toes by accident.
1308
1309 if ($args{type} =~ /^.i$/) {
1310 $msg = "Unable to assign static IP $args{cidr} to $args{custid}";
1311 eval {
1312 if ($args{cidr}) { # IP specified
1313 my ($isavail) = $dbh->selectrow_array("SELECT available FROM poolips WHERE ip=?", undef, ($args{cidr}) );
1314 die "IP is not in an IP pool.\n"
1315 if !$isavail;
1316 die "IP already allocated. Deallocate and reallocate, or update the entry\n"
1317 if $isavail eq 'n';
1318 } else { # IP not specified, take first available
1319 ($args{cidr}) = $dbh->selectrow_array("SELECT ip FROM poolips WHERE pool=? AND available='y' ORDER BY ip",
1320 undef, ($args{alloc_from}) );
1321 }
1322 $dbh->do("UPDATE poolips SET custid = ?, city = ?,available='n', description = ?, notes = ?, ".
1323 "circuitid = ?, privdata = ?, vrf = ?, rdns = ? ".
1324 "WHERE ip = ? AND parent_id = ?", undef,
1325 ($args{custid}, $args{city}, $args{desc}, $args{notes},
1326 $args{circid}, $args{privdata}, $args{vrf}, $args{rdns},
1327 $args{cidr}, $args{parent}) );
1328
1329# node hack
1330 if ($args{nodeid} && $args{nodeid} ne '') {
1331 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
1332 }
1333# end node hack
1334
1335 $dbh->commit; # Allocate IP from pool
1336 };
1337 if ($@) {
1338 $msg .= ": $@";
1339 eval { $dbh->rollback; };
1340 return ('FAIL', $msg);
1341 } else {
1342 _rpc('addOrUpdateRevRec', cidr => "$args{cidr}", name => $args{rdns}, rpcuser => $args{user});
1343 return ('OK', $args{cidr});
1344 }
1345
1346 } else { # end IP-from-pool allocation
1347
1348 if ($args{cidr} == $alloc_from) {
1349 # Easiest case- insert in one table, delete in the other, and go home. More or less.
1350 # insert into allocations values (cidr,custid,type,city,desc) and
1351 # delete from freeblocks where cidr='cidr'
1352 # For data safety on non-transaction DBs, we delete first.
1353
1354 eval {
1355 $msg = "Unable to allocate $args{cidr} as '$disp_alloctypes{$args{type}}'";
1356
1357 # Insert the allocations entry
1358 $dbh->do("INSERT INTO allocations ".
1359 "(cidr,parent_id,master_id,vrf,vlan,custid,type,city,description,notes,circuitid,privdata,rdns)".
1360 " VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)", undef,
1361 ($args{cidr}, $fbparent, $fbmaster, $args{vrf}, $args{vlan}, $args{custid}, $args{type}, $args{city},
1362 $args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{rdns}) );
1363 my ($bid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
1364
1365 # Munge freeblocks
1366 if ($args{type} =~ /^(.)[mc]$/) {
1367 # special case - block is a routed or container/"reserve" block
1368 my $rtype = $1;
1369 $dbh->do("UPDATE freeblocks SET routed = ?,city = ?,parent_id = ? WHERE id = ?",
1370 undef, ($rtype, $args{city}, $bid, $args{fbid}) );
1371 } else {
1372 # "normal" case
1373 $dbh->do("DELETE FROM freeblocks WHERE id = ?", undef, ($args{fbid}) );
1374 }
1375
1376 # And initialize the pool, if necessary
1377 # PPPoE pools (currently dialup, DSL, and WiFi) get all IPs made available
1378 # "DHCP" or "real-subnet" pools have the net, gw, and bcast IPs removed.
1379 if ($args{type} =~ /^.p$/) {
1380 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1381 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "all", $bid);
1382 die $rmsg if $code eq 'FAIL';
1383 } elsif ($args{type} =~ /^.d$/) {
1384 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1385 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "normal", $bid);
1386 die $rmsg if $code eq 'FAIL';
1387 }
1388
1389# node hack
1390 if ($args{nodeid} && $args{nodeid} ne '') {
1391 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
1392 }
1393# end node hack
1394
1395 $dbh->commit; # Simple block allocation
1396 }; # end of eval
1397 if ($@) {
1398 $msg .= ": ".$@;
1399 eval { $dbh->rollback; };
1400 return ('FAIL',$msg);
1401 }
1402
1403 } else { # cidr != alloc_from
1404
1405 # Hard case. Allocation is smaller than free block.
1406
1407 # make sure new allocation is in fact within freeblock. *sigh*
1408 return ('FAIL',"Requested allocation $args{cidr} is not within $alloc_from")
1409 if !$alloc_from->contains($args{cidr});
1410 my $wantmaskbits = $args{cidr}->masklen;
1411 my $maskbits = $alloc_from->masklen;
1412
1413 my @newfreeblocks; # Holds free blocks generated from splitting the source freeblock.
1414
1415 # This determines which blocks will be left "free" after allocation. We take the
1416 # block we're allocating from, and split it in half. We see which half the wanted
1417 # block is in, and repeat until the wanted block is equal to one of the halves.
1418 my $i=0;
1419 my $tmp_from = $alloc_from; # So we don't munge $args{alloc_from}
1420 while ($maskbits++ < $wantmaskbits) {
1421 my @subblocks = $tmp_from->split($maskbits);
1422 $newfreeblocks[$i++] = (($args{cidr}->within($subblocks[0])) ? $subblocks[1] : $subblocks[0]);
1423 $tmp_from = ( ($args{cidr}->within($subblocks[0])) ? $subblocks[0] : $subblocks[1] );
1424 } # while
1425
1426 # Begin SQL transaction block
1427 eval {
1428 $msg = "Unable to allocate $args{cidr} as '$disp_alloctypes{$args{type}}'";
1429
1430 # Delete old freeblocks entry
1431 $dbh->do("DELETE FROM freeblocks WHERE id = ?", undef, ($args{fbid}) );
1432
1433 # Insert the allocations entry
1434 $dbh->do("INSERT INTO allocations ".
1435 "(cidr,parent_id,master_id,vrf,vlan,custid,type,city,description,notes,circuitid,privdata,rdns)".
1436 " VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)", undef,
1437 ($args{cidr}, $fbparent, $fbmaster, $args{vrf}, $args{vlan}, $args{custid}, $args{type}, $args{city},
1438 $args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{rdns}) );
1439 my ($bid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
1440
1441 # Insert new list of smaller free blocks left over. Flag the one that matches the
1442 # masklength of the new allocation, if a reserve block was requested.
1443 $sth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id,reserve_for) ".
1444 "VALUES (?,?,?,?,?,?,?)");
1445 foreach my $block (@newfreeblocks) {
1446 $sth->execute($block, $fcity, $alloc_from_type, $args{vrf}, $fbparent, $fbmaster,
1447 ($args{reserve} && $block->masklen == $wantmaskbits ? $bid : 0));
1448 }
1449
1450 # For routed/container types, add a freeblock within the allocated block so we can subdivide it further
1451 if ($args{type} =~ /(.)[mc]/) { # rm and .c types - containers
1452 my $rtype = $1;
1453 $sth->execute($args{cidr}, $args{city}, $rtype, $args{vrf}, $bid, $fbmaster, 0);
1454 }
1455
1456 # And initialize the pool, if necessary
1457 # PPPoE pools (currently dialup, DSL, and WiFi) get all IPs made available
1458 # "DHCP" or "real-subnet" pools have the net, gw, and bcast IPs removed.
1459 if ($args{type} =~ /^.p$/) {
1460 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1461 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "all", $bid);
1462 die $rmsg if $code eq 'FAIL';
1463 } elsif ($args{type} =~ /^.d$/) {
1464 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1465 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "normal", $bid);
1466 die $rmsg if $code eq 'FAIL';
1467 }
1468
1469# node hack
1470 if ($args{nodeid} && $args{nodeid} ne '') {
1471 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
1472 }
1473# end node hack
1474
1475 $dbh->commit; # Complex block allocation
1476 }; # end eval
1477 if ($@) {
1478 $msg .= ": ".$@;
1479 eval { $dbh->rollback; };
1480 return ('FAIL',$msg);
1481 }
1482
1483 } # end fullcidr != alloc_from
1484
1485 # now we do the DNS dance for netblocks, if we have an RPC server to do it with and a pattern to use.
1486 _rpc('addOrUpdateRevRec', cidr => "$args{cidr}", name => $args{rdns}, rpcuser => $args{user})
1487 if $args{rdns};
1488
1489 # and the per-IP set, if there is one.
1490 _rpc('updateRevSet', %{$args{iprev}}, rpcuser => $args{user});
1491
1492 return ('OK', 'OK');
1493
1494 } # end static-IP vs netblock allocation
1495
1496} # end allocateBlock()
1497
1498
1499## IPDB::initPool()
1500# Initializes a pool
1501# Requires a database handle, the pool CIDR, type, city, and a parameter
1502# indicating whether the pool should allow allocation of literally every
1503# IP, or if it should reserve network/gateway/broadcast IPs
1504# Note that this is NOT done in a transaction, that's why it's a private
1505# function and should ONLY EVER get called from allocateBlock()
1506sub initPool {
1507 my ($dbh,undef,$type,$city,$class,$parent) = @_;
1508 my $pool = new NetAddr::IP $_[1];
1509
1510 # IPv6 does not lend itself to IP pools as supported
1511 return ('FAIL',"Refusing to create IPv6 static IP pool") if $pool->{isv6};
1512 # IPv4 pools don't make much sense beyond even /24. Allow up to 4096-host footshooting anyway.
1513 # NetAddr::IP won't allow more than a /16 (65k hosts).
1514 return ('FAIL',"Refusing to create oversized static IP pool") if $pool->masklen <= 20;
1515
1516 # Retrieve some odds and ends for defaults on the IPs
1517 my ($pcustid) = $dbh->selectrow_array("SELECT def_custid FROM alloctypes WHERE type=?", undef, ($type) );
1518 my ($vrf,$vlan,$master) = $dbh->selectrow_array("SELECT vrf,vlan,master_id FROM allocations WHERE id = ?",
1519 undef, ($parent) );
1520
1521 $type =~ s/[pd]$/i/;
1522 my $sth;
1523 my $msg;
1524
1525 # Trap errors so we can pass them back to the caller. Even if the
1526 # caller is only ever supposed to be local, and therefore already
1527 # trapping errors. >:(
1528 local $dbh->{AutoCommit} = 0; # These need to be local so we don't
1529 local $dbh->{RaiseError} = 1; # step on our toes by accident.
1530
1531 eval {
1532 # have to insert all pool IPs into poolips table as "unallocated".
1533 $sth = $dbh->prepare("INSERT INTO poolips (ip,custid,city,type,parent_id,master_id) VALUES (?,?,?,?,?,?)");
1534
1535 # in case of pool extension by some means, we need to see what IPs were already inserted
1536 my $tmp1 = $dbh->selectall_arrayref("SELECT ip FROM poolips WHERE parent_id = ?", undef, $parent);
1537 my %foundips;
1538 foreach (@{$tmp1}) {
1539 $foundips{$_->[0]} = 1;
1540 }
1541
1542# Dodge an edge case - pool where IPs have been "stolen" and turned into a netblock assignment.
1543# We can't just "get all the current IPs, and add the missing ones", because some IPs are
1544# legitimately missing (for stretchy values of "legitimately").
1545
1546 my $pdata = getBlockData($dbh, $parent);
1547 my $pcidr = new NetAddr::IP $pdata->{block};
1548
1549 if ($pcidr != $pool) {
1550 # enumerate the IPs from the *old* pool, flag them as "found", so we can iterate the entire
1551 # requested pool and still make sure we skip the IPs in the old pool - even if they've been
1552 # "stolen" by legacy netblocks.
1553 my @oldips = $pcidr->hostenum;
1554 # decide whether to start excluding existing IPs at the "gateway" or "gateway+1"
1555 my $ostart = ($pdata->{type} =~ /^.d$/ ? 1 : 0);
1556 for (my $i = $ostart; $i<= $#oldips; $i++) {
1557 $foundips{$oldips[$i]} = 1;
1558 }
1559 }
1560
1561 # enumerate the hosts in the IP range - everything except the first (net) and last (bcast) IP
1562 my @poolip_list = $pool->hostenum;
1563
1564 # always check/add IPs from gw+1 through bcast-1:
1565 # (but the set won't be in oooorderrrrr! <pout>)
1566 for (my $i=1; $i<=$#poolip_list; $i++) {
1567 my $baseip = $poolip_list[$i]->addr;
1568 if ($baseip !~ /\.(?:0|255)$/ && !$foundips{$poolip_list[$i]}) {
1569 $sth->execute($baseip, $pcustid, $city, $type, $parent, $master);
1570 }
1571 }
1572
1573 # now do the special case - DSL/PPP blocks can use the "net", "gw", and "bcast" IPs.
1574 # we exclude .0 and .255 anyway, since while they'll mostly work, they *will* behave badly here and there.
1575 if ($class eq 'all') { # (DSL-ish block - *all* IPs available
1576 if ($pool->addr !~ /\.0$/) { # .0 causes weirdness.
1577 $sth->execute($pool->addr, $pcustid, $city, $type, $parent, $master) unless $foundips{$pool->addr};
1578 }
1579 $sth->execute($poolip_list[0]->addr, $pcustid, $city, $type, $parent, $master) unless $foundips{$poolip_list[0]};
1580 $pool--;
1581 if ($pool->addr !~ /\.255$/) { # .255 can cause weirdness.
1582 $sth->execute($pool->addr, $pcustid, $city, $type, $parent, $master) unless $foundips{$pool->addr};
1583 }
1584 }
1585# don't commit here! the caller may not be done.
1586# $dbh->commit;
1587 };
1588 if ($@) {
1589 $msg = $@;
1590# Don't roll back! It's up to the caller to handle this.
1591# eval { $dbh->rollback; };
1592 return ('FAIL',$msg);
1593 } else {
1594 return ('OK',"OK");
1595 }
1596} # end initPool()
1597
1598
1599## IPDB::updateBlock()
1600# Update an allocation
1601# Takes all allocation fields in a hash
1602sub updateBlock {
1603 my $dbh = shift;
1604 my %args = @_;
1605
1606 return ('FAIL', 'Missing block to update') if !$args{block};
1607
1608 # Spaces don't show up well in lots of places. Make sure they don't get into the DB.
1609 $args{custid} =~ s/^\s+//;
1610 $args{custid} =~ s/\s+$//;
1611
1612 # do it all in a transaction
1613 local $dbh->{AutoCommit} = 0;
1614 local $dbh->{RaiseError} = 1;
1615
1616 my @fieldlist;
1617 my @vallist;
1618 foreach ('custid', 'city', 'description', 'notes', 'circuitid', 'privdata', 'rdns', 'vrf', 'vlan') {
1619 if ($args{$_}) {
1620 push @fieldlist, $_;
1621 push @vallist, $args{$_};
1622 }
1623 }
1624
1625 my $binfo;
1626 my $updtable = 'allocations';
1627 my $keyfield = 'id';
1628 if ($args{type} =~ /^(.)i$/) {
1629 $updtable = 'poolips';
1630 $binfo = getBlockData($dbh, $args{block}, 'i');
1631 } else {
1632## fixme: there's got to be a better way...
1633 $binfo = getBlockData($dbh, $args{block});
1634 if ($args{swip}) {
1635 if ($args{swip} eq 'on' || $args{swip} eq '1' || $args{swip} eq 'y') {
1636 $args{swip} = 'y';
1637 } else {
1638 $args{swip} = 'n';
1639 }
1640 }
1641 foreach ('type', 'swip') {
1642 if ($args{$_}) {
1643 push @fieldlist, $_;
1644 push @vallist, $args{$_};
1645 }
1646 }
1647 }
1648
1649 return ('FAIL', 'No fields to update') if !@fieldlist;
1650
1651 my $sql = "UPDATE $updtable SET ";
1652 $sql .= join " = ?, ", @fieldlist;
1653
1654 eval {
1655 # check for block merge first...
1656 if ($args{fbmerge}) {
1657 my $cidr = NetAddr::IP->new($binfo->{block});
1658 my $newblock = NetAddr::IP->new($cidr->addr, $cidr->masklen - 1)->network;
1659 # safety net? make sure mergeable block passed in is really one or both of
1660 # a) reserved for expansion of the block and
1661 # b) confirmed CIDR-combinable
1662 # "safety? SELECT foo FROM freeblocks WHERE cidr << ? AND masklen(cidr) = ?, $newblock, ".$cidr->masklen."\n";
1663 $dbh->do("DELETE FROM freeblocks WHERE id=?", undef, $args{fbmerge});
1664 # ... so we can append the change in the stored CIDR field to extend the allocation.
1665 $sql .= " = ?, cidr";
1666 push @vallist, $newblock;
1667 # if we have an IP pool, call initPool to fill in any missing entries in the pool
1668 if ($binfo->{type} =~ /^.p$/) {
1669 my ($code,$rmsg) = initPool($dbh, "$newblock", $binfo->{type}, $binfo->{city}, 'all', $args{block});
1670 die $rmsg if $code eq 'FAIL';
1671 } elsif ($binfo->{type} =~ /^.d$/) {
1672 my ($code,$rmsg) = initPool($dbh, "$newblock", $binfo->{type}, $binfo->{city}, 'normal', $args{block});
1673 die $rmsg if $code eq 'FAIL';
1674 }
1675 }
1676
1677 # append another SQL fragment
1678 push @vallist, $args{block};
1679 $sql .= " = ? WHERE $keyfield = ?";
1680
1681 # do the update
1682 $dbh->do($sql, undef, @vallist);
1683
1684 if ($args{node}) {
1685 # done with delete/insert so we don't have to worry about funkyness updating a node ref that isn't there
1686 $dbh->do("DELETE FROM noderef WHERE block = ?", undef, ($binfo->{block}) );
1687 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($binfo->{block}, $args{node}) )
1688 if $args{node} ne '--';
1689 }
1690
1691 $dbh->commit;
1692 };
1693 if ($@) {
1694 my $msg = $@;
1695 $dbh->rollback;
1696 return ('FAIL', $msg);
1697 }
1698
1699 # In case of any container (mainly master block), only update freeblocks so we don't stomp subs
1700 # (which would be the wrong thing in pretty much any case except "DELETE ALL EVARYTHING!!1!oneone!")
1701 if ($binfo->{type} =~ '.[mc]') {
1702 # Not using listFree() as it doesn't return quite all of the blocks wanted.
1703 # Retrieve the immediate free blocks
1704 my $sth = $dbh->prepare(q(
1705 SELECT cidr FROM freeblocks WHERE parent_id = ?
1706 UNION
1707 SELECT cidr FROM freeblocks f WHERE
1708 cidr = (SELECT cidr FROM allocations a WHERE f.cidr = a.cidr)
1709 AND master_id = ?
1710 ) );
1711 $sth->execute($args{block}, $binfo->{master_id});
1712 my %fbset;
1713 while (my ($fb) = $sth->fetchrow_array) {
1714 $fbset{"host_$fb"} = $args{rdns};
1715 }
1716 # We use this RPC call instead of multiple addOrUpdateRevRec calls, since we don't
1717 # know how many records we'll be updating and more than 3-4 is far too slow. This
1718 # should be safe to call unconditionally.
1719 # Requires dnsadmin >= r678
1720 _rpc('updateRevSet', %fbset, rpcuser => $args{user});
1721
1722 } else {
1723 $binfo->{block} =~ s|/32$||;
1724 _rpc('addOrUpdateRevRec', cidr => $binfo->{block}, name => $args{rdns}, rpcuser => $args{user});
1725
1726 # and the per-IP set, if there is one.
1727 _rpc('updateRevSet', %{$args{iprev}}, rpcuser => $args{user}) if keys (%{$args{iprev}});
1728 }
1729
1730 return ('OK','OK');
1731} # end updateBlock()
1732
1733
1734## IPDB::splitBlock()
1735# Splits an existing allocation into two or more smaller allocations based on a passed netmask
1736# Duplicates all other data
1737# Returns an arrayref to a list of hashrefs with ID and CIDR keys for the list of new allocations.
1738# Should probably commit DNS magic to realign DNS data
1739# Mostly works but may return Strange Things(TM) if used on a master block
1740sub splitBlock {
1741 my $dbh = shift;
1742 my %args = @_;
1743# my $id = shift;
1744# my $basetype = shift;
1745# my $newmask = shift;
1746
1747##fixme: set errstr on errors so caller can suitably clue-by-four the user
1748 return if $args{basetype} ne 'b'; # only netblocks allowed!
1749
1750 my $binfo = getBlockData($dbh, $args{id});
1751 return if !$binfo;
1752
1753 return if $args{newmask} !~ /^\d+$/;
1754
1755 my @ret;
1756 my $block = new NetAddr::IP $binfo->{block};
1757 my $oldmask = $block->masklen;
1758
1759 # Fail if the block to split is "too small" - eg, can't split a v4 /32 at all
1760 # failure modes:
1761 # difference between $oldmask and $newmask is negative or 0
1762 if ($args{newmask} - $oldmask <= 0) {
1763 $errstr = "Can't split a /$oldmask allocation into /$args{newmask} pieces";
1764 return;
1765 }
1766# # difference between $oldmask and $newmask is > n, for arbitrary n?
1767# if ($newmask - $oldmask > 42) { # because 42
1768# }
1769 # $oldmask > n, for arbitrary n? At least check limits of data type.
1770 if ($block->{isv6}) {
1771 if ($args{newmask} - $oldmask > 128) {
1772 $errstr = "Impossible IPv6 mask length /$args{newmask} requested";
1773 return;
1774 }
1775 } else {
1776 if ($args{newmask} - $oldmask > 32) {
1777 $errstr = "Impossible IPv4 mask length /$args{newmask} requested";
1778 return;
1779 }
1780 }
1781
1782 my @newblocks = $block->split($args{newmask});
1783
1784 local $dbh->{AutoCommit} = 0;
1785 local $dbh->{RaiseError} = 1;
1786
1787 eval {
1788 # line up a list of fields and values. Be nice if there was a handy way to do,
1789 # direct in SQL, something like
1790 # "INSERT INTO foo (f1,f2,f3) VALUES (newf1,(SELECT oldf2,oldf3 FROM foo WHERE baz))"
1791 my @fieldlist = qw(type city description notes circuitid privdata custid swip vrf vlan rdns parent_id master_id);
1792 my $fields_sql = join(',', @fieldlist);
1793 my @vals;
1794 foreach (@fieldlist) {
1795 push @vals, $binfo->{$_};
1796 }
1797 # note the first block in the split for return
1798 push @ret, {nid => $args{id}, nblock => "$newblocks[0]"};
1799
1800 # prepare
1801 my $idsth = $dbh->prepare("SELECT currval('allocations_id_seq')");
1802 my $allocsth = $dbh->prepare("INSERT INTO allocations (cidr, $fields_sql)".
1803 " VALUES (?".',?'x(scalar(@fieldlist)).")");
1804 my $nbsth = $dbh->prepare("DELETE FROM poolips WHERE parent_id = ? AND ip = ?");
1805 my $upd_psth = $dbh->prepare("UPDATE allocations SET parent_id = ? WHERE parent_id = ? AND cidr <<= ?");
1806 my $upd_msth = $dbh->prepare("UPDATE allocations SET master_id = ? WHERE master_id = ? AND cidr <<= ?");
1807 my $fb_psth = $dbh->prepare("UPDATE freeblocks SET parent_id = ? WHERE parent_id = ? AND cidr <<= ?");
1808 my $fb_msth = $dbh->prepare("UPDATE freeblocks SET master_id = ? WHERE master_id = ? AND cidr <<= ?");
1809 my $pool_psth = $dbh->prepare("UPDATE poolips SET parent_id = ? WHERE parent_id = ? AND ip << ?");
1810 my $pool_msth = $dbh->prepare("UPDATE poolips SET master_id = ? WHERE master_id = ? AND ip <<= ?");
1811
1812 # set up update of existing block
1813 $dbh->do("UPDATE allocations SET cidr = ? WHERE id = ?", undef, ("$newblocks[0]", $args{id}) );
1814
1815 # axe the new bcast IP from the smaller pool at the "base" block, if it's a "normal" pool
1816 if ($binfo->{type} =~ /.d/) {
1817 $newblocks[0]--;
1818 $nbsth->execute($args{id}, $newblocks[0]->addr);
1819 }
1820
1821 # Loop over the new blocks that are not the base block
1822 for (my $i = 1; $i <= $#newblocks; $i++) {
1823 # add the new allocation
1824 $allocsth->execute($newblocks[$i], @vals);
1825 # fetch the ID of the entry we just added...
1826 $idsth->execute();
1827 my ($nid) = $idsth->fetchrow_array();
1828 # ... so we can pass back the list of blocks and IDs...
1829 push @ret, {nid => $nid, nblock => "$newblocks[$i]"};
1830 # axe the net, gw, and bcast IPs as necessary when splitting a "normal" pool
1831 if ($binfo->{type} =~ /.d/) {
1832 # net
1833 $nbsth->execute($args{id}, $newblocks[$i]->addr);
1834 $newblocks[$i]++;
1835 # gw
1836 $nbsth->execute($args{id}, $newblocks[$i]->addr);
1837 $newblocks[$i]--;
1838 $newblocks[$i]--;
1839 # bcast
1840 $nbsth->execute($args{id}, $newblocks[$i]->addr);
1841 $newblocks[$i]++;
1842 }
1843
1844 # Reparent allocations, freeblocks, and pool IPs.
1845 $upd_psth->execute($nid, $args{id}, $newblocks[$i]);
1846 $fb_psth->execute($nid, $args{id}, $newblocks[$i]);
1847 $pool_psth->execute($nid, $args{id}, $newblocks[$i]);
1848
1849 # Update master if we've split a master block
1850 if ($binfo->{type} eq 'mm') {
1851 $upd_msth->execute($nid, $args{id}, $newblocks[$i]);
1852 $fb_msth->execute($nid, $args{id}, $newblocks[$i]);
1853 $pool_msth->execute($nid, $args{id}, $newblocks[$i]);
1854 }
1855
1856 } # for (... @newblocks)
1857
1858 $dbh->commit;
1859 };
1860 if ($@) {
1861 $errstr = "Error splitting $binfo->{block}: $@";
1862 $dbh->rollback;
1863 return;
1864 }
1865##fixme: RPC return code?
1866# particularly useful in this case as there may be arbitrary combinations of pass, warn, fail
1867# results from each of the update and add(s), which could get the user to prod dnsadmin to see what exploded
1868 my $foo = _rpc('splitTemplate', cidr => $binfo->{block}, newmask => $args{newmask}, rpcuser => $args{user});
1869
1870 return \@ret;
1871} # end splitBlock()
1872
1873
1874## IPDB::shrinkBlock()
1875# Shrink an allocation to the passed CIDR block
1876# Takes an allocation ID and a new CIDR
1877# Returns an arrayref to a list of hashrefs with the ID and CIDR of the freed block(s)
1878# Refuses to shrink "real netblock" pool types below /30
1879sub shrinkBlock {
1880 my $dbh = shift;
1881 my $id = shift;
1882
1883 # just take the new CIDR spec; this way we can shrink eg .16/28 to .20/30 without extra contortions
1884 my $newblock = new NetAddr::IP shift;
1885
1886 if (!$newblock) {
1887 $errstr = "Can't shrink something that's not a netblock";
1888 return;
1889 }
1890
1891 my $binfo = getBlockData($dbh, $id);
1892 my $pinfo = getBlockData($dbh, $binfo->{parent_id});
1893
1894 if ($binfo->{type} =~ /.d/ && $newblock->masklen > ($newblock->bits+2) ) {
1895 $errstr = "Can't shrink a non-PPP pool smaller than ".($newblock->{isv6} ? '/124' : '/30');
1896 return;
1897 }
1898
1899 my $oldblock = new NetAddr::IP $binfo->{block};
1900
1901 # Don't try to shrink the block outside of itself, Bad Things (probably) Happen.
1902 if (!$oldblock->contains($newblock)) {
1903 $errstr = "Can't shrink an allocation outside of itself";
1904 return;
1905 }
1906
1907 local $dbh->{AutoCommit} = 0;
1908 local $dbh->{RaiseError} = 1;
1909
1910 my $addfbsth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)");
1911 my $idsth = $dbh->prepare("SELECT currval('freeblocks_id_seq')");
1912 my $poolsth = $dbh->prepare("DELETE FROM poolips WHERE parent_id = ? AND ip << ?");
1913 my $netsth = $dbh->prepare("DELETE FROM poolips WHERE parent_id = ? AND ip = ?");
1914 my $allocsth = $dbh->prepare("DELETE FROM allocations WHERE parent_id = ? AND cidr <<= ?");
1915 my $delfbsth = $dbh->prepare("DELETE FROM freeblocks WHERE parent_id = ? AND cidr <<= ?");
1916
1917##fixme: turn this into a public/top-level sub?
1918 sub getchildren {
1919 my $dbh = shift;
1920 my $id = shift;
1921 my $master = shift;
1922 my $retlist = shift; # better than trying to return complex structures recursively. Ow.
1923 my $cidr = shift;
1924
1925 if (!$cidr) {
1926 my $bd = getBlockData($dbh, $id);
1927 $cidr = $bd->{cidr};
1928 }
1929
1930 my $sth = $dbh->prepare(q(
1931 SELECT id,cidr,type FROM allocations
1932 WHERE parent_id = ? AND master_id = ? AND cidr <<= ?
1933 ) );
1934 $sth->execute($id, $master, $cidr);
1935 while (my $row = $sth->fetchrow_hashref) {
1936 push @$retlist, $row;
1937 getchildren($dbh, $row->{id}, $master, $retlist, $cidr);
1938 }
1939 }
1940
1941 my @ret;
1942 eval {
1943 $dbh->do("UPDATE allocations SET cidr = ? WHERE id = ?", undef, $newblock, $id);
1944
1945 # find the netblock(s) that are now free
1946 my @workingblocks = $oldblock->split($newblock->masklen);
1947 my @wb2;
1948 foreach my $newsub (@workingblocks) {
1949 next if $newsub == $newblock;
1950 push @wb2, $newsub;
1951 }
1952 @wb2 = Compact(@wb2);
1953
1954 # set new freeblocks, and clean up any IP pool entries if needed.
1955 foreach my $newfree (@wb2) {
1956 my @clist;
1957 # the block we're munging
1958 push @clist, { id => $id, type => $binfo->{type}, cidr => $binfo->{block} };
1959 getchildren($dbh, $id, $binfo->{master_id}, \@clist, $newfree);
1960
1961 foreach my $goner (@clist) {
1962 $poolsth->execute($goner->{id}, $newfree) if $goner->{type} =~ /.[dp]/;
1963 $allocsth->execute($goner->{id}, $newfree);
1964 $delfbsth->execute($goner->{id}, $newfree);
1965 }
1966
1967 # No pinfo means we're shrinking a master block, which means the free space is returned outside of IPDB.
1968 if ($pinfo) {
1969 $addfbsth->execute($newfree, $pinfo->{city}, 'm', $pinfo->{vrf}, $binfo->{parent_id}, $pinfo->{master_id});
1970 $idsth->execute;
1971 my ($nid) = $idsth->fetchrow_array();
1972 # add to return list
1973 push @ret, {fbid => $nid, newfree => "$newfree", fbparent => $binfo->{parent_id} };
1974 }
1975
1976 } # $newfree (@wb2)
1977
1978 # additional cleanup on net/gw/bcast IPs in pool
1979 if ($binfo->{type} =~ /.d/) {
1980 $netsth->execute($id, $newblock->addr);
1981 $newblock++;
1982 $netsth->execute($id, $newblock->addr);
1983 $newblock--;
1984 $newblock--;
1985 $netsth->execute($id, $newblock->addr);
1986 }
1987
1988 $dbh->commit;
1989 };
1990 if ($@) {
1991 $errstr = "Error splitting $binfo->{block}: $@";
1992 $dbh->rollback;
1993 return;
1994 }
1995
1996 return \@ret;
1997} # end shrinkBlock()
1998
1999
2000## IPDB::deleteBlock()
2001# Removes an allocation from the database, including deleting IPs
2002# from poolips and recombining entries in freeblocks if possible
2003# Also handles "deleting" a static IP allocation, and removal of a master
2004# Requires a database handle, the block to delete, the routing depth (if applicable),
2005# the VRF ID, and a flag to indicate whether to delete associated forward DNS entries
2006# as well as the reverse entry
2007sub deleteBlock {
2008 my ($dbh,$id,$basetype,$delfwd,$user) = @_;
2009
2010 # Collect info about the block we're going to delete
2011 my $binfo = getBlockData($dbh, $id, $basetype);
2012 my $cidr = new NetAddr::IP $binfo->{block};
2013
2014# For possible auto-VRF-ignoring (since public IPs shouldn't usually be present in more than one VRF)
2015# is_rfc1918 requires NetAddr::IP >= 4.059
2016# rather than doing this over and over and over.....
2017 my $tmpnum = $cidr->numeric;
2018# 192.168.0.0/16 -> 192.168.255.255 => 3232235520 -> 3232301055
2019# 172.16.0.0/12 -> 172.31.255.255 => 2886729728 -> 2887778303
2020# 10.0.0.0/8 -> 10.255.255.255 => 167772160 -> 184549375
2021 my $isprivnet = (3232235520 <= $tmpnum && $tmpnum <= 3232301055) ||
2022 (2886729728 <= $tmpnum && $tmpnum <= 2887778303) ||
2023 (167772160 <= $tmpnum && $tmpnum <= 184549375);
2024
2025 my $sth;
2026
2027 # Magic variables used for odd allocation cases.
2028 my $container;
2029 my $con_type;
2030
2031
2032 # temporarily forced null, until a sane UI for VRF tracking can be found.
2033# $vrf = '';# if !$vrf; # as with SQL, the null value is not equal to ''. *sigh*
2034
2035 # To contain the error message, if any.
2036 my $msg = "Unknown error deallocating $binfo->{type} $cidr";
2037 my $goback; # to put the parent in so we can link back where the deallocate started
2038
2039 # Enable transactions and exception-on-errors... but only for this sub
2040 local $dbh->{AutoCommit} = 0;
2041 local $dbh->{RaiseError} = 1;
2042
2043 if ($binfo->{type} =~ /^.i$/) {
2044 # First case. The "block" is a static IP
2045 # Note that we still need some additional code in the odd case
2046 # of a netblock-aligned contiguous group of static IPs
2047
2048 eval {
2049 $msg = "Unable to deallocate $disp_alloctypes{$binfo->{type}} $cidr";
2050 my $pinfo = getBlockData($dbh, $binfo->{parent_id}, 'b');
2051##fixme: VRF and rdepth
2052 $dbh->do("UPDATE poolips SET custid = ?, available = 'y',".
2053 "city = (SELECT city FROM allocations WHERE id = ?),".
2054 "description = '', notes = '', circuitid = '', vrf = ? WHERE id = ?", undef,
2055 ($pinfo->{custid}, $binfo->{parent_id}, $pinfo->{vrf}, $id) );
2056 $dbh->commit;
2057 };
2058 if ($@) {
2059 $msg .= ": $@";
2060 eval { $dbh->rollback; };
2061 return ('FAIL',$msg);
2062 } else {
2063##fixme: RPC return code?
2064 _rpc('delByCIDR', cidr => "$cidr", user => $user, delforward => $delfwd, rpcuser => $user);
2065 return ('OK',"OK");
2066 }
2067
2068 } elsif ($binfo->{type} eq 'mm') { # end alloctype =~ /.i/
2069 # Second case. The block is a full master block
2070
2071##fixme: VRF limit
2072 $msg = "Unable to delete master block $cidr";
2073 eval {
2074 $dbh->do("DELETE FROM allocations WHERE cidr <<= ? AND master_id = ?", undef, ($cidr, $binfo->{master_id}) );
2075 $dbh->do("DELETE FROM freeblocks WHERE cidr <<= ? AND master_id = ?", undef, ($cidr, $binfo->{master_id}) );
2076 $dbh->commit;
2077 };
2078 if ($@) {
2079 $msg .= ": $@";
2080 eval { $dbh->rollback; };
2081 return ('FAIL', $msg);
2082 }
2083
2084 # Have to handle potentially split reverse zones. Assume they *are* split,
2085 # since if we added them here, they would have been added split.
2086# allow splitting reverse zones to be disabled, maybe, someday
2087#if ($splitrevzones && !$cidr->{isv6}) {
2088 my @zonelist;
2089 if (1 && !$cidr->{isv6}) {
2090 my $splitpoint = ($cidr->masklen <= 16 ? 16 : 24); # hack pthui
2091 @zonelist = $cidr->split($splitpoint);
2092 } else {
2093 @zonelist = ($cidr);
2094 }
2095 my @fails;
2096 foreach my $subzone (@zonelist) {
2097 if ($rpc_url && !_rpc('delZone', zone => "$subzone", revrec => 'y', rpcuser => $user, delforward => $delfwd) ) {
2098 push @fails, ("$subzone" => $errstr);
2099 }
2100 }
2101 if (@fails) {
2102 return ('WARN',"Warning(s) deleting $cidr from reverse DNS:\n".join("\n", @fails));
2103 }
2104 return ('OK','OK');
2105
2106 } else { # end alloctype master block case
2107
2108 ## This is a big block; but it HAS to be done in a chunk. Any removal
2109 ## of a netblock allocation may result in a larger chunk of free
2110 ## contiguous IP space - which may in turn be combined into a single
2111 ## netblock rather than a number of smaller netblocks.
2112
2113 my $retcode = 'OK';
2114 my ($ptype,$pcity,$ppatt,$p_id);
2115
2116 eval {
2117
2118##fixme: add recursive flag to allow "YES DAMMIT DELETE ALL EVARYTHING!!1!!" without
2119# explicitly deleting any suballocations of the block to be deleted.
2120
2121 # get parent info of the block we're deleting
2122 my $pinfo = getBlockData($dbh, $binfo->{parent_id});
2123 $ptype = $pinfo->{type};
2124 $pcity = $pinfo->{city};
2125 $ppatt = $pinfo->{rdns};
2126 $p_id = $binfo->{parent_id};
2127
2128 # Delete the block
2129 $dbh->do("DELETE FROM allocations WHERE id = ?", undef, ($id) );
2130
2131 # munge the parent type a little
2132 $ptype = (split //, $ptype)[1];
2133
2134##fixme: you can't... CAN NOT.... assign the same public IP to multiple things.
2135# 'Net don't work like that, homey. Restrict VRF-uniqueness to private IPs?
2136# -> $isprivnet flag from start of sub
2137
2138 # check to see if any container allocations could be the "true" parent
2139 my ($tparent,$tpar_id,$trtype,$tcity);
2140 $tpar_id = 0;
2141
2142##fixme: this is far simpler in the strict VRF case; we "know" that any allocation
2143# contained by a container is a part of the same allocation tree when the VRF fields are equal.
2144
2145# logic:
2146# For each possible container of $cidr
2147# note the parent id
2148# walk the chain up the parents
2149# if we intersect $cidr's current parent, break
2150# if we've intersected $cidr's current parent
2151# set some variables to track that block
2152# break
2153
2154# Set up part of "is it in the middle of a pool?" check
2155 my $wuzpool = $dbh->selectrow_hashref("SELECT cidr,parent_id,type,city,custid,id FROM allocations ".
2156 "WHERE (type LIKE '_d' OR type LIKE '_p') AND cidr >> ? AND master_id = ?", { Slice => {} },
2157 ($cidr, $binfo->{master_id}) );
2158
2159##fixme?
2160# edge cases not handled, or handled badly:
2161# -> $cidr managed to get to be the entirety of an IP pool
2162
2163 if ($wuzpool && $wuzpool->{id} != $id) {
2164 # we have legacy goo to be purified
2165 # going to ignore nested pools; not possible to create them via API and no current legacy data includes any.
2166
2167 # for convenience
2168 my $poolid = $wuzpool->{id};
2169 my $pool = $wuzpool->{cidr};
2170 my $poolcity = $wuzpool->{city};
2171 my $pooltype = $wuzpool->{type};
2172 my $poolcustid = $wuzpool->{custid};
2173
2174 $retcode = 'WARNPOOL';
2175 $goback = "$poolid,$pool";
2176 # We've already deleted the block, now we have to stuff its IPs into the pool.
2177 $pooltype =~ s/[dp]$/i/; # change type to static IP
2178 my $sth2 = $dbh->prepare("INSERT INTO poolips (ip,city,type,custid,parent_id) VALUES ".
2179 "(?,'$poolcity','$pooltype','$poolcustid',$poolid)");
2180
2181##fixme: need to not insert net, gateway, and bcast on "real netblock" pools (DHCPish)
2182 # don't insert .0
2183 $sth2->execute($cidr->addr) unless $cidr->addr =~ m|\.0$|;
2184 $cidr++;
2185 my $bcast = $cidr->broadcast;
2186 while ($cidr != $bcast) {
2187 $sth2->execute($cidr->addr);
2188 $cidr++;
2189 }
2190 # don't insert .255
2191 $sth2->execute($cidr->addr) unless $cidr->addr =~ m|\.255$|;
2192
2193# Weirdness Happens. $cidr goes read-only somewhere (this is a thing?!?),
2194# causing ->split, ->hostenum, and related methods to explode. O_o
2195# foreach my $ip ($cidr->hostenum) {
2196# $sth2->execute($ip);
2197# }
2198
2199 }
2200
2201## important!
2202# ... or IS IT?
2203# we may have undef'ed $wuzpool above, if the allocation tree $cidr is in doesn't intersect the pool we found
2204#if (!$wuzpool) {
2205
2206 else {
2207
2208# Edge case: Block is the same size as more than one parent level. Should be rare.
2209# - mainly master + first routing. Sorting on parent_id hides the problem pretty well,
2210# but it's likely still possible to fail in particularly well-mangled databases.
2211# The ultimate fix for this may be to resurrect the "routing depth" atrocity. :/
2212 # Get all possible (and probably a number of impossible) containers for $cidr
2213 $sth = $dbh->prepare("SELECT cidr,parent_id,type,city,id FROM allocations ".
2214 "WHERE (type LIKE '_m' OR type LIKE '_c') AND cidr >>= ? AND master_id = ? ".
2215 "ORDER BY masklen(cidr) DESC,parent_id DESC");
2216 $sth->execute($cidr, $binfo->{master_id});
2217
2218 # Quickly get certain fields (simpler than getBlockData()
2219 my $sth2 = $dbh->prepare("SELECT cidr,parent_id,type,city FROM allocations ".
2220 "WHERE (type LIKE '_m' OR type LIKE '_c') AND id = ? AND master_id = ?");
2221
2222 # For each possible container of $cidr...
2223 while (my @data = $sth->fetchrow_array) {
2224 my $i = 0;
2225 # Save some state and set a start point - parent ID of container we're checking
2226 $tparent = $data[0];
2227 my $ppid = $data[1];
2228 $trtype = $data[2];
2229 $tcity = $data[3];
2230 $tpar_id = $data[4];
2231 last if $data[4] == $binfo->{parent_id}; # Preemptively break if we're already in the right place
2232 last if $ppid == $binfo->{parent_id}; # ... or if the parent of the container is the block's parent
2233 while (1) {
2234 # Retrieve bits on that parent ID
2235 $sth2->execute($ppid, $binfo->{master_id});
2236 my @container = $sth2->fetchrow_array;
2237 $ppid = $container[1];
2238 last if $container[1] == 0; # Break if we've hit a master block
2239 last if $ppid == $binfo->{parent_id}; # Break if we've reached the block $cidr is currently in
2240 }
2241 last if $ppid == $binfo->{parent_id};
2242 }
2243
2244 # found an alternate parent; reset some parent-info bits
2245 if ($tpar_id != $binfo->{parent_id}) {
2246 $ptype = (split //, $trtype)[1];
2247 $pcity = $tcity;
2248 $retcode = 'WARNMERGE'; # may be redundant
2249 $p_id = $tpar_id;
2250 }
2251
2252 $goback = "$p_id,$tparent"; # breadcrumb, currently only used in case of live-parent-is-not-true-parent
2253
2254 # Special case - delete pool IPs
2255 if ($binfo->{type} =~ /^.[pd]$/) {
2256 # We have to delete the IPs from the pool listing.
2257##fixme: rdepth? vrf?
2258 $dbh->do("DELETE FROM poolips WHERE parent_id = ?", undef, ($id) );
2259 }
2260
2261 $pinfo = getBlockData($dbh, $p_id);
2262
2263 # If the block wasn't legacy goo embedded in a static pool, we check the
2264 # freeblocks in the identified parent to see if we can combine any of them.
2265
2266 # if the block to be deleted is a container, move its freeblock(s) up a level, and reset their parenting info
2267 if ($binfo->{type} =~ /^.[mc]/) {
2268 # move the freeblocks into the parent
2269 # we don't insert a new freeblock because there could be a live reparented sub.
2270 $dbh->do("UPDATE freeblocks SET parent_id = ?, routed = ?, city = ? WHERE parent_id = ?", undef,
2271 ($p_id, $ptype, $pcity, $id) );
2272 } else {
2273 # ... otherwise, add the freeblock
2274 $dbh->do("INSERT INTO freeblocks (cidr, city, routed, parent_id, master_id) VALUES (?,?,?,?,?)", undef,
2275 ($cidr, $pcity, $ptype, $p_id, $binfo->{master_id}) );
2276 }
2277
2278 # Walk the free blocks in the parent and reduce them to the minimal set of CIDR ranges necessary
2279 _compactFree($dbh, $p_id);
2280
2281 } # done returning IPs to the appropriate place
2282
2283 # If we got here, we've succeeded. Whew!
2284 $dbh->commit;
2285 }; # end eval
2286 if ($@) {
2287 $msg .= ": $@";
2288 eval { $dbh->rollback; };
2289 return ('FAIL', $msg);
2290 } else {
2291##fixme: RPC return code?
2292 _rpc('delByCIDR', cidr => "$cidr", rpcuser => $user, delforward => $delfwd, delsubs => 'y', parpatt => $ppatt);
2293 return ($retcode, $goback);
2294 }
2295
2296 } # end alloctype != netblock
2297
2298} # end deleteBlock()
2299
2300
2301## IPDB::getBlockData()
2302# Get CIDR or IP, custid, type, city, circuit ID, description, notes, modification time,
2303# private/restricted data, for a CIDR block or pool IP
2304# Also returns SWIP status flag for CIDR blocks or pool netblock for IPs
2305# Takes the block ID or IP to look up and an optional flag to indicate a pool IP lookup
2306# instead of a netblock.
2307# Returns a hashref to the block data
2308sub getBlockData {
2309 my $dbh = shift;
2310 my $id = shift;
2311 my $type = shift || 'b'; # default to netblock for lazy callers
2312
2313 # netblocks are in the allocations table; pool IPs are in the poolips table.
2314 # If we try to look up a CIDR in an integer field we should just get back nothing.
2315 my ($btype) = $dbh->selectrow_array("SELECT type FROM allocations WHERE id=?", undef, ($id) );
2316
2317 # Note city, vrf, parent_id and master_id removed due to JOIN uncertainty for block allocations
2318 my $commonfields = q(custid, type, circuitid, description, notes, modifystamp AS lastmod,
2319 privdata, vlan, rdns);
2320
2321 if ($type eq 'i') {
2322 my $binfo = $dbh->selectrow_hashref(qq(
2323 SELECT id, ip AS block, city, vrf, parent_id, master_id, $commonfields
2324 FROM poolips WHERE id = ?
2325 ), undef, ($id) );
2326 return $binfo;
2327 } else {
2328 my $binfo = $dbh->selectrow_hashref(qq(
2329 SELECT a.id, a.cidr AS block, a.city, a.vrf, a.parent_id, a.master_id, swip, $commonfields,
2330 f.cidr AS reserve, f.id as reserve_id
2331 FROM allocations a LEFT JOIN freeblocks f ON a.id=f.reserve_for
2332 WHERE a.id = ?
2333 ), undef, ($id) );
2334 return $binfo;
2335 }
2336} # end getBlockData()
2337
2338
2339## IPDB::getBlockRDNS()
2340# Gets reverse DNS pattern for a block or IP. Note that this will also
2341# retrieve any default pattern following the parent chain up, and check via
2342# RPC (if available) to see what the narrowest pattern for the requested block is
2343# Returns the current pattern for the block or IP.
2344sub getBlockRDNS {
2345 my $dbh = shift;
2346 my %args = @_;
2347
2348 $args{type} = 'b' if !$args{type};
2349 my $cached = 1;
2350
2351 # snag entry from database
2352 my ($rdns,$rfrom,$pid);
2353 if ($args{type} =~ /.i/) {
2354 ($rdns, $rfrom, $pid) = $dbh->selectrow_array("SELECT rdns,ip,parent_id FROM poolips WHERE id = ?",
2355 undef, ($args{id}) );
2356 } else {
2357 ($rdns, $rfrom, $pid) = $dbh->selectrow_array("SELECT rdns,cidr,parent_id FROM allocations WHERE id = ?",
2358 undef, ($args{id}) );
2359 }
2360
2361 # Can't see a way this could end up empty, for any case I care about. If the caller
2362 # doesn't know an allocation ID to request, then they don't know anything else anyway.
2363 my $selfblock = $rfrom;
2364
2365 my $type;
2366 while (!$rdns && $pid) {
2367 ($rdns, $rfrom, $pid, $type) = $dbh->selectrow_array(
2368 "SELECT rdns,cidr,parent_id,type FROM allocations WHERE id = ?",
2369 undef, ($pid) );
2370 last if $type eq 'mm'; # break loops in unfortunate legacy data
2371 }
2372
2373 # use the actual allocation to check against the DNS utility; we don't want
2374 # to always go chasing up the chain to the master... which may (usually won't)
2375 # be present directly in DNS anyway
2376 my $cidr = new NetAddr::IP $selfblock;
2377
2378 if ($rpc_url) {
2379 # Use the first /16 or /24, rather than dithering over which sub-/14 /16
2380 # or sub-/19 /24 to retrieve - it's the least-wrong way to do things.
2381
2382 my ($rpcblock) = ($cidr->masklen <= 24 ? $cidr->split( ($cidr->masklen <= 16 ? 16 : 24) ) : $cidr);
2383 my %rpcargs = (
2384 rpcuser => $args{user},
2385 group => $revgroup, # not sure how this could sanely be exposed, tbh...
2386 cidr => "$rpcblock",
2387 );
2388
2389 my $remote_rdns = _rpc('getRevPattern', %rpcargs);
2390 $rdns = $remote_rdns if $remote_rdns;
2391 $cached = 0;
2392 }
2393
2394 # hmm. do we care about where it actually came from?
2395 return $rdns, $cached;
2396} # end getBlockRDNS()
2397
2398
2399## IPDB::getRDNSbyIP()
2400# Get individual reverse entries for the IP or CIDR IP range passed. Sort of looking the
2401# opposite direction down the netblock tree compared to getBlockRDNS() above.
2402sub getRDNSbyIP {
2403 my $dbh = shift;
2404 my %args = @_; # We want to accept a variety of call types
2405
2406 # key arguments: allocation ID, type
2407 unless ($args{id} || $args{type}) {
2408 $errstr = 'Missing allocation ID or type';
2409 return;
2410 }
2411
2412 my @ret = ();
2413 # special case: single IP. Check if it's an allocation or in a pool, then do the RPC call for fresh data.
2414 if ($args{type} =~ /^.i$/) {
2415 my ($ip, $localrev) = $dbh->selectrow_array("SELECT ip, rdns FROM poolips WHERE id = ?", undef, ($args{id}) );
2416 push @ret, { 'r_ip' => $ip, 'iphost' => $localrev };
2417 } else {
2418 if ($rpc_url) {
2419 my %rpcargs = (
2420 rpcuser => $args{user},
2421 group => $revgroup, # not sure how this could sanely be exposed, tbh...
2422 cidr => $args{range},
2423 );
2424
2425 my $remote_rdns = _rpc('getRevSet', %rpcargs);
2426 return $remote_rdns;
2427# $rdns = $remote_rdns if $remote_rdns;
2428# $cached = 0;
2429 }
2430 }
2431 return \@ret;
2432} # end getRDNSbyIP()
2433
2434
2435## IPDB::getNodeList()
2436# Gets a list of node ID+name pairs as an arrayref to a list of hashrefs
2437sub getNodeList {
2438 my $dbh = shift;
2439
2440 my $ret = $dbh->selectall_arrayref("SELECT node_id, node_name FROM nodes ORDER BY node_type,node_id",
2441 { Slice => {} });
2442 return $ret;
2443} # end getNodeList()
2444
2445
2446## IPDB::getNodeName()
2447# Get node name from the ID
2448sub getNodeName {
2449 my $dbh = shift;
2450 my $nid = shift;
2451
2452 my ($nname) = $dbh->selectrow_array("SELECT node_name FROM nodes WHERE node_id = ?", undef, ($nid) );
2453 return $nname;
2454} # end getNodeName()
2455
2456
2457## IPDB::getNodeInfo()
2458# Get node name and ID associated with a block
2459sub getNodeInfo {
2460 my $dbh = shift;
2461 my $block = shift;
2462
2463 my ($nid, $nname) = $dbh->selectrow_array("SELECT nodes.node_id,node_name FROM nodes INNER JOIN noderef".
2464 " ON nodes.node_id=noderef.node_id WHERE noderef.block = ?", undef, ($block) );
2465 return ($nid, $nname);
2466} # end getNodeInfo()
2467
2468
2469## IPDB::mailNotify()
2470# Sends notification mail to recipients regarding an IPDB operation
2471sub mailNotify {
2472 my $dbh = shift;
2473 my ($action,$subj,$message) = @_;
2474
2475 return if $smtphost eq 'smtp.example.com'; # do nothing if still using default SMTP host.
2476
2477##fixme: need to redesign the breakdown/processing for $action for proper handling of all cases
2478
2479# split action into parts for fiddlement. nb: there are almost certainly better ways to do this.
2480 my @actionbits = split //, $action;
2481
2482 # want to notify anyone who has specifically requested notify on *this* type ($action as passed),
2483 # on "all static IP types" or "all pool types" (and other last-char-in-type groupings), on eg "all DSL types",
2484 # and "all events with this action"
2485 my @actionsets = ($action);
2486##fixme: ick, eww. really gotta find a better way to handle this...
2487 push @actionsets, ($actionbits[0].'.'.$actionbits[2],
2488 $actionbits[0].$actionbits[1].'.', $actionbits[0].'a') if $action =~ /^.{3}$/;
2489
2490 my $mailer = Net::SMTP->new($smtphost, Hello => "ipdb.$domain");
2491
2492 # get recip list from db
2493 my $sth = $dbh->prepare("SELECT reciplist FROM notify WHERE action=?");
2494
2495 my %reciplist;
2496 foreach (@actionsets) {
2497 $sth->execute($_);
2498##fixme - need to handle db errors
2499 my ($recipsub) = $sth->fetchrow_array;
2500 next if !$recipsub;
2501 foreach (split(/,/, $recipsub)) {
2502 $reciplist{$_}++;
2503 }
2504 }
2505
2506 return if !%reciplist;
2507
2508 foreach my $recip (keys %reciplist) {
2509 $mailer->mail($smtpsender);
2510 $mailer->to($recip);
2511 $mailer->data("From: \"$org_name IP Database\" <$smtpsender>\n",
2512 "To: $recip\n",
2513 "Date: ".strftime("%a, %d %b %Y %H:%M:%S %z",localtime)."\n",
2514 "Subject: {IPDB} $subj\n",
2515 "X-Mailer: IPDB Notify v".sprintf("%.1d",$IPDB::VERSION)."\n",
2516 "Organization: $org_name\n",
2517 "\n$message\n");
2518 }
2519 $mailer->quit;
2520}
2521
2522# Indicates module loaded OK. Required by Perl.
25231;
Note: See TracBrowser for help on using the repository browser.