<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#!/usr/bin/perl -w

package UserapTcTools;

use strict;
use UserapCommon;
use UserapParser;


my $rc = {};

my $HISTORY=12;			#number of stored values - default 12 = hour
my %hist= ();
my %c2u= ();			#class to user hash table
my %u2c= ();			#user to class hash table
my $HISTORY_STAMP=0;

my $SYSCLASS = {};

my $IF_CEIL = {};		#hash for saving current CEIL value for users
my $IF_TOTAL = {};		#total data of user on interface
my $IF_LAST = ();		#increment since last measurement
my $IF_HOUR = {};		#hour data on each interface

my $SUM_HOUR = {};		#total data on all interfaces in last hour
my $SUM_TOTAL = {};		#tatal data on all interfaces 
my %FORCE_UPDATE =();

my $nicks;
my $FACE_CONF;
my $STATFILE = "$DATADIR/tc_dump.xml";


# ==========================================================
# load everything available from the tc -s class show command
sub parseTcStatus {
    print "   parsing tc status\n";
    my $tfces=`cd $QOSDIR; ls qos-* | sed "s/qos-//"`;
    my @faces=split ('\n',$tfces);
    
    $IF_CEIL = {};		#reset old values
    $SUM_TOTAL = {};
    $SUM_HOUR = {}; 
    foreach (@faces) {
	my $face=$_;
	print "      $face";

	$FACE_CONF = UserapParser::getIfacesInfo() unless exists ($FACE_CONF-&gt;{$face});
	
        if ($FACE_CONF-&gt;{$face}-&gt;{type} eq "userap") {
    	    my $tcbuf = `tc -s class show dev $face parent 2:1`;
    	    my @tcClasses = split ("\n\n", $tcbuf);
    	    #for each user class
	    my $class_count = 0;
	    foreach (@tcClasses) {
		my ($l1, $l2) = split ('\n', $_);
		#don't care about root class
		if ($l1 =~ /root/) { next; }
		$class_count ++;
		my (undef, undef ,$cid, undef, undef, %params) = split(' ', $l1);
		my (undef, $send) = split (' ', $l2);
		$cid =~ s/2://g;
		my $uid = 0;
		if (exists $c2u{"$cid:$face"}) {
		    $uid = $c2u{"$cid:$face"};

		    my @line = ();
		    #save value to history
		    if (!exists $hist{"$uid:$face"}) {
			$hist{"$uid:$face"} = [ $send ];
			@line = ($send);
		    } else {
			@line = @{$hist{"$uid:$face"}};
			if ($#line == $HISTORY) {
			    shift @line;
			}
			push @line, $send;
			@{$hist{"$uid:$face"}} = @line;
		    }
		    if ($params{"ceil"} =~ /K/ ) {
			$params{"ceil"} =~ s/Kbit// ;
		    } elsif ($params{"ceil"} =~ /M/ ) { 
			$params{"ceil"} =~ s/Mbit// ;
			$params{"ceil"} *= 1000;
		    } else {
			$params{"ceil"} =~ s/bit//;
			$params{"ceil"} /= 1000;
		    }
		    #store current ceils for users
		    if (exists ($IF_CEIL-&gt;{$face})) {
			$IF_CEIL-&gt;{$face}-&gt;{$uid} = $params{"ceil"};
		    } else {
			$IF_CEIL-&gt;{$face} = {};
			$IF_CEIL-&gt;{$face}-&gt;{$uid} = $params{"ceil"};
		    }
		    #spocteme statistiky pro cleny na interfacech (total data)
		    my $tincr = 0;
		    for (my $i=0;$i&lt; ($#line);$i++) {
			my $pr = $line[$i+1] - $line[$i];
			#print "PR: $pr\n";
			if ($pr &gt;= 0) {
			    $tincr+=$pr;
			} else {
	        	    $tincr+=$line[$i+1];
			}
		    }
		    #store data for last hour	    
		    if (exists ($IF_HOUR-&gt;{$face})) {
			$IF_HOUR-&gt;{$face}-&gt;{$uid} = $tincr;
		    } else {
			$IF_HOUR-&gt;{$face} = {};
			$IF_HOUR-&gt;{$face}-&gt;{$uid} = $tincr;
		    }
		    if (exists $SUM_HOUR-&gt;{$uid}) {
			$SUM_HOUR-&gt;{$uid} += $tincr;
		    } else {
			$SUM_HOUR-&gt;{$uid} = $tincr;
		    }
	    
		    my $ttemp = 0;
		    #calculate total traffic on interface (total + increment)
		    if (!exists $IF_TOTAL-&gt;{$face}) {
			$IF_TOTAL-&gt;{$face} = {};
			$ttemp = $send;
		    } else {
			if (!exists $IF_TOTAL-&gt;{$face}-&gt;{$uid}) {
		    	    $ttemp = $send;
			} else {
			    $ttemp = $IF_TOTAL-&gt;{$face}-&gt;{$uid};
			    if ($ttemp &lt;= $send) {
	    			$ttemp = $send;
	    			#print "INC1: old: $ttemp new: $send - $uid:$face\n";
			    } else {
	    			if ($#line &gt; 0) {
	    			    my $pr = ($line[$#line] - $line[$#line -1]);
	    			    #print "INC2: old $totalek ";
	    			    if ($pr &gt;=0) {
					$ttemp+=$pr;
				    } else {
					$ttemp+=$line[$#line];
				    }
				    #print "new: $ttmp ($uid:$face) - pr: $pr\n";
    				}
			    }
			}
		    }
		    $IF_TOTAL-&gt;{$face}-&gt;{$uid} = $ttemp;
		    if (exists $SUM_TOTAL-&gt;{$uid}) {
			$SUM_TOTAL-&gt;{$uid} +=$ttemp;
		    } else {
			$SUM_TOTAL-&gt;{$uid} = $ttemp;
		    }
		} else {
		    print "W: no class mapping! for $cid $face";
		}
		
	    }
	    if ($class_count &lt; 2)  {
		print " $class_count found! forcing update\n";
		$FORCE_UPDATE{$face} = 1;
	    } else {
		print " $class_count classes\n";
		$FORCE_UPDATE{$face} = 0;
	    }
	} else {
	    print " other\n";
	}
	
	#==================================================================
	#get system class info.
    	my $tcbuf = `tc -s class show dev $face parent 1:0`;
	my @lines = split ("\n\n", $tcbuf);

	#jednotlive classy
	foreach (@lines) {
	    my $tmp_hash = { };
	    my ($l1, $l2, $l3) = split ('\n', $_);
	    my $uid;my %params=();
	    if ($l1 =~ /root/) {
	        (undef, undef ,$uid, undef, %params ) = split(' ', $l1);
	    } else {
	        (undef, undef ,$uid, %params ) = split(' ', $l1);
	    }
	    (undef, $tmp_hash-&gt;{"send"}, undef, undef, undef, undef, $tmp_hash-&gt;{"drop"}) = split (' ', $l2);
	    (undef, $tmp_hash-&gt;{"rrate"}) = split (' ', $l3);
	    $uid =~ s/1://g;
	    ${$tmp_hash}{"drop"} =~ s/\,// ;
	    $tmp_hash-&gt;{"crate"} = $params{"rate"};
	    $tmp_hash-&gt;{"cceil"} = $params{"ceil"};
	    $tmp_hash-&gt;{"crate"} =~ s/bit//g;
	    $tmp_hash-&gt;{"cceil"} =~ s/bit//g;

	    if ($tmp_hash-&gt;{"rrate"} =~ /k/ ) {
		$tmp_hash-&gt;{"rrate"} = ($tmp_hash-&gt;{"rrate"} =~ s/kbit//) *1024;
	    } else {
		$tmp_hash-&gt;{"rrate"} =~ s/bit// ;
	    }
	    if (exists $SYSCLASS-&gt;{$face}) {
		$SYSCLASS-&gt;{$face}-&gt;{$uid} = $tmp_hash;
	    } else {
		$SYSCLASS-&gt;{$face} = {};
		$SYSCLASS-&gt;{$face}-&gt;{$uid} = $tmp_hash;
	    }
	}
    }
}

sub loadHistory {
    print "   loading history dump";
    my $ci = 0;my $ri = 0;
    $IF_TOTAL = {};
    if (open F, "$DATADIR/tc_dump-hist.txt") {
    	$HISTORY_STAMP = &lt;F&gt;;
	#nactem dump
	while (&lt;F&gt;) {
	    my $line=$_;
	    chomp($line);
	    if ($line ne "") {
		my ($uid,$face,$tt,$data)=split(";",$line);
		$ci++;
		my @tmpd = split (":", $data);
		$ri = $#tmpd;
		$hist{"$uid:$face"} = [ @tmpd ];
		if (exists $IF_TOTAL-&gt;{$face}) {
		    $IF_TOTAL-&gt;{$face}-&gt;{$uid} = $tt;
		} else {
		    $IF_TOTAL-&gt;{$face} = {};
		    $IF_TOTAL-&gt;{$face}-&gt;{$uid} = $tt;
		}
	    }
	}
	$ri++;
	print ".. DONE ($ci lines with $ri value(s)).\n";    
    } else {
	print ".. FAIL (file not exists)\n";
	$HISTORY_STAMP = time();
    }
}

sub saveHistory {
    print "   saving history dump";
    if (open F, "&gt;$DATADIR/tc_dump-hist.txt") {
	print F $HISTORY_STAMP."\n";
	#sejvnem dump
	while (my ($fau,$data) = each (%hist)) {
	    my ($uid,$face)=split(":",$fau);
	    my $tmpd = join (":",@{$hist{"$fau"}});
	    my $tt = $IF_TOTAL-&gt;{$face}-&gt;{$uid};
	    print F "$uid;$face;$tt;$tmpd\n";
	}
	print ".\n";
    } else {
	print " FAIL!!! cannot dump data!!! to $DATADIR/tc_dump-hist.txt";
    }
}

sub saveResults {
    UserapParser::saveNicks($nicks);
    UserapParser::saveConfig($FACE_CONF);
    UserapParser::saveUserLimits($rc);
};	    


sub init_classes ($) {
    my $face = shift;
    if (!defined($face) || $face eq "") {
	return;
    }
    my $rate  = $FACE_CONF-&gt;{$face}-&gt;{rate};
    my $speed = $FACE_CONF-&gt;{$face}-&gt;{speed};
    
    print " ($face: $speed)";
    #aliases ... I'm just too lazy to write these long shits in each command
    my $TC=`which tc`;chomp($TC);chomp($TC);
    my $TQ="$TC qdisc add dev $face";
    my $TA="$TC class add dev $face parent";
    my $TF="$TC filter add dev $face parent ";
    my $SFQ="sfq perturb 10";

    #delete parent qdisc .. :)
    `$TC qdisc del dev $face handle 2: parent 1:4`;
    #print "$TC qdisc del dev $face handle 2: parent 1:4\n";
    #create parent qdisc and default class (6666) for users
    `$TQ parent 1:4 handle 2: htb default 6666`;
    #print "$TQ parent 1:4 handle 2: htb default 6666\n";

    `$TA 2: classid 2:1 htb rate ${speed}kbit ceil ${speed}kbit burst 100k quantum 1514`;                #root class
    #print "$TA 2: classid 2:1 htb rate ${speed}kbit ceil ${speed}kbit burst 100k quantum 1514\n";                #root class
    `$TA 2:1 classid 6666 htb rate 128kbit ceil 256kbit burst 10k prio 1 quantum 1514`;                  #default class
    $c2u{"6666:$face"}=6666;
    $u2c{"6666:$face"}=6666;
    `$TQ parent 2:6666 handle 6666: pfifo limit 10`;

    #creation of user classes &amp; filters
    my $ips = UserapParser::GetIPs($face);
    my $user_class = 20;
    while (my ($id,$ip) = each ( %{$ips})) {
	if ($id == 0) {
	    next;
	}
	$c2u{"$user_class:$face"}=$id;
	$u2c{"$id:$face"}=$user_class;
	#print "$id \n";
	`$TA 2:1 classid $user_class htb rate ${rate}kbit ceil ${speed}kbit burst 30k prio 1 quantum 1514`;
	#print "$TA 2:1 classid $id htb rate ${rate}kbit ceil ${speed}kbit burst 30k prio 1 quantum 1514\n";
	`$TQ parent 2:$user_class handle $user_class pfifo limit 40`;
	#print "$TQ parent 2:$id handle $id pfifo limit 40\n";
	my @pole = split (":", $ip);
	foreach (@pole) {
	    my $tip = $_;
		`$TF 2:0 protocol ip prio 4 u32 match ip src $tip flowid 2:$user_class`;
		#print "$TF 2:0 protocol ip prio 4 u32 match ip src $tip flowid 2:$id\n";
		`$TF 2:0 protocol ip prio 4 u32 match ip dst $tip flowid 2:$user_class`;
		#print "$TF 2:0 protocol ip prio 4 u32 match ip dst $tip flowid 2:$id\n";
	}
	$user_class++;
    }
    #clean dead users
    
}
# ==========================================================

sub initFaces {
    $FACE_CONF = UserapParser::getIfacesInfo();
    print "   initialising";
    $nicks = UserapParser::loadNicks();
	    
    while (my ($face,$facec) = each (%{$FACE_CONF})) {
        print " $face";
	if ($FORCE_UPDATE{$face}) {
            print "F";
            init_classes($face);
	    next;
	}	
	if(-e "$DATADIR/qos-$face.act" &amp;&amp; !(-e "$DATADIR/autoban/$face")) {
            print "I";
            init_classes($face);
	    next;
	}
        if (-e "$DATADIR/qos-$face.act" &amp;&amp; -e "$DATADIR/autoban/$face") {
            if ((stat("$DATADIR/faces/$face"))[9] &gt; (stat("$DATADIR/autoban/$face"))[9]) {
                print "!";
                init_classes($face);
            }
        }
    }
    print "\n";
}

sub set_manual_rates {
    print "   setting manual rates ..\n";
    `cp $QOSBIN/scripts/userap_files/manual/class* $DATADIR 2&gt;/dev/null`;
    my $tmp=`cd $DATADIR; ls class-*`;
    my @manfiles = split ('\n', $tmp);


    foreach(@manfiles) {
	print "      $_";
	my $FN = "$DATADIR/$_";
	open IF, "$FN";
	my $lcount=0;
	while (&lt;IF&gt;) {
	    $_ =~ s/#.*//;
	    chomp;
	    if ($_) {
    		my ($id,$face,$rate,$ceil,$nick) = split;
		my $cid = 0;
		if (defined($nick) &amp;&amp; $nick ne "") {
		    $nicks-&gt;{"$id"}=$nick;
		}
		my $rsend = 0;
		if (exists $u2c{"$id:$face"}) {
		    $cid = $u2c {"$id:$face"};
		} else{
		    $cid = $id;
		}
		system("tc class add dev $face classid $cid parent 2:1 htb rate ${rate}kbit ceil ${ceil}kbit prio 1 burst 10k quantum 1514 2&gt;/dev/null");
		system("tc class change dev $face classid $cid parent 2:1 htb rate ${rate}kbit ceil ${ceil}kbit prio 1 burst 10k quantum 1514 2&gt;/dev/null");
		#store info.
		$rc-&gt;{"$id:$face"}= join(":", ($rate,$ceil));
		$lcount++;
	    }
	}
	print " $lcount rules. \n";
    }
    close IF;

    #filters
    `cp $QOSBIN/scripts/userap_files/manual/filter* $DATADIR 2&gt;/dev/null`;
    $tmp=`cd $DATADIR; ls filter-* 2&gt;/dev/null`;
    @manfiles = split ('\n', $tmp);

    foreach(@manfiles) {
	print "      $_";
	my $FN = "$DATADIR/$_";
	open IF, "$FN";
	my $lcount=0;
	while (&lt;IF&gt;) {
	    $_ =~ s/#.*//;
	    chomp;
	    if ($_) {
		my ($id,$face,$ip,$advanced) = split;
		my $cid = 0;
		if (!defined($advanced)) {
		    $advanced = "";
		}
		my $TC=`which tc`;chomp($TC);chomp($TC);
		my $TF="$TC filter add dev $face parent ";

		if (exists $u2c{"$id:$face"}) {
		    $cid = $u2c {"$id:$face"};
		} else{
		    $cid = $id;
		}

		system("$TF 2:0 protocol ip prio 4 u32 match ip src $ip flowid 2:$cid $advanced");
		#`$TF 2:0 protocol ip prio 4 u32 match ip dst $ip flowid 2:$id `;
		system("$TF 2:0 protocol ip prio 4 u32 match ip dst $ip flowid 2:$cid $advanced");
		$lcount++;
	    }
	}
	print " $lcount rules. \n";
    }

}

sub set_auto_rates {
    print "   setting auto rates...\n";
    #!!!!!!!!!!!!    TODO!!! sanity check - check if user classes are set!!!!!!!!!!!!!

    #penalties
    $rc = {};
    my $pf = {};
    `cp $QOSBIN/scripts/userap_files/manual/penalty* $DATADIR 2&gt;/dev/null`;
    my $tmp=`cd $DATADIR; ls penalty* 2&gt;/dev/null`;
    my @manfiles = split ('\n', $tmp);

    foreach(@manfiles) {
	print "      $_";
	my $FN = "$DATADIR/$_";
	open IF, "$FN";
	my $lcount=0;
	while (&lt;IF&gt;) {
	    $_ =~ s/#.*//;
	    chomp;
	    if ($_) {
		my ($id,$upen,undef) = split;
		$pf-&gt;{$id} = $upen;
		$lcount++;
	    }
	}
	print " $lcount rules. \n";
    }

    
    #postupne pro vsecky interfacey
    while (my ($face,$face_cfg) = each (%{$FACE_CONF})) {
        #pouze userap interfejsy
        if (${$face_cfg}{"type"} ne "userap") {
	    next;
	}
	#print "AUTO: $face ============================\n";
	
        #nactem bany pro tento interfejs
        my $bans = UserapParser::GetAutoBans("$face");
	#nactem data
	my $datas = (exists $IF_HOUR-&gt;{$face}) ? $IF_HOUR-&gt;{$face} : UserapParser::GetInterfacesHourData("$face");
	
        while (my ($uid,undef) = each (%{$datas})) {
	    my $prirustek = $SUM_HOUR-&gt;{$uid};
	    #projdeme vsecky usery na interfacu a omezime je.
    	    #print "$face:$uid:$prirustek";

	    my $penalty = ${$face_cfg}{"penalty0"};
	    if ($uid == $DEFAULT_CLASS) {
		$rc-&gt;{"$uid:$face"} = join(":", ($DEFAULT_CLASS_RATE,$DEFAULT_CLASS_CEIL));
		next;
	    } else {
		my ($nr, $nc);
		if (exists ($bans-&gt;{$uid})) {
		    $nc = $bans-&gt;{$uid};
		    $nr = 32;
		    #print "BAN: $uid $nr $nc\n";
		} else {
		    if ($prirustek &gt; ${$face_cfg}{"limit2"}) {
			$penalty = ${$face_cfg}{"penalty2"};
		    } elsif ($prirustek &gt; ${$face_cfg}{"limit1"}) {
			$penalty = ${$face_cfg}{"penalty1"};
		    }
		    $nr = int( ${$face_cfg}{"rate"} * $penalty / 100);
		    $nc = int( ${$face_cfg}{"speed"} * $penalty / 100);
		}
		#penalties
		if (exists $pf-&gt;{$uid}) {
		    my $pen = $pf-&gt;{$uid};
		    $nr = int( $nr * $pen / 100);
		    $nc = int( $nc * $pen / 100);
		}
		#print " | pen: $penalty | ";
		if (exists $IF_CEIL-&gt;{$face}-&gt;{$uid}) {
		    if ($nc != $IF_CEIL-&gt;{$face}-&gt;{$uid}) {
			if (exists $u2c{"$uid:$face"}) {
			    my $cid = $u2c {"$uid:$face"};
			    system("tc class change dev $face classid $cid parent 2:1 htb rate ${nr}kbit ceil ${nc}kbit prio 1 burst 10k quantum 1514 2&gt;/dev/null");
			#print "change! ($IF_CEIL-&gt;{$face}-&gt;{$uid})";
			} else {
			    $FORCE_UPDATE{$face} = 1;
			}
		    }
		    $rc-&gt;{"$uid:$face"} = join(":", ($nr,$nc));
		} else {
		    print "!";
		}
		#print " | $nr/$nc \n";
	    }
	}
    }
}        



#=======================================================================================
sub genStats {
    UserapParser::saveStats($IF_HOUR,$IF_TOTAL,$IF_LAST,$SUM_HOUR,$SUM_TOTAL,$SYSCLASS);
    if ($ENABLE_HTMLOUT) {
	UserapHtml::genHtml($FACE_CONF,$nicks,$rc,$IF_TOTAL,$SUM_HOUR,$SUM_TOTAL,$SYSCLASS,$HISTORY_STAMP);
    }
}

# ==========================================================

UserapTcTools::loadHistory();

1;</pre></body></html>