#!/usr/bin/perl -w
#
# Copyright (c) 2000-2020 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 English;
use Getopt::Std;

#
# Setup/Update the system with new delays. Use -i for install mode, which
# means to run the scripts so that the delays are installed. Use -u for
# uninstall mode, which really only makes sense when used in conjunction
# with -j. On a real delay node, no real need to do an uninstall; an install
# flushes the current rules for the entire node. 
#
sub usage()
{
    print "Usage: delaysetup [-i | -u | -r] [-j <vnodeid>]\n";
    exit(1);
}
my $optlist	= "iurj:";
my $install	= 0;
my $uninstall	= 0;
my $reinstall   = 0;
my $vnodeid;

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

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

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

#
# Must be root.
#
if ($EUID) {
    die("*** $0:\n".
	"    Must be run as root!\n");
}

#
# Parse command arguments. Once we return from getopts, all that should be
# left are the required arguments.
#
%options = ();
if (! getopts($optlist, \%options)) {
    usage();
}
if (defined($options{"i"})) {
    $install = 1;
}
if (defined($options{"u"})) {
    $uninstall = 1;
}
if (defined($options{"r"})) {
    $reinstall = 1;
}
if (defined($options{"j"})) {
    $vnodeid = $options{"j"};
    libsetup_setvnodeid($vnodeid);
    # Tell tmcc library, although thats already been done with previous call.
    configtmcc("subnode", $vnodeid);
}
if (@ARGV) {
    usage();
}

# XXX not yet
if (INXENVM()) {
    exit(0);
}

sub checkkernel($$);

$FBSD_VERSION = `uname -v`;

if ($FBSD_VERSION =~ /FreeBSD ([0-9]+).*/) {
    $FBSD_VERSION = int($1);
}
else {
    die("*** $0:\n".
	"    Cannot determine version\n");
}

my $canbackfill = 0;

#
# Delay node configuration goop.
# First figure out our kernels.
#
my $KERNELDELAY;	# kernel for delay nodes
my $KERNELDELAYHZ;	# HZ for delay node kernel
my $KERNELLDELAY;	# kernel for linkdelays
my $KERNELLDELAYHZ;	# HZ for linkdelay kernel
my $KERNELJAIL;		# kernel for jails (implies linkdelays)
my $KERNELJAILHZ;	# HZ for jail kernel

if ($FBSD_VERSION <= 4) {
    if (-e "/kernel") {
	# newer 4.x setup
	$KERNELDELAY  = "/kernel.delay";
	$KERNELLDELAY = "/kernel.linkdelay";
	$KERNELJAIL   = "/kernel.jail";
    } else {
	# old 4.x setup
	$KERNELDELAY  = "/kernel.10000HZ";
	$KERNELLDELAY = "/kernel.1000HZ";
	$KERNELJAIL   = "/kernel.1000HZ";
    }
    $canbackfill = 1;
}
elsif ($FBSD_VERSION == 5) {
    # 5.x
    $KERNELDELAY = "/boot/kernel.delay/kernel";
    $KERNELJAIL  = "/boot/kernel.linkdelay/kernel";
    $KERNELLDELAY= "/boot/kernel.linkdelay/kernel";
}
elsif ($FBSD_VERSION < 8 && ($FBSD_VERSION != 7 || -d "/boot/kernel.poll")) {
    # for 6.x and 7.x, we use the same kernel for all.
    # XXX ok not quite yet til we characterize the effect of polling.
    $KERNELDELAY = "/boot/kernel.poll/kernel";
    $KERNELJAIL = $KERNELLDELAY = "/boot/kernel/kernel";
}
else {
    # for 8.x and above, we really do use the same kernel for all.
    $KERNELDELAY = $KERNELJAIL = $KERNELLDELAY = "/boot/kernel/kernel";
}

# for all kernels right now
$KERNELDELAYHZ  = 10000;
$KERNELLDELAYHZ = 1000;
$KERNELJAILHZ   = 1000;

# This should never happen!
if ((REMOTE() && !REMOTEDED()) || MFS()) {
    print "Skipping delay configuration on remote/MFS node!\n";
    exit(0);
}

print "Checking Testbed delay configuration ... \n";

# Uninstall just looks for the files, runs them, and exits.
if ($reinstall || $uninstall) {
    system(TMDELAY . " disable")
	if (-e TMDELAY);

    system(TMLINKDELAY . " disable")
	if (-e TMLINKDELAY);
    exit(0)
	if ($uninstall);
}

#
# Figure out the current clock rate
#
my $currenthz = 0;
if ($FBSD_VERSION >= 6) {
    $currenthz = `sysctl -n kern.clockrate 2>/dev/null`;
    if ($currenthz =~ /hz = (\d+),/) {
	$currenthz = int($1);
    }
}

#
# Update the delays configuration. Also run the the commands to make
# the changes. Since a node cannot be doing delays and linkdelays at the
# same time, try each and exit.
#
if (DelaySetup()) {
    exit(1);
}
if (-e TMDELAY) {
    system(TMDELAY . " enable")
	if ($install || $reinstall);
    exit(0);
}

if (LinkDelaySetup()) {
    exit(1);
}
if (-e TMLINKDELAY) {
    system(TMLINKDELAY . " enable")
	if ($install || $reinstall);
    exit(0);
}
exit(0);

#
# This sets up delays on a delay node.
#
sub DelaySetup
{
    my @delays;
    my $kernel;
    my $kernelhz;

    # Lets clean out old instructions.
    unlink TMDELAY;
    unlink TMDELMAP;

    if (tmcc(TMCCCMD_DELAY, undef, \@delays) < 0) {
	warn("*** WARNING: Could not get delays from server!\n");
	return -1;
    }

    #
    # Determine the native speed of the interfaces. We use this to decide
    # whether we need to set the BW in dummynet.
    #
    my %nativebw = ();
    my @ifinfo;
    if (tmcc(TMCCCMD_IFC, undef, \@ifinfo) >= 0) {
	#
	# Don't need fancy parsing ala getifconfig, we just need the
	# mac/name/speed.
	#
	foreach my $str (@ifinfo) {
	    if ($str =~ /^INTERFACE .*MAC=(\w+) SPEED=(\w+)/) {
		my $ifname = findiface($1);
		my $speed = $2;
		if ($speed =~ /(\d+)(\D*)/) {
		    if ($2 eq "Kbps") {
			$nativebw{$ifname} = $1;
		    } elsif ($2 eq "Mbps") {
			$nativebw{$ifname} = $1 * 1000;
		    }
		}
	    }
	}
    } else {
	warn("*** WARNING: Could not get interface config from server!\n");
    }

    # If we have any 10Gb interfaces, we may need to tweak some settings
    my $using10g = 0;
    foreach my $nif (keys %nativebw) {
	if ($nativebw{$nif} >= 10000) {
	    $using10g = 1;
	    last;
	}
    }

    if (@delays) {
	my $mindelay = 10000;
	my @bridges  = ();

	# before going any further, see if we need to boot a new kernel
 	if (-e $KERNELDELAY) {
 	    $kernel = $KERNELDELAY;
 	    $kernelhz = $KERNELDELAYHZ;
 	} else {
 	    $kernel = $KERNELLDELAY;
 	    $kernelhz = $KERNELLDELAYHZ;
 	}
	if (checkkernel($kernel, $kernelhz)) {
	    return -1;
	}

	open(MAP, ">" . TMDELMAP)
	    or die("Could not open " . TMDELMAP . ": $!");

	open(DEL, ">" . TMDELAY)
	    or die("Could not open " . TMDELAY . ": $!");

	my $bix = 1;
	foreach $delay (@delays) {
	    $delay =~ /DELAY INT0=([\d\w]+) INT1=([\d\w]+) /;
	    my $iface1 = findiface($1);
	    my $iface2 = findiface($2);
	    push @bridges, [ $bix, $iface1, $iface2 ];
	    $bix++;
	}

	print DEL "#!/bin/sh\n";
	print DEL "# auto-generated by delaysetup.pm, DO NOT EDIT\n";
	print DEL "if [ x\$1 = x ]; then action=enable; else action=\$1; fi\n";

	#
	# Shutdown: undo only the stuff that might get redone during
	# a reconfig.
	#
	print DEL "if [ \"\$action\" = \"disable\" ]; then\n";

	# bridging
	if ($FBSD_VERSION <= 4) {
	    print DEL "    sysctl -w net.link.ether.bridge=0\n";
	    print DEL "    sysctl -w net.link.ether.bridge_ipfw=0\n";
	}
	elsif ($FBSD_VERSION <= 6) {
	    print DEL "    sysctl -w net.link.ether.bridge.enable=0\n";
	    print DEL "    sysctl -w net.link.ether.bridge.ipfw=0\n";
	}
	else {
	    foreach my $bridge (@bridges) {
		my ($bix) = @$bridge;
		print DEL "    ifconfig bridge$bix down destroy\n";
	    }
	    print DEL "    sysctl -w net.link.bridge.ipfw=0\n";
	    print DEL "    sysctl -w net.link.bridge.ipfw_arp=0\n";
	    if ($FBSD_VERSION >= 10) {
		print DEL "    sysctl -w net.link.ether.ipfw=0\n";
	    }
	}

	# ipfw pipes
	print DEL "    ipfw -f pipe flush\n";
	print DEL "    ipfw -q flush\n";
	if ($FBSD_VERSION >= 6) {
	    print DEL "    ipfw add 65534 allow all from any to any\n";
	}

	# polling
	if ($FBSD_VERSION >= 8) {
	    print DEL "    if [ -n \"`sysctl kern.polling.phase 2>/dev/null`\" ]; then\n";
	} else {
	    print DEL "    if [ -n \"`sysctl kern.polling.enable 2>/dev/null`\" ]; then\n";
	}
	if ($FBSD_VERSION >= 6) {
	    foreach my $bridge (@bridges) {
		my (undef,$if1,$if2) = @$bridge;
		print DEL "        ifconfig $if1 -polling\n";
		print DEL "        ifconfig $if2 -polling\n";
	    }
	} else {
	    print DEL "        sysctl -w kern.polling.enable=0\n";
	}
	print DEL "    fi\n";

	print DEL "    exit 0\n";
	print DEL "fi\n";

	#
	# For FreeBSD 6 and beyond we must configure the number of kernel
	# mbuf clusters via sysctl, there is no param in the kernel anymore.
	#
	# We also load the bridge, IPFW2 and dummynet code if necessary.
	#
	if ($FBSD_VERSION >= 7) {
	    my $MPATH = $KERNELDELAY;
	    $MPATH =~ s/\/[^\/]+$//;

	    print DEL "if [ `sysctl -n kern.ipc.nmbclusters` -lt 65536 ]; then\n";
	    print DEL "    sysctl -w kern.ipc.nmbclusters=65536\n";
	    print DEL "fi\n";
	    print DEL "if ! kldstat -q -m if_bridge >/dev/null 2>&1; then\n";
	    print DEL "    echo \"Loading bridge module...\"\n";
	    print DEL "    kldload $MPATH/if_bridge.ko || {\n";
	    print DEL "        echo '  *** Could not load bridge code'\n";
	    print DEL "        exit 1\n";
	    print DEL "    }\n";
	    print DEL "fi\n";
	    print DEL "if ! kldstat -q -m ipfw >/dev/null 2>&1; then\n";
	    print DEL "    echo \"Loading ipfw module...\"\n";
	    print DEL "    kldload $MPATH/ipfw.ko || {\n";
	    print DEL "        echo '  *** Could not load ipfw code'\n";
	    print DEL "        exit 1\n";
	    print DEL "    }\n";
	    print DEL "    ipfw add 65534 allow all from any to any\n";
	    print DEL "fi\n";

	    print DEL "if ! kldstat -q -m dummynet >/dev/null 2>&1; then\n";
	    print DEL "    echo \"Loading dummynet module...\"\n";
	    print DEL "    kldload $MPATH/dummynet.ko || {\n";
	    print DEL "        echo '  *** Could not load dummynet code'\n";
	    print DEL "        exit 1\n";
	    print DEL "    }\n";
	    print DEL "fi\n";

	} elsif ($FBSD_VERSION >= 6) {
	    my $MPATH = $KERNELDELAY;
	    $MPATH =~ s/\/[^\/]+$//;

	    print DEL "if [ `sysctl -n kern.ipc.nmbclusters` -lt 65536 ]; then\n";
	    print DEL "    sysctl -w kern.ipc.nmbclusters=65536\n";
	    print DEL "fi\n";

	    print DEL "if ! sysctl net.link.ether.bridge >/dev/null 2>&1; then\n";
	    print DEL "    kldload $MPATH/bridge.ko || {\n";
	    print DEL "        echo \"Could not load bridge code\"\n";
	    print DEL "        exit 1\n";
	    print DEL "    }\n";
	    print DEL "fi\n";

	    print DEL "if ! sysctl net.inet.ip.fw.enable >/dev/null 2>&1; then\n";
	    print DEL "    kldload $MPATH/ipfw.ko || {\n";
	    print DEL "        echo \"Could not load IPFW code\"\n";
	    print DEL "        exit 1\n";
	    print DEL "    }\n";
	    print DEL "    ipfw add 65534 allow all from any to any\n";
	    print DEL "fi\n";

	    print DEL "if ! sysctl net.inet.ip.dummynet.curr_time >/dev/null 2>&1; then\n";
	    print DEL "    kldload $MPATH/dummynet.ko || {\n";
	    print DEL "        echo \"Could not load dummynet code\"\n";
	    print DEL "        exit 1\n";
	    print DEL "    }\n";
	    print DEL "fi\n";
	}

	#
	# Starting with FreeBSD 7, we use the new if_bridge module
	#
	if ($FBSD_VERSION >= 7) {
	    # Turn these off before setting bridge_cfg.
	    print DEL "sysctl -w net.link.bridge.ipfw=0\n";
	    print DEL "sysctl -w net.link.bridge.ipfw_arp=0\n";
	    if ($FBSD_VERSION >= 10) {
		print DEL "sysctl -w net.link.ether.ipfw=0\n";
	    }
	    
	    foreach my $bridge (@bridges) {
		my ($bix,$if1,$if2) = @$bridge;
		print DEL "ifconfig bridge$bix create || {\n";
		print DEL "    echo \"Could not create bridge$bix\"\n";
		print DEL "    exit 1\n";
		print DEL "}\n";
		print DEL "ifconfig bridge$bix addm $if1 addm $if2 up || {\n";
		print DEL "    echo \"Could not add $if1/$if2 to bridge$bix\"\n";
		print DEL "    ifconfig bridge$bix down destroy\n";
		print DEL "    exit 1\n";
		print DEL "}\n";
	    }

	    # Now turn them back on.
	    print DEL "sysctl -w net.link.bridge.ipfw=1\n";
	    print DEL "sysctl -w net.link.bridge.ipfw_arp=1\n";
	    if ($FBSD_VERSION >= 10) {
		print DEL "sysctl -w net.link.ether.ipfw=1\n";
	    }
	} else {
	    # Turn these off before setting bridge_cfg.
	    if ($FBSD_VERSION <= 4) {
		print DEL "sysctl -w net.link.ether.bridge=0\n";
		print DEL "sysctl -w net.link.ether.bridge_ipfw=0\n";
		print DEL "sysctl -w net.link.ether.bridge_cfg=";
	    }
	    else {
		print DEL "sysctl -w net.link.ether.bridge.enable=0\n";
		print DEL "sysctl -w net.link.ether.bridge.ipfw=0\n";
		print DEL "sysctl -w net.link.ether.bridge.config=";
	    }
	    foreach my $bridge (@bridges) {
		my ($count,$iface1,$iface2) = @$bridge;
		$count += 68;	# XXX backward compat

		print DEL "$iface1:$count,$iface2:$count,";
	    }
	    print DEL "\n";
	    # Now turn them back on.
	    if ($FBSD_VERSION <= 4) {
		print DEL "sysctl -w net.link.ether.bridge=1\n";
		print DEL "sysctl -w net.link.ether.bridge_ipfw=1\n";
	    }
	    else {
		print DEL "sysctl -w net.link.ether.bridge.enable=1\n";
		print DEL "sysctl -w net.link.ether.bridge.ipfw=1\n";
	    }
	}
	print DEL "ipfw -f pipe flush\n";
	print DEL "ipfw -q flush\n";
	if ($FBSD_VERSION >= 6) {
	    print DEL "ipfw add 65534 allow all from any to any\n";
	}

 	#
	# Turn on polling if possible.
	# For FreeBSD 6 and beyond, we turn it on only for the interfaces
	# in question.  For older FreeBSDs, we just have to turn it on
	# globally.
 	#
	if ($FBSD_VERSION >= 8) {

	    # XXX just in case we don't support polling
	    if ($using10g) {
		print DEL "sysctl hw.intr_storm_threshold=0\n";
	    }

	    print DEL "if [ -n \"`sysctl kern.polling.phase 2>/dev/null`\" ]; then\n";
	} else {
	    print DEL "if [ -n \"`sysctl kern.polling.enable 2>/dev/null`\" ]; then\n";
	}
	if ($FBSD_VERSION >= 6) {
	    if ($FBSD_VERSION < 8) {
		print DEL "    sysctl -w kern.polling.enable=0\n";
	    }
	    foreach my $bridge (@bridges) {
		my (undef,$if1,$if2) = @$bridge;
		print DEL "    ifconfig $if1 polling\n";
		print DEL "    ifconfig $if2 polling\n";
	    }

	    #
	    # Our kernel is running hot (10000HZ) so adjust some params.
	    # XXX this check should be done in the generated shell script,
	    # but I am too lazy to parse sysctl output with awk/sed and it
	    # doesn't matter right now as we always rerun this perl wrapper
	    # to produce the shell script.
	    #
	    if ($currenthz > 1000) {
		print DEL "    # adjustments for kernel at $currenthz HZ\n";
		# limit register accesses to 50 times a second
		print DEL "    sysctl -w kern.polling.reg_frac=200\n";

		# 80% of CPU can be used for polling activities
		print DEL "    sysctl -w kern.polling.user_frac=20\n";
	    }
	} else {
	    print DEL "    sysctl -w kern.polling.enable=1\n";
	}
	print DEL "else\n";
	print DEL "    echo '*** WARNING: no DEVICE_POLLING in delay kernel!'\n";
	print DEL "fi\n";

	foreach $delay (@delays) {
	    my $pat  = q(DELAY INT0=([\d\w]+) INT1=([\d\w]+) );
	    $pat .= q(PIPE0=(\d+) DELAY0=([\d\.]+) BW0=(\d+) PLR0=([\d\.]+) );
	    $pat .= q(PIPE1=(\d+) DELAY1=([\d\.]+) BW1=(\d+) PLR1=([\d\.]+) );
	    $pat .= q(LINKNAME=([-\d\w]+) );
	    $pat .= q(RED0=(\d) RED1=(\d) );
	    $pat .= q(LIMIT0=(\d+) );
	    $pat .= q(MAXTHRESH0=(\d+) MINTHRESH0=(\d+) WEIGHT0=([\d\.]+) );
	    $pat .= q(LINTERM0=(\d+) QINBYTES0=(\d+) BYTES0=(\d+) );
	    $pat .= q(MEANPSIZE0=(\d+) WAIT0=(\d+) SETBIT0=(\d+) );
	    $pat .= q(DROPTAIL0=(\d+) GENTLE0=(\d+) );
	    $pat .= q(LIMIT1=(\d+) );
	    $pat .= q(MAXTHRESH1=(\d+) MINTHRESH1=(\d+) WEIGHT1=([\d\.]+) );
	    $pat .= q(LINTERM1=(\d+) QINBYTES1=(\d+) BYTES1=(\d+) );
	    $pat .= q(MEANPSIZE1=(\d+) WAIT1=(\d+) SETBIT1=(\d+) );
	    $pat .= q(DROPTAIL1=(\d+) GENTLE1=(\d+) );
	    $pat .= q(VNODE0=([-\d\w]+) VNODE1=([-\d\w]+) );
	    $pat .= q(NOSHAPING=(\d+) );
	    $pat .= q(BACKFILL0=(\d+) BACKFILL1=(\d+));

	    $delay =~ /$pat/;

	    #
	    # tmcd returns the interfaces as MAC addrs.
	    #
	    my $iface1 = findiface($1);
	    my $iface2 = findiface($2);
	    my $p1        = $3;
	    my $delay1    = $4;
	    my $bandw1    = $5;
	    my $plr1      = $6;
	    my $p2        = $7;
	    my $delay2    = $8;
	    my $bandw2    = $9;
	    my $plr2      = $10;
	    my $linkname  = $11;
	    my $red1      = $12;
	    my $red2      = $13;

	    #
	    # Only a few of these NS RED params make sense for dummynet,
	    # but they all come through; someday they might be used.
	    #
	    my $limit1     = $14;
	    my $maxthresh1 = $15;
	    my $minthresh1 = $16;
	    my $weight1    = $17;
	    my $linterm1   = $18;
	    my $qinbytes1  = $19;
	    my $bytes1     = $20;
	    my $meanpsize1 = $21;
	    my $wait1      = $22;
	    my $setbit1    = $23;
	    my $droptail1  = $24;
	    my $gentle1    = $25;
	    my $limit2     = $26;
	    my $maxthresh2 = $27;
	    my $minthresh2 = $28;
	    my $weight2    = $29;
	    my $linterm2   = $30;
	    my $qinbytes2  = $31;
	    my $bytes2     = $32;
	    my $meanpsize2 = $33;
	    my $wait2      = $34;
	    my $setbit2    = $35;
	    my $droptail2  = $36;
	    my $gentle2    = $37;
	    my $vnode0     = $38;
	    my $vnode1     = $39;
	    my $noshaping  = $40;

	    my $backfill1  = $41;
	    my $backfill2  = $42;

	    #
	    # Noshaping. All we wanted was to set up the bridge (above).
	    # We do not want to actually delay the packets via a pipe,
	    # and we do not want a queuing!
	    #
	    next
		if ($noshaping);

	    #
	    # Set backfill if specified.
	    #
	    my $bf1arg = $bf2arg = "";
	    if ($backfill1 > 0) {
		$bf1arg = "backfill ${backfill1}Kbits/s";
	    }
	    if ($backfill2 > 0) {
		$bf2arg = "backfill ${backfill2}Kbits/s";
	    }
	    if (!$canbackfill && ($bf1arg || $bf2arg)) {
		print STDOUT "*** WARNING: IPFW does not support backfill\n";
	    }

	    #
	    # If the specified BW matches the native speed of the
	    # receive interface, leave the pipe bw arg as unlimited.
	    #
	    my $bw1arg = $bw2arg = "";
	    if (!exists($nativebw{$iface1}) || $bandw1 != $nativebw{$iface1}) {
		$bw1arg = "bw ${bandw1}Kbit/s";
	    }
	    if (!exists($nativebw{$iface2}) || $bandw2 != $nativebw{$iface2}) {
		$bw2arg = "bw ${bandw2}Kbit/s";
	    }

	    #
	    # Delays are floating point numbers (unit is ms). ipfw does not
	    # support floats, so apply a cheesy rounding function to convert
            # to an integer (since perl does not have a builtin way to
	    # properly round a floating point number to an integer).
	    #
	    $delay1 = int($delay1 + 0.5);
	    $delay2 = int($delay2 + 0.5);

	    #
	    # Qsizes are in slots or packets. My perusal of the 4.3 code
	    # shows the limits are 50 < slots <= 100 or 0 <= bytes <= 1MB.
	    #
	    my $queue1 = "";
	    my $queue2 = "";
	    if ($qinbytes1) {
		if ($limit1 <= 0 || $limit1 > (1024 * 1024)) {
		    print "Q limit $limit1 for pipe $p1 is bogus.\n";
		}
		else {
		    $queue1 = "queue ${limit1}bytes";
		}
	    }
	    elsif ($limit1 != 0) {
		if ($limit1 < 0 || $limit1 > 100) {
		    print "Q limit $limit1 for pipe $p1 is bogus.\n";
		}
		else {
		    $queue1 = "queue $limit1";
		}
	    }
	    if ($qinbytes2) {
		if ($limit2 <= 0 || $limit2 > (1024 * 1024)) {
		    print "Q limit $limit2 for pipe $p2 is bogus.\n";
		}
		else {
		    $queue2 = "queue ${limit2}bytes";
		}
	    }
	    elsif ($limit2 != 0) {
		if ($limit2 < 0 || $limit2 > 100) {
		    print "Q limit $limit2 for pipe $p2 is bogus.\n";
		}
		else {
		    $queue2 = "queue $limit2";
		}
	    }

	    #
	    # RED/GRED stuff
	    #
	    my $redparams1 = "";
	    my $redparams2 = "";
	    if ($red1) {
		if ($gentle1) {
		    $redparams1 = "gred ";
		}
		else {
		    $redparams1 = "red ";
		}
		my $max_p = 1 / $linterm1;
		$redparams1 .= "$weight1/$minthresh1/$maxthresh1/$max_p";
	    }
	    if ($red2) {
		if ($gentle2) {
		    $redparams2 = "gred ";
		}
		else {
		    $redparams2 = "red ";
		}
		my $max_p = 1 / $linterm2;
		$redparams2 .= "$weight2/$minthresh2/$maxthresh2/$max_p";
	    }

	    #
	    # To allow addition of more specific, per-interface rules
	    # (e.g., for pelab) we put the general rules toward the
	    # end of the table.  We don't know what the max general rule
	    # fed to us out of the DB will be, but lets assume that starting
	    # at 60000 provides us with enough room for those.
	    #
	    $p1 += 60000
		if ($p1 + 60000 < 65535);
	    $p2 += 60000
		if ($p2 + 60000 < 65535);

	    #
	    # As of FreeBSD 7, when filtering at the bridge level, packets are
	    # only processed by IPFW at the output interface.  Thus we must
	    # use "out" rather than "in" or packets won't match.
	    #
	    if ($FBSD_VERSION < 7) {
		print DEL "ipfw add $p1 pipe $p1 ip from any to any in recv $iface1\n";
		print DEL "ipfw add $p2 pipe $p2 ip from any to any in recv $iface2\n";
	    } else {
		print DEL "ipfw add $p1 pipe $p1 ip from any to any out recv $iface1\n";
		print DEL "ipfw add $p2 pipe $p2 ip from any to any out recv $iface2\n";
	    }
	    print DEL "ipfw pipe $p1 config delay ${delay1}ms ";
	    print DEL "$bw1arg $bf1arg plr $plr1 $queue1 $redparams1\n";
	    print DEL "ipfw pipe $p2 config delay ${delay2}ms ";
	    print DEL "$bw2arg $bf2arg plr $plr2 $queue2 $redparams2\n";

	    print STDOUT "  $iface1/$iface2 pipe $p1 config delay ";
	    print STDOUT "${delay1}ms $bw1arg plr $plr1 ";
	    print STDOUT "$queue1 $redparams1\n";
	    print STDOUT "  $iface1/$iface2 pipe $p2 config delay ";
	    print STDOUT "${delay2}ms $bw2arg plr $plr2 ";
	    print STDOUT "$queue2 $redparams2\n";

	    print MAP "$linkname duplex $vnode0 $vnode1 ".
		"$iface1 $iface2 $p1 $p2\n";
	}
	#
	# If a delay node, then lets report status and ready in so that batch
	# experiments do not become stuck.
	#
	printf DEL "%s %s 0\n", TMCC(), TMCCCMD_STARTSTAT();

	print DEL "echo \"Delay Configuration Complete\"\n";
	print DEL "exit 0\n";
	close(DEL);
	chmod(0755, TMDELAY);
	close(MAP);
	
	# Touch this file so that we globally know that the node is a delay
	# node. See routing setup. Need to avoid fastforwarding whenever we
	# have link delays.
	system("touch " . ISDELAYNODEPATH());
    }
    return 0;
}

#
# This sets up linkdelays on an experimental node.
#
sub LinkDelaySetup
{
    my @delays;
    my @jails;
    my $kernel;
    my $gotjails = (defined($vnodeid) ? 1 : 0);
    my $upcmds   = "";
    my $downcmds = "";

    # Lets clean out old instructions.
    unlink TMLINKDELAY;
    unlink TMDELMAP;

    #
    # We need to know if any jailed nodes. That changes which kernel
    # we want to boot.
    #
    # XXX Temporary until the jail stuff is better tested.
    #
    if (!$gotjails) {
	if (tmcc(TMCCCMD_VNODELIST, undef, \@jails) < 0) {
	    warn("*** WARNING: Could not get jails from server!\n");
	    return -1;
	}
	foreach my $str (@jails) {
	    if ($str =~ /^VNODEID=([-\w]+) JAILED=(\d)$/) {
		if ($2) {
		    $gotjails++;
		}
	    }
	}
    }
    if ($gotjails) {
	$kernel = $KERNELJAIL;
	$kernelhz = $KERNELJAILHZ;
    } else {
	$kernel = $KERNELLDELAY;
	$kernelhz = $KERNELLDELAYHZ;
    }

    # Get delay config.
    if (tmcc(TMCCCMD_LINKDELAYS, undef, \@delays) < 0) {
	warn("*** WARNING: Could not get link delays from server!\n");
	return -1;
    }

    if (@delays) {
	# before going any further, see if we need to boot a new kernel
	if (checkkernel($kernel, $kernelhz)) {
	    return -1;
	}

	open(MAP, ">" . TMDELMAP)
	    or die("Could not open " . TMDELMAP . ": $!");

	open(DEL, ">" . TMLINKDELAY)
	    or die("Could not open " . TMLINKDELAY . ": $!");

	foreach $delay (@delays) {
	    my $pat = q(LINKDELAY IFACE=([\d\w]+) TYPE=(simplex|duplex) );
	    $pat .= q(LINKNAME=([-\d\w]+) VNODE=([-\d\w]+) );
	    $pat .= q(INET=([0-9.]*) MASK=([0-9.]*) );
	    $pat .= q(PIPE=(\d+) DELAY=([\d\.]+) BW=(\d+) PLR=([\d\.]+) );
	    $pat .= q(RPIPE=(\d+) RDELAY=([\d\.]+) RBW=(\d+) RPLR=([\d\.]+) );
	    $pat .= q(RED=(\d) LIMIT=(\d+) );
	    $pat .= q(MAXTHRESH=(\d+) MINTHRESH=(\d+) WEIGHT=([\d\.]+) );
	    $pat .= q(LINTERM=(\d+) QINBYTES=(\d+) BYTES=(\d+) );
	    $pat .= q(MEANPSIZE=(\d+) WAIT=(\d+) SETBIT=(\d+) );
	    $pat .= q(DROPTAIL=(\d+) GENTLE=(\d+));

	    $delay =~ /$pat/;

	    #
	    # tmcd returns the interfaces as MAC addrs.
	    #
	    my $iface     = $1;
	    my $type      = $2;
	    my $linkname  = $3;
	    my $vnode     = $4;
	    my $inet      = $5;
	    my $mask      = $6;
	    my $pipeno    = $7;
	    my $delay     = $8;
	    my $bandw     = $9;
	    my $plr       = $10;
	    my $rpipeno   = $11;
	    my $rdelay    = $12;
	    my $rbandw    = $13;
	    my $rplr      = $14;
	    my $red       = $15;

	    #
	    # Only a few of these NS RED params make sense for dummynet,
	    # but they all come through; someday they might be used.
	    #
	    my $limit     = $16;
	    my $maxthresh = $17;
	    my $minthresh = $18;
	    my $weight    = $19;
	    my $linterm   = $20;
	    my $qinbytes  = $21;
	    my $bytes     = $22;
	    my $meanpsize = $23;
	    my $wait      = $24;
	    my $setbit    = $25;
	    my $droptail  = $26;
	    my $gentle    = $27;

	    #
	    # tmcd returns the interfaces as MAC addrs, so convert to
	    # an interface name.  Note that we also use the given IP
	    # address which is the unique characteristic for some forms
	    # of virtual interface.
	    # 
	    if (!($iface = findiface($iface,$inet))) {
		warn("*** WARNING: Could not map $1/$inet to an interface!\n");
		return -1;
	    }

	    #
	    # Delays are floating point numbers (unit is ms). ipfw does not
	    # support floats, so apply a cheesy rounding function to convert
            # to an integer (since perl does not have a builtin way to
	    # properly round a floating point number to an integer).
	    #
	    $delay  = int($delay + 0.5);
	    $rdelay = int($rdelay + 0.5);

	    #
	    # Qsizes are in slots or packets. My perusal of the 4.3 code
	    # shows the limits are 50 < slots <= 100 or 0 <= bytes <= 1MB.
	    #
	    my $queue = "";
	    if ($qinbytes) {
		if ($limit <= 0 || $limit > (1024 * 1024)) {
		    print "Q limit $limit for pipe $pipeno is bogus.\n";
		}
		else {
		    $queue = "queue ${limit}bytes";
		}
	    }
	    elsif ($limit != 0) {
		if ($limit < 0 || $limit > 100) {
		    print "Q limit $limit for pipe $pipeno is bogus.\n";
		}
		else {
		    $queue = "queue $limit";
		}
	    }

	    #
	    # RED/GRED stuff
	    #
	    my $redparams = "";
	    if ($red) {
		if ($gentle) {
		    $redparams = "gred ";
		}
		else {
		    $redparams = "red ";
		}
		my $max_p = 1 / $linterm;
		$redparams .= "$weight/$minthresh/$maxthresh/$max_p";
	    }

	    # rc.ifconfig (through the generated rc.ifc) does this
	    ##
	    ## XXX don't try to set the speed/duplex of virtual devices
	    ## XXX we should not be hardwiring the speed/duplex here anyway
	    ##
	    #if ($iface !~ /^(vlan|veth)/) {
	    #    $upcmds .= "ifconfig $iface media 100baseTX ".
	    #               "mediaopt full-duplex\n    ";
	    #}

	    $upcmds .= "ipfw add $pipeno pipe $pipeno ip from any to ".
		       "any out xmit $iface\n    ";

	    $upcmds .= "ipfw pipe $pipeno config delay ${delay}ms " .
	               "bw ${bandw}Kbit/s plr $plr $queue $redparams\n    ";

	    # not needed due to flush commands output below
	    if (defined($vnodeid)) {
		$downcmds .= "ipfw pipe delete $pipeno\n    ";
		$downcmds .= "ipfw delete $pipeno\n    ";
	    }

	    if ($type eq "duplex") {
		#
		# Want to force the reverse side to 1 queue slot to enforce
		# the proper bandwidth. Not ideal, especially since at 1000HZ
		# 1 queue slot is not enough. Make it 4 instead.
		#
		$upcmds .= "ipfw add $rpipeno pipe $rpipeno ip from any ".
		           "to any in recv $iface\n    ";

		$upcmds .= "ipfw pipe $rpipeno config delay ${rdelay}ms ".
		           "bw ${rbandw}Kbit/s plr $rplr queue 5\n    ";

		# not needed due to flush commands output below
		if (defined($vnodeid)) {
		    $downcmds .= "ipfw pipe delete $rpipeno\n    ";
		    $downcmds .= "ipfw delete $rpipeno\n    ";
		}
	    }

	    if ($type eq "duplex") {
		print MAP "$linkname duplex $vnode $vnode $iface $iface ".
		    "$pipeno $rpipeno\n";
	    }
	    else {
		print MAP "$linkname simplex $vnode $iface $pipeno\n";
	    }
	}
	close(MAP);

	print DEL "#!/bin/sh\n";
	print DEL "# auto-generated by delaysetup.pm, DO NOT EDIT\n";

	#
	# For FreeBSD 6 and beyond we must configure the number of kernel
	# mbuf clusters via sysctl, there is no param in the kernel anymore.
	#
	# We also load the IPFW2 and dummynet code if necessary.
	#
	if ($FBSD_VERSION >= 6) {
	    my $MPATH = $KERNELLDELAY;
	    $MPATH =~ s/\/[^\/]+$//;

	    print DEL "if [ `sysctl -n kern.ipc.nmbclusters` -lt 65536 ]; then\n";
	    print DEL "    sysctl -w kern.ipc.nmbclusters=65536\n";
	    print DEL "fi\n";

	    print DEL "if ! sysctl net.inet.ip.fw.enable >/dev/null 2>&1; then\n";
	    print DEL "    kldload $MPATH/ipfw.ko || {\n";
	    print DEL "        echo \"Could not load IPFW code\"\n";
	    print DEL "        exit 1\n";
	    print DEL "    }\n";
	    print DEL "    ipfw add 65534 allow all from any to any\n";
	    print DEL "fi\n";

	    print DEL "if ! sysctl net.inet.ip.dummynet.curr_time >/dev/null 2>&1; then\n";
	    print DEL "    kldload $MPATH/dummynet.ko || {\n";
	    print DEL "        echo \"Could not load dummynet code\"\n";
	    print DEL "        exit 1\n";
	    print DEL "    }\n";
	    print DEL "fi\n";
	}

	# Main boot only.
	if (!defined($vnodeid)) {
	    print DEL "ipfw -f pipe flush\n";
	    print DEL "ipfw -q flush\n";
	    if ($FBSD_VERSION >= 6) {
		print DEL "ipfw add 65534 allow all from any to any\n";
	    }
	}
	print DEL "if [ x\$1 = x ]; then action=enable; else action=\$1; fi\n";
	print DEL "case \"\$action\" in\n";
	print DEL "  enable)\n";
	print DEL "    $upcmds\n";
	# Turn off Flow-based IP (fast) forwarding since it causes packets
	# to bypass traffic shaping and ipfw. Stupid!
	print DEL "    sysctl -w net.inet.ip.fastforwarding=0\n";
	print DEL "    ;;\n";
	print DEL "  disable)\n";
	print DEL "    $downcmds\n";
	print DEL "    ;;\n";
	print DEL "esac\n";
	close(DEL);
	chmod(0755, TMLINKDELAY);

	# Touch this file so that we globally know that the node is a delay
	# node. See routing setup. Need to avoid fastforwarding whenever we
	# have link delays.
	system("touch " . ISDELAYNODEPATH());
    }
    return 0;
}

#
# Check kernel config, and reboot.
# Returns 0 if kernel is already ok, non-zero if kernel could not be fixed.
#
sub checkkernel($$)
{
    my ($kernel,$kernelhz) = @_;
    my $needreboot = 0;
    my $failed = 0;

    print STDOUT "Making sure node is running $kernel at ${kernelhz}HZ ...\n";

    #
    # See if kernel is running at the correct HZ.
    # Update the loader.conf file and reboot if not.
    #
    # XXX we only do this for FreeBSD 6 and above since before since,
    # before that, we had special kernels with hardwired HZ for delay nodes.
    #
    if ($FBSD_VERSION >= 6) {
	if ($currenthz > 0) {
	    if ($currenthz != $kernelhz) {
		print STDOUT "Updating kernel HZ ($currenthz -> $kernelhz) ...\n";
		#
		# See if there is a custom Emulab command line setting.
		# If so, warn and do not change.
		#
		my $binfo = `$BINDIR/tmcc bootwhat`;
		if ($binfo =~ /HZ=(\d+)/ && int($1) == $currenthz) {
		    print "*** WARNING: custom HZ value on command line, ".
			  "not changing to $kernelhz.\n";
		    return 0;
		}
		if (-e "/boot/loader.conf") {
		    #
		    # If already running a custom HZ rate, don't change it.
		    # Just warn and continue.
		    #
		    if (!system("grep '^kern.hz=' /boot/loader.conf 2>&1 >/dev/null")) {
			print "*** WARNING: kernel running custom HZ value, ".
			      "not changing to $kernelhz.\n";
			return 0;
		    }
		    #
		    # Otherwise back up the existing config before changing
		    #
		    if (system("cp -fp /boot/loader.conf /boot/loader.conf.bak")) {
			print "Could not backup loader.conf! ".
			    "Aborting HZ change.\n";
			return 1;
		    }
		}
		if (!open(FD, ">>/boot/loader.conf")) {
		    print "Could not set new HZ value in loader.conf! ".
			"Aborting HZ change.\n";
		    return 1;
		}
		print FD "\n# The following was added by delay setup.\n";
		print FD "kern.hz=$kernelhz\n";
		close(FD);
		$needreboot = 1;
	    }
	} else {
	    print "*** WARNING: Could not determine HZ value of kernel! ".
		  "Continuing anyway.\n";
	}
    }

    #
    # Make sure we are running the desired kernel.
    #
    if (-e $kernel) {
	#
	# In FreeBSD 5 and above, the command line is used to ensure we
	# boot the correct kernel.  So just complain if it is not right,
	# as we have no way to fix it.
	#
	if ($FBSD_VERSION >= 5) {
	    my $curkernel = `sysctl -n kern.bootfile`;
	    chomp($curkernel);
	    if ($curkernel ne $kernel) {
		print "*** WARNING: FreeBSD 5+ running wrong kernel ".
		      "'$curkernel', should be '$kernel'. ".
		      "Continuing anyway.\n";
	    }
	}
	elsif (system("cmp -s /kernel $kernel") != 0) {
	    print STDOUT "Copying $kernel to /kernel ...\n";
	    if (system("cp -fp /kernel /kernel.save")) {
		print "Could not backup /kernel! Aborting kernel change\n";
		$failed++;
	    }
	    elsif (!unlink("/kernel")) {
		print "Could not unlink /kernel! Aborting kernel change\n";
		unlink("/kernel.save");
		$failed++;
	    }
	    elsif (system("cp -fp $kernel /kernel")) {
		print "Could not cp $kernel to /kernel!\n";
		rename("/kernel.save", "/kernel");
		$failed++;
	    }
	    else {
		$needreboot = 1;
	    }
	}
    }
    else {
	print "*** WARNING: $kernel does not exist! ".
	      "Continuing anyway.\n";
    }
    if ($failed) {
	return 1;
    }

    #
    # Finally, reboot if necessary.
    #
    if ($needreboot) {
	print STDOUT "Rebooting to $kernel ...\n";
	system("sync");
	system("reboot");
	#
	# Make sure that, even if the reboot command returns
	# before the node is totally down, this process doesn't
	# exit (otherwise, we would proceed with testbed setup)
	#
	sleep(10000);
	print "Failed to reboot! Aborting.\n";
	return 1;
    }

    return 0;
}
