Context Navigation

source: trunk/cgi-bin/main.cgi@ 866

Last change on this file since 866 was 866, checked in by Kris Deugau, 8 years ago

/trunk

main.cgi:

Don't spew warnings and break the UI when retrieval of the zone list for a netblock fails

IPDB.pm, ipdb-rpc.cgi:

Fill out rpc_listPool stub in ipdb-rpc.cgi. The first likely consumer may not want the full UI dataset (with description and "deleteme" flag) so the core sub has been extended with an optional flag that defaults to on.

ipdb-rpc.cgi:

Correct argument validation in rpc_deleteBlock()

Property svn:executable set to *
Property svn:keywords set to Date Rev Author

File size: 59.3 KB

Rev	Line
[4]	1	#!/usr/bin/perl
	2	# ipdb/cgi-bin/main.cgi
[8]	3	###
	4	# SVN revision info
	5	# $Date: 2016-05-02 21:59:07 +0000 (Mon, 02 May 2016) $
	6	# SVN revision $Rev: 866 $
	7	# Last update by $Author: kdeugau $
	8	###
[417]	9	# Copyright (C) 2004-2010 - Kris Deugau
[4]	10
	11	use strict;
	12	use warnings;
	13	use CGI::Carp qw(fatalsToBrowser);
[517]	14	use CGI::Simple;
	15	use HTML::Template;
[4]	16	use DBI;
	17	use POSIX qw(ceil);
	18	use NetAddr::IP;
[582]	19	use Frontier::Client;
[4]	20
	21	use Sys::Syslog;
	22
[417]	23	# don't remove! required for GNU/FHS-ish install from tarball
	24	##uselib##
	25
[515]	26	use CustIDCK;
[417]	27	use MyIPDB;
	28
[431]	29	openlog "IPDB","pid","$IPDB::syslog_facility";
[4]	30
[517]	31	## Environment. Collect some things, process some things, set some things...
	32
[233]	33	# Collect the username from HTTP auth. If undefined, we're in
	34	# a test environment, or called without a username.
[4]	35	my $authuser;
	36	if (!defined($ENV{'REMOTE_USER'})) {
	37	$authuser = '__temptest';
	38	} else {
	39	$authuser = $ENV{'REMOTE_USER'};
	40	}
	41
[517]	42	# anyone got a better name? :P
	43	my $thingroot = $ENV{SCRIPT_FILENAME};
	44	$thingroot =~ s\|cgi-bin/main.cgi\|\|;
	45
[402]	46	syslog "debug", "$authuser active, $ENV{'REMOTE_ADDR'}";
[4]	47
[517]	48	##fixme there must be a better order to do things in so this can go back where it was
	49	# CGI fiddling done here so we can declare %webvar so we can alter $webvar{action}
	50	# to show the right page on DB errors.
	51	# Set up the CGI object...
	52	my $q = new CGI::Simple;
	53	# ... and get query-string params as well as POST params if necessary
	54	$q->parse_query_string;
	55
	56	# Convenience; saves changing all references to %webvar
	57	##fixme: tweak for handling <select multiple='y' size=3> (list with multiple selection)
	58	my %webvar = $q->Vars;
	59
[106]	60	# Why not a global DB handle? (And a global statement handle, as well...)
	61	# Use the connectDB function, otherwise we end up confusing ourselves
	62	my $ip_dbh;
	63	my $errstr;
[142]	64	($ip_dbh,$errstr) = connectDB_My;
[106]	65	if (!$ip_dbh) {
[517]	66	$webvar{action} = "dberr";
	67	} else {
	68	initIPDBGlobals($ip_dbh);
[106]	69	}
[4]	70
[517]	71	# Set up some globals
[793]	72	$ENV{HTML_TEMPLATE_ROOT} = $thingroot;
	73	my @templatepath = [ "localtemplates", "templates" ];
[233]	74
[793]	75	my $header = HTML::Template->new(filename => "header.tmpl", path => @templatepath);
	76	my $footer = HTML::Template->new(filename => "footer.tmpl", path => @templatepath);
	77	my $utilbar = HTML::Template->new(filename => "utilbar.tmpl", loop_context_vars => 1, global_vars => 1,
	78	path => @templatepath);
[233]	79
[697]	80	print "Content-type: text/html\n\n";
	81
[517]	82	$header->param(version => $IPDB::VERSION);
	83	$header->param(addperm => $IPDBacl{$authuser} =~ /a/);
	84	$header->param(webpath => $IPDB::webpath);
[4]	85
[697]	86	$utilbar->param(webpath => $IPDB::webpath);
[4]	87
[697]	88	print $header->output;
	89
[760]	90	##fixme: whine and complain when the user is not present in the ACL hash above
[697]	91
[4]	92	#main()
[517]	93	my $aclerr;
[4]	94
	95	if(!defined($webvar{action})) {
[517]	96	$webvar{action} = "index"; #shuts up the warnings.
[4]	97	}
	98
[517]	99	my $page;
[793]	100	if (-e "$ENV{HTML_TEMPLATE_ROOT}/templates/$webvar{action}.tmpl") {
	101	$page = HTML::Template->new(filename => "$webvar{action}.tmpl", loop_context_vars => 1, global_vars => 1,
	102	path => @templatepath);
[517]	103	} else {
[793]	104	$page = HTML::Template->new(filename => "dunno.tmpl", die_on_bad_params => 0,
	105	path => @templatepath);
[517]	106	}
	107
[4]	108	if($webvar{action} eq 'index') {
	109	showSummary();
[808]	110	} elsif ($webvar{action} eq 'showvrf') {
	111	showVRF();
[810]	112
	113	} elsif ($webvar{action} eq 'addvrf') {
	114	if ($IPDBacl{$authuser} !~ /s/) {
	115	$aclerr = 'addvrf';
	116	}
	117
	118	# Retrieve the list of DNS locations if we've got a place to grab them from
	119	if ($IPDB::rpc_url) {
	120	my %rpcargs = (
	121	rpcuser => $authuser,
	122	group => 1, # bleh
	123	defloc => '',
	124	);
	125	my $result = IPDB::_rpc('getLocDropdown', %rpcargs);
	126	$page->param(loclist => $result);
	127	}
	128
[811]	129	} elsif ($webvar{action} eq 'newvrf') {
	130	if ($IPDBacl{$authuser} !~ /s/) {
	131	$aclerr = 'addvrf';
	132	} else {
	133	my ($code,$msg) = addVRF($ip_dbh, $webvar{vrf}, comment => $webvar{comment}, location => $webvar{loc});
	134
	135	if ($code eq 'FAIL') {
	136	syslog "err", "Could not add VRF '$webvar{vrf}' to database: '$msg'";
	137	$page->param(err => $msg);
	138	$page->param(vrf => $webvar{vrf});
	139	} else {
	140	$page->param(vrf => $msg);
	141	if ($code eq 'WARN') {
	142	$IPDB::errstr =~ s/\n\n/<br>\n/g;
	143	$IPDB::errstr =~ s/:\n/:<br>\n/g;
	144	$page->param(warn => $IPDB::errstr);
	145	}
	146	syslog "info", "$authuser added VRF $webvar{vrf}";
	147	}
	148
	149	} # ACL check
	150
[820]	151	} elsif ($webvar{action} eq 'delvrf') {
	152	if ($IPDBacl{$authuser} !~ /s/) {
	153	$aclerr = 'delvrf';
	154	}
	155
	156	my $vrf = getVRF($ip_dbh, $webvar{vrf});
	157
	158	$page->param(vrf => $webvar{vrf});
	159	$page->param(vrfcomment => $vrf->{comment});
	160
	161	} elsif ($webvar{action} eq 'finaldelvrf') {
	162	if ($IPDBacl{$authuser} !~ /s/) {
	163	$aclerr = 'finaldelvrf';
	164	}
	165
	166	my $vrf = getVRF($ip_dbh, $webvar{vrf});
	167	$page->param(vrf => $webvar{vrf});
	168	$page->param(vrfcomment => $vrf->{comment});
	169
	170	my ($code,$msg) = deleteVRF($ip_dbh, $webvar{vrf}, $authuser);
	171
	172	if ($code eq 'FAIL') {
	173	$page->param(failmsg => $msg);
	174	}
	175
[233]	176	} elsif ($webvar{action} eq 'addmaster') {
	177	if ($IPDBacl{$authuser} !~ /a/) {
[517]	178	$aclerr = 'addmaster';
[233]	179	}
[582]	180
[816]	181	my $vrf = getVRF($ip_dbh, $webvar{vrf});
	182
[582]	183	# Retrieve the list of DNS locations if we've got a place to grab them from
	184	if ($IPDB::rpc_url) {
	185	my %rpcargs = (
	186	rpcuser => $authuser,
	187	group => 1, # bleh
[816]	188	defloc => $vrf->{location},
[582]	189	);
[623]	190	my $result = IPDB::_rpc('getLocDropdown', %rpcargs);
[582]	191	$page->param(loclist => $result);
	192	}
	193
[815]	194	# we don't have a netblock; pass 0 for the block ID
	195	# Tree navigation
	196	my $crumbs = getBreadCrumbs($ip_dbh, 0, $webvar{vrf});
	197	my @rcrumbs = reverse (@$crumbs);
	198	$utilbar->param(breadcrumb => \@rcrumbs);
	199
	200	$page->param(vrf => $webvar{vrf});
	201
[4]	202	} elsif ($webvar{action} eq 'newmaster') {
	203
[233]	204	if ($IPDBacl{$authuser} !~ /a/) {
[517]	205	$aclerr = 'addmaster';
[233]	206	} else {
	207	my $cidr = new NetAddr::IP $webvar{cidr};
[517]	208	$page->param(cidr => "$cidr");
[4]	209
[582]	210	my ($code,$msg) = addMaster($ip_dbh, $webvar{cidr}, (vrf => $webvar{vrf}, rdns => $webvar{rdns},
	211	rwhois => $webvar{rwhois}, defloc => $webvar{loc}, user => $authuser) );
[4]	212
[371]	213	if ($code eq 'FAIL') {
[320]	214	syslog "err", "Could not add master block '$webvar{cidr}' to database: '$msg'";
[517]	215	$page->param(err => $msg);
[233]	216	} else {
[624]	217	$page->param(parent => $msg);
[582]	218	if ($code eq 'WARN') {
[624]	219	$IPDB::errstr =~ s/\n\n/<br>\n/g;
	220	$IPDB::errstr =~ s/:\n/:<br>\n/g;
	221	$page->param(warn => $IPDB::errstr);
[582]	222	}
[233]	223	syslog "info", "$authuser added master block $webvar{cidr}";
	224	}
[4]	225
[815]	226	# we don't have a netblock; pass 0 for the block ID
	227	# Tree navigation
	228	my $crumbs = getBreadCrumbs($ip_dbh, 0, $webvar{vrf});
	229	my @rcrumbs = reverse (@$crumbs);
	230	$utilbar->param(breadcrumb => \@rcrumbs);
	231
[233]	232	} # ACL check
	233
[4]	234	} # end add new master
	235
[567]	236	elsif ($webvar{action} eq 'showsubs') {
	237	showSubs();
	238	}
	239
[4]	240	elsif($webvar{action} eq 'listpool') {
[528]	241	showPool();
[4]	242	}
	243
	244	# Not modified or added; just shuffled
	245	elsif($webvar{action} eq 'assign') {
	246	assignBlock();
	247	}
	248	elsif($webvar{action} eq 'confirm') {
	249	confirmAssign();
	250	}
	251	elsif($webvar{action} eq 'insert') {
	252	insertAssign();
	253	}
	254	elsif($webvar{action} eq 'edit') {
	255	edit();
	256	}
	257	elsif($webvar{action} eq 'update') {
	258	update();
	259	}
[702]	260	elsif($webvar{action} eq 'split') {
	261	prepSplit();
	262	}
	263	elsif($webvar{action} eq 'dosplit') {
	264	doSplit();
	265	}
[717]	266	elsif($webvar{action} eq 'merge') {
	267	prepMerge();
	268	}
[720]	269	elsif($webvar{action} eq 'confmerge') {
	270	confMerge();
	271	}
[751]	272	elsif($webvar{action} eq 'domerge') {
	273	doMerge();
	274	}
[4]	275	elsif($webvar{action} eq 'delete') {
	276	remove();
	277	}
	278	elsif($webvar{action} eq 'finaldelete') {
	279	finalDelete();
	280	}
[397]	281	elsif ($webvar{action} eq 'nodesearch') {
[519]	282	my $nodelist = getNodeList($ip_dbh);
	283	$page->param(nodelist => $nodelist);
[517]	284	}
[397]	285
[517]	286	# DB failure. Can't do much here, really.
	287	elsif ($webvar{action} eq 'dberr') {
	288	$page->param(errmsg => $errstr);
[397]	289	}
	290
[517]	291	# Default is an error. It shouldn't be possible to get here unless you're
	292	# randomly feeding in values for webvar{action}.
[4]	293	else {
	294	my $rnd = rand 500;
	295	my $boing = sprintf("%.2f", rand 500);
[517]	296	my @excuses = (
	297	"Aether cloudy. Ask again later about $webvar{action}.",
	298	"The gods are unhappy with your sacrificial $webvar{action}.",
	299	"Because one of $webvar{action}'s legs are both the same",
	300	"<b>wibble</b><br>Can't $webvar{action}, the grue will get me!<br>Can't $webvar{action}, the grue will get me!",
	301	"Hey, man, you've had your free $webvar{action}. Next one's gonna... <i>cost</i>....",
	302	"I ain't done $webvar{action}",
	303	"Oooo, look! A flying $webvar{action}!",
	304	"$webvar{action} too evil, avoiding.",
	305	"Rocks fall, $webvar{action} dies.",
	306	"Bit bucket must be emptied before I can $webvar{action}..."
	307	);
	308	$page->param(dunno => $excuses[$rnd/50.0]);
[4]	309	}
[111]	310	## Finally! Done with that NASTY "case" emulation!
[4]	311
	312
[517]	313	# Switch to a different template if we've tripped on an ACL error.
	314	# Note that this should only be exercised in development, when
	315	# deeplinked, or when being attacked; normal ACL handling should
	316	# remove the links a user is not allowed to click on.
	317	if ($aclerr) {
[793]	318	$page = HTML::Template->new(filename => "aclerror.tmpl", path => @templatepath);
[517]	319	$page->param(ipdbfunc => $aclmsg{$aclerr});
	320	}
[4]	321
[106]	322	# Clean up IPDB globals, DB handle, etc.
[111]	323	finish($ip_dbh);
[199]	324
[517]	325	## Do all our printing here so we can generate errors and stick them into the slots in the templates.
[199]	326
[517]	327	# can't do this yet, too many blowups
	328	#print "Content-type: text/html\n\n", $header->output;
	329	$page->param(webpath => $IPDB::webpath);
[697]	330	print $utilbar->output;
[517]	331	print $page->output;
	332
	333	# include the admin tools link in the output?
	334	$footer->param(adminlink => ($IPDBacl{$authuser} =~ /A/));
	335	$footer->param(webpath => $IPDB::webpath);
	336	print $footer->output;
	337
[106]	338	# Just in case something waaaayyy down isn't in place
	339	# properly... we exit explicitly.
[517]	340	exit 0;
[4]	341
	342
[806]	343	# Initial display: Show list of VRFs
[118]	344	sub showSummary {
[806]	345	my $vrflist = listVRF($ip_dbh);
[818]	346
	347	if ($IPDB::masterswithvrfs == 2) {
	348	$page = HTML::Template->new(filename => "index2.tmpl", loop_context_vars => 1, global_vars => 1,
	349	path => @templatepath);
	350	# alternate layout; put master blocks on the front summary page instead of "out"/"down" a
[821]	351	# layer in the browse tree. Leaving the manual include of showvrf.tmpl for reference; not
	352	# sure why setting webpath here didn't seem to make it to the output.
	353	# my $vrfinfo = HTML::Template->new(filename => "showvrf.tmpl", path => @templatepath);
[818]	354	foreach my $vrf (@$vrflist) {
	355	my $masterlist = listSummary($ip_dbh, $vrf->{vrf});
[821]	356	$vrf->{masterlist} = $masterlist;
	357	$vrf->{addmaster} = ($IPDBacl{$authuser} =~ /s/);
	358	$vrf->{maydel} = ($IPDBacl{$authuser} =~ /s/);
	359	$vrf->{sub} = 1;
	360	# $vrfinfo->param(vrf => $vrf->{vrf});
	361	# $vrfinfo->param(masterlist => $masterlist);
	362	# $vrfinfo->param(addmaster => ($IPDBacl{$authuser} =~ /s/) );
	363	# $vrfinfo->param(maydel => ($IPDBacl{$authuser} =~ /s/) );
	364	# $vrfinfo->param(sub => 1);
	365	# $vrfinfo->param(webpath => $IPDB::webpath);
	366	# $vrf->{vrfinfo} = $vrfinfo->output;
[818]	367	}
	368	}
	369
[806]	370	$page->param(vrflist => $vrflist);
[106]	371
[806]	372	# Only systems/network should be allowed to add VRFs - or maybe higher?
	373	$page->param(addvrf => ($IPDBacl{$authuser} =~ /s/) );
[818]	374
[4]	375	} # showSummary
	376
	377
[808]	378	# Show IP blocks in a VRF
	379	sub showVRF {
	380	my $masterlist = listSummary($ip_dbh, $webvar{vrf});
	381	$page->param(vrf => $webvar{vrf});
	382	$page->param(masterlist => $masterlist);
	383
	384	# we don't have a netblock; pass 0 for the block ID
	385	# Tree navigation
	386	my $crumbs = getBreadCrumbs($ip_dbh, 0, $webvar{vrf});
	387	my @rcrumbs = reverse (@$crumbs);
	388	$utilbar->param(breadcrumb => \@rcrumbs);
	389
[818]	390	$page->param(maydel => ($IPDBacl{$authuser} =~ /s/) );
[808]	391	$page->param(addmaster => ($IPDBacl{$authuser} =~ /s/) );
	392	} # showVRF
	393
	394
[566]	395	# Display blocks immediately within a given parent
	396	sub showSubs {
[682]	397	# Which layout?
	398	if ($IPDB::sublistlayout == 2) {
	399
	400	# 2-part layout; mixed containers and end-use allocations and free blocks.
	401	# Containers have a second line for the subblock metadata.
	402	# We need to load an alternate template for this case.
[793]	403	$page = HTML::Template->new(filename => "showsubs2.tmpl", loop_context_vars => 1, global_vars => 1,
	404	path => @templatepath);
[682]	405
	406	$page->param(maydel => ($IPDBacl{$authuser} =~ /d/));
	407
	408	my $sublist = listSubs($ip_dbh, parent => $webvar{parent});
	409	$page->param(sublist => $sublist);
	410
	411	} else {
	412
[685]	413	# 3-part layout; containers, end-use allocations, and free blocks
[682]	414
	415	my $contlist = listContainers($ip_dbh, parent => $webvar{parent});
	416	$page->param(contlist => $contlist);
	417
	418	my $alloclist = listAllocations($ip_dbh, parent => $webvar{parent});
	419	$page->param(alloclist => $alloclist);
	420
	421	# only show "delete" button if we have no container or usage allocations
	422	$page->param(maydel => ($IPDBacl{$authuser} =~ /d/) && !(@$contlist \|\| @$alloclist));
	423
	424	}
	425
	426	# Common elements
[627]	427	my $pinfo = getBlockData($ip_dbh, $webvar{parent});
	428
[685]	429	##fixme: do we add a wrapper to not show the edit link for master blocks?
	430	#$page->param(editme => 1) unless $pinfo->{type} ne 'mm';
	431
[808]	432	my $crumbs = getBreadCrumbs($ip_dbh, $pinfo->{parent_id}, $pinfo->{vrf});
[697]	433	my @rcrumbs = reverse (@$crumbs);
	434	$utilbar->param(breadcrumb => \@rcrumbs);
	435
[685]	436	$page->param(self_id => $webvar{parent});
[627]	437	$page->param(block => $pinfo->{block});
[566]	438	$page->param(mayadd => ($IPDBacl{$authuser} =~ /a/));
[4]	439
[627]	440	my $flist = listFree($ip_dbh, parent => $webvar{parent});
[566]	441	$page->param(freelist => $flist);
	442	} # showSubs
[4]	443
	444
	445	# List the IPs used in a pool
[528]	446	sub showPool {
[4]	447
[631]	448	my $poolinfo = getBlockData($ip_dbh, $webvar{pool});
	449	my $cidr = new NetAddr::IP $poolinfo->{block};
[771]	450	$page->param(vlan => $poolinfo->{vlan});
[4]	451
[697]	452	# Tree navigation
	453	my $crumbs = getBreadCrumbs($ip_dbh, $poolinfo->{parent_id});
	454	my @rcrumbs = reverse (@$crumbs);
	455	$utilbar->param(breadcrumb => \@rcrumbs);
	456
[631]	457	$page->param(block => $cidr);
[517]	458	$page->param(netip => $cidr->addr);
	459	$cidr++;
	460	$page->param(gate => $cidr->addr);
	461	$cidr--; $cidr--;
	462	$page->param(bcast => $cidr->addr);
	463	$page->param(mask => $cidr->mask);
[157]	464
[528]	465	$page->param(disptype => $disp_alloctypes{$poolinfo->{type}});
	466	$page->param(city => $poolinfo->{city});
[517]	467
[157]	468	# Only display net/gw/bcast if it's a "real" netblock and not a PPP(oE) lunacy
[528]	469	$page->param(realblock => $poolinfo->{type} =~ /^.d$/);
[4]	470
	471	# probably have to add an "edit IP allocation" link here somewhere.
	472
[855]	473	# this will cascade into the IP list below
	474	$page->param(maydel => $IPDBacl{$authuser} =~ /d/);
	475
[866]	476	my $plist = listPool($ip_dbh, $webvar{pool}, 1);
[528]	477	$page->param(poolips => $plist);
	478	} # end showPool
[4]	479
	480
[106]	481	# Show "Add new allocation" page. Note that the actual page may
	482	# be one of two templates, and the lists come from the database.
[4]	483	sub assignBlock {
	484
[233]	485	if ($IPDBacl{$authuser} !~ /a/) {
[517]	486	$aclerr = 'addblock';
[233]	487	return;
	488	}
	489
[517]	490	# hack pthbttt eww
[633]	491	$webvar{parent} = 0 if !$webvar{parent};
[517]	492	$webvar{block} = '' if !$webvar{block};
[21]	493
[575]	494	$page->param(allocfrom => $webvar{block}); # fb-assign flag, if block is set, we're in fb-assign
[517]	495
[633]	496	if ($webvar{fbid} \|\| $webvar{fbtype}) {
[575]	497
	498	# Common case, according to reported usage. Block to assign is specified.
[21]	499	my $block = new NetAddr::IP $webvar{block};
[187]	500
[675]	501	my ($rdns,$cached) = getBlockRDNS($ip_dbh, id => $webvar{parent}, type => $webvar{fbtype}, user => $authuser);
[585]	502	$page->param(rdns => $rdns) if $rdns;
[633]	503	$page->param(parent => $webvar{parent});
	504	$page->param(fbid => $webvar{fbid});
[675]	505	# visual flag that we're working IPDB-local, not off more authoritative data in dnsadmin
	506	$page->param(cached => $cached);
[585]	507
[691]	508	my $pinfo = getBlockData($ip_dbh, $webvar{parent});
	509
[697]	510	# Tree navigation
	511	my $crumbs = getBreadCrumbs($ip_dbh, $webvar{parent});
	512	my @rcrumbs = reverse (@$crumbs);
	513	$utilbar->param(breadcrumb => \@rcrumbs);
	514
[575]	515	$webvar{fbtype} = '' if !$webvar{fbtype};
	516	if ($webvar{fbtype} eq 'i') {
[633]	517	my $ipinfo = getBlockData($ip_dbh, $webvar{block}, 'i');
[575]	518	$page->param(
	519	fbip => 1,
[633]	520	block => $ipinfo->{block},
[575]	521	fbdisptype => $list_alloctypes{$ipinfo->{type}},
	522	type => $ipinfo->{type},
[633]	523	allocfrom => $pinfo->{block},
[575]	524	);
[187]	525	} else {
[529]	526	# get "primary" alloctypes, since these are all that can correctly be assigned if we're in this branch
[575]	527	my $tlist = getTypeList($ip_dbh, 'n');
[529]	528	$tlist->[0]->{sel} = 1;
[575]	529	$page->param(typelist => $tlist, block => $block);
[106]	530	}
[575]	531
[21]	532	} else {
[575]	533
	534	# Uncommon case, according to reported usage. Block to assign needs to be found based on criteria.
[541]	535	my $mlist = getMasterList($ip_dbh, 'c');
	536	$page->param(masterlist => $mlist);
[517]	537
	538	my @pops;
[633]	539	foreach my $pop (@citylist) {
[517]	540	my %row = (pop => $pop);
	541	push (@pops, \%row);
[92]	542	}
[517]	543	$page->param(pops => \@pops);
	544
[529]	545	# get all standard alloctypes
	546	my $tlist = getTypeList($ip_dbh, 'a');
	547	$tlist->[0]->{sel} = 1;
	548	$page->param(typelist => $tlist);
[21]	549	}
[517]	550
	551	my @cities;
[92]	552	foreach my $city (@citylist) {
[517]	553	my %row = (city => $city);
	554	push (@cities, \%row);
[92]	555	}
[517]	556	$page->param(citylist => \@cities);
[4]	557
[397]	558	## node hack
[530]	559	my $nlist = getNodeList($ip_dbh);
	560	$page->param(nodelist => $nlist);
[397]	561	## end node hack
	562
[782]	563	$page->param(nocling => $IPDBacl{$authuser} =~ /s/);
[284]	564
[4]	565	} # assignBlock
	566
	567
	568	# Take info on requested IP assignment and see what we can provide.
	569	sub confirmAssign {
[233]	570	if ($IPDBacl{$authuser} !~ /a/) {
[517]	571	$aclerr = 'addblock';
[233]	572	return;
	573	}
[4]	574
	575	my $cidr;
[692]	576	my $resv; # Reserved for expansion.
[4]	577	my $alloc_from;
[633]	578	my $fbid = $webvar{fbid};
	579	my $p_id = $webvar{parent};
[4]	580
	581	# Going to manually validate some items.
	582	# custid and city are automagic.
[111]	583	return if !validateInput();
[4]	584
[665]	585	# make sure this is defined
	586	$webvar{fbassign} = 'n' if !$webvar{fbassign};
	587
[4]	588	# Several different cases here.
	589	# Static IP vs netblock
	590	# + Different flavours of static IP
	591	# + Different flavours of netblock
	592
[575]	593	if ($webvar{alloctype} =~ /^.i$/ && $webvar{fbassign} ne 'y') {
[665]	594	if (!$webvar{pop}) {
	595	$page->param(err => "Please select a location/POP site to allocate from.");
	596	return;
	597	}
[532]	598	my $plist = getPoolSelect($ip_dbh, $webvar{alloctype}, $webvar{pop});
[517]	599	$page->param(staticip => 1);
[532]	600	$page->param(poollist => $plist) if $plist;
[4]	601	$cidr = "Single static IP";
[517]	602	##fixme: need to handle "no available pools"
[4]	603
	604	} else { # end show pool options
[21]	605
[533]	606	if ($webvar{fbassign} && $webvar{fbassign} eq 'y') {
[697]	607
	608	# Tree navigation
	609	my $crumbs = getBreadCrumbs($ip_dbh, $webvar{parent});
	610	my @rcrumbs = reverse (@$crumbs);
	611	$utilbar->param(breadcrumb => \@rcrumbs);
	612
[21]	613	$cidr = new NetAddr::IP $webvar{block};
[575]	614	$alloc_from = new NetAddr::IP $webvar{allocfrom};
[21]	615	$webvar{maskbits} = $cidr->masklen;
[692]	616	# Some additional checks are needed for reserving free space
	617	if ($webvar{reserve}) {
	618	if ($cidr == $alloc_from) {
	619	# We could still squirm and fiddle to try to find a way to reserve space, but the storage model for
	620	# IPDB means that all continguous free space is kept in the smallest number of strict CIDR netblocks
	621	# possible. (In theory.) If the request and the freeblock are the same, it is theoretically impossible
	622	# to reserve an equivalent-sized block either ahead or behind the requested one, because the pair
	623	# together would never be a strict CIDR block.
	624	$page->param(warning => "Can't reserve space for expansion; free block and requested allocation are the same.");
	625	delete $webvar{reserve};
	626	} else {
	627	# Find which new free block will match the reqested block.
	628	# Take the requested mask, shift by one
	629	my $tmpmask = $webvar{maskbits};
	630	$tmpmask--;
	631	# find the subnets with that mask in the selected free block
	632	my @pieces = $alloc_from->split($tmpmask);
	633	foreach my $slice (@pieces) {
	634	if ($slice->contains($cidr)) {
	635	# For the subnet that contains the requested block, split that in two,
	636	# and flag/cache the one that's not the requested block.
	637	my @bits = $slice->split($webvar{maskbits});
	638	if ($bits[0] == $cidr) {
	639	$resv = $bits[1];
	640	} else {
	641	$resv = $bits[0];
	642	}
	643	}
	644	}
	645	}
	646	} # reserve block check
	647
[21]	648	} else { # done with direct freeblocks assignment
	649
	650	if (!$webvar{maskbits}) {
[517]	651	$page->param(err => "Please specify a CIDR mask length.");
[111]	652	return;
[21]	653	}
[533]	654
	655	##fixme ick, ew, bleh. gotta handle the failure message generation better. push it into findAllocateFrom()?
	656	my $failmsg = "No suitable free block found.<br>\n";
[187]	657	if ($webvar{alloctype} eq 'rm') {
[533]	658	$failmsg .= "We do not have a free routeable block of that size.<br>\n".
	659	"You will have to either route a set of smaller netblocks or a single smaller netblock.";
[4]	660	} else {
[214]	661	if ($webvar{alloctype} =~ /^.[pc]$/) {
[533]	662	$failmsg .= "You will have to route another superblock from one of the<br>\n".
	663	"master blocks or chose a smaller block size for the pool.";
[21]	664	} else {
[517]	665	if (!$webvar{pop}) {
	666	$page->param(err => 'Please select a POP to route the block from/through.');
	667	return;
	668	}
[533]	669	$failmsg .= "You will have to route another superblock to $webvar{pop}<br>\n".
[692]	670	"from one of the master blocks";
	671	if ($webvar{reserve}) {
	672	$failmsg .= ', choose a smaller blocksize, or uncheck "Reserve space for expansion".';
	673	} else {
	674	$failmsg .= " or chose a smaller blocksize.";
	675	}
[21]	676	}
[4]	677	}
[533]	678
[692]	679	# if requesting extra space "reserved for expansion", we need to find a free
	680	# block at least double the size of the request.
	681	if ($webvar{reserve}) {
	682	$webvar{maskbits}--;
	683	}
	684
[633]	685	($fbid,$cidr,$p_id) = findAllocateFrom($ip_dbh, $webvar{maskbits}, $webvar{alloctype},
	686	$webvar{city}, $webvar{pop}, (master => $webvar{allocfrom}, allowpriv => $webvar{allowpriv}) );
[533]	687	if (!$cidr) {
[517]	688	$page->param(err => $failmsg);
[111]	689	return;
[21]	690	}
[533]	691	$cidr = new NetAddr::IP $cidr;
[575]	692
	693	$alloc_from = "$cidr";
[692]	694
	695	# when autofinding a block to allocate from, use the first piece of the found
	696	# block for the allocation, and the next piece for the "reserved for expansion".
	697	if ($webvar{reserve}) {
	698	# reset the mask to the real requested one, now that we've got a
	699	# block large enough for the request plus reserve
	700	$webvar{maskbits}++;
	701	($cidr,$resv) = $cidr->split($webvar{maskbits});
	702	}
	703
[575]	704	# If the block to be allocated is smaller than the one we found,
	705	# figure out the "real" block to be allocated.
	706	if ($cidr->masklen() ne $webvar{maskbits}) {
	707	my $maskbits = $cidr->masklen();
	708	my @subblocks;
	709	while ($maskbits++ < $webvar{maskbits}) {
	710	@subblocks = $cidr->split($maskbits);
	711	}
	712	$cidr = $subblocks[0];
	713	}
[21]	714	} # check for freeblocks assignment or IPDB-controlled assignment
[4]	715
[674]	716	# Generate the IP list for the new allocation in case someone wants to set per-IP rDNS right away.
	717	# We don't do this on the previous page because we don't know how big a block or even what IP range
	718	# it's for (if following the "normal" allocation process)
	719	if ($IPDBacl{$authuser} =~ /c/
	720	&& $cidr->masklen != $cidr->bits
[780]	721	&& ($cidr->bits - $cidr->masklen) <= $IPDB::maxrevlist
	722	# config flag for "all block types" OR "not-a-pool-or-IP type"
	723	&& ($IPDB::revlistalltypes \|\| $webvar{alloctype} !~ /^.[dpi]/)
	724	# safety against trying to retrieve and display more than 1k (10 bits, /22 v4) worth of individual IPs
	725	# ever. If you really need to manage a long list of IPs like that all in one place, you can use the DNS
	726	# management tool. Even a /26 is a bit much, really.
	727	&& ($cidr->bits - $cidr->masklen) <= 10
[674]	728	# do we want to allow v6 at all?
	729	#&& ! $cidr->{isv6}
	730	) {
	731	my @list;
	732	foreach my $ip (@{$cidr->splitref()}) {
	733	my %row;
	734	$row{r_ip} = $ip->addr;
	735	$row{iphost} = '';
	736	push @list, \%row;
	737	}
	738	$page->param(r_iplist => \@list);
	739	# We don't use this here, because these IPs should already be bare.
	740	# ... or should we be paranoid? Make it a config option?
	741	#getRDNSbyIP($ip_dbh, type => $webvar{alloctype}, range => "$cidr", user => $authuser) );
	742	}
[157]	743	} # if ($webvar{alloctype} =~ /^.i$/)
[4]	744
[397]	745	## node hack
	746	if ($webvar{node} && $webvar{node} ne '-') {
[530]	747	my $nodename = getNodeName($ip_dbh, $webvar{node});
[517]	748	$page->param(nodename => $nodename);
	749	$page->param(nodeid => $webvar{node});
[397]	750	}
	751	## end node hack
	752
[760]	753	# flag DNS info if we can't publish the entry remotely
	754	my $pinfo = getBlockData($ip_dbh, $webvar{parent});
	755	$page->param(dnslocal => 1) unless ($pinfo->{revpartial} \|\| $pinfo->{revavail});
	756
[692]	757	# reserve for expansion
	758	$page->param(reserve => $webvar{reserve});
	759	# probably just preventing a little log noise doing this; could just set the param
	760	# all the time since it won't be shown if the reserve param above isn't set.
	761	# if ($webvar{reserve}) {
	762	$page->param(resvblock => $resv);
	763	# }
	764
[4]	765	# Stick in the allocation data
[517]	766	$page->param(alloc_type => $webvar{alloctype});
	767	$page->param(typefull => $q->escapeHTML($disp_alloctypes{$webvar{alloctype}}));
	768	$page->param(alloc_from => $alloc_from);
[633]	769	$page->param(parent => $p_id);
	770	$page->param(fbid => $fbid);
[517]	771	$page->param(cidr => $cidr);
[585]	772	$page->param(rdns => $webvar{rdns});
[691]	773	$page->param(vrf => $webvar{vrf});
	774	$page->param(vlan => $webvar{vlan});
[517]	775	$page->param(city => $q->escapeHTML($webvar{city}));
	776	$page->param(custid => $webvar{custid});
	777	$page->param(circid => $q->escapeHTML($webvar{circid}));
	778	$page->param(desc => $q->escapeHTML($webvar{desc}));
[4]	779
[517]	780	##fixme: find a way to have the displayed copy have <br> substitutions
	781	# for newlines, and the <input> value have either encoded or bare newlines.
	782	# Also applies to privdata.
	783	$page->param(notes => $q->escapeHTML($webvar{notes},'y'));
	784
[284]	785	# Check to see if user is allowed to do anything with sensitive data
[800]	786	if ($IPDBacl{$authuser} =~ /s/) {
[782]	787	$page->param(nocling => 1);
	788	$page->param(privdata => $q->escapeHTML($webvar{privdata},'y'));
[517]	789
[782]	790	$page->param(backupfields => $webvar{backupfields});
	791	$page->param(bkbrand => $webvar{bkbrand});
	792	$page->param(bkmodel => $webvar{bkmodel});
	793	$page->param(bktype => $webvar{bktype});
	794	$page->param(bksrc => $webvar{bksrc});
	795	$page->param(bkuser => $webvar{bkuser});
	796	# these two could use virtually any character
	797	$page->param(bkvpass => $q->escapeHTML($webvar{bkvpass}));
	798	$page->param(bkepass => $q->escapeHTML($webvar{bkepass}));
	799	$page->param(bkport => $webvar{bkport});
[798]	800	$page->param(bkip => $webvar{bkip});
[782]	801	}
	802
[517]	803	# Yay! This now has it's very own little home.
	804	$page->param(billinguser => $webvar{userid})
[299]	805	if $webvar{userid};
[284]	806
[835]	807	syslog "debug", "billinguser used ($authuser): alloc_from $alloc_from, type $webvar{alloctype}" if $webvar{userid};
	808
[517]	809	##fixme: this is only needed iff confirm.tmpl and
	810	# confirmRemove.tmpl are merged (quite possible, just
	811	# a little tedious)
	812	$page->param(action => "insert");
[284]	813
[4]	814	} # end confirmAssign
	815
	816
	817	# Do the work of actually inserting a block in the database.
	818	sub insertAssign {
[233]	819	if ($IPDBacl{$authuser} !~ /a/) {
[517]	820	$aclerr = 'addblock';
[233]	821	return;
	822	}
[4]	823	# Some things are done more than once.
[111]	824	return if !validateInput();
[4]	825
[782]	826	##fixme: permission check
[284]	827	if (!defined($webvar{privdata})) {
	828	$webvar{privdata} = '';
	829	}
[575]	830
[106]	831	# $code is "success" vs "failure", $msg contains OK for a
	832	# successful netblock allocation, the IP allocated for static
	833	# IP, or the error message if an error occurred.
[517]	834
[677]	835	##fixme: consider just passing \%webvar to allocateBlock()?
	836	# collect per-IP rDNS fields. only copy over the ones that actually have something in them.
	837	my %iprev;
	838	foreach (keys %webvar) {
	839	$iprev{$_} = $webvar{$_} if /host_[\d.a-fA-F:]+/ && $webvar{$_};
	840	}
	841
[691]	842	# Easier to see and cosmetically fiddle the list like this
	843	my %insert_args = (
	844	cidr => $webvar{fullcidr},
	845	fbid => $webvar{fbid},
[692]	846	reserve => $webvar{reserve},
[691]	847	parent => $webvar{parent},
	848	custid => $webvar{custid},
	849	type => $webvar{alloctype},
	850	city => $webvar{city},
	851	desc => $webvar{desc},
	852	notes => $webvar{notes},
	853	circid => $webvar{circid},
	854	privdata => $webvar{privdata},
	855	nodeid => $webvar{node},
	856	rdns => $webvar{rdns},
	857	vrf => $webvar{vrf},
	858	vlan => $webvar{vlan},
	859	user => $authuser,
	860	);
[4]	861
[782]	862	##fixme: permission check
	863	# fill in backup data, if present/allowed
	864	if ($webvar{backupfields}) {
	865	$insert_args{backup} = 1;
[798]	866	for my $bkfield (@IPDB::backupfields) {
[782]	867	$insert_args{"bk$bkfield"} = ($webvar{"bk$bkfield"} ? $webvar{"bk$bkfield"} : '');
	868	}
	869	}
	870
[766]	871	my $pinfo = getBlockData($ip_dbh, $webvar{parent});
	872
	873	# clean up a minor mess with guided allocation of static IPs
	874	if ($webvar{alloctype} =~ /^.i$/) {
	875	$insert_args{alloc_from} = $pinfo->{block};
	876	}
	877
[691]	878	my ($code,$msg) = allocateBlock($ip_dbh, %insert_args, iprev => \%iprev);
	879
[111]	880	if ($code eq 'OK') {
[766]	881	# breadcrumbs lite! provide at least a link to the parent of the block we just allocated.
	882	$page->param(parentid => $webvar{parent});
	883	$page->param(parentblock => $pinfo->{block});
	884
[106]	885	if ($webvar{alloctype} =~ /^.i$/) {
[300]	886	$msg =~ s\|/32\|\|;
[517]	887	$page->param(staticip => $msg);
	888	$page->param(custid => $webvar{custid});
	889	$page->param(billinguser => $webvar{billinguser});
[839]	890	$page->param(billinglink => $IPDB::billinglink);
[416]	891	mailNotify($ip_dbh, "a$webvar{alloctype}", "ADDED: $disp_alloctypes{$webvar{alloctype}} allocation",
	892	"$disp_alloctypes{$webvar{alloctype}} $msg allocated to customer $webvar{custid}\n".
	893	"Description: $webvar{desc}\n\nAllocated by: $authuser\n");
[106]	894	} else {
[301]	895	my $netblock = new NetAddr::IP $webvar{fullcidr};
[517]	896	$page->param(fullcidr => $webvar{fullcidr});
	897	$page->param(alloctype => $disp_alloctypes{$webvar{alloctype}});
	898	$page->param(custid => $webvar{custid});
[697]	899
	900	# Full breadcrumbs
	901	my $crumbs = getBreadCrumbs($ip_dbh, $webvar{parent});
	902	my @rcrumbs = reverse (@$crumbs);
	903	$utilbar->param(breadcrumb => \@rcrumbs);
	904
[517]	905	if ($webvar{alloctype} eq 'pr' && $webvar{billinguser}) {
	906	$page->param(billinguser => $webvar{billinguser});
[839]	907	$page->param(billinglink => $IPDB::billinglink);
[517]	908	$page->param(custid => $webvar{custid});
	909	$page->param(netaddr => $netblock->addr);
	910	$page->param(masklen => $netblock->masklen);
	911	}
[835]	912	syslog "debug", "billinguser used ($authuser): allocated $netblock, type $webvar{alloctype}" if $webvar{billinguser};
[416]	913	mailNotify($ip_dbh, "a$webvar{alloctype}", "ADDED: $disp_alloctypes{$webvar{alloctype}} allocation",
	914	"$disp_alloctypes{$webvar{alloctype}} $webvar{fullcidr} allocated to customer $webvar{custid}\n".
	915	"Description: $webvar{desc}\n\nAllocated by: $authuser\n");
[4]	916	}
[106]	917	syslog "notice", "$authuser allocated '$webvar{fullcidr}' to '$webvar{custid}' as ".
[256]	918	"'$webvar{alloctype}' ($msg)";
[111]	919	} else {
	920	syslog "err", "Allocation of '$webvar{fullcidr}' to '$webvar{custid}' as ".
	921	"'$webvar{alloctype}' by $authuser failed: '$msg'";
[766]	922	$page->param(err => "Allocation of $webvar{fullcidr} as '$disp_alloctypes{$webvar{alloctype}}' failed:");
	923	$page->param(errmsg => $msg);
[106]	924	}
[4]	925
	926	} # end insertAssign()
	927
	928
	929	# Does some basic checks on common input data to make sure nothing
	930	# really weird gets in to the database through this script.
	931	# Does NOT do complete input validation!!!
	932	sub validateInput {
	933	if ($webvar{city} eq '-') {
[517]	934	$page->param(err => 'Please choose a city');
[111]	935	return;
[4]	936	}
[138]	937
	938	# Alloctype check.
[4]	939	chomp $webvar{alloctype};
[138]	940	if (!grep /$webvar{alloctype}/, keys %disp_alloctypes) {
	941	# Danger! Danger! alloctype should ALWAYS be set by a dropdown. Anyone
	942	# managing to call things in such a way as to cause this deserves a cryptic error.
[517]	943	$page->param(err => 'Invalid alloctype');
[138]	944	return;
	945	}
	946
	947	# CustID check
[4]	948	# We have different handling for customer allocations and "internal" or "our" allocations
[214]	949	if ($def_custids{$webvar{alloctype}} eq '') {
[4]	950	if (!$webvar{custid}) {
[517]	951	$page->param(err => 'Please enter a customer ID.');
[111]	952	return;
[4]	953	}
[546]	954	# Crosscheck with billing.
	955	my $status = CustIDCK->custid_exist($webvar{custid});
	956	if ($CustIDCK::Error) {
	957	$page->param(err => "Error verifying customer ID: ".$CustIDCK::ErrMsg);
	958	return;
[4]	959	}
[546]	960	if (!$status) {
	961	$page->param(err => "Customer ID not valid. Make sure the Customer ID ".
	962	"is correct.<br>\nUse STAFF for staff static IPs, and $IPDB::defcustid for any other ".
	963	"non-customer assignments.");
	964	return;
	965	}
[400]	966	# print "<!-- [ In validateInput(). Insert customer ID cross-check here. ] -->\n";
[138]	967	} else {
[167]	968	# New! Improved! And now Loaded From The Database!!
[320]	969	if ((!$webvar{custid}) \|\| ($webvar{custid} ne 'STAFF')) {
	970	$webvar{custid} = $def_custids{$webvar{alloctype}};
	971	}
[4]	972	}
[111]	973
[571]	974	## hmmm.... is this even useful?
	975	if (0) {
[111]	976	# Check POP location
	977	my $flag;
[187]	978	if ($webvar{alloctype} eq 'rm') {
[111]	979	$flag = 'for a routed netblock';
	980	foreach (@poplist) {
	981	if (/^$webvar{city}$/) {
	982	$flag = 'n';
	983	last;
	984	}
	985	}
	986	} else {
	987	$flag = 'n';
[442]	988	##fixme: hook to force-set POP or city on certain alloctypes
	989	# if ($webvar{alloctype =~ /foo,bar,bz/ { $webvar{pop} = 'blah'; }
[536]	990	if ($webvar{pop} && $webvar{pop} =~ /^-$/) {
[111]	991	$flag = 'to route the block from/through';
	992	}
	993	}
[517]	994
	995	# if the alloctype has a restricted city/POP list as determined above,
	996	# and the reqested city/POP does not match that list, complain
[111]	997	if ($flag ne 'n') {
[517]	998	$page->param(err => "Please choose a valid POP location $flag. Valid ".
[111]	999	"POP locations are currently:<br>\n".join (" - ", @poplist));
	1000	return;
	1001	}
[571]	1002	}
[111]	1003
[691]	1004	# VRF. Not a full validity check, just a basic sanity check.
	1005	if ($webvar{vrf}) {
	1006	# Trim leading and trailing whitespace first
	1007	$webvar{vrf} =~ s/^\s+//;
	1008	$webvar{vrf} =~ s/\s+$//;
	1009	if ($webvar{vrf} !~ /^[\w\d_.-]{1,32}$/) {
	1010	$page->param(err => "VRF values may only contain alphanumerics, and may not be more than 32 characters");
	1011	return;
	1012	}
	1013	}
	1014
	1015	# VLAN. Should we allow/use VLAN names, or just the numeric ID?
	1016	if ($webvar{vlan}) {
	1017	# Trim leading and trailing whitespace first
	1018	$webvar{vlan} =~ s/^\s+//;
	1019	$webvar{vlan} =~ s/\s+$//;
	1020	# ... ve make it ze configurable thingy!
	1021	if ($IPDB::numeric_vlan) {
	1022	if ($webvar{vlan} !~ /^\d+$/) {
	1023	$page->param(err => "VLANs must be numeric");
	1024	return;
	1025	}
	1026	} else {
	1027	if ($webvar{vlan} !~ /^[\w\d_.-]+$/) {
	1028	$page->param(err => "VLANs must be alphanumeric");
	1029	return;
	1030	}
	1031	}
	1032	}
	1033
[782]	1034	# Backup fields. Minimal sanity checks.
[813]	1035	# Bypass if the user isn't authorized for backup data, or if the checkbox is unchecked
	1036	if ($IPDBacl{$authuser} =~ /s/ && defined($webvar{backupfields})) {
	1037	for my $bkfield (qw(brand model)) {
	1038	if (!$webvar{"bk$bkfield"}) {
	1039	$page->param(err => "Backup $bkfield must be filled in if IP/netblock is flagged for backup");
	1040	return;
	1041	}
	1042	if ($webvar{"bk$bkfield"} !~ /^[a-zA-Z0-9\s_.-]+$/) {
	1043	$page->param(err => "Invalid characters in backup $bkfield");
	1044	return;
	1045	}
[798]	1046	}
[813]	1047	for my $bkfield (qw(type src user)) { # no spaces in these!
	1048	if ($webvar{"bk$bkfield"} && $webvar{"bk$bkfield"} !~ /^[a-zA-Z0-9_.-]+$/) {
	1049	$page->param(err => "Invalid characters in backup $bkfield");
	1050	return;
	1051	}
[782]	1052	}
[813]	1053	if ($webvar{bkport}) {
	1054	$webvar{bkport} =~ s/^\s+//g;
	1055	$webvar{bkport} =~ s/\s+$//g;
	1056	if ($webvar{bkport} !~ /^\d+$/) {
	1057	$page->param(err => "Backup port must be numeric");
	1058	return;
	1059	}
[782]	1060	}
[798]	1061	##fixme: code review: should normalize $webvar{cidr} variants so we can
	1062	# check for non-/32 allocations having the backup IP field filled in here,
	1063	# instead of failing on the allocation or update attempt
[813]	1064	if ($webvar{bkip}) {
	1065	$webvar{bkip} =~ s/^\s+//g;
	1066	$webvar{bkip} =~ s/\s+$//g;
	1067	if ($webvar{bkip} !~ /^[\da-fA-F:.]+$/) {
	1068	$page->param(err => "Backup IP must be an IP");
	1069	return;
	1070	}
[798]	1071	}
[813]	1072	} # backup
[782]	1073
[111]	1074	return 'OK';
[4]	1075	} # end validateInput
	1076
	1077
	1078	# Displays details of a specific allocation in a form
	1079	# Allows update/delete
	1080	# action=edit
	1081	sub edit {
	1082
[534]	1083	# snag block info from db
[634]	1084	my $blockinfo = getBlockData($ip_dbh, $webvar{id}, $webvar{basetype});
[750]	1085	my $cidr = new NetAddr::IP $blockinfo->{block};
[691]	1086	$page->param(id => $webvar{id});
[634]	1087	$page->param(basetype => $webvar{basetype});
[4]	1088
[697]	1089	# Tree navigation
	1090	my $crumbs = getBreadCrumbs($ip_dbh, $blockinfo->{parent_id});
	1091	my @rcrumbs = reverse (@$crumbs);
	1092	$utilbar->param(breadcrumb => \@rcrumbs);
	1093
[705]	1094	# Show link to IP list for pools
	1095	$page->param(ispool => 1) if $blockinfo->{type} =~ /^.[dp]$/;
	1096
[534]	1097	# Clean up extra whitespace on alloc type. Mainly a legacy-data cleanup.
	1098	$blockinfo->{type} =~ s/\s//;
[4]	1099
[760]	1100	##fixme: The case of "allocation larger than a /24" (or any similar case
	1101	# where the allocation is larger than the zone(s) in DNS) doesn't work well.
	1102	# Best solution may just be to add a warning that the entry shown may not be
	1103	# correct/complete.
	1104	if ($blockinfo->{revavail} \|\| $blockinfo->{revpartial}) {
	1105	$page->param(showrev => ($blockinfo->{revavail} \|\| $blockinfo->{revpartial}) );
[830]	1106	$page->param(v6 => $cidr->{isv6});
	1107	$page->param(dnslink => $IPDB::dnsadmin_url);
	1108
	1109	# get the DNSAdmin zone ID(s) for this allocation.
	1110	# Multiple zones should be rare, but are NOT impossible!
	1111	my $revlist = getRevID($ip_dbh, user => $authuser, cidr => $blockinfo->{block},
	1112	location => $blockinfo->{location});
[866]	1113	$page->param(revlist => $revlist) if $revlist;
[830]	1114
[750]	1115	my $cached;
	1116	# Get rDNS info; duplicates a bit of getBlockData but also does the RPC call if possible
	1117	($blockinfo->{rdns},$cached) = getBlockRDNS($ip_dbh, id => $webvar{id}, type => $blockinfo->{type}, user => $authuser);
[760]	1118	$page->param(rdns => $blockinfo->{rdns});
[750]	1119	# visual flag that we're working IPDB-local, not off more authoritative data in dnsadmin
	1120	$page->param(cached => $cached);
[586]	1121
[750]	1122	# Limit the per-IP rDNS list based on CIDR length; larger ones just take up too much space.
	1123	# Also, don't show on IP pools; the individual IPs will have a space for rDNS
	1124	# Don't show on single IPs; these use the "pattern" field
	1125	if ($IPDBacl{$authuser} =~ /c/
	1126	&& $cidr->masklen != $cidr->bits
	1127	&& ($cidr->bits - $cidr->masklen) <= $IPDB::maxrevlist
[780]	1128	# config flag for "all block types" OR "not-a-pool-or-IP type"
	1129	&& ($IPDB::revlistalltypes \|\| $blockinfo->{type} !~ /^.[dpi]/)
	1130	# safety against trying to retrieve and display more than 1k (10 bits, /22 v4) worth of individual IPs
	1131	# ever. If you really need to manage a long list of IPs like that all in one place, you can use the DNS
	1132	# management tool. Even a /26 is a bit much, really.
	1133	&& ($cidr->bits - $cidr->masklen) <= 10
[750]	1134	# do we want to allow v6 at all?
	1135	#&& ! $cidr->{isv6}
	1136	) {
	1137	$page->param(r_iplist => getRDNSbyIP($ip_dbh, id => $webvar{id}, type => $blockinfo->{type},
	1138	range => $blockinfo->{block}, user => $authuser) );
	1139	}
	1140	} # rDNS availability check
[675]	1141
[786]	1142	# backup data
	1143	if ($blockinfo->{hasbk}) {
	1144	$page->param(hasbackup => $blockinfo->{hasbk});
[798]	1145	for my $bkfield (@IPDB::backupfields) {
[786]	1146	$page->param("bk$bkfield" => $blockinfo->{"bk$bkfield"});
	1147	}
	1148	$page->param(bktelnet => 1) if $blockinfo->{bktype} eq 'telnet';
	1149	$page->param(bkssh => 1) if $blockinfo->{bktype} eq 'SSH';
	1150	}
	1151
[691]	1152	# consider extending this to show time as well as date
	1153	my ($lastmod,undef) = split /\s+/, $blockinfo->{lastmod};
	1154	$page->param(lastmod => $lastmod);
[4]	1155
[691]	1156	$page->param(block => $blockinfo->{block});
	1157	$page->param(city => $blockinfo->{city});
	1158	$page->param(custid => $blockinfo->{custid});
[4]	1159
[187]	1160	##fixme The check here should be built from the database
[517]	1161	# Need to expand to support pool types too
[534]	1162	if ($blockinfo->{type} =~ /^.[ne]$/ && $IPDBacl{$authuser} =~ /c/) {
[517]	1163	$page->param(changetype => 1);
	1164	$page->param(alloctype => [
[534]	1165	{ selme => ($blockinfo->{type} eq 'me'), type => "me", disptype => "Dialup netblock" },
	1166	{ selme => ($blockinfo->{type} eq 'de'), type => "de", disptype => "Dynamic DSL netblock" },
	1167	{ selme => ($blockinfo->{type} eq 'ce'), type => "ce", disptype => "Dynamic cable netblock" },
	1168	{ selme => ($blockinfo->{type} eq 'we'), type => "we", disptype => "Dynamic wireless netblock" },
	1169	{ selme => ($blockinfo->{type} eq 'cn'), type => "cn", disptype => "Customer netblock" },
	1170	{ selme => ($blockinfo->{type} eq 'en'), type => "en", disptype => "End-use netblock" },
	1171	{ selme => ($blockinfo->{type} eq 'in'), type => "in", disptype => "Internal netblock" },
[517]	1172	]
	1173	);
	1174	} else {
[534]	1175	$page->param(disptype => $disp_alloctypes{$blockinfo->{type}});
	1176	$page->param(type => $blockinfo->{type});
[517]	1177	}
	1178
[397]	1179	## node hack
[634]	1180	my ($nodeid,$nodename) = getNodeInfo($ip_dbh, $blockinfo->{block});
	1181	# $page->param(havenodeid => $nodeid);
	1182	$page->param(nodename => $nodename);
[517]	1183
	1184	##fixme: this whole hack needs cleanup and generalization for all alloctypes
	1185	##fixme: arguably a bug that presence of a nodeid implies it can be changed..
[634]	1186	if ($IPDBacl{$authuser} =~ /c/) {
	1187	my $nlist = getNodeList($ip_dbh);
	1188	if ($nodeid) {
[530]	1189	foreach (@{$nlist}) {
[634]	1190	$$_{selme} = ($$_{node_id} == $nodeid);
[397]	1191	}
	1192	}
[634]	1193	$page->param(nodelist => $nlist);
[397]	1194	}
	1195	## end node hack
[517]	1196
[834]	1197	# $page->param(vrf => $blockinfo->{vrf});
[691]	1198	$page->param(vlan => $blockinfo->{vlan});
[33]	1199
[695]	1200	# Reserved-for-expansion
	1201	$page->param(reserve => $blockinfo->{reserve});
	1202	$page->param(reserve_id => $blockinfo->{reserve_id});
	1203	my $newblock = NetAddr::IP->new($cidr->addr, $cidr->masklen - 1)->network;
	1204	$page->param(newblock => $newblock);
	1205
[517]	1206	# not happy with the upside-down logic, but...
[534]	1207	$page->param(swipable => $blockinfo->{type} !~ /.i/);
[691]	1208	$page->param(swip => $blockinfo->{swip} ne 'n') if $blockinfo->{swip};
[320]	1209
[691]	1210	$page->param(circid => $blockinfo->{circuitid});
	1211	$page->param(desc => $blockinfo->{description});
	1212	$page->param(notes => $blockinfo->{notes});
	1213
[284]	1214	# Check to see if we can display sensitive data
[691]	1215	$page->param(nocling => $IPDBacl{$authuser} =~ /s/);
[534]	1216	$page->param(privdata => $blockinfo->{privdata});
[284]	1217
[517]	1218	# ACL trickery - these two template booleans control the presence of all form/input tags
	1219	$page->param(maychange => $IPDBacl{$authuser} =~ /c/);
	1220	$page->param(maydel => $IPDBacl{$authuser} =~ /d/);
[4]	1221
[702]	1222	# Need to find internal knobs to twist to actually vary these. (Ab)use "change" flag for now
[789]	1223	$page->param(maymerge => ($IPDBacl{$authuser} =~ /m/ && $blockinfo->{type} !~ /^.i$/));
	1224
[702]	1225	if ($IPDBacl{$authuser} =~ /c/ && $blockinfo->{type} !~ /^.i$/) {
	1226	if ($blockinfo->{type} =~ /^.p$/) {
	1227	# PPP pools
	1228	$page->param(maysplit => 1) if $cidr->masklen+1 < $cidr->bits;
	1229	} elsif ($blockinfo->{type} =~ /.d/) {
	1230	# Non-PPP pools
	1231	$page->param(maysplit => 1) if $cidr->masklen+2 < $cidr->bits;
	1232	} else {
	1233	# Standard netblocks. Arguably allowing splitting these down to single IPs
	1234	# doesn't make much sense, but forcing users to apply allocation types
	1235	# "properly" is worse than herding cats.
	1236	$page->param(maysplit => 1) if $cidr->masklen < $cidr->bits;
	1237	}
	1238	}
	1239
[4]	1240	} # edit()
	1241
	1242
	1243	# Stuff new info about a block into the db
	1244	# action=update
	1245	sub update {
[284]	1246	if ($IPDBacl{$authuser} !~ /c/) {
[517]	1247	$aclerr = 'updateblock';
[284]	1248	return;
	1249	}
[4]	1250
[706]	1251	# Collect existing block info here, since we need it for the breadcrumb nav
	1252	my $binfo = getBlockData($ip_dbh, $webvar{block}, $webvar{basetype});
	1253	my $crumbs = getBreadCrumbs($ip_dbh, $binfo->{parent_id});
	1254	my @rcrumbs = reverse (@$crumbs);
	1255	$utilbar->param(breadcrumb => \@rcrumbs);
	1256
[4]	1257	# Make sure incoming data is in correct format - custID among other things.
[228]	1258	return if !validateInput;
[4]	1259
[536]	1260	$webvar{swip} = 'n' if !$webvar{swip};
	1261
[531]	1262	my %updargs = (
	1263	custid => $webvar{custid},
	1264	city => $webvar{city},
	1265	description => $webvar{desc},
	1266	notes => $webvar{notes},
	1267	circuitid => $webvar{circid},
	1268	block => $webvar{block},
	1269	type => $webvar{alloctype},
[536]	1270	swip => $webvar{swip},
[588]	1271	rdns => $webvar{rdns},
[691]	1272	vrf => $webvar{vrf},
	1273	vlan => $webvar{vlan},
[588]	1274	user => $authuser,
[531]	1275	);
	1276
[788]	1277	# Check to see if user is allowed to do anything with sensitive data
	1278	if ($IPDBacl{$authuser} =~ /s/) {
	1279	$updargs{privdata} = $webvar{privdata};
[798]	1280	for my $bkfield (@IPDB::backupfields) {
[788]	1281	$updargs{"bk$bkfield"} = $webvar{"bk$bkfield"};
	1282	}
[798]	1283	$updargs{backup} = $webvar{backupfields};
[788]	1284	} else {
	1285	# If the user doesn't have permissions to monkey with NOC-things, pass
	1286	# a flag so we don't treat it as "backup data removed"
	1287	$updargs{ignorebk} = 1;
	1288	}
	1289
[531]	1290	# Semioptional values
	1291	$updargs{node} = $webvar{node} if $webvar{node};
	1292
[677]	1293	# collect per-IP rDNS fields. only copy over the ones that actually have something in them.
	1294	my %iprev;
	1295	foreach (keys %webvar) {
	1296	$iprev{$_} = $webvar{$_} if /host_[\d.a-fA-F:]+/ && $webvar{$_};
	1297	}
[531]	1298
[830]	1299	# and now IPv6
	1300	##fixme: how to remove an entry? maybe treat empty host as "delete meeeee!"?
	1301	if ($webvar{v6list}) {
	1302	my @v6lines = split /\n/, $webvar{v6list};
	1303	foreach (@v6lines) {
	1304	s/^\s+//;
	1305	s/\s+$//;
	1306	next if /^$/;
	1307	my ($ip,$name) = split /,/;
	1308	$iprev{"host_$ip"} = $name;
	1309	}
	1310	}
	1311
[695]	1312	# Merge with reserved freeblock
	1313	$updargs{fbmerge} = $webvar{expandme} if $webvar{expandme};
	1314
[677]	1315	my ($code,$msg) = updateBlock($ip_dbh, %updargs, iprev => \%iprev);
	1316
[531]	1317	if ($code eq 'FAIL') {
[851]	1318	syslog "err", "$authuser could not update block/IP $webvar{block} ($binfo->{block}): '$msg'";
[787]	1319	$page->param(err => "Could not update block/IP $binfo->{block}: $msg");
[111]	1320	return;
[4]	1321	}
	1322
	1323	# If we get here, the operation succeeded.
[851]	1324	syslog "notice", "$authuser updated $webvar{block} ($binfo->{block})";
[531]	1325	##fixme: log details of the change? old way is in the .debug stream anyway.
[416]	1326	##fixme: need to wedge something in to allow "update:field" notifications
	1327	## hmm. how to tell what changed? O_o
[787]	1328	mailNotify($ip_dbh, 's:swi', "SWIPed: $disp_alloctypes{$webvar{alloctype}} $binfo->{block}",
	1329	"$binfo->{block} had SWIP status changed to \"Yes\" by $authuser") if $webvar{swip} eq 'on';
[4]	1330
[517]	1331	## node hack
	1332	if ($webvar{node} && $webvar{node} ne '-') {
[530]	1333	my $nodename = getNodeName($ip_dbh, $webvar{node});
[517]	1334	$page->param(nodename => $nodename);
	1335	}
	1336	## end node hack
	1337
[380]	1338	# Link back to browse-routed or list-pool page on "Update complete" page.
[634]	1339	my $pblock = getBlockData($ip_dbh, $binfo->{parent_id});
	1340	$page->param(backid => $binfo->{parent_id});
	1341	$page->param(backblock => $pblock->{block});
	1342	$page->param(backpool => ($webvar{basetype} eq 'i'));
[380]	1343
[536]	1344	# Do some HTML fiddling here instead of using ESCAPE=HTML in the template,
	1345	# because otherwise we can't convert \n to <br>. sigh
	1346	$webvar{notes} = $q->escapeHTML($webvar{notes}); # escape first...
	1347	$webvar{notes} =~ s/\n/<br>\n/; # ... then convert newlines
	1348	$webvar{privdata} = ($webvar{privdata} ? $q->escapeHTML($webvar{privdata}) : " ");
	1349	$webvar{privdata} =~ s/\n/<br>\n/;
	1350
[765]	1351	if ($webvar{expandme}) {
	1352	# this is fugly but still faster than hitting the DB again with getBlockData()
	1353	my $tmp = new NetAddr::IP $binfo->{block};
	1354	my $fb = new NetAddr::IP $binfo->{reserve};
	1355	my @newblock = $tmp->compact($fb);
	1356	$page->param(cidr => $newblock[0]);
	1357	} else {
	1358	$page->param(cidr => $binfo->{block});
	1359	}
[588]	1360	$page->param(rdns => $webvar{rdns});
[517]	1361	$page->param(city => $webvar{city});
	1362	$page->param(disptype => $disp_alloctypes{$webvar{alloctype}});
	1363	$page->param(custid => $webvar{custid});
	1364	$page->param(swip => $webvar{swip} eq 'on' ? 'Yes' : 'No');
[536]	1365	$page->param(circid => $webvar{circid});
	1366	$page->param(desc => $webvar{desc});
	1367	$page->param(notes => $webvar{notes});
[788]	1368	if ($IPDBacl{$authuser} =~ /s/) {
	1369	$page->param(nocling => 1);
	1370	$page->param(privdata => $webvar{privdata});
[798]	1371	if ($webvar{backupfields} && $webvar{backupfields} eq 'on') {
	1372	$page->param(hasbackup => 1);
[800]	1373	for my $bkfield (@IPDB::backupfields) {
[798]	1374	$page->param("bk$bkfield" => $webvar{"bk$bkfield"});
[788]	1375	}
	1376	}
	1377	}
[4]	1378
	1379	} # update()
	1380
	1381
[702]	1382	sub prepSplit {
	1383	if ($IPDBacl{$authuser} !~ /c/) {
	1384	$aclerr = 'splitblock';
	1385	return;
	1386	}
	1387
	1388	my $blockinfo = getBlockData($ip_dbh, $webvar{block});
	1389
[705]	1390	# Tree navigation
	1391	my $crumbs = getBreadCrumbs($ip_dbh, $blockinfo->{parent_id});
	1392	my @rcrumbs = reverse (@$crumbs);
	1393	$utilbar->param(breadcrumb => \@rcrumbs);
	1394
[702]	1395	if ($blockinfo->{type} =~ /^.i$/) {
	1396	$page->param(err => "Can't split a single IP allocation");
	1397	return;
	1398	}
	1399
	1400	# Info about current allocation
	1401	$page->param(oldblock => $blockinfo->{block});
	1402	$page->param(block => $webvar{block});
	1403
	1404	# Note that there are probably different rules that should be followed to restrict splitting IPv6 blocks;
	1405	# strictly speaking it will be exceptionally rare to see smaller than a /64 assigned to a customer, since that
	1406	# breaks auto-addressing schemes.
	1407
	1408	# Generate possible splits
	1409	my $block = new NetAddr::IP $blockinfo->{block};
	1410	my $oldmask = $block->masklen;
	1411	if ($blockinfo->{type} =~ /^.d$/) {
	1412	# Non-PPP pools
[705]	1413	$page->param(ispool => 1);
[702]	1414	if ($oldmask+2 >= $block->bits) {
	1415	$page->param(err => "Can't split a standard netblock pool any further");
	1416	return;
	1417	}
	1418	# Allow splitting down to v4 /30 (which results in one usable IP; dubiously useful)
	1419	$page->param(sp4mask => $oldmask+2) if $oldmask+2 <= $block->bits-2;
	1420	} elsif ($blockinfo->{type} =~ /.p/) {
[705]	1421	$page->param(ispool => 1);
[702]	1422	# Allow splitting PPP pools down to v4 /31
	1423	$page->param(sp4mask => $oldmask+2) if $oldmask+2 <= $block->bits-1;
	1424	} else {
	1425	# Allow splitting all other non-pool netblocks down to single IPs, which...
	1426	# arguably should be aggregated in a pool. Except where they shouldn't.
	1427	$page->param(sp4mask => $oldmask+2) if $oldmask+2 <= $block->bits;
	1428	}
	1429	# set the split-in-half mask
	1430	$page->param(sp2mask => $oldmask+1);
	1431
	1432	# Generate possible shrink targets
	1433	my @keepers = $block->split($block->masklen+1);
	1434	$page->param(newblockA => $keepers[0]);
	1435	$page->param(newblockB => $keepers[1]);
	1436	} # prepSplit()
	1437
	1438
	1439	sub doSplit {
	1440	if ($IPDBacl{$authuser} !~ /c/) {
	1441	$aclerr = 'splitblock';
	1442	return;
	1443	}
	1444
	1445	##fixme: need consistent way to identify "this thing that is this thing" with only the ID
	1446	# also applies to other locations
	1447	my $blockinfo = getBlockData($ip_dbh, $webvar{block});
	1448
[705]	1449	# Tree navigation
	1450	my $crumbs = getBreadCrumbs($ip_dbh, $blockinfo->{parent_id});
	1451	my @rcrumbs = reverse (@$crumbs);
	1452	$utilbar->param(breadcrumb => \@rcrumbs);
	1453
[702]	1454	if ($blockinfo->{type} =~ /^.i$/) {
	1455	$page->param(err => "Can't split a single IP allocation");
	1456	return;
	1457	}
	1458
	1459	if ($webvar{subact} eq 'split') {
	1460	$page->param(issplit => 1);
[705]	1461	my $block = new NetAddr::IP $blockinfo->{block};
[707]	1462	my $newblocks = splitBlock($ip_dbh, id => $webvar{block}, basetype => 'b', newmask => $webvar{split},
	1463	user => $authuser);
[702]	1464	if ($newblocks) {
	1465	$page->param(newblocks => $newblocks);
	1466	} else {
	1467	$page->param(err => $IPDB::errstr);
	1468	}
	1469
[705]	1470	} elsif ($webvar{subact} eq 'shrink') {
	1471	$page->param(nid => $webvar{block});
	1472	$page->param(newblock => $webvar{shrink});
	1473	my $newfree = shrinkBlock($ip_dbh, $webvar{block}, $webvar{shrink});
	1474	if ($newfree) {
	1475	$page->param(newfb => $newfree);
	1476	} else {
	1477	$page->param(err => $IPDB::errstr);
	1478	}
	1479
[702]	1480	} else {
[705]	1481	# Your llama is on fire.
	1482	$page->param(err => "Missing form field that shouldn't be missing.");
	1483	return;
[702]	1484	}
[705]	1485
	1486	# common bits
	1487	$page->param(cidr => $blockinfo->{block});
	1488	# and the backlink to the parent container
	1489	my $pinfo = getBlockData($ip_dbh, $blockinfo->{parent_id});
	1490	$page->param(backid => $blockinfo->{parent_id});
	1491	$page->param(backblock => $pinfo->{block});
[702]	1492	} # doSplit()
	1493
	1494
[717]	1495	# Set up for merge
	1496	sub prepMerge {
[789]	1497	if ($IPDBacl{$authuser} !~ /m/) {
	1498	$aclerr = 'mergeblock';
	1499	return;
	1500	}
	1501
[717]	1502	my $binfo = getBlockData($ip_dbh, $webvar{block});
[760]	1503
	1504	# Tree navigation
	1505	my $crumbs = getBreadCrumbs($ip_dbh, $binfo->{parent_id});
	1506	my @rcrumbs = reverse (@$crumbs);
	1507	$utilbar->param(breadcrumb => \@rcrumbs);
	1508
[717]	1509	$page->param(block => $webvar{block});
	1510	$page->param(ispool => $binfo->{type} =~ /.[dp]/);
	1511	$page->param(ismaster => $binfo->{type} eq 'mm');
	1512	$page->param(oldblock => $binfo->{block});
	1513	$page->param(oldtype => $disp_alloctypes{$binfo->{type}});
	1514	$page->param(typelist => getTypeList($ip_dbh, 'n', $binfo->{type})); # down the rabbit hole we go...
	1515
[733]	1516	# Strings for scope; do this way so we don't have to edit them many places
	1517	$page->param(vis_keepall => $merge_display{keepall});
	1518	$page->param(vis_mergepeer => $merge_display{mergepeer});
	1519	$page->param(vis_clearpeer => $merge_display{clearpeer});
	1520	$page->param(vis_clearall => $merge_display{clearall});
	1521
[717]	1522	} # prepMerge()
	1523
	1524
[720]	1525	# Show what will be merged, present warnings about data loss
	1526	sub confMerge {
[789]	1527	if ($IPDBacl{$authuser} !~ /m/) {
	1528	$aclerr = 'mergeblock';
	1529	return;
	1530	}
	1531
[720]	1532	if (!$webvar{newmask} \|\| $webvar{newmask} !~ /^\d+$/) {
	1533	$page->param(err => 'New netmask required');
	1534	return;
	1535	}
	1536
	1537	$page->param(block => $webvar{block});
	1538	my $binfo = getBlockData($ip_dbh, $webvar{block});
	1539	my $pinfo = getBlockData($ip_dbh, $binfo->{parent_id});
	1540	my $minfo = getBlockData($ip_dbh, $binfo->{master_id});
	1541	my $block = new NetAddr::IP $binfo->{block};
	1542
	1543	# Tree navigation
	1544	my $crumbs = getBreadCrumbs($ip_dbh, $binfo->{parent_id});
	1545	my @rcrumbs = reverse (@$crumbs);
	1546	$utilbar->param(breadcrumb => \@rcrumbs);
	1547
	1548	$page->param(oldblock => $binfo->{block});
	1549	$page->param(oldtype => $disp_alloctypes{$binfo->{type}});
	1550	$page->param(ismaster => $binfo->{type} eq 'mm');
	1551	$page->param(ispool => $webvar{alloctype} =~ /.[dp]/);
	1552	$page->param(isleaf => $webvar{alloctype} =~ /.[enr]/);
	1553	$page->param(newtype => $webvar{alloctype});
	1554	$page->param(newdisptype => $disp_alloctypes{$webvar{alloctype}});
	1555	my $newblock = new NetAddr::IP $block->addr."/$webvar{newmask}";
	1556	$newblock = $newblock->network;
	1557	$page->param(newmask => $webvar{newmask});
	1558	$page->param(newblock => "$newblock");
	1559
	1560	# get list of allocations and freeblocks to be merged
	1561	my $malloc_list = listForMerge($ip_dbh, $binfo->{parent_id}, $newblock, 'a');
	1562	$page->param(mergealloc => $malloc_list);
	1563
[733]	1564	$page->param(vis_scope => $merge_display{$webvar{scope}});
[727]	1565	$page->param(scope => $webvar{scope});
[720]	1566	} # confMerge()
	1567
	1568
[751]	1569	# Make it so
	1570	sub doMerge {
[789]	1571	if ($IPDBacl{$authuser} !~ /m/) {
	1572	$aclerr = 'mergeblock';
	1573	return;
	1574	}
	1575
[751]	1576	if (!$webvar{newmask} \|\| $webvar{newmask} !~ /^\d+$/) {
	1577	$page->param(err => 'New netmask required');
	1578	return;
	1579	}
	1580
	1581	$page->param(block => $webvar{block});
	1582	my $binfo = getBlockData($ip_dbh, $webvar{block});
	1583	my $pinfo = getBlockData($ip_dbh, $binfo->{parent_id});
	1584	my $block = new NetAddr::IP $binfo->{block};
	1585
	1586	# Tree navigation
	1587	my $crumbs = getBreadCrumbs($ip_dbh, $binfo->{parent_id});
	1588	my @rcrumbs = reverse (@$crumbs);
	1589	$utilbar->param(breadcrumb => \@rcrumbs);
	1590
	1591	$page->param(oldblock => $binfo->{block});
	1592	$page->param(oldtype => $disp_alloctypes{$binfo->{type}});
	1593	$page->param(newdisptype => $disp_alloctypes{$webvar{newtype}});
	1594	my $newblock = new NetAddr::IP $block->addr."/$webvar{newmask}";
	1595	$newblock = $newblock->network;
	1596	$page->param(newblock => $newblock);
	1597	$page->param(vis_scope => $merge_display{$webvar{scope}});
	1598
	1599	my $mlist = mergeBlocks($ip_dbh, $webvar{block}, %webvar, user => $authuser);
	1600
	1601	if ($mlist) {
	1602	#(newtype => $webvar{newtype}, newmask => $webvar{newmask}));
	1603	# Slice off first entry (the new parent - note this may be a new allocation,
	1604	# not the same ID that was "merged"!
	1605	my $parent = shift @$mlist;
	1606	$page->param(backpool => $webvar{newtype} =~ /.[dp]/);
	1607	if ($webvar{newtype} =~ /.[enr]/) {
	1608	$page->param(backleaf => 1);
	1609	$page->param(backid => $binfo->{parent_id});
	1610	$page->param(backblock => $pinfo->{block});
	1611	} else {
	1612	$page->param(backid => $parent->{id});
	1613	$page->param(backblock => $parent->{block});
	1614	}
	1615	$page->param(mergelist => $mlist);
	1616	} else {
	1617	$page->param(err => "Merge failed: $IPDB::errstr");
	1618	}
	1619	} # doMerge()
	1620
	1621
[4]	1622	# Delete an allocation.
[106]	1623	sub remove {
[233]	1624	if ($IPDBacl{$authuser} !~ /d/) {
[517]	1625	$aclerr = 'delblock';
[233]	1626	return;
	1627	}
	1628
[4]	1629	# Serves'em right for getting here...
	1630	if (!defined($webvar{block})) {
[517]	1631	$page->param(err => "Can't delete a block that doesn't exist");
[111]	1632	return;
[4]	1633	}
	1634
[538]	1635	my $blockdata;
[638]	1636	$blockdata = getBlockData($ip_dbh, $webvar{block}, $webvar{basetype});
[4]	1637
[765]	1638	# Tree navigation
	1639	my $crumbs = getBreadCrumbs($ip_dbh, $blockdata->{parent_id});
	1640	my @rcrumbs = reverse (@$crumbs);
	1641	$utilbar->param(breadcrumb => \@rcrumbs);
	1642
[638]	1643	if ($blockdata->{parent_id} == 0) { # $webvar{alloctype} eq 'mm'
[538]	1644	$blockdata->{city} = "N/A";
	1645	$blockdata->{custid} = "N/A";
	1646	$blockdata->{circuitid} = "N/A";
	1647	$blockdata->{description} = "N/A";
	1648	$blockdata->{notes} = "N/A";
	1649	$blockdata->{privdata} = "N/A";
[638]	1650	} # end cases for different alloctypes
[517]	1651
[638]	1652	$page->param(blockid => $webvar{block});
	1653	$page->param(basetype => $webvar{basetype});
[4]	1654
[538]	1655	$page->param(block => $blockdata->{block});
[589]	1656	$page->param(rdns => $blockdata->{rdns});
	1657
	1658	# maybe need to apply more magic here?
	1659	# most allocations we do want to autodelete the forward as well as reverse; for a handful we don't.
	1660	# -> all real blocks (nb: pool IPs need extra handling)
	1661	# -> NOC/private-IP (how to ID?)
	1662	# -> anything with a pattern matching $IPDB::domain?
	1663	if ($blockdata->{type} !~ /^.i$/) {
	1664	$page->param(autodel => 1);
	1665	}
	1666
[538]	1667	$page->param(disptype => $disp_alloctypes{$blockdata->{type}});
	1668	$page->param(city => $blockdata->{city});
	1669	$page->param(custid => $blockdata->{custid});
	1670	$page->param(circid => $blockdata->{circuitid});
	1671	$page->param(desc => $blockdata->{description});
	1672	$blockdata->{notes} = $q->escapeHTML($blockdata->{notes});
	1673	$blockdata->{notes} =~ s/\n/<br>\n/;
	1674	$page->param(notes => $blockdata->{notes});
	1675	$blockdata->{privdata} = $q->escapeHTML($blockdata->{privdata});
[540]	1676	$blockdata->{privdata} = ' ' if !$blockdata->{privdata};
[538]	1677	$blockdata->{privdata} =~ s/\n/<br>\n/;
	1678	$page->param(privdata => $blockdata->{privdata}) if $IPDBacl{$authuser} =~ /s/;
	1679	$page->param(delpool => $blockdata->{type} =~ /^.[pd]$/);
[4]	1680
[517]	1681	} # end remove()
[4]	1682
	1683
	1684	# Delete an allocation. Return it to the freeblocks table; munge
	1685	# data as necessary to keep as few records as possible in freeblocks
	1686	# to prevent weirdness when allocating blocks later.
	1687	# Remove IPs from pool listing if necessary
	1688	sub finalDelete {
[233]	1689	if ($IPDBacl{$authuser} !~ /d/) {
[517]	1690	$aclerr = 'delblock';
[233]	1691	return;
	1692	}
[4]	1693
[370]	1694	# need to retrieve block data before deleting so we can notify on that
[638]	1695	my $blockinfo = getBlockData($ip_dbh, $webvar{block}, $webvar{basetype});
	1696	my $pinfo = getBlockData($ip_dbh, $blockinfo->{parent_id}, 'b');
[370]	1697
[765]	1698	# Tree navigation
	1699	my $crumbs = getBreadCrumbs($ip_dbh, $blockinfo->{parent_id});
	1700	my @rcrumbs = reverse (@$crumbs);
	1701	$utilbar->param(breadcrumb => \@rcrumbs);
	1702
[638]	1703	my ($code,$msg) = deleteBlock($ip_dbh, $webvar{block}, $webvar{basetype}, $webvar{delforward}, $authuser);
[4]	1704
[638]	1705	$page->param(block => $blockinfo->{block});
[651]	1706	$page->param(bdisp => $q->escapeHTML($disp_alloctypes{$blockinfo->{type}}));
[766]	1707	$page->param(delparent_id => $blockinfo->{parent_id});
[651]	1708	if ($pinfo) {
	1709	$page->param(delparent => $pinfo->{block});
	1710	$page->param(pdisp => $q->escapeHTML($disp_alloctypes{$pinfo->{type}}));
	1711	}
[638]	1712	$page->param(returnpool => ($webvar{basetype} eq 'i') );
[591]	1713	if ($code =~ /^WARN(POOL\|MERGE)/) {
[638]	1714	my ($pid,$pcidr) = split /,/, $msg;
[654]	1715	my $real_pinfo = getBlockData($ip_dbh, $pid, 'b');
[638]	1716	$page->param(parent_id => $pid);
	1717	$page->param(parent => $pcidr);
[654]	1718	$page->param(real_disp => $q->escapeHTML($disp_alloctypes{$real_pinfo->{type}}));
[577]	1719	$page->param(mergeip => $code eq 'WARNPOOL');
	1720	}
[591]	1721	if ($code eq 'WARN') {
	1722	$msg =~ s/\n/<br>\n/g;
	1723	$page->param(genwarn => $msg);
	1724	}
[577]	1725	if ($code eq 'OK' \|\| $code =~ /^WARN/) {
[851]	1726	syslog "notice", "$authuser deallocated '".$blockinfo->{type}."'-type netblock ID $webvar{block} ".
	1727	"($blockinfo->{block}), $blockinfo->{custid}, $blockinfo->{city}, desc='$blockinfo->{description}'";
	1728	mailNotify($ip_dbh, 'da', "REMOVED: $disp_alloctypes{$blockinfo->{type}} $blockinfo->{block}",
	1729	# $webvar{block} useful? do we care about the block ID here?
	1730	"$disp_alloctypes{$blockinfo->{type}} $blockinfo->{block} deallocated by $authuser\n".
	1731	"CustID: $blockinfo->{custid}\nCity: $blockinfo->{city}\n".
	1732	"Description: $blockinfo->{description}\n");
[106]	1733	} else {
[517]	1734	$page->param(failmsg => $msg);
[106]	1735	if ($webvar{alloctype} =~ /^.i$/) {
[851]	1736	syslog "err", "$authuser could not deallocate static IP $webvar{block} ($blockinfo->{block}): '$msg'";
[106]	1737	} else {
[851]	1738	syslog "err", "$authuser could not deallocate netblock $webvar{block} ($blockinfo->{block}): '$msg'";
[517]	1739	$page->param(netblock => 1);
[4]	1740	}
[106]	1741	}
[4]	1742
	1743	} # finalDelete

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

Download in other formats: