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

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

/trunk

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