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

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

/trunk

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

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

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