File Coverage

lib/Net/ISP/Balance.pm
Criterion Covered Total %
statement 486 729 66.6
branch 114 260 43.8
condition 34 79 43.0
subroutine 73 104 70.1
pod 60 70 85.7
total 767 1242 61.7


line stmt bran cond sub pod time code
1             package Net::ISP::Balance;
2              
3 1     1   877 use strict;
  1         2  
  1         46  
4 1     1   7 use Fcntl ':flock';
  1         3  
  1         222  
5 1     1   9 use Carp 'croak','carp';
  1         2  
  1         74  
6 1     1   544 use Data::Dumper;
  1         8471  
  1         112  
7 1     1   14 no warnings;
  1         3  
  1         96  
8              
9 1     1   738 eval 'use Net::Netmask';
  1         20440  
  1         143  
10 1     1   699 eval 'use Net::ISP::Balance::ConfigData';
  1         5  
  1         36  
11              
12             our $VERSION = '1.27';
13              
14             =head1 NAME
15              
16             Net::ISP::Balance - Support load balancing across multiple internet service providers
17              
18             =head1 SYNOPSIS
19              
20             use Net::ISP::Balance;
21              
22             # initialize the module with its configuration file
23             my $bal = Net::ISP::Balance->new('/etc/network/balance.conf');
24              
25             $bal->verbose(1); # verbosely print routing and firewall
26             # commands to STDERR before running them.
27             $bal->echo_only(1); # echo commands to STDOUT; don't execute them.
28              
29             # mark the balanced services that are up
30             $bal->up('CABLE','DSL','SATELLITE');
31              
32             # write out routing and firewall commands
33             $bal->set_routes_and_firewall();
34              
35             # write out a forwarding rule
36             $bal->forward(80 => '192.168.10.35'); # forward web requests to this host
37              
38             # write out an arbitrary routing rule
39             $bal->ip_route('add 192.168.100.1 dev eth0 src 198.162.1.14');
40              
41             # write out an arbitrary iptables rule
42             $bal->iptables('-A INCOMING -p tcp --dport 6000 -j REJECT');
43              
44             # get information about all services
45             my @s = $bal->service_names;
46             for my $s (@s) {
47             print $bal->dev($s);
48             print $bal->ip($s);
49             print $bal->gw($s);
50             print $bal->net($s);
51             print $bal->fwmark($s);
52             print $bal->table($s);
53             print $bal->running($s);
54             print $bal->weight($s);
55             }
56              
57             =cut
58              
59 1     1   8 use Carp;
  1         2  
  1         11983  
60              
61             =head1 USAGE
62              
63             This library supports load_balance.pl, a script to load-balance a home
64             network across two or more Internet Service Providers (ISP). The
65             load_balance.pl script can be found in the bin subdirectory of this
66             distribution. Installation and configuration instructions can be found
67             at http://lstein.github.io/Net-ISP-Balance/.
68              
69             =head1 CONFIGURATION FILE
70              
71             This module reads a configuration file with the following format:
72              
73             #service device role ping-ip weight gateway
74             CABLE eth0 isp 173.194.43.95 1 173.193.43.1
75             DSL ppp0 isp 173.194.43.95 1
76             LAN1 eth1 lan
77             LAN2 eth2 lan
78             LAN3 eth3 lan
79              
80              
81             The first column is a service name that is used to bring up or down
82             the needed routes and firewall rules.
83              
84             The second column is the name of the network interface device that
85             connects to that service.
86              
87             The third column is either "isp" or "lan". There may be any number of
88             these. The script will firewall traffic passing through any of the
89             ISPs, and will load balance traffic among them. Traffic can flow
90             freely among any of the interfaces marked as belonging to a LAN.
91              
92             The fourth column (optional) is the IP address of a host that can be
93             periodically pinged to test the integrity of each ISP connection. If
94             too many pings failed, the service will be brought down and all
95             traffic routed through the remaining ISP(s). The service will continue
96             to be monitored and will be brought up when it is once again
97             working. Choose a host that is not likely to go offline for reasons
98             unrelated to your network connectivity, such as google.com, or the
99             ISP's web site. If this column is absent or marked "default", then the
100             host will default to www.google.ca.
101              
102             The fifth column (optional) is a weight to assign to the service, and
103             is only valid for ISP rows. If weights are equal, traffic will be
104             apportioned evenly between the two routes. Increase a weight to favor
105             one ISP over the others. For example, if "CABLE" has a weight of 2 and
106             "DSL" has a weight of 1, then twice as much traffic will flow through
107             the CABLE service. If this column is omitted or marked "default", then
108             equal weights are assumed.
109              
110             The sixth column (optional) is the gateway for this service using
111             dotted IP notation. If absent or named "default", the system will
112             attempt to determine the proper gateway automatically. Note the
113             algorithm relies on the fact that the gateway is almost always the
114             first address in the IP range for the subnetwork. If this is not the
115             case, then routing through the interface won't work properly. Add the
116             correct gateway IP address manually to correct this.
117              
118             If this package is running on a single Internet-connected host, not a
119             router, then do not include a "lan" line.
120              
121             In addition to the main table, there are several configuration options
122             that follow the format "configuration_name=value":
123              
124             =over 4
125              
126             =item forwarding_group=
127              
128             The forwarding_group configuration option defines a set of services
129             that the router is allowed to forward packets among. Provide a
130             space-delimited set of service names or one or more of the
131             abbreviations ":isp" and ":lan". ":isp" is an abbreviation for all
132             ISP services, while ":lan" is an abbreviation for all LAN services. So
133             for example, the two configuration lines below will allow forwarding
134             of packets between LAN1, LAN2, LAN3 and both ISPs. LAN4 will be
135             granted access to both ISPs but won't be able to exchange packets with
136             LANs 1 through 3:
137              
138             forwarding_group=LAN1 LAN2 LAN3 :isp
139             forwarding_group=LAN4 :isp
140              
141             If no forwarding_group options are defined, then the router will
142             forward packets among all LANs and ISP interfaces. It is equivalent to
143             this:
144              
145             forwarding_group=:lan :isp
146              
147             =item warn_email=
148              
149             Warn_email provides an email address to send notification messages to
150             if the status of a link changes (goes down, or comes back up). You
151             must have the "mail" program installed and configured for this to
152             work.
153              
154             =item interval_ms=
155              
156             Indicates how often to check the ping host for each ISP.
157              
158             =item min_packet_loss=
159              
160             =item max_packet_loss=
161              
162             These define the minimum and maximum packet losses required to declare
163             a link up or down.
164              
165             =item min_successive_pkts_rcvd=
166              
167             =item max_successive_pkts_recvd=
168              
169             These define the minimum and maximum numbers of
170             successively-transmitted pings that must be returned in order to
171             declare a link up or down.
172              
173             =item long_down_time=
174              
175             This is a value in seconds after a service that has gone down is
176             considered to have been down for a long time. You may optionally run a
177             series of shell scripts when this has occurred (see below).
178              
179             =back
180              
181             =head1 FREQUENTLY-USED METHODS
182              
183             Here are the class methods for this module that can be called on the
184             class name.
185              
186             =head2 $bal = Net::ISP::Balance->new('/path/to/config_file.conf');
187              
188             Creates a new balancer object.
189              
190             The first optional argument is the balancer configuration file, which
191             defaults to /etc/network/balance.conf on Ubuntu/Debian-derived
192             systems, and /etc/sysconfig/network-scripts/balance.conf on
193             RedHat/CentOS-derived systems. From hereon, we'll refer to the base of
194             the various configuration files as $ETC_NETWORK.
195              
196             =cut
197              
198             sub new {
199 2     2 1 10083 my $class = shift;
200 2         18 my ($conf,%options) = @_;
201 2   33     15 $conf ||= $class->default_conf_file;
202 2 50 33     99 $conf && -r $conf || croak 'Must provide a readable configuration file path';
203             my $self = bless {
204             verbose => 0,
205             echo_only => 0,
206             services => {},
207             rules_directory => $class->default_rules_directory,
208             lsm_conf_file => $class->default_lsm_conf_file,
209             lsm_scripts_dir => $class->default_lsm_scripts_dir,
210             bal_conf_file => $conf,
211             keep_custom_chains => 1,
212             dummy_data => $options{dummy_test_data},
213             dev_lookup_retries => $options{dev_lookup_retries},
214             dev_lookup_retry_delay => $options{dev_lookup_retry_delay},
215 2   33     20 },ref $class || $class;
216              
217 2         17 $self->_parse_configuration_file($conf);
218              
219             # Instead of potentially timing out on new(), we collect information on all
220             # interfaces that are currently up. We do this again with the timeout before
221             # actually changing the routing table, when it is critical that all interfaces
222             # be configured.
223             # $self->_collect_interfaces_retry(); # try to collect interfaces over 10 seconds
224 2         6 my %ifs;
225 2         14 $self->_collect_interfaces(\%ifs);
226 2         9 $self->{services} = \%ifs;
227              
228 2         18 return $self;
229             }
230              
231             =head2 $bal->set_routes_and_firewall
232              
233             Once the Balance objecty is created, call set_routes_and_firewall() to
234             configure the routing tables and firewall for load balancing. These
235             rules will either be executed on the system, or printed to standard
236             output as a series of shell script commands if echo_only() is set to
237             true.
238              
239             The routing tables and firewall rules are based on the configuration
240             described in $ETC_NETWORK/balance.conf. You may add custom routes and
241             rules by creating files in $ETC_NETWORK/balance/routes and
242             $ETC_NETWORK/balance/firewall. The former contains a series of files
243             or perl scripts that define additional routing rules. The latter
244             contains files or perl scripts that define additional firewall rules.
245              
246             Files located in $ETC_NETWORK/balance/pre-run will be executed AFTER
247             load_balance.pl has cleared the routing table and firewall, but before
248             it has emitted any any route/firewall commands. Files located in
249             in $ETC_NETWORK/balance/post-run will be run after load_balance.pl is
250             finished.
251              
252             Any files you put into these directories will be read in alphabetic
253             order and added to the routes and/or firewall rules emitted by the
254             load balancing script.Contained in this directory are subdirectories named "routes" and
255             "firewall". The former contains a series of files or perl scripts that
256             define additional routing rules. The latter contains files or perl
257             scripts that define additional firewall rules.
258              
259             Note that files ending in ~ or starting with # are treated as autosave files
260             and ignored.
261              
262             A typical routing rules file will look like the example shown
263             below.
264              
265             # file: /etc/network/balance/01.my_routes
266             ip route add 192.168.100.1 dev eth0 src 198.162.1.14
267             ip route add 192.168.1.0/24 dev eth2 src 10.0.0.4
268              
269             Each line will be sent to the shell, and it is intended (but not
270             required) that these be calls to the "ip" command. General shell
271             scripting constructs are not allowed here.
272              
273             A typical firewall rules file will look like the example shown here:
274              
275             # file: /etc/network/firewall/01.my_firewall_rules
276              
277             # accept incoming telnet connections to the router
278             iptable -A INPUT -p tcp --syn --dport telnet -j ACCEPT
279              
280             # masquerade connections to the DSL modem's control interface
281             iptables -t nat -A POSTROUTING -o eth2 -j MASQUERADE
282              
283             You may also insert routing and firewall rules via fragments of Perl
284             code, which is convenient because you don't have to hard-code any
285             network addresses and can make use of a variety of shortcuts. To do
286             this, simply end the file's name with .pl and make it executable.
287              
288             Here's an example that defines a series of port forwarding rules for
289             incoming connections:
290              
291             # file: /etc/network/firewall/02.forwardings.pl
292              
293             $B->forward(80 => '192.168.10.35'); # forward port 80 to internal web server
294             $B->forward(443=> '192.168.10.35'); # forward port 443 to
295             $B->forward(23 => '192.168.10.35:22'); # forward port 23 to ssh on web sever
296              
297             The main thing to know is that on entry to the script the global
298             variable $B will contain an initialized instance of a
299             Net::ISP::Balance object. You may then make method calls on this
300             object to emit firewall and routing rules.
301              
302             A typical routing rules file will look like the example shown
303             below.
304              
305             # file: /etc/network/balance/01.my_routes
306             ip route add 192.168.100.1 dev eth0 src 198.162.1.14
307             ip route add 192.168.1.0/24 dev eth2 src 10.0.0.4
308              
309             Each line will be sent to the shell, and it is intended (but not
310             required) that these be calls to the "ip" command. General shell
311             scripting constructs are not allowed here.
312              
313             A typical firewall rules file will look like the example shown here:
314              
315             # file: /etc/network/firewall/01.my_firewall_rules
316              
317             # accept incoming telnet connections to the router
318             iptable -A INPUT -p tcp --syn --dport telnet -j ACCEPT
319              
320             # masquerade connections to the DSL modem's control interface
321             iptables -t nat -A POSTROUTING -o eth2 -j MASQUERADE
322              
323             You may also insert routing and firewall rules via fragments of Perl
324             code, which is convenient because you don't have to hard-code any
325             network addresses and can make use of a variety of shortcuts. To do
326             this, simply end the file's name with .pl and make it executable.
327              
328             Here's an example that defines a series of port forwarding rules for
329             incoming connections:
330              
331             # file: /etc/network/firewall/02.forwardings.pl
332              
333             $B->forward(80 => '192.168.10.35'); # forward port 80 to internal web server
334             $B->forward(443=> '192.168.10.35'); # forward port 443 to
335             $B->forward(23 => '192.168.10.35:22'); # forward port 23 to ssh on web sever
336              
337             The main thing to know is that on entry to the script the global
338             variable $B will contain an initialized instance of a
339             Net::ISP::Balance object. You may then make method calls on this
340             object to emit firewall and routing rules.
341              
342             =cut
343              
344             sub set_routes_and_firewall {
345 0     0 1 0 my $self = shift;
346              
347 0         0 $self->save_routing_and_firewall();
348              
349             # first disable forwarding
350 0         0 $self->enable_forwarding(0);
351              
352 0         0 $self->_collect_interfaces_retry();
353 0 0       0 if ($self->isp_services) {
354 0         0 $self->pre_run_rules();
355 0         0 $self->set_routes();
356 0         0 $self->set_firewall();
357 0         0 $self->enable_forwarding(1);
358 0         0 $self->post_run_rules();
359             } else {
360 0         0 warn "No ISP services seem to be up. Restoring routing tables and firewall.\n";
361 0 0       0 $self->restore_routing_and_firewall() unless $self->echo_only;
362 0         0 return;
363             }
364             }
365              
366             sub save_routing_and_firewall {
367 0     0 0 0 my $self = shift;
368              
369 0         0 $self->{stored_routes} = [];
370 0         0 $self->{stored_rules} = '';
371 0         0 $self->{stored_firewall} = '';
372              
373 0 0       0 open my $f,"ip route show table all|" or die $!; # binary
374 0         0 while (<$f>) {
375 0         0 chomp;
376 0 0       0 next if /unreachable/;
377 0 0       0 next if /proto none/;
378 0         0 unshift @{$self->{stored_routes}},$_;
  0         0  
379             }
380 0         0 close $f;
381              
382 0 0       0 open $f,"ip rule show|" or die $!; # text
383 0         0 while (<$f>) {
384 0         0 $self->{stored_rules} .= $_;
385             }
386 0         0 close $f;
387              
388 0 0       0 open $f,"iptables-save|" or die $!; # text
389 0         0 while (<$f>) {
390 0         0 $self->{stored_firewall} .= $_;
391             }
392 0         0 close $f;
393             }
394              
395             sub restore_routing_and_firewall {
396 0     0 0 0 my $self = shift;
397              
398 0         0 $self->_initialize_routes();
399 0 0       0 if ($self->{stored_routes}) {
400 0         0 for (@{$self->{stored_routes}}) {
  0         0  
401 0         0 $self->ip_route("add $_");
402             }
403             }
404              
405 0 0       0 if ($self->{stored_rules}) {
406 0         0 my @rules = split "\n",$self->{stored_rules};
407 0         0 for my $r (@rules) {
408 0         0 my ($priority,$rule) = $r =~ /^(\d+):\s*(.+)/;
409 0 0       0 next if $priority == 32766; # these are created by _initialize!
410 0 0       0 next if $priority == 32767;
411 0         0 $self->ip_rule('add',$rule,"priority $priority");
412             }
413             }
414              
415 0 0       0 if ($self->{stored_firewall}) {
416 0 0       0 open my $f,"|iptables-restore" or die $!;
417 0         0 print $f $self->{stored_firewall};
418 0         0 close $f;
419             }
420             }
421              
422             =head2 $verbose = $bal->verbose([boolean]);
423              
424             sub bal_conf_file { my $self = shift; my $d = $self->{bal_conf_file};
425             $self->{bal_conf_file} = shift if @_; $d; } Get/set verbosity of
426             the module. If verbose is true, then firewall and routing rules
427             will be echoed to STDERR before being executed on the system.
428              
429             =cut
430              
431             sub verbose {
432 236     236 1 566 my $self = shift;
433 236         691 my $d = $self->{verbose};
434 236 50       634 $self->{verbose} = shift if @_;
435 236         860 $d;
436             }
437              
438             =head2 $echo = $bal->echo_only([boolean]);
439              
440             Get/set the echo_only flag. If this is true (default false), then
441             routing and firewall rules will be printed to STDOUT rathar than being
442             executed.
443              
444             =cut
445              
446             sub echo_only {
447 216     216 1 1469 my $self = shift;
448 216         429 my $d = $self->{echo_only};
449 216 100       808 $self->{echo_only} = shift if @_;
450 216         845 $d;
451             }
452              
453             =head2 $mode = $bal->operating_mode([$mode])
454              
455             Set or interrogate the operating mode. Will return one of "balanced"
456             (currently the default) or "failover". This corresponds to the "mode"
457             option in the configuration file. If the option is neither "balanced"
458             nor "failover", then "balanced" is chosen (be warned!)
459              
460             =cut
461              
462             sub operating_mode {
463 10     10 1 781 my $self = shift;
464 10         27 my $d = $self->{operating_mode};
465 10 100       50 $self->{operating_mode} = shift if @_;
466 10 100 100     93 return 'failover' if $d && $d =~ /failover/i;
467 6         33 return 'balanced';
468             }
469              
470             =head2 $retries = $bal->dev_lookup_retries([$retries])
471              
472             Get/set the number of times the library will try to look up an interface
473             that is not up or does not have an IP address. Default is 10
474              
475             =cut
476              
477             sub dev_lookup_retries {
478 0     0 1 0 my $self = shift;
479 0   0     0 my $d = $self->{dev_lookup_retries} || 10;
480 0 0       0 $self->{dev_lookup_retries} = shift if @_;
481 0         0 $d;
482             }
483              
484             =head2 $seconds = $bal->dev_lookup_retry_delay([$seconds])
485              
486             Get/set the number of seconds between retries when an interface is not up
487             or is missing an IP address. Default is 1.
488              
489             =cut
490              
491             sub dev_lookup_retry_delay {
492 0     0 1 0 my $self = shift;
493 0   0     0 my $d = $self->{dev_lookup_retry_delay} || 1;
494 0 0       0 $self->{dev_lookup_retry_delay} = shift if @_;
495 0         0 $d;
496             }
497              
498             =head2 $boolean = $bal->keep_custom_chains([boolean]);
499              
500             Get/set the keep_custom_chains flag. If this is true (default), then
501             any custom iptables chains, such as those created by miniunpnpd or
502             fail2ban, will be restored after execution of the firewall rules. If
503             false, then these rules were be flushed.
504              
505             =cut
506              
507             sub keep_custom_chains {
508 0     0 1 0 my $self = shift;
509 0         0 my $d = $self->{keep_custom_chains};
510 0 0       0 $self->{keep_custom_chains} = shift if @_;
511 0         0 $d;
512             }
513              
514             =head2 $result_code = $bal->sh(@args)
515              
516             Pass @args to the shell for execution. If echo_only() is set to true,
517             the command will not be executed, but instead be printed to standard
518             output.
519              
520             Example:
521              
522             $bal->sh('ip rule flush');
523              
524             The result code is the same as CORE::system().
525              
526             =cut
527              
528             sub sh {
529 214     214 1 513 my $self = shift;
530 214         790 my @args = @_;
531 214         940 my $arg = join ' ',@args;
532 214         542 chomp($arg);
533 214 50       739 carp $arg if $self->verbose;
534 214 50       1127 if ($self->echo_only) {
535 214         458 $arg .= "\n";
536 214         1523 print $arg;
537             } else {
538 0         0 system $arg;
539             }
540             }
541              
542             =head2 $bal->iptables(@args)
543              
544             Invoke sh() to call "iptables @args".
545              
546             Example:
547              
548             $bal->iptables('-A OUTPUT -o eth0 -j DROP');
549              
550             You may pass an array reference to iptables(), in which case iptables
551             is called on each member of the array in turn.
552              
553             Example:
554              
555             $bal->iptables(['-P OUTPUT DROP',
556             '-P INPUT DROP',
557             '-P FORWARD DROP']);
558              
559             Note that the method keeps track of rules; if you try to enter the
560             same iptables rule more than once the redundant ones will be ignored.
561              
562             =cut
563              
564             my %seen_rule;
565              
566             sub iptables {
567 163     163 1 820 my $self = shift;
568 163 100       435 if (ref $_[0] eq 'ARRAY') {
569 4   50     10 $seen_rule{$_}++ || $self->sh('iptables',$_) foreach @{$_[0]};
  4         31  
570             } else {
571 159 100       1171 $seen_rule{"@_"}++ || $self->sh('iptables',@_)
572             }
573             }
574              
575             sub _iptables_add_rule {
576 13     13   25 my $self = shift;
577 13         53 my ($operation,$chain,$table,@args) = @_;
578 13 50       34 croak "You must provide a chain name" unless $chain;
579 13 50       68 my $op = $operation eq 'append' ? '-A'
    50          
    100          
    100          
580             :$operation eq 'delete' ? '-D'
581             :$operation eq 'check ' ? '-C'
582             :$operation eq 'insert' ? '-I'
583             :'-A';
584            
585 13         29 my $command = '';
586 13 100       35 $command .= "-t $table " if $table;
587 13         33 $command .= "$op $chain ";
588 13         38 $command .= $self->_process_iptable_options(@args);
589 13         54 $self->iptables($command);
590             }
591              
592             sub iptables_append {
593 0     0 0 0 my $self = shift;
594 0         0 my ($table,$chain,@args) = @_;
595 0         0 $self->_iptables_add_rule('append',$table,$chain,@args);
596             }
597              
598             sub iptables_delete {
599 0     0 0 0 my $self = shift;
600 0         0 my ($table,$chain,@args) = @_;
601 0         0 $self->_iptables_add_rule('delete',$table,$chain,@args);
602             }
603              
604             sub iptables_check {
605 0     0 0 0 my $self = shift;
606 0         0 my ($table,$chain,@args) = @_;
607 0         0 $self->_iptables_add_rule('check',$table,$chain,@args);
608             }
609              
610             sub iptables_insert {
611 0     0 0 0 my $self = shift;
612 0         0 my ($table,$chain,@args) = @_;
613 0         0 $self->_iptables_add_rule('insert',$table,$chain,@args);
614             }
615              
616             =head2 $bal->firewall_rule($chain,$table,@args)
617              
618             Issue an iptables firewall rule.
619              
620             $chain -- The chain to apply the rule to, e.g. "INPUT".
621            
622             $table -- The table to apply the rule to, e.g. "nat". Undef defaults to
623             the standard "filter" table.
624              
625             @args -- The other arguments to pass to iptables.
626              
627             Here is a typical example of blocking incoming connections to port 25:
628              
629             $bal->firewall_rule(INPUT=>undef,-p=>'tcp',-dport=>25,-j=>'REJECT');
630              
631             This will issue the following command:
632              
633             iptables -A INPUT -p tcp --dport 25 -j REJECT
634              
635             The default operation is to append the rule to the chain using
636             -A. This can be changed by passing $bal->firewall_op() any of the
637             strings "append", "delete", "insert" or "check". Subsequent calls to
638             firewall_rule() will return commands for the indicated function:
639              
640             $bal->firewall_op('delete');
641             $bal->firewall_rule(INPUT=>undef,-p=>'tcp',-dport=>25,-j=>'REJECT');
642             # gives iptables -A INPUT -p tcp --dport 25 -j REJECT
643              
644             If you want to apply a series of deletes and then revert to the
645             original append behavior, then it is easiest to localize the hash key
646             "firewall_op":
647              
648             {
649             local $bal->{firewall_op} = 'delete';
650             $bal->firewall_rule(INPUT=>undef,-dport=>25,-j=>'ACCEPT');
651             $bal->firewall_rule(INPUT->undef,-dport=>80,-j=>'ACCEPT');
652             }
653            
654             $bal->firewall_rule(INPUT=>undef,-dport=>25,-j=>'DROP');
655             $bal->firewall_rule(INPUT=>undef,-dport=>80,-j=>'DROP');
656              
657             =cut
658              
659             sub firewall_rule {
660 13     13 1 29 my $self = shift;
661 13         56 my ($chain,$table,@args) = @_;
662 13         36 my $operation = $self->firewall_op();
663 13         45 $self->_iptables_add_rule($operation,$chain,$table,@args);
664             }
665              
666             sub firewall_op {
667 13     13 0 28 my $self = shift;
668 13 50       40 if (@_) {
669 0         0 $self->{firewall_op} = shift;
670 0         0 return;
671             }
672 13   100     46 my $d = $self->{firewall_op} || 'append';
673 13         37 return $d;
674             }
675              
676             =head2 $bal->force_route($service_or_device,@selectors)
677              
678             The force_route() method issues iptables commands that will force
679             certain traffic to travel over a particular ISP service or network
680             device. This is useful, for example, when one of your ISPs acts as
681             your e-mail relay and only accepts connections from the IP address
682             it assigns.
683              
684             $service_or_device is the symbolic name of an ISP service
685             (e.g. "CABLE") or a network device that a service is attached to
686             (e.g. "eth0").
687              
688             @selectors are a series of options that will be passed to
689             iptables to select the routing of packets. For example, to forward all
690             outgoing mail (destined to port 25) to the "CABLE" ISP, you would
691             write:
692              
693             $bal->force_route('CABLE','-p'=>'tcp','--syn','--dport'=>25);
694              
695             @selectors is a series of optional arguments that will be passed to
696             iptables on the command line. They will simply be space-separated, and
697             so the following is equivalent to the previous example:
698              
699             $bal->force_route('CABLE','-p tcp --syn --dport 25');
700              
701             Bare arguments that begin with a leading hyphen and are followed by
702             two or more alphanumeric characters are automatically converted into
703             double-hyphen arguments. This allows you to simplify commands
704             slightly. The following is equivalent to the previous examples:
705              
706             $bal->force_route('CABLE',-p=>'tcp',-syn,-dport=>25);
707              
708             You can delete force_route rules by setting firewall_op() to 'delete':
709              
710             $bal->firewall_op('delete');
711             $bal->force_route('CABLE',-p=>'tcp',-syn,-dport=>25);
712              
713             =cut
714              
715             sub force_route {
716 2     2 1 2624 my $self = shift;
717 2         12 my ($service_or_device,@selectors) = @_;
718            
719 2 50       12 my $service = $self->_service_or_device($service_or_device)
720             or croak "did not recognize $service_or_device as a service or a device";
721              
722 2         12 my $dest = $self->mark_table($service);
723 2         10 my $selectors = $self->_process_iptable_options(@selectors);
724 2         13 $self->firewall_rule(PREROUTING=>'mangle',$selectors,-j=>$dest);
725             }
726              
727             =head2 $bal->add_route($address => $device, [$masquerade])
728              
729             This method is used to create routing and firewall rules for a network
730             that isn't mentioned in balance.conf. This may be necessary to route
731             to VPNs and/or to the control interfaces of attached modems.
732              
733             The first argument is the network address in CIDR format,
734             e.g. '192.168.2.0/24'. The second is the network interface that the
735             network can be accessed via. The third, optional, argument is a
736             boolean. If true, then firewall rules will be set up to masquerade
737             from the LAN into the attached network.
738              
739             Note that this is pretty limited. If you want to do anything more
740             sophisticated you're better off setting the routes and firewall rules
741             manually.
742              
743             =cut
744              
745             sub add_route {
746 1     1 1 1010 my $self = shift;
747 1         6 my ($network,$device,$masquerade) = @_;
748 1 50 33     12 $network && $device or croak "usage: add_network(\$network,\$device,[\$masquerade])";
749             # add the route to our main table
750 1         10 $self->ip_route("add $network dev $device");
751             # add the route to each outgoing table
752 1         7 $self->ip_route("add $network dev $device table $_") for map {$self->table($_)} $self->isp_services;
  3         12  
753            
754             # create appropriate firewall rules for the network
755             {
756 1         4 local $self->{firewall_op} = 'insert';
  1         6  
757 1         9 $self->firewall_rule(OUTPUT => undef,
758             -o => $device,
759             -d => $network,
760             -j => 'ACCEPT');
761 1         8 $self->firewall_rule(INPUT => undef,
762             -i => $device,
763             -s => $network,
764             -j => 'ACCEPT');
765             $self->firewall_rule(FORWARD => undef,
766             -i => $self->dev($_),
767             -s => $self->net($_),
768             -o => $device,
769             -d => $network,
770 1         6 -j => 'ACCEPT') for $self->lan_services;
771             $self->firewall_rule(FORWARD => undef,
772             -i => $device,
773             -s => $network,
774             -o => $self->dev($_),
775             -d => $self->net($_),
776 1         7 -j => 'ACCEPT') for $self->lan_services;
777             }
778 1 50       7 if ($masquerade) {
779 1         8 $self->firewall_rule(POSTROUTING=>'nat',
780             -d => $network,
781             -o => $device,
782             -j => 'MASQUERADE');
783             }
784             }
785              
786             sub _process_iptable_options {
787 15     15   34 my $self = shift;
788 15         138 my @opt = @_;
789 15         43 foreach (@opt) {
790 114 100       388 $_ = "-$_" if /^-\w{2,}/; # add an extra hyphen to -arguments
791 114         1207 $_ =~ quotemeta($_);
792             }
793 15         93 return join ' ',@opt;
794             }
795              
796             sub _mark {
797 30     30   139 my $self = shift;
798 30         61 my $service = shift;
799 30         173 return "MARK-${service}";
800             }
801              
802             =head2 $table_name = $bal->mark_table($service)
803              
804             This returns the iptables table name for connections marked for output
805             on a particular ISP service. The name is simply the word "MARK-"
806             appended to the service name. For example, for a service named "DSL",
807             the corresponding firewall table will be named "MARK-DSL".
808              
809             =cut
810              
811 30     30 1 89 sub mark_table { shift->_mark(shift) }
812              
813             sub _service_or_device {
814 2     2   7 my $self = shift;
815 2         6 my $sod = shift;
816 2 50       9 return $sod if $self->dev($sod);
817             # otherwise try looking for devices
818 0         0 my %dev2s = map {$self->dev($_) => $_} $self->service_names;
  0         0  
819 0         0 return $dev2s{$sod};
820             }
821              
822             =head2 $bal->forward($incoming_port,$destination_host,@protocols)
823              
824             This method emits appropriate port/host forwarding rules using DNAT
825             address translation. The destination host can be specified using
826             either of these forms:
827              
828             192.168.100.1 # forward to same port as incoming
829             192.168.100.1:8080 # forward to a different port on host
830              
831             Protocols are one or more of 'tcp','udp'. If omitted defaults to tcp.
832              
833             Examples:
834            
835             $bal->forward(80 => '192.168.100.1');
836             $bal->forward(80 => '192.168.100.1:8080','tcp');
837              
838             =cut
839              
840             sub forward {
841 3     3 1 2174 my $self = shift;
842 3         76 my ($port,$host,@protocols) = @_;
843 3 100       19 @protocols = ('tcp') unless @protocols;
844              
845 3         20 my ($dhost,$dport) = split ':',$host;
846 3   33     13 $dhost ||= $host;
847 3   66     18 $dport ||= $port;
848              
849 3         15 my @dev = map {$self->dev($_)} $self->isp_services;
  9         27  
850              
851 3         13 for my $dev (@dev) {
852 9         24 for my $protocol (@protocols) {
853 12         66 $self->iptables("-t nat -A PREROUTING -i $dev -p $protocol --dport $port -j DNAT --to-destination $host");
854 12         40 for my $lan ($self->lan_services) {
855 48         135 my $landev = $self->dev($lan);
856 48         126 my $lannet = $self->net($lan);
857 48         123 my $lanip = $self->ip($lan);
858 48 100       139 my $syn = $protocol eq 'tcp' ? '--syn' : '';
859 48         209 $self->iptables("-A FORWARD -p $protocol -o $landev $syn -d $dhost --dport $dport -j ACCEPT");
860             }
861             }
862             }
863             }
864              
865             =head2 $bal->forward_with_snat($incoming_port,$destination_host,@protocols)
866              
867             This method is the same as forward(), except that it also does source
868             NATing from LAN-based requests to make the request appear to have come
869             from the router. This is used when you expose a server, such as a web
870             server, to the internet, but you also need to access the server from
871             machines on the LAN. Use this if you find that the service is visible
872             from outside the LAN but not inside the LAN.
873              
874             Examples:
875              
876             $bal->forward_with_snat(80 => '192.168.100.1');
877             $bal->forward_with_snat(80 => '192.168.100.1:8080','tcp');
878              
879              
880             =cut
881              
882             sub forward_with_snat {
883 0     0 1 0 my $self = shift;
884 0         0 my ($port,$host,@protocols) = @_;
885              
886 0 0       0 @protocols = ('tcp') unless @protocols;
887              
888 0         0 my ($dhost,$dport) = split ':',$host;
889 0   0     0 $dhost ||= $host;
890 0   0     0 $dport ||= $port;
891              
892 0         0 for my $protocol (@protocols) {
893 0         0 for my $svc ($self->isp_services) {
894 0         0 my $external_ip = $self->ip($svc);
895 0         0 $self->iptables("-t nat -A PREROUTING -d $external_ip -p $protocol --dport $port -j DNAT --to-destination $host");
896             }
897              
898 0         0 for my $lan ($self->lan_services) {
899 0         0 my $lannet = $self->net($lan);
900 0         0 $self->iptables("-t nat -A POSTROUTING -s $lannet -p $protocol --dport $port -d $host -j MASQUERADE");
901             }
902              
903 0         0 $self->iptables("-A FORWARD -p $protocol --dport $port -d $host -j ACCEPT");
904              
905             }
906              
907             }
908              
909             =head2 $bal->ip_route(@args)
910              
911             Shortcut for $bal->sh('ip route',@args);
912              
913             =cut
914              
915 61     61 1 622 sub ip_route {shift->sh('ip','route',@_)}
916              
917             =head2 $bal->ip_rule(@args)
918              
919             Shortcut for $bal->sh('ip rule',@args);
920              
921             =cut
922              
923 10     10 1 30 sub ip_rule {shift->sh('ip','rule',@_)}
924              
925             =head2 $verbose = $bal->iptables_verbose([boolean])
926              
927             Makes iptables send an incredible amount of debugging information to
928             syslog.
929              
930             =cut
931              
932             sub iptables_verbose {
933 0     0 1 0 my $self = shift;
934 0         0 my $d = $self->{iptables_verbose};
935 0 0       0 $self->{iptables_verbose} = shift if @_;
936 0         0 $d;
937             }
938              
939             =head1 QUERYING THE CONFIGURATION
940              
941             These methods allow you to get information about the Net::ISP::Balance
942             object's configuration, including settings and other characteristics
943             of the various network interfaces.
944              
945             =head2 @names = $bal->service_names
946              
947             Return the list of service names defined in balance.conf.
948              
949             =cut
950              
951             sub service_names {
952 48     48 1 207 my $self = shift;
953 48         248 my $s = $self->services;
954 48         467 return sort keys %$s;
955             }
956              
957             =head2 @names = $bal->isp_services
958              
959             Return list of service names that correspond to load-balanced ISPs.
960              
961             =cut
962              
963             sub isp_services {
964 20     20 1 60 my $self = shift;
965 20         70 my @n = $self->service_names;
966 20         82 return grep {$self->role($_) eq 'isp'} @n; # kill uninit warning
  156         411  
967             }
968              
969             =head2 @names = $bal->lan_services
970              
971             Return list of service names that correspond to lans.
972              
973              
974             =cut
975              
976             sub lan_services {
977 21     21 1 56 my $self = shift;
978 21         63 my @n = $self->service_names;
979 21         74 return grep {$self->role($_) eq 'lan'} @n; # kill uninit warning...
  168         725  
980             }
981              
982             =head2 $state = $bal->event($service => $new_state)
983              
984             Record a transition between "up" and "down" for a named service. The
985             first argument is the name of the ISP service that has changed,
986             e.g. "CABLE". The second argument is either "up" or "down".
987              
988             The method returns a hashref in which the keys are the ISP service names
989             and the values are one of 'up' or 'down'.
990              
991             The persistent state information is stored in /var/lib/lsm/ under a
992             series of files named .state.
993              
994             =cut
995              
996             sub event {
997 0     0 1 0 my $self = shift;
998              
999 0 0       0 if (@_) {
1000 0         0 my ($svc,$new_state) = @_;
1001 0 0       0 $new_state =~ /^(up|down)$/ or croak "state must be 'up' or down'";
1002 0 0       0 $self->dev($svc) or croak "service '$svc' is unknown";
1003 0         0 my $file = "/var/lib/lsm/${svc}.state";
1004 0 0       0 my $mode = -e $file ? '+<' : '>';
1005 0 0       0 open my $fh,$mode,$file or croak "Couldn't open $file mode $mode: $!";
1006 0         0 flock $fh,LOCK_EX;
1007 0         0 truncate $fh,0;
1008 0         0 seek($fh,0,0);
1009 0         0 print $fh $new_state;
1010 0         0 close $fh;
1011             }
1012              
1013 0         0 my %state;
1014 0         0 for my $svc ($self->isp_services) {
1015 0         0 my $file = "/var/lib/lsm/${svc}.state";
1016 0 0       0 if (open my $fh,'<',$file) {
1017 0         0 flock $fh,LOCK_SH;
1018 0         0 my $state = <$fh>;
1019 0         0 close $fh;
1020 0         0 $state{$svc}=$state;
1021             } else {
1022 0         0 $state{$svc}='unknown';
1023             }
1024             }
1025 0         0 my @up = grep {$state{$_} eq 'up'} keys %state;
  0         0  
1026 0         0 $self->up(@up);
1027 0         0 return \%state;
1028             }
1029              
1030             =head2 $bal->run_eventd(@args)
1031              
1032             Runs scripts in response to lsm events. The scripts are stored in
1033             directories named after the events, e.g.:
1034              
1035             /etc/network/lsm/up.d/*
1036             /etc/network/lsm/down.d/*
1037             /etc/network/lsm/long_down.d/*
1038              
1039             Scripts are called with the following arguments:
1040              
1041             0. STATE
1042             1. SERVICE NAME
1043             2. CHECKIP
1044             3. DEVICE
1045             4. WARN_EMAIL
1046             5. REPLIED
1047             6. WAITING
1048             7. TIMEOUT
1049             8. REPLY_LATE
1050             9. CONS_RCVD
1051             10. CONS_WAIT
1052             11. CONS_MISS
1053             12. AVG_RTT
1054             13. SRCIP
1055             14. PREVSTATE
1056             15. TIMESTAMP
1057              
1058             =cut
1059              
1060             sub run_eventd {
1061 0     0 1 0 my $self = shift;
1062 0         0 my @args = @_;
1063 0         0 my $state = $args[0];
1064 0         0 my $dir = $self->lsm_scripts_dir();
1065 0         0 my $dird = "$dir/${state}.d";
1066 0         0 my @files = sort glob("$dird/*");
1067 0         0 for my $script (sort @files) {
1068 0 0       0 next if $script =~ /^#/;
1069 0 0       0 next if $script =~ /~$/;
1070 0 0 0     0 next unless -f $script && -x _;
1071 0         0 system $script,@args;
1072             }
1073             }
1074              
1075             =head2 @up = $bal->up(@up_services)
1076              
1077             Get or set the list of ISP interfaces that are currently active and
1078             should be used for balancing.
1079              
1080             =cut
1081              
1082             sub up {
1083 6     6 1 1706 my $self = shift;
1084 6 100       28 $self->{up} = \@_ if @_;
1085 6 100       28 unless ($self->{up}) { # initialize with running services
1086 2         11 my @svc = grep {$self->running($_)} $self->isp_services;
  5         20  
1087 2         23 $self->{up} = \@svc;
1088             }
1089 6         18 my @up = @{$self->{up}};
  6         26  
1090 6         32 return @up;
1091             }
1092              
1093             =head2 $services = $bal->services
1094              
1095             Return a hash containing the configuration information for each
1096             service. The keys are the service names. Here's an example:
1097              
1098             {
1099             0 HASH(0x91201e8)
1100             'CABLE' => HASH(0x9170500)
1101             'dev' => 'eth0'
1102             'fwmark' => 2
1103             'gw' => '191.3.88.1'
1104             'ip' => '191.3.88.152'
1105             'net' => '191.3.88.128/27'
1106             'ping' => 'www.google.ca'
1107             'role' => 'isp'
1108             'running' => 1
1109             'table' => 2
1110             'DSL' => HASH(0x9113e00)
1111             'dev' => 'ppp0'
1112             'fwmark' => 1
1113             'gw' => '112.211.154.198'
1114             'ip' => '11.120.199.108'
1115             'net' => '112.211.154.198/32'
1116             'ping' => 'www.google.ca'
1117             'role' => 'isp'
1118             'running' => 1
1119             'table' => 1
1120             'LAN' => HASH(0x913ce58)
1121             'dev' => 'eth1'
1122             'fwmark' => undef
1123             'gw' => '192.168.10.1'
1124             'ip' => '192.168.10.1'
1125             'net' => '192.168.10.0/24'
1126             'ping' => ''
1127             'role' => 'lan'
1128             'running' => 1
1129             }
1130              
1131             =cut
1132              
1133 49     49 1 900 sub services { return shift->{services} }
1134              
1135             =head2 $service = $bal->service('CABLE')
1136              
1137             Return the subhash describing the single named service (see services()
1138             above).
1139              
1140             =cut
1141              
1142             sub service {
1143 0     0 1 0 shift->{services}{shift()};
1144             }
1145              
1146             =head2 $dev = $bal->dev('CABLE')
1147              
1148             =head2 $ip = $bal->ip('CABLE')
1149              
1150             =head2 $gateway = $bal->gw('CABLE')
1151              
1152             =head2 $network = $bal->net('CABLE')
1153              
1154             =head2 $role = $bal->role('CABLE')
1155              
1156             =head2 $running = $bal->running('CABLE')
1157              
1158             =head2 $mark_number = $bal->fwmark('CABLE')
1159              
1160             =head2 $routing_table_number = $bal->table('CABLE')
1161              
1162             =head2 $ping_dest = $bal->ping('CABLE')
1163              
1164             These methods pull out the named information from the configuration
1165             data. fwmark() returns a small integer that will be used for marking
1166             connections for routing through one of the ISP connections when an
1167             outgoing connection originates on the LAN and is routed through the
1168             router. table() returns a small integer corresponding to a routing
1169             table used to route connections originating on the router itself.
1170              
1171             =cut
1172              
1173 194     194 1 10099 sub dev { shift->_service_field(shift,'dev') }
1174 106     106 1 390 sub ip { shift->_service_field(shift,'ip') }
1175 9     9 1 33 sub gw { shift->_service_field(shift,'gw') }
1176 156     156 1 404 sub net { shift->_service_field(shift,'net') }
1177 5     5 1 14 sub running { shift->_service_field(shift,'running') }
1178 326     326 1 1298 sub role { shift->_service_field(shift,'role') }
1179 11     11 1 32 sub fwmark { shift->_service_field(shift,'fwmark') }
1180 54     54 1 144 sub table { shift->_service_field(shift,'table') }
1181 3     3 1 10 sub ping { shift->_service_field(shift,'ping') }
1182 17     17 0 143 sub weight { shift->_service_field(shift,'weight') }
1183              
1184             sub _service_field {
1185 881     881   1799 my $self = shift;
1186 881         2563 my ($service,$field) = @_;
1187 881 50       2762 my $s = $self->{services}{$service} or return;
1188 881         3968 $s->{$field};
1189             }
1190              
1191             sub _save_custom_chains {
1192 0     0   0 my $self = shift;
1193 0         0 for my $table ('filter','nat','mangle') {
1194 0         0 my @rules = split("\n",`sudo iptables -t $table -S`);
1195             # find custom chains
1196 0         0 my $mine = 'MARK-|REJECTPERM|DROPGEN|DROPINVAL|DROPPERM|DROPSPOOF|DROPFLOOD|DEBUG';
1197 0 0       0 my @chains = grep {!/^-N ($mine)/} grep {/^-N (\S+)/} @rules or next;
  0         0  
  0         0  
1198 0         0 s/^-N // foreach @chains;
1199 0         0 my $chains = join '|',map {quotemeta($_)} @chains;
  0         0  
1200 0         0 my @targets = grep {/-(?:j|A|I) (?:$chains)/} @rules;
  0         0  
1201 0         0 $self->{_custom_chains}{$table} = [(map {"-N $_"} @chains),@targets];
  0         0  
1202             }
1203             }
1204              
1205             sub _restore_custom_chains {
1206 0     0   0 my $self = shift;
1207 0 0       0 my $custom_chains = $self->{_custom_chains} or return;
1208 0         0 for my $table (keys %{$custom_chains}) {
  0         0  
1209 0 0       0 my @rules = @{$custom_chains->{$table}} or next;
  0         0  
1210 0         0 $self->iptables([map {"-t $table $_"} @rules]);
  0         0  
1211             }
1212             }
1213              
1214             =head1 FILES AND PATHS
1215              
1216             These are methods that determine where Net::ISP::Balance finds its
1217             configuration files.
1218              
1219             =head2 $path = Net::ISP::Balance->install_etc
1220              
1221             Returns the path to where the network configuration files reside on
1222             this system, e.g. /etc/network. Note that this only knows about
1223             Ubuntu/Debian-style network configuration files in /etc/network, and
1224             RedHat/CentOS network configuration files in
1225             /etc/sysconfig/network-scripts.
1226              
1227             =cut
1228              
1229             sub install_etc {
1230 7     7 1 18 my $self = shift;
1231 7 50       168 return '/etc/network' if -d '/etc/network';
1232 0 0       0 return '/etc/sysconfig/network-scripts' if -d '/etc/sysconfig/network-scripts';
1233 0         0 return '/etc';
1234             }
1235              
1236             =head2 $file = Net::ISP::Balance->default_conf_file
1237              
1238             Returns the path to the default configuration file,
1239             $ETC_NETWORK/balance.conf.
1240              
1241             =cut
1242              
1243             sub default_conf_file {
1244 0     0 1 0 my $self = shift;
1245 0         0 return $self->install_etc.'/balance.conf';
1246             }
1247              
1248             =head2 $dir = Net::ISP::Balance->default_rules_directory
1249              
1250             Returns the path to the directory where the additional router and
1251             firewall rules are stored. On Ubuntu-Debian-derived systems, this is
1252             /etc/network/balance/. On RedHat/CentOS systems, this is
1253             /etc/sysconfig/network-scripts/balance/.
1254              
1255             =cut
1256              
1257             sub default_rules_directory {
1258 2     2 1 29 my $self = shift;
1259 2         25 return $self->install_etc."/balance";
1260             }
1261              
1262             =head2 $file = Net::ISP::Balance->default_lsm_conf_file
1263              
1264             Returns the path to the place where we should store lsm.conf, the file
1265             used to configure the lsm (link status monitor) application.
1266              
1267             On Ubuntu/Debian-derived systems, this will be the file
1268             /etc/network/lsm.conf. On RedHad/CentOS-derived systems, this will be
1269             /etc/sysconfig/network-scripts/lsm.conf.
1270              
1271             =cut
1272              
1273             sub default_lsm_conf_file {
1274 2     2 1 8 my $self = shift;
1275 2         9 return $self->install_etc."/balance/lsm.conf";
1276             }
1277              
1278             =head2 $dir = Net::ISP::Balance->default_lsm_scripts_dir
1279              
1280             Returns the path to the place where lsm stores its helper scripts. On
1281             Ubuntu/Debian-derived systems, this will be the directory
1282             /etc/network/lsm/. On RedHad/CentOS-derived systems, this will be
1283             /etc/sysconfig/network-scripts/lsm/.
1284              
1285             =cut
1286              
1287             sub default_lsm_scripts_dir {
1288 2     2 1 7 my $self = shift;
1289 2         10 return $self->install_etc.'/balance/lsm';
1290             }
1291              
1292             =head2 $file = $bal->bal_conf_file([$new_file])
1293              
1294             Get/set the main configuration file path, balance.conf.
1295              
1296             =cut
1297              
1298             sub bal_conf_file {
1299 0     0 1 0 my $self = shift;
1300 0         0 my $d = $self->{bal_conf_file};
1301 0 0       0 $self->{bal_conf_file} = shift if @_;
1302 0         0 $d;
1303             }
1304              
1305             =head2 $dir = $bal->rules_directory([$new_rules_directory])
1306              
1307             Get/set the route and firewall rules directory.
1308              
1309             =cut
1310              
1311             sub rules_directory {
1312 3     3 1 16 my $self = shift;
1313 3         12 my $d = $self->{rules_directory};
1314 3 100       15 $self->{rules_directory} = shift if @_;
1315 3         10 $d;
1316             }
1317              
1318             =head2 $file = $bal->lsm_conf_file([$new_conffile])
1319              
1320             Get/set the path to the lsm configuration file.
1321              
1322             =cut
1323              
1324             sub lsm_conf_file {
1325 0     0 1 0 my $self = shift;
1326 0         0 my $d = $self->{lsm_conf_file};
1327 0 0       0 $self->{lsm_conf_file} = shift if @_;
1328 0         0 $d;
1329             }
1330              
1331             =head2 $dir = $bal->lsm_scripts_dir([$new_dir])
1332              
1333             Get/set the path to the lsm scripts directory.
1334              
1335             =cut
1336              
1337             sub lsm_scripts_dir {
1338 1     1 1 3 my $self = shift;
1339 1         4 my $d = $self->{lsm_scripts_dir};
1340 1 50       6 $self->{lsm_scripts_dir} = shift if @_;
1341 1         4 $d;
1342             }
1343              
1344             =head1 INFREQUENTLY-USED METHODS
1345              
1346             These are methods that are used internally, but may be useful to
1347             applications developers.
1348              
1349             =head2 $lsm_config_text = $bal->lsm_config_file(-warn_email=>'root@localhost')
1350              
1351             This method creates the text used to create the lsm.conf configuration
1352             file. Pass it a series of -name=>value pairs to incorporate into the
1353             file.
1354              
1355             Possible switches and their defaults are:
1356              
1357             -checkip 127.0.0.1
1358             -eventscript /etc/network/load_balance.pl
1359             -long_down_eventscript /etc/network/load_balance.pl
1360             -notifyscript /etc/network/balance/lsm/default_script
1361             -max_packet_loss 15
1362             -max_successive_pkts_lost 7
1363             -min_packet_loss 5
1364             -min_successive_pkts_rcvd 10
1365             -interval_ms 1000
1366             -timeout_ms 1000
1367             -warn_email root
1368             -check_arp 0
1369             -sourceip
1370             -device -eventscript => $balance_script,
1371             -ttl 0
1372             -status 2
1373             -debug 8
1374              
1375             =cut
1376              
1377             sub lsm_config_text {
1378 1     1 0 4 my $self = shift;
1379 1         6 my %args = @_;
1380 1         5 my $scripts_dir = $self->lsm_scripts_dir;
1381 1         5 my $balance_script = $self->install_etc."/load_balance.pl";
1382 1         24 my %defaults = (
1383             -checkip => '127.0.0.1',
1384             -debug => 8,
1385             -eventscript => $balance_script,
1386             -long_down_eventscript => $balance_script,
1387             -notifyscript => "$scripts_dir/default_script",
1388             -max_packet_loss => 20,
1389             -max_successive_pkts_lost => 7,
1390             -min_packet_loss => 10,
1391             -min_successive_pkts_rcvd => 5,
1392             -interval_ms => 1000,
1393             -timeout_ms => 500,
1394             -long_down_time => 120,
1395             -warn_email => 'root',
1396             -check_arp => 0,
1397             -sourceip => undef,
1398             -device => undef,
1399             -ttl => 0,
1400             -status => 2
1401             );
1402 1         7 %defaults = (%defaults,%{$self->{lsm_config}},%args); # %args supersedes what's in %defaults
  1         11  
1403              
1404 1         5 my $result = "# This file is autogenerated by load_balancer.pl when it first runs.\n";
1405 1         4 $result .= "# Do not edit directly. Instead edit /etc/network/balance.conf.\n\n";
1406 1         6 $result .= "debug=$defaults{-debug}\n\n";
1407 1         3 delete $defaults{-debug};
1408              
1409 1         4 $result .= "defaults {\n";
1410 1         3 $result .= " name=defaults\n";
1411 1         17 for my $option (sort keys %defaults) {
1412 17         75 (my $o = $option) =~ s/^-//;
1413 17 100       55 $defaults{$option} = '' unless defined $defaults{$option}; # avoid uninit var warnings
1414 17         140 $result .= " $o=$defaults{$option}\n";
1415             }
1416 1         4 $result .= "}\n\n";
1417              
1418 1         7 for my $svc ($self->isp_services) {
1419 3         10 my $device = $self->dev($svc);
1420 3         12 my $src_ip = $self->ip($svc);
1421 3         21 my $ping = $self->ping($svc);
1422 3         8 $result .= "connection {\n";
1423 3         10 $result .= " name=$svc\n";
1424 3         8 $result .= " device=$device\n";
1425 3         8 $result .= " checkip=$ping\n";
1426 3         10 $result .= "}\n\n";
1427             }
1428              
1429 1         9 return $result;
1430             }
1431              
1432             sub _parse_configuration_file {
1433 2     2   6 my $self = shift;
1434 2         7 my $path = shift;
1435 2         7 my (%services,%lsm_options,@forwarding_group);
1436 2 50       109 open my $f,$path or die "Could not open $path: $!";
1437              
1438 2         97 while (<$f>) {
1439 32         72 chomp;
1440 32 100       125 next if /^\s*#/;
1441 26 50       75 if (/^forwarding_group\s*=\s*(.+)$/) { # routing group
1442 0 0       0 my @group = split /\s+/,$1 or next;
1443 0         0 push @forwarding_group,\@group;
1444 0         0 next;
1445             }
1446 26 100       69 if (/^mode\s*=\s*(.+)$/) { # operating mode
1447 1         8 $self->operating_mode($1);
1448 1         10 next;
1449             }
1450 25 50       65 if (/^(\w+)\s*=\s*(.*)$/) { # lsm config
1451 0         0 $lsm_options{"-${1}"} = $2;
1452 0         0 next;
1453             }
1454 25         162 my ($service,$device,$role,$ping_dest,$weight,$gateway) = split /\s+/;
1455 25 50 66     152 next unless $service && $device && $role;
      66        
1456 15 50       70 croak "load_balance.conf line $.: A service can not be named 'up' or 'down'"
1457             if $service=~/^(up|down)$/;
1458              
1459 15         47 foreach (\$ping_dest,\$weight,\$gateway) {
1460 45 100       131 undef $$_ if $$_ eq 'default';
1461             }
1462            
1463 15         74 $services{$service}{dev} = $device;
1464 15         41 $services{$service}{role} = $role;
1465 15   100     67 $services{$service}{ping} = $ping_dest || 'www.google.ca';
1466 15   100     58 $services{$service}{weight} = $weight || 1;
1467 15         72 $services{$service}{gateway}= $gateway;
1468             }
1469 2         20 close $f;
1470 2         20 $self->{svc_config} = \%services;
1471 2         8 $self->{lsm_config} = \%lsm_options;
1472 2         15 $self->{forwarding_groups} = \@forwarding_group;
1473             }
1474              
1475             sub _collect_interfaces_retry {
1476 0     0   0 my $self = shift;
1477 0         0 my $retries = $self->dev_lookup_retries;
1478 0         0 my $wait = $self->dev_lookup_retry_delay;
1479 0         0 my %ifs;
1480 0         0 for (1..$retries) {
1481 0         0 delete $self->{_interface_info_cache}; # don't want to cache partial results
1482 0 0       0 last if $self->_collect_interfaces(\%ifs);
1483 0         0 sleep $wait;
1484             }
1485 0         0 $self->{services} = \%ifs;
1486             }
1487              
1488             sub _collect_interfaces {
1489 2     2   7 my $self = shift;
1490 2         5 my $interface_info = shift;
1491              
1492 2 50       10 my $s = $self->{svc_config} or return;
1493 2         10 my $i = $self->interface_info;
1494              
1495             # print STDERR Dumper($i);
1496              
1497             # map devices to services
1498 2         8 my %devs;
1499 2         18 for my $svc (keys %$s) {
1500 15         41 my $vdev = $s->{$svc}{dev};
1501 15         42 $devs{$vdev}=$svc;
1502             }
1503              
1504 2         7 my $counter = 0;
1505 2         7 my $configured_interfaces = 0;
1506              
1507 2         23 for my $vdev (sort keys %devs) {
1508 15 100       57 my $info = $i->{$vdev} or next;
1509 13         30 my $dev = $info->{dev};
1510 13         27 my $svc = $devs{$vdev};
1511 13         30 my $role = $s->{$svc}{role};
1512 13         24 $configured_interfaces++;
1513              
1514             # copy into hash passed to us
1515             $interface_info->{$svc} = {
1516             dev => $dev, # otherwise, iptables will croak!!!
1517             running => $info->{running},
1518             gw => $s->{$svc}{gateway} || $info->{gw},
1519             net => $info->{net},
1520             ip => $info->{ip},
1521             fwmark => $role eq 'isp' ? ++$counter : undef,
1522             table => $role eq 'isp' ? $counter : undef,
1523             role => $role,
1524             ping => $s->{$svc}{ping},
1525             weight => $s->{$svc}{weight},
1526             }
1527 13 100 66     166 }
    100          
1528 2         15 return $configured_interfaces >= keys %devs;
1529             }
1530              
1531             =head2 $if_hash = $bal->interface_info
1532              
1533             =head2 $if_hash = Net::ISP::Balance->interface_info
1534              
1535             This method returns a hashref containing information about each of the
1536             network interfaces found on the system (independent of those mentioned
1537             in the configuration file). It may be called as a class method or an
1538             instance method.
1539              
1540             Each key in the hash is the name of a (virtual) interface device. The
1541             values are hashrefs with the following keys:
1542              
1543             key value
1544             --- -----
1545             dev name of the underlying physical device (usually same as vdev)
1546             running boolean, true if interface is running
1547             gw gateway, if present
1548             net subnet in xxx.xxx.xxx.xxx/xx
1549              
1550             =cut
1551              
1552              
1553             sub interface_info {
1554 2     2 1 5 my $self = shift;
1555             return $self->{_interface_info_cache}
1556 2 50 33     19 if ref $self && exists $self->{_interface_info_cache};
1557            
1558 2         4 my %results; # keyed by interface device
1559              
1560             # LOGIC TO DEAL WITH VIRTUAL INTERFACES
1561             # 1. From _ip_addr_show get all the inet XXX.XXX.XXX.XXX lines and calculate
1562             # corresponding network and virtual interface.
1563             # 2. Record mapping of network to virtual interface in a hash (%vif)
1564             # 3. When going through the routes, replace $dev with virtual interface name
1565             # 4. In (keys %devs) loop, create an inner loop for each inet found and replace
1566             # device with correct virtual device.
1567              
1568             # get interfaces with assigned addresses
1569 2         10 my $a = $self->_ip_addr_show;
1570 2         49 my (undef,@ifs) = split /^\d+: /m,$a;
1571 2         10 chomp(@ifs);
1572             my %ifs = map {
1573 2         9 my ($dev,$config) = split(/: /,$_,2);
  20         72  
1574 20         49 $dev =~ s/\@.+$//; # get rid of bonding master information
1575 20         81 ($dev,$config);
1576             } @ifs;
1577              
1578             # find virtual interfaces
1579 2         9 my (%vnet,%vif);
1580 2         12 for my $dev (keys %ifs) {
1581 20         52 my $info = $ifs{$dev};
1582 20         326 while ($info =~ /inet (\d+\.\d+\.\d+\.\d+)(?:\/(\d+))?.+?(\S+)$/mg) {
1583 18         97 my ($addr,$bits,$vdev) = ($1,$2,$3);
1584 18 50       54 $addr or next;
1585 18   100     62 $bits ||= 32;
1586 18         69 my ($peer) = $info =~ /peer\s+(\d+\.\d+\.\d+\.\d+)/;
1587 18         113 my $block = Net::Netmask->new2("$addr/$bits");
1588 18         1629 $vnet{$dev}{"$block"} = $vdev;
1589 18         301 $vif{$dev}{$vdev}{block} = $block;
1590 18         151 $vif{$dev}{$vdev}{addr} = $addr;
1591             }
1592             }
1593              
1594             # get existing routes
1595 2         9 my (%gws,%nets);
1596 2         18 my $r = $self->_ip_route_show;
1597 2         32 my @routes = split /^(?!\s)/m,$r;
1598 2         8 chomp(@routes);
1599 2         8 foreach (@routes) {
1600 16         79 while (/(\S+)\s+via\s+(\S+)\s+dev\s+(\S+)/g) {
1601 6         33 my ($net,$gateway,$dev) = ($1,$2,$3);
1602 6 100       33 ($net) = /^(\S+)/ if $net eq 'nexthop';
1603 6   33     32 my $vdev = $vnet{$dev}{$net} || $dev;
1604 6 100       22 $nets{$vdev} = $net unless $net eq 'default';
1605 6         34 $gws{$vdev} = $gateway;
1606             }
1607             }
1608              
1609 2         14 for my $dev (keys %ifs) {
1610 20         55 my $info = $ifs{$dev};
1611 20         102 my $running = $info =~ /[<,]UP[,>]/;
1612 20         79 my ($peer) = $info =~ /peer\s+(\d+\.\d+\.\d+\.\d+)/;
1613 20         41 for my $vdev (keys %{$vif{$dev}}) {
  20         89  
1614 18         56 my $addr = $vif{$dev}{$vdev}{addr};
1615 18         40 my $block = $vif{$dev}{$vdev}{block};
1616 18   66     140 my $net = $nets{$dev} || ($peer?"$peer/32":undef) || "$block";
1617 18   33     502 my $gw = $gws{$dev} || $peer
1618             || $self->_dhcp_gateway($dev)
1619             || $block->nth(1); # this guess is correct >95% of time
1620              
1621             # copy into hash passed to us
1622 18         589 $results{$vdev} = {
1623             dev => $dev, # otherwise, iptables will croak!!!
1624             running => $running,
1625             gw => $gw,
1626             net => $net,
1627             ip => $addr,
1628             }
1629             }
1630             }
1631              
1632 2 50       20 $self->{_interface_info_cache} = \%results if ref $self;
1633 2         70 return \%results;
1634             }
1635              
1636             sub _ip_addr_show {
1637 2     2   5 my $self = shift;
1638 2   33     6 return eval{$self->{dummy_data}{"ip_addr_show"}} || `ip addr show`;
1639             }
1640              
1641             sub _ip_route_show {
1642 2     2   7 my $self = shift;
1643 2   33     7 return eval{$self->{dummy_data}{"ip_route_show"}} || `ip route show all`;
1644             }
1645              
1646             # This subroutine is called for dhcp-assigned IP addresses to try to
1647             # get the gateway. It is used for those unusual cases in which the gateway
1648             # is NOT the first IP address in the net block.
1649             # In versions 1.05 and older, we tried to recover this information on static
1650             # interfaces by reading /etc/network/interfaces as well, but the file location was too
1651             # unpredictable across different Linux distros.
1652             sub _dhcp_gateway {
1653 12     12   32 my $self = shift;
1654 12         25 my $dev = shift;
1655 12 50       39 my $fh = $self->_open_dhclient_leases($dev) or return;
1656 0         0 my ($gw);
1657 0         0 while (<$fh>) {
1658 0         0 chomp;
1659 0 0       0 $gw = $1 if /option routers (\S+)[,;]/;
1660             }
1661 0         0 return $gw;
1662             }
1663              
1664             sub _open_dhclient_leases {
1665 12     12   26 my $self = shift;
1666 12         25 my $device = shift;
1667 12 50       27 if (my $dummy = eval{$self->{dummy_data}{"leases_$device"}}) {
  12         53  
1668 0 0       0 open my $fh,'<',\$dummy or die $!;
1669 0         0 return $fh;
1670             }
1671 12 50       41 my $leases = $self->_find_dhclient_leases($device) or return;
1672 0 0       0 open my $fh,$leases or die "Can't open $leases: $!";
1673 0         0 return $fh;
1674             }
1675              
1676             sub _find_dhclient_leases {
1677 12     12   26 my $self = shift;
1678 12         26 my $device = shift;
1679 12         39 my @locations = ('/var/lib/NetworkManager','/var/lib/dhcp','/var/lib/dhclient');
1680 12         34 for my $l (@locations) {
1681 36         989 my @matches = glob("$l/dhclient*$device.lease*");
1682 36 50       204 next unless @matches;
1683 0         0 return $matches[0];
1684             }
1685 12         127 return;
1686             }
1687              
1688              
1689              
1690             #################################### here are the routing rules ###################
1691              
1692             =head2 $bal->set_routes()
1693              
1694             This method is called by set_routes_and_firewall() to emit the rules
1695             needed to create the load balancing routing tables.
1696              
1697             =cut
1698              
1699             sub set_routes {
1700 0     0 1 0 my $self = shift;
1701 0         0 $self->_initialize_routes();
1702 0         0 $self->routing_rules();
1703 0         0 $self->local_routing_rules();
1704             }
1705              
1706             =head2 $bal->set_firewall
1707              
1708             This method is called by set_routes_and_firewall() to emit the rules
1709             needed to create the balancing firewall.
1710              
1711             =cut
1712              
1713             sub set_firewall {
1714 0     0 1 0 my $self = shift;
1715 0 0       0 $self->_save_custom_chains if $self->keep_custom_chains;
1716 0         0 $self->_initialize_firewall();
1717 0         0 $self->base_fw_rules();
1718 0 0       0 $self->_restore_custom_chains if $self->keep_custom_chains;
1719 0         0 $self->balancing_fw_rules(); # WARNING: This is a null-op in "failover" mode
1720 0         0 $self->sanity_fw_rules();
1721 0         0 $self->nat_fw_rules();
1722 0         0 $self->local_fw_rules();
1723             }
1724              
1725              
1726             =head2 $bal->enable_forwarding($boolean)
1727              
1728             =cut
1729              
1730             sub enable_forwarding {
1731 1     1 1 1093 my $self = shift;
1732 1 50       6 my $enable = $_[0] ? 1 : 0;
1733 1         7 $self->sh("echo $enable > /proc/sys/net/ipv4/ip_forward");
1734             }
1735             =head2 $bal->routing_rules()
1736              
1737             This method is called by set_routes() to emit the rules needed to
1738             create the routing rules.
1739              
1740             =cut
1741              
1742             sub routing_rules {
1743 2     2 0 11 my $self = shift;
1744             # main table
1745 2         10 $self->ip_route("add ",$self->net($_),'dev',$self->dev($_),'src',$self->ip($_)) foreach $self->service_names;
1746              
1747             # different handling of the default route depending on whether we are in
1748             # "balanced" or "failover" mode.
1749 2         22 my $mode = $self->operating_mode;
1750 2 100       15 if ($mode eq 'balanced') {
    50          
1751 1         6 $self->_create_default_multipath_route();
1752             } elsif ($mode eq 'failover') {
1753 1         8 $self->_create_default_failover_route();
1754             }
1755              
1756 2         13 $self->_create_service_routing_tables();
1757             }
1758              
1759             sub _initialize_routes {
1760 0     0   0 my $self = shift;
1761 0         0 $self->sh(<
1762             ip route flush all
1763             ip rule flush
1764             ip rule add from all lookup main pref 32766
1765             ip rule add from all lookup default pref 32767
1766             END
1767             ;
1768              
1769 0         0 $self->ip_route("flush table ",$self->table($_)) foreach $self->isp_services;
1770             }
1771              
1772             sub _create_default_multipath_route {
1773 1     1   4 my $self = shift;
1774              
1775 1         6 my @up = $self->up;
1776              
1777             # create multipath route
1778 1 50       7 if (@up > 1) { # multipath
1779 1 50       7 print STDERR "# setting multipath default gw\n" if $self->verbose;
1780             # EG
1781             # ip route add default scope global nexthop via 192.168.10.1 dev eth0 weight 1 \
1782             # nexthop via 192.168.11.1 dev eth1 weight 1
1783 1         5 my $hops = '';
1784 1         5 for my $svc (@up) {
1785 3 50       14 my $gw = $self->gw($svc) or next;
1786 3 50       11 my $dev = $self->dev($svc) or next;
1787 3 50       14 my $weight = $self->weight($svc) or next;
1788 3         146 $hops .= "nexthop via $gw dev $dev weight $weight ";
1789             }
1790 1 50       12 die "no valid gateways!" unless $hops;
1791 1         6 $self->ip_route("add default scope global $hops");
1792             }
1793              
1794             else {
1795 0 0       0 print STDERR "# setting single default route via $up[0]n" if $self->verbose;
1796 0         0 $self->ip_route("add default via",$self->gw($up[0]),'dev',$self->dev($up[0]));
1797             }
1798              
1799             }
1800              
1801             sub _create_default_failover_route {
1802 1     1   3 my $self = shift;
1803 1         6 my $preferred = $self->preferred_service;
1804 1 50       5 print STDERR "# setting single default route via $preferred\n" if $self->verbose;
1805 1         7 $self->ip_route("add default via",$self->gw($preferred),'dev',$self->dev($preferred));
1806             }
1807              
1808             =head2 $service = $bal->preferred_service
1809              
1810             Returns the preferred service, which is the currently running service with the highest weight. Used for
1811             failover mode.
1812              
1813             =cut
1814              
1815             sub preferred_service {
1816 1     1 1 3 my $self = shift;
1817 1         8 my @up = sort { $self->weight($b) <=> $self->weight($a) } $self->up;
  1         10  
1818 1         7 return $up[0];
1819             }
1820              
1821             sub _create_service_routing_tables {
1822 2     2   7 my $self = shift;
1823              
1824 2         9 for my $svc ($self->isp_services) {
1825 5 50       20 print STDERR "# creating routing table for $svc\n" if $self->verbose;
1826 5         23 $self->ip_route('add table',$self->table($svc),'default dev',$self->dev($svc),'via',$self->gw($svc));
1827 5         18 for my $s ($self->service_names) {
1828 36         120 $self->ip_route('add table',$self->table($svc),$self->net($s),'dev',$self->dev($s),'src',$self->ip($s));
1829             }
1830 5         24 $self->ip_rule('add from',$self->ip($svc),'table',$self->table($svc));
1831 5         23 $self->ip_rule('add fwmark',$self->fwmark($svc),'table',$self->table($svc));
1832             }
1833             }
1834              
1835             =head2 $bal->local_routing_rules()
1836              
1837             This method is called by set_routes() to process the fules and emit
1838             the commands contained in the customized route files located in
1839             $ETC_DIR/balance/routes.
1840              
1841             =cut
1842              
1843             sub local_routing_rules {
1844 1     1 1 12 my $self = shift;
1845 1         7 my $dir = $self->rules_directory;
1846 1         425 my @files = sort glob("$dir/routes/*");
1847 1         11 $self->_execute_rules_files(@files);
1848             }
1849              
1850             =head2 $bal->local_fw_rules()
1851              
1852             This method is called by set_firewall() to process the fules and emit
1853             the commands contained in the customized route files located in
1854             $ETC_DIR/balance/firewall.
1855              
1856             =cut
1857              
1858             sub local_fw_rules {
1859 1     1 1 1107 my $self = shift;
1860 1         7 my $dir = $self->rules_directory;
1861 1         519 my @files = sort glob("$dir/firewall/*");
1862 1         11 $self->_execute_rules_files(@files);
1863             }
1864              
1865             =head2 $bal->pre_run_rules()
1866              
1867             This method is called by set_routes_and_firewall() to process the fules and emit
1868             the commands contained in the customized route files located in
1869             $ETC_DIR/balance/pre-run.
1870              
1871             =cut
1872              
1873             sub pre_run_rules {
1874 0     0 1 0 my $self = shift;
1875 0         0 my $dir = $self->rules_directory;
1876 0         0 my @files = sort glob("$dir/pre-run/*");
1877 0         0 $self->_execute_rules_files(@files);
1878             }
1879              
1880             =head2 $bal->post_run_rules()
1881              
1882             This method is called by set__routes_andfirewall() to process the
1883             fules and emit the commands contained in the customized route files
1884             located in $ETC_DIR/balance/post-run.
1885              
1886             =cut
1887              
1888             sub post_run_rules {
1889 0     0 1 0 my $self = shift;
1890 0         0 my $dir = $self->rules_directory;
1891 0         0 my @files = sort glob("$dir/post-run/*");
1892 0         0 $self->_execute_rules_files(@files);
1893             }
1894              
1895              
1896             sub _execute_rules_files {
1897 2     2   8 my $self = shift;
1898 2         11 my @files = @_;
1899              
1900 2         11 for my $f (@files) {
1901 5 50       29 next if $f =~ /~$/; # ignore emacs backup files
1902 5 50       22 next if $f =~ /^#/; # ignore autosave files
1903 5 50       21 print STDERR "# executing contents of $f\n" if $self->verbose;
1904 5         34 $self->sh("## Including rules from $f ##\n");
1905 5 50 33     77 next if $f =~ /(~|\.bak)$/ or $f=~/^#/;
1906              
1907 5 100       37 if ($f =~ /\.pl$/) { # perl script
1908 3         11 our $B = $self;
1909 3         1946 do $f;
1910 3 50       111 warn $@ if $@;
1911             } else {
1912 2 50       94 open my $fh,$f or die "Couldn't open $f: $!";
1913 2         126 $self->sh($_) while <$fh>;
1914 2         25 close $fh;
1915             }
1916 5         31 $self->sh("## Finished $f ##\n");
1917             }
1918             }
1919              
1920             #########################
1921             # firewall rules
1922             #########################
1923              
1924             sub _initialize_firewall {
1925 0     0   0 my $self = shift;
1926 0         0 $self->sh(<
1927             iptables -F
1928             iptables -X
1929             iptables -t nat -F
1930             iptables -t nat -X
1931             iptables -t mangle -F
1932             iptables -t mangle -X
1933             END
1934             }
1935              
1936             =head2 $bal->base_fw_rules()
1937              
1938             This method is called by set_firewall() to set up basic firewall
1939             rules, including default rules and reporting.
1940              
1941             =cut
1942              
1943             sub base_fw_rules {
1944 0     0 1 0 my $self = shift;
1945 0         0 $self->sh(<
1946             iptables -P INPUT DROP
1947             iptables -P OUTPUT DROP
1948             iptables -P FORWARD DROP
1949              
1950             iptables -N REJECTPERM
1951             iptables -A REJECTPERM -j LOG -m limit --limit 1/minute --log-level 4 --log-prefix "REJECTED: "
1952             iptables -A REJECTPERM -j REJECT --reject-with icmp-net-unreachable
1953              
1954             iptables -N DROPGEN
1955             iptables -A DROPGEN -j LOG -m limit --limit 1/minute --log-level 4 --log-prefix "GENERAL: "
1956             iptables -A DROPGEN -j DROP
1957              
1958             iptables -N DROPINVAL
1959             iptables -A DROPINVAL -j LOG -m limit --limit 1/minute --log-level 4 --log-prefix "INVALID: "
1960             iptables -A DROPINVAL -j DROP
1961              
1962             iptables -N DROPPERM
1963             iptables -A DROPPERM -j LOG -m limit --limit 1/minute --log-level 4 --log-prefix "ACCESS-DENIED: "
1964             iptables -A DROPPERM -j DROP
1965              
1966             iptables -N DROPSPOOF
1967             iptables -A DROPSPOOF -j LOG -m limit --limit 1/minute --log-level 4 --log-prefix "DROP-SPOOF: "
1968             iptables -A DROPSPOOF -j DROP
1969              
1970             iptables -N DROPFLOOD
1971             iptables -A DROPFLOOD -m limit --limit 1/minute -j LOG --log-level 4 --log-prefix "DROP-FLOOD: "
1972             iptables -A DROPFLOOD -j DROP
1973              
1974             iptables -N DEBUG
1975             iptables -A DEBUG -j LOG --log-level 3 --log-prefix "DEBUG: "
1976             END
1977             ;
1978 0 0       0 if ($self->iptables_verbose) {
1979 0 0       0 print STDERR " #Setting up debugging logging\n" if $self->verbose;
1980 0         0 $self->sh(<
1981             iptables -A INPUT -j LOG --log-prefix "INPUT: "
1982             iptables -A OUTPUT -j LOG --log-prefix "OUTPUT: "
1983             iptables -A FORWARD -j LOG --log-prefix "FORWARD: "
1984             iptables -t nat -A INPUT -j LOG --log-prefix "nat INPUT: "
1985             iptables -t nat -A OUTPUT -j LOG --log-prefix "nat OUTPUT: "
1986             iptables -t nat -A FORWARD -j LOG --log-prefix "nat FORWARD: "
1987             iptables -t nat -A PREROUTING -j LOG --log-prefix "nat PREROUTING: "
1988             iptables -t nat -A POSTROUTING -j LOG --log-prefix "nat POSTROUTING: "
1989             iptables -t mangle -A INPUT -j LOG --log-prefix "mangle INPUT: "
1990             iptables -t mangle -A OUTPUT -j LOG --log-prefix "mangle OUTPUT: "
1991             iptables -t mangle -A FORWARD -j LOG --log-prefix "mangle FORWARD: "
1992             iptables -t mangle -A PREROUTING -j LOG --log-prefix "mangle PRE: "
1993             END
1994             ;
1995             }
1996             }
1997              
1998             =head2 $bal->balancing_fw_rules()
1999              
2000             This method is called by set_firewall() to set up the mangle/fwmark
2001             rules for balancing outgoing connections.
2002              
2003             =cut
2004              
2005             sub balancing_fw_rules {
2006 3     3 1 3095 my $self = shift;
2007              
2008 3 100       17 return unless $self->operating_mode eq 'balanced';
2009              
2010 2 50       10 print STDERR "# balancing FW rules\n" if $self->verbose;
2011              
2012 2         11 for my $svc ($self->isp_services) {
2013 6         21 my $table = $self->mark_table($svc);
2014 6         23 my $mark = $self->fwmark($svc);
2015 6 50 33     34 next unless defined $mark && defined $table;
2016 6         35 $self->sh(<
2017             iptables -t mangle -N $table
2018             iptables -t mangle -A $table -j MARK --set-mark $mark
2019             iptables -t mangle -A $table -j CONNMARK --save-mark
2020             END
2021             }
2022              
2023 2         13 my @up = $self->up;
2024              
2025             # packets from LAN
2026 2         9 for my $lan ($self->lan_services) {
2027 8         43 my $landev = $self->dev($lan);
2028 8         27 my $src = $self->net($lan);
2029            
2030 8 100       30 if (@up > 1) {
2031 4 50       12 print STDERR "# creating balanced mangling rules\n" if $self->verbose;
2032 4         11 my $count = @up;
2033 4         16 my $probabilities = $self->_weight_to_probability(\@up);
2034 4         25 for my $svc (sort {$probabilities->{$b} <=> $probabilities->{$a}} @up) {
  8         33  
2035 12         40 my $table = $self->mark_table($svc);
2036 12         29 my $probability = $probabilities->{$svc};
2037 12         111 $self->iptables("-t mangle -A PREROUTING -i $landev -s $src -m conntrack --ctstate NEW -m statistic --mode random --probability $probability -j $table");
2038             }
2039             }
2040              
2041             else {
2042 4         12 my $svc = $up[0];
2043 4 50       13 print STDERR "# forcing all traffic through $svc\n" if $self->verbose;
2044 4         14 my $table = $self->mark_table($svc);
2045 4         26 $self->iptables("-t mangle -A PREROUTING -i $landev -s $src -m conntrack --ctstate NEW -j $table");
2046             }
2047              
2048 8         39 $self->iptables("-t mangle -A PREROUTING -i $landev -s $src -m conntrack --ctstate ESTABLISHED,RELATED -j CONNMARK --restore-mark");
2049             }
2050              
2051             # inbound packets from WAN
2052 2         10 for my $wan ($self->isp_services) {
2053 6         27 my $dev = $self->dev($wan);
2054 6         22 my $table = $self->mark_table($wan);
2055 6         19 my $src = $self->net($wan);
2056 6         33 $self->iptables("-t mangle -A PREROUTING -i $dev -m conntrack --ctstate NEW -j $table");
2057 6         27 $self->iptables("-t mangle -A PREROUTING -i $dev -m conntrack --ctstate ESTABLISHED,RELATED -j CONNMARK --restore-mark");
2058             }
2059              
2060             }
2061              
2062             sub _weight_to_probability {
2063 4     4   9 my $self = shift;
2064 4         10 my $svcs = shift;
2065              
2066             # first turn weights into proportions of the total
2067 4         11 my %weights = map {$_ => $self->weight($_)} @$svcs;
  12         32  
2068 4         13 my $total = 0;
2069 4         25 $total += $_ foreach (values %weights);
2070 4         13 my %proportions = map {$_ => $weights{$_}/$total} keys %weights;
  12         54  
2071              
2072             # now turn them into probabilities
2073 4         148 my %probabilities;
2074              
2075 4         13 my $last = 0;
2076 4 0       25 for (sort {$proportions{$a}<=>$proportions{$b} || $a cmp $b} keys %proportions) {
  10         45  
2077 12         100 my $threshold = $proportions{$_}/(1-$last);
2078 12         23 $last += $proportions{$_};
2079 12         38 $probabilities{$_} = $threshold;
2080             }
2081 4         784 return \%probabilities;
2082             }
2083              
2084             =head2 $bal->sanity_fw_rules()
2085              
2086             This is called by set_firewall() to create a sensible series of
2087             firewall rules that seeks to prevent spoofing, flooding, and other
2088             antisocial behavior. It also enables UDP-based network time and domain
2089             name service.
2090              
2091             =cut
2092              
2093             sub sanity_fw_rules {
2094 1     1 1 42 my $self = shift;
2095              
2096             # if any of the devices are ppp, then we clamp the mss
2097 1         6 my @ppp_devices = grep {/ppp\d+/} map {$self->dev($_)} $self->isp_services;
  3         84  
  3         10  
2098             $self->iptables("-t mangle -A POSTROUTING -o $_ -p tcp --tcp-flags SYN,RST SYN -j TCPMSS --clamp-mss-to-pmtu")
2099 1         11 foreach @ppp_devices;
2100              
2101             # lo is ok
2102 1         8 $self->iptables(['-A INPUT -i lo -j ACCEPT',
2103             '-A OUTPUT -o lo -j ACCEPT',
2104             '-A INPUT -d 127.0.0.0/8 -j DROPPERM']);
2105              
2106             # accept continuing foreign traffic
2107 1         9 $self->iptables(['-A INPUT -m state --state ESTABLISHED,RELATED -j ACCEPT',
2108             '-A FORWARD -m state --state ESTABLISHED,RELATED -j ACCEPT',
2109             '-A INPUT -p tcp --tcp-flags SYN,ACK ACK -j ACCEPT',
2110             '-A FORWARD -p tcp --tcp-flags SYN,ACK ACK -j ACCEPT',
2111             '-A FORWARD -p tcp --tcp-flags SYN,ACK,FIN,RST RST -j ACCEPT'
2112             ]);
2113              
2114             # we allow ICMP echo, but establish flood limits
2115 1         8 $self->iptables(['-A INPUT -p icmp --icmp-type echo-request -m limit --limit 1/s -j ACCEPT',
2116             '-A INPUT -p icmp --icmp-type echo-request -j DROPFLOOD']);
2117              
2118             # allowable traffic patterns within the LAN services
2119 1         7 for my $lan ($self->lan_services) {
2120 4         14 my $dev = $self->dev($lan);
2121 4         16 my $net = $self->net($lan);
2122              
2123             # allow unlimited traffic from internal network using legit address
2124 4         160 $self->iptables("-A INPUT -i $dev -s $net -j ACCEPT");
2125              
2126             # allow locally-generated output to the LAN on the LANDEV
2127 4         30 $self->iptables("-A OUTPUT -o $dev -d $net -j ACCEPT");
2128              
2129             # and allow broadcasts to the lan
2130 4         27 $self->iptables("-A OUTPUT -o $dev -d 255.255.255.255/32 -j ACCEPT");
2131              
2132             # any outgoing udp packet is fine with me
2133 4         16 $self->iptables("-A OUTPUT -p udp -s $net -j ACCEPT");
2134             }
2135              
2136             # allow appropriate outgoing traffic via the ISPs
2137             # NOTE: we use svc_config here so that we allow outgoing traffic
2138             # on interfaces that might be down
2139             # for my $svc ($self->isp_services) {
2140             # my $ispdev = $self->dev($svc);
2141             # $self->iptables("-A OUTPUT -o $ispdev -j ACCEPT");
2142             # }
2143 1         5 for my $svc (keys %{$self->{svc_config}}) {
  1         9  
2144 8 100       35 next unless $self->{svc_config}{$svc}{role} eq 'isp';
2145 4         10 my $ispdev = $self->{svc_config}{$svc}{dev};
2146 4         20 $self->iptables("-A OUTPUT -o $ispdev -j ACCEPT");
2147             }
2148              
2149             # forwarding rules
2150 1         8 $self->_lan_wan_forwarding_rules();
2151 1         8 $self->_lan_lan_forwarding_rules();
2152              
2153             # anything else is bizarre and should be dropped
2154 1         5 $self->iptables('-A OUTPUT -j DROPSPOOF');
2155             }
2156              
2157             # establish expected traffic patterns between lan(s) and isp interfaces
2158             sub _lan_wan_forwarding_rules {
2159 1     1   4 my $self = shift;
2160              
2161 1         7 for my $lan ($self->lan_services) {
2162 4         21 my $dev = $self->dev($lan);
2163 4         13 my $net = $self->net($lan);
2164              
2165             # lan/wan forwarding
2166             # allow lan/wan forwarding
2167 4         20 for my $svc ($self->isp_services) {
2168 12         43 my $ispdev = $self->dev($svc);
2169 12 50       38 my $target = $self->_allow_forwarding($lan,$svc) ? 'ACCEPT' : 'REJECTPERM';
2170 12         119 $self->iptables("-A FORWARD -i $dev -o $ispdev -s $net -j $target");
2171             }
2172             }
2173             }
2174              
2175             # Allow forwarding between lans
2176             sub _lan_lan_forwarding_rules {
2177 1     1   3 my $self = shift;
2178              
2179             # This generates a very long list of rules if you have multiple lan services, but I think
2180             # it is the most general way to get this right.
2181 1         5 my @lans = $self->lan_services;
2182 1         9 for (my $i=0;$i<@lans;$i++) {
2183 4         18 for (my $j=0;$j<@lans;$j++) {
2184 16 100       63 next if $i == $j;
2185 12         31 my $lan1 = $lans[$i];
2186 12         23 my $lan2 = $lans[$j];
2187 12 50       37 my $target = $self->_allow_forwarding($lan1,$lan2) ? 'ACCEPT' : 'REJECTPERM';
2188 12         108 $self->iptables('-A FORWARD','-i',$self->dev($lan1),'-o',$self->dev($lan2),'-s',$self->net($lan1),'-d',$self->net($lan2),"-j $target");
2189             }
2190             }
2191             }
2192              
2193             sub _allow_forwarding {
2194 24     24   44 my $self = shift;
2195 24         76 my ($net_a,$net_b) = @_;
2196 24         60 my $forward = $self->_forwarding_groups();
2197 24         103 my $key = join ',',sort ($net_a,$net_b);
2198 24         92 return $forward->{$key};
2199             }
2200              
2201             # this returns a hashref of service pairs that are allowed to forward packets.
2202             # the keys are service name pairs, in alphabetic order, separated by a comma.
2203             sub _forwarding_groups {
2204 24     24   46 my $self = shift;
2205              
2206             # _forwarding_groups is the processed and normalized version of forwarding_groups
2207 24 100       85 return $self->{_forwarding_groups} if exists $self->{_forwarding_groups};
2208              
2209 1         4 my %allowed_pairs;
2210 1         5 my $fgs = $self->{forwarding_groups};
2211 1 50       5 unless (@$fgs) {
2212 1         6 $fgs = [[':isp',':lan']];
2213             }
2214              
2215 1         5 for my $fg (@$fgs) {
2216             my @services = map {
2217 1 50       3 /^:isp$/ ? $self->isp_services
  2 100       29  
2218             : /^:lan$/ ? $self->lan_services
2219             : $_
2220             } @$fg;
2221              
2222 1         10 for (my $i=0;$i<@services-1;$i++) {
2223 6         20 for (my $j=$i;$j<@services;$j++) {
2224 27         83 my $key = join ',',sort ($services[$i],$services[$j]);
2225 27         126 $allowed_pairs{$key}++;
2226             }
2227             }
2228             }
2229 1         6 return $self->{_forwarding_groups} = \%allowed_pairs;
2230             }
2231              
2232             =head2 $bal->nat_fw_rules()
2233              
2234             This is called by set_firewall() to set up basic NAT rules for lan traffic over ISP
2235              
2236             =cut
2237              
2238             sub nat_fw_rules {
2239 0     0 1   my $self = shift;
2240 0 0         return unless $self->lan_services;
2241             $self->iptables('-t nat -A POSTROUTING -o',$self->dev($_),'-j MASQUERADE')
2242 0           foreach $self->isp_services;
2243             }
2244              
2245             =head2 $bal->start_lsm()
2246              
2247             Start an lsm process.
2248              
2249             =cut
2250              
2251             sub start_lsm {
2252 0     0 1   my $self = shift;
2253 0           my $lsm = Net::ISP::Balance::ConfigData->config('lsm_path');
2254 0           my $lsm_conf = $self->lsm_conf_file;
2255 0           system "$lsm $lsm_conf /var/run/lsm.pid";
2256             }
2257              
2258             =head2 $bal->signal_lsm($signal)
2259              
2260             Send a signal to a running LSM and return true if successfully
2261             signalled. The signal can be numeric (e.g. 9) or a string ('TERM').
2262              
2263             =cut
2264              
2265             sub signal_lsm {
2266 0     0 1   my $self = shift;
2267 0           my $signal = shift;
2268 0   0       $signal ||= 0;
2269 0           my $pid;
2270 0 0         open my $f,'/var/run/lsm.pid' or return;
2271 0           chomp($pid = <$f>);
2272 0           close $f;
2273 0 0         return unless $pid =~ /^\d+$/;
2274 0           return kill($signal=>$pid);
2275             }
2276              
2277              
2278             1;
2279              
2280             =head1 BUGS
2281              
2282             Please report bugs to GitHub: https://github.com/lstein/Net-ISP-Balance.
2283              
2284             =head1 AUTHOR
2285              
2286             Copyright 2014, Lincoln D. Stein (lincoln.stein@gmail.com)
2287              
2288             Senior Principal Investigator,
2289             Ontario Institute for Cancer Research
2290              
2291             =head1 LICENSE
2292              
2293             This package is distributed under the terms of the Perl Artistic
2294             License 2.0. See http://www.perlfoundation.org/artistic_license_2_0.
2295              
2296             =cut
2297              
2298             __END__