Context Navigation

source: branches/stable/cgi-bin/IPDB.pm@ 604

Last change on this file since 604 was 601, checked in by Kris Deugau, 12 years ago

/branches/stable

File off the last few rough edges (make sure webpath is used everywhere

appropriate)

Update copyright dates
Bump the version for release

Property svn:keywords set to Date Rev Author

File size: 46.5 KB

Rev	Line
[8]	1	# ipdb/cgi-bin/IPDB.pm
[71]	2	# Contains functions for IPDB - database access, subnet mangling, block allocation, etc
[8]	3	###
	4	# SVN revision info
	5	# $Date: 2013-10-04 20:47:32 +0000 (Fri, 04 Oct 2013) $
	6	# SVN revision $Rev: 601 $
	7	# Last update by $Author: kdeugau $
	8	###
[601]	9	# Copyright (C) 2004-2013 Kris Deugau <kdeugau@deepnet.cx>
[8]	10
[4]	11	package IPDB;
	12
	13	use strict;
	14	use warnings;
	15	use Exporter;
[125]	16	use DBI;
[71]	17	use Net::SMTP;
[365]	18	use NetAddr::IP qw( Compact );
[71]	19	use POSIX;
[4]	20	use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
	21
[445]	22	$VERSION = 2; ##VERSION##
[4]	23	@ISA = qw(Exporter);
[125]	24	@EXPORT_OK = qw(
[594]	25	%disp_alloctypes %list_alloctypes %def_custids @citylist @poplist
[600]	26	%IPDBacl %aclmsg %rpcacl
[594]	27	&initIPDBGlobals &connectDB &finish &checkDBSanity
	28	&addMaster &touchMaster
	29	&listSummary &listMaster &listRBlock &listFree &listPool
	30	&getMasterList &getTypeList &getPoolSelect &findAllocateFrom
	31	&ipParent &subParent &blockParent &getRoutedCity
	32	&allocateBlock &updateBlock &deleteBlock &getBlockData
	33	&getNodeList &getNodeName &getNodeInfo
	34	&mailNotify
[125]	35	);
[4]	36
	37	@EXPORT = (); # Export nothing by default.
[125]	38	%EXPORT_TAGS = ( ALL => [qw(
[168]	39	%disp_alloctypes %list_alloctypes %def_custids @citylist @poplist
[600]	40	%IPDBacl %aclmsg %rpcacl
[594]	41	&initIPDBGlobals &connectDB &finish &checkDBSanity
	42	&addMaster &touchMaster
	43	&listSummary &listMaster &listRBlock &listFree &listPool
	44	&getMasterList &getTypeList &getPoolSelect &findAllocateFrom
	45	&ipParent &subParent &blockParent &getRoutedCity
	46	&allocateBlock &updateBlock &deleteBlock &getBlockData
	47	&getNodeList &getNodeName &getNodeInfo
	48	&mailNotify
[125]	49	)]
	50	);
[4]	51
[125]	52	##
	53	## Global variables
	54	##
	55	our %disp_alloctypes;
	56	our %list_alloctypes;
[168]	57	our %def_custids;
[125]	58	our @citylist;
	59	our @poplist;
[242]	60	our %IPDBacl;
[71]	61
[593]	62	# mapping table for functional-area => error message
	63	our %aclmsg = (
	64	addmaster => 'add a master block',
	65	addblock => 'add an allocation',
	66	updateblock => 'update a block',
	67	delblock => 'delete an allocation',
	68	);
	69
[600]	70	our %rpcacl;
	71
[445]	72	our $org_name = 'Example Corp';
	73	our $smtphost = 'smtp.example.com';
	74	our $domain = 'example.com';
	75	our $defcustid = '5554242';
	76	# mostly for rwhois
	77	##fixme: leave these blank by default?
	78	our $rwhoisDataPath = '/usr/local/rwhoisd/etc/rwhoisd'; # to match ./configure defaults from rwhoisd-1.5.9.6
	79	our $org_street = '123 4th Street';
	80	our $org_city = 'Anytown';
	81	our $org_prov_state = 'ON';
	82	our $org_pocode = 'H0H 0H0';
	83	our $org_country = 'CA';
	84	our $org_phone = '000-555-1234';
	85	our $org_techhandle = 'ISP-ARIN-HANDLE';
	86	our $org_email = 'noc@example.com';
	87	our $hostmaster = 'dns@example.com';
	88
	89	our $syslog_facility = 'local2';
	90
[508]	91	# Allow allocations to come from private IP ranges by default?
	92	# Set to 'y' or 'on' to enable.
	93	our $allowprivrange = '';
	94
[125]	95	# Let's initialize the globals.
	96	## IPDB::initIPDBGlobals()
	97	# Initialize all globals. Takes a database handle, returns a success or error code
	98	sub initIPDBGlobals {
	99	my $dbh = $_[0];
	100	my $sth;
	101
	102	# Initialize alloctypes hashes
[168]	103	$sth = $dbh->prepare("select type,listname,dispname,listorder,def_custid from alloctypes order by listorder");
[125]	104	$sth->execute;
	105	while (my @data = $sth->fetchrow_array) {
	106	$disp_alloctypes{$data[0]} = $data[2];
[168]	107	$def_custids{$data[0]} = $data[4];
[125]	108	if ($data[3] < 900) {
	109	$list_alloctypes{$data[0]} = $data[1];
	110	}
	111	}
	112
	113	# City and POP listings
[159]	114	$sth = $dbh->prepare("select city,routing from cities order by city");
[125]	115	$sth->execute;
	116	return (undef,$sth->errstr) if $sth->err;
	117	while (my @data = $sth->fetchrow_array) {
	118	push @citylist, $data[0];
	119	if ($data[1] eq 'y') {
	120	push @poplist, $data[0];
	121	}
	122	}
	123
[242]	124	# Load ACL data. Specific username checks are done at a different level.
	125	$sth = $dbh->prepare("select username,acl from users");
	126	$sth->execute;
[125]	127	return (undef,$sth->errstr) if $sth->err;
[242]	128	while (my @data = $sth->fetchrow_array) {
	129	$IPDBacl{$data[0]} = $data[1];
	130	}
[125]	131
[593]	132	##fixme: initialize HTML::Template env var for template path
	133	# something like $self->path().'/templates' ?
	134	# $ENV{HTML_TEMPLATE_ROOT} = 'foo/bar';
	135
[125]	136	return (1,"OK");
	137	} # end initIPDBGlobals
	138
	139
	140	## IPDB::connectDB()
[4]	141	# Creates connection to IPDB.
[125]	142	# Requires the database name, username, and password.
[4]	143	# Returns a handle to the db.
[125]	144	# Set up for a PostgreSQL db; could be any transactional DBMS with the
	145	# right changes.
[4]	146	sub connectDB {
[445]	147	my $dbname = shift;
	148	my $user = shift;
	149	my $pass = shift;
	150	my $dbhost = shift;
	151
[4]	152	my $dbh;
[445]	153	my $DSN = "DBI:Pg:".($dbhost ? "host=$dbhost;" : '')."dbname=$dbname";
[4]	154
	155	# Note that we want to autocommit by default, and we will turn it off locally as necessary.
[125]	156	# We may not want to print gobbledygook errors; YMMV. Have to ponder that further.
	157	$dbh = DBI->connect($DSN, $user, $pass, {
	158	AutoCommit => 1,
	159	PrintError => 0
	160	})
	161	or return (undef, $DBI::errstr) if(!$dbh);
[4]	162
[125]	163	# Return here if we can't select. Note that this indicates a
	164	# problem executing the select.
[185]	165	my $sth = $dbh->prepare("select type from alloctypes");
[125]	166	$sth->execute();
	167	return (undef,$DBI::errstr) if ($sth->err);
	168
	169	# See if the select returned anything (or null data). This should
	170	# succeed if the select executed, but...
	171	$sth->fetchrow();
	172	return (undef,$DBI::errstr) if ($sth->err);
	173
	174	# If we get here, we should be OK.
	175	return ($dbh,"DB connection OK");
[4]	176	} # end connectDB
	177
[125]	178
	179	## IPDB::finish()
	180	# Cleans up after database handles and so on.
	181	# Requires a database handle
	182	sub finish {
	183	my $dbh = $_[0];
[593]	184	$dbh->disconnect if $dbh;
[125]	185	} # end finish
	186
	187
	188	## IPDB::checkDBSanity()
[4]	189	# Quick check to see if the db is responding. A full integrity
	190	# check will have to be a separate tool to walk the IP allocation trees.
	191	sub checkDBSanity {
[125]	192	my ($dbh) = $_[0];
[4]	193
	194	if (!$dbh) {
[125]	195	print "No database handle, or connection has been closed.";
	196	return -1;
[4]	197	} else {
	198	# it connects, try a stmt.
[185]	199	my $sth = $dbh->prepare("select type from alloctypes");
[4]	200	my $err = $sth->execute();
	201
	202	if ($sth->fetchrow()) {
	203	# all is well.
	204	return 1;
	205	} else {
[16]	206	print "Connected to the database, but could not execute test statement. ".$sth->errstr();
[125]	207	return -1;
[4]	208	}
	209	}
	210	# Clean up after ourselves.
[125]	211	# $dbh->disconnect;
[4]	212	} # end checkDBSanity
	213
[71]	214
[365]	215	## IPDB::addMaster()
	216	# Does all the magic necessary to sucessfully add a master block
	217	# Requires database handle, block to add
	218	# Returns failure code and error message or success code and "message"
	219	sub addMaster {
	220	my $dbh = shift;
	221	my $cidr = new NetAddr::IP shift;
	222
	223	# Allow transactions, and raise an exception on errors so we can catch it later.
	224	# Use local to make sure these get "reset" properly on exiting this block
	225	local $dbh->{AutoCommit} = 0;
	226	local $dbh->{RaiseError} = 1;
	227
	228	# Wrap all the SQL in a transaction
	229	eval {
[594]	230	my ($mexist) = $dbh->selectrow_array("SELECT cidr FROM masterblocks WHERE cidr <<= ?", undef, ($cidr) );
[365]	231
[594]	232	if (!$mexist) {
[365]	233	# First case - master is brand-spanking-new.
	234	##fixme: rwhois should be globally-flagable somewhere, much like a number of other things
	235	## maybe a db table called "config"?
[594]	236	$dbh->do("INSERT INTO masterblocks (cidr,rwhois) VALUES (?,?)", undef, ($cidr,'y') );
[365]	237
	238	# Unrouted blocks aren't associated with a city (yet). We don't rely on this
	239	# elsewhere though; legacy data may have traps and pitfalls in it to break this.
	240	# Thus the "routed" flag.
[594]	241	$dbh->do("INSERT INTO freeblocks (cidr,maskbits,city,routed) VALUES (?,?,?,?)", undef,
	242	($cidr, $cidr->masklen, '<NULL>', 'n') );
[365]	243
	244	# If we get here, everything is happy. Commit changes.
	245	$dbh->commit;
	246
[594]	247	} # done new master does not contain existing master(s)
[365]	248	else {
	249
	250	# collect the master(s) we're going to absorb, and snag the longest netmask while we're at it.
	251	my $smallmask = $cidr->masklen;
[594]	252	my $sth = $dbh->prepare("SELECT cidr FROM masterblocks WHERE cidr <<= ?");
	253	$sth->execute($cidr);
[365]	254	my @cmasters;
	255	while (my @data = $sth->fetchrow_array) {
	256	my $master = new NetAddr::IP $data[0];
	257	push @cmasters, $master;
	258	$smallmask = $master->masklen if $master->masklen > $smallmask;
	259	}
	260
	261	# split the new master, and keep only those blocks not part of an existing master
	262	my @blocklist;
	263	foreach my $seg ($cidr->split($smallmask)) {
	264	my $contained = 0;
	265	foreach my $master (@cmasters) {
	266	$contained = 1 if $master->contains($seg);
	267	}
	268	push @blocklist, $seg if !$contained;
	269	}
	270
	271	# collect the unrouted free blocks within the new master
[594]	272	$sth = $dbh->prepare("SELECT cidr FROM freeblocks WHERE maskbits <= ? AND cidr <<= ? AND routed = 'n'");
	273	$sth->execute($smallmask, $cidr);
[365]	274	while (my @data = $sth->fetchrow_array) {
	275	my $freeblock = new NetAddr::IP $data[0];
	276	push @blocklist, $freeblock;
	277	}
	278
	279	# combine the set of free blocks we should have now.
	280	@blocklist = Compact(@blocklist);
	281
	282	# and now insert the new data. Make sure to delete old masters too.
	283
	284	# freeblocks
[594]	285	$sth = $dbh->prepare("DELETE FROM freeblocks WHERE cidr <<= ?");
	286	my $sth2 = $dbh->prepare("INSERT INTO freeblocks (cidr,maskbits,city,routed) VALUES (?,?,'<NULL>','n')");
[365]	287	foreach my $newblock (@blocklist) {
[594]	288	$sth->execute($newblock);
	289	$sth2->execute($newblock, $newblock->masklen);
[365]	290	}
	291
	292	# master
[594]	293	$dbh->do("DELETE FROM masterblocks WHERE cidr <<= ?", undef, ($cidr) );
	294	$dbh->do("INSERT INTO masterblocks (cidr,rwhois) VALUES (?,?)", undef, ($cidr, 'y') );
[365]	295
	296	# whew If we got here, we likely suceeded.
	297	$dbh->commit;
	298	} # new master contained existing master(s)
	299	}; # end eval
	300
	301	if ($@) {
	302	my $msg = $@;
	303	eval { $dbh->rollback; };
	304	return ('FAIL',$msg);
	305	} else {
	306	return ('OK','OK');
	307	}
	308	} # end addMaster
	309
	310
[594]	311	## IPDB::touchMaster()
	312	# Update last-changed timestamp on a master block.
	313	sub touchMaster {
	314	my $dbh = shift;
	315	my $master = shift;
	316
	317	local $dbh->{AutoCommit} = 0;
	318	local $dbh->{RaiseError} = 1;
	319
	320	eval {
	321	$dbh->do("UPDATE masterblocks SET mtime=now() WHERE cidr = ?", undef, ($master));
	322	$dbh->commit;
	323	};
	324
	325	if ($@) {
	326	my $msg = $@;
	327	eval { $dbh->rollback; };
	328	return ('FAIL',$msg);
	329	}
	330	return ('OK','OK');
	331	} # end touchMaster()
	332
	333
	334	## IPDB::listSummary()
	335	# Get summary list of all master blocks
	336	# Returns an arrayref to a list of hashrefs containing the master block, routed count,
	337	# allocated count, free count, and largest free block masklength
	338	sub listSummary {
	339	my $dbh = shift;
	340
	341	my $mlist = $dbh->selectall_arrayref("SELECT cidr AS master FROM masterblocks ORDER BY cidr", { Slice => {} });
	342
	343	foreach (@{$mlist}) {
	344	my ($rcnt) = $dbh->selectrow_array("SELECT count(*) FROM routed WHERE cidr <<= ?", undef, ($$_{master}));
	345	$$_{routed} = $rcnt;
	346	my ($acnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ?", undef, ($$_{master}));
	347	$$_{allocated} = $acnt;
	348	my ($fcnt) = $dbh->selectrow_array("SELECT count(*) FROM freeblocks WHERE cidr <<= ?".
	349	" AND (routed='y' OR routed='n')", undef, ($$_{master}));
	350	$$_{free} = $fcnt;
	351	my ($bigfree) = $dbh->selectrow_array("SELECT maskbits FROM freeblocks WHERE cidr <<= ?".
	352	" AND (routed='y' OR routed='n') ORDER BY maskbits LIMIT 1", undef, ($$_{master}));
	353	##fixme: should find a way to do this without having to HTMLize the <>
	354	$bigfree = "/$bigfree" if $bigfree;
	355	$bigfree = '<NONE>' if !$bigfree;
	356	$$_{bigfree} = $bigfree;
	357	}
	358	return $mlist;
	359	} # end listSummary()
	360
	361
	362	## IPDB::listMaster()
	363	# Get list of routed blocks in the requested master
	364	# Returns an arrayref to a list of hashrefs containing the routed block, POP/city the block is routed to,
	365	# allocated count, free count, and largest free block masklength
	366	sub listMaster {
	367	my $dbh = shift;
	368	my $master = shift;
	369
	370	my $rlist = $dbh->selectall_arrayref("SELECT cidr AS block,city FROM routed WHERE cidr <<= ? ORDER BY cidr",
	371	{ Slice => {} }, ($master) );
	372
	373	foreach (@{$rlist}) {
	374	my ($acnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ?", undef, ($$_{block}));
	375	$$_{nsubs} = $acnt;
	376	my ($fcnt) = $dbh->selectrow_array("SELECT count(*) FROM freeblocks WHERE cidr <<= ?".
	377	" AND (routed='y' OR routed='n')", undef, ($$_{block}));
	378	$$_{nfree} = $fcnt;
	379	my ($bigfree) = $dbh->selectrow_array("SELECT maskbits FROM freeblocks WHERE cidr <<= ?".
	380	" AND (routed='y' OR routed='n') ORDER BY maskbits LIMIT 1", undef, ($$_{block}));
	381	##fixme: should find a way to do this without having to HTMLize the <>
	382	$bigfree = "/$bigfree" if $bigfree;
	383	$bigfree = '<NONE>' if !$bigfree;
	384	$$_{lfree} = $bigfree;
	385	}
	386	return $rlist;
	387	} # end listMaster()
	388
	389
	390	## IPDB::listRBlock()
	391	# Gets a list of free blocks in the requested parent/master in both CIDR and range notation
	392	# Takes a parent/master and an optional flag to look at routed or unrouted blocks, depending
	393	# on whether the master is a direct master or a routed block
	394	# Returns an arrayref to a list of hashrefs containing the CIDR and range-notation blocks
	395	sub listRBlock {
	396	my $dbh = shift;
	397	my $routed = shift;
	398
	399	# Snag the allocations for this block
[598]	400	my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description,vrf".
[594]	401	" FROM allocations WHERE cidr <<= ? ORDER BY cidr");
	402	$sth->execute($routed);
	403
	404	# hack hack hack
	405	# set up to flag swip=y records if they don't actually have supporting data in the customers table
	406	my $custsth = $dbh->prepare("SELECT count(*) FROM customers WHERE custid = ?");
	407
	408	my @blocklist;
[598]	409	while (my ($cidr,$city,$type,$custid,$swip,$desc,$vrf) = $sth->fetchrow_array()) {
	410	$desc .= " - vrf:$vrf" if $desc && $vrf;
	411	$desc = "vrf:$vrf" if !$desc && $vrf;
[594]	412	$custsth->execute($custid);
	413	my ($ncust) = $custsth->fetchrow_array();
	414	my %row = (
	415	block => $cidr,
	416	city => $city,
	417	type => $disp_alloctypes{$type},
	418	custid => $custid,
	419	swip => ($swip eq 'y' ? 'Yes' : 'No'),
	420	partswip => ($swip eq 'y' && $ncust == 0 ? 1 : 0),
	421	desc => $desc
	422	);
	423	$row{subblock} = ($type =~ /^.r$/); # hmf. wonder why these won't work in the hash declaration...
	424	$row{listpool} = ($type =~ /^.[pd]$/);
	425	push (@blocklist, \%row);
	426	}
	427	return \@blocklist;
	428	} # end listRBlock()
	429
	430
	431	## IPDB::listFree()
	432	# Gets a list of free blocks in the requested parent/master in both CIDR and range notation
	433	# Takes a parent/master and an optional "routed or unrouted" flag that defaults to unrouted.
	434	# Returns an arrayref to a list of hashrefs containing the CIDR and range-notation blocks
	435	# Returns some extra flags in the hashrefs for routed blocks, since those can have several subtypes
	436	sub listFree {
	437	my $dbh = shift;
	438	my $master = shift;
	439	my $routed = shift \|\| 'n';
	440
	441	# do it this way so we can waste a little less time iterating
	442	my $sth = $dbh->prepare("SELECT cidr,routed FROM freeblocks WHERE cidr <<= ? AND ".
	443	($routed eq 'n' ? '' : 'NOT')." routed = 'n' ORDER BY cidr");
	444	$sth->execute($master);
	445	my @flist;
	446	while (my ($cidr,$rtype) = $sth->fetchrow_array()) {
	447	$cidr = new NetAddr::IP $cidr;
	448	my %row = (
	449	fblock => "$cidr",
	450	frange => $cidr->range,
	451	);
	452	if ($routed eq 'y') {
	453	$row{subblock} = ($rtype ne 'y' && $rtype ne 'n');
	454	$row{fbtype} = $rtype;
	455	}
	456	push @flist, \%row;
	457	}
	458	return \@flist;
	459	} # end listFree()
	460
	461
	462	## IPDB::listPool()
	463	#
	464	sub listPool {
	465	my $dbh = shift;
	466	my $pool = shift;
	467
[598]	468	my $sth = $dbh->prepare("SELECT ip,custid,available,description,type,vrf".
[594]	469	" FROM poolips WHERE pool = ? ORDER BY ip");
	470	$sth->execute($pool);
	471	my @poolips;
[598]	472	while (my ($ip,$custid,$available,$desc,$type,$vrf) = $sth->fetchrow_array) {
	473	$desc .= " - vrf:$vrf" if $desc && $vrf;
	474	$desc = "vrf:$vrf" if !$desc && $vrf;
[594]	475	my %row = (
	476	ip => $ip,
	477	custid => $custid,
	478	available => $available,
	479	desc => $desc,
	480	delme => $available eq 'n'
	481	);
	482	push @poolips, \%row;
	483	}
	484	return \@poolips;
	485	} # end listPool()
	486
	487
	488	## IPDB::getMasterList()
	489	# Get a list of master blocks, optionally including last-modified timestamps
	490	# Takes an optional flag to indicate whether to include timestamps;
	491	# 'm' includes ctime, all others (suggest 'c') do not.
	492	# Returns an arrayref to a list of hashrefs
	493	sub getMasterList {
	494	my $dbh = shift;
	495	my $stampme = shift \|\| 'm'; # optional but should be set by caller for clarity
	496
	497	my $mlist = $dbh->selectall_arrayref("SELECT cidr AS master".($stampme eq 'm' ? ',mtime' : '').
	498	" FROM masterblocks ORDER BY cidr", { Slice => {} });
	499	return $mlist;
	500	} # end getMasterList()
	501
	502
	503	## IPDB::getTypeList()
	504	# Get an alloctype/description pair list suitable for dropdowns
	505	# Takes a flag to determine which general groups of types are returned
	506	# Returns an reference to an array of hashrefs
	507	sub getTypeList {
	508	my $dbh = shift;
	509	my $tgroup = shift \|\| 'a'; # technically optional, like this, but should
	510	# really be specified in the call for clarity
	511	my $tlist;
[595]	512	if ($tgroup eq 'n') {
	513	# grouping 'n' - all netblock types. These include routed blocks, containers (_c)
	514	# and contained (_r) types, dynamic-allocation ranges (_e), static IP pools (_d and _p),
	515	# and the "miscellaneous" cn, in, and en types.
	516	$tlist = $dbh->selectall_arrayref("SELECT type,listname FROM alloctypes WHERE listorder <= 500 ".
	517	"AND type NOT LIKE '_i' ORDER BY listorder", { Slice => {} });
	518	} elsif ($tgroup eq 'p') {
	519	# grouping 'p' - primary allocation types. As with 'n' above but without the _r contained types.
	520	$tlist = $dbh->selectall_arrayref("SELECT type,listname FROM alloctypes WHERE listorder <= 500 ".
	521	"AND type NOT LIKE '_i' AND type NOT LIKE '_r' ORDER BY listorder", { Slice => {} });
[594]	522	} elsif ($tgroup eq 'c') {
	523	# grouping 'c' - contained types. These include all static IPs and all _r types.
	524	$tlist = $dbh->selectall_arrayref("SELECT type,listname FROM alloctypes WHERE listorder <= 500 ".
[595]	525	" AND (type LIKE '_i' OR type LIKE '_r') ORDER BY listorder", { Slice => {} });
	526	} elsif ($tgroup eq 'i') {
	527	# grouping 'i' - static IP types.
	528	$tlist = $dbh->selectall_arrayref("SELECT type,listname FROM alloctypes WHERE listorder <= 500 ".
	529	" AND type LIKE '_i' ORDER BY listorder", { Slice => {} });
[594]	530	} else {
	531	# grouping 'a' - all standard allocation types. This includes everything
	532	# but mm (present only as a formality). Make this the default.
	533	$tlist = $dbh->selectall_arrayref("SELECT type,listname FROM alloctypes WHERE listorder <= 500 ".
[595]	534	" ORDER BY listorder", { Slice => {} });
[594]	535	}
	536	return $tlist;
	537	}
	538
	539
	540	## IPDB::getPoolSelect()
	541	# Get a list of pools matching the passed city and type that have 1 or more free IPs
	542	# Returns an arrayref to a list of hashrefs
	543	sub getPoolSelect {
	544	my $dbh = shift;
	545	my $iptype = shift;
	546	my $pcity = shift;
	547
	548	my ($ptype) = ($iptype =~ /^(.)i$/);
	549	return if !$ptype;
	550	$ptype .= '_';
	551
	552	my $plist = $dbh->selectall_arrayref(
	553	"SELECT (SELECT city FROM allocations WHERE cidr=poolips.pool) AS poolcit, ".
	554	"poolips.pool AS poolblock, COUNT(*) AS poolfree FROM poolips,allocations ".
	555	"WHERE poolips.available='y' AND poolips.pool=allocations.cidr ".
	556	"AND allocations.city = ? AND poolips.type LIKE ? ".
	557	"GROUP BY pool", { Slice => {} }, ($pcity, $ptype) );
	558	return $plist;
	559	} # end getPoolSelect()
	560
	561
	562	## IPDB::findAllocateFrom()
	563	# Find free block to add a new allocation from. (CIDR block version of pool select above, more or less)
	564	# Takes
	565	# - mask length
	566	# - allocation type
	567	# - POP city "parent"
	568	# - optional master-block restriction
	569	# - optional flag to allow automatic pick-from-private-network-ranges
	570	# Returns a string with the first CIDR block matching the criteria, if any
	571	sub findAllocateFrom {
	572	my $dbh = shift;
	573	my $maskbits = shift;
	574	my $type = shift;
	575	my $city = shift;
	576	my $pop = shift;
	577	my %optargs = @_;
	578
	579	my $failmsg = "No suitable free block found\n";
	580
	581	## Set up the SQL to find out what freeblock we can (probably) use for an allocation.
	582	## Very large systems will require development of a reserve system (possibly an extension
	583	## of the reserve-for-expansion concept in https://secure.deepnet.cx/trac/ipdb/ticket/24?)
	584	## Also populate a value list for the DBI call.
	585
	586	my @vallist = ($maskbits, ($type eq 'rm' ? 'n' : ($type =~ /^(.)r$/ ? "$1" : 'y')) );
	587	my $sql = "SELECT cidr FROM freeblocks WHERE maskbits <= ? AND routed = ?";
	588
	589	# for PPP(oE) and container types, the POP city is the one attached to the pool.
	590	# individual allocations get listed with the customer city site.
	591	##fixme: chain cities to align roughly with a full layer-2 node graph
	592	$city = $pop if $type !~ /^.[pc]$/;
	593	if ($type ne 'rm' && $city) {
	594	$sql .= " AND city = ?";
	595	push @vallist, $city;
	596	}
	597	# Allow specifying an arbitrary full block, instead of a master
	598	if ($optargs{gimme}) {
	599	$sql .= " AND cidr >>= ?";
	600	push @vallist, $optargs{gimme};
	601	}
	602	# if a specific master was requested, allow the requestor to self->shoot(foot)
	603	if ($optargs{master} && $optargs{master} ne '-') {
	604	$sql .= " AND cidr <<= ?" if $optargs{master} ne '-';
	605	push @vallist, $optargs{master};
	606	} else {
	607	# if a specific master was NOT requested, filter out the RFC 1918 private networks
	608	if (!$optargs{allowpriv}) {
	609	$sql .= " AND NOT (cidr <<= '192.168.0.0/16' OR cidr <<= '10.0.0.0/8' OR cidr <<= '172.16.0.0/12')";
	610	}
	611	}
	612	# Sorting and limiting, since we don't (currently) care to provide a selection of
	613	# blocks to carve up. This preserves something resembling optimal usage of the IP
	614	# space by forcing contiguous allocations and free blocks as much as possible.
	615	$sql .= " ORDER BY maskbits DESC,cidr LIMIT 1";
	616
	617	my ($fbfound) = $dbh->selectrow_array($sql, undef, @vallist);
	618	return $fbfound;
	619	} # end findAllocateFrom()
	620
	621
	622	## IPDB::ipParent()
	623	# Get an IP's parent pool's details
	624	# Takes a database handle and IP
	625	# Returns a hashref to the parent pool block, if any
	626	sub ipParent {
	627	my $dbh = shift;
	628	my $block = shift;
	629
	630	my $pinfo = $dbh->selectrow_hashref("SELECT cidr,custid,type,city,description FROM allocations".
	631	" WHERE cidr >>= ?", undef, ($block) );
	632	return $pinfo;
	633	} # end ipParent()
	634
	635
	636	## IPDB::subParent()
	637	# Get a block's parent's details
	638	# Takes a database handle and CIDR block
	639	# Returns a hashref to the parent container block, if any
	640	sub subParent {
	641	my $dbh = shift;
	642	my $block = shift;
	643
	644	my $pinfo = $dbh->selectrow_hashref("SELECT cidr,custid,type,city,description FROM allocations".
	645	" WHERE cidr >>= ?", undef, ($block) );
	646	return $pinfo;
	647	} # end subParent()
	648
	649
	650	## IPDB::blockParent()
	651	# Get a block's parent's details
	652	# Takes a database handle and CIDR block
	653	# Returns a hashref to the parent container block, if any
	654	sub blockParent {
	655	my $dbh = shift;
	656	my $block = shift;
	657
	658	my $pinfo = $dbh->selectrow_hashref("SELECT cidr,city FROM routed".
	659	" WHERE cidr >>= ?", undef, ($block) );
	660	return $pinfo;
	661	} # end blockParent()
	662
	663
	664	## IPDB::getRoutedCity()
	665	# Get the city for a routed block.
	666	sub getRoutedCity {
	667	my $dbh = shift;
	668	my $block = shift;
	669
	670	my ($rcity) = $dbh->selectrow_array("SELECT city FROM routed WHERE cidr = ?", undef, ($block) );
	671	return $rcity;
	672	} # end getRoutedCity()
	673
	674
[125]	675	## IPDB::allocateBlock()
[71]	676	# Does all of the magic of actually allocating a netblock
[125]	677	# Requires database handle, block to allocate, custid, type, city,
[286]	678	# description, notes, circuit ID, block to allocate from, private data
[125]	679	# Returns a success code and optional error message.
	680	sub allocateBlock {
[598]	681	my ($dbh,undef,undef,$custid,$type,$city,$desc,$notes,$circid,$privdata,$nodeid,$vrf) = @_;
[508]	682	$privdata = '' if !defined($privdata);
[598]	683	$vrf = '' if !defined($vrf);
[286]	684
[125]	685	my $cidr = new NetAddr::IP $_[1];
	686	my $alloc_from = new NetAddr::IP $_[2];
	687	my $sth;
[71]	688
[592]	689	$desc = '' if !$desc;
	690	$notes = '' if !$notes;
	691	$circid = '' if !$circid;
	692	$privdata = '' if !$privdata;
	693
[336]	694	# Snag the "type" of the freeblock (alloc_from) "just in case"
	695	$sth = $dbh->prepare("select routed from freeblocks where cidr='$alloc_from'");
	696	$sth->execute;
	697	my ($alloc_from_type) = $sth->fetchrow_array;
	698
[125]	699	# To contain the error message, if any.
	700	my $msg = "Unknown error allocating $cidr as '$type'";
[71]	701
[125]	702	# Enable transactions and error handling
	703	local $dbh->{AutoCommit} = 0; # These need to be local so we don't
	704	local $dbh->{RaiseError} = 1; # step on our toes by accident.
	705
[159]	706	if ($type =~ /^.i$/) {
[125]	707	$msg = "Unable to assign static IP $cidr to $custid";
	708	eval {
[159]	709	# We have to do this in two parts because otherwise we lose
	710	# the ability to return the IP assigned. Should that change,
	711	# the commented SQL statement below may become usable.
[125]	712	# update poolips set custid='$custid',city='$city',available='n',
	713	# description='$desc',notes='$notes',circuitid='$circid'
	714	# where ip=(select ip from poolips where pool='$alloc_from'
	715	# and available='y' order by ip limit 1);
[159]	716
[594]	717	if ($cidr) {
	718	my ($isavail) = $dbh->selectrow_array("SELECT available FROM poolips WHERE ip=?", undef, ($cidr) );
	719	if ($isavail eq 'n') {
	720	die "IP already allocated. Deallocate and reallocate, or update the entry\n";
	721	}
	722	if (!$isavail) {
	723	die "IP is not in an IP pool.\n";
	724	}
	725	} else {
	726	($cidr) = $dbh->selectrow_array("SELECT ip FROM poolips WHERE pool=? AND available='y' ORDER BY ip",
	727	undef, ($alloc_from) );
[550]	728	}
[598]	729	$dbh->do("UPDATE poolips SET custid=?,city=?,available='n',description=?,".
	730	"notes=?,circuitid=?,privdata=?,vrf=? ".
	731	"WHERE ip=?", undef, ($custid, $city, $desc, $notes, $circid, $privdata, $vrf, $cidr) );
[125]	732
[394]	733	# node hack
	734	if ($nodeid && $nodeid ne '') {
	735	$sth = $dbh->prepare("INSERT INTO noderef (block,node_id) VALUES (?,?)");
	736	$sth->execute("$cidr",$nodeid);
	737	}
	738	# end node hack
[594]	739
[125]	740	$dbh->commit;
	741	};
	742	if ($@) {
[594]	743	$msg .= ": $@";
[125]	744	eval { $dbh->rollback; };
	745	return ('FAIL',$msg);
	746	} else {
	747	return ('OK',"$cidr");
	748	}
	749
	750	} else { # end IP-from-pool allocation
	751
[549]	752	my $errcode = 'OK';
[125]	753	if ($cidr == $alloc_from) {
	754	# Easiest case- insert in one table, delete in the other, and go home. More or less.
	755	# insert into allocations values (cidr,custid,type,city,desc) and
	756	# delete from freeblocks where cidr='cidr'
	757	# For data safety on non-transaction DBs, we delete first.
	758
	759	eval {
	760	$msg = "Unable to allocate $cidr as '$disp_alloctypes{$type}'";
[192]	761	if ($type eq 'rm') {
[125]	762	$sth = $dbh->prepare("update freeblocks set routed='y',city='$city'".
	763	" where cidr='$cidr'");
	764	$sth->execute;
[159]	765	$sth = $dbh->prepare("insert into routed (cidr,maskbits,city)".
	766	" values ('$cidr',".$cidr->masklen.",'$city')");
[125]	767	$sth->execute;
	768	} else {
	769	# common stuff for end-use, dialup, dynDSL, pools, etc, etc.
	770
[192]	771	# special case - block is a container/"reserve" block
	772	if ($type =~ /^(.)c$/) {
	773	$sth = $dbh->prepare("update freeblocks set routed='$1' where cidr='$cidr'");
	774	$sth->execute;
	775	} else {
	776	# "normal" case
	777	$sth = $dbh->prepare("delete from freeblocks where cidr='$cidr'");
	778	$sth->execute;
	779	}
[159]	780	$sth = $dbh->prepare("insert into allocations".
[598]	781	" (cidr,custid,type,city,description,notes,maskbits,circuitid,privdata,vrf)".
	782	" values (?,?,?,?,?,?,?,?,?,?)");
	783	$sth->execute("$cidr", $custid, $type, $city, $desc, $notes, $cidr->masklen, $circid, $privdata, $vrf);
[125]	784
	785	# And initialize the pool, if necessary
[159]	786	# PPPoE pools (currently dialup, DSL, and WiFi) get all IPs made available
	787	# "DHCP" or "real-subnet" pools have the net, gw, and bcast IPs removed.
[125]	788	if ($type =~ /^.p$/) {
[159]	789	$msg = "Could not initialize IPs in new $disp_alloctypes{$type} $cidr";
	790	my ($code,$rmsg) = initPool($dbh,$cidr,$type,$city,"all");
	791	die $rmsg if $code eq 'FAIL';
[549]	792	$msg = $rmsg;
	793	$errcode = $code;
[159]	794	} elsif ($type =~ /^.d$/) {
	795	$msg = "Could not initialize IPs in new $disp_alloctypes{$type} $cidr";
	796	my ($code,$rmsg) = initPool($dbh,$cidr,$type,$city,"normal");
	797	die $rmsg if $code eq 'FAIL';
[549]	798	$msg = $rmsg;
	799	$errcode = $code;
[125]	800	}
	801
	802	} # routing vs non-routing netblock
	803
[394]	804	# node hack
	805	if ($nodeid && $nodeid ne '') {
	806	$sth = $dbh->prepare("INSERT INTO noderef (block,node_id) VALUES (?,?)");
	807	$sth->execute("$cidr",$nodeid);
	808	}
	809	# end node hack
[125]	810	$dbh->commit;
	811	}; # end of eval
	812	if ($@) {
[159]	813	$msg .= ": ".$@;
[125]	814	eval { $dbh->rollback; };
[159]	815	return ('FAIL',$msg);
[125]	816	} else {
[549]	817	return ($errcode,($type =~ /^.[pd]$/ ? $msg : "OK"));
[125]	818	}
	819
	820	} else { # cidr != alloc_from
	821
	822	# Hard case. Allocation is smaller than free block.
	823	my $wantmaskbits = $cidr->masklen;
	824	my $maskbits = $alloc_from->masklen;
	825
	826	my @newfreeblocks; # Holds free blocks generated from splitting the source freeblock.
	827
	828	# This determines which blocks will be left "free" after allocation. We take the
	829	# block we're allocating from, and split it in half. We see which half the wanted
	830	# block is in, and repeat until the wanted block is equal to one of the halves.
	831	my $i=0;
	832	my $tmp_from = $alloc_from; # So we don't munge $alloc_from
	833	while ($maskbits++ < $wantmaskbits) {
	834	my @subblocks = $tmp_from->split($maskbits);
	835	$newfreeblocks[$i++] = (($cidr->within($subblocks[0])) ? $subblocks[1] : $subblocks[0]);
	836	$tmp_from = ( ($cidr->within($subblocks[0])) ? $subblocks[0] : $subblocks[1] );
	837	} # while
	838
	839	# Begin SQL transaction block
	840	eval {
	841	$msg = "Unable to allocate $cidr as '$disp_alloctypes{$type}'";
	842
	843	# Delete old freeblocks entry
	844	$sth = $dbh->prepare("delete from freeblocks where cidr='$alloc_from'");
	845	$sth->execute();
	846
	847	# now we have to do some magic for routing blocks
[192]	848	if ($type eq 'rm') {
[125]	849
	850	# Insert the new freeblocks entries
	851	# Note that non-routed blocks are assigned to <NULL>
[159]	852	# and use the default value for the routed column ('n')
	853	$sth = $dbh->prepare("insert into freeblocks (cidr,maskbits,city)".
	854	" values (?, ?, '<NULL>')");
[125]	855	foreach my $block (@newfreeblocks) {
	856	$sth->execute("$block", $block->masklen);
	857	}
	858
	859	# Insert the entry in the routed table
[159]	860	$sth = $dbh->prepare("insert into routed (cidr,maskbits,city)".
	861	" values ('$cidr',".$cidr->masklen.",'$city')");
[125]	862	$sth->execute;
	863	# Insert the (almost) same entry in the freeblocks table
[159]	864	$sth = $dbh->prepare("insert into freeblocks (cidr,maskbits,city,routed)".
	865	" values ('$cidr',".$cidr->masklen.",'$city','y')");
[125]	866	$sth->execute;
	867
[192]	868	} else { # done with alloctype == rm
[125]	869
	870	# Insert the new freeblocks entries
[336]	871	# Along with some more HairyPerl(TM):
	872	# if $alloc_type_from is p
	873	# OR
	874	# $type matches /^(.)r$/
	875	# inserted value for routed column should match.
	876	# This solves the case of inserting an arbitrary block into a
	877	# "Reserve-for-routed-DSL" block. Which you really shouldn't
	878	# do in the first place, but anyway...
[159]	879	$sth = $dbh->prepare("insert into freeblocks (cidr,maskbits,city,routed)".
[192]	880	" values (?, ?, (select city from routed where cidr >>= '$cidr'),'".
[336]	881	( ( ($alloc_from_type =~ /^(p)$/) \|\| ($type =~ /^(.)r$/) ) ? "$1" : 'y')."')");
[125]	882	foreach my $block (@newfreeblocks) {
	883	$sth->execute("$block", $block->masklen);
	884	}
[192]	885	# Special-case for reserve/"container" blocks - generate
	886	# the "extra" freeblocks entry for the container
	887	if ($type =~ /^(.)c$/) {
	888	$sth = $dbh->prepare("insert into freeblocks (cidr,maskbits,city,routed)".
	889	" values ('$cidr',".$cidr->masklen.",'$city','$1')");
	890	$sth->execute;
	891	}
[125]	892	# Insert the allocations entry
[159]	893	$sth = $dbh->prepare("insert into allocations (cidr,custid,type,city,".
[598]	894	"description,notes,maskbits,circuitid,privdata,vrf)".
	895	" values (?,?,?,?,?,?,?,?,?,?)");
	896	$sth->execute("$cidr", $custid, $type, $city, $desc, $notes, $cidr->masklen, $circid, $privdata, $vrf);
[125]	897
	898	# And initialize the pool, if necessary
[159]	899	# PPPoE pools (currently dialup, DSL, and WiFi) get all IPs made available
	900	# "DHCP" or "real-subnet" pools have the net, gw, and bcast IPs removed.
[125]	901	if ($type =~ /^.p$/) {
	902	$msg = "Could not initialize IPs in new $disp_alloctypes{$type} $cidr";
[159]	903	my ($code,$rmsg) = initPool($dbh,$cidr,$type,$city,"all");
	904	die $rmsg if $code eq 'FAIL';
	905	} elsif ($type =~ /^.d$/) {
	906	$msg = "Could not initialize IPs in new $disp_alloctypes{$type} $cidr";
	907	my ($code,$rmsg) = initPool($dbh,$cidr,$type,$city,"normal");
	908	die $rmsg if $code eq 'FAIL';
[125]	909	}
	910
[192]	911	} # done with netblock alloctype != rm
[125]	912
[394]	913	# node hack
	914	if ($nodeid && $nodeid ne '') {
	915	$sth = $dbh->prepare("INSERT INTO noderef (block,node_id) VALUES (?,?)");
	916	$sth->execute("$cidr",$nodeid);
	917	}
	918	# end node hack
[125]	919	$dbh->commit;
	920	}; # end eval
	921	if ($@) {
[250]	922	$msg .= ": ".$@;
[125]	923	eval { $dbh->rollback; };
	924	return ('FAIL',$msg);
	925	} else {
[549]	926	return ($errcode,($type =~ /^.[pd]$/ ? $msg : "OK"));
[125]	927	}
	928
	929	} # end fullcidr != alloc_from
	930
	931	} # end static-IP vs netblock allocation
	932
	933	} # end allocateBlock()
	934
	935
	936	## IPDB::initPool()
	937	# Initializes a pool
	938	# Requires a database handle, the pool CIDR, type, city, and a parameter
	939	# indicating whether the pool should allow allocation of literally every
	940	# IP, or if it should reserve network/gateway/broadcast IPs
	941	# Note that this is NOT done in a transaction, that's why it's a private
	942	# function and should ONLY EVER get called from allocateBlock()
	943	sub initPool {
	944	my ($dbh,undef,$type,$city,$class) = @_;
	945	my $pool = new NetAddr::IP $_[1];
	946
[549]	947	return ('WARN','Refusing to melt server with IPv6 IP pool') if $pool->bits == 128;
	948
[159]	949	##fixme Need to just replace 2nd char of type with i rather than capturing 1st char of type
	950	$type =~ s/[pd]$/i/;
[125]	951	my $sth;
[159]	952	my $msg;
[125]	953
[159]	954	# Trap errors so we can pass them back to the caller. Even if the
	955	# caller is only ever supposed to be local, and therefore already
	956	# trapping errors. >:(
	957	local $dbh->{AutoCommit} = 0; # These need to be local so we don't
	958	local $dbh->{RaiseError} = 1; # step on our toes by accident.
	959
	960	eval {
	961	# have to insert all pool IPs into poolips table as "unallocated".
	962	$sth = $dbh->prepare("insert into poolips (pool,ip,custid,city,type)".
[592]	963	" values ('$pool', ?, '$defcustid', ?, '$type')");
[159]	964	my @poolip_list = $pool->hostenum;
	965	if ($class eq 'all') { # (DSL-ish block - all IPs available
[248]	966	if ($pool->addr !~ /\.0$/) { # .0 causes weirdness.
[592]	967	$sth->execute($pool->addr, $city);
[248]	968	}
[159]	969	for (my $i=0; $i<=$#poolip_list; $i++) {
[592]	970	$sth->execute($poolip_list[$i]->addr, $city);
[159]	971	}
	972	$pool--;
[248]	973	if ($pool->addr !~ /\.255$/) { # .255 can cause weirdness.
[592]	974	$sth->execute($pool->addr, $city);
[248]	975	}
[159]	976	} else { # (real netblock)
	977	for (my $i=1; $i<=$#poolip_list; $i++) {
[592]	978	$sth->execute($poolip_list[$i]->addr, $city);
[159]	979	}
[125]	980	}
[159]	981	};
	982	if ($@) {
[592]	983	$msg = $@." '".$sth->errstr."'";
[159]	984	eval { $dbh->rollback; };
	985	return ('FAIL',$msg);
	986	} else {
	987	return ('OK',"OK");
[125]	988	}
	989	} # end initPool()
	990
	991
[594]	992	## IPDB::updateBlock()
	993	# Update an allocation
	994	# Takes all allocation fields in a hash
	995	sub updateBlock {
	996	my $dbh = shift;
	997	my %args = @_;
	998
	999	return ('FAIL', 'Missing block to update') if !$args{block};
	1000
	1001	# do it all in a transaction
	1002	local $dbh->{AutoCommit} = 0;
	1003	local $dbh->{RaiseError} = 1;
	1004
	1005	my @fieldlist;
	1006	my @vallist;
[598]	1007	foreach ('custid', 'city', 'description', 'notes', 'circuitid', 'privdata', 'vrf') {
[594]	1008	if ($args{$_}) {
	1009	push @fieldlist, $_;
	1010	push @vallist, $args{$_};
	1011	}
	1012	}
	1013
	1014	my $updtable = 'allocations';
	1015	my $keyfield = 'cidr';
	1016	if ($args{type} =~ /^(.)i$/) {
	1017	$updtable = 'poolips';
	1018	$keyfield = 'ip';
	1019	} else {
	1020	## fixme: there's got to be a better way...
	1021	if ($args{swip}) {
	1022	if ($args{swip} eq 'on' \|\| $args{swip} eq '1' \|\| $args{swip} eq 'y') {
	1023	$args{swip} = 'y';
	1024	} else {
	1025	$args{swip} = 'n';
	1026	}
	1027	}
	1028	foreach ('type', 'swip') {
	1029	if ($args{$_}) {
	1030	push @fieldlist, $_;
	1031	push @vallist, $args{$_};
	1032	}
	1033	}
	1034	}
	1035
	1036	return ('FAIL', 'No fields to update') if !@fieldlist;
	1037
	1038	push @vallist, $args{block};
	1039	my $sql = "UPDATE $updtable SET ";
	1040	$sql .= join " = ?, ", @fieldlist;
	1041	$sql .= " = ? WHERE $keyfield = ?";
	1042
	1043	eval {
	1044	# do the update
	1045	$dbh->do($sql, undef, @vallist);
	1046
	1047	if ($args{node}) {
	1048	# done with delete/insert so we don't have to worry about funkyness updating a node ref that isn't there
	1049	$dbh->do("DELETE FROM noderef WHERE block = ?", undef, ($args{block}) );
	1050	$dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{block}, $args{node}) );
	1051	}
	1052
	1053	$dbh->commit;
	1054	};
	1055	if ($@) {
	1056	my $msg = $@;
	1057	$dbh->rollback;
	1058	return ('FAIL', $msg);
	1059	}
	1060	return 0;
	1061	} # end updateBlock()
	1062
	1063
[125]	1064	## IPDB::deleteBlock()
	1065	# Removes an allocation from the database, including deleting IPs
	1066	# from poolips and recombining entries in freeblocks if possible
	1067	# Also handles "deleting" a static IP allocation, and removal of a master
	1068	# Requires a database handle, the block to delete, and the type of block
	1069	sub deleteBlock {
	1070	my ($dbh,undef,$type) = @_;
	1071	my $cidr = new NetAddr::IP $_[1];
	1072
	1073	my $sth;
	1074
[336]	1075	# Magic variables used for odd allocation cases.
	1076	my $container;
	1077	my $con_type;
	1078
[125]	1079	# To contain the error message, if any.
	1080	my $msg = "Unknown error deallocating $type $cidr";
	1081	# Enable transactions and exception-on-errors... but only for this sub
	1082	local $dbh->{AutoCommit} = 0;
	1083	local $dbh->{RaiseError} = 1;
	1084
	1085	# First case. The "block" is a static IP
	1086	# Note that we still need some additional code in the odd case
	1087	# of a netblock-aligned contiguous group of static IPs
	1088	if ($type =~ /^.i$/) {
	1089
	1090	eval {
[159]	1091	$msg = "Unable to deallocate $disp_alloctypes{$type} $cidr";
[593]	1092	$sth = $dbh->prepare("update poolips set custid=?,available='y',".
	1093	"city=(select city from allocations where cidr >>= ?".
[354]	1094	" order by masklen(cidr) desc limit 1),".
[593]	1095	"description='',notes='',circuitid='' where ip=?");
	1096	$sth->execute($defcustid, "$cidr", "$cidr");
[125]	1097	$dbh->commit;
	1098	};
	1099	if ($@) {
	1100	eval { $dbh->rollback; };
	1101	return ('FAIL',$msg);
	1102	} else {
	1103	return ('OK',"OK");
	1104	}
	1105
	1106	} elsif ($type eq 'mm') { # end alloctype =~ /.i/
	1107
	1108	$msg = "Unable to delete master block $cidr";
	1109	eval {
[598]	1110	$sth = $dbh->prepare("delete from masterblocks where cidr=?");
	1111	$sth->execute($cidr);
	1112	$sth = $dbh->prepare("delete from freeblocks where cidr <<= ?");
	1113	$sth->execute($cidr);
[125]	1114	$dbh->commit;
	1115	};
	1116	if ($@) {
	1117	eval { $dbh->rollback; };
	1118	return ('FAIL', $msg);
	1119	} else {
	1120	return ('OK',"OK");
	1121	}
	1122
	1123	} else { # end alloctype master block case
	1124
	1125	## This is a big block; but it HAS to be done in a chunk. Any removal
	1126	## of a netblock allocation may result in a larger chunk of free
	1127	## contiguous IP space - which may in turn be combined into a single
	1128	## netblock rather than a number of smaller netblocks.
	1129
	1130	eval {
	1131
[192]	1132	if ($type eq 'rm') {
[125]	1133	$msg = "Unable to remove routing allocation $cidr";
	1134	$sth = $dbh->prepare("delete from routed where cidr='$cidr'");
	1135	$sth->execute;
	1136	# Make sure block getting deleted is properly accounted for.
	1137	$sth = $dbh->prepare("update freeblocks set routed='n',city='<NULL>'".
	1138	" where cidr='$cidr'");
	1139	$sth->execute;
	1140	# Set up query to start compacting free blocks.
[159]	1141	$sth = $dbh->prepare("select cidr from freeblocks where ".
[125]	1142	"maskbits<=".$cidr->masklen." and routed='n' order by maskbits desc");
	1143
	1144	} else { # end alloctype routing case
	1145
[336]	1146	# Magic. We need to get information about the containing block (if any)
	1147	# so as to make sure that the freeblocks we insert get the correct "type".
	1148	$sth = $dbh->prepare("select cidr,type from allocations where cidr >> '$cidr'");
	1149	$sth->execute;
	1150	($container, $con_type) = $sth->fetchrow_array;
	1151
[192]	1152	# Delete all allocations within the block being deleted. This is
	1153	# deliberate and correct, and removes the need to special-case
	1154	# removal of "container" blocks.
	1155	$sth = $dbh->prepare("delete from allocations where cidr <<='$cidr'");
[125]	1156	$sth->execute;
[192]	1157
[125]	1158	# Special case - delete pool IPs
[159]	1159	if ($type =~ /^.[pd]$/) {
[125]	1160	# We have to delete the IPs from the pool listing.
	1161	$sth = $dbh->prepare("delete from poolips where pool='$cidr'");
	1162	$sth->execute;
	1163	}
	1164
	1165	# Set up query for compacting free blocks.
[336]	1166	if ($con_type && $con_type eq 'pc') {
	1167	# Clean up after "bad" allocations (blocks that are not formally
	1168	# contained which have nevertheless been allocated from a container block)
	1169	# We want to make certain that the freeblocks are properly "labelled"
[362]	1170	$sth = $dbh->prepare("select cidr from freeblocks where cidr <<= '$container' order by maskbits desc");
[336]	1171	} else {
	1172	# Standard deallocation.
	1173	$sth = $dbh->prepare("select cidr from freeblocks where cidr <<= ".
[125]	1174	"(select cidr from routed where cidr >>= '$cidr') ".
[192]	1175	" and maskbits<=".$cidr->masklen.
[304]	1176	" and routed='".(($type =~ /^(.)r$/) ? "$1" : 'y').
[192]	1177	"' order by maskbits desc");
[336]	1178	}
[125]	1179
	1180	} # end alloctype general case
	1181
[445]	1182	## Deallocate legacy blocks stashed in the middle of a static IP pool
	1183	## This may be expandable to an even more general case of contained netblock, or other pool types.
[126]	1184
[445]	1185	# Find out if the block we're deallocating is within a DSL pool
	1186	my $sth2 = $dbh->prepare("SELECT cidr,city,type FROM allocations WHERE type LIKE '_p' AND cidr >>= ?");
	1187	$sth2->execute("$cidr");
	1188	my ($pool,$poolcity,$pooltype) = $sth2->fetchrow_array;
[126]	1189
[445]	1190	if ($pool \|\| $sth2->rows) {
	1191	# We've already deleted the block, now we have to stuff its IPs into the pool.
	1192	$pooltype =~ s/p$/i/; # change type to static IP
	1193	$sth2 = $dbh->prepare("INSERT INTO poolips (pool,ip,city,type,custid) values ".
	1194	"('$pool',?,'$poolcity','$pooltype','$defcustid')");
	1195	##fixme: need to not insert net, gateway, and bcast on "real netblock" pools (DHCPish)
	1196	# don't insert .0
	1197	$sth2->execute($cidr->addr) unless $cidr->addr =~ m\|\.0$\|;
	1198	foreach my $ip ($cidr->hostenum) {
	1199	$sth2->execute("$ip");
	1200	}
	1201	$cidr--;
	1202	# don't insert .255
	1203	$sth2->execute($cidr->addr) unless $cidr->addr =~ m\|\.255$\|;
	1204	} else { # done returning IPs from a block to a static DSL pool
[125]	1205
[445]	1206	# Now we look for larger-or-equal-sized free blocks in the same master (routed)
	1207	# (super)block. If there aren't any, we can't combine blocks anyway. If there
	1208	# are, we check to see if we can combine blocks.
	1209	# Execute the statement prepared in the if-else above.
[125]	1210
[445]	1211	$sth->execute;
	1212
[125]	1213	# NetAddr::IP->compact() attempts to produce the smallest inclusive block
	1214	# from the caller and the passed terms.
	1215	# EG: if you call $cidr->compact($ip1,$ip2,$ip3) when $cidr, $ip1, $ip2,
	1216	# and $ip3 are consecutive /27's starting on .0 (.0-.31, .32-.63,
	1217	# .64-.95, and .96-.128), you will get an array containing a single
	1218	# /25 as element 0 (.0-.127). Order is not important; you could have
	1219	# $cidr=.32/27, $ip1=.96/27, $ip2=.0/27, and $ip3=.64/27.
	1220
[445]	1221	my (@together, @combinelist);
	1222	my $i=0;
	1223	while (my @data = $sth->fetchrow_array) {
	1224	my $testIP = new NetAddr::IP $data[0];
	1225	@together = $testIP->compact($cidr);
	1226	my $num = @together;
	1227	if ($num == 1) {
	1228	$cidr = $together[0];
	1229	$combinelist[$i++] = $testIP;
	1230	}
[125]	1231	}
	1232
[445]	1233	# Clear old freeblocks entries - if any. They should all be within
	1234	# the $cidr determined above.
	1235	$sth = $dbh->prepare("delete from freeblocks where cidr <<='$cidr'");
	1236	$sth->execute;
[125]	1237
[445]	1238	# insert "new" freeblocks entry
	1239	if ($type eq 'rm') {
	1240	$sth = $dbh->prepare("insert into freeblocks (cidr,maskbits,city)".
[159]	1241	" values ('$cidr',".$cidr->masklen.",'<NULL>')");
[445]	1242	} else {
	1243	# Magic hackery to insert "correct" data for deallocation of
	1244	# non-contained blocks allocated from within a container.
	1245	$type = 'pr' if $con_type && $con_type eq 'pc';
[336]	1246
[445]	1247	$sth = $dbh->prepare("insert into freeblocks (cidr,maskbits,city,routed)".
[159]	1248	" values ('$cidr',".$cidr->masklen.
[192]	1249	",(select city from routed where cidr >>= '$cidr'),'".
	1250	(($type =~ /^(.)r$/) ? "$1" : 'y')."')");
[445]	1251	}
	1252	$sth->execute;
[125]	1253
[445]	1254	} # done returning IPs to the appropriate place
[126]	1255
[125]	1256	# If we got here, we've succeeded. Whew!
	1257	$dbh->commit;
	1258	}; # end eval
	1259	if ($@) {
[445]	1260	$msg = $@;
[125]	1261	eval { $dbh->rollback; };
	1262	return ('FAIL', $msg);
	1263	} else {
	1264	return ('OK',"OK");
	1265	}
	1266
	1267	} # end alloctype != netblock
	1268
	1269	} # end deleteBlock()
	1270
	1271
[356]	1272	## IPDB::getBlockData()
[594]	1273	# Get CIDR or IP, custid, type, city, circuit ID, description, notes, modification time, private/restricted
[598]	1274	# data, and VRF tag, for a CIDR block or pool IP
[594]	1275	# Also returns SWIP status flag for CIDR blocks
	1276	# Takes the block/IP to look up
	1277	# Returns an arrayref to a list of hashrefs
[356]	1278	sub getBlockData {
	1279	my $dbh = shift;
	1280	my $block = shift;
	1281
[594]	1282	my $cidr = new NetAddr::IP $block;
	1283
	1284	my $keycol = 'cidr';
	1285	my $blocktable = 'allocations';
	1286	my $poolip = 0;
	1287
	1288	# Pool IP and IPv6 check all in one! Still needs to be tightened
	1289	# up a little for the as-yet-unhandled case of IPv6 IP pools
	1290	if ($cidr->bits == 32 && $cidr->masklen == 32) {
	1291	$poolip = 1;
	1292	$keycol = 'ip';
	1293	$blocktable = 'poolips';
	1294	}
	1295	my $binfo = $dbh->selectrow_hashref("SELECT $keycol AS block, custid, type, city, circuitid, description,".
[598]	1296	" notes, modifystamp AS lastmod, privdata, vrf".($poolip ? '' : ', swip')." FROM $blocktable".
[594]	1297	" WHERE $keycol = ?", undef, ($block) );
	1298	return $binfo;
[356]	1299	} # end getBlockData()
	1300
	1301
[594]	1302	## IPDB::getNodeList()
	1303	# Gets a list of node ID+name pairs as an arrayref to a list of hashrefs
	1304	sub getNodeList {
	1305	my $dbh = shift;
	1306
	1307	my $ret = $dbh->selectall_arrayref("SELECT node_id, node_name FROM nodes ORDER BY node_type,node_id",
	1308	{ Slice => {} });
	1309	return $ret;
	1310	} # end getNodeList()
	1311
	1312
	1313	## IPDB::getNodeName()
	1314	# Get node name from the ID
	1315	sub getNodeName {
	1316	my $dbh = shift;
	1317	my $nid = shift;
	1318
	1319	my ($nname) = $dbh->selectrow_array("SELECT node_name FROM nodes WHERE node_id = ?", undef, ($nid) );
	1320	return $nname;
	1321	} # end getNodeName()
	1322
	1323
	1324	## IPDB::getNodeInfo()
	1325	# Get node name and ID associated with a block
	1326	sub getNodeInfo {
	1327	my $dbh = shift;
	1328	my $block = shift;
	1329
	1330	my ($nid, $nname) = $dbh->selectrow_array("SELECT nodes.node_id,node_name FROM nodes INNER JOIN noderef".
	1331	" ON nodes.node_id=noderef.node_id WHERE noderef.block = ?", undef, ($block) );
	1332	return ($nid, $nname);
	1333	} # end getNodeInfo()
	1334
	1335
[125]	1336	## IPDB::mailNotify()
[71]	1337	# Sends notification mail to recipients regarding an IPDB operation
[445]	1338	sub mailNotify {
	1339	my $dbh = shift;
	1340	my ($action,$subj,$message) = @_;
[71]	1341
[592]	1342	return if $smtphost eq 'smtp.example.com'; # do nothing if still using default SMTP host.
[509]	1343
[445]	1344	##fixme: need to redesign the breakdown/processing for $action for proper handling of all cases
	1345
	1346	# split action into parts for fiddlement. nb: there are almost certainly better ways to do this.
	1347	my @actionbits = split //, $action;
	1348
	1349	# want to notify anyone who has specifically requested notify on this type ($action as passed),
	1350	# on "all static IP types" or "all pool types" (and other last-char-in-type groupings), on eg "all DSL types",
	1351	# and "all events with this action"
	1352	my @actionsets = ($action);
	1353	##fixme: ick, eww. really gotta find a better way to handle this...
	1354	push @actionsets, ($actionbits[0].'.'.$actionbits[2],
	1355	$actionbits[0].$actionbits[1].'.', $actionbits[0].'a') if $action =~ /^.{3}$/;
	1356
	1357	my $mailer = Net::SMTP->new($smtphost, Hello => "ipdb.$domain");
	1358
	1359	# get recip list from db
	1360	my $sth = $dbh->prepare("SELECT reciplist FROM notify WHERE action=?");
	1361
	1362	my %reciplist;
	1363	foreach (@actionsets) {
	1364	$sth->execute($_);
	1365	##fixme - need to handle db errors
	1366	my ($recipsub) = $sth->fetchrow_array;
	1367	next if !$recipsub;
	1368	foreach (split(/,/, $recipsub)) {
	1369	$reciplist{$_}++;
	1370	}
	1371	}
	1372
	1373	return if !%reciplist;
	1374
	1375	foreach my $recip (keys %reciplist) {
	1376	$mailer->mail("ipdb\@$domain");
	1377	$mailer->to($recip);
	1378	$mailer->data("From: \"$org_name IP Database\" <ipdb\@$domain>\n",
[131]	1379	"To: $recip\n",
[71]	1380	"Date: ".strftime("%a, %d %b %Y %H:%M:%S %z",localtime)."\n",
	1381	"Subject: {IPDB} $subj\n",
	1382	"X-Mailer: IPDB Notify v".sprintf("%.1d",$IPDB::VERSION)."\n",
[445]	1383	"Organization: $org_name\n",
[71]	1384	"\n$message\n");
[445]	1385	}
[71]	1386	$mailer->quit;
	1387	}
	1388
[4]	1389	# Indicates module loaded OK. Required by Perl.
	1390	1;

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

Download in other formats: