Context Navigation

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

Rev	Line
[8]	1	# ipdb/cgi-bin/IPDB.pm
[66]	2	# Contains functions for IPDB - database access, subnet mangling, block allocation, etc
[8]	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	###
[417]	9	# Copyright (C) 2004-2010 - Kris Deugau
[8]	10
[4]	11	package IPDB;
	12
	13	use strict;
	14	use warnings;
	15	use Exporter;
[77]	16	use DBI;
[66]	17	use Net::SMTP;
[573]	18	use NetAddr::IP qw(:lower Compact );
[582]	19	use Frontier::Client;
[68]	20	use POSIX;
[4]	21	use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
	22
[417]	23	$VERSION = 2; ##VERSION##
[4]	24	@ISA = qw(Exporter);
[106]	25	@EXPORT_OK = qw(
[541]	26	%disp_alloctypes %list_alloctypes %def_custids @citylist @poplist
[661]	27	%IPDBacl %aclmsg %rpcacl $maxfcgi
[660]	28	$errstr
[523]	29	&initIPDBGlobals &connectDB &finish &checkDBSanity
[547]	30	&addMaster &touchMaster
[663]	31	&listSummary &listSubs &listContainers &listAllocations &listFree &listPool
[541]	32	&getMasterList &getTypeList &getPoolSelect &findAllocateFrom
[536]	33	&ipParent &subParent &blockParent &getRoutedCity
[675]	34	&allocateBlock &updateBlock &deleteBlock &getBlockData &getBlockRDNS &getRDNSbyIP
[530]	35	&getNodeList &getNodeName &getNodeInfo
[519]	36	&mailNotify
[106]	37	);
[4]	38
	39	@EXPORT = (); # Export nothing by default.
[106]	40	%EXPORT_TAGS = ( ALL => [qw(
[167]	41	%disp_alloctypes %list_alloctypes %def_custids @citylist @poplist
[661]	42	%IPDBacl %aclmsg %rpcacl $maxfcgi
[660]	43	$errstr
[523]	44	&initIPDBGlobals &connectDB &finish &checkDBSanity
[547]	45	&addMaster &touchMaster
[663]	46	&listSummary &listSubs &listContainers &listAllocations &listFree &listPool
[541]	47	&getMasterList &getTypeList &getPoolSelect &findAllocateFrom
[536]	48	&ipParent &subParent &blockParent &getRoutedCity
[675]	49	&allocateBlock &updateBlock &deleteBlock &getBlockData &getBlockRDNS &getRDNSbyIP
[530]	50	&getNodeList &getNodeName &getNodeInfo
[519]	51	&mailNotify
[106]	52	)]
	53	);
[4]	54
[77]	55	##
	56	## Global variables
	57	##
	58	our %disp_alloctypes;
	59	our %list_alloctypes;
[167]	60	our %def_custids;
[96]	61	our @citylist;
	62	our @poplist;
[233]	63	our %IPDBacl;
[66]	64
[517]	65	# mapping table for functional-area => error message
	66	our %aclmsg = (
	67	addmaster => 'add a master block',
	68	addblock => 'add an allocation',
	69	updateblock => 'update a block',
	70	delblock => 'delete an allocation',
	71	);
	72
[660]	73	our %rpcacl;
[661]	74	our $maxfcgi = 3;
[660]	75
[585]	76	# error reporting
	77	our $errstr = '';
	78
[417]	79	our $org_name = 'Example Corp';
[416]	80	our $smtphost = 'smtp.example.com';
	81	our $domain = 'example.com';
[417]	82	our $defcustid = '5554242';
[681]	83	our $smtpsender = 'ipdb@example.com';
[417]	84	# mostly for rwhois
	85	##fixme: leave these blank by default?
[420]	86	our $rwhoisDataPath = '/usr/local/rwhoisd/etc/rwhoisd'; # to match ./configure defaults from rwhoisd-1.5.9.6
[417]	87	our $org_street = '123 4th Street';
	88	our $org_city = 'Anytown';
	89	our $org_prov_state = 'ON';
	90	our $org_pocode = 'H0H 0H0';
	91	our $org_country = 'CA';
	92	our $org_phone = '000-555-1234';
	93	our $org_techhandle = 'ISP-ARIN-HANDLE';
[434]	94	our $org_email = 'noc@example.com';
[437]	95	our $hostmaster = 'dns@example.com';
[416]	96
[417]	97	our $syslog_facility = 'local2';
	98
[582]	99	our $rpc_url = '';
[585]	100	our $revgroup = 1; # should probably be configurable somewhere
	101	our $rpccount = 0;
[582]	102
[674]	103	# Largest inverse CIDR mask length to show per-IP rDNS list
	104	# (eg, NetAddr::IP->bits - NetAddr::IP->masklen)
	105	our $maxrevlist = 5; # /27
	106
[682]	107	# UI layout for subblocks/containers
	108	our $sublistlayout = 1;
	109
[585]	110	##
	111	## Internal utility functions
	112	##
	113
	114	## IPDB::_rpc
	115	# Make an RPC call for DNS changes
	116	sub _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',
[640]	127	# must be provided by caller's caller
	128	# rpcuser => $args{user},
	129	%args,
[585]	130	);
	131
	132	eval {
[640]	133	$result = $server->call("dnsdb.$rpcsub", %rpcargs);
[585]	134	};
	135	if ($@) {
	136	$errstr = $@;
[678]	137	$errstr =~ s/\s*$//;
[585]	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
[77]	146	# Let's initialize the globals.
	147	## IPDB::initIPDBGlobals()
	148	# Initialize all globals. Takes a database handle, returns a success or error code
	149	sub initIPDBGlobals {
	150	my $dbh = $_[0];
	151	my $sth;
	152
[106]	153	# Initialize alloctypes hashes
[167]	154	$sth = $dbh->prepare("select type,listname,dispname,listorder,def_custid from alloctypes order by listorder");
[77]	155	$sth->execute;
	156	while (my @data = $sth->fetchrow_array) {
[106]	157	$disp_alloctypes{$data[0]} = $data[2];
[167]	158	$def_custids{$data[0]} = $data[4];
[106]	159	if ($data[3] < 900) {
	160	$list_alloctypes{$data[0]} = $data[1];
	161	}
[77]	162	}
[96]	163
	164	# City and POP listings
[157]	165	$sth = $dbh->prepare("select city,routing from cities order by city");
[96]	166	$sth->execute;
	167	return (undef,$sth->errstr) if $sth->err;
	168	while (my @data = $sth->fetchrow_array) {
[106]	169	push @citylist, $data[0];
[96]	170	if ($data[1] eq 'y') {
[106]	171	push @poplist, $data[0];
[96]	172	}
	173	}
	174
[233]	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;
[106]	178	return (undef,$sth->errstr) if $sth->err;
[233]	179	while (my @data = $sth->fetchrow_array) {
	180	$IPDBacl{$data[0]} = $data[1];
	181	}
[106]	182
[517]	183	##fixme: initialize HTML::Template env var for template path
	184	# something like $self->path().'/templates' ?
	185	# $ENV{HTML_TEMPLATE_ROOT} = 'foo/bar';
	186
[77]	187	return (1,"OK");
	188	} # end initIPDBGlobals
	189
	190
	191	## IPDB::connectDB()
[4]	192	# Creates connection to IPDB.
[77]	193	# Requires the database name, username, and password.
[4]	194	# Returns a handle to the db.
[77]	195	# Set up for a PostgreSQL db; could be any transactional DBMS with the
	196	# right changes.
[4]	197	sub connectDB {
[432]	198	my $dbname = shift;
	199	my $user = shift;
	200	my $pass = shift;
	201	my $dbhost = shift;
	202
[4]	203	my $dbh;
[432]	204	my $DSN = "DBI:Pg:".($dbhost ? "host=$dbhost;" : '')."dbname=$dbname";
[4]	205
	206	# Note that we want to autocommit by default, and we will turn it off locally as necessary.
[77]	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);
[4]	213
[77]	214	# Return here if we can't select. Note that this indicates a
	215	# problem executing the select.
[183]	216	my $sth = $dbh->prepare("select type from alloctypes");
[77]	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");
[4]	227	} # end connectDB
	228
[77]	229
	230	## IPDB::finish()
	231	# Cleans up after database handles and so on.
	232	# Requires a database handle
	233	sub finish {
	234	my $dbh = $_[0];
[517]	235	$dbh->disconnect if $dbh;
[77]	236	} # end finish
	237
	238
[106]	239	## IPDB::checkDBSanity()
[4]	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.
	242	sub checkDBSanity {
[106]	243	my ($dbh) = $_[0];
[4]	244
	245	if (!$dbh) {
[106]	246	print "No database handle, or connection has been closed.";
	247	return -1;
[4]	248	} else {
	249	# it connects, try a stmt.
[184]	250	my $sth = $dbh->prepare("select type from alloctypes");
[4]	251	my $err = $sth->execute();
	252
	253	if ($sth->fetchrow()) {
	254	# all is well.
	255	return 1;
	256	} else {
[16]	257	print "Connected to the database, but could not execute test statement. ".$sth->errstr();
[106]	258	return -1;
[4]	259	}
	260	}
	261	# Clean up after ourselves.
[106]	262	# $dbh->disconnect;
[4]	263	} # end checkDBSanity
	264
[66]	265
[371]	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"
	270	sub addMaster {
	271	my $dbh = shift;
[591]	272	# warning! during testing, this somehow generated a "Bad file descriptor" error. O_o
[371]	273	my $cidr = new NetAddr::IP shift;
[582]	274	my %args = @_;
[371]	275
[582]	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
[629]	282	my $mid;
	283
[371]	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 {
[628]	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;
[371]	296
[628]	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
[518]	301	if (!$mexist) {
[371]	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"?
[628]	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')");
[371]	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.
[628]	312	$dbh->do("INSERT INTO freeblocks (cidr,city,routed,parent_id,vrf,master_id) VALUES (?,?,?,?,?,?)", undef,
	313	($cidr, '<NULL>', 'm', $mid, $args{vrf}, $mid) );
[371]	314
[628]	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
[371]	318	# If we get here, everything is happy. Commit changes.
	319	$dbh->commit;
	320
[518]	321	} # done new master does not contain existing master(s)
[371]	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;
[628]	326	my $sth = $dbh->prepare("SELECT cidr,id FROM allocations WHERE cidr <<= ? AND type='mm' AND parent_id=0");
[518]	327	$sth->execute($cidr);
[371]	328	my @cmasters;
[628]	329	my @oldmids;
[371]	330	while (my @data = $sth->fetchrow_array) {
	331	my $master = new NetAddr::IP $data[0];
	332	push @cmasters, $master;
[628]	333	push @oldmids, $data[1];
[371]	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
[628]	347	##fixme: master_id
[371]	348	# collect the unrouted free blocks within the new master
[556]	349	$sth = $dbh->prepare("SELECT cidr FROM freeblocks WHERE masklen(cidr) <= ? AND cidr <<= ? AND routed = 'm'");
[518]	350	$sth->execute($smallmask, $cidr);
[371]	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
[628]	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
[371]	367	# and now insert the new data. Make sure to delete old masters too.
	368
	369	# freeblocks
[628]	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',?,?,?)");
[371]	373	foreach my $newblock (@blocklist) {
[518]	374	$sth->execute($newblock);
[628]	375	$sth2->execute($newblock, $mid, $args{vrf}, $mid);
[371]	376	}
	377
[628]	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	}
[556]	385
[371]	386	# whew If we got here, we likely suceeded.
	387	$dbh->commit;
[628]	388
[371]	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 {
[582]	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},
[585]	423	group => $revgroup, # not sure how these two could sanely be exposed, tbh...
[582]	424	state => 1, # could make them globally configurable maybe
	425	);
[587]	426	if ($rpc_url && !_rpc('addRDNS', %rpcargs)) {
[585]	427	push @fails, ("$subzone" => $errstr);
[582]	428	}
	429	}
	430	if (@fails) {
[628]	431	$errstr = "Warning(s) adding $cidr to reverse DNS:\n".join("\n", @fails);
	432	return ('WARN',$mid);
[582]	433	}
	434	}
[628]	435	return ('OK',$mid);
[371]	436	}
	437	} # end addMaster
	438
	439
[547]	440	## IPDB::touchMaster()
	441	# Update last-changed timestamp on a master block.
	442	sub touchMaster {
	443	my $dbh = shift;
	444	my $master = shift;
	445
	446	local $dbh->{AutoCommit} = 0;
	447	local $dbh->{RaiseError} = 1;
	448
	449	eval {
[652]	450	$dbh->do("UPDATE allocations SET modifystamp=now() WHERE id = ?", undef, ($master));
[547]	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
[523]	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
	467	sub listSummary {
	468	my $dbh = shift;
	469
[625]	470	my $mlist = $dbh->selectall_arrayref("SELECT cidr AS master,id,vrf FROM allocations ".
	471	"WHERE type='mm' ORDER BY cidr",
	472	{ Slice => {} });
[523]	473
	474	foreach (@{$mlist}) {
[625]	475	my ($rcnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ? AND type='rm' AND master_id = ?",
	476	undef, ($$_{master}, $$_{id}));
[523]	477	$$_{routed} = $rcnt;
[625]	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}));
[523]	481	$$_{allocated} = $acnt;
[625]	482	my ($fcnt) = $dbh->selectrow_array("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?",
	483	undef, ($$_{master}, $$_{id}));
[523]	484	$$_{free} = $fcnt;
[560]	485	my ($bigfree) = $dbh->selectrow_array("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?".
[625]	486	" AND master_id = ? ORDER BY masklen(cidr) LIMIT 1", undef, ($$_{master}, $$_{id}));
[523]	487	##fixme: should find a way to do this without having to HTMLize the <>
	488	$bigfree = "/$bigfree" if $bigfree;
[525]	489	$bigfree = '<NONE>' if !$bigfree;
[523]	490	$$_{bigfree} = $bigfree;
	491	}
	492	return $mlist;
	493	} # end listSummary()
	494
	495
[561]	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
	500	sub 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
[627]	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});
[561]	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
[653]	516	# snag some more details
[664]	517	my $substh = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
[663]	518	"AND type ~ '[mc]\$' AND master_id = ? AND NOT cidr = ? ");
[653]	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
[561]	525	my @blocklist;
[653]	526	while (my ($cidr,$city,$type,$custid,$swip,$desc,$id,$mid) = $sth->fetchrow_array()) {
[561]	527	$custsth->execute($custid);
	528	my ($ncust) = $custsth->fetchrow_array();
[653]	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;
[561]	539	my %row = (
	540	block => $cidr,
[653]	541	subcontainers => $cont,
	542	suballocs => $alloc,
	543	subfree => $free,
	544	lfree => $lfree,
[561]	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),
[627]	552	id => $id,
[561]	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
[663]	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
	569	sub 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
	619	sub 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
[524]	654	## IPDB::listFree()
[562]	655	# Gets a list of free blocks in the requested parent/master and VRF instance in both CIDR and range notation
[630]	656	# Takes a parent/master ID and an optional VRF specifier that defaults to empty.
[524]	657	# Returns an arrayref to a list of hashrefs containing the CIDR and range-notation blocks
[527]	658	# Returns some extra flags in the hashrefs for routed blocks, since those can have several subtypes
[524]	659	sub listFree {
	660	my $dbh = shift;
	661
[562]	662	my %args = @_;
	663	# Just In Case
	664	$args{vrf} = '' if !$args{vrf};
	665
[630]	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});
[524]	669	my @flist;
[630]	670	while (my ($cidr,$id) = $sth->fetchrow_array()) {
[524]	671	$cidr = new NetAddr::IP $cidr;
[527]	672	my %row = (
	673	fblock => "$cidr",
	674	frange => $cidr->range,
[630]	675	fbid => $id,
	676	fbparent => $args{parent},
[527]	677	);
[524]	678	push @flist, \%row;
	679	}
	680	return \@flist;
[527]	681	} # end listFree()
[524]	682
	683
[528]	684	## IPDB::listPool()
	685	#
	686	sub listPool {
	687	my $dbh = shift;
	688	my $pool = shift;
	689
[630]	690	my $sth = $dbh->prepare("SELECT ip,custid,available,description,type,id".
	691	" FROM poolips WHERE parent_id = ? ORDER BY ip");
[528]	692	$sth->execute($pool);
	693	my @poolips;
[630]	694	while (my ($ip,$custid,$available,$desc,$type,$id) = $sth->fetchrow_array) {
[528]	695	my %row = (
	696	ip => $ip,
	697	custid => $custid,
	698	available => $available,
	699	desc => $desc,
[563]	700	delme => $available eq 'n',
[630]	701	parent => $pool,
	702	id => $id,
[528]	703	);
	704	push @poolips, \%row;
	705	}
	706	return \@poolips;
	707	} # end listPool()
	708
	709
[541]	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
	715	sub getMasterList {
	716	my $dbh = shift;
	717	my $stampme = shift \|\| 'm'; # optional but should be set by caller for clarity
	718
[632]	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 => {} });
[541]	721	return $mlist;
	722	} # end getMasterList()
	723
	724
[529]	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
	729	sub 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;
[564]	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 ".
[529]	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 => {} });
[632]	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 => {} });
[529]	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
[532]	762	## IPDB::getPoolSelect()
	763	# Get a list of pools matching the passed city and type that have 1 or more free IPs
[533]	764	# Returns an arrayref to a list of hashrefs
[532]	765	sub 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
[663]	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	),
[572]	781	{ Slice => {} }, ($pcity, $ptype) );
[532]	782	return $plist;
	783	} # end getPoolSelect()
	784
	785
[533]	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
	795	sub 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
[633]	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
[533]	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
[633]	820	@vallist = ($maskbits);
	821	$sql = "SELECT id,cidr,parent_id FROM freeblocks WHERE masklen(cidr) <= ?";
[533]	822
[572]	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
[633]	842	##fixme: config or UI flag for "Strict" mode
	843	# if ($strictmode) {
	844	if (0) {
[572]	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	}
[633]	853	}
[572]	854
[633]	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;
[533]	862	}
[633]	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
[533]	884
[633]	885	my ($fbid,$fbfound,$fbparent) = $dbh->selectrow_array($sql, undef, @vallist);
	886	return $fbid,$fbfound,$fbparent;
[533]	887	} # end findAllocateFrom()
	888
	889
[536]	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
	894	sub ipParent {
	895	my $dbh = shift;
	896	my $block = shift;
	897
	898	my $pinfo = $dbh->selectrow_hashref("SELECT cidr,custid,type,city,description FROM allocations".
[565]	899	" WHERE cidr >>= ? AND (type LIKE '_p' OR type LIKE '_d')", undef, ($block) );
[536]	900	return $pinfo;
	901	} # end ipParent()
	902
	903
	904	## IPDB::subParent()
[529]	905	# Get a block's parent's details
	906	# Takes a database handle and CIDR block
[536]	907	# Returns a hashref to the parent container block, if any
	908	sub subParent {
[529]	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;
[536]	915	} # end subParent()
[529]	916
	917
[536]	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
	922	sub 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
[527]	932	## IPDB::getRoutedCity()
	933	# Get the city for a routed block.
	934	sub 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
[77]	943	## IPDB::allocateBlock()
[66]	944	# Does all of the magic of actually allocating a netblock
[554]	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
[77]	948	# Returns a success code and optional error message.
	949	sub allocateBlock {
[554]	950	my $dbh = shift;
[284]	951
[554]	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};
[585]	961	$args{rdns} = '' if !$args{rdns};
[554]	962
[690]	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
[77]	969	my $sth;
[66]	970
[633]	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;
[349]	976
[79]	977	# To contain the error message, if any.
[554]	978	my $msg = "Unknown error allocating $args{cidr} as '$disp_alloctypes{$args{type}}'";
[79]	979
[77]	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.
[66]	983
[554]	984	if ($args{type} =~ /^.i$/) {
	985	$msg = "Unable to assign static IP $args{cidr} to $args{custid}";
[77]	986	eval {
[554]	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}) );
[545]	996	}
[633]	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}) );
[157]	1003
[397]	1004	# node hack
[554]	1005	if ($args{nodeid} && $args{nodeid} ne '') {
	1006	$dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
[397]	1007	}
	1008	# end node hack
[545]	1009
[79]	1010	$dbh->commit;
[77]	1011	};
	1012	if ($@) {
[545]	1013	$msg .= ": $@";
[78]	1014	eval { $dbh->rollback; };
[578]	1015	return ('FAIL', $msg);
[77]	1016	} else {
[585]	1017	_rpc('addOrUpdateRevRec', cidr => "$args{cidr}", name => $args{rdns}, rpcuser => $args{user});
[578]	1018	return ('OK', $args{cidr});
[77]	1019	}
	1020
	1021	} else { # end IP-from-pool allocation
	1022
[633]	1023	if ($args{cidr} == $alloc_from) {
[77]	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 {
[554]	1030	$msg = "Unable to allocate $args{cidr} as '$disp_alloctypes{$args{type}}'";
	1031
[633]	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')");
[555]	1039
[554]	1040	# Munge freeblocks
	1041	if ($args{type} =~ /^(.)[mc]$/) {
	1042	# special case - block is a routed or container/"reserve" block
	1043	my $rtype = $1;
[633]	1044	$dbh->do("UPDATE freeblocks SET routed = ?,city = ?,parent_id = ? WHERE id = ?",
	1045	undef, ($rtype, $args{city}, $bid, $args{fbid}) );
[77]	1046	} else {
[554]	1047	# "normal" case
[633]	1048	$dbh->do("DELETE FROM freeblocks WHERE id = ?", undef, ($args{fbid}) );
[554]	1049	}
[77]	1050
[554]	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}";
[633]	1056	my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "all", $bid);
[554]	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}";
[633]	1060	my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "normal", $bid);
[554]	1061	die $rmsg if $code eq 'FAIL';
	1062	}
[79]	1063
[397]	1064	# node hack
[554]	1065	if ($args{nodeid} && $args{nodeid} ne '') {
	1066	$dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
[397]	1067	}
	1068	# end node hack
[574]	1069
[77]	1070	$dbh->commit;
[78]	1071	}; # end of eval
[77]	1072	if ($@) {
[157]	1073	$msg .= ": ".$@;
[77]	1074	eval { $dbh->rollback; };
[157]	1075	return ('FAIL',$msg);
[78]	1076	}
[77]	1077
	1078	} else { # cidr != alloc_from
	1079
	1080	# Hard case. Allocation is smaller than free block.
[633]	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});
[554]	1085	my $wantmaskbits = $args{cidr}->masklen;
[633]	1086	my $maskbits = $alloc_from->masklen;
[77]	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;
[633]	1094	my $tmp_from = $alloc_from; # So we don't munge $args{alloc_from}
[77]	1095	while ($maskbits++ < $wantmaskbits) {
	1096	my @subblocks = $tmp_from->split($maskbits);
[554]	1097	$newfreeblocks[$i++] = (($args{cidr}->within($subblocks[0])) ? $subblocks[1] : $subblocks[0]);
	1098	$tmp_from = ( ($args{cidr}->within($subblocks[0])) ? $subblocks[0] : $subblocks[1] );
[77]	1099	} # while
	1100
	1101	# Begin SQL transaction block
	1102	eval {
[554]	1103	$msg = "Unable to allocate $args{cidr} as '$disp_alloctypes{$args{type}}'";
[79]	1104
[77]	1105	# Delete old freeblocks entry
[633]	1106	$dbh->do("DELETE FROM freeblocks WHERE id = ?", undef, ($args{fbid}) );
[77]	1107
[554]	1108	# Insert new list of smaller free blocks left over
[633]	1109	$sth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)");
[554]	1110	foreach my $block (@newfreeblocks) {
[633]	1111	$sth->execute($block, $fcity, $alloc_from_type, $args{vrf}, $fbparent, $fbmaster);
[554]	1112	}
[79]	1113
[633]	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
[554]	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;
[633]	1125	$sth->execute($args{cidr}, $args{city}, $rtype, $args{vrf}, $bid, $fbmaster);
[554]	1126	}
[79]	1127
[554]	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}";
[633]	1133	my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "all", $bid);
[554]	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}";
[633]	1137	my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "normal", $bid);
[554]	1138	die $rmsg if $code eq 'FAIL';
	1139	}
[77]	1140
[397]	1141	# node hack
[554]	1142	if ($args{nodeid} && $args{nodeid} ne '') {
	1143	$dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
[397]	1144	}
	1145	# end node hack
[554]	1146
[77]	1147	$dbh->commit;
	1148	}; # end eval
	1149	if ($@) {
[256]	1150	$msg .= ": ".$@;
[77]	1151	eval { $dbh->rollback; };
[78]	1152	return ('FAIL',$msg);
[77]	1153	}
	1154
	1155	} # end fullcidr != alloc_from
	1156
[590]	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};
[585]	1160
[677]	1161	# and the per-IP set, if there is one.
	1162	_rpc('updateRevSet', %{$args{iprev}}, rpcuser => $args{user});
	1163
[585]	1164	return ('OK', 'OK');
	1165
[77]	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
[78]	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()
[77]	1178	sub initPool {
[633]	1179	my ($dbh,undef,$type,$city,$class,$parent) = @_;
[77]	1180	my $pool = new NetAddr::IP $_[1];
	1181
[574]	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
[633]	1188	my ($pcustid) = $dbh->selectrow_array("SELECT def_custid FROM alloctypes WHERE type=?", undef, ($type) );
[157]	1189	$type =~ s/[pd]$/i/;
[77]	1190	my $sth;
[157]	1191	my $msg;
[77]	1192
[157]	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".
[633]	1201	$sth = $dbh->prepare("INSERT INTO poolips (ip,custid,city,type,parent_id) VALUES (?,?,?,?,?)");
[157]	1202	my @poolip_list = $pool->hostenum;
	1203	if ($class eq 'all') { # (DSL-ish block - all IPs available
[246]	1204	if ($pool->addr !~ /\.0$/) { # .0 causes weirdness.
[633]	1205	$sth->execute($pool->addr, $pcustid, $city, $type, $parent);
[246]	1206	}
[157]	1207	for (my $i=0; $i<=$#poolip_list; $i++) {
[633]	1208	$sth->execute($poolip_list[$i]->addr, $pcustid, $city, $type, $parent);
[157]	1209	}
	1210	$pool--;
[246]	1211	if ($pool->addr !~ /\.255$/) { # .255 can cause weirdness.
[633]	1212	$sth->execute($pool->addr, $pcustid, $city, $type, $parent);
[246]	1213	}
[157]	1214	} else { # (real netblock)
	1215	for (my $i=1; $i<=$#poolip_list; $i++) {
[633]	1216	$sth->execute($poolip_list[$i]->addr, $pcustid, $city, $type, $parent);
[157]	1217	}
[77]	1218	}
[633]	1219	# don't commit here! the caller may not be done.
	1220	# $dbh->commit;
[157]	1221	};
	1222	if ($@) {
[574]	1223	$msg = $@;
[633]	1224	# Don't roll back! It's up to the caller to handle this.
	1225	# eval { $dbh->rollback; };
[157]	1226	return ('FAIL',$msg);
	1227	} else {
	1228	return ('OK',"OK");
[77]	1229	}
	1230	} # end initPool()
	1231
	1232
[531]	1233	## IPDB::updateBlock()
	1234	# Update an allocation
	1235	# Takes all allocation fields in a hash
	1236	sub updateBlock {
	1237	my $dbh = shift;
	1238	my %args = @_;
	1239
	1240	return ('FAIL', 'Missing block to update') if !$args{block};
	1241
[634]	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
[531]	1246	# do it all in a transaction
	1247	local $dbh->{AutoCommit} = 0;
	1248	local $dbh->{RaiseError} = 1;
	1249
	1250	my @fieldlist;
	1251	my @vallist;
[588]	1252	foreach ('custid', 'city', 'description', 'notes', 'circuitid', 'privdata', 'rdns') {
[531]	1253	if ($args{$_}) {
	1254	push @fieldlist, $_;
	1255	push @vallist, $args{$_};
	1256	}
	1257	}
	1258
[634]	1259	my $binfo;
[531]	1260	my $updtable = 'allocations';
[634]	1261	my $keyfield = 'id';
[535]	1262	if ($args{type} =~ /^(.)i$/) {
[531]	1263	$updtable = 'poolips';
[634]	1264	$binfo = getBlockData($dbh, $args{block}, 'i');
[531]	1265	} else {
	1266	## fixme: there's got to be a better way...
[634]	1267	$binfo = getBlockData($dbh, $args{block});
[531]	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
[634]	1285	push @vallist, $args{block};
[531]	1286	my $sql = "UPDATE $updtable SET ";
	1287	$sql .= join " = ?, ", @fieldlist;
[634]	1288	$sql .= " = ? WHERE $keyfield = ?";
[531]	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
[634]	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 '--';
[531]	1299	}
	1300
	1301	$dbh->commit;
	1302	};
	1303	if ($@) {
	1304	my $msg = $@;
	1305	$dbh->rollback;
	1306	return ('FAIL', $msg);
	1307	}
[588]	1308
[686]	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});
[677]	1331
[686]	1332	} else {
	1333	$binfo->{block} =~ s\|/32$\|\|;
	1334	_rpc('addOrUpdateRevRec', cidr => $binfo->{block}, name => $args{rdns}, rpcuser => $args{user});
[677]	1335
[686]	1336	# and the per-IP set, if there is one.
	1337	_rpc('updateRevSet', %{$args{iprev}}, rpcuser => $args{user}) if keys (%{$args{iprev}});
	1338	}
	1339
[588]	1340	return ('OK','OK');
[531]	1341	} # end updateBlock()
	1342
	1343
[93]	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
[558]	1348	# Requires a database handle, the block to delete, the routing depth (if applicable),
[590]	1349	# the VRF ID, and a flag to indicate whether to delete associated forward DNS entries
	1350	# as well as the reverse entry
[93]	1351	sub deleteBlock {
[638]	1352	my ($dbh,$id,$basetype,$delfwd,$user) = @_;
[93]	1353
[638]	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
[558]	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
[93]	1369	my $sth;
	1370
[349]	1371	# Magic variables used for odd allocation cases.
	1372	my $container;
	1373	my $con_type;
	1374
[558]	1375
	1376	# temporarily forced null, until a sane UI for VRF tracking can be found.
[638]	1377	# $vrf = '';# if !$vrf; # as with SQL, the null value is not equal to ''. sigh
[558]	1378
[93]	1379	# To contain the error message, if any.
[558]	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
[93]	1383	# Enable transactions and exception-on-errors... but only for this sub
	1384	local $dbh->{AutoCommit} = 0;
	1385	local $dbh->{RaiseError} = 1;
	1386
[558]	1387	if ($binfo->{type} =~ /^.i$/) {
[638]	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
[93]	1391
	1392	eval {
[558]	1393	$msg = "Unable to deallocate $disp_alloctypes{$binfo->{type}} $cidr";
[638]	1394	my $pinfo = getBlockData($dbh, $binfo->{parent_id}, 'b');
[558]	1395	##fixme: VRF and rdepth
[638]	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) );
[93]	1400	$dbh->commit;
	1401	};
	1402	if ($@) {
[558]	1403	$msg .= ": $@";
[93]	1404	eval { $dbh->rollback; };
	1405	return ('FAIL',$msg);
	1406	} else {
[590]	1407	##fixme: RPC return code?
[638]	1408	_rpc('delByCIDR', cidr => "$cidr", user => $user, delforward => $delfwd, rpcuser => $user);
[93]	1409	return ('OK',"OK");
	1410	}
	1411
[558]	1412	} elsif ($binfo->{type} eq 'mm') { # end alloctype =~ /.i/
[638]	1413	# Second case. The block is a full master block
[93]	1414
[558]	1415	##fixme: VRF limit
[93]	1416	$msg = "Unable to delete master block $cidr";
	1417	eval {
[638]	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}) );
[93]	1420	$dbh->commit;
	1421	};
	1422	if ($@) {
[558]	1423	$msg .= ": $@";
[93]	1424	eval { $dbh->rollback; };
	1425	return ('FAIL', $msg);
[591]	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);
[93]	1436	} else {
[591]	1437	@zonelist = ($cidr);
[93]	1438	}
[591]	1439	my @fails;
	1440	foreach my $subzone (@zonelist) {
[638]	1441	if ($rpc_url && !_rpc('delZone', zone => "$subzone", revrec => 'y', rpcuser => $user, delforward => $delfwd) ) {
[591]	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');
[93]	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
[558]	1457	my $retcode = 'OK';
[638]	1458	my ($ptype,$pcity,$ppatt,$p_id);
[558]	1459
[93]	1460	eval {
	1461
[558]	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.
[93]	1464
[638]	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};
[93]	1471
[558]	1472	# Delete the block
[638]	1473	$dbh->do("DELETE FROM allocations WHERE id = ?", undef, ($id) );
[349]	1474
[558]	1475	# munge the parent type a little
[638]	1476	$ptype = (split //, $ptype)[1];
[93]	1477
[558]	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
[93]	1481
[558]	1482	# check to see if any container allocations could be the "true" parent
[638]	1483	my ($tparent,$tpar_id,$trtype,$tcity);
	1484	$tpar_id = 0;
[404]	1485
[638]	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.
[558]	1488
[638]	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
[558]	1497
[638]	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}) );
[558]	1502
[638]	1503	##fixme?
	1504	# edge cases not handled, or handled badly:
	1505	# -> $cidr managed to get to be the entirety of an IP pool
[558]	1506
[638]	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)");
[655]	1524
[429]	1525	##fixme: need to not insert net, gateway, and bcast on "real netblock" pools (DHCPish)
[638]	1526	# don't insert .0
	1527	$sth2->execute($cidr->addr) unless $cidr->addr =~ m\|\.0$\|;
[655]	1528	$cidr++;
	1529	my $bcast = $cidr->broadcast;
	1530	while ($cidr != $bcast) {
	1531	$sth2->execute($cidr->addr);
	1532	$cidr++;
[638]	1533	}
	1534	# don't insert .255
	1535	$sth2->execute($cidr->addr) unless $cidr->addr =~ m\|\.255$\|;
[655]	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
[638]	1543	}
[93]	1544
[638]	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
[655]	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. :/
[638]	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 = ? ".
[655]	1559	"ORDER BY masklen(cidr) DESC,parent_id DESC");
[638]	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]$/) {
[655]	1600	# We have to delete the IPs from the pool listing.
	1601	##fixme: rdepth? vrf?
[638]	1602	$dbh->do("DELETE FROM poolips WHERE parent_id = ?", undef, ($id) );
	1603	}
	1604
	1605	$pinfo = getBlockData($dbh, $p_id);
	1606
[558]	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.
[93]	1609
[559]	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.
[638]	1614	$dbh->do("UPDATE freeblocks SET parent_id = ?, routed = ?, city = ? WHERE parent_id = ?", undef,
	1615	($p_id, $ptype, $pcity, $id) );
[559]	1616	} else {
	1617	# ... otherwise, add the freeblock
[638]	1618	$dbh->do("INSERT INTO freeblocks (cidr, city, routed, parent_id, master_id) VALUES (?,?,?,?,?)", undef,
	1619	($cidr, $pcity, $ptype, $p_id, $binfo->{master_id}) );
[559]	1620	}
	1621
[558]	1622	##fixme: vrf
[638]	1623	##fixme: simplify since all containers now represent different "layers"/"levels"?
[558]	1624	# set up the query to get the list of blocks to try to merge.
[638]	1625	$sth = $dbh->prepare("SELECT cidr,id FROM freeblocks ".
	1626	"WHERE parent_id = ? ".
[558]	1627	"ORDER BY masklen(cidr) DESC");
[428]	1628
[638]	1629	$sth->execute($p_id);
[558]	1630
[93]	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
[638]	1639	my (@rawfb, @combinelist, %rawid);
[428]	1640	my $i=0;
[558]	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.
[428]	1643	while (my @data = $sth->fetchrow_array) {
	1644	my $testIP = new NetAddr::IP $data[0];
[558]	1645	push @rawfb, $testIP;
[671]	1646	$rawid{"$testIP"} = $data[1]; # $data[0] vs "$testIP" does make a difference for v6
[558]	1647	@combinelist = $testIP->compact(@combinelist);
[93]	1648	}
	1649
[558]	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.
[638]	1652	$sth = $dbh->prepare("DELETE FROM freeblocks WHERE id = ?");
[558]	1653	foreach my $rawfree (@rawfb) {
	1654	next if grep { $rawfree == $_ } @combinelist; # skip if the raw block is in the compacted list
[638]	1655	$sth->execute($rawid{$rawfree});
[558]	1656	}
[93]	1657
[558]	1658	# now we walk the new list of compacted blocks, and see which ones we need to insert
[638]	1659	$sth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,parent_id,master_id) VALUES (?,?,?,?,?)");
[558]	1660	foreach my $cme (@combinelist) {
	1661	next if grep { $cme == $_ } @rawfb; # skip if the combined block was in the raw list
[638]	1662	$sth->execute($cme, $pcity, $ptype, $p_id, $binfo->{master_id});
[428]	1663	}
[93]	1664
[428]	1665	} # done returning IPs to the appropriate place
[404]	1666
[93]	1667	# If we got here, we've succeeded. Whew!
	1668	$dbh->commit;
	1669	}; # end eval
	1670	if ($@) {
[558]	1671	$msg .= ": $@";
[93]	1672	eval { $dbh->rollback; };
	1673	return ('FAIL', $msg);
	1674	} else {
[590]	1675	##fixme: RPC return code?
[638]	1676	_rpc('delByCIDR', cidr => "$cidr", rpcuser => $user, delforward => $delfwd, delsubs => 'y', parpatt => $ppatt);
[558]	1677	return ($retcode, $goback);
[93]	1678	}
	1679
	1680	} # end alloctype != netblock
	1681
	1682	} # end deleteBlock()
	1683
	1684
[370]	1685	## IPDB::getBlockData()
[557]	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
[636]	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.
[557]	1691	# Returns a hashref to the block data
[370]	1692	sub getBlockData {
	1693	my $dbh = shift;
[636]	1694	my $id = shift;
	1695	my $type = shift \|\| 'b'; # default to netblock for lazy callers
[370]	1696
[636]	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) );
[534]	1700
[636]	1701	if ($type eq 'i') {
[557]	1702	my $binfo = $dbh->selectrow_hashref("SELECT ip AS block, custid, type, city, circuitid, description,".
[636]	1703	" notes, modifystamp AS lastmod, privdata, vrf, rdns, parent_id, master_id".
	1704	" FROM poolips WHERE id = ?", undef, ($id) );
[557]	1705	return $binfo;
	1706	} else {
[636]	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) );
[557]	1710	return $binfo;
[534]	1711	}
[370]	1712	} # end getBlockData()
	1713
	1714
[585]	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.
	1720	sub getBlockRDNS {
	1721	my $dbh = shift;
	1722	my %args = @_;
	1723
[637]	1724	$args{type} = 'b' if !$args{type};
[675]	1725	my $cached = 1;
[585]	1726
[637]	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	}
[585]	1736
[637]	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;
[585]	1740
[637]	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
[585]	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
[586]	1758	my ($rpcblock) = ($cidr->masklen <= 24 ? $cidr->split( ($cidr->masklen <= 16 ? 16 : 24) ) : $cidr);
[585]	1759	my %rpcargs = (
	1760	rpcuser => $args{user},
	1761	group => $revgroup, # not sure how this could sanely be exposed, tbh...
	1762	cidr => "$rpcblock",
	1763	);
	1764
[637]	1765	my $remote_rdns = _rpc('getRevPattern', %rpcargs);
	1766	$rdns = $remote_rdns if $remote_rdns;
[675]	1767	$cached = 0;
[585]	1768	}
	1769
	1770	# hmm. do we care about where it actually came from?
[675]	1771	return $rdns, $cached;
[585]	1772	} # end getBlockRDNS()
	1773
	1774
[675]	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.
	1778	sub 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
[519]	1811	## IPDB::getNodeList()
	1812	# Gets a list of node ID+name pairs as an arrayref to a list of hashrefs
	1813	sub 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
[530]	1822	## IPDB::getNodeName()
	1823	# Get node name from the ID
	1824	sub 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
	1835	sub 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
[77]	1845	## IPDB::mailNotify()
[66]	1846	# Sends notification mail to recipients regarding an IPDB operation
[416]	1847	sub mailNotify {
	1848	my $dbh = shift;
	1849	my ($action,$subj,$message) = @_;
[66]	1850
[462]	1851	return if $smtphost eq 'smtp.example.com'; # do nothing if still using default SMTP host.
	1852
[422]	1853	##fixme: need to redesign the breakdown/processing for $action for proper handling of all cases
	1854
[416]	1855	# split action into parts for fiddlement. nb: there are almost certainly better ways to do this.
[422]	1856	my @actionbits = split //, $action;
[416]	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
[443]	1871	my %reciplist;
[416]	1872	foreach (@actionsets) {
[426]	1873	$sth->execute($_);
[416]	1874	##fixme - need to handle db errors
	1875	my ($recipsub) = $sth->fetchrow_array;
	1876	next if !$recipsub;
	1877	foreach (split(/,/, $recipsub)) {
[443]	1878	$reciplist{$_}++;
[416]	1879	}
	1880	}
	1881
[443]	1882	return if !%reciplist;
[420]	1883
[443]	1884	foreach my $recip (keys %reciplist) {
[681]	1885	$mailer->mail($smtpsender);
[416]	1886	$mailer->to($recip);
[681]	1887	$mailer->data("From: \"$org_name IP Database\" <$smtpsender>\n",
[135]	1888	"To: $recip\n",
[69]	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",
[417]	1892	"Organization: $org_name\n",
[69]	1893	"\n$message\n");
[416]	1894	}
[66]	1895	$mailer->quit;
	1896	}
	1897
[4]	1898	# Indicates module loaded OK. Required by Perl.
	1899	1;

Note: See TracBrowser for help on using the repository browser.

Download in other formats: