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

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

/trunk

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