### 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;