#!/usr/bin/perl -wT
#
# Copyright (c) 2000-2016 University of Utah and the Flux Group.
# 
# {{{EMULAB-LICENSE
# 
# This file is part of the Emulab network testbed software.
# 
# This file is free software: you can redistribute it and/or modify it
# under the terms of the GNU Affero General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
# 
# This file is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Affero General Public
# License for more details.
# 
# You should have received a copy of the GNU Affero General Public License
# along with this file.  If not, see <http://www.gnu.org/licenses/>.
# 
# }}}
#
use strict;
use English;
use Getopt::Std;

#
# Figure out the basic shaping params for the delay agent and print
# them out. 1000 times easier to do this in perl then in C, and its
# not critical that it be super fast anyway. This is used by the
# delay-agent event handler to get the current shaping params. 
#

# Drag in path stuff so we can find emulab stuff.
BEGIN { require "/etc/emulab/paths.pm"; import emulabpaths; }

sub usage()
{
    print "Usage: foo [-d] linkname\n";
    exit(1);
}
my $optlist   = "d";
my $debug     = 0;
my $linkname;

#
# Turn off line buffering on output
#
$| = 1;

usage()
    if (!@ARGV);
$linkname = shift(@ARGV);

#
# Load the OS independent support library. It will load the OS dependent
# library and initialize itself.
#
use libsetup;

my $TMDELMAP	= TMDELMAP;	# Really comes from libloc.
my $IFCONFIG    = "/sbin/ifconfig";
my $TC          = "/usr/local/sbin/tc";       # This is the working version!
my $IPTABLES    = "/usr/local/sbin/iptables"; # This is the working version!
# Unless they do not exist!
$TC = "/sbin/tc" if (! -e $TC);
$IPTABLES = "/sbin/iptables" if (! -e $IPTABLES);

# What kind of shaping do we have going.
my $usenetem = 0;
my $useifb   = 0;
my $linktype;
my $iface;
my $idev;
my $pipe1;
my $pipe2;

# Parameters for the link.
my $bw;
my $bwspec;
my $delay = 0;
my $plr   = 0.0;
my $qlen  = 0;
my $rbw;
my $rbwspec;
my $rdelay= 0;
my $rplr  = 0.0;
sub getShapingParams($);

system("modinfo ifb 2>&1 >/dev/null");
if ($? == 0) {
    $useifb = 1;
    if ($debug) {
	print "Switching to ifb mode\n";
    }
}
system("modinfo sch_netem 2>&1 >/dev/null");
if ($? == 0) {
    $usenetem = 1;
    if ($debug) {
	print "Switching to netem mode\n";
    }
}

#
# Load the delay mapping file and search for the link entry. 
#
open(MAP, "$TMDELMAP")
    or die("Could not open $TMDELMAP");
while (<MAP>) {
    if ($_ =~ /^([-\w]+) simplex [-\w]+ ([-\w]+) (\d+)/) {
	if ($debug) {
	    print "Found simplex link: iface:$iface, pipe:$pipe1\n";
	}
	if ($1 eq $linkname) {
	    $linktype = "simplex";
	    $iface    = $2;
	    $pipe1    = $3;
	    last;
	}
    }
    elsif ($_ =~
	   /^([-\w]+) duplex [-\w]+ [-\w]+ ([-\w]+) ([-\w]+) (\d+) (\d+)/) {
	if ($debug) {
	    print "Found duplex link: iface:$iface, idev:$idev, ".
		"pipe1:$pipe1, pipe2:$pipe2\n";
	}
	if ($1 eq $linkname) {
	    $linktype = "duplex";
	    $iface    = $2;
	    $idev     = $3;
	    $pipe1    = $4;
	    $pipe2    = $5;
	    last;
	}
    }
    else {
	die("Could not parse line from delay map: $_");
    }
}
close(MAP);

if (!$iface) {
    die("Could not find interface $linkname!\n");
}

#
# We are looking for bw/delay/plr primarily, but also queue info.
#
if ($usenetem) {
    my $tmp = `$IFCONFIG $iface | grep txqueuelen`;
    if ($?) {
	die("$IFCONFIG failed, trying to get txqueuelen for $iface");
    }
    if ($tmp =~ /txqueuelen:(\d+)/) {
	$qlen = $1;
    }
    else {
	die("Could not get txqueuelen for $iface");
    }

    # This gets plr and delay on the outgoing side.
    ($bw, $bwspec, $delay, $plr) = getShapingParams($iface);
    # For duplex delays, we need the reverse parameters too.
    if ($linktype eq "duplex") {
	($rbw, $rbwspec, $rdelay, $rplr) = getShapingParams($idev);
    }
}
else {
    die("Only supporting netem module\n");
}
if ($debug) {
    print "bw:${bw} $bwspec, delay:${delay}ms, plr:$plr, qlen:$qlen\n";
    if ($linktype eq "duplex") {
	print "rbw:${bw} $rbwspec, rdelay:${delay}ms, rplr:$plr\n";
    }
}
printf "bw:%d %s delay:%d plr:%.3f qlen:%d\n", $bw, $bwspec,$delay, $plr, $qlen;
if ($linktype eq "duplex") {
    printf "rbw:%d %s rdelay:%d rplr:%.3f\n", $rbw, $rbwspec, $rdelay, $rplr;
}
exit(0);

#
# Get the bw/delay/plr for an iface device.
#
sub getShapingParams($)
{
    my ($iface) = @_;
    my $bw    = 0;
    my $bwspec= "";
    my $delay = 0;
    my $plr   = 0.0;
    
    open(TC, "$TC qdisc show dev $iface |")
	or die("Could not start TC");
    while (<TC>) {
	if ($_ =~ /^qdisc netem .* delay ([\.\d]+)(\w+)/) {
	    # Unit sillyness.
	    $delay = $1;
	    if ($2 eq "s") {
		$delay = $delay * 1000;
	    }
	    elsif ($2 eq "us") {
		$delay = int(($delay / 1000.0) + 0.5);
	    }
	}
	if ($_ =~ /^qdisc netem .* loss ([\.\d]+)/) {
	    # We get back percent, convert back to 0-1.
	    $plr = $1 / 100.0;
	}
    }
    close(TC) or die("$TC qdisc failed");
    # This gets bandwidth on the outgoing side.
    open(TC, "$TC class show dev $iface |")
	or die("Could not start TC");
    while (<TC>) {
	if ($_ =~ /^class htb .* rate ([\.\d]+)(\w+)/) {
	    $bw = $1;
	    $bwspec = $2;
	}
    }
    close(TC) or die("$TC qdisc failed");
    return ($bw, $bwspec, $delay, $plr);
}
