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

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

/trunk

Head off a potential point of confusion by blocking expandable template
patterns in reverse DNS for IPv6. At best they'll never work the same
way as for IPv4 simply due to the scale of the address space. Could be
considered for /120 and smaller allocations for network infrastructure
someday, maybe. See #1 and #22.
  • Property svn:keywords set to Date Rev Author
File size: 66.3 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-02-06 22:28:19 +0000 (Fri, 06 Feb 2015) $
6# SVN revision $Rev: 690 $
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 # Could arguably allow this for eg /120 allocations, but end users who get a single v4 IP are
964 # usually given a v6 /64, and most v6 addressing schemes need at least half that address space
965 if ($args{cidr}->{isv6} && $args{rdns} =~ /\%/) {
966 return ('FAIL','Reverse DNS template patterns are not supported for IPv6 allocations');
967 }
968
969 my $sth;
970
971 # Snag the "type" of the freeblock and its CIDR
972 my ($alloc_from_type, $alloc_from, $fbparent, $fcity, $fbmaster) =
973 $dbh->selectrow_array("SELECT routed,cidr,parent_id,city,master_id FROM freeblocks WHERE id = ?",
974 undef, $args{fbid});
975 $alloc_from = new NetAddr::IP $alloc_from;
976
977 # To contain the error message, if any.
978 my $msg = "Unknown error allocating $args{cidr} as '$disp_alloctypes{$args{type}}'";
979
980 # Enable transactions and error handling
981 local $dbh->{AutoCommit} = 0; # These need to be local so we don't
982 local $dbh->{RaiseError} = 1; # step on our toes by accident.
983
984 if ($args{type} =~ /^.i$/) {
985 $msg = "Unable to assign static IP $args{cidr} to $args{custid}";
986 eval {
987 if ($args{cidr}) { # IP specified
988 my ($isavail) = $dbh->selectrow_array("SELECT available FROM poolips WHERE ip=?", undef, ($args{cidr}) );
989 die "IP is not in an IP pool.\n"
990 if !$isavail;
991 die "IP already allocated. Deallocate and reallocate, or update the entry\n"
992 if $isavail eq 'n';
993 } else { # IP not specified, take first available
994 ($args{cidr}) = $dbh->selectrow_array("SELECT ip FROM poolips WHERE pool=? AND available='y' ORDER BY ip",
995 undef, ($args{alloc_from}) );
996 }
997 $dbh->do("UPDATE poolips SET custid = ?, city = ?,available='n', description = ?, notes = ?, ".
998 "circuitid = ?, privdata = ?, vrf = ?, rdns = ? ".
999 "WHERE ip = ? AND parent_id = ?", undef,
1000 ($args{custid}, $args{city}, $args{desc}, $args{notes},
1001 $args{circid}, $args{privdata}, $args{vrf}, $args{rdns},
1002 $args{cidr}, $args{parent}) );
1003
1004# node hack
1005 if ($args{nodeid} && $args{nodeid} ne '') {
1006 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
1007 }
1008# end node hack
1009
1010 $dbh->commit;
1011 };
1012 if ($@) {
1013 $msg .= ": $@";
1014 eval { $dbh->rollback; };
1015 return ('FAIL', $msg);
1016 } else {
1017 _rpc('addOrUpdateRevRec', cidr => "$args{cidr}", name => $args{rdns}, rpcuser => $args{user});
1018 return ('OK', $args{cidr});
1019 }
1020
1021 } else { # end IP-from-pool allocation
1022
1023 if ($args{cidr} == $alloc_from) {
1024 # Easiest case- insert in one table, delete in the other, and go home. More or less.
1025 # insert into allocations values (cidr,custid,type,city,desc) and
1026 # delete from freeblocks where cidr='cidr'
1027 # For data safety on non-transaction DBs, we delete first.
1028
1029 eval {
1030 $msg = "Unable to allocate $args{cidr} as '$disp_alloctypes{$args{type}}'";
1031
1032 # Insert the allocations entry
1033 $dbh->do("INSERT INTO allocations ".
1034 "(cidr,parent_id,master_id,vrf,custid,type,city,description,notes,circuitid,privdata,rdns)".
1035 " VALUES (?,?,?,?,?,?,?,?,?,?,?,?)", undef,
1036 ($args{cidr}, $fbparent, $fbmaster, $args{vrf}, $args{custid}, $args{type}, $args{city},
1037 $args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{rdns}) );
1038 my ($bid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
1039
1040 # Munge freeblocks
1041 if ($args{type} =~ /^(.)[mc]$/) {
1042 # special case - block is a routed or container/"reserve" block
1043 my $rtype = $1;
1044 $dbh->do("UPDATE freeblocks SET routed = ?,city = ?,parent_id = ? WHERE id = ?",
1045 undef, ($rtype, $args{city}, $bid, $args{fbid}) );
1046 } else {
1047 # "normal" case
1048 $dbh->do("DELETE FROM freeblocks WHERE id = ?", undef, ($args{fbid}) );
1049 }
1050
1051 # And initialize the pool, if necessary
1052 # PPPoE pools (currently dialup, DSL, and WiFi) get all IPs made available
1053 # "DHCP" or "real-subnet" pools have the net, gw, and bcast IPs removed.
1054 if ($args{type} =~ /^.p$/) {
1055 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1056 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "all", $bid);
1057 die $rmsg if $code eq 'FAIL';
1058 } elsif ($args{type} =~ /^.d$/) {
1059 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1060 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "normal", $bid);
1061 die $rmsg if $code eq 'FAIL';
1062 }
1063
1064# node hack
1065 if ($args{nodeid} && $args{nodeid} ne '') {
1066 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
1067 }
1068# end node hack
1069
1070 $dbh->commit;
1071 }; # end of eval
1072 if ($@) {
1073 $msg .= ": ".$@;
1074 eval { $dbh->rollback; };
1075 return ('FAIL',$msg);
1076 }
1077
1078 } else { # cidr != alloc_from
1079
1080 # Hard case. Allocation is smaller than free block.
1081
1082 # make sure new allocation is in fact within freeblock. *sigh*
1083 return ('FAIL',"Requested allocation $args{cidr} is not within $alloc_from")
1084 if !$alloc_from->contains($args{cidr});
1085 my $wantmaskbits = $args{cidr}->masklen;
1086 my $maskbits = $alloc_from->masklen;
1087
1088 my @newfreeblocks; # Holds free blocks generated from splitting the source freeblock.
1089
1090 # This determines which blocks will be left "free" after allocation. We take the
1091 # block we're allocating from, and split it in half. We see which half the wanted
1092 # block is in, and repeat until the wanted block is equal to one of the halves.
1093 my $i=0;
1094 my $tmp_from = $alloc_from; # So we don't munge $args{alloc_from}
1095 while ($maskbits++ < $wantmaskbits) {
1096 my @subblocks = $tmp_from->split($maskbits);
1097 $newfreeblocks[$i++] = (($args{cidr}->within($subblocks[0])) ? $subblocks[1] : $subblocks[0]);
1098 $tmp_from = ( ($args{cidr}->within($subblocks[0])) ? $subblocks[0] : $subblocks[1] );
1099 } # while
1100
1101 # Begin SQL transaction block
1102 eval {
1103 $msg = "Unable to allocate $args{cidr} as '$disp_alloctypes{$args{type}}'";
1104
1105 # Delete old freeblocks entry
1106 $dbh->do("DELETE FROM freeblocks WHERE id = ?", undef, ($args{fbid}) );
1107
1108 # Insert new list of smaller free blocks left over
1109 $sth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)");
1110 foreach my $block (@newfreeblocks) {
1111 $sth->execute($block, $fcity, $alloc_from_type, $args{vrf}, $fbparent, $fbmaster);
1112 }
1113
1114 # Insert the allocations entry
1115 $dbh->do("INSERT INTO allocations ".
1116 "(cidr,parent_id,master_id,vrf,custid,type,city,description,notes,circuitid,privdata,rdns)".
1117 " VALUES (?,?,?,?,?,?,?,?,?,?,?,?)", undef,
1118 ($args{cidr}, $fbparent, $fbmaster, $args{vrf}, $args{custid}, $args{type}, $args{city},
1119 $args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{rdns}) );
1120 my ($bid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
1121
1122 # For routed/container types, add a freeblock within the allocated block so we can subdivide it further
1123 if ($args{type} =~ /(.)[mc]/) { # rm and .c types - containers
1124 my $rtype = $1;
1125 $sth->execute($args{cidr}, $args{city}, $rtype, $args{vrf}, $bid, $fbmaster);
1126 }
1127
1128 # And initialize the pool, if necessary
1129 # PPPoE pools (currently dialup, DSL, and WiFi) get all IPs made available
1130 # "DHCP" or "real-subnet" pools have the net, gw, and bcast IPs removed.
1131 if ($args{type} =~ /^.p$/) {
1132 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1133 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "all", $bid);
1134 die $rmsg if $code eq 'FAIL';
1135 } elsif ($args{type} =~ /^.d$/) {
1136 $msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1137 my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "normal", $bid);
1138 die $rmsg if $code eq 'FAIL';
1139 }
1140
1141# node hack
1142 if ($args{nodeid} && $args{nodeid} ne '') {
1143 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
1144 }
1145# end node hack
1146
1147 $dbh->commit;
1148 }; # end eval
1149 if ($@) {
1150 $msg .= ": ".$@;
1151 eval { $dbh->rollback; };
1152 return ('FAIL',$msg);
1153 }
1154
1155 } # end fullcidr != alloc_from
1156
1157 # now we do the DNS dance for netblocks, if we have an RPC server to do it with and a pattern to use.
1158 _rpc('addOrUpdateRevRec', cidr => "$args{cidr}", name => $args{rdns}, rpcuser => $args{user})
1159 if $args{rdns};
1160
1161 # and the per-IP set, if there is one.
1162 _rpc('updateRevSet', %{$args{iprev}}, rpcuser => $args{user});
1163
1164 return ('OK', 'OK');
1165
1166 } # end static-IP vs netblock allocation
1167
1168} # end allocateBlock()
1169
1170
1171## IPDB::initPool()
1172# Initializes a pool
1173# Requires a database handle, the pool CIDR, type, city, and a parameter
1174# indicating whether the pool should allow allocation of literally every
1175# IP, or if it should reserve network/gateway/broadcast IPs
1176# Note that this is NOT done in a transaction, that's why it's a private
1177# function and should ONLY EVER get called from allocateBlock()
1178sub initPool {
1179 my ($dbh,undef,$type,$city,$class,$parent) = @_;
1180 my $pool = new NetAddr::IP $_[1];
1181
1182 # IPv6 does not lend itself to IP pools as supported
1183 return ('FAIL',"Refusing to create IPv6 static IP pool") if $pool->{isv6};
1184 # IPv4 pools don't make much sense beyond even /24. Allow up to 4096-host footshooting anyway.
1185 # NetAddr::IP won't allow more than a /16 (65k hosts).
1186 return ('FAIL',"Refusing to create oversized static IP pool") if $pool->masklen <= 20;
1187
1188 my ($pcustid) = $dbh->selectrow_array("SELECT def_custid FROM alloctypes WHERE type=?", undef, ($type) );
1189 $type =~ s/[pd]$/i/;
1190 my $sth;
1191 my $msg;
1192
1193 # Trap errors so we can pass them back to the caller. Even if the
1194 # caller is only ever supposed to be local, and therefore already
1195 # trapping errors. >:(
1196 local $dbh->{AutoCommit} = 0; # These need to be local so we don't
1197 local $dbh->{RaiseError} = 1; # step on our toes by accident.
1198
1199 eval {
1200 # have to insert all pool IPs into poolips table as "unallocated".
1201 $sth = $dbh->prepare("INSERT INTO poolips (ip,custid,city,type,parent_id) VALUES (?,?,?,?,?)");
1202 my @poolip_list = $pool->hostenum;
1203 if ($class eq 'all') { # (DSL-ish block - *all* IPs available
1204 if ($pool->addr !~ /\.0$/) { # .0 causes weirdness.
1205 $sth->execute($pool->addr, $pcustid, $city, $type, $parent);
1206 }
1207 for (my $i=0; $i<=$#poolip_list; $i++) {
1208 $sth->execute($poolip_list[$i]->addr, $pcustid, $city, $type, $parent);
1209 }
1210 $pool--;
1211 if ($pool->addr !~ /\.255$/) { # .255 can cause weirdness.
1212 $sth->execute($pool->addr, $pcustid, $city, $type, $parent);
1213 }
1214 } else { # (real netblock)
1215 for (my $i=1; $i<=$#poolip_list; $i++) {
1216 $sth->execute($poolip_list[$i]->addr, $pcustid, $city, $type, $parent);
1217 }
1218 }
1219# don't commit here! the caller may not be done.
1220# $dbh->commit;
1221 };
1222 if ($@) {
1223 $msg = $@;
1224# Don't roll back! It's up to the caller to handle this.
1225# eval { $dbh->rollback; };
1226 return ('FAIL',$msg);
1227 } else {
1228 return ('OK',"OK");
1229 }
1230} # end initPool()
1231
1232
1233## IPDB::updateBlock()
1234# Update an allocation
1235# Takes all allocation fields in a hash
1236sub updateBlock {
1237 my $dbh = shift;
1238 my %args = @_;
1239
1240 return ('FAIL', 'Missing block to update') if !$args{block};
1241
1242 # Spaces don't show up well in lots of places. Make sure they don't get into the DB.
1243 $args{custid} =~ s/^\s+//;
1244 $args{custid} =~ s/\s+$//;
1245
1246 # do it all in a transaction
1247 local $dbh->{AutoCommit} = 0;
1248 local $dbh->{RaiseError} = 1;
1249
1250 my @fieldlist;
1251 my @vallist;
1252 foreach ('custid', 'city', 'description', 'notes', 'circuitid', 'privdata', 'rdns') {
1253 if ($args{$_}) {
1254 push @fieldlist, $_;
1255 push @vallist, $args{$_};
1256 }
1257 }
1258
1259 my $binfo;
1260 my $updtable = 'allocations';
1261 my $keyfield = 'id';
1262 if ($args{type} =~ /^(.)i$/) {
1263 $updtable = 'poolips';
1264 $binfo = getBlockData($dbh, $args{block}, 'i');
1265 } else {
1266## fixme: there's got to be a better way...
1267 $binfo = getBlockData($dbh, $args{block});
1268 if ($args{swip}) {
1269 if ($args{swip} eq 'on' || $args{swip} eq '1' || $args{swip} eq 'y') {
1270 $args{swip} = 'y';
1271 } else {
1272 $args{swip} = 'n';
1273 }
1274 }
1275 foreach ('type', 'swip') {
1276 if ($args{$_}) {
1277 push @fieldlist, $_;
1278 push @vallist, $args{$_};
1279 }
1280 }
1281 }
1282
1283 return ('FAIL', 'No fields to update') if !@fieldlist;
1284
1285 push @vallist, $args{block};
1286 my $sql = "UPDATE $updtable SET ";
1287 $sql .= join " = ?, ", @fieldlist;
1288 $sql .= " = ? WHERE $keyfield = ?";
1289
1290 eval {
1291 # do the update
1292 $dbh->do($sql, undef, @vallist);
1293
1294 if ($args{node}) {
1295 # done with delete/insert so we don't have to worry about funkyness updating a node ref that isn't there
1296 $dbh->do("DELETE FROM noderef WHERE block = ?", undef, ($binfo->{block}) );
1297 $dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($binfo->{block}, $args{node}) )
1298 if $args{node} ne '--';
1299 }
1300
1301 $dbh->commit;
1302 };
1303 if ($@) {
1304 my $msg = $@;
1305 $dbh->rollback;
1306 return ('FAIL', $msg);
1307 }
1308
1309 # In case of any container (mainly master block), only update freeblocks so we don't stomp subs
1310 # (which would be the wrong thing in pretty much any case except "DELETE ALL EVARYTHING!!1!oneone!")
1311 if ($binfo->{type} =~ '.[mc]') {
1312 # Not using listFree() as it doesn't return quite all of the blocks wanted.
1313 # Retrieve the immediate free blocks
1314 my $sth = $dbh->prepare(q(
1315 SELECT cidr FROM freeblocks WHERE parent_id = ?
1316 UNION
1317 SELECT cidr FROM freeblocks f WHERE
1318 cidr = (SELECT cidr FROM allocations a WHERE f.cidr = a.cidr)
1319 AND master_id = ?
1320 ) );
1321 $sth->execute($args{block}, $binfo->{master_id});
1322 my %fbset;
1323 while (my ($fb) = $sth->fetchrow_array) {
1324 $fbset{"host_$fb"} = $args{rdns};
1325 }
1326 # We use this RPC call instead of multiple addOrUpdateRevRec calls, since we don't
1327 # know how many records we'll be updating and more than 3-4 is far too slow. This
1328 # should be safe to call unconditionally.
1329 # Requires dnsadmin >= r678
1330 _rpc('updateRevSet', %fbset, rpcuser => $args{user});
1331
1332 } else {
1333 $binfo->{block} =~ s|/32$||;
1334 _rpc('addOrUpdateRevRec', cidr => $binfo->{block}, name => $args{rdns}, rpcuser => $args{user});
1335
1336 # and the per-IP set, if there is one.
1337 _rpc('updateRevSet', %{$args{iprev}}, rpcuser => $args{user}) if keys (%{$args{iprev}});
1338 }
1339
1340 return ('OK','OK');
1341} # end updateBlock()
1342
1343
1344## IPDB::deleteBlock()
1345# Removes an allocation from the database, including deleting IPs
1346# from poolips and recombining entries in freeblocks if possible
1347# Also handles "deleting" a static IP allocation, and removal of a master
1348# Requires a database handle, the block to delete, the routing depth (if applicable),
1349# the VRF ID, and a flag to indicate whether to delete associated forward DNS entries
1350# as well as the reverse entry
1351sub deleteBlock {
1352 my ($dbh,$id,$basetype,$delfwd,$user) = @_;
1353
1354 # Collect info about the block we're going to delete
1355 my $binfo = getBlockData($dbh, $id, $basetype);
1356 my $cidr = new NetAddr::IP $binfo->{block};
1357
1358# For possible auto-VRF-ignoring (since public IPs shouldn't usually be present in more than one VRF)
1359# is_rfc1918 requires NetAddr::IP >= 4.059
1360# rather than doing this over and over and over.....
1361 my $tmpnum = $cidr->numeric;
1362# 192.168.0.0/16 -> 192.168.255.255 => 3232235520 -> 3232301055
1363# 172.16.0.0/12 -> 172.31.255.255 => 2886729728 -> 2887778303
1364# 10.0.0.0/8 -> 10.255.255.255 => 167772160 -> 184549375
1365 my $isprivnet = (3232235520 <= $tmpnum && $tmpnum <= 3232301055) ||
1366 (2886729728 <= $tmpnum && $tmpnum <= 2887778303) ||
1367 (167772160 <= $tmpnum && $tmpnum <= 184549375);
1368
1369 my $sth;
1370
1371 # Magic variables used for odd allocation cases.
1372 my $container;
1373 my $con_type;
1374
1375
1376 # temporarily forced null, until a sane UI for VRF tracking can be found.
1377# $vrf = '';# if !$vrf; # as with SQL, the null value is not equal to ''. *sigh*
1378
1379 # To contain the error message, if any.
1380 my $msg = "Unknown error deallocating $binfo->{type} $cidr";
1381 my $goback; # to put the parent in so we can link back where the deallocate started
1382
1383 # Enable transactions and exception-on-errors... but only for this sub
1384 local $dbh->{AutoCommit} = 0;
1385 local $dbh->{RaiseError} = 1;
1386
1387 if ($binfo->{type} =~ /^.i$/) {
1388 # First case. The "block" is a static IP
1389 # Note that we still need some additional code in the odd case
1390 # of a netblock-aligned contiguous group of static IPs
1391
1392 eval {
1393 $msg = "Unable to deallocate $disp_alloctypes{$binfo->{type}} $cidr";
1394 my $pinfo = getBlockData($dbh, $binfo->{parent_id}, 'b');
1395##fixme: VRF and rdepth
1396 $dbh->do("UPDATE poolips SET custid = ?, available = 'y',".
1397 "city = (SELECT city FROM allocations WHERE id = ?),".
1398 "description = '', notes = '', circuitid = '', vrf = ? WHERE id = ?", undef,
1399 ($pinfo->{custid}, $binfo->{parent_id}, $pinfo->{vrf}, $id) );
1400 $dbh->commit;
1401 };
1402 if ($@) {
1403 $msg .= ": $@";
1404 eval { $dbh->rollback; };
1405 return ('FAIL',$msg);
1406 } else {
1407##fixme: RPC return code?
1408 _rpc('delByCIDR', cidr => "$cidr", user => $user, delforward => $delfwd, rpcuser => $user);
1409 return ('OK',"OK");
1410 }
1411
1412 } elsif ($binfo->{type} eq 'mm') { # end alloctype =~ /.i/
1413 # Second case. The block is a full master block
1414
1415##fixme: VRF limit
1416 $msg = "Unable to delete master block $cidr";
1417 eval {
1418 $dbh->do("DELETE FROM allocations WHERE cidr <<= ? AND master_id = ?", undef, ($cidr, $binfo->{master_id}) );
1419 $dbh->do("DELETE FROM freeblocks WHERE cidr <<= ? AND master_id = ?", undef, ($cidr, $binfo->{master_id}) );
1420 $dbh->commit;
1421 };
1422 if ($@) {
1423 $msg .= ": $@";
1424 eval { $dbh->rollback; };
1425 return ('FAIL', $msg);
1426 }
1427
1428 # Have to handle potentially split reverse zones. Assume they *are* split,
1429 # since if we added them here, they would have been added split.
1430# allow splitting reverse zones to be disabled, maybe, someday
1431#if ($splitrevzones && !$cidr->{isv6}) {
1432 my @zonelist;
1433 if (1 && !$cidr->{isv6}) {
1434 my $splitpoint = ($cidr->masklen <= 16 ? 16 : 24); # hack pthui
1435 @zonelist = $cidr->split($splitpoint);
1436 } else {
1437 @zonelist = ($cidr);
1438 }
1439 my @fails;
1440 foreach my $subzone (@zonelist) {
1441 if ($rpc_url && !_rpc('delZone', zone => "$subzone", revrec => 'y', rpcuser => $user, delforward => $delfwd) ) {
1442 push @fails, ("$subzone" => $errstr);
1443 }
1444 }
1445 if (@fails) {
1446 return ('WARN',"Warning(s) deleting $cidr from reverse DNS:\n".join("\n", @fails));
1447 }
1448 return ('OK','OK');
1449
1450 } else { # end alloctype master block case
1451
1452 ## This is a big block; but it HAS to be done in a chunk. Any removal
1453 ## of a netblock allocation may result in a larger chunk of free
1454 ## contiguous IP space - which may in turn be combined into a single
1455 ## netblock rather than a number of smaller netblocks.
1456
1457 my $retcode = 'OK';
1458 my ($ptype,$pcity,$ppatt,$p_id);
1459
1460 eval {
1461
1462##fixme: add recursive flag to allow "YES DAMMIT DELETE ALL EVARYTHING!!1!!" without
1463# explicitly deleting any suballocations of the block to be deleted.
1464
1465 # get parent info of the block we're deleting
1466 my $pinfo = getBlockData($dbh, $binfo->{parent_id});
1467 $ptype = $pinfo->{type};
1468 $pcity = $pinfo->{city};
1469 $ppatt = $pinfo->{rdns};
1470 $p_id = $binfo->{parent_id};
1471
1472 # Delete the block
1473 $dbh->do("DELETE FROM allocations WHERE id = ?", undef, ($id) );
1474
1475 # munge the parent type a little
1476 $ptype = (split //, $ptype)[1];
1477
1478##fixme: you can't... CAN NOT.... assign the same public IP to multiple things.
1479# 'Net don't work like that, homey. Restrict VRF-uniqueness to private IPs?
1480# -> $isprivnet flag from start of sub
1481
1482 # check to see if any container allocations could be the "true" parent
1483 my ($tparent,$tpar_id,$trtype,$tcity);
1484 $tpar_id = 0;
1485
1486##fixme: this is far simpler in the strict VRF case; we "know" that any allocation
1487# contained by a container is a part of the same allocation tree when the VRF fields are equal.
1488
1489# logic:
1490# For each possible container of $cidr
1491# note the parent id
1492# walk the chain up the parents
1493# if we intersect $cidr's current parent, break
1494# if we've intersected $cidr's current parent
1495# set some variables to track that block
1496# break
1497
1498# Set up part of "is it in the middle of a pool?" check
1499 my $wuzpool = $dbh->selectrow_hashref("SELECT cidr,parent_id,type,city,custid,id FROM allocations ".
1500 "WHERE (type LIKE '_d' OR type LIKE '_p') AND cidr >> ? AND master_id = ?", { Slice => {} },
1501 ($cidr, $binfo->{master_id}) );
1502
1503##fixme?
1504# edge cases not handled, or handled badly:
1505# -> $cidr managed to get to be the entirety of an IP pool
1506
1507 if ($wuzpool && $wuzpool->{id} != $id) {
1508 # we have legacy goo to be purified
1509 # going to ignore nested pools; not possible to create them via API and no current legacy data includes any.
1510
1511 # for convenience
1512 my $poolid = $wuzpool->{id};
1513 my $pool = $wuzpool->{cidr};
1514 my $poolcity = $wuzpool->{city};
1515 my $pooltype = $wuzpool->{type};
1516 my $poolcustid = $wuzpool->{custid};
1517
1518 $retcode = 'WARNPOOL';
1519 $goback = "$poolid,$pool";
1520 # We've already deleted the block, now we have to stuff its IPs into the pool.
1521 $pooltype =~ s/[dp]$/i/; # change type to static IP
1522 my $sth2 = $dbh->prepare("INSERT INTO poolips (ip,city,type,custid,parent_id) VALUES ".
1523 "(?,'$poolcity','$pooltype','$poolcustid',$poolid)");
1524
1525##fixme: need to not insert net, gateway, and bcast on "real netblock" pools (DHCPish)
1526 # don't insert .0
1527 $sth2->execute($cidr->addr) unless $cidr->addr =~ m|\.0$|;
1528 $cidr++;
1529 my $bcast = $cidr->broadcast;
1530 while ($cidr != $bcast) {
1531 $sth2->execute($cidr->addr);
1532 $cidr++;
1533 }
1534 # don't insert .255
1535 $sth2->execute($cidr->addr) unless $cidr->addr =~ m|\.255$|;
1536
1537# Weirdness Happens. $cidr goes read-only somewhere (this is a thing?!?),
1538# causing ->split, ->hostenum, and related methods to explode. O_o
1539# foreach my $ip ($cidr->hostenum) {
1540# $sth2->execute($ip);
1541# }
1542
1543 }
1544
1545## important!
1546# ... or IS IT?
1547# we may have undef'ed $wuzpool above, if the allocation tree $cidr is in doesn't intersect the pool we found
1548#if (!$wuzpool) {
1549
1550 else {
1551
1552# Edge case: Block is the same size as more than one parent level. Should be rare.
1553# - mainly master + first routing. Sorting on parent_id hides the problem pretty well,
1554# but it's likely still possible to fail in particularly well-mangled databases.
1555# The ultimate fix for this may be to resurrect the "routing depth" atrocity. :/
1556 # Get all possible (and probably a number of impossible) containers for $cidr
1557 $sth = $dbh->prepare("SELECT cidr,parent_id,type,city,id FROM allocations ".
1558 "WHERE (type LIKE '_m' OR type LIKE '_c') AND cidr >>= ? AND master_id = ? ".
1559 "ORDER BY masklen(cidr) DESC,parent_id DESC");
1560 $sth->execute($cidr, $binfo->{master_id});
1561
1562 # Quickly get certain fields (simpler than getBlockData()
1563 my $sth2 = $dbh->prepare("SELECT cidr,parent_id,type,city FROM allocations ".
1564 "WHERE (type LIKE '_m' OR type LIKE '_c') AND id = ? AND master_id = ?");
1565
1566 # For each possible container of $cidr...
1567 while (my @data = $sth->fetchrow_array) {
1568 my $i = 0;
1569 # Save some state and set a start point - parent ID of container we're checking
1570 $tparent = $data[0];
1571 my $ppid = $data[1];
1572 $trtype = $data[2];
1573 $tcity = $data[3];
1574 $tpar_id = $data[4];
1575 last if $data[4] == $binfo->{parent_id}; # Preemptively break if we're already in the right place
1576 last if $ppid == $binfo->{parent_id}; # ... or if the parent of the container is the block's parent
1577 while (1) {
1578 # Retrieve bits on that parent ID
1579 $sth2->execute($ppid, $binfo->{master_id});
1580 my @container = $sth2->fetchrow_array;
1581 $ppid = $container[1];
1582 last if $container[1] == 0; # Break if we've hit a master block
1583 last if $ppid == $binfo->{parent_id}; # Break if we've reached the block $cidr is currently in
1584 }
1585 last if $ppid == $binfo->{parent_id};
1586 }
1587
1588 # found an alternate parent; reset some parent-info bits
1589 if ($tpar_id != $binfo->{parent_id}) {
1590 $ptype = (split //, $trtype)[1];
1591 $pcity = $tcity;
1592 $retcode = 'WARNMERGE'; # may be redundant
1593 $p_id = $tpar_id;
1594 }
1595
1596 $goback = "$p_id,$tparent"; # breadcrumb, currently only used in case of live-parent-is-not-true-parent
1597
1598 # Special case - delete pool IPs
1599 if ($binfo->{type} =~ /^.[pd]$/) {
1600 # We have to delete the IPs from the pool listing.
1601##fixme: rdepth? vrf?
1602 $dbh->do("DELETE FROM poolips WHERE parent_id = ?", undef, ($id) );
1603 }
1604
1605 $pinfo = getBlockData($dbh, $p_id);
1606
1607 # If the block wasn't legacy goo embedded in a static pool, we check the
1608 # freeblocks in the identified parent to see if we can combine any of them.
1609
1610 # if the block to be deleted is a container, move its freeblock(s) up a level, and reset their parenting info
1611 if ($binfo->{type} =~ /^.[mc]/) {
1612 # move the freeblocks into the parent
1613 # we don't insert a new freeblock because there could be a live reparented sub.
1614 $dbh->do("UPDATE freeblocks SET parent_id = ?, routed = ?, city = ? WHERE parent_id = ?", undef,
1615 ($p_id, $ptype, $pcity, $id) );
1616 } else {
1617 # ... otherwise, add the freeblock
1618 $dbh->do("INSERT INTO freeblocks (cidr, city, routed, parent_id, master_id) VALUES (?,?,?,?,?)", undef,
1619 ($cidr, $pcity, $ptype, $p_id, $binfo->{master_id}) );
1620 }
1621
1622##fixme: vrf
1623##fixme: simplify since all containers now represent different "layers"/"levels"?
1624 # set up the query to get the list of blocks to try to merge.
1625 $sth = $dbh->prepare("SELECT cidr,id FROM freeblocks ".
1626 "WHERE parent_id = ? ".
1627 "ORDER BY masklen(cidr) DESC");
1628
1629 $sth->execute($p_id);
1630
1631# NetAddr::IP->compact() attempts to produce the smallest inclusive block
1632# from the caller and the passed terms.
1633# EG: if you call $cidr->compact($ip1,$ip2,$ip3) when $cidr, $ip1, $ip2,
1634# and $ip3 are consecutive /27's starting on .0 (.0-.31, .32-.63,
1635# .64-.95, and .96-.128), you will get an array containing a single
1636# /25 as element 0 (.0-.127). Order is not important; you could have
1637# $cidr=.32/27, $ip1=.96/27, $ip2=.0/27, and $ip3=.64/27.
1638
1639 my (@rawfb, @combinelist, %rawid);
1640 my $i=0;
1641 # for each free block under $parent, push a NetAddr::IP object into one list, and
1642 # continuously use NetAddr::IP->compact to automagically merge netblocks as possible.
1643 while (my @data = $sth->fetchrow_array) {
1644 my $testIP = new NetAddr::IP $data[0];
1645 push @rawfb, $testIP;
1646 $rawid{"$testIP"} = $data[1]; # $data[0] vs "$testIP" *does* make a difference for v6
1647 @combinelist = $testIP->compact(@combinelist);
1648 }
1649
1650 # now that we have the full list of "compacted" freeblocks, go back over
1651 # the list of raw freeblocks, and delete the ones that got merged.
1652 $sth = $dbh->prepare("DELETE FROM freeblocks WHERE id = ?");
1653 foreach my $rawfree (@rawfb) {
1654 next if grep { $rawfree == $_ } @combinelist; # skip if the raw block is in the compacted list
1655 $sth->execute($rawid{$rawfree});
1656 }
1657
1658 # now we walk the new list of compacted blocks, and see which ones we need to insert
1659 $sth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,parent_id,master_id) VALUES (?,?,?,?,?)");
1660 foreach my $cme (@combinelist) {
1661 next if grep { $cme == $_ } @rawfb; # skip if the combined block was in the raw list
1662 $sth->execute($cme, $pcity, $ptype, $p_id, $binfo->{master_id});
1663 }
1664
1665 } # done returning IPs to the appropriate place
1666
1667 # If we got here, we've succeeded. Whew!
1668 $dbh->commit;
1669 }; # end eval
1670 if ($@) {
1671 $msg .= ": $@";
1672 eval { $dbh->rollback; };
1673 return ('FAIL', $msg);
1674 } else {
1675##fixme: RPC return code?
1676 _rpc('delByCIDR', cidr => "$cidr", rpcuser => $user, delforward => $delfwd, delsubs => 'y', parpatt => $ppatt);
1677 return ($retcode, $goback);
1678 }
1679
1680 } # end alloctype != netblock
1681
1682} # end deleteBlock()
1683
1684
1685## IPDB::getBlockData()
1686# Get CIDR or IP, custid, type, city, circuit ID, description, notes, modification time,
1687# private/restricted data, for a CIDR block or pool IP
1688# Also returns SWIP status flag for CIDR blocks or pool netblock for IPs
1689# Takes the block ID or IP to look up and an optional flag to indicate a pool IP lookup
1690# instead of a netblock.
1691# Returns a hashref to the block data
1692sub getBlockData {
1693 my $dbh = shift;
1694 my $id = shift;
1695 my $type = shift || 'b'; # default to netblock for lazy callers
1696
1697 # netblocks are in the allocations table; pool IPs are in the poolips table.
1698 # If we try to look up a CIDR in an integer field we should just get back nothing.
1699 my ($btype) = $dbh->selectrow_array("SELECT type FROM allocations WHERE id=?", undef, ($id) );
1700
1701 if ($type eq 'i') {
1702 my $binfo = $dbh->selectrow_hashref("SELECT ip AS block, custid, type, city, circuitid, description,".
1703 " notes, modifystamp AS lastmod, privdata, vrf, rdns, parent_id, master_id".
1704 " FROM poolips WHERE id = ?", undef, ($id) );
1705 return $binfo;
1706 } else {
1707 my $binfo = $dbh->selectrow_hashref("SELECT cidr AS block, custid, type, city, circuitid, ".
1708 "description, notes, modifystamp AS lastmod, privdata, vrf, swip, rdns, parent_id, master_id".
1709 " FROM allocations WHERE id = ?", undef, ($id) );
1710 return $binfo;
1711 }
1712} # end getBlockData()
1713
1714
1715## IPDB::getBlockRDNS()
1716# Gets reverse DNS pattern for a block or IP. Note that this will also
1717# retrieve any default pattern following the parent chain up, and check via
1718# RPC (if available) to see what the narrowest pattern for the requested block is
1719# Returns the current pattern for the block or IP.
1720sub getBlockRDNS {
1721 my $dbh = shift;
1722 my %args = @_;
1723
1724 $args{type} = 'b' if !$args{type};
1725 my $cached = 1;
1726
1727 # snag entry from database
1728 my ($rdns,$rfrom,$pid);
1729 if ($args{type} =~ /.i/) {
1730 ($rdns, $rfrom, $pid) = $dbh->selectrow_array("SELECT rdns,ip,parent_id FROM poolips WHERE id = ?",
1731 undef, ($args{id}) );
1732 } else {
1733 ($rdns, $rfrom, $pid) = $dbh->selectrow_array("SELECT rdns,cidr,parent_id FROM allocations WHERE id = ?",
1734 undef, ($args{id}) );
1735 }
1736
1737 # Can't see a way this could end up empty, for any case I care about. If the caller
1738 # doesn't know an allocation ID to request, then they don't know anything else anyway.
1739 my $selfblock = $rfrom;
1740
1741 my $type;
1742 while (!$rdns && $pid) {
1743 ($rdns, $rfrom, $pid, $type) = $dbh->selectrow_array(
1744 "SELECT rdns,cidr,parent_id,type FROM allocations WHERE id = ?",
1745 undef, ($pid) );
1746 last if $type eq 'mm'; # break loops in unfortunate legacy data
1747 }
1748
1749 # use the actual allocation to check against the DNS utility; we don't want
1750 # to always go chasing up the chain to the master... which may (usually won't)
1751 # be present directly in DNS anyway
1752 my $cidr = new NetAddr::IP $selfblock;
1753
1754 if ($rpc_url) {
1755 # Use the first /16 or /24, rather than dithering over which sub-/14 /16
1756 # or sub-/19 /24 to retrieve - it's the least-wrong way to do things.
1757
1758 my ($rpcblock) = ($cidr->masklen <= 24 ? $cidr->split( ($cidr->masklen <= 16 ? 16 : 24) ) : $cidr);
1759 my %rpcargs = (
1760 rpcuser => $args{user},
1761 group => $revgroup, # not sure how this could sanely be exposed, tbh...
1762 cidr => "$rpcblock",
1763 );
1764
1765 my $remote_rdns = _rpc('getRevPattern', %rpcargs);
1766 $rdns = $remote_rdns if $remote_rdns;
1767 $cached = 0;
1768 }
1769
1770 # hmm. do we care about where it actually came from?
1771 return $rdns, $cached;
1772} # end getBlockRDNS()
1773
1774
1775## IPDB::getRDNSbyIP()
1776# Get individual reverse entries for the IP or CIDR IP range passed. Sort of looking the
1777# opposite direction down the netblock tree compared to getBlockRDNS() above.
1778sub getRDNSbyIP {
1779 my $dbh = shift;
1780 my %args = @_; # We want to accept a variety of call types
1781
1782 # key arguments: allocation ID, type
1783 unless ($args{id} || $args{type}) {
1784 $errstr = 'Missing allocation ID or type';
1785 return;
1786 }
1787
1788 my @ret = ();
1789 # special case: single IP. Check if it's an allocation or in a pool, then do the RPC call for fresh data.
1790 if ($args{type} =~ /^.i$/) {
1791 my ($ip, $localrev) = $dbh->selectrow_array("SELECT ip, rdns FROM poolips WHERE id = ?", undef, ($args{id}) );
1792 push @ret, { 'r_ip' => $ip, 'iphost' => $localrev };
1793 } else {
1794 if ($rpc_url) {
1795 my %rpcargs = (
1796 rpcuser => $args{user},
1797 group => $revgroup, # not sure how this could sanely be exposed, tbh...
1798 cidr => $args{range},
1799 );
1800
1801 my $remote_rdns = _rpc('getRevSet', %rpcargs);
1802 return $remote_rdns;
1803# $rdns = $remote_rdns if $remote_rdns;
1804# $cached = 0;
1805 }
1806 }
1807 return \@ret;
1808} # end getRDNSbyIP()
1809
1810
1811## IPDB::getNodeList()
1812# Gets a list of node ID+name pairs as an arrayref to a list of hashrefs
1813sub getNodeList {
1814 my $dbh = shift;
1815
1816 my $ret = $dbh->selectall_arrayref("SELECT node_id, node_name FROM nodes ORDER BY node_type,node_id",
1817 { Slice => {} });
1818 return $ret;
1819} # end getNodeList()
1820
1821
1822## IPDB::getNodeName()
1823# Get node name from the ID
1824sub getNodeName {
1825 my $dbh = shift;
1826 my $nid = shift;
1827
1828 my ($nname) = $dbh->selectrow_array("SELECT node_name FROM nodes WHERE node_id = ?", undef, ($nid) );
1829 return $nname;
1830} # end getNodeName()
1831
1832
1833## IPDB::getNodeInfo()
1834# Get node name and ID associated with a block
1835sub getNodeInfo {
1836 my $dbh = shift;
1837 my $block = shift;
1838
1839 my ($nid, $nname) = $dbh->selectrow_array("SELECT nodes.node_id,node_name FROM nodes INNER JOIN noderef".
1840 " ON nodes.node_id=noderef.node_id WHERE noderef.block = ?", undef, ($block) );
1841 return ($nid, $nname);
1842} # end getNodeInfo()
1843
1844
1845## IPDB::mailNotify()
1846# Sends notification mail to recipients regarding an IPDB operation
1847sub mailNotify {
1848 my $dbh = shift;
1849 my ($action,$subj,$message) = @_;
1850
1851 return if $smtphost eq 'smtp.example.com'; # do nothing if still using default SMTP host.
1852
1853##fixme: need to redesign the breakdown/processing for $action for proper handling of all cases
1854
1855# split action into parts for fiddlement. nb: there are almost certainly better ways to do this.
1856 my @actionbits = split //, $action;
1857
1858 # want to notify anyone who has specifically requested notify on *this* type ($action as passed),
1859 # on "all static IP types" or "all pool types" (and other last-char-in-type groupings), on eg "all DSL types",
1860 # and "all events with this action"
1861 my @actionsets = ($action);
1862##fixme: ick, eww. really gotta find a better way to handle this...
1863 push @actionsets, ($actionbits[0].'.'.$actionbits[2],
1864 $actionbits[0].$actionbits[1].'.', $actionbits[0].'a') if $action =~ /^.{3}$/;
1865
1866 my $mailer = Net::SMTP->new($smtphost, Hello => "ipdb.$domain");
1867
1868 # get recip list from db
1869 my $sth = $dbh->prepare("SELECT reciplist FROM notify WHERE action=?");
1870
1871 my %reciplist;
1872 foreach (@actionsets) {
1873 $sth->execute($_);
1874##fixme - need to handle db errors
1875 my ($recipsub) = $sth->fetchrow_array;
1876 next if !$recipsub;
1877 foreach (split(/,/, $recipsub)) {
1878 $reciplist{$_}++;
1879 }
1880 }
1881
1882 return if !%reciplist;
1883
1884 foreach my $recip (keys %reciplist) {
1885 $mailer->mail($smtpsender);
1886 $mailer->to($recip);
1887 $mailer->data("From: \"$org_name IP Database\" <$smtpsender>\n",
1888 "To: $recip\n",
1889 "Date: ".strftime("%a, %d %b %Y %H:%M:%S %z",localtime)."\n",
1890 "Subject: {IPDB} $subj\n",
1891 "X-Mailer: IPDB Notify v".sprintf("%.1d",$IPDB::VERSION)."\n",
1892 "Organization: $org_name\n",
1893 "\n$message\n");
1894 }
1895 $mailer->quit;
1896}
1897
1898# Indicates module loaded OK. Required by Perl.
18991;
Note: See TracBrowser for help on using the repository browser.