Context Navigation

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

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

/trunk

Introduce a more "relaxed" layout for listing VRFs and master netblocks -
interleave the lists of master blocks for each VRF with the VRF heading,
instead of formally separating them onto different pages.

Refine and adapt showvrfs.tmpl to show the master blocks instead of
reinventing another wheel.

See #54.

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

File size: 57.3 KB

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

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

Download in other formats: