Initial version of vyatta-cfg-qosdebian/0.1

This the initial checkin prior to integration

7 files changed, 662 insertions, 0 deletions

diff --git a/scripts/VyattaQosFairQueue.pm b/scripts/VyattaQosFairQueue.pm
new file mode 100644
index 0000000..d943db2
--- /dev/null
+++ b/scripts/VyattaQosFairQueue.pm
@@ -0,0 +1,41 @@
+package VyattaQosFairQueue;
+@ISA = qw/VyattaQosPolicy/;
+
+#
+# This is a wrapper around Stochastic Fair Queue(SFQ) queue discipline
+# Since SFQ is a hard to explain, use the name fair-queue since SFQ
+# is most similar to Weighted Fair Queue (WFQ) on Cisco IOS.
+#
+
+use strict;
+
+require VyattaConfig;
+
+# Fair Queue
+# Uses SFQ which is similar to (but not same as) WFQ
+
+my %fields = (
+    _perturb => undef,
+    _limit   => undef,
+);
+
+sub new {
+    my ( $that, $config ) = @_;
+    my $class = ref($that) || $that;
+    my $self = {%fields};
+
+    $self->{_perturb} = $config->returnValue("rekey-interval");
+    $self->{_limit}   = $config->returnValue("queue-limit");
+    return bless $self, $class;
+}
+
+sub commands {
+    my ( $self, $out, $dev ) = @_;
+    
+    print {$out} "qdisc add dev $dev root sfq";
+    print {$out} " perturb $self->{_perturb}" if ( defined $self->{_perturb} );
+    print {$out} " limit $self->{_limit}"     if ( defined $self->{_limit} );
+    print "\n";
+}
+
+1;
diff --git a/scripts/VyattaQosMatch.pm b/scripts/VyattaQosMatch.pm
new file mode 100644
index 0000000..72f7a36
--- /dev/null
+++ b/scripts/VyattaQosMatch.pm
@@ -0,0 +1,82 @@
+package VyattaQosMatch;
+require VyattaConfig;
+use VyattaQosUtil;
+use strict;
+
+my %fields = (
+	_dev      => undef,
+	_vlan     => undef,
+	_ip	  => {
+	    _src      => undef,
+	    _dst      => undef,
+	    _dsfield  => undef,
+	    _protocol => undef,
+	    _sport    => undef,
+	    _dport    => undef,
+	}
+);
+
+sub new {
+    my ( $that, $config ) = @_;
+    my $self = {%fields};
+    my $class = ref($that) || $that;
+
+    bless $self, $class;
+    $self->_define($config);
+
+    return $self;
+}
+
+sub _tos {
+    my $tos = shift;
+    my $ret = undef;
+
+    if ( defined $tos ) {
+        $ret = VyattaQosUtil::getDsfield($tos);
+        if ( !defined $ret ) {
+            $tos = hex($tos);
+        }
+    }
+    return $ret;
+}
+
+sub _define {
+    my ( $self, $config ) = @_;
+
+    my $level=$config->setLevel();
+
+    $self->{_vlan} = $config->returnValue("vif");
+    $self->{_dev} = $config->returnValue("interface");
+
+    $self->{_ip}->{_tos} = _tos( $config->returnValue("ip tos") );
+    $self->{_ip}->{_protocol} = $config->returnValue("ip protocol");
+    $self->{_ip}->{_src} = $config->returnValue("ip source address");
+    $self->{_ip}->{_dst} = $config->returnValue("ip destination address");
+    $self->{_ip}->{_sport} = $config->returnValue("ip source port");
+    $self->{_ip}->{_dport} = $config->returnValue("ip source dport");
+}
+
+sub filter {
+    my ( $self, $out, $dev, $id ) = @_;
+
+    print {$out} "filter add dev $dev parent 1:0 prio 10";
+
+    # TODO match on vlan, device, ...
+    if (defined $self->{_ip}) {
+	print {$out} " u32";
+	print {$out} " match ip tos $self->{_ip}->{_tos} 0xff"
+	    if defined $self->{_ip}->{_tos};
+	print {$out} " match ip protocol $self->{_ip}->{_protcol} 0xff"
+	    if defined $self->{_ip}->{_protocol};
+	print {$out} " match ip src $self->{_ip}->{_src}"
+	    if defined $self->{_ip}->{_src};
+	print {$out} " match ip sport $self->{_ip}->{_sport}"
+	    if defined $self->{_ip}->{_sport};
+	print {$out} " match ip dst $self->{_ip}->{_dst}"
+	    if defined $self->{_ip}->{_dst};
+	print {$out} " match ip dport $self->{_ip}->{_dport}"
+	    if defined $self->{_ip}->{_dport};
+    }
+
+    print {$out} " classid $id\n";
+}
diff --git a/scripts/VyattaQosPolicy.pm b/scripts/VyattaQosPolicy.pm
new file mode 100644
index 0000000..76f86eb
--- /dev/null
+++ b/scripts/VyattaQosPolicy.pm
@@ -0,0 +1,34 @@
+package VyattaQosPolicy;
+
+use strict;
+
+require VyattaConfig;
+use VyattaQosTrafficShaper;
+use VyattaQosFairQueue;
+
+# Main class for all QoS policys
+# It is a base class, and actual policies are subclass instances.
+
+# Build a new traffic shaper of the proper type based
+# on the configuration information.
+sub config {
+    my ( $class, $config, $type ) = @_;
+    my $object = undef;
+
+  SWITCH: {
+        ( $type eq 'fair-queue' ) && do {
+            $object = new VyattaQosFairQueue($config);
+            last SWITCH;
+        };
+
+        ( $type eq 'traffic-shaper' ) && do {
+            $object = new VyattaQosTrafficShaper($config);
+            last SWITCH;
+        };
+
+        die "Unknown policy type \"$type\"\n";
+    }
+    return $object;
+}
+
+1;
diff --git a/scripts/VyattaQosTrafficShaper.pm b/scripts/VyattaQosTrafficShaper.pm
new file mode 100644
index 0000000..903aeeb
--- /dev/null
+++ b/scripts/VyattaQosTrafficShaper.pm
@@ -0,0 +1,182 @@
+# Traffic shaper
+# This is a extended form of Hierarchal Token Bucket with
+# more admin friendly features. Similar in spirt to other shaper scripts
+# such as wondershaper.
+
+{
+    package ShaperClass;
+    use strict;
+    require VyattaConfig;
+    use VyattaQosMatch;
+
+    my %fields = (
+	id	  => undef,
+        _priority => undef,
+        _rate     => undef,
+        _ceiling  => undef,
+        _burst    => undef,
+        _match    => undef,
+    );
+
+    sub new {
+        my ( $that, $config, $id ) = @_;
+        my $class = ref($that) || $that;
+        my $self = {%fields};
+
+        bless $self, $class;
+        $self->_define($config, $id);
+
+        return $self;
+    }
+
+    sub _define {
+        my ( $self, $config, $id ) = @_;
+	my $level = $config->setLevel();
+	my @matches = ();
+
+
+	$self->{_id}	   = sprintf "%04x", $id;
+        $self->{_priority} = $config->returnValue("priority");
+        $self->{_rate}     = $config->returnValue("rate");
+        $self->{_ceiling}  = $config->returnValue("ceiling");
+        $self->{_burst}    = $config->returnValue("burst");
+
+	foreach my $match ($config->listNodes("match")) {
+            $config->setLevel("$level match $match");
+	    push @matches, new VyattaQosMatch($config);
+        }
+	$self->{_match}    = \@matches;
+    }
+
+    sub _getPercentRate {
+	my ($rate, $speed) = @_;
+
+        if ( ! defined $rate ) {
+	    return;  # leave rate undef
+	}
+
+        # Rate might be a percentage of speed
+        if ( $rate =~ /%$/ ) {
+            my $percent = substr( $rate, 0, length($rate) - 1 );
+            if ( $percent < 0 || $percent > 100 ) {
+                die "Invalid percentage bandwidth\n";
+            }
+
+            $rate = ( $percent * $speed ) / 100.;
+        } else {
+	    $rate = VyattaQosUtil::getRate($rate);
+	}
+
+	return $rate;
+    }
+
+    sub commands {
+        my ( $self, $out, $dev, $speed ) = @_;
+        my $rate = _getPercentRate($self->{_rate}, $speed);
+	my $ceil = _getPercentRate($self->{_ceiling}, $speed);
+        my $id   = $self->{_id};
+	my $matches = $self->{_match};
+
+	die "Rate is not defined\n"	                  if (! defined $rate );
+	die "Class $id rate $rate > shaper rate $speed\n" if ($rate > $speed);
+
+	# create the class
+        my $cmd ="class add dev $dev parent 1:1 classid 1:$id htb rate $rate";
+        if ( defined $ceil) {
+	    if ($ceil < $rate ) {
+		die "Rate limit (ceiling) $ceil < base rate $rate\n";
+	    }
+	    $cmd .= " ceil $ceil";
+	}
+
+        $cmd .= " burst $self->{_burst}"   if ( defined $self->{_burst} );
+        $cmd .= " prio $self->{_priority}" if ( defined $self->{_priority} );
+
+	print {$out} $cmd . "\n";
+
+	# create leaf qdisc
+	print {$out} "qdisc add dev $dev parent 1:$id sfq\n";
+
+	foreach my $match (@$matches) {
+	    $match->filter( $out, $dev, $id );
+        }
+    }
+}
+
+package VyattaQosTrafficShaper;
+@ISA = qw/VyattaQosPolicy/;
+use strict;
+require VyattaConfig;
+use VyattaQosUtil;
+
+my $defaultId = 0x4000;
+
+my %fields = (
+    _rate       => undef,
+    _classes    => undef,
+);
+
+# new VyattaQosTrafficShaper($config)
+# Create a new instance based on config information
+sub new {
+    my ( $that, $config ) = @_;
+    my $self = {%fields};
+    my $class = ref($that) || $that;
+
+    bless $self, $class;
+    $self->_define($config);
+
+    return $self;
+}
+
+# Rate can be something like "auto" or "10.2mbit"
+sub _getAutoRate {
+    my ($rate, $dev) = @_;
+
+    if ( $rate eq "auto" ) {
+        my $rate = VyattaQosUtil::interfaceRate($dev);
+        if ( ! defined $rate ) {
+	    die "Auto speed setting but can't get rate from $dev\n";
+	}
+    } else {
+	$rate = VyattaQosUtil::getRate($rate);
+    }
+
+    return $rate;
+}
+
+# Setup new instance.
+# Assumes caller has done $config->setLevel to "traffic-shaper $name"
+sub _define {
+    my ( $self, $config ) = @_;
+    my $level = $config->setLevel();
+    my @classes = ( );
+
+    $self->{_rate} = $config->returnValue("rate");
+
+    $config->setLevel("$level default");
+    push @classes, new ShaperClass( $config, $defaultId); 
+    $config->setLevel($level);
+
+    foreach my $id ( $config->listNodes("class") ) {
+        $config->setLevel("$level class $id");
+	push @classes, new ShaperClass( $config, $id );
+    }
+    $self->{_classes} = \@classes;
+}
+
+sub commands {
+    my ( $self, $out, $dev ) = @_;
+    my $rate = _getAutoRate($self->{_rate}, $dev);
+    my $classes = $self->{_classes};
+    my @tc  = ( );
+
+    print {$out} "qdisc add dev $dev root handle 1: htb default $defaultId\n";
+    print {$out} "class add dev $dev parent 1: classid 1:1 htb rate $rate\n";
+
+    foreach my $class (@$classes) {
+        $class->commands( $out, $dev, $rate );
+    }
+}
+
+1;
diff --git a/scripts/VyattaQosUtil.pm b/scripts/VyattaQosUtil.pm
new file mode 100644
index 0000000..121970e
--- /dev/null
+++ b/scripts/VyattaQosUtil.pm
@@ -0,0 +1,173 @@
+package VyattaQosUtil;
+use POSIX;
+require Exporter;
+@EXPORT	= qw/getRate getSize getProtocol getDsfield interfaceRate/;
+
+sub get_num  {
+    my ($str) = @_;
+    
+    # clear errno
+    $! = 0;
+    ($num, $unparsed) = POSIX::strtod($str);
+    if (($str eq '') || $!) {
+	die "Non-numeric input \"$str\"" . ($! ? ": $!\n" : "\n");
+    }
+
+    if ($unparsed > 0) { return $num, substr($str, -$unparsed); }
+    else	       { return $num; }
+}
+
+## get_rate("10mbit")
+# convert rate specification to number
+# from tc/tc_util.c
+sub getRate {
+    my ($num, $suffix) = get_num(@_);
+
+    if (defined $suffix) {
+      SWITCH: {
+	  ($suffix eq 'bit')	&& do { last SWITCH; };
+	  ($suffix eq 'kibit')	&& do { $num *= 1024.; last SWITCH };
+	  ($suffix eq 'kbit')	&& do { $num *= 1000.,; last SWITCH; };
+	  ($suffix eq 'mibit')	&& do { $num *= 1048576.,; last SWITCH; };
+	  ($suffix eq 'mbit')	&& do { $num *= 1000000.,; last SWITCH; };
+	  ($suffix eq 'gibit')	&& do { $num *= 1073741824.,; last SWITCH; };
+	  ($suffix eq 'gbit')	&& do { $num *= 1000000000.,; last SWITCH; };
+	  ($suffix eq 'tibit')	&& do { $num *= 1099511627776.,; last SWITCH; };
+	  ($suffix eq 'tbit')	&& do { $num *= 1000000000000.,; last SWITCH; };
+	  ($suffix eq 'bps')	&& do { $num *= 8.,; last SWITCH; };
+	  ($suffix eq 'kibps')	&& do { $num *= 8192.,; last SWITCH; };
+	  ($suffix eq 'kbps')	&& do { $num *= 8000.,; last SWITCH; };
+	  ($suffix eq 'mibps')	&& do { $num *= 8388608.,; last SWITCH; };
+	  ($suffix eq 'mbps')	&& do { $num *= 8000000.,; last SWITCH; };
+	  ($suffix eq 'gibps')	&& do { $num *= 8589934592.,; last SWITCH; };
+	  ($suffix eq 'gbps')	&& do { $num *= 8000000000.,; last SWITCH; };
+	  ($suffix eq 'tibps')	&& do { $num *= 8796093022208.,; last SWITCH; };
+	  ($suffix eq 'tbps')	&& do { $num *= 8000000000000.,; last SWITCH; };
+
+	  die "Rate must be a number followed by a optional suffix (kbit, mbps, ...)\n";
+	}
+    }
+    
+    die "Negative rate not allowed\n"  if ($num < 0);
+    return $num;
+}
+
+sub getSize {
+    my ($num, $suffix) = get_num(@_);
+
+    if (defined $suffix) {
+      SWITCH: {
+	  ($suffix eq 'b')		&& do { $num *= 1.,; last SWITCH; };
+	  ($suffix eq 'k')		&& do { $num *= 1024.,; last SWITCH; };
+	  ($suffix eq 'kb')		&& do { $num *= 1024.,; last SWITCH; };
+	  ($suffix eq 'kbit')	&& do { $num *= 128.,; last SWITCH; };
+	  ($suffix eq 'm')		&& do { $num *= 1048576.,; last SWITCH; };
+	  ($suffix eq 'mb')		&& do { $num *= 1048576.,; last SWITCH; };
+	  ($suffix eq 'mbit')	&& do { $num *= 131072.,; last SWITCH; };
+	  ($suffix eq 'g')		&& do { $num *= 1073741824.,; last SWITCH; };
+	  ($suffix eq 'gb')		&& do { $num *= 1073741824.,; last SWITCH; };
+	  ($suffix eq 'gbit')	&& do { $num *= 134217728.,; last SWITCH; };
+	  
+	  die "Unknown suffix \"$suffix\"\n";
+	}
+    }
+    
+    die "Negative size not allowed\n"  if ($num < 0);
+    return $num;
+}
+
+sub getProtocol {
+    my ($p) = @_;
+
+    if ($p =~ /^([0-9]+)|(0x[0-9a-fA-F]+)$/) {
+	if ($p < 0 || $p > 255) {
+	    die "$p is not a valid protocol number\n";
+	}
+	return $p;
+    }
+
+    ($name, $aliases, $proto) =  getprotobyname($p);
+    (defined $proto)  or die "\"$p\" unknown protocol\n";
+    return $proto;
+}
+
+# Parse /etc/iproute/rt_dsfield 
+# return a hex string "0x10" or undefined
+sub getDsfield {
+    my ($str) = @_;
+    my $match = undef;
+    my $dsFileName = '/etc/iproute2/rt_dsfield';
+    
+    if ($str =~ /^([0-9]+)|(0x[0-9a-fA-F]+)$/) {
+	if ($str < 0 || $str > 255) {
+	    die "$str is not a valid dsfield value\n";
+	}
+	return $str;
+    }
+
+    open(DSFIELD,"<$dsFileName") || die "Can't open $dsFileName, $!\n";
+    while (<DSFIELD>) {
+	next if /^#/;
+	chomp;
+	@fields = split;
+	if ($str eq $fields[1]) {
+	    $match = $fields[0];
+	    last;
+	}
+    }
+    close(DSFIELD);
+
+    return $match;
+}
+
+# Utility routines
+
+## interfaceRate("eth0")
+# return result in bits per second
+sub interfaceRate {
+    my ($interface) = @_;
+    my $rate = undef;
+    my $config = new VyattaConfig;
+
+    $config->setLevel("interfaces ethernet");
+    if ($config->exists("$interface")) {
+	my $speed  = $config->returnValue("$interface speed");
+	if (defined($speed) && $speed != "auto") {
+	    return $speed * 1000000;
+	}
+    } 
+
+    $rate = ethtoolRate($interface);
+
+    if (! defined $rate) {
+	die "Interace speed for $interface unknown\n";
+    }
+
+    return $rate * 1000000;
+}
+
+## ethtoolRate("eth0")
+# Fetch actual rate using ethtool and format to valid tc rate
+sub ethtoolRate {
+    my ($dev) = @_;
+    my $rate = undef;
+
+    open(ETHTOOL, "sudo ethtool $dev |") or return $rate;
+
+    # ethtool produces:
+    #
+    # Settings for eth1:
+    # Supported ports: [ TP ]
+    # ...
+    # Speed: 1000Mb/s
+    while (<ETHTOOL>) {
+	my @line = split;
+	if ($line[0] =~ /^Speed/) {
+	    $rate = $line[1];
+	    $rate =~ s/Mb\/s/000000/;
+	    last;
+	}
+    }
+    close(ETHTOOL);
+    return $rate;
+}
diff --git a/scripts/vyatta-qos-util.pl b/scripts/vyatta-qos-util.pl
new file mode 100755
index 0000000..5dd869f
--- /dev/null
+++ b/scripts/vyatta-qos-util.pl
@@ -0,0 +1,44 @@
+#!/usr/bin/perl
+#
+# Utility routines for validating input
+# These functions don't change existing QoS parameters
+#
+
+use lib "/opt/vyatta/share/perl5/";
+use VyattaQosUtil;
+use Getopt::Long;
+
+GetOptions(
+    "rate=s"     => \$rate,
+    "burst=s"    => \$burst,
+    "protocol=s" => \$protocol,
+    "dsfield=s"  => \$dsfield,
+);
+
+if ( defined $rate ) {
+    my $r = VyattaQosUtil::getRate($rate);
+    exit 0;
+}
+
+if ( defined $burst ) {
+    my $b = VyattaQosUtil::getSize($burst);
+    exit 0;
+}
+
+if ( defined $protocol ) {
+    my $p = VyattaQosUtil::getProtocol($protocol);
+    exit 0;
+}
+
+if ( defined $dsfield ) {
+    my $d = VyattaQosUtil::getDsfield($dsfield);
+    exit 0;
+}
+
+print <<EOF;
+usage: vyatta-qos-util.pl --rate rate
+       vyatta-qos-util.pl --burst size
+       vyatta-qos-util.pl --protocol protocol
+       vyatta-qos-util.pl --dsfield tos|dsfield
+EOF
+exit 1;
diff --git a/scripts/vyatta-qos.pl b/scripts/vyatta-qos.pl
new file mode 100755
index 0000000..86a0c62
--- /dev/null
+++ b/scripts/vyatta-qos.pl
@@ -0,0 +1,106 @@
+#!/usr/bin/perl
+
+use lib "/opt/vyatta/share/perl5/";
+use VyattaConfig;
+use VyattaQosPolicy;
+
+use Getopt::Long;
+
+my $qosNode = 'qos-policy';
+
+my @update = ();
+my @delete = ();
+my $debug = $ENV{"DEBUG"};
+my $list = undef;
+
+GetOptions(
+    "debug"       => \$debug,
+    "list"        => \$list,
+    "update=s{3}" => \@update,
+    "delete=s{2}" => \@delete,
+);
+
+## list available qos policy names
+sub list_available {
+    my $config = new VyattaConfig;
+    my @nodes  = ();
+
+    foreach my $policy ( $config->listNodes($qosNode) ) {
+        foreach my $name ( $config->listNodes("$qosNode $policy") ) {
+            push @nodes, $name;
+        }
+    }
+
+    print join( ' ', @nodes ), "\n";
+}
+
+## delete_interface('eth0', 'out')
+# remove all filters and qdisc's
+sub delete_interface {
+    my ( $interface, $direction ) = @_;
+
+    if ( $direction =~ /^out/ ) {
+
+        # delete old qdisc - will give error if no policy in place
+        system("tc qdisc del dev $interface root 2>/dev/null");
+        system("tc filter del dev $interface 2>/dev/null");
+    }
+    else {
+        return -1;
+    }
+}
+
+## update_interface('eth0', 'out', 'my-shaper')
+# update policy to interface
+sub update_interface {
+    my ( $interface, $direction, $name ) = @_;
+    my $config = new VyattaConfig;
+
+    # TODO: add support for ingress
+    ( $direction =~ /^out/ ) or die "Only out direction supported";
+
+    foreach my $policy ( $config->listNodes($qosNode) ) {
+        if ( $config->exists("$qosNode $policy $name") ) {
+            $config->setLevel("$qosNode $policy $name");
+
+            my $policy = VyattaQosPolicy->config( $config, $policy );
+            defined $policy or die "undefined policy";
+
+	    # When doing debugging just echo the commands
+	    if (defined $debug) {
+		open (my $out, ">&STDOUT");
+	    } else {
+		open( my $out, "|sudo tc -batch -" )
+		    or die "Tc setup failed: $!\n";
+	    }
+
+            $policy->commands($out, $interface);
+	    close $out or die "Tc command failed: $!\n";
+            exit 0;
+        }
+    }
+
+    die "Unknown $qosNode $name\n";
+}
+
+if ( defined $list ) {
+    list_available();
+    exit 0;
+}
+
+if ( $#delete == 1 ) {
+    delete_interface(@delete);
+    exit 0;
+}
+
+if ( $#update == 2 ) {
+    update_interface(@update);
+    exit 0;
+}
+
+print <<EOF;
+usage: vyatta-qos.pl --list
+       vyatta-qos.pl --update interface direction policy
+       vyatta-qos.pl --delete interface direction
+EOF
+exit 1;