### Local Variables: ***
### mode:perl ***
### comment-column:0 ***
### comment-start: "### " ***
### comment-end: "***" ***
### End: ***
#
# ****************DO NOT MOVE OR CHANGE LINES ABOVE THIS*********************
#
# The first set of lines runs perl from any shell. The second set of lines
# identifies the rest of the file as PERL for EMACS autoformatting.
# See end of copyright for more information.
#
#
# -------------------------------------------------------------------
# X-BONE
#
# http://www.isi.edu/xbone
# USC Information Sciences Institute (USC/ISI)
# Marina del Rey, California 90292, USA
# Copyright (c) 1998-2005
#
# -------------------------------------------------------------------
#
# Copyright (c) 1998-2005 by the University of Southern California.
# All rights reserved.
#
# Permission to use, copy, modify, and distribute this software and
# its documentation in source and binary forms for non-commercial
# purposes and without fee is hereby granted, provided that the above
# copyright notice appear in all copies and that both the copyright
# notice and this permission notice appear in supporting
# documentation, and that any documentation, advertising materials,
# and other materials related to such distribution and use acknowledge
# that the software was developed by the University of Southern
# California, Information Sciences Institute. The name of the
# University may not be used to endorse or promote products derived
# from this software without specific prior written permission.
#
# THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT
# THE SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE. THIS SOFTWARE IS
# PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES,
# INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# Other copyrights might apply to parts of this software and are so
# noted when applicable.
#
# -------------------------------------------------------------------
#
# Effort partly sponsored by the Defense Advanced Research Projects
# Agency (DARPA) and Air Force Research Laboratory, Air Force Materiel
# Command, USAF, under agreement numbers F30602-98-1-0200 (X-Bone) and
# F30602-01-2-0529 (DynaBone). The views and conclusions contained
# herein are those of the authors and should not be interpreted as
# necessarily representing the official policies or endorsements,
# either expressed or implied, of the Defense Advanced Research
# Projects Agency (DARPA), the Air Force Research Laboratory, or the
# U.S. Government.
#
# This work was partly supported by the NSF STI-XTEND (ANI-0230789)
# and NETFS (ANI-0129689) projects. Any opinions, findings, and
# conclusions or recommendations expressed in this material are those
# of the authors and do not necessarily reflect the views of the
# National Science Foundation.
#
# -------------------------------------------------------------------
# $RCSfile: XB_VN_IPalloc.pm,v $
#
# $Revision: 1.14 $
# $Author: pingali $
# $Date: 2005/03/31 07:04:00 $
# $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Lars Eggert (originally written for Tethernet)
# Yu-Shun Wang (extended to handle NetAddr::IP objects)
# Venkata Pingali (extended to handle v6)
# Description: * IP allocator: Functions to allocate & deallocate IP (v4|v6)
# address blocks
# * XBone Overlay: Functions to assign IP addresses from the
# given block to each interfaces [used per overlay]
# Notes:
# - All address states are stored in CIDR-format strings. NetAddr::IP objects
# are only used to manipulate the address blocks.
package XB_VN_IPalloc;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(request allocate);
use strict;
use sigtrap;
use Data::Dumper;
use XB_Params;
use XB_Log;
# TODO Once NetAddr::IP 3.17 is committed into the port tree, we should
# TODO add version requirements here or it wouldn't work.
use NetAddr::IP;
use Net::IP::XB_IP;
my $modname = 'XB_VN_IPalloc::';
# prototypes, because we recurse
sub allocate($$$);
sub deallocate($$);
sub new_allocate($$$);
sub new_deallocate($$);
###############################################################################
# UTILITY FUNCTIONS
###############################################################################
# Description:
# Compute the size of a block in free space list i.
sub blocksize ($) { return (1 << shift); }
# Description:
# Construct XBone Control Protocol messages for address operations.
# Arguments:
# $cmd command type: request, reply, release, ack
# $size number of addresses
# $type IPv4 or IPv6
# $appinfo (ref) hash of application info (type, name, level, credential)
# Returns:
# $msg (ref) resulting message
# Exceptions:
# -
sub addr_msg($$$$){
my ($cmd, $size, $type, $appinfo) = @_;
my $procname = $modname. "addr_msg";
my $argstr = join ", ", @_;
XB_Log::log "info", "-> $procname $argstr";
#unless($command
my $addr_msg =
"(xbone-ctl $XB_Params::ctl_ver $XB_Params::rel_ver\n".
$appinfo->{credential}. "\n".
" (address_request\n".
" (application $appinfo->{type})\n".
" (name $appinfo->{name})\n".
" (level $appinfo->{level})\n".
" (hostname $XB_Params::node_opts{hostname})\n".
" (addr-blk ovl_net\n".
" (addr_type $type)\n".
" (size $size))\n".
" (addr-blk ovl_link\n".
" (addr_type $type)\n".
" (size $size))\n".
" )\n".
")\n$XB_Params::msg_delimiter\n";
return \$addr_msg;
}
###############################################################################
# EXPORTED API
###############################################################################
### OLD ROUTINES ##############################################################
#== IP Allocator ==============================================================
# Description:
# [VN] Initialize the database & states for IP allocator
# Arguments:
# $ip_ref (ref) hash to store the IP blocks & states
# $netv4 IPv4 net block
# $linkv4 IPv4 link block
# $netv6 IPv6 net block
# $linkv6 IPv6 link block
# Returns:
# 1 on success
# Exceptions:
# "XB_VN_IPalloc::init" on failure, nothing to cleanup by caller
#
sub init($$$$$){
my ($ip_ref, $netv4, $linkv4, $netv6, $linkv6) = @_;
my $procname = "init";
XB_Log::log "info", "-> $modname$procname $ip_ref, $netv4, $linkv4\n".
" $netv6, $linkv6";
eval{
# TODO how about only v4 or only v6?
#=> construct the IP state hash:
# ipv4|ipv6 => netblock, linkblock, maxblock, freelists
$ip_ref->{ipv4}{netblock} = $netv4;
$ip_ref->{ipv4}{linkblock} = $linkv4;
$ip_ref->{ipv6}{netblock} = $netv6;
$ip_ref->{ipv6}{linkblock} = $linkv6;
# - initialize NetAddr objects
my $v4net = new Net::IP::XB_IP $netv4;
my $v4link = new Net::IP::XB_IP $linkv4;
my $v6net = new Net::IP::XB_IP $netv6;
my $v6link = new Net::IP::XB_IP $linkv6;
# - calculate the max block length
$ip_ref->{ipv4}{maxblock} = 32 - $v4net->masklen;
$ip_ref->{ipv6}{maxblock} = 128 - $v6net->masklen;
if (($ip_ref->{ipv4}{maxblock} >= 32) or
($ip_ref->{ipv6}{maxblock} >= 32)){
XB_Log::log "err", "The current implementation of X-Bone has a ".
"limitation that it can support blocks of 31 bits of less ".
" /1 and above for IPv4 and /97 and above for IPv6";
die("initblocksize");
}
# - initialize the list of free blocks:
for (my $i = 0; $i <= $ip_ref->{ipv4}{maxblock}; $i++){
$ip_ref->{ipv4}{free_net_blks}[$i] = [];
$ip_ref->{ipv4}{free_link_blks}[$i] = [];
}
$ip_ref->{ipv4}{free_net_blks}[$ip_ref->{ipv4}{maxblock}] = [$v4net];
$ip_ref->{ipv4}{free_link_blks}[$ip_ref->{ipv4}{maxblock}] = [$v4link];
for (my $i = 0; $i <= $ip_ref->{ipv6}{maxblock}; $i++){
$ip_ref->{ipv6}{free_net_blks}[$i] = [];
$ip_ref->{ipv6}{free_link_blks}[$i] = [];
}
$ip_ref->{ipv6}{free_net_blks}[$ip_ref->{ipv6}{maxblock}] = [$v6net];
$ip_ref->{ipv6}{free_link_blks}[$ip_ref->{ipv6}{maxblock}] = [$v6link];
};
XB_Log::log "info", "<- $modname$procname";
return 1 unless $@;
if($@ =~ /\S+/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$modname$procname";
}
# Description:
# [VN] Allocate a block of IP addresses for a given size & options
# Arguments:
# $freelist (ref) list of free IP blocks in Net::IP::XB_IP objects
# $size size of the request
# $maxblk maximum block size
# Returns:
# $block address block in cidr-format string
# Exceptions:
# "XB_VN_IPalloc::allocate" on failure, nothing to cleanup by caller
#
sub allocate($$$){
my ($freelist, $size, $maxblk) = @_;
my ($block);
my $procname = "allocate";
XB_Log::log "info", "-> $modname$procname $freelist, $size, $maxblk";
eval{
my $i;
# compute $i as the least integer such that $i >= log2($size)
for($i = 0; blocksize $i < $size; $i++) {}
XB_Log::log "debug2", " [$procname] block $i for size $size";
# terminate recursion if we don't have a large enough block left
if($i > $maxblk){
XB_Log::log "err", " [$procname] IP address block allocation ".
"failed: no address block left";
die "addr";
}
my ($buddy);
if(scalar @{ $freelist->[$i] }){
# have a block of that size available
$block = pop @{ $freelist->[$i] };
}else{
# need to split a larger block
$block = allocate $freelist, blocksize $i+1, $maxblk;
# Block manipulation object
$block = new Net::IP::XB_IP $block;
#use a different prefix length to split based on
if ($block->version() == 4){
# split the block into $block & $buddy
($buddy, $block) = $block->split(32-$i);
} else {
# split the block into $block & $buddy
($buddy, $block) = $block->split(128-$i);
}
# push $buddy into freelist
push @{ $freelist->[$i] }, $buddy;
}
# obtain the prefix
$block = $block->cidr;
};
XB_Log::log "info", "<- $modname$procname";
return $block unless $@;
unless($@ =~ /(addr|allocate)/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$modname$procname";
}
# Description:
# [VN] Deallocate the given block, store it back to freelist
# Arguments:
# $freelist (ref) list of free IP blocks in Net::IP::XB_IP objects
# $block block in cidr format to be freed
# Returns:
# 1 on success
# Exceptions:
# "XB_VN_IPalloc::deallocate" on failure, nothing to cleanup by caller
#
# XXX -- this function needs more testing. - Venkata 07/25/2003
sub deallocate($$){
my ($freelist, $block) = @_;
my $procname = "deallocate";
XB_Log::log "info", "-> $modname$procname $freelist, $block";
eval{
# TODO should check if the block is already free
my $i;
my $blk_cidr = $block;
# convert block into Net::IP::XB_IP object
$block = new Net::IP::XB_IP $block;
die ("Invalid block to deallocate") if (not defined $block);
# obtain the size from the masklen
my $maxprefixlen = ($block->version() == 4) ? 32 : 128;
$i = $maxprefixlen - $block->masklen;
XB_Log::log "debug2", " [$procname] deallocating $blk_cidr with size $i";
# find its buddy and merge the block
my $buddy;
# to find the buddy, find the parent first, split it
my $ipaddr = $block->addr;
my $newmask = $block->masklen-1;
my $ip_parent = new Net::IP::XB_IP ("$ipaddr/$newmask");
if (not defined $ip_parent){
#this could happen if the prefix is such that with the new mask,
# the suffix has atleast one bit set. eg., 192.168.1.0/23
push @{ $freelist->[$i] }, $block;
} else {
# parent is defined. This still does not mean there is a
# buddy sitting waiting to be merged with.
my ($ip1, $ip2) = $ip_parent->split($maxprefixlen-$i);
$buddy = ($ip1 eq $block)? $ip2:$ip1;
# check whether this block's buddy is also free
my $buddy_free = 0;
for my $p (@{ $freelist->[$i] }) {
if ($p eq $buddy){
my $bdy_cidr = $buddy->cidr;
$buddy_free = 1;
last;
}
}
unless ($buddy_free) {
# nope, buddy is not free, can't merge buddies
push @{ $freelist->[$i] }, $block;
} else {
# yup, buddy is free, merge the two together to create a larger
# free block
@{ $freelist->[$i]} = grep { $_ ne $buddy } @{ $freelist->[$i] };
deallocate ($freelist, $ip_parent->cidr);
}
}
};
XB_Log::log "info", "<- $modname$procname";
return 1 unless $@;
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
die "$modname$procname";
}
# Description:
# [VN] Show the available IP address blocks for the given freelist
# Arguments:
# $freelist (ref) list of free IP blocks in Net::IP::XB_IP objects
# Returns:
# %free hash of block_size -> cidr_block
# Exceptions:
# -
sub available($$$){
my ($ip_state, $blk_v4, $blk_v6) = @_;
my $procname = "available";
#XB_Log::log "info", "> $modname$procname $ip_state, $blk_v4n, $blk_v4l\n".
# " $blk_v6n, $blk_v6l";
eval{
# code segments:
#sub available () {
#my %result;
#for (my $i = 0; $i <= $maxblock; $i++) {
# foreach my $block (@{ $freelist[$i] }) { $result{$block} = blocksize $i; }
#}
#return %result;
#}
};
XB_Log::log "info", "<- $modname$procname";
return 1 unless $@;
if($@ =~ /\S+/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$modname$procname";
}
# Description:
# [VN] Request 2 blocks of IP addresses for a given size & options
# Arguments:
# $size number of addresses
# $type IPv4 or IPv6
# Returns:
# $net_blk address block for overlay net in CIDR fromat
# $link_blk address block for overlay link in CIDR format
# $server address server
# Exceptions:
# "XB_VN_IPalloc::request" on failure, nothing to cleanup by caller
#
sub request($$;$){
my ($size, $type, $server) = @_;
my $procname = "request";
XB_Log::log "info", "-> $modname$procname $size, $type";
my ($net_blk, $link_blk);
eval{
if($XB_Params::node_state{ip_allocator}){
# is an address allocator itself
my $ipblks = $XB_Params::node_state{ip_blocks};
my $max = $ipblks->{$type}{maxblock};
$net_blk = allocate $ipblks->{$type}{free_net_blks}, $size, $max;
$link_blk = allocate $ipblks->{$type}{free_link_blks}, $size, $max;
#$server = $XB_Params::node_opts{hostname};
$server = "localhost";
}
#elsif($XB_Params::node_opts{addrserv}){
# TODO if obtained from address server, need to passed the server info
# TODO back because we need it to release
# preconfigured address server
# TCP/SSL connect to addrserv
# form & send request to addrserv
# get reply & store blocks into app_obj
#}else{
# by resource discovery
# did we get one?
# [y] store the blocks into app_obj
# store the addrserv to send ack
# [n] die "addr"
#}
};
XB_Log::log "info", "<- $modname$procname net $net_blk, link $link_blk".
" $server";
return ($net_blk, $link_blk, $server) unless $@;
unless ($@ =~ /\b(allocate)\b/){
XB_Log::log "warning", " ! $procname caught unkown exception: $@";
}
die "$modname$procname";
}
# Description:
# [VN] Release blocks of IP addresses
# Arguments:
# $blks (ref) array of address blocks to release
# $server address server
# Returns:
# 1 on success
# Exceptions:
# "XB_VN_IPalloc::release" on failure, nothing to cleanup by caller
#
sub release($$$){
my ($blks, $type, $server) = @_;
my $procname = "release";
my $str = join ", ", @{$blks};
XB_Log::log "info", "-> $modname$procname $str, $type, $server";
eval{
if($server eq "localhost"){
# from localhost
if($XB_Params::node_state{ip_allocator}){
# hack: we know that the first one is net, 2nd one is link
my ($net_blk, $link_blk) = @{$blks};
my $ipblks = $XB_Params::node_state{ip_blocks};
deallocate $ipblks->{$type}{free_net_blks}, $net_blk;
deallocate $ipblks->{$type}{free_link_blks}, $link_blk;
}else{
XB_Log::log "warning", " [$procname] $server is not an addr server!";
die "server";
}
}
#else{
# from remote address server
# preconfigured address server
# TCP/SSL connect to addrserv
# form & send release to addrserv
# get reply & store blocks into app_obj
#}
};
XB_Log::log "info", "<- $modname$procname";
return 1 unless $@;
unless ($@ =~ /\b(deallocate|server)\b/){
XB_Log::log "warning", " ! $procname caught unkown exception: $@";
}
# TODO should we die here?
return 0;
}
#== XBone Overlay IP assignment ===============================================
# Description:
# [VN] Assign IP addresses from the given block to each interface
# Arguments:
# $block an address block in CIDR format
# $ovl (ref) hash of the overlay data structure
# $atype address type (overlay net or link)
# Returns:
# -
# Exceptions:
# -
sub assign($$$){
my ($block, $ovl, $atype) = @_;
my $procname = "assign";
XB_Log::log "info", "-> $modname$procname $block, $ovl, $atype";
eval{
# convert $block into Net::IP::XB_IP object
$block = new Net::IP::XB_IP($block);
my @subnets;
# TODO The following commented lines show 3 styles of assignment:
# TODO 1. subnet per router:
# TODO give each router a subnet, so the hosts of the router will
# TODO be included within the subnet
# TODO 2. continuous assignment:
# TODO assign addresses continuously, will not give each link a /30
# TODO 3. regular:
# TODO treat each link as a /30 subnet and use only the 2nd & 3rd
# TODO of the /30 block; but use the /30's continuously among all
# TODO routers
#if(one subnet per router){
# will waste a lot of addresses :-)
#}elsif(continuous address assignment){
# no per-link subnet :-(
#}else{
#for each router
# for each host link
# pop a /30
# assign 2nd to local
# assign 3rd to remote
# add the /30 to localdest
# for each router link
# if(numbered)
# add local addr to localdest
# else
# pop a /30
# assign 2nd to local
# assign 3rd to remote
# add local to localdest
# do a sanity check.
if((($block->version() == 4) and ($block->masklen > 30))
||(($block->version() == 6) and ($block->masklen > 126))){
my $len = $block->masklen;
XB_Log::log "err", " [$procname] IP address block allocation ".
"failed: block (/$len) too small";
die "masklen";
}
# split the blocks into of 4 addresses
my $bits = ($block->version() == 4)? 30 : 126;
@subnets = $block->split($bits);
my $link_count = scalar (keys %{$ovl->{links}});
my $subnet_count = @subnets;
# check if the block is big enough
if ($link_count > $subnet_count){
XB_Log::log "err", " [$procname] IP address block allocation ".
"failed: not enough /30's! (req $link_count, got $subnet_count)";
die "link";
}
my $nodes = $ovl->{nodes};
for my $n ( keys %{$ovl->{nodes}} ){
my ($blk, $my_if, $remote, $remote_if, $addr1, $addr2);
unless($nodes->{$n}{properties}{type} eq "router"){
next;
}
for my $hl (@{$nodes->{$n}{properties}{host_links}}){
# figure out who the other end is
if($ovl->{links}{$hl}{right_node} eq $n){
$remote = $ovl->{links}{$hl}{left_node};
$remote_if = $ovl->{links}{$hl}{left_if};
$my_if = $ovl->{links}{$hl}{right_if};
}else{
$remote = $ovl->{links}{$hl}{right_node};
$remote_if = $ovl->{links}{$hl}{right_if};
$my_if = $ovl->{links}{$hl}{left_if};
}
$blk = shift @subnets;
$addr1 = ($blk->nth(1))->addr;
$addr2 = ($blk->nth(2))->addr;
XB_Log::log "debug8", " - $hl: $n:$my_if:$addr1 <=> ".
"$remote:$remote_if:$addr2";
$nodes->{$remote}{interfaces}{$remote_if}{$atype} = $addr2;
$nodes->{$n}{interfaces}{$my_if}{$atype} = $addr1;
if($atype eq "netaddr"){
push @{ $nodes->{$n}{properties}{local_dest} }, $blk->cidr;
}
}
for my $rl (@{$nodes->{$n}{properties}{router_links}}){
# figure out who the other end is
if($ovl->{links}{$rl}{right_node} eq $n){
$remote = $ovl->{links}{$rl}{left_node};
$remote_if = $ovl->{links}{$rl}{left_if};
$my_if = $ovl->{links}{$rl}{right_if};
}else{
$remote = $ovl->{links}{$rl}{right_node};
$remote_if = $ovl->{links}{$rl}{right_if};
$my_if = $ovl->{links}{$rl}{left_if};
}
unless(defined $nodes->{$n}{interfaces}{$my_if}{$atype}){
$blk = shift @subnets;
$addr1 = ($blk->nth(1))->addr;
$addr2 = ($blk->nth(2))->addr;
$nodes->{$remote}{interfaces}{$remote_if}{$atype} = $addr2;
$nodes->{$n}{interfaces}{$my_if}{$atype} = $addr1;
}
if($atype eq "netaddr"){
push @{ $nodes->{$n}{properties}{local_dest} },
$nodes->{$n}{interfaces}{$my_if}{$atype};
}
}
}
#}
};
XB_Log::log "info", "<- $modname$procname";
return 1 unless $@;
unless($@ =~ /(masklen|link)/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$modname$procname";
}
### END OLD ROUTINES ##########################################################
#== IP Allocator ==============================================================
# Description:
# [VN] Initialize the database & states for IP allocator
# Arguments:
# $blocks (ref) array of address blocks in CIDR format
# Returns:
# 1 on success
# Exceptions:
# "XB_VN_IPalloc::init" on failure, nothing to cleanup by caller
#
sub new_init($){
my ($blocks) = shift;
my $blks = join ", ", @{$blocks};
my $procname = $modname. "init";
XB_Log::log "info", "-> $procname $blocks ($blks)";
my (%addr_hash);
eval{
unless(@{$blocks} >= 1){
XB_Log::log "err", " [$procname] did not specify any address blocks";
die "none";
}
for my $b (@{$blocks}){
# initialize NetAddr::IP object
my $ip = NetAddr::IP->new($b);
# find IP version
my $ipproto = "ipv". $ip->version;
# get max block length (in bits)
my $maxblk = $ip->bits - $ip->masklen;
unless($maxblk > 2){
XB_Log::log "err", " [$procname] address block is too small, ".
"recommended size of at least 6 bits";
die "small";
}
# only one block per IP version
if(exists $addr_hash{$ipproto}){
XB_Log::log "err", " [$procname] defined two blocks of same IP ".
"protocol ($ipproto)";
die "dupl";
}
# initialize the list of free blocks
my @freeblks;
for (my $i = 0; $i <= $maxblk; $i++){
$freeblks[$i] = [];
}
$freeblks[$maxblk] = [$b];
# have everything, fill in the hash
$addr_hash{$ipproto}{cidr} = $b;
$addr_hash{$ipproto}{maxblock} = $maxblk;
$addr_hash{$ipproto}{addrlen} = $ip->bits;
$addr_hash{$ipproto}{freeblks} = \@freeblks;
}
};
XB_Log::log "info", "<- $procname";
return \%addr_hash unless $@;
if($@ =~ /(none|small|dupl)/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$procname";
}
# Description:
# [VN] Allocate a block of IP addresses for a given size & options
# Arguments:
# $freelist (ref) list of free IP blocks in CIDR-format strings
# $size size of the request
# $maxblk maximum block size
# Returns:
# $block address block in CIDR-format string
# Exceptions:
# "XB_VN_IPalloc::allocate" on failure, nothing to cleanup by caller
#
sub new_allocate($$$){
my ($freelist, $size, $maxblk) = @_;
my ($block);
my $procname = $modname. "allocate";
XB_Log::log "info", "-> $procname $freelist, $size, $maxblk";
eval{
my $i;
# compute $i as the least integer such that $i >= log2($size)
for($i = 0; blocksize $i < $size; $i++) {}
XB_Log::log "debug2", " [$procname] block $i for size $size";
# terminate recursion if we don't have a large enough block left
if($i > $maxblk){
XB_Log::log "err", " [$procname] no address block left";
die "addr";
}
my ($buddy);
if(scalar @{ $freelist->[$i] }){
# have a block of that size available
$block = pop @{ $freelist->[$i] };
}else{
# need to split a larger block
$block = new_allocate $freelist, blocksize $i+1, $maxblk;
# make a NetAddr::IP object to manipulate the block
$block = NetAddr::IP->new($block);
# split the block
($buddy, $block) = $block->split($block->bits - $i);
# push $buddy into freelist
push @{ $freelist->[$i] }, $buddy->cidr;
$block = $block->cidr;
}
};
XB_Log::log "info", "<- $procname $block";
return $block unless $@;
unless($@ =~ /(addr|allocate)/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$procname";
}
# Description:
# [VN] Deallocate the given block, store it back to freelist
# Arguments:
# $freelist (ref) list of free IP blocks in CIDR-format strings
# $block block in CIDR format to be freed
# Returns:
# 1 on success
# Exceptions:
# "XB_VN_IPalloc::deallocate" on failure, nothing to cleanup by caller
#
sub new_deallocate($$){
my ($freelist, $block) = @_;
my $procname = $modname. "deallocate";
XB_Log::log "info", "-> $procname $freelist, $block";
eval{
# TODO should check if the block is already free
my $i;
my $blk_cidr = $block;
# convert block into NetAddr::IP object
$block = NetAddr::IP->new($block);
unless(defined $block){
XB_Log::log "err", " [$procname] invalid block: $blk_cidr";
die "invalid";
}
# obtain the size from the masklen
$i = $block->bits - $block->masklen;
XB_Log::log "debug2", " [$procname] deallocating $blk_cidr (size $i)";
# find its buddy and merge the block
my $buddy;
# to find the buddy, find the parent first, split it
my $ipaddr = $block->addr;
my $newmask = $block->masklen - 1;
my $ip_parent = NetAddr::IP->new("$ipaddr/$newmask");
$ip_parent = $ip_parent->network;
print "Parent0 : $ipaddr/$newmask\n";
if(not defined $ip_parent){
# TODO would only happen if $newmask = -1
push @{ $freelist->[$i] }, $blk_cidr;
}else{
# parent is defined, check if buddy is free
my ($ip1, $ip2) = $ip_parent->split($block->bits - $i);
$buddy = ($ip1 eq $block)? $ip2 : $ip1;
#XB_Log::log "debug3", " [$procname] block : $blk_cidr";
#XB_Log::log "debug3", " [$procname] parent: ". $ip_parent->cidr;
#XB_Log::log "debug3", " [$procname] ip1 : ". $ip1->cidr;
#XB_Log::log "debug3", " [$procname] ip2 : ". $ip2->cidr;
#XB_Log::log "debug3", " [$procname] buddy : ". $buddy->cidr;
# check whether this block's buddy is also free
my $buddy_free = 0;
my @new_array;
for my $p (@{$freelist->[$i]}) {
if ($p eq $buddy->cidr){
$buddy_free = 1;
last;
}
}
unless ($buddy_free) {
# buddy is not free, can't merge buddies
push @{ $freelist->[$i] }, $blk_cidr;
}else{
# buddy is free, merge the two together to create a larger free block
@{ $freelist->[$i]} = grep { $_ ne $buddy->cidr } @{ $freelist->[$i] };
new_deallocate ($freelist, $ip_parent->cidr);
}
}
};
XB_Log::log "info", "<- $procname";
return 1 unless $@;
unless($@ =~ /(invalid)/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$procname";
}
# Description:
# [VN] Show the available IP address blocks for the given freelist
# Arguments:
# $freelist (ref) list of free IP blocks in CIDR format
# Returns:
# %free hash of block_size -> cidr_block
# Exceptions:
# -
sub new_available($$$){
my ($ip_state, $blk_v4, $blk_v6) = @_;
my $procname = "available";
#XB_Log::log "info", "> $modname$procname $ip_state, $blk_v4n, $blk_v4l\n".
# " $blk_v6n, $blk_v6l";
eval{
# code segments:
#sub available () {
#my %result;
#for (my $i = 0; $i <= $maxblock; $i++) {
# foreach my $block (@{ $freelist[$i] }) { $result{$block} = blocksize $i; }
#}
#return %result;
#}
};
XB_Log::log "info", "<- $modname$procname";
return 1 unless $@;
if($@ =~ /\S+/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$modname$procname";
}
# Description:
# [VN] Request 2 blocks of IP addresses for a given size & options
# Arguments:
# $size number of addresses
# $type IPv4 or IPv6
# $appinfo (ref) hash of application info (type, name, level, credential)
# Returns:
# $net_blk address block for overlay net in CIDR fromat
# $link_blk address block for overlay link in CIDR format
# $server address server
# Exceptions:
# "XB_VN_IPalloc::request" on failure, nothing to cleanup by caller
#
sub new_request($$;$){
my ($size, $type, $appinfo) = @_;
my $procname = $modname. "request";
my $argstr = join ", ", @_;
XB_Log::log "info", "-> $procname $argstr";
my ($net_blk, $link_blk, $server, $sock, $failed);
eval{
if($XB_Params::node_state{ip_allocator}){
# is an address allocator itself
my $ipblks = $XB_Params::node_state{ip_blocks};
my $max = $ipblks->{$type}{maxblock};
$net_blk = new_allocate $ipblks->{$type}{freeblks}, $size, $max;
$link_blk = new_allocate $ipblks->{$type}{freeblks}, $size, $max;
$server = "localhost";
$ipblks->{$type}{leases}{$net_blk}{client} = "localhost";
$ipblks->{$type}{leases}{$link_blk}{client} = "localhost";
}elsif($XB_Params::node_opts{addr_server}){
#-> get server & construct address request message
$server = $XB_Params::node_opts{addr_server};
my $addr_req =
"(xbone-ctl $XB_Params::ctl_ver $XB_Params::rel_ver\n".
$appinfo->{credential}. "\n".
" (address_request\n".
" (application $appinfo->{type})\n".
" (name $appinfo->{name})\n".
" (level $appinfo->{level})\n".
" (hostname $XB_Params::node_opts{hostname})\n".
" (addr-blk ovl_net\n".
" (addr_type $type)\n".
" (size $size))\n".
" (addr-blk ovl_link\n".
" (addr_type $type)\n".
" (size $size))\n".
" )\n".
")\n$XB_Params::msg_delimiter\n";
#-> create TCP/SSL socket to server & send the request
# TODO need IP address for IPv6 connection
$sock = XB_Common::tcp_ssl_sock($type, $server,
$XB_Params::node_opts{xbone_ctl_port});
my $sel;
unless($sel = IO::Select->new($sock)){
XB_Log::log "err", " [$procname] select failed: $!" and die "sel";
}
print $sock $addr_req;
#-> receive and process reply
while(my @r = $sel->can_read()){ # TODO timeout
for my $fh (@r){
unless($fh == $sock){
XB_Log::log "warning", " [$procname] wrong socket" and next;
}else{
my $addr_rep = XB_Common::fh_read_until ($fh,
$XB_Params::msg_delimiter);
# parse & process reply
my $ctl_cmd = $XB_CTL_parser::parser->xb_ctl($addr_rep);
XB_Log::log "debug6", " [$procname] CTL cmd:". Dumper($ctl_cmd);
if(not defined $ctl_cmd){
XB_Log::log "err", " [$procname] error parsing message ".
"from $server:\n$addr_rep" and die "parse";
}elsif($ctl_cmd->{command}{command} eq 'address_reply'){
$net_blk = $ctl_cmd->{command}{blocks}{ovl_net}{block};
$link_blk = $ctl_cmd->{command}{blocks}{ovl_link}{block};
XB_Log::log "debug2", " [$procname] from $server:\n".
" o net: $net_blk\n o link: $link_blk";
}elsif($ctl_cmd->{command}{command} eq 'error'){
XB_Log::log "err", " [$procname] $server replied error msg".
" for $ctl_cmd->{command}{err_cmd} command: \n".
" \"$ctl_cmd->{command}{message}\"";
die "err";
}else{
XB_Log::log "err", " [$procname] wrong command: ".
"$ctl_cmd->{command}{command}" and die "cmd";
}
}
$sel->remove($fh);
}
}
}#else{
# by resource discovery
# did we get one?
# [y] store the blocks into app_obj
# store the addrserv to send ack
# [n] die "addr"
#}
};
XB_Log::log "info", "<- $procname net: $net_blk,\n link: $link_blk".
" server: $server";
return ($net_blk, $link_blk, $server) unless $@;
unless ($@ =~ /\b(allocate|ssl_sock|sel|read_until|parse|err|cmd)\b/){
XB_Log::log "warning", " ! $procname caught unkown exception: $@";
}
die "$procname";
}
# Description:
# [VN] Release blocks of IP addresses
# Arguments:
# $blks (ref) array of address blocks to release
# $server address server
# Returns:
# 1 on success
# Exceptions:
# "XB_VN_IPalloc::release" on failure, nothing to cleanup by caller
#
sub new_release($$$){
my ($blks, $type, $server) = @_;
my $procname = $modname. "release";
my $str = join ", ", @{$blks};
XB_Log::log "info", "-> $procname $str, $type, $server";
eval{
if($server eq "localhost"){
# from localhost
if($XB_Params::node_state{ip_allocator}){
my $ipblks = $XB_Params::node_state{ip_blocks};
for my $i (@{$blks}){
new_deallocate $ipblks->{$type}{freeblks}, $i;
delete $ipblks->{$type}{leases}{$i};
}
}else{
XB_Log::log "warning", " [$procname] $server is not an addr server!";
die "server";
}
}
#else{
# from remote address server
# preconfigured address server
# TCP/SSL connect to addrserv
# form & send release to addrserv
# get reply & store blocks into app_obj
#}
};
XB_Log::log "info", "<- $procname";
return 1 unless $@;
unless ($@ =~ /\b(deallocate|server)\b/){
XB_Log::log "warning", " ! $procname caught unkown exception: $@";
}
# TODO should we die here?
return 0;
}
#== XBone Overlay IP assignment ===============================================
# Description:
# [VN] Assign IP addresses from the given block to each interface
# Arguments:
# $block an address block in CIDR format
# $ovl (ref) hash of the overlay data structure
# $atype address type (overlay net or link)
# Returns:
# -
# Exceptions:
# -
sub new_assign($$$){
my ($block, $ovl, $atype) = @_;
my $procname = "assign";
XB_Log::log "info", "-> $modname$procname $block, $ovl, $atype";
eval{
$block = NetAddr::IP->new($block);
my @subnets;
# TODO The following commented lines show 3 styles of assignment:
# TODO 1. subnet per router:
# TODO give each router a subnet, so the hosts of the router will
# TODO be included within the subnet
# TODO 2. continuous assignment:
# TODO assign addresses continuously, will not give each link a /30
# TODO 3. regular:
# TODO treat each link as a /30 subnet and use only the 2nd & 3rd
# TODO of the /30 block; but use the /30's continuously among all
# TODO routers
#if(one subnet per router){
# will waste a lot of addresses :-)
#}elsif(continuous address assignment){
# no per-link subnet :-(
#}else{
#for each router
# for each host link
# pop a /30
# assign 2nd to local
# assign 3rd to remote
# add the /30 to localdest
# for each router link
# if(numbered)
# add local addr to localdest
# else
# pop a /30
# assign 2nd to local
# assign 3rd to remote
# add local to localdest
my $bits = $block->bits - 2;
@subnets = $block->split($bits);
my $link_count = scalar (keys %{$ovl->{links}});
my $subnet_count = @subnets;
# check if the block is big enough
if ($link_count > $subnet_count){
XB_Log::log "err", " [$procname] not enough /30's! (req ".
"$link_count, got $subnet_count";
die "link";
}
my $nodes = $ovl->{nodes};
for my $n ( keys %{$ovl->{nodes}} ){
my ($blk, $my_if, $remote, $remote_if, $addr1, $addr2);
unless($nodes->{$n}{properties}{type} eq "router"){
next;
}
for my $hl (@{$nodes->{$n}{properties}{host_links}}){
# figure out who the other end is
if($ovl->{links}{$hl}{right_node} eq $n){
$remote = $ovl->{links}{$hl}{left_node};
$remote_if = $ovl->{links}{$hl}{left_if};
$my_if = $ovl->{links}{$hl}{right_if};
}else{
$remote = $ovl->{links}{$hl}{right_node};
$remote_if = $ovl->{links}{$hl}{right_if};
$my_if = $ovl->{links}{$hl}{left_if};
}
$blk = shift @subnets;
$addr1 = ($blk->nth(1))->addr;
$addr2 = ($blk->nth(2))->addr;
XB_Log::log "debug8", " - $hl: $n:$my_if:$addr1 <=> ".
"$remote:$remote_if:$addr2";
$nodes->{$remote}{interfaces}{$remote_if}{$atype} = $addr2;
$nodes->{$n}{interfaces}{$my_if}{$atype} = $addr1;
if($atype eq "netaddr"){
push @{ $nodes->{$n}{properties}{local_dest} }, $blk->cidr;
}
}
for my $rl (@{$nodes->{$n}{properties}{router_links}}){
# figure out who the other end is
if($ovl->{links}{$rl}{right_node} eq $n){
$remote = $ovl->{links}{$rl}{left_node};
$remote_if = $ovl->{links}{$rl}{left_if};
$my_if = $ovl->{links}{$rl}{right_if};
}else{
$remote = $ovl->{links}{$rl}{right_node};
$remote_if = $ovl->{links}{$rl}{right_if};
$my_if = $ovl->{links}{$rl}{left_if};
}
unless(defined $nodes->{$n}{interfaces}{$my_if}{$atype}){
$blk = shift @subnets;
$addr1 = ($blk->nth(1))->addr;
$addr2 = ($blk->nth(2))->addr;
$nodes->{$remote}{interfaces}{$remote_if}{$atype} = $addr2;
$nodes->{$n}{interfaces}{$my_if}{$atype} = $addr1;
}
if($atype eq "netaddr"){
push @{ $nodes->{$n}{properties}{local_dest} },
$nodes->{$n}{interfaces}{$my_if}{$atype};
}
}
}
#}
};
XB_Log::log "info", "<- $modname$procname";
return 1 unless $@;
unless($@ =~ /(masklen|link)/){
XB_Log::log "warning", " ! $procname caught unknown exception: $@";
}
die "$modname$procname";
}
1;
syntax highlighted by Code2HTML, v. 0.9.1