### 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_Dummynet.pm,v $
#
# $Revision: 1.21 $
#   $Author: pingali $
#     $Date: 2005/03/31 07:03:55 $
#    $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Nop Vanitcha

package XB_Dummynet;

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(up down is_present);

use strict;
use sigtrap;

use XB_Params;
use XB_Route;
use XB_Log;


# Description:
#	Add a dummynet pipe.
#
# Arguments:
#	$l	local address (outer header source)
#	$r	remote address (outer header destination)      	
#       $n      pipe number
#       $dir    direction
#
# Returns:
#       - 
#
# Exceptions:
#	"XB_Dummynet::add_pipe" on error, nothing to clean up by caller

sub add_pipe ($$$$) {
  my $proc = "XB_Dummynet::add_pipe";
  XB_Log::log "info", "-> $proc: @_";
  
  # this function is so simple, we don't need our normal exception magic
  my ($l, $r, $n, $dir) = @_;
  my @cmd = ("ipfw", "-q", "-f", "add", $n, "pipe", $n, "ip",
	     "from", $l, "to", $r, $dir);
#  open SAVEOUT, ">&STDOUT"; open STDOUT, ">/dev/null";  # suppress STDOUT
#  open SAVEERR, ">&STDERR"; open STDERR, ">/dev/null";  # suppress STDERR
  XB_Log::log "debug6", "[$proc] executing @cmd ";
  my $rc = 0xff & system(@cmd);
  ($rc == 0) or XB_Log::log "err", 
    "Unable to configure the traffic shaper. @cmd failed: $!" and die $proc;
#  open STDERR, ">&SAVEERR"; # reenable STDERR
#  open STDOUT, ">&SAVEOUT"; # reenable STDOUT
  
  XB_Log::log "info", "<- $proc";
}




# Description:
#	Delete a dummynet pipe.
#
# Arguments:
#       $n     pipe number (can be used as rule number)
#
# Returns:
#	-
#
# Exceptions:
#	"XB_Dummynet::delete_pipe" on error, nothing to clean up by caller

sub delete_pipe ($) {
  my $proc = "XB_Dummynet::delete_pipe";
  XB_Log::log "info", "-> $proc: @_";

  # this function is so simple, we don't need our normal exception magic
  my @cmd = ("ipfw", "-q", "-f", "delete", shift);
#  open SAVEOUT, ">&STDOUT"; open STDOUT, ">/dev/null";  # suppress STDOUT
#  open SAVEERR, ">&STDERR"; open STDERR, ">/dev/null";  # suppress STDERR
  my $rc = 0xff & system(@cmd);
  ($rc == 0) or XB_Log::log "err", 
    "Unable to deconfigure the traffic shaper. @cmd failed: $!" and die $proc;
#  open STDERR, ">&SAVEERR"; # reenable STDERR
#  open STDOUT, ">&SAVEOUT"; # reenable STDOUT

  XB_Log::log "info", "<- $proc";
}



# Description:
#	Configure a dummynet pipe.
#
# Arguments:
#       $n      pipe number
#       %args   dummynet settings
#
# Returns:
#	-
#
# Exceptions:
#	"XB_Dummynet::config_pipe" on error, nothing to clean up by caller

sub config_pipe ($$) {
  my $proc = "XB_Dummynet::config_pipe";
  XB_Log::log "info", "-> $proc: @_";

  # this function is so simple, we don't need our normal exception magic
  my ($n, $args) = @_;
  my @cmd = ("ipfw", "-q", "-f", "pipe", $n, "config");

  if (defined $args->{delay}) { push @cmd, "delay", $args->{delay}; }
  if (defined $args->{loss_rate}) { push @cmd, "plr", $args->{loss_rate}; }
  if (defined $args->{bandwidth}) {
    push @cmd, "bw", $args->{bandwidth}.$args->{bandwidth_unit};
  }
  if (defined $args->{queue}) {
    push @cmd, "queue", $args->{queue}.$args->{queue_unit};
  }
#  open SAVEOUT, ">&STDOUT"; open STDOUT, ">/dev/null";  # suppress STDOUT
#  open SAVEERR, ">&STDERR"; open STDERR, ">/dev/null";  # suppress STDERR
  XB_Log::log "debug6", "[$proc] executing @cmd ";
  my $rc = 0xff & system(@cmd); 
  ($rc == 0) or XB_Log::log "err", 
    "Unable to configure the traffic shaper. @cmd failed: $!" and die $proc;
#  open STDERR, ">&SAVEERR"; # reenable STDERR
#  open STDOUT, ">&SAVEOUT"; # reenable STDOUT

  XB_Log::log "info", "<- $proc";
}



# Description:
#	Delete a dummynet pipe configuration.
#
# Arguments:
#       $n     pipe number (can be used as rule number)
#
# Returns:
#	-
#
# Exceptions:
#	"XB_Dummynet::delete_config_pipe" on error, nothing to clean
#	up by caller

sub delete_config_pipe ($) {
  my $proc = "XB_Dummynet::delete_config_pipe";
  XB_Log::log "info", "-> $proc: @_";

  # this function is so simple, we don't need our normal exception magic
  my @cmd = ("ipfw", "-q", "-f", "pipe", "delete", shift);
#  open SAVEOUT, ">&STDOUT"; open STDOUT, ">/dev/null";  # suppress STDOUT
#  open SAVEERR, ">&STDERR"; open STDERR, ">/dev/null";  # suppress STDERR
  XB_Log::log "debug6", "[$proc] executing @cmd ";
  my $rc = 0xff & system(@cmd);
  ($rc == 0) or XB_Log::log "err", 
    "Unable to deconfigure the traffic shaper. @cmd failed: $!" and die $proc;
#  open STDERR, ">&SAVEERR"; # reenable STDERR
#  open STDOUT, ">&SAVEOUT"; # reenable STDOUT

  XB_Log::log "info", "<- $proc";
}

# Description:
#	Configure dummynet.
#
# Arguments:
#	$l	local virtual address (inner header source)
#	$r	remote virtual address (inner header destination)
#       %args   dummynet settings such as delay, bandwidth, loss probability.
#
# Returns:
#	dummynet handle for FreeBSD
#
# Exceptions:
#	"XB_Dummynet::up" on error, nothing to clean up by caller

sub up ($$$) {
  my $proc = "XB_Dummynet::up";
  XB_Log::log "info", "-> $proc: @_";

  my ($l, $r, $args) = @_;
  my @rules = ();
  
  if ($XB_Params::node_opts{os} =~ /linux/i) {
    eval {
      my $cmd = "cnistnet -u";
      my $rc = 0xff & system ($cmd);
      ($rc == 0) or XB_Log::log "err", "unable to configure nistnet".
	" $cmd failed: $!" and die "nistnet";
      
      # remove any rule from $r to $l
      $cmd = "cnistnet -r $r $l";
      $rc = 0xff & system ($cmd);
      ($rc == 0) or  XB_Log::log "err", "unable to configure nistnet".
        " $cmd failed: $!" and die "nistnet";
      my $delay = $args->{delay}; 
      $cmd = "cnistnet -a $r $l add new";
      if (defined $args->{delay}) {$cmd = $cmd." --delay $delay";}
      if (defined $args->{loss_rate}) {
        my $lossrate = $args->{loss_rate}*100;
        $cmd = $cmd." --drop $lossrate";
      }
      if (defined $args->{bandwidth}) {
        if ($args->{bandwidth_unit} eq "Mbit/s") {
          my $bandwidth = $args->{bandwidth}*1000/8;
          $cmd = $cmd. " --bandwidth $bandwidth";
        } elsif ($args->{bandwidth_unit} eq "bit/s") {
          my $bandwidth = $args->{bandwidth}/8;
          $cmd = $cmd." --bandwidth $bandwidth";
        }
      }
      if (defined $args->{queue}) {
        $cmd = $cmd. " --drd $args->{queue}, $args->{queue}";
      }
      XB_Log::log "debug6", "[$proc] executing $cmd ";
      $rc = 0xff & system($cmd);
      ($rc == 0) or XB_Log::log "err", "unable to configure nistnet".
        "$cmd failed: $!" and die "nistnet";
    };  
     # exception handling
    if ($@) {
      unless($@ =~ /^nistnet/) {
        # unknown exception caught, log and pass up a defined one
        XB_Log::log "warning", "$proc: caught unexpected exception $@";
      }
      # pass defined exceptions up to caller
      die $proc;
    }
  } else {
    # Default (FreeBSD)
    eval {
      foreach my $x ([$l, $r, "out"], [$r, $l, "in"]) {
        my ($a, $b, $dir) = @$x;
        # We need to find an unused ipfw rule number for the new
        # pipe rule. What we do is put all the used rule numbers
        # into a hash, pick a random rule, and then search linearly
        # from there upwards until we find an empty one. This only
        # works well if the rule number table is sparsely populated
        # (but much better than Nop's original scheme).
        my %used_rules;
        my $pipe = "ipfw -q -f pipe list |";
        open PIPE, $pipe
	  or XB_Log::log "err", 
	    "Unable to obtain traffic shaper information." . 
	    "cannot open $pipe: $!" and die "open";
        while(<PIPE>) { if(/^(\d+):/) { $used_rules{$1} = 1; } }
        close PIPE
	  or XB_Log::log "err", 
	    "Unable to obtain traffic shaper information.". 
	    "cannot close $pipe: $!" and die "close";
        # since we use pipe numbers as rule numbers, we need to find one
        # that's unused in both
        $pipe = "ipfw -q -f list |";
        open PIPE, $pipe
	  or XB_Log::log "err", 
	    "Unable to obtain traffic shaper information.". 
	    "cannot open $pipe: $!" and die "open";
        while(<PIPE>) { if(/^(\d+)\s/) { $used_rules{$1} = 1; } }
        close PIPE
	  or XB_Log::log "err", 
	    "Unable to configure traffic shaper. cleanup failed.". 
	    "cannot close $pipe: $!" and die "close";
      
        # starting at a random rule 0 <= n < 65535, look for an unused
        # one and wrap around if needed
        my $n = int rand 65535;
        my $n_original = $n;
        while(exists $used_rules{$n}) {
	  # wrap around if we hit the limit
	  if (++$n >= 65535) { $n = 0; }
	  # check if the number space is exhausted
	  if ($n == $n_original) { 
	    XB_Log::log "err", 
	        "Unable to configure the traffic shaper.". 
	        "no available ipfw rule numbers" and die "rule";
	  }
        }
      
        # use rule number n for the pipe
        eval { 
	  add_pipe $a, $b, $n, $dir;
        };
        if ($@){
	  delete_pipe $n; 
	  XB_Log::log "err", "Unable to configure traffic shaper. ". 
	      "Error while creating a pipe";
	  die($@);
        }

        eval { 
	  config_pipe $n, $args;
        }; 
        if ($@){
	  delete_config_pipe $n; 
	  XB_Log::log "err", "Unable to configure traffic shaper. ". 
	      "Error while configuring the pipe";
	  die($@);
        }      

        # remember the rule number used, so we can create a tag below
        push @rules, $n;
      }
    };
    # exception handling
    if ($@) {
      unless($@ =~ /^(open|close|rule|XB_Dummynet::(add|config)_pipe)/) {
        # unknown exception caught, log and pass up a defined one
        XB_Log::log "warning", "$proc: caught unexpected exception $@";
      }
      # pass defined exceptions up to caller
      die $proc;
    }
  }

  XB_Log::log "info", "<- $proc";
  return join ":", @rules unless $@; # success if no exception
}


# Description:
#	Tear down dummynet pipe.
#
# Arguments:
#	$tag  tag (return value from corresponding XB_Dummynet::up)
#
# Returns:
#	-
#
# Exceptions:
#	"XB_Dummynet::down" on error, nothing to clean up by caller

sub down ($) {
  my $proc = "XB_Dummynet::down";
  XB_Log::log "info", "-> $proc";

  # set if *any* error occurred - we don't throw exceptions during
  # ::down, so we can take down as much as we can
  my $failure = 0;
  
  if ($XB_Params::node_opts{os} =~ /linux/i) {
     # Linux OS
    eval {
      XB_Log::log "debug6", "execute cnistnet -d";
      my $pipe = "cnistnet -d |";
      open PIPE, $pipe
        or XB_Log::log "err",
          "Unable to obtain nistnet information." .
          "cannot open $pipe:$!" and die "open";
      while (<PIPE>) {
        XB_Log::log "err", "nistnet is not sucessfully installed"
          and die "nistnet";
      }
      close PIPE
        or XB_Log::log "err",
          "Unable to obtain nistnet information.".
          "cannot close $pipe: $!" and die "close";
    };
    if ($@) {$failure = 1; XB_Log::log "info", "-> $@";}
  } else {
    # Default FreeBSD
    # unwrap rule number from opaque dummynet tag
    foreach my $n (split /:/, shift) {
      eval { delete_pipe $n };
      if ($@ =~ /^XB_Dummynet/) { $failure = 1; XB_Log::log "info", "-> $@";}
      eval { delete_config_pipe $n };
      if ($@ =~ /^XB_Dummynet/) { $failure = 1; XB_Log::log "info", "-> $@";}
    }
  }

  XB_Log::log "info", "<- $proc";
  return unless $failure; # success if no exception

  # pass defined exceptions up to caller (no matter which one)
  die $proc;
}



# Description: 
#	Check if Dummynet is available on a host.
# Arguments:
#	-
# Returns:
#	1 if Dummynet is available, 0 otherwise.
# Exceptions:
#	-
sub is_present () {
  XB_Log::log "info", "-> XB_Dummynet::is_present";
  
  my $proc = "XB_Dummynet::is_present";
  my $result = 0;
  if($XB_Params::node_opts{os} =~ /freebsd|kame/) { 
    # On FreeBSD, test for Dummynet by trying to read from the
    # "net.inet.ip.dummynet.curr_time" sysctl switch. If that
    # succeeds, Dummynet is present.
    eval { $result = XB_Utils::sysctl_read "net.inet.ip.dummynet.curr_time" };
    $result = defined $result;
  }
  elsif ($XB_Params::node_opts{os} =~ /linux/i) {
    eval {
      my $pipe = "which cnistnet |";
      open PIPE, $pipe
        or XB_Log::log "err", "Unable to obtain nistnet information." .
	  "cannot open $pipe:$!" and die "open";
      my $path = <PIPE>;
      if(defined $path) {
        close PIPE or XB_Log::log "err", 
          "cannot close $pipe: $!" and die "close";
        $result = 1 if ($path ne "");
      }
    };
    if ($@) {
      unless ($@ =~ /^(open|close)/) {
	# unknown exception caught, log and pass up a defined one
	XB_Log::log "warning", "$proc: caught unexpected exception $@";
      }
      die $proc;
    }
  }
  XB_Log::log "info", "<- XB_Dummynet::is_present";
  return $result;
}

1;