Репозиторий Sisyphus
Последнее обновление: 25 мая 2019 | Пакетов: 17693 | Посещений: 13593538
en ru br
Репозитории ALT

Группа :: Безопасность/Сети
Пакет: shapercontrol

 Главная   Изменения   Спек   Патчи   Исходники   Загрузить   Gear   Bugs and FR  Repocop 

shapercontrol-1.3.4/000075500000000000000000000000001165425052100144015ustar00rootroot00000000000000shapercontrol-1.3.4/Makefile000064400000000000000000000030231165425052100160370ustar00rootroot00000000000000PROG=sc
VERSION=1.3.4
ARCH=$(PROG)-$(VERSION).tar.bz2

DESTDIR?=/usr/local/sbin
MANDIR?=/usr/local/share/man
INITDIR?=/etc/init.d
CFGDIR=/etc/sc

CLFILES?=sc.8 sc.conf.5 $(ARCH) *.batch


man: sc.8 sc.conf.5

sc.8: sc
pod2man --section=8 --release=" " \
--center="Linux System Manager's Manual" $^ > $@

sc.conf.5: sc.conf.pod
pod2man --section=5 --release=" " --center=" " $^ > $@

help:
@echo "Targets:" ;\
echo " clean clean output files" ;\
echo " install install program" ;\
echo " help show this message" ;\
echo " man (default) generate manpages" ;\
echo " srcdist create archive with source distribution" ;\
echo " uninstall uninstall program"

install: sc sc.init sc.conf.5 sc.8 sc.conf
install -D -o root -g root -m 755 $(PROG) $(DESTDIR)
install -D -o root -g root -m 755 $(PROG).init $(INITDIR)/$(PROG)
install -D -o root -g root -m 644 sc.8 $(MANDIR)/man8
install -D -o root -g root -m 644 sc.conf.5 $(MANDIR)/man5
mkdir -p $(CFGDIR)
if [ -f $(CFGDIR)/sc.conf ]; then \
install -D -o root -g root -m 644 sc.conf $(CFGDIR)/sc.conf.default ;\
else \
install -D -o root -g root -m 644 sc.conf $(CFGDIR) ;\
fi

uninstall:
-rm $(DESTDIR)/sc
-rm $(INITDIR)/sc
-rm $(MANDIR)/man8/sc.8
-rm $(MANDIR)/man5/sc.conf.5
-[ -f $(MANDIR)/man8/sc.8.gz ] && rm $(MANDIR)/man8/sc.8.gz
-[ -f $(MANDIR)/man5/sc.conf.5.gz ] && rm $(MANDIR)/man5/sc.conf.5.gz

reinstall: uninstall install

clean:
rm -f $(CLFILES)

srcdist:
hg archive -t tbz2 -X .hgtags -X .hgignore -X .hg_archival.txt $(ARCH)

shapercontrol-1.3.4/README000064400000000000000000000075761165425052100153000ustar00rootroot00000000000000Shaper Control Tool Readme File

Download & update
=================

Project page at Sourceforge:
http://sourceforge.net/projects/sc-tool/

Project page at BitBucket:
http://bitbucket.org/sky/sc/

Source code repositories:
http://bitbucket.org/sky/sc/src/
http://mercurial.intuxication.org/hg/sc/
http://sc-tool.hg.sourceforge.net/hgweb/sc-tool/


Installation
============

0. Install Linux kernel that supports "u32" classifier (CONFIG_NET_CLS_U32),
traffic control actions (CONFIG_NET_CLS_ACT, CONFIG_NET_ACT_GACT), traffic
policing (CONFIG_NET_ACT_POLICE), and (optionally) "flow" classifier
(CONFIG_NET_CLS_FLOW).

1. Install Perl 5 and the following modules:
AppConfig, DBI, DBD-module for your database (DBD::Pg, DBD::SQLite,
DBD::mysql, etc), Getopt::Long, Pod::Usage, Term::ANSIColor, Sys::Syslog.

a. Installation from package repository of your Linux distribution.

Example for Debian:
# aptitude install perl perl-base perl-doc perl-modules libdbi-perl \
libdbd-sqlite3-perl libappconfig-perl

b. Installation of modules from CPAN.
# cpan AppConfig DBI DBD::SQLite Getopt::Long Pod::Usage \
Term::ANSIColor Sys::Syslog

If you see that the output of "sc help" command is broken, please update
Pod::Usage module from CPAN.

2. Install iproute2 suite. The latest version from
<http://deversources.linuxfoundation.org/dev/iproute2/download> is preferred.

3. Install iptables and ipset <http://ipset.netfilter.org/> if you are
planning to use "flow" classifier.

5. Install sc, manpages, configuration file and init script.

# make install

SC comes with prepared init script that should be installed to location
/etc/init.d/sc. To enable automatic start of the shaper script you should
create appropriate symlinks in the runlevel directories. In Debian and related
distributives you may use the following command:

# update-rc.d sc defaults


Configuration and usage
=======================

1. Database settings

By default, sc stores it's data in SQLite database at /etc/sc/sc.db, but it
can use any other DBI-compatible database server like MySQL, PostgreSQL or
Oracle. If you plan to load the data from a remote database on a dedicated
server, you must install corresponding Perl DBD module, configure database
driver and SQL-queries that will produce correct output for sc. The first
column must contain an IP-addresses in integer representation, and the second
column provides the integer bandwith rate values (see default value of
"query_create" parameter).

Rate units are defined by "rate_unit" parameter in sc.conf or by similar
command line option. Default rate unit is 1 Kibit/s = 1024 bit/s.

If you plan to use shaper with it's own SQLite database, you need to create it
and add some data.

# sc dbcreate
# sc dbadd 172.16.0.1 10Mibit
# sc dbadd 172.16.0.2 20Mibit

You may also use "genbase" script to generate some database entries with
random values of bandwidth rates.


2. Synchronization of rules with database

To perform the synchronization of the shaping rules with the database entries
you should edit your crontab file. The following example of crontab(5) entry
creates the cron(8) task which performs the synchronization of the rules every
10 minutes:

*/10 * * * * root /usr/local/sbin/sc sync

If you want to have rates that will differ from that stored in the database
you should edit the rate_ratio in the sc.conf file with the suitable cron
instruction. There is no need to reload the rules manually if you use the
task for synchronization every 10 minutes from the example above.

Examples of cron instructions for setting rate_ratio = 1.5 at 02:00 and
changing it back to 1.0 at 07:00 every day:

0 2 * * * root sed -i 's/^rate_ratio.*=.*/rate_ratio = 1.5/g' /etc/sc/sc.conf
0 7 * * * root sed -i 's/^rate_ratio.*=.*/rate_ratio = 1.0/g' /etc/sc/sc.conf

3. Syslog

SC can log errors and warnings through syslog. To enable this feature set
"syslog" option to 1 in /etc/sc/sc.conf.

shapercontrol-1.3.4/genbase000075500000000000000000000030311165425052100157300ustar00rootroot00000000000000#!/usr/bin/perl

# genbase - generator of random data for sc databases

use strict;
use warnings;
use Getopt::Long;

my $rate_unit = 'kibit';

my $PROG = 'genbase';
my $VERSION = '1.0.0';

my $ip_i;
my $ip_f;
my $create = 0;
my $help = 0;

my %optd = (
'i=s' => \$ip_i,
'f=s' => \$ip_f,
'create|c!' => \$create,
'help|h!' => \$help,
);

GetOptions(%optd) or exit 1;

usage(0) if $help;
usage(1) if !defined $ip_i || !defined $ip_f;

my $intip_i = ip_texttoint($ip_i);
my $intip_f = ip_texttoint($ip_f);

if ($intip_i > $intip_f || $intip_f - $intip_i > 2**16 - 1) {
die "$PROG: IP interval ${ip_i}-${ip_f} is incorrect";
}

open my $SCH, q{|-}, './sc -b' or
die "$PROG: unable to open pipe for sc";

print $SCH "dbcreate\n" if $create;

for my $i ($intip_i .. $intip_f) {
my $rate = 1 << (int(rand(9)) + 7);
print {$SCH} "dbadd ", ip_inttotext($i), " $rate$rate_unit\n";
}
close $SCH or die "$PROG: unable to close pipe for sc";

exit(0);

sub ip_texttoint
{
my $ip = shift;
my @oct = split /\./ixms, $ip;
my $int = 0;
for my $i (0..3) {
$int += $oct[$i]*( 1 << 8*(3-$i) );
}
return $int;
}

sub ip_inttotext
{
my $int = shift;
my @oct;

for my $i (0..3) {
my $div = 1 << 8*(3-$i);
$oct[$i] = int($int/$div);
$int %= $div;
}
return join q{.}, @oct;
}

sub usage
{
my $ret = shift;
print STDERR <<"EOF"
$PROG (version $VERSION) - generator of random data for sc databases

Usage: $PROG [-c|--create] -i <init-ip> -f <final-ip>

Example:
$PROG -c -i 172.16.0.1 -f 172.16.5.255
$PROG -i 10.0.0.1 -f 10.0.1.255

EOF
;
exit($ret);
}

shapercontrol-1.3.4/sc000075500000000000000000001612621165425052100147440ustar00rootroot00000000000000#!/usr/bin/perl

use strict;
use warnings;
use Carp;
use Getopt::Long qw( GetOptionsFromArray );
use DBI;
use Pod::Usage;
use Sys::Syslog;
use AppConfig qw( :expand );
use Term::ANSIColor qw( :constants );
use POSIX qw( isatty );

#
# Configurable parameters
#

my $cfg_file = '/etc/sc/sc.conf';

my $iptables = '/sbin/iptables';
my $tc = '/sbin/tc';
my $ipset = '/usr/local/sbin/ipset';

use constant {
DEBUG_OFF => 0, # no debug output
DEBUG_ON => 1, # print command line that caused error
DEBUG_PRINT => 2, # print all commands instead of executing them
};
my $debug = DEBUG_OFF;

use constant {
VERB_OFF => 0, # no verbose messages
VERB_ON => 1, # enable messages
VERB_NOBATCH => 2, # disable batch modes of tc and ipset
};
my $verbose = VERB_OFF;

my $quiet = 0;
my $colored = 1;
my $batch = 0;
my $joint = 0;

my $o_if = 'eth0';
my $i_if = 'eth1';

my $db_driver = 'sqlite';
my $db_host = '127.0.0.1';
my $db_user = 'username';
my $db_pass = 'password';
my $db_name = 'sc.db';

my $query_create = 'CREATE TABLE rates (ip UNSIGNED INTEGER PRIMARY KEY, '.
'rate UNSIGNED INTEGER NOT NULL)';
my $query_load = 'SELECT ip, rate FROM rates';
my $query_list = 'SELECT ip, rate FROM rates WHERE ip=?';
my $query_add = 'INSERT INTO rates VALUES (?, ?)';
my $query_del = 'DELETE FROM rates WHERE ip=?';
my $query_change = 'REPLACE INTO rates VALUES (?, ?)';

my $set_name = 'pass';
my $set_type = 'ipmap';
my $set_size = '65536';
my $chain_name = 'FORWARD';
my $policer_burst_ratio = 0.1;
my $quantum = '1500';
my $rate_unit = 'kibit';
my $rate_ratio = 1.0;
my $leaf_qdisc = 'pfifo limit 50';
my $network = '172.16.0.0/16';
my $filter_network = $network;
my $filter_method = 'u32';
my $limit_method = 'shaping';

my (%filter_nets, %class_nets);

my $syslog = 0;
my $syslog_options = q{};
my $syslog_facility = 'user';

#
# Internal variables and constants
#

my $PROG = 'sc';
my $VERSION = '1.3.4';
my $VERSTR = "Shaper Control Tool (version $VERSION)";

# command dispatch table
my %cmdd = (
'add' => {
# handler (points to function that performs action)
'handler' => \&cmd_add,
# database handler (optional)
'dbhandler' => \&cmd_dbadd,
# arguments (optional)
'arg' => '<ip> <rate>',
# command description
'desc' => 'add rules',
# check root privileges before execution (optional)
'priv' => 1,
},
'calc' => {
'handler' => \&cmd_calc,
'arg' => '[ip]',
'desc' => 'calculate and print internally used values',
'priv' => 0,
},
'change|mod' => {
'handler' => \&cmd_change,
'dbhandler' => \&cmd_change,
'arg' => '<ip> <rate>',
'desc' => 'change rate',
'priv' => 1,
},
'del|rm' => {
'handler' => \&cmd_del,
'dbhandler' => \&cmd_dbdel,
'arg' => '<ip>',
'desc' => 'delete rules',
'priv' => 1,
},
'list|ls' => {
'handler' => \&cmd_list,
'arg' => '[ip] ...',
'desc' => 'list current rules in human-readable form',
'priv' => 1,
},
'help' => {
'handler' => \&cmd_help,
'desc' => 'show help and available database drivers',
'priv' => 0,
},
'init' => {
'handler' => \&cmd_init,
'desc' => 'initialization of rules',
'priv' => 1,
},
'sync' => {
'handler' => \&cmd_sync,
'desc' => 'synchronize rules with database',
'priv' => 1,
},
'load|start' => {
'handler' => \&cmd_load,
'desc' => 'load information from database and create all rules',
'priv' => 1,
},
'ratecvt' => {
'handler' => \&cmd_ratecvt,
'arg' => '<rate> <unit>',
'desc' => 'convert rate unit',
'priv' => 0,
},
'reload|restart' => {
'handler' => \&cmd_reload,
'desc' => 'reset and load rules',
'priv' => 1,
},
'reset|stop' => {
'handler' => \&cmd_reset,
'desc' => 'delete all shaping rules',
'priv' => 1,
},
'show' => {
'handler' => \&cmd_show,
'arg' => '[ip] ...',
'desc' => 'show rules explicitly',
'priv' => 1,
},
'status' => {
'handler' => \&cmd_status,
'desc' => 'show status of rules',
'priv' => 1,
},
'version' => {
'handler' => \&cmd_ver,
'desc' => 'output version and copyright information',
'priv' => 0,
},
'dbadd' => {
'handler' => \&cmd_dbadd,
'arg' => '<ip> <rate>',
'desc' => 'add database entry',
'priv' => 0,
},
'dbdel|dbrm' => {
'handler' => \&cmd_dbdel,
'arg' => '<ip>',
'desc' => 'delete database entry',
'priv' => 0,
},
'dblist|dbls' => {
'handler' => \&cmd_dblist,
'arg' => '[ip]',
'desc' => 'list database entries',
'priv' => 0,
},
'dbchange|dbmod' => {
'handler' => \&cmd_dbchange,
'arg' => '<ip> <rate>',
'desc' => 'change database entry',
'priv' => 0,
},
'dbcreate' => {
'handler' => \&cmd_dbcreate,
'desc' => 'create database and table',
'priv' => 0,
},
);

# pointers to functions for rule handling
my ($rul_init, $rul_add, $rul_del, $rul_change, $rul_load,
$rul_batch_start, $rul_batch_stop, $rul_show, $rul_reset);

# rate unit transformation coefficients
my %units = (
# bit-based
'bit' => 1,
'kibit|Kibit' => 2**10,
'kbit|Kbit' => 1_000,
'mibit|Mibit' => 2**20,
'mbit|Mbit' => 10**6,
'gibit|Gibit' => 2**30,
'gbit|Gbit' => 10**9,
# byte-based
'bps|Bps' => 8,
'kibps|KiBps' => 2**13,
'kbps|KBps' => 8_000,
'mibps|MiBps' => 2**23,
'mbps|MBps' => 8*10**6,
'gibps|GiBps' => 2**33,
'gbps|GBps' => 8*10**9,
);

# Error codes
use constant {
E_OK => 0,
E_PARAM => 1,
E_IP_COLL => 2,
E_UNDEF => 3,
E_EXIST => 4,
E_NOTEXIST => 5,
E_CMD => 6,
E_PRIV => 7,
};

# global return value
my $RET = E_OK;

# Preamble for usage and help message
my $usage_preamble = <<"EOF"
$VERSTR

Usage: $PROG [options] command <arguments>

Commands:
EOF
;

# options dispatch table for AppConfig and Getopt::Long
my %optd = (
'f|config=s' => \$cfg_file,
'iptables=s' => \$iptables,
'tc=s' => \$tc,
'ipset=s' => \$ipset,
'o|out_if=s' => \$o_if,
'i|in_if=s' => \$i_if,
'filter_method=s' => \$filter_method,
'limit_method=s' => \$limit_method,
'd|debug=i' => \$debug,
'v|verbose=i' => \$verbose,
'q|quiet!' => \$quiet,
'c|colored!' => \$colored,
'j|joint!' => \$joint,
'b|batch!' => \$batch,
'N|network=s' => \$network,
'filter_network=s' => \$filter_network,
'policer_burst_ratio=s' => \$policer_burst_ratio,
'quantum=s' => \$quantum,
'u|rate_unit=s' => \$rate_unit,
'r|rate_ratio=f' => \$rate_ratio,
'leaf_qdisc=s' => \$leaf_qdisc,
'chain=s' => \$chain_name,
's|set_name=s' => \$set_name,
'set_type=s' => \$set_type,
'set_size=s' => \$set_size,
'db_driver=s' => \$db_driver,
'db_host=s' => \$db_host,
'db_name=s' => \$db_name,
'db_user=s' => \$db_user,
'db_pass=s' => \$db_pass,
'query_create=s' => \$query_create,
'query_load=s' => \$query_load,
'query_list=s' => \$query_list,
'query_add=s' => \$query_add,
'query_del=s' => \$query_del,
'query_change=s' => \$query_change,
'S|syslog' => \$syslog,
'syslog_options' => \$syslog_options,
'syslog_facility=s' => \$syslog_facility,
);

my %db_data;
my %rul_data;

# handlers and pointers for execution of external commands
my ($TC_H, $IPS_H);
my $TC = \&tc_sys;
my $IPS = \&ips_sys;
my $sys;

# pref values for different types of tc filters
my $pref_hash = 10; # hashing filters and flow
my $pref_leaf = 20; # hash table entries
my $pref_default = 30; # default rule

my $ip_re = '\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}';

#
# Main routine
#

# parse command line to get the name of configuration file properly
my @argv = @ARGV;
GetOptionsFromArray(\@argv, %optd) or exit E_PARAM;
my $batch_cl = $batch;

# read configuration file
if (-T $cfg_file) {
my @args = keys %optd;
my @cargs = @args;

my $cfg = AppConfig->new({
CASE => 1, GLOBAL => { EXPAND => EXPAND_VAR | EXPAND_ENV }
});

$cfg->define(@args);
$cfg->file($cfg_file);
# prepare list of configuration file parameters and get their values
for my $i (0..$#cargs) {
$cargs[$i] =~ s/^\w+\|//ixms;
$cargs[$i] =~ s/[=!+].*$//ixms;
${ $optd{$args[$i]} } = $cfg->get( $cargs[$i] );
}
}
else {
log_carp("unable to read configuration file $cfg_file");
}

# override values that we read from file by the command line parameters
GetOptions(%optd) or exit E_PARAM;

if ($batch) {
# command queue for batch mode
my @queue;

while (my $c = <>) {
chomp $c;
next if $c =~ /^\s*$/ixms;
next if $c =~ /^\#/ixms;
$c =~ s/\s+\#.*$//ixms;
push @queue, $c;
}
foreach (@queue) {
my @a = split /\ /ixms;
$RET = main(@a);
}
}
else {
$RET = main(@ARGV);
}

exit $RET;

## end of main routine

sub main
{
my @argv = @_;
my $ret = E_OK;

# process command line in batch mode
if ($batch) {
GetOptionsFromArray(\@argv, %optd) or return E_PARAM;
}
usage(E_CMD) if !defined $argv[0];
my $cmd = acomp_cmd($argv[0]);
usage(E_CMD) if !defined $cmd;
return E_CMD if $cmd eq q{};

if ($cmdd{$cmd}{'priv'} && !$debug && $>) {
log_warn('you must run this command with root privileges');
return E_PRIV;
}

# prepare all settings
set_ptrs();
set_class_nets();
set_filter_nets();
local $ENV{ANSI_COLORS_DISABLED} = 1 if !($colored && isatty(\*STDOUT));

# call handler
shift @argv;
$ret = $cmdd{$cmd}{'handler'}->(@argv);

# process return values
if (!defined $ret) {
$ret = -1;
return $ret;
}
elsif ($ret == E_NOTEXIST) {
log_carp("specified IP does not exist. Arguments: @argv");
}
elsif ($ret == E_EXIST) {
log_carp("specified IP already exists. Arguments: @argv");
}

if ($joint && defined $cmdd{$cmd}{'dbhandler'}) {
$ret = $cmdd{$cmd}{'dbhandler'}->(@argv);
if ($ret == E_NOTEXIST) {
log_carp(
'database entry for specified IP does not exist. '.
"Arguments: @argv"
);
}
elsif ($ret == E_EXIST) {
log_carp(
'database entry for specified IP already exists. '.
"Arguments: @argv"
);
}
}
return $ret;
}

sub usage
{
my ($ret) = @_;
print $usage_preamble;
print_cmds();
print "\n";
exit $ret;
}

sub print_cmds
{
my @cmds = sort keys %cmdd;
my ($maxcmdlen, $maxarglen) = (0, 0);
my @colspace = (2, 2, 3);
my ($al, $cl);
my %lengths;

# find maximum length of command and arguments
foreach my $key (@cmds) {
my @aliases = split /\|/ixms, $key;
$lengths{$key}{'cmd'} = $aliases[0];

$cl = length $aliases[0];
$lengths{$key}{'cmdl'} = $cl;
$maxcmdlen = $cl if $maxcmdlen < $cl;

$al = (defined $cmdd{$key}{'arg'})
? length $cmdd{$key}{'arg'} : 0;
$lengths{$key}{'argl'} = $al;
$maxarglen = $al if $maxarglen < $al;
}

foreach my $key (@cmds) {
next unless nonempty($cmdd{$key}{'desc'});
print q{ } x $colspace[0], $lengths{$key}{'cmd'},
q{ } x ($maxcmdlen - $lengths{$key}{'cmdl'} + $colspace[1]);
print $cmdd{$key}{'arg'} if defined $cmdd{$key}{'arg'};
print q{ } x ($maxarglen - $lengths{$key}{'argl'} + $colspace[2]),
$cmdd{$key}{'desc'}, "\n";
}
return;
}

sub set_ptrs
{
if ($debug == DEBUG_OFF) {
$sys = ($quiet)
? sub { return system "@_ >/dev/null 2>&1"; }
: sub { return system @_; };
}
elsif ($debug == DEBUG_ON) {
$sys = sub {
my ($c) = @_;
print RED, "$c\n", RESET if system $c;
return $?;
}
}
elsif ($debug == DEBUG_PRINT) {
$sys = sub { return print "@_\n"; }
}

if ($filter_method eq 'flow') {
$rul_batch_start = sub {
unless ($verbose & VERB_NOBATCH) {
tc_batch_start();
ips_batch_start();
}
};
$rul_batch_stop = sub {
unless ($verbose & VERB_NOBATCH) {
tc_batch_stop();
ips_batch_stop();
}
ipt_init();
};
$rul_init = \&flow_init;
$rul_add = \&flow_add;
$rul_del = \&flow_del;
$rul_change = \&htb_change;
$rul_load = \&flow_load;
$rul_show = \&flow_show;
$rul_reset = \&flow_reset;
}
elsif ($filter_method eq 'u32') {
$rul_batch_start = sub {
tc_batch_start() unless $verbose & VERB_NOBATCH;
};
$rul_batch_stop = sub {
tc_batch_stop() unless $verbose & VERB_NOBATCH;
};

if ($limit_method eq 'shaping') {
$rul_init = \&u32_init;
$rul_add = \&u32_add;
$rul_del = \&u32_del;
$rul_change = \&htb_change;
$rul_load = \&u32_load;
$rul_show = \&u32_show;
$rul_reset = \&htb_reset;
}
elsif ($limit_method eq 'policing') {
$rul_init = \&pol_init;
$rul_add = \&pol_add;
$rul_del = \&pol_del;
$rul_change = \&pol_add;
$rul_load = \&pol_load;
$rul_show = \&pol_show;
$rul_reset = \&pol_reset;
}
elsif ($limit_method eq 'hybrid') {
$rul_init = \&hybrid_init;
$rul_add = \&hybrid_add;
$rul_del = \&hybrid_del;
$rul_change = \&hybrid_change;
$rul_load = \&pol_load;
$rul_show = \&hybrid_show;
$rul_reset = \&hybrid_reset;
}
else {
log_croak(
"\'$limit_method\' is invalid value for limit_method"
);
}
}
else {
if ($limit_method eq 'policing') {
log_croak(
'Policing can be used only when filter_method = u32'
);
return;
}
log_croak(
"\'$filter_method\' is invalid value for filter_method"
);
}
return;
}

sub nonempty
{
my ($str) = @_;
return (defined $str && $str ne q{});
}

sub round
{
my ($n) = @_;
return int($n + .5*($n <=> 0));
}

# autocompletion for commands
sub acomp_cmd
{
my ($input) = @_;
my @match;
my @ambig;

foreach my $key (keys %cmdd) {
my @cmds = split /\|/ixms, $key;
foreach my $a (@cmds) {
if ($a =~ /^$input/xms) {
push @match, $key;
push @ambig, $a;
last;
}
}
}

if ($#match == 0) {
return $match[0];
}
elsif ($#match > 0) {
log_warn("command \'$input\' is ambiguous:\n @ambig");
return q{};
}
else {
log_warn("unknown command \'$input\'\n");
return;
}
}

sub log_syslog
{
my ($severity, $msg) = @_;

openlog($PROG, $syslog_options, $syslog_facility);
syslog($severity, $msg);
closelog();
return $!;
}

sub log_carp
{
my ($msg) = @_;

log_syslog('warn', $msg) if $syslog;
carp "$PROG: $msg" if !$quiet;
return $!;
}

sub log_croak
{
my ($msg) = @_;

log_syslog('err', $msg) if $syslog;
if ($quiet) {
exit $!;
}
else {
croak "$PROG: $msg";
}
}

sub log_warn
{
my ($msg) = @_;

log_syslog('warn', $msg) if $syslog;
print {*STDERR} "$PROG: $msg\n" if !$quiet;
return $!;
}

sub arg_check
{
my ($issub, $arg, $argname) = @_;
my $result = 0;

log_croak("$argname is undefined") if !defined $arg;
$result = $issub->($arg);
log_croak("$arg is invalid $argname") if !$result;
return $result;
}

sub is_ip
{
my ($ip) = @_;

chomp $ip;
if ($ip =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ixms) {
if ($1 > 0 && $1 < 255 && $2 >= 0 && $2 <= 255 &&
$3 >= 0 && $3 <= 255 && $4 >= 0 && $4 <= 255) {
return $ip;
}
}
return 0;
}

sub is_rate
{
my ($rate) = @_;
chomp $rate;
my $result = 0;
my ($num, $unit);

if (($num, $unit) = $rate =~ /^([0-9]+)([A-z]*)$/xms) {
return 0 if $num == 0;
if (nonempty($unit)) {
foreach my $u (keys %units) {
if ($unit =~ /^(?:$u)$/xms) {
$result = $rate;
last;
}
}
}
else {
$result = $num . $rate_unit;
}
}
else {
return 0;
}
return $result;
}

sub ip_inttotext
{
my ($int) = @_;
my @oct;

for my $i (0..3) {
my $div = 1 << 8*(3-$i);
$oct[$i] = int $int/$div;
$int %= $div;
}
return join q{.}, @oct;
}

sub ip_texttoint
{
my ($ip) = @_;
my @oct = split /\./ixms, $ip;
my $int = 0;

for my $i (0..3) {
$int += $oct[$i] * (1 << 8*(3-$i));
}
return $int;
}

sub rate_cvt
{
my ($rate, $dst_unit) = @_;
my ($num, $unit, $s_key, $d_key);

if (($num) = $rate =~ /^([0-9]+)([A-z]*)$/xms) {
$unit = nonempty($2) ? $2 : $rate_unit;
return $rate if $unit eq $dst_unit;
foreach my $u (keys %units) {
if ($unit =~ /^($u)$/xms) {
$s_key = $u;
last;
}
}
}
else {
log_croak('invalid rate specified');
}
log_croak('invalid source unit specified') if !defined $s_key;

foreach my $u (keys %units) {
if ($dst_unit =~ /^($u)$/xms) {
$d_key = $u;
last;
}
}
log_croak('invalid destination unit specified') if !defined $d_key;
my $dnum = round($num * $units{$s_key} / $units{$d_key});
return "$dnum$dst_unit";
}

sub db_connect
{
my $dbh;

if ($db_driver =~ /sqlite/ixms) {
$dbh = DBI->connect(
"DBI:SQLite:${db_name}",
$db_user, $db_pass, { RaiseError => 1, AutoCommit => 1 }
);
}
else {
$dbh = DBI->connect(
"DBI:${db_driver}:dbname=$db_name;host=$db_host",
$db_user, $db_pass, { RaiseError => 1, AutoCommit => 1 }
);
}
return $dbh;
}

sub db_load
{
my $dbh = db_connect();
my $sth = $dbh->prepare($query_load);
$sth->execute();
my ($intip, $rate, $ip, $cid);

while (my $ref = $sth->fetchrow_arrayref()) {
($intip, $rate) = @{$ref};
if (!defined $rate) {
log_carp("IP $ip has undefined rate, skipping\n");
next;
}
$ip = ip_inttotext($intip);
$cid = ip_classid($ip);
$db_data{$cid}{'rate'} = $rate;
$db_data{$cid}{'ip'} = $ip;
}
$sth->finish();
undef $sth;
$dbh->disconnect();
return $dbh;
}

#
# Common rule processing functions
#

sub set_class_nets
{
my $cid_min = 2;
my $cid_max = 0xFFFF;
my $cid_i = $cid_min;

foreach my $n (split /\ /ixms, $network) {
my ($netip, $netmask) = split /\//ixms, $n;

log_croak("network mask $netmask is not supported. Network: $n")
if $netmask < 16;

$class_nets{$n}{'ip'} = $netip;
$class_nets{$n}{'mask'} = $netmask;
my $invmask = 2**(32 - $netmask) - 1;
my $intmask = 2**32 - 1 - $invmask;
my $ip_i = ip_texttoint($netip) & $intmask;
$class_nets{$n}{'invmask'} = $invmask;
$class_nets{$n}{'intip_i'} = $ip_i;
$class_nets{$n}{'intip_f'} = $ip_i + $invmask;
$class_nets{$n}{'classid_i'} = $cid_i;
$cid_i += $invmask + 1;
log_croak("network $n overfulls classid space")
if $cid_i - $cid_min - 1 > $cid_max;
}
return;
}

sub ip_classid
{
my ($ip) = @_;
my $intip = ip_texttoint($ip);
my $cid;

foreach my $n (keys %class_nets) {
if ($intip >= $class_nets{$n}{'intip_i'} &&
$intip <= $class_nets{$n}{'intip_f'}) {
my $offset = $intip & $class_nets{$n}{'invmask'};
$cid = sprintf '%x', $class_nets{$n}{'classid_i'} + $offset;
last;
}
}
log_croak(
"$ip does not belong to any of specified networks: $network"
) if !defined $cid;
return $cid;
}

sub print_rules
{
my ($comment, @cmds) = @_;
my @out;
my $PIPE;

foreach my $c (@cmds) {
open $PIPE, '-|', $c or log_croak("unable to open pipe for $c");
push @out, <$PIPE>;
close $PIPE or log_croak("unable to close pipe for $c");
}
if (@out) {
print BOLD, "$comment\n", RESET if nonempty($comment);
print @out;
}
return $?;
}

sub tc_sys
{
my ($c) = @_;
return $sys->("$tc $c");
}

sub tc_batch
{
my ($c) = @_;
return print {$TC_H} "$c\n";
}

sub tc_batch_start
{
if ($debug == DEBUG_PRINT) {
open $TC_H, '>', 'tc.batch'
or log_croak('unable to open tc.batch');
}
else {
open $TC_H, '|-', "$tc -batch"
or log_croak("unable to create pipe for $tc");
}
$TC = \&tc_batch;
return $TC_H;
}

sub tc_batch_stop
{
$TC = \&tc_sys;
return close $TC_H;
}

sub htb_change
{
my ($ip, $cid, $rate) = @_;
my $ceil = $rate;

htb_dev_change($i_if, $cid, $rate, $ceil);
htb_dev_change($o_if, $cid, $rate, $ceil);
return $?;
}

sub htb_dev_change
{
my ($dev, $cid, $rate, $ceil) = @_;

$TC->(
"class change dev $dev parent 1:0 classid 1:$cid htb ".
"rate $rate ceil $ceil quantum $quantum"
);
return $?;
}

sub htb_reset
{
$sys->("$tc qdisc del dev $o_if root handle 1: htb");
$sys->("$tc qdisc del dev $i_if root handle 1: htb");
return $?;
}

#
# Flow filter functions
#

sub flow_init
{
flow_dev_init($i_if);
flow_dev_init($o_if);

if ($set_type eq 'ipmap') {
$IPS->("-N $set_name $set_type --network $network");
}
elsif ($set_type eq 'iphash') {
$IPS->("-N $set_name $set_type --hashsize $set_size");
}
else {
log_croak("unknown set type \'$set_type\' specified");
}
return $?;
}

sub flow_dev_init
{
my ($dev) = @_;

$TC->("qdisc add dev $dev root handle 1: htb");
$TC->(
"filter add dev $dev parent 1:0 protocol ip pref $pref_hash ".
"handle 1 flow map key src and 0xffff"
);
return $?;
}

sub flow_add
{
my ($ip, $cid, $rate) = @_;
my $ceil = $rate;
flow_dev_add($i_if, $cid, $rate, $ceil);
flow_dev_add($o_if, $cid, $rate, $ceil);
$IPS->("-A $set_name $ip");
return $?;
}

sub flow_dev_add
{
my ($dev, $cid, $rate, $ceil) = @_;

$TC->(
"class replace dev $dev parent 1: classid 1:$cid ".
"htb rate $rate ceil $ceil quantum $quantum"
);
$TC->(
"qdisc replace dev $dev parent 1:$cid handle $cid:0 $leaf_qdisc"
);
return $?;
}

sub flow_del
{
my ($ip, $cid) = @_;

$IPS->("-D $set_name $ip");
flow_dev_del($i_if, $cid);
flow_dev_del($o_if, $cid);
return $?;
}

sub flow_dev_del
{
my ($dev, $cid) = @_;

$TC->("qdisc del dev $dev parent 1:$cid handle $cid:0");
$TC->("class del dev $dev parent 1: classid 1:$cid");
return $?;
}

sub flow_load
{
my ($ip, $cid, $rate);
my $ret = E_OK;

open my $IPH, '-|', "$ipset -nsL $set_name" or
log_croak("unable to open pipe for $ipset");
my @ipsout = <$IPH>;
close $IPH or log_carp("unable to close pipe for $ipset");
foreach (@ipsout) {
next unless /^$ip_re/xms;
chomp;
$ip = $_;
$cid = ip_classid($ip);
if (defined $rul_data{$cid}{'ip'}) {
log_carp('IP-to-classid collision detected, skipping. OLD: '.
$rul_data{$cid}{'ip'}.", NEW: $ip");
$ret = E_IP_COLL;
next;
}
$rul_data{$cid}{'ip'} = $ip;
}

open my $TCCH, '-|', "$tc class show dev $i_if"
or log_croak("unable to open pipe for $tc");
my @tcout = <$TCCH>;
close $TCCH or log_carp("unable to close pipe for $tc");
foreach (@tcout) {
if (($cid, $rate) = /leaf\ ([0-9a-f]+):\ .*\ rate\ (\w+)/xms) {
next if !defined $rul_data{$cid};
$rate = rate_cvt($rate, $rate_unit);
$rul_data{$cid}{'rate'} = $rate;
}
}
return $ret;
}

sub flow_show
{
my @ips = @_;

if (nonempty($ips[0])) {
foreach my $ip (@ips) {
my $cid = ip_classid($ip);
print_rules(
"TC rules for $ip\n\nInput class [$i_if]:",
"$tc -i -s -d class show dev $i_if | ".
"grep -F -w -A 3 \"leaf $cid\:\""
);
print_rules(
"\nOutput class [$o_if]:",
"$tc -i -s -d class show dev $o_if | ".
"grep -F -w -A 3 \"leaf $cid\:\""
);
print_rules(
"\nInput qdisc [$i_if]:",
"$tc -i -s -d qdisc show dev $i_if | ".
"grep -F -w -A 2 \"$cid\: parent 1:$cid\""
);
print_rules(
"\nOutput qdisc [$o_if]:",
"$tc -i -s -d qdisc show dev $o_if | ".
"grep -F -w -A 2 \"$cid\: parent 1:$cid\""
);
print_rules("\nIPSet entry for $ip:", "$ipset -T $set_name $ip");
print "\n";
}
}
else {
print BOLD, "FILTERS:\n", RESET;
system "$tc -p -s filter show dev $i_if";
system "$tc -p -s filter show dev $o_if";
print BOLD, "\nCLASSES:\n", RESET;
system "$tc -i -s -d class show dev $i_if";
system "$tc -i -s -d class show dev $o_if";
print BOLD, "\nQDISCS:\n", RESET;
system "$tc -i -s -d qdisc show dev $i_if";
system "$tc -i -s -d qdisc show dev $o_if";
print BOLD, "\nIPTABLES RULES:\n", RESET;
system "$iptables -nL";
}
return $?;
}

sub flow_reset
{
ipt_reset();
htb_reset();
return $?;
};

# iptables & ipset functions

sub ipt_init
{
$sys->("$iptables --policy FORWARD DROP");
if ($chain_name ne 'FORWARD') {
$sys->("$iptables --new-chain $chain_name");
$sys->("$iptables -A FORWARD -j $chain_name");
}
$sys->(
"$iptables -A $chain_name -p all -m set --set $set_name src -j ACCEPT"
);
$sys->(
"$iptables -A $chain_name -p all -m set --set $set_name dst -j ACCEPT"
);
return $?;
}

sub ipt_reset
{
if ($chain_name ne 'FORWARD') {
$sys->("$iptables --delete FORWARD -j $chain_name");
$sys->("$iptables --flush $chain_name");
$sys->("$iptables --delete-chain $chain_name");
}
else {
$sys->(
"$iptables -D $chain_name -p all -m set --set $set_name src ".
'-j ACCEPT'
);
$sys->(
"$iptables -D $chain_name -p all -m set --set $set_name dst ".
'-j ACCEPT'
);
}
$sys->("$ipset --flush $set_name");
$sys->("$ipset --destroy $set_name");
return $?;
}

sub ips_sys
{
my ($c) = @_;
return $sys->("$ipset $c");
}

sub ips_batch
{
my ($c) = @_;
return print {$IPS_H} "$c\n";
}

sub ips_batch_start
{
if ($debug == DEBUG_PRINT) {
open $IPS_H, '>', 'ipset.batch'
or log_croak('unable to open ipset.batch');
}
else {
open $IPS_H, '|-', "$ipset --restore"
or log_croak("unable to create pipe for $ipset");
}

$IPS = \&ips_batch;
return $IPS_H;
}

sub ips_batch_stop
{
$IPS = \&ips_sys;
print $IPS_H "COMMIT\n";
return close $IPS_H;
}

#
# u32 hashing filters functions
#

sub set_filter_nets
{
# I restrict this value to a 0x799 to avoid discontinuity of filter space.
# Real maximum number of u32 hash tables is 0xfff.
my $ht_max = 0x799;

# Initial numbers for hash tables of 1st and 2nd nesting levels
#
# Real minimal number of u32 hash tables is 1. 0x100 is taken for
# simplicity.
my $ht1 = 256;
# Difference between initial numbers for hash tables of 1st and 2nd
# nesting levels. Increase this value if you want to set more than 255
# netmasks to filter_network parameter.
my $ht_21 = 256;
my $ht2 = $ht1 + $ht_21;

foreach my $n (split /\ /ixms, $filter_network) {
my ($netip, $netmask) = split /\//ixms, $n;
if ($netmask >= 24 && $netmask < 32) {
$filter_nets{$n}{'leafht_i'} = $ht1;
}
elsif ($netmask >= 16 && $netmask < 24) {
$filter_nets{$n}{'leafht_i'} = $ht2;
$ht2 += 2**(24 - $netmask);
}
else {
log_croak("network mask $netmask is not supported. Network: $n");
}

$filter_nets{$n}{'ip'} = $netip;
$filter_nets{$n}{'mask'} = $netmask;
my $invmask = 2**(32 - $netmask) - 1;
my $intmask = 2**32 - 1 - $invmask;
my $ip_i = ip_texttoint($netip) & $intmask;
$filter_nets{$n}{'invmask'} = $invmask;
$filter_nets{$n}{'intip_i'} = $ip_i;
$filter_nets{$n}{'intip_f'} = $ip_i + $invmask;
$filter_nets{$n}{'ht'} = $ht1;
++$ht1;
log_croak("network $n overfulls filter space")
if $ht2 > $ht_max;
}
return;
}

# calculate leaf hash table and bucket number
#
# input: IP address
# output: leaf hash key, bucket number
sub ip_leafht_key
{
my ($ip) = @_;
my $intip = ip_texttoint($ip);
my ($leafht, $key);

foreach my $n (keys %filter_nets) {
if ($intip >= $filter_nets{$n}{'intip_i'} &&
$intip <= $filter_nets{$n}{'intip_f'}) {
# 3rd octet
my $ht_offset = ($intip & $filter_nets{$n}{'invmask'}) >> 8;
# 4th octet
$key = sprintf '%x', $intip & 0xFF;
$leafht = sprintf '%x', $filter_nets{$n}{'leafht_i'} + $ht_offset;
last;
}
}
log_croak(
"$ip does not belong to any of specified networks: $network"
) if !defined $leafht;
return ($leafht, $key);
}

# calculate divisor and hashkey mask
#
# netmask = mask in decimal form
# n = number of octet
sub u32_div_hmask
{
my ($netmask, $n) = @_;
log_croak("$n is invalid number of octet") if $n < 1 || $n > 4;
# get n-th byte from netmask
my $inthmask = (2**(32 - $netmask) - 1) & (0xFF << 8*(4-$n));
my $hmask = sprintf '0x%08x', $inthmask;
my $div = ($inthmask >> 8*(4-$n)) + 1;
return ($div, $hmask);
}

# u32 hashing filters with shaping

sub u32_init
{
u32_dev_init($o_if, 'src', 12);
u32_dev_init($i_if, 'dst', 16);
return $?;
}

sub u32_dev_init
{
my ($dev, $match, $offset) = @_;

$TC->("qdisc add dev $dev root handle 1: htb");
$TC->("filter add dev $dev parent 1:0 protocol ip pref $pref_hash u32");
foreach my $net (sort {$filter_nets{$a}{'ht'} <=> $filter_nets{$b}{'ht'}}
keys %filter_nets) {
my $ht1 = sprintf '%x', $filter_nets{$net}{'ht'};
my $netmask = $filter_nets{$net}{'mask'};

if ($netmask >= 24 && $netmask < 31) {
my ($div1, $hmask1) = u32_div_hmask($netmask, 4);
$TC->(
"filter add dev $dev parent 1:0 protocol ip pref $pref_hash ".
"handle $ht1: u32 divisor $div1"
);
$TC->(
"filter add dev $dev parent 1:0 protocol ip pref $pref_hash ".
"u32 ht 800:: match ip $match $net ".
"hashkey mask $hmask1 at $offset link $ht1:"
);
}
elsif ($netmask >= 16 && $netmask < 24) {
my @oct = split /\./ixms, $filter_nets{$net}{'ip'};
my ($div1, $hmask1) = u32_div_hmask($netmask, 3);

# parent filter
$TC->(
"filter add dev $dev parent 1:0 protocol ip pref $pref_hash ".
"handle $ht1: u32 divisor $div1"
);
$TC->(
"filter add dev $dev parent 1:0 protocol ip pref $pref_hash ".
"u32 ht 800:: match ip $match $net ".
"hashkey mask $hmask1 at $offset link $ht1:"
);

# child filters
my ($div2, $hmask2) = u32_div_hmask($netmask, 4);
for my $i (0 .. $div1 - 1) {
my $key = sprintf '%x', $i;
my $ht2 = sprintf '%x', $filter_nets{$net}{'leafht_i'} + $i;
my $j = $oct[2] + $i;
my $net2 = "$oct[0].$oct[1].$j.0/24";

$TC->(
"filter add dev $dev parent 1:0 protocol ip ".
"pref $pref_hash handle $ht2: u32 divisor $div2"
);
$TC->(
"filter add dev $dev parent 1:0 protocol ip ".
"pref $pref_hash u32 ht $ht1:$key: ".
"match ip $match $net2 ".
"hashkey mask $hmask2 at $offset link $ht2:"
);
}
}
else {
log_croak("network mask \'\/$netmask\' is not supported");
}
}

# block all other traffic
$TC->(
"filter add dev $dev parent 1:0 protocol ip pref $pref_default ".
'u32 match u32 0 0 at 0 police mtu 1 action drop'
);
return $?;
}

sub u32_add
{
my ($ip, $cid, $rate) = @_;
my $ceil = $rate;
my ($ht, $key) = ip_leafht_key($ip);
u32_dev_add($i_if, $cid, $rate, $ceil, "ip dst $ip", $ht, $key);
u32_dev_add($o_if, $cid, $rate, $ceil, "ip src $ip", $ht, $key);
return $?;
}

sub u32_dev_add
{
my ($dev, $cid, $rate, $ceil, $match, $ht, $key) = @_;

$TC->(
"class replace dev $dev parent 1: classid 1:$cid htb ".
"rate $rate ceil $ceil quantum $quantum"
);
$TC->(
"qdisc replace dev $dev parent 1:$cid handle $cid:0 $leaf_qdisc"
);
$TC->(
"filter replace dev $dev parent 1: pref $pref_leaf ".
"handle $ht:$key:800 u32 ht $ht:$key: match $match flowid 1:$cid"
);
return $?;
}

sub u32_del
{
my ($ip, $cid) = @_;
my ($ht, $key) = ip_leafht_key($ip);

u32_dev_del($i_if, $cid, $ht, $key);
u32_dev_del($o_if, $cid, $ht, $key);
return $?
}

sub u32_dev_del
{
my ($dev, $cid, $ht, $key) = @_;

$TC->(
"filter del dev $dev parent 1: pref $pref_hash ".
"handle $ht:$key:800 u32"
);
$TC->("qdisc del dev $dev parent 1:$cid handle $cid:0");
$TC->("class del dev $dev parent 1: classid 1:$cid");
return $?;
}

sub u32_load
{
my ($ip, $cid, $rate);
my $ret = E_OK;

open my $TCFH, '-|', "$tc -p -iec filter show dev $i_if"
or log_croak("unable to open pipe for $tc");
my @tcout = <$TCFH>;
close $TCFH or log_carp("unable to close pipe for $tc");
for my $i (0 .. $#tcout) {
chomp $tcout[$i];
if (($ip) = $tcout[$i] =~ /match\ IP\ .*\ ($ip_re)\/32/xms) {
if (($cid) = $tcout[$i-1] =~ /flowid\ 1:([0-9a-f]+)/xms) {
$rul_data{$cid}{'ip'} = $ip;
}
}
}

open my $TCCH, '-|', "$tc class show dev $i_if"
or log_croak("unable to open pipe for $tc");
@tcout = <$TCCH>;
close $TCCH or log_carp("unable to close pipe for $tc");
foreach (@tcout) {
if (($cid, $rate) = /leaf\ ([0-9a-f]+):\ .*\ rate\ (\w+)/xms) {
next if !defined $rul_data{$cid};
$rate = rate_cvt($rate, $rate_unit);
$rul_data{$cid}{'rate'} = $rate;
}
}
return $ret;
}

sub u32_show
{
my @ips = @_;

if (nonempty($ips[0])) {
foreach my $ip (@ips) {
arg_check(\&is_ip, $ip, 'IP');
my $cid;

open my $TCFH, '-|', "$tc -p -s filter show dev $i_if"
or log_croak("unable to open pipe for $tc");
my @tcout = <$TCFH>;
close $TCFH or log_carp("unable to close pipe for $tc");
for my $i (0 .. $#tcout) {
chomp $tcout[$i];
if ($tcout[$i] =~ /match\ IP\ .*\ $ip\/32/xms) {
if (($cid) = $tcout[$i-1] =~ /flowid\ 1:([0-9a-f]+)/xms) {
print BOLD, "TC rules for $ip\n\n",
"Input filter [$i_if]:\n", RESET;
print "$tcout[$i-1]\n$tcout[$i]\n";
print_rules(
"\nOutput filter [$o_if]:",
"$tc -p -s filter show dev $o_if | ".
"grep -F -w -B 1 \"match IP src $ip/32\""
);
# tc class
print_rules(
"\nInput class [$i_if]:",
"$tc -i -s -d class show dev $i_if | ".
"grep -F -w -A 3 \"leaf $cid\:\""
);
print_rules(
"\nOutput class [$o_if]:",
"$tc -i -s -d class show dev $o_if | ".
"grep -F -w -A 3 \"leaf $cid\:\""
);
# tc qdisc
print_rules(
"\nInput qdisc [$i_if]:",
"$tc -i -s -d qdisc show dev $i_if | ".
"grep -F -w -A 2 \"$cid\: parent 1:$cid\""
);
print_rules(
"\nOutput qdisc [$o_if]:",
"$tc -i -s -d qdisc show dev $o_if | ".
"grep -F -w -A 2 \"$cid\: parent 1:$cid\""
);
print "\n";
last;
}
}
}
}
}
else {
print BOLD, "FILTERS:\n", RESET;
system "$tc -p -s filter show dev $i_if";
system "$tc -p -s filter show dev $o_if";
print BOLD, "\nCLASSES:\n", RESET;
system "$tc -i -s -d class show dev $i_if";
system "$tc -i -s -d class show dev $o_if";
print BOLD, "\nQDISCS:\n", RESET;
system "$tc -i -s -d qdisc show dev $i_if";
system "$tc -i -s -d qdisc show dev $o_if";
return $?;
}
return $?;
}

# u32 hashing filters with policing

sub pol_init
{
pol_dev_init($o_if, 'dst', 16);
pol_dev_init($i_if, 'src', 12);
return $?;
}

sub pol_dev_init
{
my ($dev, $match, $offset) = @_;

$TC->("qdisc add dev $dev handle ffff: ingress");
$TC->("filter add dev $dev parent ffff: protocol ip pref $pref_hash u32");
foreach my $net (sort {$filter_nets{$a}{'ht'} <=> $filter_nets{$b}{'ht'}}
keys %filter_nets) {
my $ht1 = sprintf '%x', $filter_nets{$net}{'ht'};
my $netmask = $filter_nets{$net}{'mask'};

if ($netmask >= 24 && $netmask < 31) {
my ($div1, $hmask1) = u32_div_hmask($netmask, 4);
$TC->(
"filter add dev $dev parent ffff: protocol ip ".
"pref $pref_hash handle $ht1: u32 divisor $div1"
);
$TC->(
"filter add dev $dev parent ffff: protocol ip ".
"pref $pref_hash u32 ht 800:: match ip $match $net ".
"hashkey mask $hmask1 at $offset link $ht1:"
);
}
elsif ($netmask >= 16 && $netmask < 24) {
my @oct = split /\./ixms, $filter_nets{$net}{'ip'};
my ($div1, $hmask1) = u32_div_hmask($netmask, 3);

# parent filter
$TC->(
"filter add dev $dev parent ffff: protocol ip ".
"pref $pref_hash handle $ht1: u32 divisor $div1"
);
$TC->(
"filter add dev $dev parent ffff: protocol ip ".
"pref $pref_hash u32 ht 800:: match ip $match $net ".
"hashkey mask $hmask1 at $offset link $ht1:"
);

# child filters
my ($div2, $hmask2) = u32_div_hmask($netmask, 4);
for my $i (0 .. $div1 - 1) {
my $key = sprintf '%x', $i;
my $ht2 = sprintf '%x', $filter_nets{$net}{'leafht_i'} + $i;
my $j = $oct[2] + $i;
my $net2 = "$oct[0].$oct[1].$j.0/24";

$TC->(
"filter add dev $dev parent ffff: protocol ip ".
"pref $pref_hash handle $ht2: u32 divisor $div2"
);
$TC->(
"filter add dev $dev parent ffff: protocol ip ".
"pref $pref_hash u32 ht $ht1:$key: ".
"match ip $match $net2 ".
"hashkey mask $hmask2 at $offset link $ht2:"
);
}
}
else {
log_croak("network mask \'\/$netmask\' is not supported");
}
}

# block all other traffic
$TC->(
"filter add dev $dev parent ffff:0 protocol ip pref $pref_default ".
'u32 match u32 0 0 at 0 police mtu 1 action drop'
);
return $?;
}

sub pol_add
{
my ($ip, $cid, $rate) = @_;
my $ceil = $rate;
my ($ht, $key) = ip_leafht_key($ip);

pol_dev_add($i_if, $rate, $ceil, "ip src $ip", $ht, $key);
pol_dev_add($o_if, $rate, $ceil, "ip dst $ip", $ht, $key);
return $?;
}

sub pol_dev_add
{
my ($dev, $rate, $ceil, $match, $ht, $key) = @_;
my $rate_byte = rate_cvt($rate, 'bps');
$rate_byte =~ s/bps//gxms;
my $policer_burst = round($policer_burst_ratio * $rate_byte) . 'b';

$TC->(
"filter replace dev $dev parent ffff: pref $pref_leaf ".
"handle $ht:$key:800 u32 ht $ht:$key: match $match ".
"police rate $rate burst $policer_burst drop flowid ffff:"
);
return $?;
}

sub pol_del
{
my ($ip, $cid) = @_;
my ($ht, $key) = ip_leafht_key($ip);
pol_dev_del($i_if, $ht, $key);
pol_dev_del($o_if, $ht, $key);
return $?
}

sub pol_dev_del
{
my ($dev, $ht, $key) = @_;

$TC->(
"filter del dev $dev parent ffff: pref $pref_hash ".
"handle $ht:$key:800 u32"
);
return $?;
}

sub pol_load
{
my ($ip, $cid, $rate);
my $ret = E_OK;

open my $TCFH, '-|', "$tc -p -iec filter show dev $i_if parent ffff:"
or log_croak("unable to open pipe for $tc");
my @tcout = <$TCFH>;
close $TCFH or log_carp("unable to close pipe for $tc");
for my $i (0 .. $#tcout) {
chomp $tcout[$i];
if (($ip) = $tcout[$i] =~ /match\ IP\ .*\ ($ip_re)\/32/xms) {
$cid = ip_classid($ip);
if (($rate) = $tcout[$i+1] =~ /rate\ ([0-9A-z]+)/xms) {
$rate = rate_cvt($rate, $rate_unit);
$rul_data{$cid}{'ip'} = $ip;
$rul_data{$cid}{'rate'} = $rate;
}
}
}
return $ret;
}

sub pol_show
{
my @ips = @_;

if (nonempty($ips[0])) {
foreach my $ip (@ips) {
arg_check(\&is_ip, $ip, 'IP');
my $cid;
my @tcout;

open my $TCFH, '-|',
"$tc -p -s -iec filter show dev $i_if parent ffff:"
or log_croak("unable to open pipe for $tc");
@tcout = <$TCFH>;
close $TCFH or log_carp("unable to close pipe for $tc");
for my $i (0 .. $#tcout) {
chomp $tcout[$i];
if ($tcout[$i] =~ /match\ IP\ .*\ $ip\/32/xms) {
print BOLD, "TC rules for $ip\n\n",
"Input filter [$i_if]:\n", RESET;
for my $j ($i-1 .. $i+1) {
print "$tcout[$j]\n";
}
last;
}
}
open $TCFH, '-|',
"$tc -p -s -iec filter show dev $o_if parent ffff:"
or log_croak("unable to open pipe for $tc");
@tcout = <$TCFH>;
close $TCFH or log_carp("unable to close pipe for $tc");
for my $i (0 .. $#tcout) {
chomp $tcout[$i];
if ($tcout[$i] =~ /match\ IP\ .*\ $ip\/32/xms) {
print BOLD, "Output filter [$o_if]:\n", RESET;
for my $j ($i-1 .. $i+1) {
print "$tcout[$j]\n";
}
last;
}
}
}
}
else {
print BOLD, "POLICING FILTERS [$i_if]:\n", RESET;
system "$tc -p -s filter show dev $i_if parent ffff:";
print BOLD, "POLICING FILTERS [$o_if]:\n", RESET;
system "$tc -p -s filter show dev $o_if parent ffff:";
return $?;
}
return $?;
}

sub pol_reset
{
$sys->("$tc qdisc del dev $o_if handle ffff: ingress");
$sys->("$tc qdisc del dev $i_if handle ffff: ingress");
return $?;
}

# u32 hashing filters with policing and shaping

sub hybrid_add
{
my ($ip, $cid, $rate) = @_;
my $ceil = $rate;
my ($ht, $key) = ip_leafht_key($ip);

pol_dev_add($i_if, $rate, $ceil, "ip src $ip", $ht, $key);
u32_dev_add($i_if, $cid, $rate, $ceil, "ip dst $ip", $ht, $key);
return $?;
}

sub hybrid_del
{
my ($ip, $cid) = @_;
my ($ht, $key) = ip_leafht_key($ip);
pol_dev_del($i_if, $ht, $key);
u32_dev_del($i_if, $cid, $ht, $key);
return $?
}

sub hybrid_change
{
my ($ip, $cid, $rate) = @_;
my $ceil = $rate;
my ($ht, $key) = ip_leafht_key($ip);

pol_dev_add($i_if, $rate, $ceil, "ip src $ip", $ht, $key);
htb_dev_change($i_if, $cid, $rate, $ceil);
return $?;
}

sub hybrid_show
{
my @ips = @_;

if (nonempty($ips[0])) {
foreach my $ip (@ips) {
arg_check(\&is_ip, $ip, 'IP');
my $cid;
my @tcout;

open my $TCFH, '-|',
"$tc -p -s -iec filter show dev $i_if parent ffff:"
or log_croak("unable to open pipe for $tc");
@tcout = <$TCFH>;
close $TCFH or log_carp("unable to close pipe for $tc");
for my $i (0 .. $#tcout) {
chomp $tcout[$i];
if ($tcout[$i] =~ /match\ IP\ .*\ $ip\/32/xms) {
print BOLD, "TC rules for $ip\n\n",
"Policing filter [$i_if]:\n", RESET;
for my $j ($i-1 .. $i+1) {
print "$tcout[$j]";
}
last;
}
}

open $TCFH, '-|', "$tc -p -s filter show dev $i_if"
or log_croak("unable to open pipe for $tc");
@tcout = <$TCFH>;
close $TCFH or log_carp("unable to close pipe for $tc");
for my $i (0 .. $#tcout) {
chomp $tcout[$i];
if ($tcout[$i] =~ /match\ IP\ .*\ $ip\/32/xms) {
if (($cid) = $tcout[$i-1] =~ /flowid\ 1:([0-9a-f]+)/xms) {
print BOLD, "Input filter [$i_if]:\n", RESET;
print "$tcout[$i-1]\n$tcout[$i]\n";
print_rules(
"\nShaping filter [$i_if]:",
"$tc -p -s filter show dev $i_if | ".
"grep -F -w -B 1 \"match IP dst $ip/32\""
);
print_rules(
"\nShaping class [$i_if]:",
"$tc -i -s -d class show dev $i_if | ".
"grep -F -w -A 3 \"leaf $cid\:\""
);
print_rules(
"\nShaping qdisc [$i_if]:",
"$tc -i -s -d qdisc show dev $i_if | ".
"grep -F -w -A 2 \"$cid\: parent 1:$cid\""
);
print "\n";
last;
}
}
}
}
}
else {
print BOLD, "POLICING FILTERS [$i_if]:\n", RESET;
system "$tc -p -s filter show dev $i_if parent ffff:";
print BOLD, "SHAPING FILTERS [$i_if]:\n", RESET;
system "$tc -p -s filter show dev $i_if";
print BOLD, "\nSHAPING CLASSES [$i_if]:\n", RESET;
system "$tc -i -s -d class show dev $i_if";
print BOLD, "\nSHAPING QDISCS [$i_if]:\n", RESET;
system "$tc -i -s -d qdisc show dev $i_if";
return $?;
}
return $?;
}

sub hybrid_init
{
pol_dev_init($i_if, 'src', 12);
u32_dev_init($i_if, 'dst', 16);
return $?;
}

sub hybrid_reset
{
$sys->("$tc qdisc del dev $i_if handle ffff: ingress");
$sys->("$tc qdisc del dev $i_if root handle 1: htb");
return $?;
}

#
# Command handlers
#

sub cmd_init
{
my $ret = E_OK;

$rul_batch_start->();
$ret = $rul_init->();
$rul_batch_stop->();
return $ret;
}

sub cmd_reset
{
return $rul_reset->();
}

sub cmd_add
{
my ($ip, $rate) = @_;

arg_check(\&is_ip, $ip, 'IP');
$rate = arg_check(\&is_rate, $rate, 'rate');
my $cid = ip_classid($ip);
return $rul_add->($ip, $cid, $rate);
}

sub cmd_del
{
my ($ip) = @_;

arg_check(\&is_ip, $ip, 'IP');
my $cid = ip_classid($ip);
return $rul_del->($ip, $cid);
}

sub cmd_change
{
my ($ip, $rate) = @_;

arg_check(\&is_ip, $ip, 'IP');
$rate = arg_check(\&is_rate, $rate, 'rate');
my $cid = ip_classid($ip);
return $rul_change->($ip, $cid, $rate);
}

sub cmd_list
{
my @ips = @_;
my $ret = $rul_load->();
my $fmt = "%4s %-15s %11s\n";

if (nonempty($ips[0])) {
foreach my $ip (@ips) {
arg_check(\&is_ip, $ip, 'IP');
my $cid = ip_classid($ip);
if (defined $rul_data{$cid}) {
printf $fmt, $cid, $rul_data{$cid}{'ip'},
$rul_data{$cid}{'rate'};
}
}
}
else {
foreach my $cid (sort { hex $a <=> hex $b } keys %rul_data) {
printf $fmt, $cid, $rul_data{$cid}{'ip'}, $rul_data{$cid}{'rate'};
}
}
return $ret;
}

sub cmd_load
{
my $ret = E_OK;

$rul_batch_start->();
$ret = $rul_init->();
db_load();
foreach my $cid (keys %db_data) {
my $r = round($rate_ratio*$db_data{$cid}{'rate'});
$rul_add->($db_data{$cid}{'ip'}, $cid, "$r$rate_unit");
}
$rul_batch_stop->();
return $ret;
}

sub cmd_show
{
return $rul_show->(@_);
}

sub cmd_sync
{
my ($add, $del, $chg) = (0,0,0);

$rul_load->();
db_load();
$rul_batch_start->();

# delete rules for IPs that is not in database
foreach my $rcid (keys %rul_data) {
if (!defined $db_data{$rcid} && defined $rul_data{$rcid}) {
my $ip = $rul_data{$rcid}{'ip'};
print "- $ip\n" if $verbose & VERB_ON;
$rul_del->($ip, $rcid);
$del++;
}
}
foreach my $dcid (keys %db_data) {
# delete entries with zero rates
if ($db_data{$dcid}{'rate'} == 0) {
my $ip = $db_data{$dcid}{'ip'};
print "- $ip\n" if $verbose & VERB_ON;
$rul_del->($ip, $dcid);
$del++;
next;
}
my $db_rate = round($rate_ratio*$db_data{$dcid}{'rate'});
$db_rate .= "$rate_unit";
# add new entries
if (!defined $rul_data{$dcid}) {
my $ip = $db_data{$dcid}{'ip'};
print "+ $ip\n" if $verbose & VERB_ON;
$rul_add->($ip, $dcid, $db_rate);
$add++;
next;
}
# change if rate in database is different
my $rul_rate = $rul_data{$dcid}{'rate'};
if ($rul_rate ne $db_rate) {
my $ip = $db_data{$dcid}{'ip'};
print "* $ip $rul_rate -> $db_rate\n" if $verbose & VERB_ON;
$rul_change->($ip, $dcid, $db_rate);
$chg++;
}
else {
next;
}
}

$rul_batch_stop->();
return ($add, $del, $chg);
}

sub cmd_status
{
my @out;
my $PIPE;
open $PIPE, '-|', "$tc qdisc show dev $i_if"
or log_croak("unable to open pipe for $tc");
@out = <$PIPE>;
close $PIPE or log_croak("unable to close pipe for $tc");

my $rqdisc;
if ($out[0] =~ /^qdisc\ htb/xms) {
$rqdisc = 'htb';
}
elsif (defined $out[1]) {
if ($out[1] =~ /^qdisc\ ingress/xms) {
$rqdisc = 'ingress';
}
}
else {
log_warn('no shaping rules found');
return E_UNDEF;
}

if ($rqdisc eq 'htb') {
my @lqd = split /\ /xms, $leaf_qdisc;
my $lqdisk = $lqd[0];
shift @out;
foreach my $s (@out) {
chomp $s;
if ($s =~ /qdisc\ $lqdisk\ ([0-9a-f]+):/xms) {
log_warn('shaping rules were successfully created');
return E_OK;
}
}
log_warn('htb qdisc found but there is no child queues');
}
elsif ($rqdisc eq 'ingress') {
open $PIPE, '-|', "$tc -p filter show dev $i_if parent ffff:"
or log_croak("unable to open pipe for $tc");
@out = <$PIPE>;
close $PIPE or log_croak("unable to close pipe for $tc");
foreach my $s (@out) {
if ($s =~ /match\ IP.*\/32/xms) {
log_warn('shaping rules were successfully created');
return E_OK;
}
}
log_warn('ingress qdisc found but there is no filters for IPs');
return E_UNDEF;
}
return E_UNDEF;
}

sub cmd_ver
{
print "$VERSTR\n\n";
pod2usage({ -exitstatus => 'NOEXIT', -verbose => 99,
-sections => 'LICENSE AND COPYRIGHT' });
return E_OK;
}

sub cmd_help
{
if ($verbose & VERB_ON) {
pod2usage({ -exitstatus => 0, -verbose => 2 });
}
else {
my $linewidth = 80;
my $indent = ' ';

print "$VERSTR\n\n";
pod2usage({ -exitstatus => 'NOEXIT', -verbose => 99,
-sections => 'SYNOPSIS|COMMANDS|OPTIONS', -output => \*STDOUT });
print "Available database drivers:\n";
my $drv = join q{ }, DBI->available_drivers;
$drv =~ s/([^\n]{1,$linewidth})(?:\b\s*|\n)/$indent$1\n/goixms;
print "$drv\n";
}
return E_OK;
}

sub cmd_dbcreate
{
my $dbh = db_connect();
$dbh->do($query_create);
$dbh->disconnect();
return $dbh;
}

sub cmd_reload
{
cmd_reset();
return cmd_load();
}

sub cmd_dbadd
{
my ($ip, $rate) = @_;

arg_check(\&is_ip, $ip, 'IP');
my $dbh = db_connect();
my $intip = ip_texttoint($ip);
my $intrate = rate_cvt($rate, $rate_unit);
$intrate =~ s/\D//gixms;
my $sth = $dbh->prepare($query_add);
$sth->execute($intip, $intrate);
$sth->finish();
undef $sth;
$dbh->disconnect();
return E_OK;
}

sub cmd_dbdel
{
my @ips = @_;
my $dbh = db_connect();
my $sth;

foreach my $ip (@ips) {
arg_check(\&is_ip, $ip, 'IP');
my $intip = ip_texttoint($ip);
$sth = $dbh->prepare($query_del);
$sth->execute($intip);
$sth->finish();
}
undef $sth;
$dbh->disconnect();
return E_OK;
}

sub cmd_dbchange
{
my ($ip, $rate) = @_;

my $dbh = db_connect();
my $intip = ip_texttoint($ip);
my $intrate = rate_cvt($rate, $rate_unit);
$intrate =~ s/\D//gixms;
my $sth = $dbh->prepare($query_change);
$sth->execute($intip, $intrate);
$sth->finish();
undef $sth;
$dbh->disconnect();
return E_OK;
}

sub cmd_dblist
{
my ($ip) = @_;
my $ret = E_OK;

if (!defined $ip) {
$ret = db_load();
foreach my $cid (sort { hex $a <=> hex $b } keys %db_data) {
printf "%-15s %10s\n", $db_data{$cid}{'ip'},
"$db_data{$cid}{'rate'}$rate_unit";
}
}
else {
arg_check(\&is_ip, $ip, 'IP');
my $intip = ip_texttoint($ip);
my $rate;
my $dbh = db_connect();
my $sth = $dbh->prepare($query_list);
$sth->execute($intip);
while (my $ref = $sth->fetchrow_arrayref()) {
($intip, $rate) = @{$ref};
printf "%-15s %10s\n", $ip, $rate . $rate_unit;
}
$sth->finish();
undef $sth;
$dbh->disconnect();
}
return $ret;
}

sub cmd_ratecvt
{
my ($rate, $unit) = @_;

log_croak('rate is undefined') if !defined $rate;
log_croak('destination unit is undefined') if !defined $unit;
my $result;
$result = rate_cvt($rate, $unit);
print "$result\n";
return E_OK;
}

sub cmd_calc
{
my ($ip) = @_;

if (!defined $ip) {
use Data::Dumper;
print Dumper(\%filter_nets);
print Dumper(\%class_nets);
return E_OK;
}
arg_check(\&is_ip, $ip, 'IP');
my $cid = ip_classid($ip);
my ($ht, $key) = ip_leafht_key($ip);
print "classid = $cid, leaf ht = $ht, key = $key\n";
return E_OK;
}


__END__

=head1 NAME

B<sc> - administration tool for ISP traffic shaper

=head1 SYNOPSIS

B<sc> [options] B<command> [ip] [rate]

=head1 DESCRIPTION

sc(8) is a command-line tool intended to simplify administration of traffic
shaper for Internet service providers. ISP's usually work with the following
configuration: every customer has it's own IP-address and fixed bandwidth.
sc(8) works like a wrapper for tc(8), iptables(8) and ipset(8) abstracting you
from complexity of their rules, so you can think only about IPs and bandwidth
rates and almost forget about classid's, qdiscs, filters and other stuff.

=head2 Main features

=over

=item * Fast loading of large rulesets by using batch modes of tc(8) and
ipset(8).

=item * Effective traffic classification with B<u32> hashing filters or
B<flow> classifier.

=item * Loading of data from any relational database supported by Perl DBI
module.

=item * Synchronization of rules with database.

=item * Batch command execution mode for scripting purposes.

=item * Support of different traffic limiting methods: shaping, policing, and
hybrid.

=back


=head1 PREREQUISITES

=head2 Perl modules

DBI and corresponding database-dependent module (e.g. DBD::Pg for PostgreSQL,
DBD::SQLite for SQLite, etc), AppConfig, Carp, Getopt::Long, Pod::Usage,
Sys::Syslog, Term::ANSIColor.

=head2 Command-line tools

tc(8) from B<iproute2> suite.

=head2 Linux kernel configuration

=over

=item * B<u32> classifier (option B<CONFIG_NET_CLS_U32>=m or y)

=item * Traffic control actions (B<CONFIG_NET_CLS_ACT>=y and
B<CONFIG_NET_ACT_GACT>=m or y)

=back


=head1 COREQUISITES

If you want to use B<flow> filtering method, you should install iptables(8)
and ipset(8), B<flow> classifier (kernel version 2.6.25 or above, option
B<CONFIG_NET_CLS_FLOW>=m or y), and B<ipset> kernel modules (see
L<http://ipset.netfilter.org/> for details).

If you prefer policing as a rate limiting method, you should enable the kernel
option B<CONFIG_NET_ACT_POLICE>.


=head1 COMMANDS

=over 30

=item B<add> <ip> <rate>

Add rules for specified IP

=item B<calc> [ip]

Calculate and print internally used variables: classids, hash table numbers
and keys.

=item B<change> | B<mod> <ip> <rate>

Change rate for specified IP

=item B<dbadd> <ip> <rate>

Add database entry

=item B<dbchange> | B<dbmod> <ip> <rate>

Change database entry

=item B<dbcreate>

Create database and table

=item B<dbdel> | B<dbrm> <ip>

Delete database entry

=item B<dblist> | B<dbls> [ip]

List database entries. If no IP specified, all entries are listed.

=item B<del> | B<rm> <ip>

Delete rules

=item B<help>

Show help for commands, options and list available database drivers. Generate
and show manpage if B<-v 1> option is specified.

=item B<init>

Initialization of firewall and QoS rules. Should be used only for manual rule
editing.

=item B<list> | B<ls> [ip]

List rules in a short and human-readable form. If no IP specified, all entries
are listed.

=item B<load> | B<start>

Load IPs and rates from database and create ruleset

=item B<ratecvt> <rate> <unit>

Convert rate from one unit to another

=item B<reload> | B<restart>

Reset rules and load database

=item B<reset> | B<stop>

Delete all shaping rules

=item B<show> [ip]

Show rules explicitly. If no IP specified, all entries are listed.

=item B<status>

Show status of shaping rules

=item B<sync>

Synchronize rules with database

=item B<version>

Output version

=back


=head1 OPTIONS

=over 8

=item B<-f>, B<--config> file

Read configuration from specified file

=item B<-o>, B<--out_if> if_name

Name of output network interface

=item B<-i>, B<--in_if> if_name

Name of input network interface

=item B<-d>, B<--debug> mode

Possible values:

=over

=item B<0>

no debug (default value),

=item B<1>

print command lines with nonzero return values,

=item B<2>

print all command lines without execution.

=back

=item B<-v>, B<--verbose> mode

Possible values:

=over

=item B<0>

no verbose messages (default)

=item B<1>

enable verbose messages (i.e. for results of `sync' command)

=item B<2>

disable usage of tc(8) and ipset(8) batch rule loading

=item B<3>

do B<1> + B<2>

=back

=item B<-q>, B<--quiet>

Suppress output of error messages from external command-line tools like tc(8),
iptables(8) and ipset(8).

=item B<-c>, B<--colored>

Colorize output of some commands

=item B<-j>, B<--joint>

Joint mode. Add, change and del commands will be applied to rules and database
entries simultaneously.

=item B<-b>, B<--batch>

Batch mode. Commands and options will be read from STDIN.

=item B<-N, --network> "net/mask ..."

Network(s) for classid calculation or for C<ipmap> set (see sc.conf(5) for
details).

=item B<--filter_network> "net/mask ..."

Network(s) for hashing filter generation (see sc.conf(5) for details).

=item B<--policer_burst_ratio> real number

Ratio between the size of policer buffer size and bandwidth rate.

=item B<--quantum> size

Amount of bytes a stream is allowed to dequeue before the next queue gets a
turn.

=item B<-u>, B<--rate_unit> unit

Default rate unit

=item B<-r>, B<--rate_ratio> real number

Ratio between bandwidth rates in rules and in the database.
Used only for B<load> and B<sync> commands.

=item B<-l>, B<--leaf_qdisc> string

Leaf qdisc and parameters

=item B<--chain> name

Name of iptables(8) chain to use

=item B<-s>, B<--set_name> name

Name of IP set for storage of allowed IPs

=item B<--set_type> type

Type of IP set (ipmap or iphash)

=item B<--set_size> size

Size of IP set (up to 65536)

=item B<--db_driver> name

Database driver

=item B<--db_host> host:port

Database server address or hostname

=item B<--db_name> name

Database name to use

=item B<--db_user> name

Database username

=item B<--db_pass> password

Database password. Remember that it is insecure to specify password here.

=item B<-S>, B<--syslog>

Send errors and warnings to syslog

=back


=head1 RATE UNITS

All rates should be specified as integer numbers, possibly followed by a unit.
Bare number implies default unit (kibit).
You may use another unit by changing C<rate_unit> parameter in configuration
file or by setting the similar command line option.

=over 18

=item bit

bit per second

=item kibit, Kibit

kibibit per second (1024)

=item kbit or Kbit

kilobit per second (1000)

=item mibit or Mibit

mebibit per second (1 048 576)

=item mbit or Mbit

megabit per second (10^6)

=item gibit or Gibit

gibibit per second (1 073 741 824)

=item gbit or Gbit

gigabit per second (10^9)

=item bps or Bps

byte per second

=item kibps or KiBps

kibibyte per second

=item kbps or KBps

kilobyte per second

=item mibps or MiBps

mebibyte per second

=item mbps or MBps

megabyte per second

=item gibps or GiBps

gibibyte per second

=item gbps or GBps

gigabyte per second

=back


=head1 USAGE

=over

=item Load accounts from database and create all rules

C<sc load> or C<sc start>

=item Add class for IP 172.16.0.1 with 256kibit/s.

C<sc add 172.16.0.1 256kibit>

=item Change rate to 512kibit/s

C<sc change 172.16.0.1 512kibit>

=item Delete rules for 172.16.0.1

C<sc del 172.16.0.1>

=item Reset all rules

C<sc reset>

=back


=head1 CONFIGURATION

By default B<sc> reads configuration from F</etc/sc/sc.conf> file and uses
SQLite database at F</etc/sc/sc.db>.
See sc.conf(5) for details.

=head1 DIAGNOSTICS

The error messages are printed to standard error.
To print the command lines that return nonzero error codes, use B<-d 1>
option.
To print all generated command lines without execution, use B<-d 2> option.
To disable the usage of the batch modes of tc(8) and ipset(8), use B<-v 2>
option.
For more information please read the section B<OPTIONS>.

Program may return one of the following exit codes or the exit code of the
failed command line that aborted the execution:

=over 4

=item B<0>

correct functioning

=item B<1>

incorrect parameter

=item B<2>

IP-to-classid collision

=item B<3>

parameter is undefined

=item B<4>

IP already exists

=item B<5>

IP does not exist

=item B<6>

incorrect command

=item B<7>

insufficient privileges

=back


=head1 BUGS

For performance reasons, script does not perform checks that require
additional executions of external programs.


=head1 RESTRICTIONS

Due to limited number of classids (from 2 to ffff) you can create only 65534
classes on a single interface.
For similar reasons sc(8) only supports networks with masks from /16 to /31.
u32 classifier allows you to create several hashing filters for /16-/31
networks, but flow classifier works only with single /16 network.
IPs from the different /16 networks with the same last two octets will be
assigned to the same class.

For simplicity of u32 hash table numbers calculation, the maximum number of
entries in C<filter_network> parameter is 255, and the number of hashing
filters is limited by 0x799.


=head1 SEE ALSO

sc.conf(5), tc(8), tc-htb(8), iptables(8), ipset(8), Getopt::Long(3),
AppConfig(3),
http://lartc.org/howto/lartc.adv-filter.hashing.html,
http://www.mail-archive.com/netdev@vger.kernel.org/msg60638.html.


=head1 AUTHOR

Stanislav Kruchinin <stanislav.kruchinin@gmail.com>


=head1 LICENSE AND COPYRIGHT

Copyright (c) 2008-2012. Stanislav Kruchinin.

License: GNU GPL version 2 or later

This is free software: you are free to change and redistribute it.
There is NO WARRANTY; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR
PURPOSE.

=cut

shapercontrol-1.3.4/sc.conf000064400000000000000000000101701165425052100156540ustar00rootroot00000000000000#
# sc.conf - configuration file for shaper control tool
#

# Location of executables
tc = /usr/local/sbin/tc
# iptables and ipset are required when filter_method = flow
#iptables = /usr/local/sbin/iptables
#ipset = /usr/local/sbin/ipset

# Network interfaces
out_if = eth0
in_if = eth1

# Traffic filtering method
#
# u32 - u32 hashing filters
# flow - flow classifier with ipset
filter_method = u32

# Rate limit method
#
# Possible values: shaping, policing or hybrid
#
# Policing can be used only when filter_method = u32.
# Hybrid method uses shaping for download and policing for upload, and all
# the rules are created only for the in_if interface.
limit_method = shaping

# Debugging mode
#
# 0 - no debugging
# 1 - print command line that caused error
# 2 - just print command line without execution
debug = 0

# Message verbosity (boolean).
#
# 0 - no verbose messages
# 1 - enable verbose messages (i.e. for results of `sync' command)
# 2 - disable usage of tc(8) and ipset(8) batch rule loading
# 3 - do 1 + 2
verbose = 0

# Suppress output (boolean)
quiet = 0

# Colored output (boolean)
colored = 1

# Edit both rules and database entries using add/del/change commands (boolean)
joint = 0

# Network list for classid calculation
#
# Allowed numbers of tc classid's are 2--ffff, so the total number of hosts in
# specified networks should be 65534 or less. E.g. allowed only one /16
# network, two /17 networks, and so on. Note, that `flow' classifier works
# only with a single /16 network. Different networks are allowed only when
# filter_method = u32.
#
# Allowed masks: 16-31
network = 10.0.0.0/20 10.0.254.0/24 172.16.0.0/20

# Networks for hashing filters generation
#
# Networks with the same two last octets are supported.
# For simplicity of filter hash table numbers calculation, the maximum number
# of different entries in this list is set to 255.
#
# Allowed masks: 16-31
filter_network = 10.0.0.0/16 172.16.0.0/20

# Ratio between the size of policer buffer size and bandwidth rate
#
# Default value: 0.1
policer_burst_ratio = 0.1

# Amount of bytes a stream is allowed to dequeue before the next queue gets a
# turn.
#
# Default value: default MTU size for Ethernet (1500 bytes).
# Warning: don't use values below the MTU size!
quantum = 1500

# Default rate unit
rate_unit = kibit


# Ratio between bandwidth rates in rules and in the database.
# rule_rate = db_rate * rate_ratio
#
# This coefficient is used only for B<load> and B<sync> commands.
# Default value: 1.0.
# Possible values: any rational number.
rate_ratio = 1.0

# Classless leaf qdisc with parameters
leaf_qdisc = 'pfifo limit 50'

#
# ipset and iptables
#

# Name of set with allowed IP's
#set_name = pass

# Type of set
#
# ipmap - stores IPs from single /16 network (faster)
# iphash - stores IPs from different networks
#set_type = ipmap

# Size of iphash set
#set_size = 65536

# Name of iptables chain that will contain rules for shaped IPs
#
# NOTE: For names other than FORWARD the new chain will be created and
# attached to FORWARD chain.
#chain = FORWARD

#
# Database
#

# Driver
#
# Possible values: SQLite, mysql, Pg, Oracle.
# Requires corresponding DBD module.
# Use 'sc help' command to show available database drivers.
db_driver = SQLite

# Host
db_host = 127.0.0.1

# Database name (or filename for SQLite driver)
db_name = /etc/sc/sc.db

# Username
db_user = username

# Password
db_pass = password

# Database queries
query_create = "CREATE TABLE rates (ip UNSIGNED INTEGER PRIMARY KEY, rate UNSIGNED INTEGER NOT NULL)"
query_load = "SELECT ip,rate FROM rates"
query_list = "SELECT ip,rate FROM rates WHERE ip=?"
query_add = "INSERT OR REPLACE INTO rates VALUES (?, ?)"
query_del = "DELETE FROM rates WHERE ip=?"
query_change = "REPLACE INTO rates VALUES (?, ?)"

#
# Logging
#

# Output errors and warnings to syslog
syslog = 0

# syslog options (comma-separated)
#
# ndelay - open the connection immediately
# nofatal - just emit warnings instead of dying if the connection to syslog
# can't be established
# perror - write the message to standard error output as well to the syslog
# pid - include PID with each message
#syslog_options = ''

# facility
#syslog_facility = user

shapercontrol-1.3.4/sc.conf.pod000064400000000000000000000166021165425052100164430ustar00rootroot00000000000000#=============================================================================
# FILE: sc.conf.pod
# DESCRIPTION: Source for sc.conf(5) manpage
# AUTHOR: Stanislav Kruchinin, <stanislav.krucinin@gmail.com>
#=============================================================================


=head1 NAME

B<sc.conf> - configuration file for sc(8).

=head1 DESCRIPTION

The F<sc.conf> is parsed using C<AppConfig> module and has a simple C<variable =
value> form.
Expansion for internal and environment variables is enabled (see AppConfig(3)
for details).
The file may contain extra tabs and newlines for formatting.
Comments begin with the B<#> character and end at the end of line, like
in shell or Perl scripts.

=head1 OPTIONS

=over

=item B<tc>, B<iptables> and B<ipset>

Location of tc(8), iptables(8) and ipset(8) executables, respectively.

=item B<out_if>, B<in_if>

Names of interfaces that will be used for shaping of output and input traffic,
respectively.

=item B<filter_method>

Traffic classification (filtering) method.
Default value: u32.

Possible values:

=over 7

=item B<flow>

Use B<flow> classifier and ipset(8) for access control.
This method does not allow to use IPs with the same last two octets.

=item B<u32>

Use B<u32> hashing filters.
This method allows IPs with the same last two octets, but prohibits the
addresses with zero last octet due to limitations of tc(8) hashing filters
syntax.

=back

=item B<limit_method>

Rate limiting method.
Default value: shaping.
Possible values: B<shaping>, B<policing>, B<hybrid>.
Note, that B<policing> only works with B<u32> filtering method.
B<Hybrid> method uses shaping for download and policing for upload, and all
the rules are created on the B<in_if> interface.

=item B<debug>

Debug modes.
Default value: 0.

Possible values:

=over

=item B<0>

no debug (default value),

=item B<1>

print command lines with nonzero return values,

=item B<2>

print all command lines without execution.

=back

=item B<verbose>

When enabled, turns on verbose messages and disables piping of tc(8) and
ipset(8) rules.
Default value: 0.

Possible values:

=over

=item B<0>

no verbose messages (default)

=item B<1>

enable verbose messages (i.e. for results of `sync' command)

=item B<2>

disable batch loading of rules for tc(8) and ipset(8)

=item B<3>

do B<1> + B<2>

=back

=item B<quiet>

Suppress output. Does not affect messages caused by C<verbose> flag.
Default value: 0.
Possible values: boolean.

=item B<colored>

Colorize output using ANSI escape sequences.
Autodetection of non-tty handles is supported.
Default value: 1.
Possible values: boolean.

=item B<joint>

Perform add, change and delete operation on rules and database by a single
command.

=item B<network>

If you use filter_method = flow, this variable defines the network for ipmap
set.
When filter_method = u32, it should contain the list of networks for classid
calculation.
This networks must cover all IPs which you are going to use in shaping rules.
Default value: 172.16.0.0/16.
Possible values:
A single network with mask from 16 to 31 for B<flow> method.
A list of networks with mask from 16 to 31 for B<u32> method.
Total number of hosts in specified networks should not exceed the
maximum number of child classes, e.g. 65534 (from 2 to ffff).

=item B<filter_network>

Network list for hashing filters generation. Makes sence only for B<u32>
method.
To improve the classification performance you may specify here a summarized
network just like in case of supernetting (route aggregation).
For example, if you have the following network configuration

network = 10.0.0.0/20 10.0.253.0/24 10.0.254.0/24

you should specify a single 10.0.0.0/16 network to classify traffic
by a single hashing filer

filter_network = 10.0.0.0/16

Default value: same as B<network> parameter.
Possible values: a list of network with mask from 16 to 31 that is equivalent
or includes the networks specified in B<network> parameter.

=item B<policer_burst_ratio>

Ratio between the size of policer buffer size and bandwidth rate.
Default value: 0.1

=item B<quantum>

Amount of bytes a stream is allowed to dequeue before the next queue gets a
turn.
Default value: 1500.
Possible values: integer numbers >= MTU of the interface.

=item B<rate_unit>

Default rate unit.
Default value: kibit.
Possible values: see sc(8).

=item B<rate_ratio>

Ratio between bandwidth rates in rules and in the database.
rule_rate = db_rate * rate_ratio

This coefficient is used only for B<load> and B<sync> commands.

Default value: 1.0.
Possible values: any rational number.

=item B<leaf_qdisc>

Leaf queueing discipline with parameters. This string will be used as a tail
of corresponding C<tc qdisc ...> command line.
Default value: C<pfifo limit 50>.
Possible values: all classless qdiscs supported by tc(8).

=item B<set_name>

Name of set with allowed IPs.
Default value: pass.
Possible values: ipset-accepted string.

=item B<set_type>

Type of set.
Default value: ipmap.

Possible values:

=over 8

=item B<ipmap>

for IPs from one /16 network defined by C<network> parameter (very fast and
memory cheap)

=item B<iphash>

for IPs from arbitrary /16 networks

=back

=item B<set_size>

Size of IP hash for ipset(8).
Default value: 65536.
Possible values: from 1024 to 65536.

=item B<chain>

Name of iptables(8) chain that will contain rules for shaped IPs.
Default value: FORWARD.
For names other than FORWARD the new chain will be created and attached to
FORWARD chain.

=item B<db_host>

Database host.
Default value: 127.0.0.1.
Possible values: IP-address or domain name.

=item B<db_driver>

Database driver.
Default value: SQLite.
Possible values: all database drivers supported by Perl DBI module.
See output of C<sc help> command for the list of available drivers.

=item B<db_user>

Username to use when connecting to database.
Default value: user.
Possible values: depends on database server.

=item B<db_pass>

The password to use when connecting to database. Remember that specifying a
password on the command line is insecure.
Default value: password.
Possible values: arbitrary string.

=item B<db_name>

Database name to use.
Default value: sc.db.
Possible values: arbibrary string (should be a valid filename in case of
SQLite driver).

=item B<Database queries>

Default values of queries are used for handling SQLite database
F</etc/sc/sc.db>.

List of queries:

=over 16

=item B<query_create>

Create table with C<ip> and C<rate> columns.

=item B<query_load>

Select all data from table.

=item B<query_list>

Select data for one IP.

=item B<query_add>

add new entry.

=item B<query_del>

delete existing entry.

=item B<query_change>

modify existing entry.

=back

=item B<syslog>

Output errors and warnings to syslog.
Default value: 1.
Possible values: boolean.

=item B<syslog_options>

Syslog options.
Default value: <empty string>.

Possible values (comma-separated):

=over 12

=item B<ndelay>

open the connection immediately

=item B<nofatal>

just emit warnings instead of dying if the connection to syslog can't be
established

=item B<perror>

write the message to standard error output as well to the syslog

=item B<pid>

include PID with each message

=back

=item B<syslog_facility>

syslog facility.
Default value: user.
Possible values: see Sys::Syslog(3), section C<Facilities>.

=back

=head1 SEE ALSO

sc(8), tc(8), iptables(8), ipset(8), AppConfig(3), Sys::Syslog(3).

=head1 AUTHOR

Stanislav Kruchinin <stanislav.kruchinin@gmail.com>

=cut

# vim:set syntax=pod:

shapercontrol-1.3.4/sc.init000075500000000000000000000020201165425052100156700ustar00rootroot00000000000000#!/bin/sh

### BEGIN INIT INFO
# Provides: sc
# Required-Start: $remote_fs $syslog
# Required-Stop: $remote_fs $syslog
# Default-Start: 2 3 4 5
# Default-Stop: 1
# Short-Description: Shaper Control Tool
### END INIT INFO

set -e

# /etc/init.d/sc: init script for Shaper Control Tool

SC=/usr/local/sbin/sc
test -x $SC || exit 0

if test -f /etc/default/sc; then
. /etc/default/sc
fi

. /lib/lsb/init-functions

if [ -n "$2" ]; then
SC_OPTS="$SC_OPTS $2"
fi

case "$1" in
start)
log_daemon_msg "Starting shaper" "sc"
if $SC $SC_OPTS load ; then
log_end_msg 0
else
log_end_msg 1
fi
;;

stop)
log_daemon_msg "Stopping shaper" "sc"
if $SC $SC_OPTS reset ; then
log_end_msg 0
else
log_end_msg 1
fi
;;

restart|reload|force-reload)
log_daemon_msg "Restarting shaper" "sc"
if $SC $SC_OPTS reload ; then
log_end_msg 0
else
log_end_msg 1
fi
;;

status)
$SC $SC_OPTS status
;;

*)
log_action_msg "Usage: /etc/init.d/sc {start|stop|reload|force-reload|restart|status}"
exit 1
esac
 
дизайн и разработка: Vladimir Lettiev aka crux © 2004-2005, Andrew Avramenko aka liks © 2007-2008
текущий майнтейнер: Michael Shigorin