#!/usr/bin/perl # ipdb/cgi-bin/main.cgi ### # SVN revision info # $Date: 2015-10-08 21:41:56 +0000 (Thu, 08 Oct 2015) $ # SVN revision $Rev: 787 $ # Last update by $Author: kdeugau $ ### # Copyright (C) 2004-2010 - Kris Deugau use strict; use warnings; use CGI::Carp qw(fatalsToBrowser); use CGI::Simple; use HTML::Template; use DBI; use POSIX qw(ceil); use NetAddr::IP; use Frontier::Client; use Sys::Syslog; # don't remove! required for GNU/FHS-ish install from tarball ##uselib## use CustIDCK; use MyIPDB; openlog "IPDB","pid","$IPDB::syslog_facility"; ## Environment. Collect some things, process some things, set some things... # Collect the username from HTTP auth. If undefined, we're in # a test environment, or called without a username. my $authuser; if (!defined($ENV{'REMOTE_USER'})) { $authuser = '__temptest'; } else { $authuser = $ENV{'REMOTE_USER'}; } # anyone got a better name? :P my $thingroot = $ENV{SCRIPT_FILENAME}; $thingroot =~ s|cgi-bin/main.cgi||; syslog "debug", "$authuser active, $ENV{'REMOTE_ADDR'}"; ##fixme there *must* be a better order to do things in so this can go back where it was # CGI fiddling done here so we can declare %webvar so we can alter $webvar{action} # to show the right page on DB errors. # Set up the CGI object... my $q = new CGI::Simple; # ... and get query-string params as well as POST params if necessary $q->parse_query_string; # Convenience; saves changing all references to %webvar ##fixme: tweak for handling value have either encoded or bare newlines. # Also applies to privdata. $page->param(notes => $q->escapeHTML($webvar{notes},'y')); # Check to see if user is allowed to do anything with sensitive data if ($IPDBacl{$authuser} =~ /s/) { $page->param(nocling => 1); $page->param(privdata => $q->escapeHTML($webvar{privdata},'y')); $page->param(backupfields => $webvar{backupfields}); $page->param(bkbrand => $webvar{bkbrand}); $page->param(bkmodel => $webvar{bkmodel}); $page->param(bktype => $webvar{bktype}); $page->param(bksrc => $webvar{bksrc}); $page->param(bkuser => $webvar{bkuser}); # these two could use virtually any character $page->param(bkvpass => $q->escapeHTML($webvar{bkvpass})); $page->param(bkepass => $q->escapeHTML($webvar{bkepass})); $page->param(bkport => $webvar{bkport}); } # Yay! This now has it's very own little home. $page->param(billinguser => $webvar{userid}) if $webvar{userid}; ##fixme: this is only needed iff confirm.tmpl and # confirmRemove.tmpl are merged (quite possible, just # a little tedious) $page->param(action => "insert"); } # end confirmAssign # Do the work of actually inserting a block in the database. sub insertAssign { if ($IPDBacl{$authuser} !~ /a/) { $aclerr = 'addblock'; return; } # Some things are done more than once. return if !validateInput(); ##fixme: permission check if (!defined($webvar{privdata})) { $webvar{privdata} = ''; } # $code is "success" vs "failure", $msg contains OK for a # successful netblock allocation, the IP allocated for static # IP, or the error message if an error occurred. ##fixme: consider just passing \%webvar to allocateBlock()? # collect per-IP rDNS fields. only copy over the ones that actually have something in them. my %iprev; foreach (keys %webvar) { $iprev{$_} = $webvar{$_} if /host_[\d.a-fA-F:]+/ && $webvar{$_}; } # Easier to see and cosmetically fiddle the list like this my %insert_args = ( cidr => $webvar{fullcidr}, fbid => $webvar{fbid}, reserve => $webvar{reserve}, parent => $webvar{parent}, custid => $webvar{custid}, type => $webvar{alloctype}, city => $webvar{city}, desc => $webvar{desc}, notes => $webvar{notes}, circid => $webvar{circid}, privdata => $webvar{privdata}, nodeid => $webvar{node}, rdns => $webvar{rdns}, vrf => $webvar{vrf}, vlan => $webvar{vlan}, user => $authuser, ); ##fixme: permission check # fill in backup data, if present/allowed if ($webvar{backupfields}) { $insert_args{backup} = 1; $insert_args{bkbrand} = $webvar{bkbrand}; $insert_args{bkmodel} = $webvar{bkmodel}; for my $bkfield (qw(type src user vpass epass port)) { $insert_args{"bk$bkfield"} = ($webvar{"bk$bkfield"} ? $webvar{"bk$bkfield"} : ''); } } my $pinfo = getBlockData($ip_dbh, $webvar{parent}); # clean up a minor mess with guided allocation of static IPs if ($webvar{alloctype} =~ /^.i$/) { $insert_args{alloc_from} = $pinfo->{block}; } my ($code,$msg) = allocateBlock($ip_dbh, %insert_args, iprev => \%iprev); if ($code eq 'OK') { # breadcrumbs lite! provide at least a link to the parent of the block we just allocated. $page->param(parentid => $webvar{parent}); $page->param(parentblock => $pinfo->{block}); if ($webvar{alloctype} =~ /^.i$/) { $msg =~ s|/32||; $page->param(staticip => $msg); $page->param(custid => $webvar{custid}); $page->param(billinguser => $webvar{billinguser}); mailNotify($ip_dbh, "a$webvar{alloctype}", "ADDED: $disp_alloctypes{$webvar{alloctype}} allocation", "$disp_alloctypes{$webvar{alloctype}} $msg allocated to customer $webvar{custid}\n". "Description: $webvar{desc}\n\nAllocated by: $authuser\n"); } else { my $netblock = new NetAddr::IP $webvar{fullcidr}; $page->param(fullcidr => $webvar{fullcidr}); $page->param(alloctype => $disp_alloctypes{$webvar{alloctype}}); $page->param(custid => $webvar{custid}); # Full breadcrumbs my $crumbs = getBreadCrumbs($ip_dbh, $webvar{parent}); my @rcrumbs = reverse (@$crumbs); $utilbar->param(breadcrumb => \@rcrumbs); if ($webvar{alloctype} eq 'pr' && $webvar{billinguser}) { $page->param(billinguser => $webvar{billinguser}); $page->param(custid => $webvar{custid}); $page->param(netaddr => $netblock->addr); $page->param(masklen => $netblock->masklen); } mailNotify($ip_dbh, "a$webvar{alloctype}", "ADDED: $disp_alloctypes{$webvar{alloctype}} allocation", "$disp_alloctypes{$webvar{alloctype}} $webvar{fullcidr} allocated to customer $webvar{custid}\n". "Description: $webvar{desc}\n\nAllocated by: $authuser\n"); } syslog "notice", "$authuser allocated '$webvar{fullcidr}' to '$webvar{custid}' as ". "'$webvar{alloctype}' ($msg)"; } else { syslog "err", "Allocation of '$webvar{fullcidr}' to '$webvar{custid}' as ". "'$webvar{alloctype}' by $authuser failed: '$msg'"; $page->param(err => "Allocation of $webvar{fullcidr} as '$disp_alloctypes{$webvar{alloctype}}' failed:"); $page->param(errmsg => $msg); } } # end insertAssign() # Does some basic checks on common input data to make sure nothing # *really* weird gets in to the database through this script. # Does NOT do complete input validation!!! sub validateInput { if ($webvar{city} eq '-') { $page->param(err => 'Please choose a city'); return; } # Alloctype check. chomp $webvar{alloctype}; if (!grep /$webvar{alloctype}/, keys %disp_alloctypes) { # Danger! Danger! alloctype should ALWAYS be set by a dropdown. Anyone # managing to call things in such a way as to cause this deserves a cryptic error. $page->param(err => 'Invalid alloctype'); return; } # CustID check # We have different handling for customer allocations and "internal" or "our" allocations if ($def_custids{$webvar{alloctype}} eq '') { if (!$webvar{custid}) { $page->param(err => 'Please enter a customer ID.'); return; } # Crosscheck with billing. my $status = CustIDCK->custid_exist($webvar{custid}); if ($CustIDCK::Error) { $page->param(err => "Error verifying customer ID: ".$CustIDCK::ErrMsg); return; } if (!$status) { $page->param(err => "Customer ID not valid. Make sure the Customer ID ". "is correct.
\nUse STAFF for staff static IPs, and $IPDB::defcustid for any other ". "non-customer assignments."); return; } # print "\n"; } else { # New! Improved! And now Loaded From The Database!! if ((!$webvar{custid}) || ($webvar{custid} ne 'STAFF')) { $webvar{custid} = $def_custids{$webvar{alloctype}}; } } ## hmmm.... is this even useful? if (0) { # Check POP location my $flag; if ($webvar{alloctype} eq 'rm') { $flag = 'for a routed netblock'; foreach (@poplist) { if (/^$webvar{city}$/) { $flag = 'n'; last; } } } else { $flag = 'n'; ##fixme: hook to force-set POP or city on certain alloctypes # if ($webvar{alloctype =~ /foo,bar,bz/ { $webvar{pop} = 'blah'; } if ($webvar{pop} && $webvar{pop} =~ /^-$/) { $flag = 'to route the block from/through'; } } # if the alloctype has a restricted city/POP list as determined above, # and the reqested city/POP does not match that list, complain if ($flag ne 'n') { $page->param(err => "Please choose a valid POP location $flag. Valid ". "POP locations are currently:
\n".join (" - ", @poplist)); return; } } # VRF. Not a full validity check, just a basic sanity check. if ($webvar{vrf}) { # Trim leading and trailing whitespace first $webvar{vrf} =~ s/^\s+//; $webvar{vrf} =~ s/\s+$//; if ($webvar{vrf} !~ /^[\w\d_.-]{1,32}$/) { $page->param(err => "VRF values may only contain alphanumerics, and may not be more than 32 characters"); return; } } # VLAN. Should we allow/use VLAN names, or just the numeric ID? if ($webvar{vlan}) { # Trim leading and trailing whitespace first $webvar{vlan} =~ s/^\s+//; $webvar{vlan} =~ s/\s+$//; # ... ve make it ze configurable thingy! if ($IPDB::numeric_vlan) { if ($webvar{vlan} !~ /^\d+$/) { $page->param(err => "VLANs must be numeric"); return; } } else { if ($webvar{vlan} !~ /^[\w\d_.-]+$/) { $page->param(err => "VLANs must be alphanumeric"); return; } } } # Backup fields. Minimal sanity checks. for my $bkfield (qw(brand model)) { if ($webvar{"bk$bkfield"} && $webvar{"bk$bkfield"} !~ /^[a-zA-Z0-9\s_.-]+$/) { $page->param(err => "Invalid characters in backup $bkfield"); return; } } for my $bkfield (qw(type src user)) { # no spaces in these! if ($webvar{"bk$bkfield"} && $webvar{"bk$bkfield"} !~ /^[a-zA-Z0-9_.-]+$/) { $page->param(err => "Invalid characters in backup $bkfield"); return; } } if ($webvar{bkport}) { $webvar{bkport} =~ s/^\s+//g; $webvar{bkport} =~ s/\s+$//g; if ($webvar{bkport} !~ /^\d+$/) { $page->param(err => "Backup port must be numeric"); return; } } return 'OK'; } # end validateInput # Displays details of a specific allocation in a form # Allows update/delete # action=edit sub edit { # snag block info from db my $blockinfo = getBlockData($ip_dbh, $webvar{id}, $webvar{basetype}); my $cidr = new NetAddr::IP $blockinfo->{block}; $page->param(id => $webvar{id}); $page->param(basetype => $webvar{basetype}); # Tree navigation my $crumbs = getBreadCrumbs($ip_dbh, $blockinfo->{parent_id}); my @rcrumbs = reverse (@$crumbs); $utilbar->param(breadcrumb => \@rcrumbs); # Show link to IP list for pools $page->param(ispool => 1) if $blockinfo->{type} =~ /^.[dp]$/; # Clean up extra whitespace on alloc type. Mainly a legacy-data cleanup. $blockinfo->{type} =~ s/\s//; ##fixme: The case of "allocation larger than a /24" (or any similar case # where the allocation is larger than the zone(s) in DNS) doesn't work well. # Best solution may just be to add a warning that the entry shown may not be # correct/complete. if ($blockinfo->{revavail} || $blockinfo->{revpartial}) { $page->param(showrev => ($blockinfo->{revavail} || $blockinfo->{revpartial}) ); my $cached; # Get rDNS info; duplicates a bit of getBlockData but also does the RPC call if possible ($blockinfo->{rdns},$cached) = getBlockRDNS($ip_dbh, id => $webvar{id}, type => $blockinfo->{type}, user => $authuser); $page->param(rdns => $blockinfo->{rdns}); # visual flag that we're working IPDB-local, not off more authoritative data in dnsadmin $page->param(cached => $cached); # Limit the per-IP rDNS list based on CIDR length; larger ones just take up too much space. # Also, don't show on IP pools; the individual IPs will have a space for rDNS # Don't show on single IPs; these use the "pattern" field if ($IPDBacl{$authuser} =~ /c/ && $cidr->masklen != $cidr->bits && ($cidr->bits - $cidr->masklen) <= $IPDB::maxrevlist # config flag for "all block types" OR "not-a-pool-or-IP type" && ($IPDB::revlistalltypes || $blockinfo->{type} !~ /^.[dpi]/) # safety against trying to retrieve and display more than 1k (10 bits, /22 v4) worth of individual IPs # ever. If you really need to manage a long list of IPs like that all in one place, you can use the DNS # management tool. Even a /26 is a bit much, really. && ($cidr->bits - $cidr->masklen) <= 10 # do we want to allow v6 at all? #&& ! $cidr->{isv6} ) { $page->param(r_iplist => getRDNSbyIP($ip_dbh, id => $webvar{id}, type => $blockinfo->{type}, range => $blockinfo->{block}, user => $authuser) ); } } # rDNS availability check # backup data if ($blockinfo->{hasbk}) { $page->param(hasbackup => $blockinfo->{hasbk}); for my $bkfield (qw(brand model src user vpass epass port)) { $page->param("bk$bkfield" => $blockinfo->{"bk$bkfield"}); } $page->param(bktelnet => 1) if $blockinfo->{bktype} eq 'telnet'; $page->param(bkssh => 1) if $blockinfo->{bktype} eq 'SSH'; } # consider extending this to show time as well as date my ($lastmod,undef) = split /\s+/, $blockinfo->{lastmod}; $page->param(lastmod => $lastmod); $page->param(block => $blockinfo->{block}); $page->param(city => $blockinfo->{city}); $page->param(custid => $blockinfo->{custid}); ##fixme The check here should be built from the database # Need to expand to support pool types too if ($blockinfo->{type} =~ /^.[ne]$/ && $IPDBacl{$authuser} =~ /c/) { $page->param(changetype => 1); $page->param(alloctype => [ { selme => ($blockinfo->{type} eq 'me'), type => "me", disptype => "Dialup netblock" }, { selme => ($blockinfo->{type} eq 'de'), type => "de", disptype => "Dynamic DSL netblock" }, { selme => ($blockinfo->{type} eq 'ce'), type => "ce", disptype => "Dynamic cable netblock" }, { selme => ($blockinfo->{type} eq 'we'), type => "we", disptype => "Dynamic wireless netblock" }, { selme => ($blockinfo->{type} eq 'cn'), type => "cn", disptype => "Customer netblock" }, { selme => ($blockinfo->{type} eq 'en'), type => "en", disptype => "End-use netblock" }, { selme => ($blockinfo->{type} eq 'in'), type => "in", disptype => "Internal netblock" }, ] ); } else { $page->param(disptype => $disp_alloctypes{$blockinfo->{type}}); $page->param(type => $blockinfo->{type}); } ## node hack my ($nodeid,$nodename) = getNodeInfo($ip_dbh, $blockinfo->{block}); # $page->param(havenodeid => $nodeid); $page->param(nodename => $nodename); ##fixme: this whole hack needs cleanup and generalization for all alloctypes ##fixme: arguably a bug that presence of a nodeid implies it can be changed.. if ($IPDBacl{$authuser} =~ /c/) { my $nlist = getNodeList($ip_dbh); if ($nodeid) { foreach (@{$nlist}) { $$_{selme} = ($$_{node_id} == $nodeid); } } $page->param(nodelist => $nlist); } ## end node hack $page->param(vrf => $blockinfo->{vrf}); $page->param(vlan => $blockinfo->{vlan}); # Reserved-for-expansion $page->param(reserve => $blockinfo->{reserve}); $page->param(reserve_id => $blockinfo->{reserve_id}); my $newblock = NetAddr::IP->new($cidr->addr, $cidr->masklen - 1)->network; $page->param(newblock => $newblock); # not happy with the upside-down logic, but... $page->param(swipable => $blockinfo->{type} !~ /.i/); $page->param(swip => $blockinfo->{swip} ne 'n') if $blockinfo->{swip}; $page->param(circid => $blockinfo->{circuitid}); $page->param(desc => $blockinfo->{description}); $page->param(notes => $blockinfo->{notes}); # Check to see if we can display sensitive data $page->param(nocling => $IPDBacl{$authuser} =~ /s/); $page->param(privdata => $blockinfo->{privdata}); # ACL trickery - these two template booleans control the presence of all form/input tags $page->param(maychange => $IPDBacl{$authuser} =~ /c/); $page->param(maydel => $IPDBacl{$authuser} =~ /d/); # Need to find internal knobs to twist to actually vary these. (Ab)use "change" flag for now $page->param(maymerge => ($IPDBacl{$authuser} =~ /c/ && $blockinfo->{type} !~ /^.i$/)); if ($IPDBacl{$authuser} =~ /c/ && $blockinfo->{type} !~ /^.i$/) { if ($blockinfo->{type} =~ /^.p$/) { # PPP pools $page->param(maysplit => 1) if $cidr->masklen+1 < $cidr->bits; } elsif ($blockinfo->{type} =~ /.d/) { # Non-PPP pools $page->param(maysplit => 1) if $cidr->masklen+2 < $cidr->bits; } else { # Standard netblocks. Arguably allowing splitting these down to single IPs # doesn't make much sense, but forcing users to apply allocation types # "properly" is worse than herding cats. $page->param(maysplit => 1) if $cidr->masklen < $cidr->bits; } } } # edit() # Stuff new info about a block into the db # action=update sub update { if ($IPDBacl{$authuser} !~ /c/) { $aclerr = 'updateblock'; return; } # Collect existing block info here, since we need it for the breadcrumb nav my $binfo = getBlockData($ip_dbh, $webvar{block}, $webvar{basetype}); my $crumbs = getBreadCrumbs($ip_dbh, $binfo->{parent_id}); my @rcrumbs = reverse (@$crumbs); $utilbar->param(breadcrumb => \@rcrumbs); # Make sure incoming data is in correct format - custID among other things. return if !validateInput; $webvar{swip} = 'n' if !$webvar{swip}; my %updargs = ( custid => $webvar{custid}, city => $webvar{city}, description => $webvar{desc}, notes => $webvar{notes}, circuitid => $webvar{circid}, block => $webvar{block}, type => $webvar{alloctype}, swip => $webvar{swip}, rdns => $webvar{rdns}, vrf => $webvar{vrf}, vlan => $webvar{vlan}, user => $authuser, ); # Semioptional values $updargs{privdata} = $webvar{privdata} if $IPDBacl{$authuser} =~ /s/; $updargs{node} = $webvar{node} if $webvar{node}; # collect per-IP rDNS fields. only copy over the ones that actually have something in them. my %iprev; foreach (keys %webvar) { $iprev{$_} = $webvar{$_} if /host_[\d.a-fA-F:]+/ && $webvar{$_}; } # Merge with reserved freeblock $updargs{fbmerge} = $webvar{expandme} if $webvar{expandme}; my ($code,$msg) = updateBlock($ip_dbh, %updargs, iprev => \%iprev); if ($code eq 'FAIL') { syslog "err", "$authuser could not update block/IP '$binfo->{block}' (id $webvar{block}): '$msg'"; $page->param(err => "Could not update block/IP $binfo->{block}: $msg"); return; } # If we get here, the operation succeeded. syslog "notice", "$authuser updated $binfo->{block}"; ##fixme: log details of the change? old way is in the .debug stream anyway. ##fixme: need to wedge something in to allow "update:field" notifications ## hmm. how to tell what changed? O_o mailNotify($ip_dbh, 's:swi', "SWIPed: $disp_alloctypes{$webvar{alloctype}} $binfo->{block}", "$binfo->{block} had SWIP status changed to \"Yes\" by $authuser") if $webvar{swip} eq 'on'; ## node hack if ($webvar{node} && $webvar{node} ne '-') { my $nodename = getNodeName($ip_dbh, $webvar{node}); $page->param(nodename => $nodename); } ## end node hack # Link back to browse-routed or list-pool page on "Update complete" page. my $pblock = getBlockData($ip_dbh, $binfo->{parent_id}); $page->param(backid => $binfo->{parent_id}); $page->param(backblock => $pblock->{block}); $page->param(backpool => ($webvar{basetype} eq 'i')); # Do some HTML fiddling here instead of using ESCAPE=HTML in the template, # because otherwise we can't convert \n to
. *sigh* $webvar{notes} = $q->escapeHTML($webvar{notes}); # escape first... $webvar{notes} =~ s/\n/
\n/; # ... then convert newlines $webvar{privdata} = ($webvar{privdata} ? $q->escapeHTML($webvar{privdata}) : " "); $webvar{privdata} =~ s/\n/
\n/; if ($webvar{expandme}) { # this is fugly but still faster than hitting the DB again with getBlockData() my $tmp = new NetAddr::IP $binfo->{block}; my $fb = new NetAddr::IP $binfo->{reserve}; my @newblock = $tmp->compact($fb); $page->param(cidr => $newblock[0]); } else { $page->param(cidr => $binfo->{block}); } $page->param(rdns => $webvar{rdns}); $page->param(city => $webvar{city}); $page->param(disptype => $disp_alloctypes{$webvar{alloctype}}); $page->param(custid => $webvar{custid}); $page->param(swip => $webvar{swip} eq 'on' ? 'Yes' : 'No'); $page->param(circid => $webvar{circid}); $page->param(desc => $webvar{desc}); $page->param(notes => $webvar{notes}); $page->param(privdata => $webvar{privdata}) if $IPDBacl{$authuser} =~ /s/; } # update() sub prepSplit { if ($IPDBacl{$authuser} !~ /c/) { $aclerr = 'splitblock'; return; } my $blockinfo = getBlockData($ip_dbh, $webvar{block}); # Tree navigation my $crumbs = getBreadCrumbs($ip_dbh, $blockinfo->{parent_id}); my @rcrumbs = reverse (@$crumbs); $utilbar->param(breadcrumb => \@rcrumbs); if ($blockinfo->{type} =~ /^.i$/) { $page->param(err => "Can't split a single IP allocation"); return; } # Info about current allocation $page->param(oldblock => $blockinfo->{block}); $page->param(block => $webvar{block}); # Note that there are probably different rules that should be followed to restrict splitting IPv6 blocks; # strictly speaking it will be exceptionally rare to see smaller than a /64 assigned to a customer, since that # breaks auto-addressing schemes. # Generate possible splits my $block = new NetAddr::IP $blockinfo->{block}; my $oldmask = $block->masklen; if ($blockinfo->{type} =~ /^.d$/) { # Non-PPP pools $page->param(ispool => 1); if ($oldmask+2 >= $block->bits) { $page->param(err => "Can't split a standard netblock pool any further"); return; } # Allow splitting down to v4 /30 (which results in one usable IP; dubiously useful) $page->param(sp4mask => $oldmask+2) if $oldmask+2 <= $block->bits-2; } elsif ($blockinfo->{type} =~ /.p/) { $page->param(ispool => 1); # Allow splitting PPP pools down to v4 /31 $page->param(sp4mask => $oldmask+2) if $oldmask+2 <= $block->bits-1; } else { # Allow splitting all other non-pool netblocks down to single IPs, which... # arguably should be *aggregated* in a pool. Except where they shouldn't. $page->param(sp4mask => $oldmask+2) if $oldmask+2 <= $block->bits; } # set the split-in-half mask $page->param(sp2mask => $oldmask+1); # Generate possible shrink targets my @keepers = $block->split($block->masklen+1); $page->param(newblockA => $keepers[0]); $page->param(newblockB => $keepers[1]); } # prepSplit() sub doSplit { if ($IPDBacl{$authuser} !~ /c/) { $aclerr = 'splitblock'; return; } ##fixme: need consistent way to identify "this thing that is this thing" with only the ID # also applies to other locations my $blockinfo = getBlockData($ip_dbh, $webvar{block}); # Tree navigation my $crumbs = getBreadCrumbs($ip_dbh, $blockinfo->{parent_id}); my @rcrumbs = reverse (@$crumbs); $utilbar->param(breadcrumb => \@rcrumbs); if ($blockinfo->{type} =~ /^.i$/) { $page->param(err => "Can't split a single IP allocation"); return; } if ($webvar{subact} eq 'split') { $page->param(issplit => 1); my $block = new NetAddr::IP $blockinfo->{block}; my $newblocks = splitBlock($ip_dbh, id => $webvar{block}, basetype => 'b', newmask => $webvar{split}, user => $authuser); if ($newblocks) { $page->param(newblocks => $newblocks); } else { $page->param(err => $IPDB::errstr); } } elsif ($webvar{subact} eq 'shrink') { $page->param(nid => $webvar{block}); $page->param(newblock => $webvar{shrink}); my $newfree = shrinkBlock($ip_dbh, $webvar{block}, $webvar{shrink}); if ($newfree) { $page->param(newfb => $newfree); } else { $page->param(err => $IPDB::errstr); } } else { # Your llama is on fire. $page->param(err => "Missing form field that shouldn't be missing."); return; } # common bits $page->param(cidr => $blockinfo->{block}); # and the backlink to the parent container my $pinfo = getBlockData($ip_dbh, $blockinfo->{parent_id}); $page->param(backid => $blockinfo->{parent_id}); $page->param(backblock => $pinfo->{block}); } # doSplit() # Set up for merge sub prepMerge { my $binfo = getBlockData($ip_dbh, $webvar{block}); # Tree navigation my $crumbs = getBreadCrumbs($ip_dbh, $binfo->{parent_id}); my @rcrumbs = reverse (@$crumbs); $utilbar->param(breadcrumb => \@rcrumbs); $page->param(block => $webvar{block}); $page->param(ispool => $binfo->{type} =~ /.[dp]/); $page->param(ismaster => $binfo->{type} eq 'mm'); $page->param(oldblock => $binfo->{block}); $page->param(oldtype => $disp_alloctypes{$binfo->{type}}); $page->param(typelist => getTypeList($ip_dbh, 'n', $binfo->{type})); # down the rabbit hole we go... # Strings for scope; do this way so we don't have to edit them many places $page->param(vis_keepall => $merge_display{keepall}); $page->param(vis_mergepeer => $merge_display{mergepeer}); $page->param(vis_clearpeer => $merge_display{clearpeer}); $page->param(vis_clearall => $merge_display{clearall}); } # prepMerge() # Show what will be merged, present warnings about data loss sub confMerge { if (!$webvar{newmask} || $webvar{newmask} !~ /^\d+$/) { $page->param(err => 'New netmask required'); return; } $page->param(block => $webvar{block}); my $binfo = getBlockData($ip_dbh, $webvar{block}); my $pinfo = getBlockData($ip_dbh, $binfo->{parent_id}); my $minfo = getBlockData($ip_dbh, $binfo->{master_id}); my $block = new NetAddr::IP $binfo->{block}; # Tree navigation my $crumbs = getBreadCrumbs($ip_dbh, $binfo->{parent_id}); my @rcrumbs = reverse (@$crumbs); $utilbar->param(breadcrumb => \@rcrumbs); $page->param(oldblock => $binfo->{block}); $page->param(oldtype => $disp_alloctypes{$binfo->{type}}); $page->param(ismaster => $binfo->{type} eq 'mm'); $page->param(ispool => $webvar{alloctype} =~ /.[dp]/); $page->param(isleaf => $webvar{alloctype} =~ /.[enr]/); $page->param(newtype => $webvar{alloctype}); $page->param(newdisptype => $disp_alloctypes{$webvar{alloctype}}); my $newblock = new NetAddr::IP $block->addr."/$webvar{newmask}"; $newblock = $newblock->network; $page->param(newmask => $webvar{newmask}); $page->param(newblock => "$newblock"); # get list of allocations and freeblocks to be merged my $malloc_list = listForMerge($ip_dbh, $binfo->{parent_id}, $newblock, 'a'); $page->param(mergealloc => $malloc_list); $page->param(vis_scope => $merge_display{$webvar{scope}}); $page->param(scope => $webvar{scope}); } # confMerge() # Make it so sub doMerge { if (!$webvar{newmask} || $webvar{newmask} !~ /^\d+$/) { $page->param(err => 'New netmask required'); return; } $page->param(block => $webvar{block}); my $binfo = getBlockData($ip_dbh, $webvar{block}); my $pinfo = getBlockData($ip_dbh, $binfo->{parent_id}); my $block = new NetAddr::IP $binfo->{block}; # Tree navigation my $crumbs = getBreadCrumbs($ip_dbh, $binfo->{parent_id}); my @rcrumbs = reverse (@$crumbs); $utilbar->param(breadcrumb => \@rcrumbs); $page->param(oldblock => $binfo->{block}); $page->param(oldtype => $disp_alloctypes{$binfo->{type}}); $page->param(newdisptype => $disp_alloctypes{$webvar{newtype}}); my $newblock = new NetAddr::IP $block->addr."/$webvar{newmask}"; $newblock = $newblock->network; $page->param(newblock => $newblock); $page->param(vis_scope => $merge_display{$webvar{scope}}); my $mlist = mergeBlocks($ip_dbh, $webvar{block}, %webvar, user => $authuser); if ($mlist) { #(newtype => $webvar{newtype}, newmask => $webvar{newmask})); # Slice off first entry (the new parent - note this may be a new allocation, # not the same ID that was "merged"! my $parent = shift @$mlist; $page->param(backpool => $webvar{newtype} =~ /.[dp]/); if ($webvar{newtype} =~ /.[enr]/) { $page->param(backleaf => 1); $page->param(backid => $binfo->{parent_id}); $page->param(backblock => $pinfo->{block}); } else { $page->param(backid => $parent->{id}); $page->param(backblock => $parent->{block}); } $page->param(mergelist => $mlist); } else { $page->param(err => "Merge failed: $IPDB::errstr"); } } # doMerge() # Delete an allocation. sub remove { if ($IPDBacl{$authuser} !~ /d/) { $aclerr = 'delblock'; return; } # Serves'em right for getting here... if (!defined($webvar{block})) { $page->param(err => "Can't delete a block that doesn't exist"); return; } my $blockdata; $blockdata = getBlockData($ip_dbh, $webvar{block}, $webvar{basetype}); # Tree navigation my $crumbs = getBreadCrumbs($ip_dbh, $blockdata->{parent_id}); my @rcrumbs = reverse (@$crumbs); $utilbar->param(breadcrumb => \@rcrumbs); if ($blockdata->{parent_id} == 0) { # $webvar{alloctype} eq 'mm' $blockdata->{city} = "N/A"; $blockdata->{custid} = "N/A"; $blockdata->{circuitid} = "N/A"; $blockdata->{description} = "N/A"; $blockdata->{notes} = "N/A"; $blockdata->{privdata} = "N/A"; } # end cases for different alloctypes $page->param(blockid => $webvar{block}); $page->param(basetype => $webvar{basetype}); $page->param(block => $blockdata->{block}); $page->param(rdns => $blockdata->{rdns}); # maybe need to apply more magic here? # most allocations we *do* want to autodelete the forward as well as reverse; for a handful we don't. # -> all real blocks (nb: pool IPs need extra handling) # -> NOC/private-IP (how to ID?) # -> anything with a pattern matching $IPDB::domain? if ($blockdata->{type} !~ /^.i$/) { $page->param(autodel => 1); } $page->param(disptype => $disp_alloctypes{$blockdata->{type}}); $page->param(city => $blockdata->{city}); $page->param(custid => $blockdata->{custid}); $page->param(circid => $blockdata->{circuitid}); $page->param(desc => $blockdata->{description}); $blockdata->{notes} = $q->escapeHTML($blockdata->{notes}); $blockdata->{notes} =~ s/\n/
\n/; $page->param(notes => $blockdata->{notes}); $blockdata->{privdata} = $q->escapeHTML($blockdata->{privdata}); $blockdata->{privdata} = ' ' if !$blockdata->{privdata}; $blockdata->{privdata} =~ s/\n/
\n/; $page->param(privdata => $blockdata->{privdata}) if $IPDBacl{$authuser} =~ /s/; $page->param(delpool => $blockdata->{type} =~ /^.[pd]$/); } # end remove() # Delete an allocation. Return it to the freeblocks table; munge # data as necessary to keep as few records as possible in freeblocks # to prevent weirdness when allocating blocks later. # Remove IPs from pool listing if necessary sub finalDelete { if ($IPDBacl{$authuser} !~ /d/) { $aclerr = 'delblock'; return; } # need to retrieve block data before deleting so we can notify on that my $blockinfo = getBlockData($ip_dbh, $webvar{block}, $webvar{basetype}); my $pinfo = getBlockData($ip_dbh, $blockinfo->{parent_id}, 'b'); # Tree navigation my $crumbs = getBreadCrumbs($ip_dbh, $blockinfo->{parent_id}); my @rcrumbs = reverse (@$crumbs); $utilbar->param(breadcrumb => \@rcrumbs); my ($code,$msg) = deleteBlock($ip_dbh, $webvar{block}, $webvar{basetype}, $webvar{delforward}, $authuser); $page->param(block => $blockinfo->{block}); $page->param(bdisp => $q->escapeHTML($disp_alloctypes{$blockinfo->{type}})); $page->param(delparent_id => $blockinfo->{parent_id}); if ($pinfo) { $page->param(delparent => $pinfo->{block}); $page->param(pdisp => $q->escapeHTML($disp_alloctypes{$pinfo->{type}})); } $page->param(returnpool => ($webvar{basetype} eq 'i') ); if ($code =~ /^WARN(POOL|MERGE)/) { my ($pid,$pcidr) = split /,/, $msg; my $real_pinfo = getBlockData($ip_dbh, $pid, 'b'); $page->param(parent_id => $pid); $page->param(parent => $pcidr); $page->param(real_disp => $q->escapeHTML($disp_alloctypes{$real_pinfo->{type}})); $page->param(mergeip => $code eq 'WARNPOOL'); } if ($code eq 'WARN') { $msg =~ s/\n/
\n/g; $page->param(genwarn => $msg); } if ($code eq 'OK' || $code =~ /^WARN/) { syslog "notice", "$authuser deallocated '".$blockinfo->{type}."'-type netblock $webvar{block} ". $blockinfo->{custid}.", ".$blockinfo->{city}.", desc='".$blockinfo->{description}."'"; mailNotify($ip_dbh, 'da', "REMOVED: ".$disp_alloctypes{$blockinfo->{type}}." $webvar{block}", $disp_alloctypes{$blockinfo->{type}}." $webvar{block} deallocated by $authuser\n". "CustID: ".$blockinfo->{custid}."\nCity: ".$blockinfo->{city}. "\nDescription: ".$blockinfo->{description}."\n"); } else { $page->param(failmsg => $msg); if ($webvar{alloctype} =~ /^.i$/) { syslog "err", "$authuser could not deallocate static IP '$webvar{block}': '$msg'"; } else { syslog "err", "$authuser could not deallocate netblock '$webvar{block}': '$msg'"; $page->param(netblock => 1); } } } # finalDelete