#!/usr/bin/perl -wT
#
# Copyright (c) 2000-2018 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] [-j <vnodeid>]\n";
    exit(1);
}
my $optlist   = "iuj:";
my $install   = 0;
my $uninstall = 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;

# Protos
sub LinkDelaySetup();

#
# 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{"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 (defined($vnodeid)) {
    exit(0);
}

#
# Delay node configuration goop.
#
# The kernel identifiers are just tags to differentiate kernels.
# These tags should be the LILO identifiers (labels) and the tag should
# appear somewher in the kernel name returned via osversion.
# XXX however because we gave no thought to kernel naming in 7.x, the
# default kernel doesn't adhere to this convention.  So all we can do
# for sure is recognize that we are not running a linkdelay kernel and
# switch to it.
#
my $KERNEL100	= "emulab";
my $KERNELJAIL  = "jail";
my $KERNELLDELAY= "linkdelay";

my $TMDELMAP	= TMDELMAP;	# Really comes from libloc.
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);

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

# Uninstall just looks for the files, runs them, and exits.
if ($uninstall) {
    system(TMLINKDELAY . " disable")
	if (-e TMLINKDELAY);
    exit(0);
}

#
# Update the delays configuration. Also run the the commands to make
# the changes.
#
if (LinkDelaySetup()) {
    exit(1);
}

if ($install) {
    system(TMLINKDELAY)
	if (-e TMLINKDELAY);
}
exit(0);

#
# This sets up linkdelays on an experimental node.
# 
sub LinkDelaySetup()
{
    my @delays;
    my $kernel;
    my $checkreplace = 0;
    my $gotjails = 0;
    my @jails;
    my $useifb = 0;
    my $usenetem = 0;

    # 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. Temporary until the jail stuff is better tested.
    #
    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;
	$checkreplace = 1;
    }

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

    if (@delays) {
	open(MAP, ">$TMDELMAP")
	    or die("Could not open $TMDELMAP");

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

	system("modinfo ifb >/dev/null 2>&1");
	if ($? == 0) {
	    print "Will use ifb kernel module for duplex endnodeshaping\n";
	    $useifb = 1;
	}
	else {
	    print "Will use imq kernel module for duplex endnodeshaping\n";
	    system("modinfo imq");
	    if ($?) {
		print "WARNING: imq module does not exist; shaping may fail!\n";
	    }
	    $useifb = 0;
	}

	system("modinfo sch_netem >/dev/null 2>&1");
	if ($? == 0) {
	    print "Using sch_netem kernel module for delay/plr\n";
	    $usenetem = 1;
	    $checkreplace = 0;
	    print DEL "modprobe sch_netem\n";
	}
	else {
	    print "Using sch_plr/sch_delay kernel modules for delay/plr"
		. " (fallback)\n";
	    $usenetem = 0;
	    print DEL "modprobe sch_plr\n";
	    print DEL "modprobe sch_delay\n";
	    system("modinfo sch_plr >/dev/null 2>&1");
	    if ($?) {
		print "WARNING: sch_plr module does not exist;"
		    . " shaping may fail!\n";
	    }
	    system("modinfo sch_delay >/dev/null 2>&1");
	    if ($?) {
		print "WARNING: sch_delay module does not exist;"
		    . " shaping may fail!\n";
	    }
	}

	print DEL "#!/bin/sh\n";
# Figure out how we're going to flush iproute2+tc!
#	print DEL "ipfw -f flush\n";

	if ($useifb) {
	    print DEL "modprobe ifb numifbs=20\n";
	}
	else {
	    print DEL "modprobe imq numdevs=20\n";
	}
	# We have to dole out the ifb/imqs
	my $nextifbimq = 0;
	
        print DEL "sysctl -w net.core.rmem_max=8388608\n";
        print DEL "sysctl -w net.core.wmem_max=8388608\n";
        print DEL "sysctl -w net.core.netdev_max_backlog=2048\n";

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

	    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).
	    #
            # NB: Linux doesn't support floats either, and wants usecs.
            #
	    $delay  = int($delay + 0.5) * 1000;
	    $rdelay = int($rdelay + 0.5) * 1000;

	    #
	    # Sweet! 'k' as in "kbit" means 1024, not 1000, to tc.
	    # Just spell it out as bits here, they can't screw that up!
	    #
	    $bandw *= 1000;
	    $rbandw *= 1000;
	    
	    #
	    # Qsizes are in slots or packets. My perusal of the 4.3 code
	    # shows the limits are 50 < slots <= 100 or 0 <= bytes <= 1MB.
	    #
            # Just changed things to work similarly in Linux
            #
	    my $queue = "";
	    if ($qinbytes) {
		if ($limit <= 0 || $limit > (1024 * 1024)) {
		    print "Q limit $limit for pipe $pipeno is bogus.\n";
		}
		else {
                    # In Linux, we have to convert to packets
		    $queue = int($limit/1500);
                    $queue = $queue > 0 ? $queue : 1;
		}
	    }
	    elsif ($limit != 0) {
		if ($limit < 0 || $limit > 100) {
		    print "Q limit $limit for pipe $pipeno is bogus.\n";
		}
		else {
		    $queue = $limit;
		}
	    }

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

            # XXX: temporarily select between delay, plr, and [g]red
            # until they become classful queues.

	    if ($usenetem) {
		#
		# netem cannot have non-work-conserving qdiscs inside of
		# itself, and it can't have itself inside itself --
		# because it uses the skbuff's control block and would
		# thus overwrite itself.  The Linux maintainers removed
		# its classful support for these and other reasons, so
		# you can't nest anything inside it.  So, we have to do
		# bandwidth shaping first, and then the loss and delay
		# with the same netem qdisc.
		#

		# packet loss in netem is percent
		$plr *= 100;

		print DEL "ifconfig $iface txqueuelen $queue\n"
		    if ($queue);
		print DEL "$TC qdisc del dev $iface root >/dev/null 2>&1\n";
		print DEL "$TC qdisc del dev $iface ingress >/dev/null 2>&1\n";

		#
		# We cannot use HTB at all if bandw is 0 (i.e., no bandwidth
		# shaping should be performed).
		#
		my $dropfrag = "";
		if ($plr > 0) {
		    $dropfrag = "drop $plr";
		}
		if ($bandw != 0) {
		    print DEL "$TC qdisc add dev $iface handle ". $pipeno .
			" root htb default 1\n";
		    print DEL "$TC class add dev $iface classid ".
			$pipeno .":1 parent " . $pipeno .
			" htb rate ${bandw} ceil ${bandw}\n";
		    print DEL "$TC qdisc add dev $iface handle ".
			($pipeno+10) . " parent " . $pipeno . ":1 " .
			"netem $dropfrag delay ${delay}us\n";
		}
		else {
		    print DEL "$TC qdisc add dev $iface handle ".
			$pipeno . " root " .
			"netem $dropfrag delay ${delay}us\n";
		}
	    }
	    else {
		print DEL "$TC qdisc add dev $iface handle $pipeno root ";
		print DEL "plr $plr\n";

		print DEL "$TC qdisc add dev $iface handle ". ($pipeno+10) ." ";
		print DEL "parent ${pipeno}:1 delay usecs $delay\n";

		print DEL "$TC qdisc add dev $iface handle ". ($pipeno+20) ." ";
		print DEL "parent ". ($pipeno+10) .":1 htb default 1\n";

		if ($bandw != 0) {
		    print DEL "$TC class add dev $iface classid ".
			($pipeno+20) .":1 ";
		    print DEL "parent ". ($pipeno+20) ." htb rate ${bandw} ";
		    print DEL "ceil ${bandw}\n";
		}
	    }
	    if ($type eq "duplex") {
		my $inum = $nextifbimq++;
		my $idev = ($useifb ? "ifb" : "imq") . $inum;
		
		if ($usenetem) {
		    # packet loss in netem is percent
		    $rplr *= 100;

		    print DEL "ifconfig $idev up\n";
		    print DEL "$TC qdisc del dev $idev root\n";
		    print DEL "$TC qdisc add dev $iface handle ffff: ingress\n";
		    print DEL "$TC filter add dev $iface parent ffff: ".
			"protocol ip u32 match u32 0 0 flowid 2:1 ".
			"action mirred egress redirect dev $idev\n";

		    #
		    # We cannot use HTB at all if bandw is 0 (i.e., no bandwidth
		    # shaping should be performed).
		    #
		    my $dropfrag = "";
		    if ($rplr > 0) {
			$dropfrag = "drop $rplr";
		    }
		    if ($rbandw != 0) {
			print DEL "$TC qdisc add dev $idev root handle 2: ".
			    "htb default 1\n";
			print DEL "$TC class add dev $idev parent 2: classid 2:1 ".
			    "htb rate ${rbandw} ceil ${rbandw}\n";
			# Do not use a colon: in the handle. It BREAKS!
			print DEL "$TC qdisc add dev $idev handle 3 parent 2:1 ".
			    "netem $dropfrag delay ${rdelay}us\n";
		    }
		    else {
			# Do not use a colon: in the handle. It BREAKS!
			print DEL "$TC qdisc add dev $idev handle 3 root ".
			    "netem $dropfrag delay ${rdelay}us\n";
		    }
		}
		else {
		    print DEL "$TC qdisc add dev $idev handle $pipeno ";
		    print DEL "root plr $rplr\n";

		    print DEL "$TC qdisc add dev $idev handle ";
		    print DEL "". ($pipeno+10) ." parent ${pipeno}:1 ";
		    print DEL "delay usecs $rdelay reset_time 1\n";

		    print DEL "$TC qdisc add dev $idev handle "; 
		    print DEL "". ($pipeno+20) ." parent ". ($pipeno+10) .":1 ";
		    print DEL "htb default 1\n";

		    if ($rbandw != 0) {
			print DEL "$TC class add dev $idev classid ";
			print DEL "". ($pipeno+20) .":1 parent ".
			    ($pipeno+20) . " ";
			print DEL "htb rate ${rbandw} ceil ${rbandw}\n";
		    }
		    print DEL "$IPTABLES -t mangle -A PREROUTING -i $iface ";
		    print DEL "-j IMQ --todev $inum\n";
                
		    print DEL "ifconfig $idev up\n";

		    #
		    # *** From FreeBSD version:
		    #
		    # 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.
		    # 
		    # XXX: Why do we do this, and does Linux need to?
		    #
		}
		print MAP "$linkname duplex $vnode $vnode $iface ".
		    "$idev $pipeno $rpipeno\n";
	    }
	    else {
		print MAP "$linkname simplex $vnode $iface $pipeno\n";
	    }
	}
	print DEL "echo \"Delay Configuration Complete\"\n";
	close(DEL);
	chmod(0755, TMLINKDELAY);
	close(MAP);
    
	# Touch this file so that we globally know that the node is a delay
	# node.
	system("touch " . ISDELAYNODEPATH());

	if (!$usenetem) {
	    #
	    # Now do kernel configuration. All of the above work is wasted,
	    # but such is life.
	    #
	    if (!$gotjails) {
		$kernel = $KERNELLDELAY;
	    }
	    $checkreplace = 1;
	}
    }
    if ($checkreplace) {
	checkkernel($kernel);
    }
    return 0;
}

#
# Check kernel config, and reboot.
#
sub checkkernel($)
{
    my $kernel = shift;

    print STDOUT "Making sure node is running $kernel kernel... \n";

    my $kernvers = `cat /proc/sys/kernel/osrelease`;
    chomp $kernvers;

    if (!$kernvers) {
        print STDERR "Unable to determine running kernel version.\n";
        return;
    }

    if (!($kernvers =~ /$kernel/i)) {

        # XXX only works for linkdelay right now
        return if ($kernel ne $KERNELLDELAY);

        # check if we have lilo or grub:
        my $islilo = 0;
        if (-e "/etc/lilo.conf" && -x "/sbin/lilo") {
            $islilo = 1;
        }
        elsif (-e "/boot/grub/grub.conf" || -e "/boot/grub/menu.lst") {
            $isgrub = 1;
        }
        else {
            print STDERR "Error: neither grub nor lilo seems to be " .
                "installed!\n";
            return 1;
        }

        if ($islilo) {
            my $lilocmd = "/sbin/lilo -D $kernel";
            if (system ($lilocmd)) {
                print STDERR "Error ($?) running '$lilocmd'\n";
                return 1;
            }
        }
        elsif ($isgrub) {
            # we could have had both grub and lilo detected, but if lilo
            # was installed, we just blew away the first sector, so fixing up
            # grub becomes rather pointless.

            my $file = "/boot/grub/grub.conf";
            if (!(-e $file)) {
                $file = "/boot/grub/menu.lst";
                if (!(-e $file)) {
                    print STDERR "Error: could not find any grub " .
                        "conf files!\n";
                    return 1;
                }
            }

            my @lines;
            open(FD,$file) or die "could not open $file!";
            @lines = <FD>;
            close(FD);

            my $i = 0;
            my $found = 0;
            foreach my $line (@lines) {
                if ($line =~ /^\s*Title\s+/i) {
                    if ($line =~ /$kernel/i) {
                        $found = 1;
                        last;
                    }
                    ++$i;
                }
            }

            if (!$found) {
                print STDERR "Error: could not find a linkdelay kernel " .
                    " in $file!\n";
                return 1;
            }
            my $idx = $i;

            $found = 0;
            for ($i = 0; $i < scalar(@lines); ++$i) {
                if ($lines[$i] =~ /\s*default\s*=\s*(\d+)/i) {
                    $lines[$i] = "default=$idx\n";
                    $found = 1;
                    # note that we don't just quit -- there could be more.
                }
            }

            if (!$found) {
                @lines = ("default=$idx\n",@lines);
            }

            # rewrite it.
            open(FD,">$file") or die "could not open $file!";
            foreach my $line (@lines) {
                print FD $line;
            }
        }

        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);
    }
}
