tc.pm 62.6 KB
Newer Older
Nigel Kukard's avatar
Nigel Kukard committed
1
# OpenTrafficShaper Linux tc traffic shaping
2
# Copyright (C) 2007-2015, AllWorldIT
3
#
Nigel Kukard's avatar
Nigel Kukard committed
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.



package opentrafficshaper::plugins::tc;

use strict;
use warnings;

Nigel Kukard's avatar
Nigel Kukard committed
24
25
26
use POE qw(
	Wheel::Run Filter::Line
);
Nigel Kukard's avatar
Nigel Kukard committed
27

Nigel Kukard's avatar
Nigel Kukard committed
28
29
30
use awitpt::util qw(
	toHex
);
Nigel Kukard's avatar
Nigel Kukard committed
31
32
use opentrafficshaper::constants;
use opentrafficshaper::logger;
33
use opentrafficshaper::plugins::configmanager qw(
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
	getPool
	getPoolAttribute
	setPoolAttribute
	removePoolAttribute
	getPoolTxInterface
	getPoolRxInterface
	setPoolShaperState
	unsetPoolShaperState
	getPoolShaperState

	getEffectivePool

	getPoolMember
	setPoolMemberAttribute
	getPoolMemberAttribute
	removePoolMemberAttribute
	getPoolMemberMatchPriority
	setPoolMemberShaperState
	unsetPoolMemberShaperState
	getPoolMemberShaperState

	getTrafficClassPriority

	getAllTrafficClasses

	getInterface
	getInterfaces
	getInterfaceDefaultPool
62
63
64
65
	getEffectiveInterfaceTrafficClass2
	isInterfaceTrafficClassValid
	setInterfaceTrafficClassShaperState
	unsetInterfaceTrafficClassShaperState
66
);
Nigel Kukard's avatar
Nigel Kukard committed
67
68
69
70
71
72
73
74
75
76
77
78


# Exporter stuff
require Exporter;
our (@ISA,@EXPORT,@EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT = qw(
);
@EXPORT_OK = qw(
);

use constant {
79
	VERSION => '0.1.2',
80
81
82

	# 5% of a link can be used for very high priority traffic
	PROTO_RATE_LIMIT => 5,
83
84
	PROTO_RATE_BURST_MIN => 16, # With a minimum burst of 8KiB
	PROTO_RATE_BURST_MAXM => 1.5, # Multiplier for burst min to get to burst max
85
86
87

	# High priority traffic gets the first 20% of the bandidth to itself
	PRIO_RATE_LIMIT => 20,
88
89
	PRIO_RATE_BURST_MIN => 32, # With a minimum burst of 40KiB
	PRIO_RATE_BURST_MAXM => 1.5, # Multiplier for burst min to get to burst max
Nigel Kukard's avatar
Nigel Kukard committed
90
91

	TC_ROOT_CLASS => 1,
Nigel Kukard's avatar
Nigel Kukard committed
92
93
94
95
96
97
98
};


# Plugin info
our $pluginInfo = {
	Name => "Linux tc Interface",
	Version => VERSION,
99

Nigel Kukard's avatar
Nigel Kukard committed
100
101
	Init => \&plugin_init,
	Start => \&plugin_start,
Nigel Kukard's avatar
Nigel Kukard committed
102
103
104
};


105
# Our globals
Nigel Kukard's avatar
Nigel Kukard committed
106
my $globals;
107
# Copy of system logger
Nigel Kukard's avatar
Nigel Kukard committed
108
109
my $logger;

110
111
112
113
114
# Our configuration
my $config = {
	'ip_protocol' => "ip",
	'iphdr_offset' => 0,
};
115

116
117
118
119
#
# TASK QUEUE
#
# $globals->{'TaskQueue'}
Nigel Kukard's avatar
Nigel Kukard committed
120

121
122
123
124
125
126
#
# TC CLASSES & FILTERS
#
# $globals->{'TcClasses'}
# $globals->{'TcFilterMappings'}
# $globals->{'TcFilters'}
Nigel Kukard's avatar
Nigel Kukard committed
127

Nigel Kukard's avatar
Nigel Kukard committed
128
129

# Initialize plugin
Nigel Kukard's avatar
Nigel Kukard committed
130
sub plugin_init
Nigel Kukard's avatar
Nigel Kukard committed
131
{
132
	my $system = shift;
Nigel Kukard's avatar
Nigel Kukard committed
133
134
135


	# Setup our environment
136
	$logger = $system->{'logger'};
Nigel Kukard's avatar
Nigel Kukard committed
137

138
	$logger->log(LOG_NOTICE,"[TC] OpenTrafficShaper tc Integration v%s - Copyright (c) 2007-2014, AllWorldIT",VERSION);
139

140
141
142
143
144
	# Initialize
	$globals->{'TaskQueue'} = [ ];
	$globals->{'TcClasses'} = { };
	$globals->{'TcFilterMappings'} = { };
	$globals->{'TcFilters'} = { };
145

Nigel Kukard's avatar
Nigel Kukard committed
146
	# Grab some of our config we need
147
	if (defined(my $proto = $system->{'file.config'}->{'plugin.tc'}->{'protocol'})) {
148
		$logger->log(LOG_INFO,"[TC] Set protocol to '%s'",$proto);
149
		$config->{'ip_protocol'} = $proto;
150
	}
151
	if (defined(my $offset = $system->{'file.config'}->{'plugin.tc'}->{'iphdr_offset'})) {
152
		$logger->log(LOG_INFO,"[TC] Set IP header offset to '%s'",$offset);
153
		$config->{'iphdr_offset'} = $offset;
154
	}
155
156


157
158
	# We going to queue the initialization in plugin initialization so nothing at all can come before us
	my $changeSet = TC::ChangeSet->new();
Nigel Kukard's avatar
Nigel Kukard committed
159
	# Loop with the configured interfaces and initialize them
160
161
	foreach my $interfaceID (getInterfaces()) {
		my $interface = getInterface($interfaceID);
Nigel Kukard's avatar
Nigel Kukard committed
162
		# Initialize interface
163
164
		$logger->log(LOG_INFO,"[TC] Queuing tasks to initialize '%s'",$interface->{'Device'});
		_tc_iface_init($changeSet,$interfaceID);
Nigel Kukard's avatar
Nigel Kukard committed
165
	}
166
167
168
	_task_add_to_queue($changeSet);


Nigel Kukard's avatar
Nigel Kukard committed
169
170
171
	# This session is our main session, its alias is "shaper"
	POE::Session->create(
		inline_states => {
172
173
174
			_start => \&_session_start,
			_stop => \&_session_stop,

175
176
			class_change => \&_session_class_change,

177
178
179
			pool_add => \&_session_pool_add,
			pool_remove => \&_session_pool_remove,
			pool_change => \&_session_pool_change,
180

181
182
			poolmember_add => \&_session_poolmember_add,
			poolmember_remove => \&_session_poolmember_remove,
Nigel Kukard's avatar
Nigel Kukard committed
183
184
185
186
187
188
		}
	);

	# This is our session for communicating directly with tc, its alias is _tc
	POE::Session->create(
		inline_states => {
189
			_start => \&_task_session_start,
190
			_stop => sub { },
191
192
193
			# Signals
			_SIGCHLD => \&_task_SIGCHLD,
			_SIGINT => \&_task_SIGINT,
194

Nigel Kukard's avatar
Nigel Kukard committed
195
			# Public'ish
196
197
			queue => \&_task_queue,

Nigel Kukard's avatar
Nigel Kukard committed
198
			# Internal
199
200
201
202
203
204
			_task_child_stdout => \&_task_child_stdout,
			_task_child_stderr => \&_task_child_stderr,
			_task_child_stdin => \&_task_child_stdin,
			_task_child_close => \&_task_child_close,
			_task_child_error => \&_task_child_error,
			_task_run_next => \&_task_run_next,
Nigel Kukard's avatar
Nigel Kukard committed
205
206
		}
	);
207
208

	return 1;
Nigel Kukard's avatar
Nigel Kukard committed
209
210
211
}


Nigel Kukard's avatar
Nigel Kukard committed
212

Nigel Kukard's avatar
Nigel Kukard committed
213
214
215
216
# Start the plugin
sub plugin_start
{
	$logger->log(LOG_INFO,"[TC] Started");
Nigel Kukard's avatar
Nigel Kukard committed
217
218
219
}


Nigel Kukard's avatar
Nigel Kukard committed
220

Nigel Kukard's avatar
Nigel Kukard committed
221
# Initialize this plugins main POE session
222
sub _session_start
223
224
{
	my ($kernel,$heap) = @_[KERNEL,HEAP];
Nigel Kukard's avatar
Nigel Kukard committed
225
226
227
228


	# Set our alias
	$kernel->alias_set("shaper");
229

Nigel Kukard's avatar
Nigel Kukard committed
230
	$logger->log(LOG_DEBUG,"[TC] Initialized");
Nigel Kukard's avatar
Nigel Kukard committed
231
232
233
}


Nigel Kukard's avatar
Nigel Kukard committed
234

235
# Initialize this plugins main POE session
236
sub _session_stop
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
{
	my ($kernel,$heap) = @_[KERNEL,HEAP];


	# Remove our alias
	$kernel->alias_remove("shaper");

	# Blow away data
	$globals = undef;

	$logger->log(LOG_DEBUG,"[TC] Shutdown");

	$logger = undef;
}


253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308

# Event handler for changing a class
sub _session_class_change
{
	my ($kernel, $interfaceTrafficClassID) = @_[KERNEL, ARG0, ARG1];


	# Grab our effective class
	my $effectiveInterfaceTrafficClass = getEffectiveInterfaceTrafficClass2($interfaceTrafficClassID);

	# Grab interface ID
	my $interfaceID = $effectiveInterfaceTrafficClass->{'InterfaceID'};
	# Grab interface from config manager
	my $interface = getInterface($interfaceID);

	# Grab traffic class ID
	my $trafficClassID = $effectiveInterfaceTrafficClass->{'TrafficClassID'};

	$logger->log(LOG_INFO,"[TC] Processing interface class changes for '%s' traffic class ID '%s'",
			$interface->{'Device'},
			$trafficClassID
	);

	# Grab tc interface
	my $tcInterface = $globals->{'Interfaces'}->{$interfaceID};
	# Grab interface traffic class
	my $interfaceTrafficClass = $tcInterface->{'TrafficClasses'}->{$trafficClassID};

	# Grab the traffic class
	my $majorTcClass = $tcInterface->{'TcClass'};
	my $minorTcClass = $interfaceTrafficClass->{"TcClass"};

	# Generate changeset
	my $changeSet = TC::ChangeSet->new();

	# If we're a normal class we are treated differently than if we're a main/root class below (interface main speed)
	if ($minorTcClass > 1) {
		_tc_class_change($changeSet,$interfaceID,$majorTcClass,"",$minorTcClass,
				$effectiveInterfaceTrafficClass->{'CIR'},
				$effectiveInterfaceTrafficClass->{'Limit'}
		);
	# XXX: This will be the actual interface, we set limit and burst to the same
	} else {
		_tc_class_change($changeSet,$interfaceID,TC_ROOT_CLASS,"",$minorTcClass,$effectiveInterfaceTrafficClass->{'Limit'});
	}

	# Post changeset
	$kernel->post("_tc" => "queue" => $changeSet);

	# Mark as live
	unsetInterfaceTrafficClassShaperState($interfaceTrafficClassID,SHAPER_NOTLIVE|SHAPER_PENDING);
	setInterfaceTrafficClassShaperState($interfaceTrafficClassID,SHAPER_LIVE);
}



309
310
311
312
313
314
315
316
317
# Event handler for adding a pool
sub _session_pool_add
{
	my ($kernel,$heap,$pid) = @_[KERNEL, HEAP, ARG0];


	# Grab pool
	my $pool;
	if (!defined($pool = getPool($pid))) {
Nigel Kukard's avatar
Nigel Kukard committed
318
		$logger->log(LOG_ERR,"[TC] Shaper 'add' event with non existing pool '%s'",$pid);
319
320
321
		return;
	}

Nigel Kukard's avatar
Nigel Kukard committed
322
	$logger->log(LOG_INFO,"[TC] Add pool '%s' [%s] to interface group '%s'",
323
			$pool->{'Name'},
Nigel Kukard's avatar
Nigel Kukard committed
324
			$pool->{'ID'},
325
326
327
328
329
330
331
332
333
			$pool->{'InterfaceGroupID'},
	);

	# Grab our effective pool
	my $effectivePool = getEffectivePool($pool->{'ID'});

	my $changeSet = TC::ChangeSet->new();

	# Grab some things we need from the main pool
334
335
	my $txInterfaceID = getPoolTxInterface($pool->{'ID'});
	my $rxInterfaceID = getPoolRxInterface($pool->{'ID'});
336

337
	# Grab effective config
338
339
340
341
342
343
	my $trafficClassID = $effectivePool->{'TrafficClassID'};
	my $txCIR = $effectivePool->{'TxCIR'};
	my $txLimit = $effectivePool->{'TxLimit'};
	my $rxCIR = $effectivePool->{'RxCIR'};
	my $rxLimit = $effectivePool->{'RxLimit'};
	my $trafficPriority = getTrafficClassPriority($effectivePool->{'TrafficClassID'});
344
345

	# Get the Tx traffic classes TC class
346
	my $tcClass_TxTrafficClass = _getTcClassFromTrafficClassID($txInterfaceID,$trafficClassID);
347
	# Generate our pools Tx TC class
348
	my $tcClass_TxPool = _reserveMinorTcClassByPoolID($txInterfaceID,$pool->{'ID'});
349
	# Add the main Tx TC class for this pool
350
	_tc_class_add($changeSet,$txInterfaceID,TC_ROOT_CLASS,$tcClass_TxTrafficClass,$tcClass_TxPool,$txCIR,
351
			$txLimit,$trafficPriority
352
353
	);
	# Add Tx TC optimizations
354
	_tc_class_optimize($changeSet,$txInterfaceID,$tcClass_TxPool,$txCIR);
355
356
357
358
	# Set Tx TC class
	setPoolAttribute($pool->{'ID'},'tc.txclass',$tcClass_TxPool);

	# Get the Rx traffic classes TC class
359
	my $tcClass_RxTrafficClass = _getTcClassFromTrafficClassID($rxInterfaceID,$trafficClassID);
360
	# Generate our pools Rx TC class
361
	my $tcClass_RxPool = _reserveMinorTcClassByPoolID($rxInterfaceID,$pool->{'ID'});
362
	# Add the main Rx TC class for this pool
363
	_tc_class_add($changeSet,$rxInterfaceID,TC_ROOT_CLASS,$tcClass_RxTrafficClass,$tcClass_RxPool,$rxCIR,
364
			$rxLimit,$trafficPriority
365
366
	);
	# Add Rx TC optimizations
367
	_tc_class_optimize($changeSet,$rxInterfaceID,$tcClass_RxPool,$rxCIR);
368
369
370
371
372
373
374
	# Set Rx TC
	setPoolAttribute($pool->{'ID'},'tc.rxclass',$tcClass_RxPool);

	# Post changeset
	$kernel->post("_tc" => "queue" => $changeSet);

	# Set current live values
375
376
377
378
379
	setPoolAttribute($pool->{'ID'},'shaper.live.ClassID',$trafficClassID);
	setPoolAttribute($pool->{'ID'},'shaper.live.TxCIR',$txCIR);
	setPoolAttribute($pool->{'ID'},'shaper.live.TxLimit',$txLimit);
	setPoolAttribute($pool->{'ID'},'shaper.live.RxCIR',$rxCIR);
	setPoolAttribute($pool->{'ID'},'shaper.live.RxLimit',$rxLimit);
380
381

	# Mark as live
382
	unsetPoolShaperState($pool->{'ID'},SHAPER_NOTLIVE|SHAPER_PENDING);
383
384
385
386
	setPoolShaperState($pool->{'ID'},SHAPER_LIVE);
}


Nigel Kukard's avatar
Nigel Kukard committed
387

388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
# Event handler for removing a pool
sub _session_pool_remove
{
	my ($kernel, $pid) = @_[KERNEL, ARG0];


	my $changeSet = TC::ChangeSet->new();

	# Pull in pool
	my $pool;
	if (!defined($pool = getPool($pid))) {
		$logger->log(LOG_ERR,"[TC] Shaper 'remove' event with non existing pool '%s'",$pid);
		return;
	}

	# Make sure its not NOTLIVE
404
	if (getPoolShaperState($pid) & SHAPER_NOTLIVE) {
405
		$logger->log(LOG_WARN,"[TC] Ignoring remove for pool '%s' [%s]",
406
				$pool->{'Name'},
407
408
409
410
411
412
				$pool->{'ID'}
		);
		return;
	}

	$logger->log(LOG_INFO,"[TC] Removing pool '%s' [%s]",
413
			$pool->{'Name'},
414
415
416
417
			$pool->{'ID'}
	);

	# Grab our interfaces
418
419
	my $txInterfaceID = getPoolTxInterface($pool->{'ID'});
	my $rxInterfaceID = getPoolRxInterface($pool->{'ID'});
420
421
422
423
424
	# Grab the traffic class from the pool
	my $txPoolTcClass = getPoolAttribute($pool->{'ID'},'tc.txclass');
	my $rxPoolTcClass = getPoolAttribute($pool->{'ID'},'tc.rxclass');

	# Grab current class ID
425
	my $trafficClassID = getPoolAttribute($pool->{'ID'},'shaper.live.ClassID');
426
	# Grab our minor classes
427
428
429
430
431
	my $txTrafficClassTcClass = _getTcClassFromTrafficClassID($txInterfaceID,$trafficClassID);
	my $rxTrafficClassTcClass = _getTcClassFromTrafficClassID($rxInterfaceID,$trafficClassID);

	my $txInterface = getInterface($txInterfaceID);
	my $rxInterface = getInterface($rxInterfaceID);
432
433
434
435

	# Clear up the class
	$changeSet->add([
			'/sbin/tc','class','del',
436
				'dev',$txInterface->{'Device'},
437
438
439
440
441
				'parent',"1:$txTrafficClassTcClass",
				'classid',"1:$txPoolTcClass",
	]);
	$changeSet->add([
			'/sbin/tc','class','del',
442
				'dev',$rxInterface->{'Device'},
443
444
445
446
447
				'parent',"1:$rxTrafficClassTcClass",
				'classid',"1:$rxPoolTcClass",
	]);

	# And recycle the classs
Nigel Kukard's avatar
Nigel Kukard committed
448
449
	_disposePoolTcClass($txInterface->{'Device'},$txPoolTcClass);
	_disposePoolTcClass($rxInterface->{'Device'},$rxPoolTcClass);
450

Nigel Kukard's avatar
Nigel Kukard committed
451
452
	_disposePrioTcClass($txInterface->{'Device'},$txPoolTcClass);
	_disposePrioTcClass($rxInterface->{'Device'},$rxPoolTcClass);
453
454
455
456
457
458
459
460
461

	# Post changeset
	$kernel->post("_tc" => "queue" => $changeSet);

	# Cleanup attributes
	removePoolAttribute($pool->{'ID'},'tc.txclass');
	removePoolAttribute($pool->{'ID'},'tc.rxclass');

	removePoolAttribute($pool->{'ID'},'shaper.live.ClassID');
462
463
464
465
	removePoolAttribute($pool->{'ID'},'shaper.live.TxCIR');
	removePoolAttribute($pool->{'ID'},'shaper.live.TxLimit');
	removePoolAttribute($pool->{'ID'},'shaper.live.RxCIR');
	removePoolAttribute($pool->{'ID'},'shaper.live.RxLimit');
466
467
468
469

	# Mark as not live
	unsetPoolShaperState($pool->{'ID'},SHAPER_LIVE|SHAPER_PENDING);
	setPoolShaperState($pool->{'ID'},SHAPER_NOTLIVE);
470
471
472
}


Nigel Kukard's avatar
Nigel Kukard committed
473

474
475
## Event handler for changing a pool
sub _session_pool_change
476
{
477
	my ($kernel, $pid) = @_[KERNEL, ARG0];
478

Nigel Kukard's avatar
Nigel Kukard committed
479

480
481
482
	# Grab pool
	my $pool = getPool($pid);

483
	$logger->log(LOG_INFO,"[TC] Processing changes for '%s' [%s]",$pool->{'Name'},$pool->{'ID'});
484
485
486
487
488

	# Grab our effective pool
	my $effectivePool = getEffectivePool($pool->{'ID'});

	# Grab our interfaces
489
490
	my $txInterfaceID = getPoolTxInterface($pool->{'ID'});
	my $rxInterfaceID = getPoolRxInterface($pool->{'ID'});
491
492
493
494
495
	# Grab the traffic class from the pool
	my $txPoolTcClass = getPoolAttribute($pool->{'ID'},'tc.txclass');
	my $rxPoolTcClass = getPoolAttribute($pool->{'ID'},'tc.rxclass');

	# Grab effective config
496
497
498
499
500
501
	my $trafficClassID = $effectivePool->{'TrafficClassID'};
	my $txCIR = $effectivePool->{'TxCIR'};
	my $txLimit = $effectivePool->{'TxLimit'};
	my $rxCIR = $effectivePool->{'RxCIR'};
	my $rxLimit = $effectivePool->{'RxLimit'};
	my $trafficPriority = getTrafficClassPriority($trafficClassID);
502
503

	# Grab our minor classes
504
505
	my $txTrafficClassTcClass = _getTcClassFromTrafficClassID($txInterfaceID,$trafficClassID);
	my $rxTrafficClassTcClass = _getTcClassFromTrafficClassID($rxInterfaceID,$trafficClassID);
506
507

	# Generate changeset
508
509
	my $changeSet = TC::ChangeSet->new();

510
	_tc_class_change($changeSet,$txInterfaceID,TC_ROOT_CLASS,$txTrafficClassTcClass,$txPoolTcClass,$txCIR,
511
			$txLimit,$trafficPriority);
512
	_tc_class_change($changeSet,$rxInterfaceID,TC_ROOT_CLASS,$rxTrafficClassTcClass,$rxPoolTcClass,$rxCIR,
513
			$rxLimit,$trafficPriority);
514
515
516

	# Post changeset
	$kernel->post("_tc" => "queue" => $changeSet);
Nigel Kukard's avatar
Nigel Kukard committed
517

518
519
520
521
522
	setPoolAttribute($pool->{'ID'},'shaper.live.ClassID',$trafficClassID);
	setPoolAttribute($pool->{'ID'},'shaper.live.TxCIR',$txCIR);
	setPoolAttribute($pool->{'ID'},'shaper.live.TxLimit',$txLimit);
	setPoolAttribute($pool->{'ID'},'shaper.live.RxCIR',$rxCIR);
	setPoolAttribute($pool->{'ID'},'shaper.live.RxLimit',$rxLimit);
523

524
	# Mark as live
525
	unsetPoolShaperState($pool->{'ID'},SHAPER_NOTLIVE|SHAPER_PENDING);
526
527
528
529
	setPoolShaperState($pool->{'ID'},SHAPER_LIVE);
}


Nigel Kukard's avatar
Nigel Kukard committed
530

531
532
533
534
535
536
537
538
539
540
# Event handler for adding a pool member
sub _session_poolmember_add
{
	my ($kernel,$heap,$pmid) = @_[KERNEL, HEAP, ARG0];


	# Grab pool
	my $poolMember;
	if (!defined($poolMember = getPoolMember($pmid))) {
		$logger->log(LOG_ERR,"[TC] Shaper 'add' event with non existing pool member '%s'",$pmid);
541
542
		return;
	}
543

Nigel Kukard's avatar
Nigel Kukard committed
544
545
546
547
548
549
550
551
552
553
	# Grab the pool members associated pool
	my $pool;
	if (!defined($pool = getPool($poolMember->{'PoolID'}))) {
		$logger->log(LOG_ERR,"[TC] Shaper 'poolmember_add' event with invalid PoolID");
		return;
	}

	$logger->log(LOG_INFO,"[TC] Add pool member '%s' [%s] with IP '%s' to pool '%s' [%s]",
			$poolMember->{'Username'},
			$poolMember->{'ID'},
554
			$poolMember->{'IPAddress'},
Nigel Kukard's avatar
Nigel Kukard committed
555
556
			$pool->{'Name'},
			$pool->{'ID'}
557
558
559
	);

	my $changeSet = TC::ChangeSet->new();
Nigel Kukard's avatar
Nigel Kukard committed
560

Nigel Kukard's avatar
Nigel Kukard committed
561
	# Filter levels for the IP components
562
	my @components = split(/\./,$poolMember->{'IPAddress'});
563
564
565
566
	my $ip1 = $components[0];
	my $ip2 = $components[1];
	my $ip3 = $components[2];
	my $ip4 = $components[3];
Nigel Kukard's avatar
Nigel Kukard committed
567
568
569
570
571
	# Hex IP components
	my $ip1Hex = sprintf('%02s',toHex($ip1));
	my $ip2Hex = sprintf('%02s',toHex($ip2));
	my $ip3Hex = sprintf('%02s',toHex($ip3));
	my $ip4Hex = sprintf('%02s',toHex($ip4));
572

Nigel Kukard's avatar
Nigel Kukard committed
573
	# Grab some variables we going to need below
574
575
	my $txInterfaceID = getPoolTxInterface($pool->{'ID'});
	my $rxInterfaceID = getPoolRxInterface($pool->{'ID'});
576
	my $trafficPriority = getTrafficClassPriority($pool->{'TrafficClassID'});
577
	my $matchPriority = getPoolMemberMatchPriority($poolMember->{'ID'});
578
579

	# Check if we have a entry for the /8, if not we must create our 2nd level hash table and link it
580
	if (!defined($globals->{'TcFilterMappings'}->{$txInterfaceID}->{'dst'}->{$matchPriority}->{$ip1})) {
Nigel Kukard's avatar
Nigel Kukard committed
581
		# Grab filter ID's for 2nd level
582
		my $filterID = _reserveTcFilter($txInterfaceID,$matchPriority,$pool->{'ID'});
Nigel Kukard's avatar
Nigel Kukard committed
583
		# Track our mapping
584
		$globals->{'TcFilterMappings'}->{$txInterfaceID}->{'dst'}->{$matchPriority}->{$ip1}->{'id'} = $filterID;
585
586
587
588
589
		$logger->log(LOG_DEBUG,"[TC] Linking 2nd level TX hash table to '%s' to '%s.0.0.0/8', priority '%s'",
				$filterID,
				$ip1,
				$matchPriority
		);
590
		_tc_filter_add_dstlink($changeSet,$txInterfaceID,TC_ROOT_CLASS,$matchPriority,$filterID,$config->{'ip_protocol'},800,"",
591
				"$ip1.0.0.0/8","00ff0000");
Nigel Kukard's avatar
Nigel Kukard committed
592
	}
593
	if (!defined($globals->{'TcFilterMappings'}->{$rxInterfaceID}->{'src'}->{$matchPriority}->{$ip1})) {
Nigel Kukard's avatar
Nigel Kukard committed
594
		# Grab filter ID's for 2nd level
595
		my $filterID = _reserveTcFilter($rxInterfaceID,$matchPriority,$pool->{'ID'});
Nigel Kukard's avatar
Nigel Kukard committed
596
		# Track our mapping
597
		$globals->{'TcFilterMappings'}->{$rxInterfaceID}->{'src'}->{$matchPriority}->{$ip1}->{'id'} = $filterID;
598
599
600
601
602
		$logger->log(LOG_DEBUG,"[TC] Linking 2nd level RX hash table to '%s' to '%s.0.0.0/8', priority '%s'",
				$filterID,
				$ip1,
				$matchPriority
		);
603
		_tc_filter_add_srclink($changeSet,$rxInterfaceID,TC_ROOT_CLASS,$matchPriority,$filterID,$config->{'ip_protocol'},800,"",
604
				"$ip1.0.0.0/8","00ff0000");
605
	}
Nigel Kukard's avatar
Nigel Kukard committed
606

607
	# Check if we have our /16 hash entry, if not we must create the 3rd level hash table
608
	if (!defined($globals->{'TcFilterMappings'}->{$txInterfaceID}->{'dst'}->{$matchPriority}->{$ip1}->{$ip2})) {
Nigel Kukard's avatar
Nigel Kukard committed
609
		# Grab filter ID's for 3rd level
610
		my $filterID = _reserveTcFilter($txInterfaceID,$matchPriority,$pool->{'ID'});
Nigel Kukard's avatar
Nigel Kukard committed
611
		# Track our mapping
612
		$globals->{'TcFilterMappings'}->{$txInterfaceID}->{'dst'}->{$matchPriority}->{$ip1}->{$ip2}->{'id'} = $filterID;
613
		# Grab some hash table ID's we need
614
		my $ip1HtHex = $globals->{'TcFilterMappings'}->{$txInterfaceID}->{'dst'}->{$matchPriority}->{$ip1}->{'id'};
615
616
617
618
619
620
		$logger->log(LOG_DEBUG,"[TC] Linking 3rd level TX hash table to '%s' to '%s.%s.0.0/16', priority '%s'",
				$filterID,
				$ip1,
				$ip2,
				$matchPriority
		);
621
		_tc_filter_add_dstlink($changeSet,$txInterfaceID,TC_ROOT_CLASS,$matchPriority,$filterID,$config->{'ip_protocol'},$ip1HtHex,
622
				$ip2Hex,"$ip1.$ip2.0.0/16","0000ff00");
Nigel Kukard's avatar
Nigel Kukard committed
623
	}
624
	if (!defined($globals->{'TcFilterMappings'}->{$rxInterfaceID}->{'src'}->{$matchPriority}->{$ip1}->{$ip2})) {
Nigel Kukard's avatar
Nigel Kukard committed
625
		# Grab filter ID's for 3rd level
626
		my $filterID = _reserveTcFilter($rxInterfaceID,$matchPriority,$pool->{'ID'});
Nigel Kukard's avatar
Nigel Kukard committed
627
		# Track our mapping
628
		$globals->{'TcFilterMappings'}->{$rxInterfaceID}->{'src'}->{$matchPriority}->{$ip1}->{$ip2}->{'id'} = $filterID;
Nigel Kukard's avatar
Nigel Kukard committed
629
		# Grab some hash table ID's we need
630
		my $ip1HtHex = $globals->{'TcFilterMappings'}->{$rxInterfaceID}->{'src'}->{$matchPriority}->{$ip1}->{'id'};
631
632
633
634
635
636
		$logger->log(LOG_DEBUG,"[TC] Linking 3rd level RX hash table to '%s' to '%s.%s.0.0/16', priority '%s'",
				$filterID,
				$ip1,
				$ip2,
				$matchPriority
		);
637
		_tc_filter_add_srclink($changeSet,$rxInterfaceID,TC_ROOT_CLASS,$matchPriority,$filterID,$config->{'ip_protocol'},$ip1HtHex,
638
				$ip2Hex,"$ip1.$ip2.0.0/16","0000ff00");
639
640
641
	}

	# Check if we have our /24 hash entry, if not we must create the 4th level hash table
642
	if (!defined($globals->{'TcFilterMappings'}->{$txInterfaceID}->{'dst'}->{$matchPriority}->{$ip1}->{$ip2}->{$ip3})) {
Nigel Kukard's avatar
Nigel Kukard committed
643
		# Grab filter ID's for 4th level
644
		my $filterID = _reserveTcFilter($txInterfaceID,$matchPriority,$pool->{'ID'});
Nigel Kukard's avatar
Nigel Kukard committed
645
		# Track our mapping
646
		$globals->{'TcFilterMappings'}->{$txInterfaceID}->{'dst'}->{$matchPriority}->{$ip1}->{$ip2}->{$ip3}->{'id'} = $filterID;
647
		# Grab some hash table ID's we need
648
		my $ip2HtHex = $globals->{'TcFilterMappings'}->{$txInterfaceID}->{'dst'}->{$matchPriority}->{$ip1}->{$ip2}->{'id'};
649
650
651
652
653
654
655
		$logger->log(LOG_DEBUG,"[TC] Linking 4th level TX hash table to '%s' to '%s.%s.%s.0/24', priority '%s'",
				$filterID,
				$ip1,
				$ip2,
				$ip3,
				$matchPriority
		);
656
		_tc_filter_add_dstlink($changeSet,$txInterfaceID,TC_ROOT_CLASS,$matchPriority,$filterID,$config->{'ip_protocol'},$ip2HtHex,
657
				$ip3Hex,"$ip1.$ip2.$ip3.0/24","000000ff");
Nigel Kukard's avatar
Nigel Kukard committed
658
	}
659
	if (!defined($globals->{'TcFilterMappings'}->{$rxInterfaceID}->{'src'}->{$matchPriority}->{$ip1}->{$ip2}->{$ip3})) {
Nigel Kukard's avatar
Nigel Kukard committed
660
		# Grab filter ID's for 4th level
661
		my $filterID = _reserveTcFilter($rxInterfaceID,$matchPriority,$pool->{'ID'});
Nigel Kukard's avatar
Nigel Kukard committed
662
		# Track our mapping
663
		$globals->{'TcFilterMappings'}->{$rxInterfaceID}->{'src'}->{$matchPriority}->{$ip1}->{$ip2}->{$ip3}->{'id'} = $filterID;
Nigel Kukard's avatar
Nigel Kukard committed
664
		# Grab some hash table ID's we need
665
		my $ip2HtHex = $globals->{'TcFilterMappings'}->{$rxInterfaceID}->{'src'}->{$matchPriority}->{$ip1}->{$ip2}->{'id'};
666
667
668
669
670
671
672
		$logger->log(LOG_DEBUG,"[TC] Linking 4th level RX hash table to '%s' to '%s.%s.%s.0/24', priority '%s'",
				$filterID,
				$ip1,
				$ip2,
				$ip3,
				$matchPriority
		);
673
		_tc_filter_add_srclink($changeSet,$rxInterfaceID,TC_ROOT_CLASS,$matchPriority,$filterID,$config->{'ip_protocol'},$ip2HtHex,
674
				$ip3Hex,"$ip1.$ip2.$ip3.0/24","000000ff");
675
676
	}

677
678
679
680
	#
	# For sake of simplicity and so things loook all nice and similar, we going to do these 2 blocks in { }
	#

Nigel Kukard's avatar
Nigel Kukard committed
681
	# Only if we have TX limits setup process them
682
683
684
	{
		# Get the TX class
		my $tcClass_trafficClass = getPoolAttribute($pool->{'ID'},'tc.txclass');
685
		# Grab some hash table ID's we need
686
		my $ip3HtHex = $globals->{'TcFilterMappings'}->{$txInterfaceID}->{'dst'}->{$matchPriority}->{$ip1}->{$ip2}->{$ip3}->{'id'};
687
688
689
690
691
692
693
		$logger->log(LOG_DEBUG,"[TC] Linking pool member IP '%s' to class '%s' at hash endpoint '%s:%s'",
				$poolMember->{'IPAddress'},
				$tcClass_trafficClass,
				$ip3HtHex,
				$ip4Hex
		);

Nigel Kukard's avatar
Nigel Kukard committed
694
		# Link filter to traffic flow (class)
695
696
		_tc_filter_add_flowlink($changeSet,$txInterfaceID,TC_ROOT_CLASS,$trafficPriority,$config->{'ip_protocol'},$ip3HtHex,
				$ip4Hex,"dst",16,$poolMember->{'IPAddress'},$tcClass_trafficClass);
Nigel Kukard's avatar
Nigel Kukard committed
697

698
699
700
		# Save pool member filter ID
		setPoolMemberAttribute($poolMember->{'ID'},'tc.txfilter',"${ip3HtHex}:${ip4Hex}:1");
	}
Nigel Kukard's avatar
Nigel Kukard committed
701
	# Only if we have RX limits setup process them
702
	{
Nigel Kukard's avatar
Nigel Kukard committed
703
		# Generate our limit TC class
704
		my $tcClass_trafficClass = getPoolAttribute($pool->{'ID'},'tc.rxclass');
Nigel Kukard's avatar
Nigel Kukard committed
705
		# Grab some hash table ID's we need
706
		my $ip3HtHex = $globals->{'TcFilterMappings'}->{$rxInterfaceID}->{'src'}->{$matchPriority}->{$ip1}->{$ip2}->{$ip3}->{'id'};
707
708
709
710
711
712
713
		$logger->log(LOG_DEBUG,"[TC] Linking RX IP '%s' to class '%s' at hash endpoint '%s:%s'",
				$poolMember->{'IPAddress'},
				$tcClass_trafficClass,
				$ip3HtHex,
				$ip4Hex
		);

Nigel Kukard's avatar
Nigel Kukard committed
714
		# Link filter to traffic flow (class)
715
716
		_tc_filter_add_flowlink($changeSet,$rxInterfaceID,TC_ROOT_CLASS,$trafficPriority,$config->{'ip_protocol'},$ip3HtHex,
				$ip4Hex,"src",12,$poolMember->{'IPAddress'},$tcClass_trafficClass);
717

718
719
720
		# Save pool member filter ID
		setPoolMemberAttribute($poolMember->{'ID'},'tc.rxfilter',"${ip3HtHex}:${ip4Hex}:1");
	}
Nigel Kukard's avatar
Nigel Kukard committed
721

722
723
724
	# Post changeset
	$kernel->post("_tc" => "queue" => $changeSet);

725
	# Mark pool member as live
726
	unsetPoolMemberShaperState($poolMember->{'ID'},SHAPER_NOTLIVE|SHAPER_PENDING);
727
	setPoolMemberShaperState($poolMember->{'ID'},SHAPER_LIVE);
Nigel Kukard's avatar
Nigel Kukard committed
728
729
}

730

Nigel Kukard's avatar
Nigel Kukard committed
731

732
733
# Event handler for removing a pool member
sub _session_poolmember_remove
734
{
735
	my ($kernel, $pmid) = @_[KERNEL, ARG0];
736

Nigel Kukard's avatar
Nigel Kukard committed
737

738
739
740
741
	# Pull in pool member
	my $poolMember;
	if (!defined($poolMember = getPoolMember($pmid))) {
		$logger->log(LOG_ERR,"[TC] Shaper 'remove' event with non existing pool member '%s'",$pmid);
742
743
744
		return;
	}

745
746
747
748
	# Grab the pool members associated pool
	my $pool = getPool($poolMember->{'PoolID'});

	# Make sure its not NOTLIVE
749
	if (getPoolMemberShaperState($pmid) & SHAPER_NOTLIVE) {
750
751
752
753
		$logger->log(LOG_WARN,"[TC] Ignoring remove for pool member '%s' with IP '%s' [%s] from pool '%s'",
				$poolMember->{'Username'},
				$poolMember->{'IPAddress'},
				$poolMember->{'ID'},
754
				$pool->{'Name'}
755
		);
756
757
758
		return;
	}

Nigel Kukard's avatar
Nigel Kukard committed
759
	$logger->log(LOG_INFO,"[TC] Remove pool member '%s' [%s] with IP '%s' from pool '%s' [%s]",
760
761
			$poolMember->{'Username'},
			$poolMember->{'ID'},
Nigel Kukard's avatar
Nigel Kukard committed
762
763
764
			$poolMember->{'IPAddress'},
			$pool->{'Name'},
			$pool->{'ID'}
765
	);
766

Nigel Kukard's avatar
Nigel Kukard committed
767
	# Grab our interfaces
768
769
	my $txInterfaceID = getPoolTxInterface($pool->{'ID'});
	my $rxInterfaceID = getPoolRxInterface($pool->{'ID'});
770
771
772
	# Grab the filter ID's from the pool member which is linked to the traffic class
	my $txFilter = getPoolMemberAttribute($poolMember->{'ID'},'tc.txfilter');
	my $rxFilter = getPoolMemberAttribute($poolMember->{'ID'},'tc.rxfilter');
Nigel Kukard's avatar
Nigel Kukard committed
773

774
	# Grab current class ID
775
776
	my $trafficClassID = getPoolAttribute($pool->{'ID'},'shaper.live.ClassID');
	my $trafficPriority = getTrafficClassPriority($trafficClassID);
777

778
779
	my $txInterface = getInterface($txInterfaceID);
	my $rxInterface = getInterface($rxInterfaceID);
780

781
782
	my $changeSet = TC::ChangeSet->new();

783
	# Clear up the filter
784
	$changeSet->add([
785
			'/sbin/tc','filter','del',
786
				'dev',$txInterface->{'Device'},
787
				'parent','1:',
Nigel Kukard's avatar
Nigel Kukard committed
788
789
				'prio',$trafficPriority,
				'handle',$txFilter,
790
				'protocol',$config->{'ip_protocol'},
791
792
				'u32',
	]);
793
	$changeSet->add([
794
			'/sbin/tc','filter','del',
795
				'dev',$rxInterface->{'Device'},
796
				'parent','1:',
Nigel Kukard's avatar
Nigel Kukard committed
797
798
				'prio',$trafficPriority,
				'handle',$rxFilter,
799
				'protocol',$config->{'ip_protocol'},
800
801
				'u32',
	]);
802

803
804
805
	# Post changeset
	$kernel->post("_tc" => "queue" => $changeSet);

806
	# Cleanup attributes
807
808
	removePoolMemberAttribute($poolMember->{'ID'},'tc.txfilter');
	removePoolMemberAttribute($poolMember->{'ID'},'tc.rxfilter');
809
810
811
812

	# Mark as not live
	unsetPoolMemberShaperState($poolMember->{'ID'},SHAPER_LIVE|SHAPER_PENDING);
	setPoolMemberShaperState($poolMember->{'ID'},SHAPER_NOTLIVE);
813
}
814

815

816

817
818
# Grab pool ID from TC class
sub getPIDFromTcClass
819
{
820
	my ($interfaceID,$majorTcClass,$minorTcClass) = @_;
821
822


823
	# Return the pool ID if found
824
	my $ref = __getRefByMinorTcClass($interfaceID,$majorTcClass,$minorTcClass);
825
	if (!defined($ref) || substr($ref,0,13) ne "_pool_class_:") {
826
		return;
827
828
	}

829
	return substr($ref,13);
830
831
832
}


Nigel Kukard's avatar
Nigel Kukard committed
833

834
835
# Function to return if this is linked to a pool's class
sub isPoolTcClass
836
{
837
	my ($interfaceID,$majorTcClass,$minorTcClass) = @_;
838

839

840
	my $pid = getPIDFromTcClass($interfaceID,$majorTcClass,$minorTcClass);
841
	if (!defined($pid)) {
842
		return;
Nigel Kukard's avatar
Nigel Kukard committed
843
	}
844

845
	return $minorTcClass;
846
847
}

848

Nigel Kukard's avatar
Nigel Kukard committed
849

850
# Return the ClassID from a TC class
851
# This is similar to isTcTrafficClassValid() but returns the ref, not the minor class
852
sub getCIDFromTcClass
853
{
854
	my ($interfaceID,$majorTcClass,$minorTcClass) = @_;
855
856
857


	# Grab ref
858
	my $ref = __getRefByMinorTcClass($interfaceID,$majorTcClass,$minorTcClass);
859
860
861
862
863
864

	# If we're undefined return
	if (!defined($ref)) {
		return;
	}

865
866
	# If we're not a traffic class, just return
	if (substr($ref,0,16) ne "_traffic_class_:") {
867
		return;
868
869
	}

870
871
	# Else return the part after the above tag
	return substr($ref,16);
872
873
}

874

Nigel Kukard's avatar
Nigel Kukard committed
875
876
877
#
# Internal functions
#
878

Nigel Kukard's avatar
Nigel Kukard committed
879

880
# Function to initialize an interface
881
sub _tc_iface_init
882
{
883
	my ($changeSet,$interfaceID) = @_;
884
885


Nigel Kukard's avatar
Nigel Kukard committed
886
	# Grab our interface rate
887
	my $interface = getInterface($interfaceID);
888

889
### --- Interface Setup
890

Nigel Kukard's avatar
Nigel Kukard committed
891
	# Clear the qdisc from the interface
892
	$changeSet->add([
893
			'/sbin/tc','qdisc','del',
894
				'dev',$interface->{'Device'},
895
896
				'root',
	]);
897

898
	# Initialize the major TC class
899
900
901
902
903
904
905
906
	my $interfaceTcClass = _reserveMajorTcClass($interfaceID,"root");

	# Set interface RootClass
	$globals->{'Interfaces'}->{$interfaceID} = {
		'TcClass' => $interfaceTcClass
	};

### --- Interface Traffic Class Setup
907

908
	# Reserve our parent TC classes
909
910
	my @trafficClasses = getAllTrafficClasses();
	foreach my $trafficClassID (sort {$a <=> $b} @trafficClasses) {
911
912
		# Record the class we get for this interface traffic class ID
		my $interfaceTrafficClassTcClass = _reserveMinorTcClassByTrafficClassID($interfaceID,$trafficClassID);
Nigel Kukard's avatar
Nigel Kukard committed
913
914
	}

915
	# Do we have a default pool? if so we must direct traffic there
Nigel Kukard's avatar
Nigel Kukard committed
916
	my @qdiscOpts = ( );
917
	my $defaultPool = getInterfaceDefaultPool($interfaceID);
918
	my $defaultPoolTcClass;
Nigel Kukard's avatar
Nigel Kukard committed
919
	if (defined($defaultPool)) {
920
		# Push unclassified traffic to this class
921
		$defaultPoolTcClass = _getTcClassFromTrafficClassID($interfaceID,$defaultPool);
922
		push(@qdiscOpts,'default',$defaultPoolTcClass);
923
924
	}

925
926
927

### --- Interface Setup Part 2

Nigel Kukard's avatar
Nigel Kukard committed
928
	# Add root qdisc
929
	$changeSet->add([
930
			'/sbin/tc','qdisc','add',
931
				'dev',$interface->{'Device'},
932
933
934
				'root',
				'handle','1:',
				'htb',
Nigel Kukard's avatar
Nigel Kukard committed
935
					@qdiscOpts
936
	]);
Nigel Kukard's avatar
Nigel Kukard committed
937

938
	# Attach our main limit on the qdisc
Nigel Kukard's avatar
Nigel Kukard committed
939
	my $burst = int($interface->{'Limit'}/8); # Allow the entire interface to be emptied with a burst
940
	$changeSet->add([
941
			'/sbin/tc','class','add',