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

Last change on this file since 687 was 686, checked in by Kris Deugau, 10 years ago

/trunk

Put a bit of polish on updating DNS records when updating containers
(particularly when the container is the master block). We don't want
to stomp downstream subs, so we only update free blocks. This may result
in new DNS "sub" blocks, but when things get deleted far enough up the
chain they all go away anyway.
  • Property svn:keywords set to Date Rev Author
File size: 66.0 KB
Line 
1# ipdb/cgi-bin/IPDB.pm
2# Contains functions for IPDB - database access, subnet mangling, block allocation, etc
3###
4# SVN revision info
5# $Date: 2015-01-29 21:47:08 +0000 (Thu, 29 Jan 2015) $
6# SVN revision $Rev: 686 $
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 &listFree &listPool
32 &getMasterList &getTypeList &getPoolSelect &findAllocateFrom
33 &ipParent &subParent &blockParent &getRoutedCity
34 &allocateBlock &updateBlock &deleteBlock &getBlockData &getBlockRDNS &getRDNSbyIP
35 &getNodeList &getNodeName &getNodeInfo
36 &mailNotify
37 );
38
39@EXPORT = (); # Export nothing by default.
40%EXPORT_TAGS = ( ALL => [qw(
41 %disp_alloctypes %list_alloctypes %def_custids @citylist @poplist
42 %IPDBacl %aclmsg %rpcacl $maxfcgi
43 $errstr
44 &initIPDBGlobals &connectDB &finish &checkDBSanity
45 &addMaster &touchMaster
46 &listSummary &listSubs &listContainers &listAllocations &listFree &listPool
47 &getMasterList &getTypeList &getPoolSelect &findAllocateFrom
48 &ipParent &subParent &blockParent &getRoutedCity
49 &allocateBlock &updateBlock &deleteBlock &getBlockData &getBlockRDNS &getRDNSbyIP
50 &getNodeList &getNodeName &getNodeInfo
51 &mailNotify
52 )]
53 );
54
55##
56## Global variables
57##
58our %disp_alloctypes;
59our %list_alloctypes;
60our %def_custids;
61our @citylist;
62our @poplist;
63our %IPDBacl;
64
65# mapping table for functional-area => error message
66our %aclmsg = (
67 addmaster => 'add a master block',
68 addblock => 'add an allocation',
69 updateblock => 'update a block',
70 delblock => 'delete an allocation',
71 );
72
73our %rpcacl;
74our $maxfcgi = 3;
75
76# error reporting
77our $errstr = '';
78
79our $org_name = 'Example Corp';
80our $smtphost = 'smtp.example.com';
81our $domain = 'example.com';
82our $defcustid = '5554242';
83our $smtpsender = 'ipdb@example.com';
84# mostly for rwhois
85##fixme: leave these blank by default?
86our $rwhoisDataPath = '/usr/local/rwhoisd/etc/rwhoisd'; # to match ./configure defaults from rwhoisd-1.5.9.6
87our $org_street = '123 4th Street';
88our $org_city = 'Anytown';
89our $org_prov_state = 'ON';
90our $org_pocode = 'H0H 0H0';
91our $org_country = 'CA';
92our $org_phone = '000-555-1234';
93our $org_techhandle = 'ISP-ARIN-HANDLE';
94our $org_email = 'noc@example.com';
95our $hostmaster = 'dns@example.com';
96
97our $syslog_facility = 'local2';
98
99our $rpc_url = '';
100our $revgroup = 1; # should probably be configurable somewhere
101our $rpccount = 0;
102
103# Largest inverse CIDR mask length to show per-IP rDNS list
104# (eg, NetAddr::IP->bits - NetAddr::IP->masklen)
105our $maxrevlist = 5; # /27
106
107# UI layout for subblocks/containers
108our $sublistlayout = 1;
109
110##
111## Internal utility functions
112##
113
114## IPDB::_rpc
115# Make an RPC call for DNS changes
116sub _rpc {
117 return if !$rpc_url; # Just In Case
118 my $rpcsub = shift;
119 my %args = @_;
120
121 # Make an object to represent the XML-RPC server.
122 my $server = Frontier::Client->new(url => $rpc_url, debug => 0);
123 my $result;
124
125 my %rpcargs = (
126 rpcsystem => 'ipdb',
127# must be provided by caller's caller
128# rpcuser => $args{user},
129 %args,
130 );
131
132 eval {
133 $result = $server->call("dnsdb.$rpcsub", %rpcargs);
134 };
135 if ($@) {
136 $errstr = $@;
137 $errstr =~ s/\s*$//;
138 $errstr =~ s/Fault returned from XML RPC Server, fault code 4: error executing RPC `dnsdb.$rpcsub'\.\s//;
139 }
140 $rpccount++;
141
142 return $result if $result;
143} # end _rpc()
144
145
146# Let's initialize the globals.
147## IPDB::initIPDBGlobals()
148# Initialize all globals. Takes a database handle, returns a success or error code
149sub initIPDBGlobals {
150 my $dbh = $_[0];
151 my $sth;
152
153 # Initialize alloctypes hashes
154 $sth = $dbh->prepare("select type,listname,dispname,listorder,def_custid from alloctypes order by listorder");
155 $sth->execute;
156 while (my @data = $sth->fetchrow_array) {
157 $disp_alloctypes{$data[0]} = $data[2];
158 $def_custids{$data[0]} = $data[4];
159 if ($data[3] < 900) {
160 $list_alloctypes{$data[0]} = $data[1];
161 }
162 }
163
164 # City and POP listings
165 $sth = $dbh->prepare("select city,routing from cities order by city");
166 $sth->execute;
167 return (undef,$sth->errstr) if $sth->err;
168 while (my @data = $sth->fetchrow_array) {
169 push @citylist, $data[0];
170 if ($data[1] eq 'y') {
171 push @poplist, $data[0];
172 }
173 }
174
175 # Load ACL data. Specific username checks are done at a different level.
176 $sth = $dbh->prepare("select username,acl from users");
177 $sth->execute;
178 return (undef,$sth->errstr) if $sth->err;
179 while (my @data = $sth->fetchrow_array) {
180 $IPDBacl{$data[0]} = $data[1];
181 }
182
183##fixme: initialize HTML::Template env var for template path
184# something like $self->path().'/templates' ?
185# $ENV{HTML_TEMPLATE_ROOT} = 'foo/bar';
186
187 return (1,"OK");
188} # end initIPDBGlobals
189
190
191## IPDB::connectDB()
192# Creates connection to IPDB.
193# Requires the database name, username, and password.
194# Returns a handle to the db.
195# Set up for a PostgreSQL db; could be any transactional DBMS with the
196# right changes.
197sub connectDB {
198 my $dbname = shift;
199 my $user = shift;
200 my $pass = shift;
201 my $dbhost = shift;
202
203 my $dbh;
204 my $DSN = "DBI:Pg:".($dbhost ? "host=$dbhost;" : '')."dbname=$dbname";
205
206# Note that we want to autocommit by default, and we will turn it off locally as necessary.
207# We may not want to print gobbledygook errors; YMMV. Have to ponder that further.
208 $dbh = DBI->connect($DSN, $user, $pass, {
209 AutoCommit => 1,
210 PrintError => 0
211 })
212 or return (undef, $DBI::errstr) if(!$dbh);
213
214# Return here if we can't select. Note that this indicates a
215# problem executing the select.
216 my $sth = $dbh->prepare("select type from alloctypes");
217 $sth->execute();
218 return (undef,$DBI::errstr) if ($sth->err);
219
220# See if the select returned anything (or null data). This should
221# succeed if the select executed, but...
222 $sth->fetchrow();
223 return (undef,$DBI::errstr) if ($sth->err);
224
225# If we get here, we should be OK.
226 return ($dbh,"DB connection OK");
227} # end connectDB
228
229
230## IPDB::finish()
231# Cleans up after database handles and so on.
232# Requires a database handle
233sub finish {
234 my $dbh = $_[0];
235 $dbh->disconnect if $dbh;
236} # end finish
237
238
239## IPDB::checkDBSanity()
240# Quick check to see if the db is responding. A full integrity
241# check will have to be a separate tool to walk the IP allocation trees.
242sub checkDBSanity {
243 my ($dbh) = $_[0];
244
245 if (!$dbh) {
246 print "No database handle, or connection has been closed.";
247 return -1;
248 } else {
249 # it connects, try a stmt.
250 my $sth = $dbh->prepare("select type from alloctypes");
251 my $err = $sth->execute();
252
253 if ($sth->fetchrow()) {
254 # all is well.
255 return 1;
256 } else {
257 print "Connected to the database, but could not execute test statement. ".$sth->errstr();
258 return -1;
259 }
260 }
261 # Clean up after ourselves.
262# $dbh->disconnect;
263} # end checkDBSanity
264
265
266## IPDB::addMaster()
267# Does all the magic necessary to sucessfully add a master block
268# Requires database handle, block to add
269# Returns failure code and error message or success code and "message"
270sub addMaster {
271 my $dbh = shift;
272 # warning! during testing, this somehow generated a "Bad file descriptor" error. O_o
273 my $cidr = new NetAddr::IP shift;
274 my %args = @_;
275
276 $args{vrf} = '' if !$args{vrf};
277 $args{rdns} = '' if !$args{rdns};
278 $args{defloc} = '' if !$args{defloc};
279 $args{rwhois} = 'n' if !$args{rwhois}; # fail "safe", sort of.
280 $args{rwhois} = 'n' if $args{rwhois} ne 'n' and $args{rwhois} ne 'y';
281
282 my $mid;
283
284 # Allow transactions, and raise an exception on errors so we can catch it later.
285 # Use local to make sure these get "reset" properly on exiting this block
286 local $dbh->{AutoCommit} = 0;
287 local $dbh->{RaiseError} = 1;
288
289 # Wrap all the SQL in a transaction
290 eval {
291 # First check - does the master exist? Ignore VRFs until we can see a sane UI
292 my ($mcontained) = $dbh->selectrow_array("SELECT cidr FROM allocations WHERE cidr >>= ? AND type = 'mm'",
293 undef, ($cidr) );
294 die "Master block $mcontained already exists and entirely contains $cidr\n"
295 if $mcontained;
296
297 # Second check - does the new master contain an existing one or ones?
298 my ($mexist) = $dbh->selectrow_array("SELECT cidr FROM allocations WHERE cidr <<= ? AND type = 'mm'",
299 undef, ($cidr) );
300
301 if (!$mexist) {
302 # First case - master is brand-spanking-new.
303##fixme: rwhois should be globally-flagable somewhere, much like a number of other things
304## maybe a db table called "config"?
305 $dbh->do("INSERT INTO allocations (cidr,type,swip,vrf,rdns) VALUES (?,?,?,?,?)", undef,
306 ($cidr, 'mm', 'y', $args{vrf}, $args{rdns}) );
307 ($mid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
308
309# Unrouted blocks aren't associated with a city (yet). We don't rely on this
310# elsewhere though; legacy data may have traps and pitfalls in it to break this.
311# Thus the "routed" flag.
312 $dbh->do("INSERT INTO freeblocks (cidr,city,routed,parent_id,vrf,master_id) VALUES (?,?,?,?,?,?)", undef,
313 ($cidr, '<NULL>', 'm', $mid, $args{vrf}, $mid) );
314
315 # master should be its own master, so deletes directly at the master level work
316 $dbh->do("UPDATE allocations SET master_id = ? WHERE id = ?", undef, ($mid, $mid) );
317
318 # If we get here, everything is happy. Commit changes.
319 $dbh->commit;
320
321 } # done new master does not contain existing master(s)
322 else {
323
324 # collect the master(s) we're going to absorb, and snag the longest netmask while we're at it.
325 my $smallmask = $cidr->masklen;
326 my $sth = $dbh->prepare("SELECT cidr,id FROM allocations WHERE cidr <<= ? AND type='mm' AND parent_id=0");
327 $sth->execute($cidr);
328 my @cmasters;
329 my @oldmids;
330 while (my @data = $sth->fetchrow_array) {
331 my $master = new NetAddr::IP $data[0];
332 push @cmasters, $master;
333 push @oldmids, $data[1];
334 $smallmask = $master->masklen if $master->masklen > $smallmask;
335 }
336
337 # split the new master, and keep only those blocks not part of an existing master
338 my @blocklist;
339 foreach my $seg ($cidr->split($smallmask)) {
340 my $contained = 0;
341 foreach my $master (@cmasters) {
342 $contained = 1 if $master->contains($seg);
343 }
344 push @blocklist, $seg if !$contained;
345 }
346
347##fixme: master_id
348 # collect the unrouted free blocks within the new master
349 $sth = $dbh->prepare("SELECT cidr FROM freeblocks WHERE masklen(cidr) <= ? AND cidr <<= ? AND routed = 'm'");
350 $sth->execute($smallmask, $cidr);
351 while (my @data = $sth->fetchrow_array) {
352 my $freeblock = new NetAddr::IP $data[0];
353 push @blocklist, $freeblock;
354 }
355
356 # combine the set of free blocks we should have now.
357 @blocklist = Compact(@blocklist);
358
359 # master
360 $dbh->do("INSERT INTO allocations (cidr,type,swip,vrf,rdns) VALUES (?,?,?,?,?)", undef,
361 ($cidr, 'mm', 'y', $args{vrf}, $args{rdns}) );
362 ($mid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
363
364 # master should be its own master, so deletes directly at the master level work
365 $dbh->do("UPDATE allocations SET master_id = ? WHERE id = ?", undef, ($mid, $mid) );
366
367 # and now insert the new data. Make sure to delete old masters too.
368
369 # freeblocks
370 $sth = $dbh->prepare("DELETE FROM freeblocks WHERE cidr <<= ? AND parent_id IN (".join(',', @oldmids).")");
371 my $sth2 = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,parent_id,vrf,master_id)".
372 " VALUES (?,'<NULL>','m',?,?,?)");
373 foreach my $newblock (@blocklist) {
374 $sth->execute($newblock);
375 $sth2->execute($newblock, $mid, $args{vrf}, $mid);
376 }
377
378 # Update immediate allocations, and remove the old parents
379 $sth = $dbh->prepare("UPDATE allocations SET parent_id = ? WHERE parent_id = ?");
380 $sth2 = $dbh->prepare("DELETE FROM allocations WHERE id = ?");
381 foreach my $old (@oldmids) {
382 $sth->execute($mid, $old);
383 $sth2->execute($old);
384 }
385
386 # *whew* If we got here, we likely suceeded.
387 $dbh->commit;
388
389 } # new master contained existing master(s)
390 }; # end eval
391
392 if ($@) {
393 my $msg = $@;
394 eval { $dbh->rollback; };
395 return ('FAIL',$msg);
396 } else {
397
398 # Only attempt rDNS if the IPDB side succeeded
399 if ($rpc_url) {
400
401# Note *not* splitting reverse zones negates any benefit from caching the exported data.
402# IPv6 address space is far too large to split usefully, and in any case (also due to
403# the large address space) doesn't support the iterated template records v4 zones do
404# that causes the bulk of the slowdown that needs the cache anyway.
405
406 my @zonelist;
407# allow splitting reverse zones to be disabled, maybe, someday
408#if ($splitrevzones && !$cidr->{isv6}) {
409 if (1 && !$cidr->{isv6}) {
410 my $splitpoint = ($cidr->masklen <= 16 ? 16 : 24); # hack pthui
411 @zonelist = $cidr->split($splitpoint);
412 } else {
413 @zonelist = ($cidr);
414 }
415 my @fails;
416 ##fixme: remove hardcoding where possible
417 foreach my $subzone (@zonelist) {
418 my %rpcargs = (
419 rpcuser => $args{user},
420 revzone => "$subzone",
421 revpatt => $args{rdns},
422 defloc => $args{defloc},
423 group => $revgroup, # not sure how these two could sanely be exposed, tbh...
424 state => 1, # could make them globally configurable maybe
425 );
426 if ($rpc_url && !_rpc('addRDNS', %rpcargs)) {
427 push @fails, ("$subzone" => $errstr);
428 }
429 }
430 if (@fails) {
431 $errstr = "Warning(s) adding $cidr to reverse DNS:\n".join("\n", @fails);
432 return ('WARN',$mid);
433 }
434 }
435 return ('OK',$mid);
436 }
437} # end addMaster
438
439
440## IPDB::touchMaster()
441# Update last-changed timestamp on a master block.
442sub touchMaster {
443 my $dbh = shift;
444 my $master = shift;
445
446 local $dbh->{AutoCommit} = 0;
447 local $dbh->{RaiseError} = 1;
448
449 eval {
450 $dbh->do("UPDATE allocations SET modifystamp=now() WHERE id = ?", undef, ($master));
451 $dbh->commit;
452 };
453
454 if ($@) {
455 my $msg = $@;
456 eval { $dbh->rollback; };
457 return ('FAIL',$msg);
458 }
459 return ('OK','OK');
460} # end touchMaster()
461
462
463## IPDB::listSummary()
464# Get summary list of all master blocks
465# Returns an arrayref to a list of hashrefs containing the master block, routed count,
466# allocated count, free count, and largest free block masklength
467sub listSummary {
468 my $dbh = shift;
469
470 my $mlist = $dbh->selectall_arrayref("SELECT cidr AS master,id,vrf FROM allocations ".
471 "WHERE type='mm' ORDER BY cidr",
472 { Slice => {} });
473
474 foreach (@{$mlist}) {
475 my ($rcnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ? AND type='rm' AND master_id = ?",
476 undef, ($$_{master}, $$_{id}));
477 $$_{routed} = $rcnt;
478 my ($acnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
479 "AND NOT type='rm' AND NOT type='mm' AND master_id = ?",
480 undef, ($$_{master}, $$_{id}));
481 $$_{allocated} = $acnt;
482 my ($fcnt) = $dbh->selectrow_array("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?",
483 undef, ($$_{master}, $$_{id}));
484 $$_{free} = $fcnt;
485 my ($bigfree) = $dbh->selectrow_array("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?".
486 " AND master_id = ? ORDER BY masklen(cidr) LIMIT 1", undef, ($$_{master}, $$_{id}));
487##fixme: should find a way to do this without having to HTMLize the <>
488 $bigfree = "/$bigfree" if $bigfree;
489 $bigfree = '<NONE>' if !$bigfree;
490 $$_{bigfree} = $bigfree;
491 }
492 return $mlist;
493} # end listSummary()
494
495
496## IPDB::listSubs()
497# Get list of subnets within a specified CIDR block, on a specified VRF.
498# Returns an arrayref to a list of hashrefs containing the CIDR block, customer location or
499# city it's routed to, block type, SWIP status, and description
500sub listSubs {
501 my $dbh = shift;
502 my %args = @_;
503
504 # Just In Case
505 $args{vrf} = '' if !$args{vrf};
506
507 # Snag the allocations for this block
508 my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description,id,master_id".
509 " FROM allocations WHERE parent_id = ? ORDER BY cidr");
510 $sth->execute($args{parent});
511
512 # hack hack hack
513 # set up to flag swip=y records if they don't actually have supporting data in the customers table
514 my $custsth = $dbh->prepare("SELECT count(*) FROM customers WHERE custid = ?");
515
516 # snag some more details
517 my $substh = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
518 "AND type ~ '[mc]\$' AND master_id = ? AND NOT cidr = ? ");
519 my $alsth = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
520 "AND NOT type='rm' AND NOT type='mm' AND master_id = ?");
521 my $freesth = $dbh->prepare("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?");
522 my $lfreesth = $dbh->prepare("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?".
523 " AND master_id = ? ORDER BY masklen(cidr) LIMIT 1");
524
525 my @blocklist;
526 while (my ($cidr,$city,$type,$custid,$swip,$desc,$id,$mid) = $sth->fetchrow_array()) {
527 $custsth->execute($custid);
528 my ($ncust) = $custsth->fetchrow_array();
529 $substh->execute($cidr, $mid, $cidr);
530 my ($cont) = $substh->fetchrow_array();
531 $alsth->execute($cidr, $mid);
532 my ($alloc) = $alsth->fetchrow_array();
533 $freesth->execute($cidr, $mid);
534 my ($free) = $freesth->fetchrow_array();
535 $lfreesth->execute($cidr, $mid);
536 my ($lfree) = $lfreesth->fetchrow_array();
537 $lfree = "/$lfree" if $lfree;
538 $lfree = '<NONE>' if !$lfree;
539 my %row = (
540 block => $cidr,
541 subcontainers => $cont,
542 suballocs => $alloc,
543 subfree => $free,
544 lfree => $lfree,
545 city => $city,
546 type => $disp_alloctypes{$type},
547 custid => $custid,
548 swip => ($swip eq 'y' ? 'Yes' : 'No'),
549 partswip => ($swip eq 'y' && $ncust == 0 ? 1 : 0),
550 desc => $desc,
551 hassubs => ($type eq 'rm' || $type =~ /.c/ ? 1 : 0),
552 id => $id,
553 );
554# $row{subblock} = ($type =~ /^.r$/); # hmf. wonder why these won't work in the hash declaration...
555 $row{listpool} = ($type =~ /^.[pd]$/);
556 push (@blocklist, \%row);
557 }
558 return \@blocklist;
559} # end listSubs()
560
561
562## IPDB::listContainers()
563# List all container-type allocations in a given parent
564# Takes a database handle and a hash:
565# - parent is the ID of the parent block
566# Returns an arrayref to a list of hashrefs with the CIDR block, location, type,
567# description, block ID, and counts for the nmber uf suballocations (all types),
568# free blocks, and the CIDR size of the largest free block
569sub listContainers {
570 my $dbh = shift;
571 my %args = @_;
572
573 # Just In Case
574 $args{vrf} = '' if !$args{vrf};
575
576 # Snag the allocations for this block
577 my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description,id,master_id".
578 " FROM allocations WHERE parent_id = ? AND type ~ '[mc]\$' ORDER BY cidr");
579 $sth->execute($args{parent});
580
581 my $alsth = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
582 "AND NOT type='rm' AND NOT type='mm' AND master_id = ?");
583 my $freesth = $dbh->prepare("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?");
584 my $lfreesth = $dbh->prepare("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?".
585 " AND master_id = ? ORDER BY masklen(cidr) LIMIT 1");
586
587 my @blocklist;
588 while (my ($cidr,$city,$type,$custid,$swip,$desc,$id,$mid) = $sth->fetchrow_array()) {
589 $alsth->execute($cidr, $mid);
590 my ($alloc) = $alsth->fetchrow_array();
591 $freesth->execute($cidr, $mid);
592 my ($free) = $freesth->fetchrow_array();
593 $lfreesth->execute($cidr, $mid);
594 my ($lfree) = $lfreesth->fetchrow_array();
595 $lfree = "/$lfree" if $lfree;
596 $lfree = '<NONE>' if !$lfree;
597 my %row = (
598 block => $cidr,
599 suballocs => $alloc,
600 subfree => $free,
601 lfree => $lfree,
602 city => $city,
603 type => $disp_alloctypes{$type},
604 desc => $desc,
605 id => $id,
606 );
607 push (@blocklist, \%row);
608 }
609 return \@blocklist;
610} # end listContainers()
611
612
613## IPDB::listAllocations()
614# List all end-use allocations in a given parent
615# Takes a database handle and a hash:
616# - parent is the ID of the parent block
617# Returns an arrayref to a list of hashrefs with the CIDR block, location, type,
618# custID, SWIP flag, description, block ID, and master ID
619sub listAllocations {
620 my $dbh = shift;
621 my %args = @_;
622
623 # Snag the allocations for this block
624 my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description,id,master_id".
625 " FROM allocations WHERE parent_id = ? AND type !~ '[mc]\$' ORDER BY cidr");
626 $sth->execute($args{parent});
627
628 # hack hack hack
629 # set up to flag swip=y records if they don't actually have supporting data in the customers table
630 my $custsth = $dbh->prepare("SELECT count(*) FROM customers WHERE custid = ?");
631
632 my @blocklist;
633 while (my ($cidr,$city,$type,$custid,$swip,$desc,$id,$mid) = $sth->fetchrow_array()) {
634 $custsth->execute($custid);
635 my ($ncust) = $custsth->fetchrow_array();
636 my %row = (
637 block => $cidr,
638 city => $city,
639 type => $disp_alloctypes{$type},
640 custid => $custid,
641 swip => ($swip eq 'y' ? 'Yes' : 'No'),
642 partswip => ($swip eq 'y' && $ncust == 0 ? 1 : 0),
643 desc => $desc,
644 id => $id,
645 );
646# $row{subblock} = ($type =~ /^.r$/); # hmf. wonder why these won't work in the hash declaration...
647 $row{listpool} = ($type =~ /^.[pd]$/);
648 push (@blocklist, \%row);
649 }
650 return \@blocklist;
651} # end listAllocations()
652
653
654## IPDB::listFree()
655# Gets a list of free blocks in the requested parent/master and VRF instance in both CIDR and range notation
656# Takes a parent/master ID and an optional VRF specifier that defaults to empty.
657# Returns an arrayref to a list of hashrefs containing the CIDR and range-notation blocks
658# Returns some extra flags in the hashrefs for routed blocks, since those can have several subtypes
659sub listFree {
660 my $dbh = shift;
661
662 my %args = @_;
663 # Just In Case
664 $args{vrf} = '' if !$args{vrf};
665
666 my $sth = $dbh->prepare("SELECT cidr,id FROM freeblocks WHERE parent_id = ? ORDER BY cidr");
667# $sth->execute($args{parent}, $args{vrf});
668 $sth->execute($args{parent});
669 my @flist;
670 while (my ($cidr,$id) = $sth->fetchrow_array()) {
671 $cidr = new NetAddr::IP $cidr;
672 my %row = (
673 fblock => "$cidr",
674 frange => $cidr->range,
675 fbid => $id,
676 fbparent => $args{parent},
677 );
678 push @flist, \%row;
679 }
680 return \@flist;
681} # end listFree()
682
683
684## IPDB::listPool()
685#
686sub listPool {
687 my $dbh = shift;
688 my $pool = shift;
689
690 my $sth = $dbh->prepare("SELECT ip,custid,available,description,type,id".
691 " FROM poolips WHERE parent_id = ? ORDER BY ip");
692 $sth->execute($pool);
693 my @poolips;
694 while (my ($ip,$custid,$available,$desc,$type,$id) = $sth->fetchrow_array) {
695 my %row = (
696 ip => $ip,
697 custid => $custid,
698 available => $available,
699 desc => $desc,
700 delme => $available eq 'n',
701 parent => $pool,
702 id => $id,
703 );
704 push @poolips, \%row;
705 }
706 return \@poolips;
707} # end listPool()
708
709
710## IPDB::getMasterList()
711# Get a list of master blocks, optionally including last-modified timestamps
712# Takes an optional flag to indicate whether to include timestamps;
713# 'm' includes ctime, all others (suggest 'c') do not.
714# Returns an arrayref to a list of hashrefs
715sub getMasterList {
716 my $dbh = shift;
717 my $stampme = shift || 'm'; # optional but should be set by caller for clarity
718
719 my $mlist = $dbh->selectall_arrayref("SELECT id,vrf,cidr AS master".($stampme eq 'm' ? ',modifystamp AS mtime' : '').
720 " FROM allocations WHERE type='mm' ORDER BY cidr", { Slice => {} });
721 return $mlist;
722} # end getMasterList()
723
724
725## IPDB::getTypeList()
726# Get an alloctype/description pair list suitable for dropdowns
727# Takes a flag to determine which general groups of types are returned
728# Returns an reference to an array of hashrefs
729sub getTypeList {
730 my $dbh = shift;
731 my $tgroup = shift || 'a'; # technically optional, like this, but should
732 # really be specified in the call for clarity
733 my $tlist;
734 if ($tgroup eq 'n') {
735 # grouping 'p' - all netblock types. These include routed blocks, containers (_c)
736 # and contained (_r) types, dynamic-allocation ranges (_e), static IP pools (_d and _p),
737 # and the "miscellaneous" cn, in, and en types.
738 $tlist = $dbh->selectall_arrayref("SELECT type,listname FROM alloctypes WHERE listorder <= 500 ".
739 "AND type NOT LIKE '_i' ORDER BY listorder", { Slice => {} });
740 } elsif ($tgroup eq 'p') {
741 # grouping 'p' - primary allocation types. As with 'n' above but without the _r contained types.
742 $tlist = $dbh->selectall_arrayref("SELECT type,listname FROM alloctypes WHERE listorder <= 500 ".
743 "AND type NOT LIKE '_i' AND type NOT LIKE '_r' ORDER BY listorder", { Slice => {} });
744 } elsif ($tgroup eq 'c') {
745 # grouping 'c' - contained types. These include all static IPs and all _r types.
746 $tlist = $dbh->selectall_arrayref("SELECT type,listname FROM alloctypes WHERE listorder <= 500 ".
747 " AND (type LIKE '_i' OR type LIKE '_r') ORDER BY listorder", { Slice => {} });
748 } elsif ($tgroup eq 'i') {
749 # grouping 'i' - static IP types.
750 $tlist = $dbh->selectall_arrayref("SELECT type,listname FROM alloctypes WHERE listorder <= 500 ".
751 " AND type LIKE '_i' ORDER BY listorder", { Slice => {} });
752 } else {
753 # grouping 'a' - all standard allocation types. This includes everything
754 # but mm (present only as a formality). Make this the default.
755 $tlist = $dbh->selectall_arrayref("SELECT type,listname FROM alloctypes WHERE listorder <= 500 ".
756 " ORDER BY listorder", { Slice => {} });
757 }
758 return $tlist;
759}
760
761
762## IPDB::getPoolSelect()
763# Get a list of pools matching the passed city and type that have 1 or more free IPs
764# Returns an arrayref to a list of hashrefs
765sub getPoolSelect {
766 my $dbh = shift;
767 my $iptype = shift;
768 my $pcity = shift;
769
770 my ($ptype) = ($iptype =~ /^(.)i$/);
771 return if !$ptype;
772 $ptype .= '_';
773
774 my $plist = $dbh->selectall_arrayref( q(
775 SELECT count(*) AS poolfree,p.pool AS poolblock, a.city AS poolcit
776 FROM poolips p
777 JOIN allocations a ON p.parent_id=a.id
778 WHERE p.available='y' AND a.city = ? AND p.type LIKE ?
779 GROUP BY p.pool,a.city
780 ),
781 { Slice => {} }, ($pcity, $ptype) );
782 return $plist;
783} # end getPoolSelect()
784
785
786## IPDB::findAllocateFrom()
787# Find free block to add a new allocation from. (CIDR block version of pool select above, more or less)
788# Takes
789# - mask length
790# - allocation type
791# - POP city "parent"
792# - optional master-block restriction
793# - optional flag to allow automatic pick-from-private-network-ranges
794# Returns a string with the first CIDR block matching the criteria, if any
795sub findAllocateFrom {
796 my $dbh = shift;
797 my $maskbits = shift;
798 my $type = shift;
799 my $city = shift;
800 my $pop = shift;
801 my %optargs = @_;
802
803 my $failmsg = "No suitable free block found\n";
804
805 my @vallist;
806 my $sql;
807
808 # Free pool IPs should be easy.
809 if ($type =~ /^.i$/) {
810 # User may get an IP from the wrong VRF. User should not be using admin tools to allocate static IPs.
811 $sql = "SELECT id, ip, parent_id FROM poolips WHERE ip = ?";
812 @vallist = ($optargs{gimme});
813 } else {
814
815## Set up the SQL to find out what freeblock we can (probably) use for an allocation.
816## Very large systems will require development of a reserve system (possibly an extension
817## of the reserve-for-expansion concept in https://secure.deepnet.cx/trac/ipdb/ticket/24?)
818## Also populate a value list for the DBI call.
819
820 @vallist = ($maskbits);
821 $sql = "SELECT id,cidr,parent_id FROM freeblocks WHERE masklen(cidr) <= ?";
822
823# cases, strict rules
824# .c -> container type
825# requires a routing container, fbtype r
826# .d -> DHCP/"normal-routing" static pool
827# requires a routing container, fbtype r
828# .e -> Dynamic-assignment connectivity
829# requires a routing container, fbtype r
830# .i -> error, can't allocate static IPs this way?
831# mm -> error, master block
832# rm -> routed block
833# requires master block, fbtype m
834# .n -> Miscellaneous usage
835# requires a routing container, fbtype r
836# .p -> PPP(oE) static pool
837# requires a routing container, fbtype r
838# .r -> contained type
839# requires a matching container, fbtype $1
840##fixme: strict-or-not flag
841
842##fixme: config or UI flag for "Strict" mode
843# if ($strictmode) {
844if (0) {
845 if ($type =~ /^(.)r$/) {
846 push @vallist, $1;
847 $sql .= " AND routed = ?";
848 } elsif ($type eq 'rm') {
849 $sql .= " AND routed = 'm'";
850 } else {
851 $sql .= " AND routed = 'r'";
852 }
853}
854
855 # for PPP(oE) and container types, the POP city is the one attached to the pool.
856 # individual allocations get listed with the customer city site.
857 ##fixme: chain cities to align roughly with a full layer-2 node graph
858 $city = $pop if $type !~ /^.[pc]$/;
859 if ($type ne 'rm' && $city) {
860 $sql .= " AND city = ?";
861 push @vallist, $city;
862 }
863 # Allow specifying an arbitrary full block, instead of a master
864 if ($optargs{gimme}) {
865 $sql .= " AND cidr >>= ?";
866 push @vallist, $optargs{gimme};
867 }
868 # if a specific master was requested, allow the requestor to self->shoot(foot)
869 if ($optargs{master} && $optargs{master} ne '-') {
870 $sql .= " AND master_id = ?";
871# if $optargs{master} ne '-';
872 push @vallist, $optargs{master};
873 } else {
874 # if a specific master was NOT requested, filter out the RFC 1918 private networks
875 if (!$optargs{allowpriv}) {
876 $sql .= " AND NOT (cidr <<= '192.168.0.0/16' OR cidr <<= '10.0.0.0/8' OR cidr <<= '172.16.0.0/12')";
877 }
878 }
879 # Sorting and limiting, since we don't (currently) care to provide a selection of
880 # blocks to carve up. This preserves something resembling optimal usage of the IP
881 # space by forcing contiguous allocations and free blocks as much as possible.
882 $sql .= " ORDER BY masklen(cidr) DESC,cidr LIMIT 1";
883 } # done setting up SQL for free CIDR block
884
885 my ($fbid,$fbfound,$fbparent) = $dbh->selectrow_array($sql, undef, @vallist);
886 return $fbid,$fbfound,$fbparent;
887} # end findAllocateFrom()
888
889
890## IPDB::ipParent()
891# Get an IP's parent pool's details
892# Takes a database handle and IP
893# Returns a hashref to the parent pool block, if any
894sub ipParent {
895 my $dbh = shift;
896 my $block = shift;
897
898 my $pinfo = $dbh->selectrow_hashref("SELECT cidr,custid,type,city,description FROM allocations".
899 " WHERE cidr >>= ? AND (type LIKE '_p' OR type LIKE '_d')", undef, ($block) );
900 return $pinfo;
901} # end ipParent()
902
903
904## IPDB::subParent()
905# Get a block's parent's details
906# Takes a database handle and CIDR block
907# Returns a hashref to the parent container block, if any
908sub subParent {
909 my $dbh = shift;
910 my $block = shift;
911
912 my $pinfo = $dbh->selectrow_hashref("SELECT cidr,custid,type,city,description FROM allocations".
913 " WHERE cidr >>= ?", undef, ($block) );
914 return $pinfo;
915} # end subParent()
916
917
918## IPDB::blockParent()
919# Get a block's parent's details
920# Takes a database handle and CIDR block
921# Returns a hashref to the parent container block, if any
922sub blockParent {
923 my $dbh = shift;
924 my $block = shift;
925
926 my $pinfo = $dbh->selectrow_hashref("SELECT cidr,city FROM routed".
927 " WHERE cidr >>= ?", undef, ($block) );
928 return $pinfo;
929} # end blockParent()
930
931
932## IPDB::getRoutedCity()
933# Get the city for a routed block.
934sub getRoutedCity {
935 my $dbh = shift;
936 my $block = shift;
937
938 my ($rcity) = $dbh->selectrow_array("SELECT city FROM routed WHERE cidr = ?", undef, ($block) );
939 return $rcity;
940} # end getRoutedCity()
941
942
943## IPDB::allocateBlock()
944# Does all of the magic of actually allocating a netblock
945# Requires a database handle, and a hash containing the block to allocate, routing depth, custid,
946# type, city, block to allocate from, and optionally a description, notes, circuit ID,
947# and private data
948# Returns a success code and optional error message.
949sub allocateBlock {
950 my $dbh = shift;
951
952 my %args = @_;
953
954 $args{cidr} = new NetAddr::IP $args{cidr};
955
956 $args{desc} = '' if !$args{desc};
957 $args{notes} = '' if !$args{notes};
958 $args{circid} = '' if !$args{circid};
959 $args{privdata} = '' if !$args{privdata};
960 $args{vrf} = '' if !$args{vrf};
961 $args{rdns} = '' if !$args{rdns};
962
963 my $sth;
964
965 # Snag the "type" of the freeblock and its CIDR
966 my ($alloc_from_type, $alloc_from, $fbparent, $fcity, $fbmaster) =
967 $dbh->selectrow_array("SELECT routed,cidr,parent_id,city,master_id FROM freeblocks WHERE id = ?",
968 undef, $args{fbid});
969 $alloc_from = new NetAddr::IP $alloc_from;
970
971 # To contain the error message, if any.
972 my $msg = "Unknown error allocating $args{cidr} as '$disp_alloctypes{$args{type}}'";
973
974 # Enable transactions and error handling
975 local $dbh->{AutoCommit} = 0; # These need to be local so we don't
976 local $dbh->{RaiseError} = 1; # step on our toes by accident.
977
978 if ($args{type} =~ /^.i$/) {
979 $msg = "Unable to assign static IP $args{cidr} to $args{custid}";
980 eval {
981 if ($args{cidr}) { # IP specified
982 my ($isavail) = $dbh->selectrow_array("SELECT available FROM poolips WHERE ip=?", undef, ($args{cidr}) );
983 die "IP is not in an IP pool.\n"
984 if !$isavail;
985 die "IP already allocated. Deallocate and reallocate, or update the entry\n"
986 if $isavail eq 'n';
987 } else { # IP not specified, take first available
988 ($args{cidr}) = $dbh->selectrow_array("SELECT ip FROM poolips WHERE pool=? AND available='y' ORDER BY ip",
989 undef, ($args{alloc_from}) );
990 }
991 $dbh->do("UPDATE poolips SET custid = ?, city = ?,available='n', description = ?, notes = ?, ".
992 "circuitid = ?, privdata = ?, vrf = ?, rdns = ? ".
993 "WHERE ip = ? AND parent_id = ?", undef,
994 ($args{custid}, $args{city}, $args{desc}, $args{notes},
995 $args{circid}, $args{privdata}, $args{vrf}, $args{rdns},
996 $args{cidr}, $args{parent}) );
997
998# node hack
999 if ($args{nodeid} && $args{nodeid} ne '') {
1000 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
1001 }
1002# end node hack
1003
1004 $dbh->commit;
1005 };
1006 if ($@) {
1007 $msg .= ": $@";
1008 eval { $dbh->rollback; };
1009 return ('FAIL', $msg);
1010 } else {
1011 _rpc('addOrUpdateRevRec', cidr => "$args{cidr}", name => $args{rdns}, rpcuser => $args{user});
1012 return ('OK', $args{cidr});
1013 }
1014
1015 } else { # end IP-from-pool allocation
1016
1017 if ($args{cidr} == $alloc_from) {
1018 # Easiest case- insert in one table, delete in the other, and go home. More or less.
1019 # insert into allocations values (cidr,custid,type,city,desc) and
1020 # delete from freeblocks where cidr='cidr'
1021 # For data safety on non-transaction DBs, we delete first.
1022
1023 eval {
1024 $msg = "Unable to allocate $args{cidr} as '$disp_alloctypes{$args{type}}'";
1025
1026 # Insert the allocations entry
1027 $dbh->do("INSERT INTO allocations ".
1028 "(cidr,parent_id,master_id,vrf,custid,type,city,description,notes,circuitid,privdata,rdns)".
1029 " VALUES (?,?,?,?,?,?,?,?,?,?,?,?)", undef,
1030 ($args{cidr}, $fbparent, $fbmaster, $args{vrf}, $args{custid}, $args{type}, $args{city},
1031 $args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{rdns}) );
1032 my ($bid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
1033
1034 # Munge freeblocks
1035 if ($args{type} =~ /^(.)[mc]$/) {
1036 # special case - block is a routed or container/"reserve" block
1037 my $rtype = $1;
1038 $dbh->do("UPDATE freeblocks SET routed = ?,city = ?,parent_id = ? WHERE id = ?",
1039 undef, ($rtype, $args{city}, $bid, $args{fbid}) );
1040 } else {
1041 # "normal" case
1042 $dbh->do("DELETE FROM freeblocks WHERE id = ?", undef, ($args{fbid}) );
1043 }
1044
1045 # And initialize the pool, if necessary
1046 # PPPoE pools (currently dialup, DSL, and WiFi) get all IPs made available
1047 # "DHCP" or "real-subnet" pools have the net, gw, and bcast IPs removed.
1048 if ($args{type} =~ /^.p$/) {
1049 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1050 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "all", $bid);
1051 die $rmsg if $code eq 'FAIL';
1052 } elsif ($args{type} =~ /^.d$/) {
1053 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1054 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "normal", $bid);
1055 die $rmsg if $code eq 'FAIL';
1056 }
1057
1058# node hack
1059 if ($args{nodeid} && $args{nodeid} ne '') {
1060 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
1061 }
1062# end node hack
1063
1064 $dbh->commit;
1065 }; # end of eval
1066 if ($@) {
1067 $msg .= ": ".$@;
1068 eval { $dbh->rollback; };
1069 return ('FAIL',$msg);
1070 }
1071
1072 } else { # cidr != alloc_from
1073
1074 # Hard case. Allocation is smaller than free block.
1075
1076 # make sure new allocation is in fact within freeblock. *sigh*
1077 return ('FAIL',"Requested allocation $args{cidr} is not within $alloc_from")
1078 if !$alloc_from->contains($args{cidr});
1079 my $wantmaskbits = $args{cidr}->masklen;
1080 my $maskbits = $alloc_from->masklen;
1081
1082 my @newfreeblocks; # Holds free blocks generated from splitting the source freeblock.
1083
1084 # This determines which blocks will be left "free" after allocation. We take the
1085 # block we're allocating from, and split it in half. We see which half the wanted
1086 # block is in, and repeat until the wanted block is equal to one of the halves.
1087 my $i=0;
1088 my $tmp_from = $alloc_from; # So we don't munge $args{alloc_from}
1089 while ($maskbits++ < $wantmaskbits) {
1090 my @subblocks = $tmp_from->split($maskbits);
1091 $newfreeblocks[$i++] = (($args{cidr}->within($subblocks[0])) ? $subblocks[1] : $subblocks[0]);
1092 $tmp_from = ( ($args{cidr}->within($subblocks[0])) ? $subblocks[0] : $subblocks[1] );
1093 } # while
1094
1095 # Begin SQL transaction block
1096 eval {
1097 $msg = "Unable to allocate $args{cidr} as '$disp_alloctypes{$args{type}}'";
1098
1099 # Delete old freeblocks entry
1100 $dbh->do("DELETE FROM freeblocks WHERE id = ?", undef, ($args{fbid}) );
1101
1102 # Insert new list of smaller free blocks left over
1103 $sth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)");
1104 foreach my $block (@newfreeblocks) {
1105 $sth->execute($block, $fcity, $alloc_from_type, $args{vrf}, $fbparent, $fbmaster);
1106 }
1107
1108 # Insert the allocations entry
1109 $dbh->do("INSERT INTO allocations ".
1110 "(cidr,parent_id,master_id,vrf,custid,type,city,description,notes,circuitid,privdata,rdns)".
1111 " VALUES (?,?,?,?,?,?,?,?,?,?,?,?)", undef,
1112 ($args{cidr}, $fbparent, $fbmaster, $args{vrf}, $args{custid}, $args{type}, $args{city},
1113 $args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{rdns}) );
1114 my ($bid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
1115
1116 # For routed/container types, add a freeblock within the allocated block so we can subdivide it further
1117 if ($args{type} =~ /(.)[mc]/) { # rm and .c types - containers
1118 my $rtype = $1;
1119 $sth->execute($args{cidr}, $args{city}, $rtype, $args{vrf}, $bid, $fbmaster);
1120 }
1121
1122 # And initialize the pool, if necessary
1123 # PPPoE pools (currently dialup, DSL, and WiFi) get all IPs made available
1124 # "DHCP" or "real-subnet" pools have the net, gw, and bcast IPs removed.
1125 if ($args{type} =~ /^.p$/) {
1126 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1127 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "all", $bid);
1128 die $rmsg if $code eq 'FAIL';
1129 } elsif ($args{type} =~ /^.d$/) {
1130 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1131 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "normal", $bid);
1132 die $rmsg if $code eq 'FAIL';
1133 }
1134
1135# node hack
1136 if ($args{nodeid} && $args{nodeid} ne '') {
1137 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
1138 }
1139# end node hack
1140
1141 $dbh->commit;
1142 }; # end eval
1143 if ($@) {
1144 $msg .= ": ".$@;
1145 eval { $dbh->rollback; };
1146 return ('FAIL',$msg);
1147 }
1148
1149 } # end fullcidr != alloc_from
1150
1151 # now we do the DNS dance for netblocks, if we have an RPC server to do it with and a pattern to use.
1152 _rpc('addOrUpdateRevRec', cidr => "$args{cidr}", name => $args{rdns}, rpcuser => $args{user})
1153 if $args{rdns};
1154
1155 # and the per-IP set, if there is one.
1156 _rpc('updateRevSet', %{$args{iprev}}, rpcuser => $args{user});
1157
1158 return ('OK', 'OK');
1159
1160 } # end static-IP vs netblock allocation
1161
1162} # end allocateBlock()
1163
1164
1165## IPDB::initPool()
1166# Initializes a pool
1167# Requires a database handle, the pool CIDR, type, city, and a parameter
1168# indicating whether the pool should allow allocation of literally every
1169# IP, or if it should reserve network/gateway/broadcast IPs
1170# Note that this is NOT done in a transaction, that's why it's a private
1171# function and should ONLY EVER get called from allocateBlock()
1172sub initPool {
1173 my ($dbh,undef,$type,$city,$class,$parent) = @_;
1174 my $pool = new NetAddr::IP $_[1];
1175
1176 # IPv6 does not lend itself to IP pools as supported
1177 return ('FAIL',"Refusing to create IPv6 static IP pool") if $pool->{isv6};
1178 # IPv4 pools don't make much sense beyond even /24. Allow up to 4096-host footshooting anyway.
1179 # NetAddr::IP won't allow more than a /16 (65k hosts).
1180 return ('FAIL',"Refusing to create oversized static IP pool") if $pool->masklen <= 20;
1181
1182 my ($pcustid) = $dbh->selectrow_array("SELECT def_custid FROM alloctypes WHERE type=?", undef, ($type) );
1183 $type =~ s/[pd]$/i/;
1184 my $sth;
1185 my $msg;
1186
1187 # Trap errors so we can pass them back to the caller. Even if the
1188 # caller is only ever supposed to be local, and therefore already
1189 # trapping errors. >:(
1190 local $dbh->{AutoCommit} = 0; # These need to be local so we don't
1191 local $dbh->{RaiseError} = 1; # step on our toes by accident.
1192
1193 eval {
1194 # have to insert all pool IPs into poolips table as "unallocated".
1195 $sth = $dbh->prepare("INSERT INTO poolips (ip,custid,city,type,parent_id) VALUES (?,?,?,?,?)");
1196 my @poolip_list = $pool->hostenum;
1197 if ($class eq 'all') { # (DSL-ish block - *all* IPs available
1198 if ($pool->addr !~ /\.0$/) { # .0 causes weirdness.
1199 $sth->execute($pool->addr, $pcustid, $city, $type, $parent);
1200 }
1201 for (my $i=0; $i<=$#poolip_list; $i++) {
1202 $sth->execute($poolip_list[$i]->addr, $pcustid, $city, $type, $parent);
1203 }
1204 $pool--;
1205 if ($pool->addr !~ /\.255$/) { # .255 can cause weirdness.
1206 $sth->execute($pool->addr, $pcustid, $city, $type, $parent);
1207 }
1208 } else { # (real netblock)
1209 for (my $i=1; $i<=$#poolip_list; $i++) {
1210 $sth->execute($poolip_list[$i]->addr, $pcustid, $city, $type, $parent);
1211 }
1212 }
1213# don't commit here! the caller may not be done.
1214# $dbh->commit;
1215 };
1216 if ($@) {
1217 $msg = $@;
1218# Don't roll back! It's up to the caller to handle this.
1219# eval { $dbh->rollback; };
1220 return ('FAIL',$msg);
1221 } else {
1222 return ('OK',"OK");
1223 }
1224} # end initPool()
1225
1226
1227## IPDB::updateBlock()
1228# Update an allocation
1229# Takes all allocation fields in a hash
1230sub updateBlock {
1231 my $dbh = shift;
1232 my %args = @_;
1233
1234 return ('FAIL', 'Missing block to update') if !$args{block};
1235
1236 # Spaces don't show up well in lots of places. Make sure they don't get into the DB.
1237 $args{custid} =~ s/^\s+//;
1238 $args{custid} =~ s/\s+$//;
1239
1240 # do it all in a transaction
1241 local $dbh->{AutoCommit} = 0;
1242 local $dbh->{RaiseError} = 1;
1243
1244 my @fieldlist;
1245 my @vallist;
1246 foreach ('custid', 'city', 'description', 'notes', 'circuitid', 'privdata', 'rdns') {
1247 if ($args{$_}) {
1248 push @fieldlist, $_;
1249 push @vallist, $args{$_};
1250 }
1251 }
1252
1253 my $binfo;
1254 my $updtable = 'allocations';
1255 my $keyfield = 'id';
1256 if ($args{type} =~ /^(.)i$/) {
1257 $updtable = 'poolips';
1258 $binfo = getBlockData($dbh, $args{block}, 'i');
1259 } else {
1260## fixme: there's got to be a better way...
1261 $binfo = getBlockData($dbh, $args{block});
1262 if ($args{swip}) {
1263 if ($args{swip} eq 'on' || $args{swip} eq '1' || $args{swip} eq 'y') {
1264 $args{swip} = 'y';
1265 } else {
1266 $args{swip} = 'n';
1267 }
1268 }
1269 foreach ('type', 'swip') {
1270 if ($args{$_}) {
1271 push @fieldlist, $_;
1272 push @vallist, $args{$_};
1273 }
1274 }
1275 }
1276
1277 return ('FAIL', 'No fields to update') if !@fieldlist;
1278
1279 push @vallist, $args{block};
1280 my $sql = "UPDATE $updtable SET ";
1281 $sql .= join " = ?, ", @fieldlist;
1282 $sql .= " = ? WHERE $keyfield = ?";
1283
1284 eval {
1285 # do the update
1286 $dbh->do($sql, undef, @vallist);
1287
1288 if ($args{node}) {
1289 # done with delete/insert so we don't have to worry about funkyness updating a node ref that isn't there
1290 $dbh->do("DELETE FROM noderef WHERE block = ?", undef, ($binfo->{block}) );
1291 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($binfo->{block}, $args{node}) )
1292 if $args{node} ne '--';
1293 }
1294
1295 $dbh->commit;
1296 };
1297 if ($@) {
1298 my $msg = $@;
1299 $dbh->rollback;
1300 return ('FAIL', $msg);
1301 }
1302
1303 # In case of any container (mainly master block), only update freeblocks so we don't stomp subs
1304 # (which would be the wrong thing in pretty much any case except "DELETE ALL EVARYTHING!!1!oneone!")
1305 if ($binfo->{type} =~ '.[mc]') {
1306 # Not using listFree() as it doesn't return quite all of the blocks wanted.
1307 # Retrieve the immediate free blocks
1308 my $sth = $dbh->prepare(q(
1309 SELECT cidr FROM freeblocks WHERE parent_id = ?
1310 UNION
1311 SELECT cidr FROM freeblocks f WHERE
1312 cidr = (SELECT cidr FROM allocations a WHERE f.cidr = a.cidr)
1313 AND master_id = ?
1314 ) );
1315 $sth->execute($args{block}, $binfo->{master_id});
1316 my %fbset;
1317 while (my ($fb) = $sth->fetchrow_array) {
1318 $fbset{"host_$fb"} = $args{rdns};
1319 }
1320 # We use this RPC call instead of multiple addOrUpdateRevRec calls, since we don't
1321 # know how many records we'll be updating and more than 3-4 is far too slow. This
1322 # should be safe to call unconditionally.
1323 # Requires dnsadmin >= r678
1324 _rpc('updateRevSet', %fbset, rpcuser => $args{user});
1325
1326 } else {
1327 $binfo->{block} =~ s|/32$||;
1328 _rpc('addOrUpdateRevRec', cidr => $binfo->{block}, name => $args{rdns}, rpcuser => $args{user});
1329
1330 # and the per-IP set, if there is one.
1331 _rpc('updateRevSet', %{$args{iprev}}, rpcuser => $args{user}) if keys (%{$args{iprev}});
1332 }
1333
1334 return ('OK','OK');
1335} # end updateBlock()
1336
1337
1338## IPDB::deleteBlock()
1339# Removes an allocation from the database, including deleting IPs
1340# from poolips and recombining entries in freeblocks if possible
1341# Also handles "deleting" a static IP allocation, and removal of a master
1342# Requires a database handle, the block to delete, the routing depth (if applicable),
1343# the VRF ID, and a flag to indicate whether to delete associated forward DNS entries
1344# as well as the reverse entry
1345sub deleteBlock {
1346 my ($dbh,$id,$basetype,$delfwd,$user) = @_;
1347
1348 # Collect info about the block we're going to delete
1349 my $binfo = getBlockData($dbh, $id, $basetype);
1350 my $cidr = new NetAddr::IP $binfo->{block};
1351
1352# For possible auto-VRF-ignoring (since public IPs shouldn't usually be present in more than one VRF)
1353# is_rfc1918 requires NetAddr::IP >= 4.059
1354# rather than doing this over and over and over.....
1355 my $tmpnum = $cidr->numeric;
1356# 192.168.0.0/16 -> 192.168.255.255 => 3232235520 -> 3232301055
1357# 172.16.0.0/12 -> 172.31.255.255 => 2886729728 -> 2887778303
1358# 10.0.0.0/8 -> 10.255.255.255 => 167772160 -> 184549375
1359 my $isprivnet = (3232235520 <= $tmpnum && $tmpnum <= 3232301055) ||
1360 (2886729728 <= $tmpnum && $tmpnum <= 2887778303) ||
1361 (167772160 <= $tmpnum && $tmpnum <= 184549375);
1362
1363 my $sth;
1364
1365 # Magic variables used for odd allocation cases.
1366 my $container;
1367 my $con_type;
1368
1369
1370 # temporarily forced null, until a sane UI for VRF tracking can be found.
1371# $vrf = '';# if !$vrf; # as with SQL, the null value is not equal to ''. *sigh*
1372
1373 # To contain the error message, if any.
1374 my $msg = "Unknown error deallocating $binfo->{type} $cidr";
1375 my $goback; # to put the parent in so we can link back where the deallocate started
1376
1377 # Enable transactions and exception-on-errors... but only for this sub
1378 local $dbh->{AutoCommit} = 0;
1379 local $dbh->{RaiseError} = 1;
1380
1381 if ($binfo->{type} =~ /^.i$/) {
1382 # First case. The "block" is a static IP
1383 # Note that we still need some additional code in the odd case
1384 # of a netblock-aligned contiguous group of static IPs
1385
1386 eval {
1387 $msg = "Unable to deallocate $disp_alloctypes{$binfo->{type}} $cidr";
1388 my $pinfo = getBlockData($dbh, $binfo->{parent_id}, 'b');
1389##fixme: VRF and rdepth
1390 $dbh->do("UPDATE poolips SET custid = ?, available = 'y',".
1391 "city = (SELECT city FROM allocations WHERE id = ?),".
1392 "description = '', notes = '', circuitid = '', vrf = ? WHERE id = ?", undef,
1393 ($pinfo->{custid}, $binfo->{parent_id}, $pinfo->{vrf}, $id) );
1394 $dbh->commit;
1395 };
1396 if ($@) {
1397 $msg .= ": $@";
1398 eval { $dbh->rollback; };
1399 return ('FAIL',$msg);
1400 } else {
1401##fixme: RPC return code?
1402 _rpc('delByCIDR', cidr => "$cidr", user => $user, delforward => $delfwd, rpcuser => $user);
1403 return ('OK',"OK");
1404 }
1405
1406 } elsif ($binfo->{type} eq 'mm') { # end alloctype =~ /.i/
1407 # Second case. The block is a full master block
1408
1409##fixme: VRF limit
1410 $msg = "Unable to delete master block $cidr";
1411 eval {
1412 $dbh->do("DELETE FROM allocations WHERE cidr <<= ? AND master_id = ?", undef, ($cidr, $binfo->{master_id}) );
1413 $dbh->do("DELETE FROM freeblocks WHERE cidr <<= ? AND master_id = ?", undef, ($cidr, $binfo->{master_id}) );
1414 $dbh->commit;
1415 };
1416 if ($@) {
1417 $msg .= ": $@";
1418 eval { $dbh->rollback; };
1419 return ('FAIL', $msg);
1420 }
1421
1422 # Have to handle potentially split reverse zones. Assume they *are* split,
1423 # since if we added them here, they would have been added split.
1424# allow splitting reverse zones to be disabled, maybe, someday
1425#if ($splitrevzones && !$cidr->{isv6}) {
1426 my @zonelist;
1427 if (1 && !$cidr->{isv6}) {
1428 my $splitpoint = ($cidr->masklen <= 16 ? 16 : 24); # hack pthui
1429 @zonelist = $cidr->split($splitpoint);
1430 } else {
1431 @zonelist = ($cidr);
1432 }
1433 my @fails;
1434 foreach my $subzone (@zonelist) {
1435 if ($rpc_url && !_rpc('delZone', zone => "$subzone", revrec => 'y', rpcuser => $user, delforward => $delfwd) ) {
1436 push @fails, ("$subzone" => $errstr);
1437 }
1438 }
1439 if (@fails) {
1440 return ('WARN',"Warning(s) deleting $cidr from reverse DNS:\n".join("\n", @fails));
1441 }
1442 return ('OK','OK');
1443
1444 } else { # end alloctype master block case
1445
1446 ## This is a big block; but it HAS to be done in a chunk. Any removal
1447 ## of a netblock allocation may result in a larger chunk of free
1448 ## contiguous IP space - which may in turn be combined into a single
1449 ## netblock rather than a number of smaller netblocks.
1450
1451 my $retcode = 'OK';
1452 my ($ptype,$pcity,$ppatt,$p_id);
1453
1454 eval {
1455
1456##fixme: add recursive flag to allow "YES DAMMIT DELETE ALL EVARYTHING!!1!!" without
1457# explicitly deleting any suballocations of the block to be deleted.
1458
1459 # get parent info of the block we're deleting
1460 my $pinfo = getBlockData($dbh, $binfo->{parent_id});
1461 $ptype = $pinfo->{type};
1462 $pcity = $pinfo->{city};
1463 $ppatt = $pinfo->{rdns};
1464 $p_id = $binfo->{parent_id};
1465
1466 # Delete the block
1467 $dbh->do("DELETE FROM allocations WHERE id = ?", undef, ($id) );
1468
1469 # munge the parent type a little
1470 $ptype = (split //, $ptype)[1];
1471
1472##fixme: you can't... CAN NOT.... assign the same public IP to multiple things.
1473# 'Net don't work like that, homey. Restrict VRF-uniqueness to private IPs?
1474# -> $isprivnet flag from start of sub
1475
1476 # check to see if any container allocations could be the "true" parent
1477 my ($tparent,$tpar_id,$trtype,$tcity);
1478 $tpar_id = 0;
1479
1480##fixme: this is far simpler in the strict VRF case; we "know" that any allocation
1481# contained by a container is a part of the same allocation tree when the VRF fields are equal.
1482
1483# logic:
1484# For each possible container of $cidr
1485# note the parent id
1486# walk the chain up the parents
1487# if we intersect $cidr's current parent, break
1488# if we've intersected $cidr's current parent
1489# set some variables to track that block
1490# break
1491
1492# Set up part of "is it in the middle of a pool?" check
1493 my $wuzpool = $dbh->selectrow_hashref("SELECT cidr,parent_id,type,city,custid,id FROM allocations ".
1494 "WHERE (type LIKE '_d' OR type LIKE '_p') AND cidr >> ? AND master_id = ?", { Slice => {} },
1495 ($cidr, $binfo->{master_id}) );
1496
1497##fixme?
1498# edge cases not handled, or handled badly:
1499# -> $cidr managed to get to be the entirety of an IP pool
1500
1501 if ($wuzpool && $wuzpool->{id} != $id) {
1502 # we have legacy goo to be purified
1503 # going to ignore nested pools; not possible to create them via API and no current legacy data includes any.
1504
1505 # for convenience
1506 my $poolid = $wuzpool->{id};
1507 my $pool = $wuzpool->{cidr};
1508 my $poolcity = $wuzpool->{city};
1509 my $pooltype = $wuzpool->{type};
1510 my $poolcustid = $wuzpool->{custid};
1511
1512 $retcode = 'WARNPOOL';
1513 $goback = "$poolid,$pool";
1514 # We've already deleted the block, now we have to stuff its IPs into the pool.
1515 $pooltype =~ s/[dp]$/i/; # change type to static IP
1516 my $sth2 = $dbh->prepare("INSERT INTO poolips (ip,city,type,custid,parent_id) VALUES ".
1517 "(?,'$poolcity','$pooltype','$poolcustid',$poolid)");
1518
1519##fixme: need to not insert net, gateway, and bcast on "real netblock" pools (DHCPish)
1520 # don't insert .0
1521 $sth2->execute($cidr->addr) unless $cidr->addr =~ m|\.0$|;
1522 $cidr++;
1523 my $bcast = $cidr->broadcast;
1524 while ($cidr != $bcast) {
1525 $sth2->execute($cidr->addr);
1526 $cidr++;
1527 }
1528 # don't insert .255
1529 $sth2->execute($cidr->addr) unless $cidr->addr =~ m|\.255$|;
1530
1531# Weirdness Happens. $cidr goes read-only somewhere (this is a thing?!?),
1532# causing ->split, ->hostenum, and related methods to explode. O_o
1533# foreach my $ip ($cidr->hostenum) {
1534# $sth2->execute($ip);
1535# }
1536
1537 }
1538
1539## important!
1540# ... or IS IT?
1541# we may have undef'ed $wuzpool above, if the allocation tree $cidr is in doesn't intersect the pool we found
1542#if (!$wuzpool) {
1543
1544 else {
1545
1546# Edge case: Block is the same size as more than one parent level. Should be rare.
1547# - mainly master + first routing. Sorting on parent_id hides the problem pretty well,
1548# but it's likely still possible to fail in particularly well-mangled databases.
1549# The ultimate fix for this may be to resurrect the "routing depth" atrocity. :/
1550 # Get all possible (and probably a number of impossible) containers for $cidr
1551 $sth = $dbh->prepare("SELECT cidr,parent_id,type,city,id FROM allocations ".
1552 "WHERE (type LIKE '_m' OR type LIKE '_c') AND cidr >>= ? AND master_id = ? ".
1553 "ORDER BY masklen(cidr) DESC,parent_id DESC");
1554 $sth->execute($cidr, $binfo->{master_id});
1555
1556 # Quickly get certain fields (simpler than getBlockData()
1557 my $sth2 = $dbh->prepare("SELECT cidr,parent_id,type,city FROM allocations ".
1558 "WHERE (type LIKE '_m' OR type LIKE '_c') AND id = ? AND master_id = ?");
1559
1560 # For each possible container of $cidr...
1561 while (my @data = $sth->fetchrow_array) {
1562 my $i = 0;
1563 # Save some state and set a start point - parent ID of container we're checking
1564 $tparent = $data[0];
1565 my $ppid = $data[1];
1566 $trtype = $data[2];
1567 $tcity = $data[3];
1568 $tpar_id = $data[4];
1569 last if $data[4] == $binfo->{parent_id}; # Preemptively break if we're already in the right place
1570 last if $ppid == $binfo->{parent_id}; # ... or if the parent of the container is the block's parent
1571 while (1) {
1572 # Retrieve bits on that parent ID
1573 $sth2->execute($ppid, $binfo->{master_id});
1574 my @container = $sth2->fetchrow_array;
1575 $ppid = $container[1];
1576 last if $container[1] == 0; # Break if we've hit a master block
1577 last if $ppid == $binfo->{parent_id}; # Break if we've reached the block $cidr is currently in
1578 }
1579 last if $ppid == $binfo->{parent_id};
1580 }
1581
1582 # found an alternate parent; reset some parent-info bits
1583 if ($tpar_id != $binfo->{parent_id}) {
1584 $ptype = (split //, $trtype)[1];
1585 $pcity = $tcity;
1586 $retcode = 'WARNMERGE'; # may be redundant
1587 $p_id = $tpar_id;
1588 }
1589
1590 $goback = "$p_id,$tparent"; # breadcrumb, currently only used in case of live-parent-is-not-true-parent
1591
1592 # Special case - delete pool IPs
1593 if ($binfo->{type} =~ /^.[pd]$/) {
1594 # We have to delete the IPs from the pool listing.
1595##fixme: rdepth? vrf?
1596 $dbh->do("DELETE FROM poolips WHERE parent_id = ?", undef, ($id) );
1597 }
1598
1599 $pinfo = getBlockData($dbh, $p_id);
1600
1601 # If the block wasn't legacy goo embedded in a static pool, we check the
1602 # freeblocks in the identified parent to see if we can combine any of them.
1603
1604 # if the block to be deleted is a container, move its freeblock(s) up a level, and reset their parenting info
1605 if ($binfo->{type} =~ /^.[mc]/) {
1606 # move the freeblocks into the parent
1607 # we don't insert a new freeblock because there could be a live reparented sub.
1608 $dbh->do("UPDATE freeblocks SET parent_id = ?, routed = ?, city = ? WHERE parent_id = ?", undef,
1609 ($p_id, $ptype, $pcity, $id) );
1610 } else {
1611 # ... otherwise, add the freeblock
1612 $dbh->do("INSERT INTO freeblocks (cidr, city, routed, parent_id, master_id) VALUES (?,?,?,?,?)", undef,
1613 ($cidr, $pcity, $ptype, $p_id, $binfo->{master_id}) );
1614 }
1615
1616##fixme: vrf
1617##fixme: simplify since all containers now represent different "layers"/"levels"?
1618 # set up the query to get the list of blocks to try to merge.
1619 $sth = $dbh->prepare("SELECT cidr,id FROM freeblocks ".
1620 "WHERE parent_id = ? ".
1621 "ORDER BY masklen(cidr) DESC");
1622
1623 $sth->execute($p_id);
1624
1625# NetAddr::IP->compact() attempts to produce the smallest inclusive block
1626# from the caller and the passed terms.
1627# EG: if you call $cidr->compact($ip1,$ip2,$ip3) when $cidr, $ip1, $ip2,
1628# and $ip3 are consecutive /27's starting on .0 (.0-.31, .32-.63,
1629# .64-.95, and .96-.128), you will get an array containing a single
1630# /25 as element 0 (.0-.127). Order is not important; you could have
1631# $cidr=.32/27, $ip1=.96/27, $ip2=.0/27, and $ip3=.64/27.
1632
1633 my (@rawfb, @combinelist, %rawid);
1634 my $i=0;
1635 # for each free block under $parent, push a NetAddr::IP object into one list, and
1636 # continuously use NetAddr::IP->compact to automagically merge netblocks as possible.
1637 while (my @data = $sth->fetchrow_array) {
1638 my $testIP = new NetAddr::IP $data[0];
1639 push @rawfb, $testIP;
1640 $rawid{"$testIP"} = $data[1]; # $data[0] vs "$testIP" *does* make a difference for v6
1641 @combinelist = $testIP->compact(@combinelist);
1642 }
1643
1644 # now that we have the full list of "compacted" freeblocks, go back over
1645 # the list of raw freeblocks, and delete the ones that got merged.
1646 $sth = $dbh->prepare("DELETE FROM freeblocks WHERE id = ?");
1647 foreach my $rawfree (@rawfb) {
1648 next if grep { $rawfree == $_ } @combinelist; # skip if the raw block is in the compacted list
1649 $sth->execute($rawid{$rawfree});
1650 }
1651
1652 # now we walk the new list of compacted blocks, and see which ones we need to insert
1653 $sth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,parent_id,master_id) VALUES (?,?,?,?,?)");
1654 foreach my $cme (@combinelist) {
1655 next if grep { $cme == $_ } @rawfb; # skip if the combined block was in the raw list
1656 $sth->execute($cme, $pcity, $ptype, $p_id, $binfo->{master_id});
1657 }
1658
1659 } # done returning IPs to the appropriate place
1660
1661 # If we got here, we've succeeded. Whew!
1662 $dbh->commit;
1663 }; # end eval
1664 if ($@) {
1665 $msg .= ": $@";
1666 eval { $dbh->rollback; };
1667 return ('FAIL', $msg);
1668 } else {
1669##fixme: RPC return code?
1670 _rpc('delByCIDR', cidr => "$cidr", rpcuser => $user, delforward => $delfwd, delsubs => 'y', parpatt => $ppatt);
1671 return ($retcode, $goback);
1672 }
1673
1674 } # end alloctype != netblock
1675
1676} # end deleteBlock()
1677
1678
1679## IPDB::getBlockData()
1680# Get CIDR or IP, custid, type, city, circuit ID, description, notes, modification time,
1681# private/restricted data, for a CIDR block or pool IP
1682# Also returns SWIP status flag for CIDR blocks or pool netblock for IPs
1683# Takes the block ID or IP to look up and an optional flag to indicate a pool IP lookup
1684# instead of a netblock.
1685# Returns a hashref to the block data
1686sub getBlockData {
1687 my $dbh = shift;
1688 my $id = shift;
1689 my $type = shift || 'b'; # default to netblock for lazy callers
1690
1691 # netblocks are in the allocations table; pool IPs are in the poolips table.
1692 # If we try to look up a CIDR in an integer field we should just get back nothing.
1693 my ($btype) = $dbh->selectrow_array("SELECT type FROM allocations WHERE id=?", undef, ($id) );
1694
1695 if ($type eq 'i') {
1696 my $binfo = $dbh->selectrow_hashref("SELECT ip AS block, custid, type, city, circuitid, description,".
1697 " notes, modifystamp AS lastmod, privdata, vrf, rdns, parent_id, master_id".
1698 " FROM poolips WHERE id = ?", undef, ($id) );
1699 return $binfo;
1700 } else {
1701 my $binfo = $dbh->selectrow_hashref("SELECT cidr AS block, custid, type, city, circuitid, ".
1702 "description, notes, modifystamp AS lastmod, privdata, vrf, swip, rdns, parent_id, master_id".
1703 " FROM allocations WHERE id = ?", undef, ($id) );
1704 return $binfo;
1705 }
1706} # end getBlockData()
1707
1708
1709## IPDB::getBlockRDNS()
1710# Gets reverse DNS pattern for a block or IP. Note that this will also
1711# retrieve any default pattern following the parent chain up, and check via
1712# RPC (if available) to see what the narrowest pattern for the requested block is
1713# Returns the current pattern for the block or IP.
1714sub getBlockRDNS {
1715 my $dbh = shift;
1716 my %args = @_;
1717
1718 $args{type} = 'b' if !$args{type};
1719 my $cached = 1;
1720
1721 # snag entry from database
1722 my ($rdns,$rfrom,$pid);
1723 if ($args{type} =~ /.i/) {
1724 ($rdns, $rfrom, $pid) = $dbh->selectrow_array("SELECT rdns,ip,parent_id FROM poolips WHERE id = ?",
1725 undef, ($args{id}) );
1726 } else {
1727 ($rdns, $rfrom, $pid) = $dbh->selectrow_array("SELECT rdns,cidr,parent_id FROM allocations WHERE id = ?",
1728 undef, ($args{id}) );
1729 }
1730
1731 # Can't see a way this could end up empty, for any case I care about. If the caller
1732 # doesn't know an allocation ID to request, then they don't know anything else anyway.
1733 my $selfblock = $rfrom;
1734
1735 my $type;
1736 while (!$rdns && $pid) {
1737 ($rdns, $rfrom, $pid, $type) = $dbh->selectrow_array(
1738 "SELECT rdns,cidr,parent_id,type FROM allocations WHERE id = ?",
1739 undef, ($pid) );
1740 last if $type eq 'mm'; # break loops in unfortunate legacy data
1741 }
1742
1743 # use the actual allocation to check against the DNS utility; we don't want
1744 # to always go chasing up the chain to the master... which may (usually won't)
1745 # be present directly in DNS anyway
1746 my $cidr = new NetAddr::IP $selfblock;
1747
1748 if ($rpc_url) {
1749 # Use the first /16 or /24, rather than dithering over which sub-/14 /16
1750 # or sub-/19 /24 to retrieve - it's the least-wrong way to do things.
1751
1752 my ($rpcblock) = ($cidr->masklen <= 24 ? $cidr->split( ($cidr->masklen <= 16 ? 16 : 24) ) : $cidr);
1753 my %rpcargs = (
1754 rpcuser => $args{user},
1755 group => $revgroup, # not sure how this could sanely be exposed, tbh...
1756 cidr => "$rpcblock",
1757 );
1758
1759 my $remote_rdns = _rpc('getRevPattern', %rpcargs);
1760 $rdns = $remote_rdns if $remote_rdns;
1761 $cached = 0;
1762 }
1763
1764 # hmm. do we care about where it actually came from?
1765 return $rdns, $cached;
1766} # end getBlockRDNS()
1767
1768
1769## IPDB::getRDNSbyIP()
1770# Get individual reverse entries for the IP or CIDR IP range passed. Sort of looking the
1771# opposite direction down the netblock tree compared to getBlockRDNS() above.
1772sub getRDNSbyIP {
1773 my $dbh = shift;
1774 my %args = @_; # We want to accept a variety of call types
1775
1776 # key arguments: allocation ID, type
1777 unless ($args{id} || $args{type}) {
1778 $errstr = 'Missing allocation ID or type';
1779 return;
1780 }
1781
1782 my @ret = ();
1783 # special case: single IP. Check if it's an allocation or in a pool, then do the RPC call for fresh data.
1784 if ($args{type} =~ /^.i$/) {
1785 my ($ip, $localrev) = $dbh->selectrow_array("SELECT ip, rdns FROM poolips WHERE id = ?", undef, ($args{id}) );
1786 push @ret, { 'r_ip' => $ip, 'iphost' => $localrev };
1787 } else {
1788 if ($rpc_url) {
1789 my %rpcargs = (
1790 rpcuser => $args{user},
1791 group => $revgroup, # not sure how this could sanely be exposed, tbh...
1792 cidr => $args{range},
1793 );
1794
1795 my $remote_rdns = _rpc('getRevSet', %rpcargs);
1796 return $remote_rdns;
1797# $rdns = $remote_rdns if $remote_rdns;
1798# $cached = 0;
1799 }
1800 }
1801 return \@ret;
1802} # end getRDNSbyIP()
1803
1804
1805## IPDB::getNodeList()
1806# Gets a list of node ID+name pairs as an arrayref to a list of hashrefs
1807sub getNodeList {
1808 my $dbh = shift;
1809
1810 my $ret = $dbh->selectall_arrayref("SELECT node_id, node_name FROM nodes ORDER BY node_type,node_id",
1811 { Slice => {} });
1812 return $ret;
1813} # end getNodeList()
1814
1815
1816## IPDB::getNodeName()
1817# Get node name from the ID
1818sub getNodeName {
1819 my $dbh = shift;
1820 my $nid = shift;
1821
1822 my ($nname) = $dbh->selectrow_array("SELECT node_name FROM nodes WHERE node_id = ?", undef, ($nid) );
1823 return $nname;
1824} # end getNodeName()
1825
1826
1827## IPDB::getNodeInfo()
1828# Get node name and ID associated with a block
1829sub getNodeInfo {
1830 my $dbh = shift;
1831 my $block = shift;
1832
1833 my ($nid, $nname) = $dbh->selectrow_array("SELECT nodes.node_id,node_name FROM nodes INNER JOIN noderef".
1834 " ON nodes.node_id=noderef.node_id WHERE noderef.block = ?", undef, ($block) );
1835 return ($nid, $nname);
1836} # end getNodeInfo()
1837
1838
1839## IPDB::mailNotify()
1840# Sends notification mail to recipients regarding an IPDB operation
1841sub mailNotify {
1842 my $dbh = shift;
1843 my ($action,$subj,$message) = @_;
1844
1845 return if $smtphost eq 'smtp.example.com'; # do nothing if still using default SMTP host.
1846
1847##fixme: need to redesign the breakdown/processing for $action for proper handling of all cases
1848
1849# split action into parts for fiddlement. nb: there are almost certainly better ways to do this.
1850 my @actionbits = split //, $action;
1851
1852 # want to notify anyone who has specifically requested notify on *this* type ($action as passed),
1853 # on "all static IP types" or "all pool types" (and other last-char-in-type groupings), on eg "all DSL types",
1854 # and "all events with this action"
1855 my @actionsets = ($action);
1856##fixme: ick, eww. really gotta find a better way to handle this...
1857 push @actionsets, ($actionbits[0].'.'.$actionbits[2],
1858 $actionbits[0].$actionbits[1].'.', $actionbits[0].'a') if $action =~ /^.{3}$/;
1859
1860 my $mailer = Net::SMTP->new($smtphost, Hello => "ipdb.$domain");
1861
1862 # get recip list from db
1863 my $sth = $dbh->prepare("SELECT reciplist FROM notify WHERE action=?");
1864
1865 my %reciplist;
1866 foreach (@actionsets) {
1867 $sth->execute($_);
1868##fixme - need to handle db errors
1869 my ($recipsub) = $sth->fetchrow_array;
1870 next if !$recipsub;
1871 foreach (split(/,/, $recipsub)) {
1872 $reciplist{$_}++;
1873 }
1874 }
1875
1876 return if !%reciplist;
1877
1878 foreach my $recip (keys %reciplist) {
1879 $mailer->mail($smtpsender);
1880 $mailer->to($recip);
1881 $mailer->data("From: \"$org_name IP Database\" <$smtpsender>\n",
1882 "To: $recip\n",
1883 "Date: ".strftime("%a, %d %b %Y %H:%M:%S %z",localtime)."\n",
1884 "Subject: {IPDB} $subj\n",
1885 "X-Mailer: IPDB Notify v".sprintf("%.1d",$IPDB::VERSION)."\n",
1886 "Organization: $org_name\n",
1887 "\n$message\n");
1888 }
1889 $mailer->quit;
1890}
1891
1892# Indicates module loaded OK. Required by Perl.
18931;
Note: See TracBrowser for help on using the repository browser.