#!/usr/bin/perl
# RatRoute Version 0.2
# vim: ts=4 ft=perl sw=4 ai:
# (c) Copyright Roelf Diedericks <rodent at rodent dot za dot net>
#
# This tools makes configuring loadbalanced routes using iproute2 easier
# than trying to do it by hand. It reads a configuration file, from 
# /etc/ratroute.conf
#
# It receives interface up/down events by being symlinked into /etc/ppp/ip-up.d/
# and /etc/ppp/ip-down.d on debian like systems.
#
# As soon as an up/down event is detected, it automatically adjusts the kernel
# routing tables to effect the desired routing configuration.
#
#	ChangeLog:
#		0.1	- Initial Version
#		0.2 - Documentation and further refinements
#				- single process locking implemented to prevent contention
#				  for routing table access
#

use strict;
use FindBin qw($Script);
use Sys::Hostname;
use Fcntl qw(:DEFAULT :flock);
use LockFile::Simple;

#globals required everywhere
use vars qw(@interfaces $ifname $ifreal $ifevent $linkname $iplocal $ipremote $ping_host @crules %balanced_weights $weigh_state_file $debug $lockmgr $lock);


# ___________________________
# initialization
# ---------------------------
$debug=1;
my $thishost = hostname;
my $configfile = "/etc/ratroute.conf";
my $iproute2 = "/sbin/ip";
my $route_util= "/sbin/route";
my $rt_tables = "/etc/iproute2/rt_tables";
my $weight_state_file = "/var/state/ratroute.weights";
my %balanced_weights=();

$lockmgr = LockFile::Simple->make( -max => 30, -delay => 1, -autoclean => 1, 
								-hold => 20, -stale =>1, wfunc =>\&logmsg );
my $lock;

# __________________________________________________
# log a message to syslog, and /var/log/ratroute.log
# --------------------------------------------------
sub logmsg {
	my $msg=join(" ",@_);
	`logger -t \"$Script\" \"$msg\"`;
	print "\e[32;1m[$Script\@$thishost]:\e[36;1m $msg\e[0m\n";
}
# ____________________________________
# routecmd: execute iproute commands
# ------------------------------------
sub routecmd {
	my $cmd=shift;
	logmsg("$iproute2 $cmd") if $debug;
	my @res=`$iproute2 $cmd`;
	logmsg("result: " . join("\n",@res) ) if ($debug && $#res ne -1);
	return @res;
}



sub script_lock {
	$lock=$lockmgr->lock("/var/lock/ratroute");
}

sub script_unlock {
	$lockmgr->unlock("/var/lock/ratroute");
}

# _____________________________
# fatal: abort with fatal error
# -----------------------------
sub fatal{
	my $msg=join(" ",@_);
	`logger -t \"$Script\" \"fatal:$msg\"`;
	print "\e[32;1m[$Script\@$thishost]:\e[31;1m fatal:$msg\e[0m\n";
	script_unlock();
	exit;
}


# _________________________________________________
# load_balanced_weights: load balanced route states
# -------------------------------------------------
sub load_balanced_weights {
	open DB, "<$weight_state_file" or return;
    %balanced_weights= map /(.*)\t(.*)/, <DB>;
    close DB;
}

# _________________________________________________
# save_balanced_weights: save the weights
# -------------------------------------------------
sub save_balanced_weights{
	 open DB, ">$weight_state_file" or fatal("create: $!");
	 print DB map "$_\t$balanced_weights{$_}\n",
	 keys %balanced_weights;
	 close DB;
}

#__________________________________________________
#	update_rt_tables: 
#	adds a table to rt_tables, if required
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub check_rt_tables {
	my $table_name=shift;
	open(RT_TABLES,"<$rt_tables");
	$/="\n";
	my @tables=sort(grep(!/^#/,<RT_TABLES>));
	close(RT_TABLES);

	my @rt=grep(/^[0-9]+[\s+]$table_name\t.*$/,@tables);
	logmsg("rt_entri: $#rt $table_name");
	if ($#rt==-1) {
		#find an unumbered entry
		my %used={};
		my $max=0;
		foreach my $ta (@tables) {
			$ta=~m/^([0-9]+)([\s+])(.+)$/;
			$used{$1}=1 if (defined($1));
		}
		for (my $i=0; $i<=255; $i++) {
			if (!$used{$i}) {
				$max=$i; 
				$i=2500;
			} else {
				$max=2500;
			}
		}
		fatal("out of rt_tables entries") if ($max>255);
		logmsg("adding new rt_tables entry: $max=$table_name");
		#add it
		open(RT_TABLES,">>$rt_tables");
		print RT_TABLES "$max\t$table_name\t#inserted by $Script\n";
		close(RT_TABLES);
		return $max;
	}
	return $rt[0];

}

#___________________________________________________
#	add_interface_route
#	adds a route that gets us to the subnet/peer
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

#__________________________________________________
#	add_reverse_route
#	adds a reverse route for this interface so
#	that traffic going out, can get back in again
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub add_reverse_route {
	my $link=shift;
	my $linkname_rev="$linkname"."_reverse";
	if (!grep(/^.*lookup $linkname_rev $/,@crules)) {
		logmsg("adding reverse route rule for $iplocal $linkname_rev");
		routecmd("rule add prio $link->{priority} from $iplocal table $linkname_rev");
	}
	my @routes=routecmd("route ls table $linkname_rev");
	routecmd("route flush table $linkname_rev") if ($#routes!=-1);
		
	routecmd("route add default via $ipremote dev $ifreal src $iplocal table $linkname_rev");
	routecmd("route append prohibit default table $linkname_rev metric 1");
}

#__________________________________________________
#	del_reverse_route
#	deletes a previous reverse route
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub del_reverse_route {
	my $link=shift;
	print @crules;
	my $linkname_rev="$linkname"."_reverse";
	if (grep(/^.*lookup $linkname_rev $/,@crules)) {
		logmsg("deleting reverse route rule for $iplocal $linkname_rev");
		routecmd("rule del prio $link->{priority} from $iplocal table $linkname_rev");
	}
	my @routes=routecmd("route ls table $linkname_rev");
	routecmd("route flush table $linkname_rev") if ($#routes!=-1);
}

# ______________________________________________
# add_custom_routes: add custom routes for iface
# ----------------------------------------------
sub add_custom_routes {
	my $link=shift;
	
	if (!grep(/^.*lookup $linkname $/,@crules)) {
		logmsg("adding custom route rules for $iplocal $linkname");
		routecmd("rule add prio $link->{priority} table $linkname");
	}

	my $routes=$link->{routes};
	my @routes=@$routes;

	foreach my $route (@routes) {
		#logmsg("route: $route");
		$route=~s/\n//;
		routecmd("route add $route via $iplocal table $linkname");
	}
}

# _____________________________________
# del_custom_routes: drop custom routes
# -------------------------------------
sub del_custom_routes {
	my $link=shift;
	routecmd("route flush table $linkname");
	if (grep(/^.*lookup $linkname $/,@crules)) {
		logmsg("deleting custom route rule for $linkname");
		routecmd("rule del prio $link->{priority} table $linkname");
	}

}

# ____________________________________
# link_up: event for interface up
# ------------------------------------
sub link_up {
	my $link=shift;
	add_reverse_route($link);
	add_custom_routes($link);
	if ($link->{gateway_of_last_resort}) {
		if (!$link->{balance_last_resort}) {
			#just a normal defaultgateway
			logmsg("default gateway via $ipremote on $linkname");
			routecmd("route add default via $ipremote");
		} else {
			add_balanced_gateway($link);
		}
	}
}

# ____________________________________
# link_down: event for iface down
# ------------------------------------
sub link_down {
	my $link=shift;
	del_reverse_route($link);
	del_custom_routes($link);
	
	if ($link->{gateway_of_last_resort}) {
		if (!$link->{balance_last_resort}) {
			#just a normal defaultgateway
			logmsg("DELETE default gateway via $ipremote on $linkname");
			routecmd("route del default via $ipremote");
		} else {
			del_balanced_gateway($link);
		}
	}

}

# ____________________________________________________________________
# actively_balanced_iface: 
#	returns true if iface is currently balanced
# --------------------------------------------------------------------
sub actively_balanced_iface {
	my $i=shift;
	my @ifs=`route show table balancedpool`;
	logmsg("currently balanced:" .join("--",@ifs) );
	return 0 if (!grep(/$i/,@ifs));
	logmsg("$i is currently balanced.");
	return 1;
} 

sub active_iface {
	my $i=shift;
	#handle ethernet aliases
	$i=~m/(eth.):/;
	$i=$1 if ($1 ne "");

	open(F,"</proc/net/dev");
	my @iflist=<F>;
	return 0 if (!grep(/$i\:/,@iflist));
	return 1;
}
	

# _________________________________________________
# add_balanced_gateway: 
#	add a balanced gateway to the balanced pool
#	this is accomplished by rewriting the balanced
# 	rule from the state information saved
#	and adding the new rule to it
# -------------------------------------------------
sub add_balanced_gateway {
	my $link=shift;
	
	check_rt_tables("balancedpool");
	my @others;
	
	my @rules=`ip rule ls`;
	
	#ensure the main (local) table is before the balancedpool
	#otherwise local subnet routes disappears
	if (!grep(/^51:\tfrom all lookup main $/,@rules)) {
		logmsg("readjusting main rule");
		routecmd("rule add prio 51 table main");
	}

	if (!grep(/^52:\tfrom all lookup balancedpool $/,@rules)) {
		logmsg("adding balancedpool rule");
		routecmd("rule add prio 52 table balancedpool");
	}

	logmsg("Adding BALANCED default gateway $ipremote on $linkname");

	load_balanced_weights();
	my $alternates="";
	my %dupes;
	$dupes{$ifname}=1;
	foreach my $key (keys %balanced_weights) {
		if (!active_iface($key) || $dupes{$key}) {
			delete $balanced_weights{$key};
		} else {
			$dupes{$key}=1;
			my $alt_ifreal=$key;
			my ($alt_weight,$alt_ipremote)=split(/ /,$balanced_weights{$key});

			#handle eth0:x aliases
			$alt_ifreal=~m/(eth.):/;
			$alt_ifreal=$1 if ($1 ne "");
			$alternates.=" nexthop via $alt_ipremote dev $alt_ifreal weight $alt_weight" unless ($key eq $ipremote);
		}
	}
	$balanced_weights{$ifname}="$link->{balance_weight} $link->{ipremote}";
	save_balanced_weights();

	routecmd("route flush table balancedpool");
	routecmd("route add default table balancedpool nexthop via $ipremote dev $ifreal weight $link->{balance_weight} $alternates");
}



# _________________________________________________
# del_balanced_gateway: 
#	undoes everything add_balanced_gateway did.
#	we (stupidly) assume that it has been added before
# -------------------------------------------------
sub del_balanced_gateway {
	my $link=shift;
	
	my @others;
	
	my @rules=`ip rule ls`;
	
	logmsg("Removing BALANCED default gateway $ipremote on $linkname");

	load_balanced_weights();
	my $alternates="";
	my %dupes;
	$dupes{$ifname}=1;
	foreach my $key (keys %balanced_weights) {
		if (!active_iface($key) || $dupes{$key} || $key eq $ifname) {
			delete $balanced_weights{$key};
		} else {
			$dupes{$key}=1;
			my $alt_ifreal=$key;
			my ($alt_weight,$alt_ipremote)=split(/ /,$balanced_weights{$key});

			#handle eth0:x aliases
			$alt_ifreal=~m/(eth.):/;
			$alt_ifreal=$1 if ($1 ne "");
			$alternates.=" nexthop via $alt_ipremote dev $alt_ifreal weight $alt_weight" unless ($key eq $ipremote);
		}
	}
	save_balanced_weights();
	routecmd("route flush table balancedpool");
	routecmd("route add default table balancedpool $alternates");
}

#sub add_peer_route {
#	my $link=shift;  
#	my @routes=routecmd("$iproute2 route ls table ppp_peers");
#	if (!grep(/^.*from $iplocal lookup $linkname/,@crules)) {
#		logmsg("adding reverse route rule for $iplocal $linkname");
#		`$iproute2 rule add prio $link->{priority} from $iplocal table $linkname`;
#	}
#
#}


sub manage_interface {
	my $link=shift;

	#ensure reverse-path filtering is disabled
	`echo 0 > /proc/sys/net/ipv4/conf/$link->{ifreal}/rp_filter`;

	check_rt_tables($link->{linkname});
	check_rt_tables("$link->{linkname}_reverse");

	#check that the link priority is ok
	if (! ($link->{priority}>=2 && $link->{priority}<=50) ) {
		fatal("Invalid 'priority $link->{priority}' in config file for $linkname");
	}

	#get current rule list
	@crules=`ip rule ls`;

	#ensure the ppp_peers table is correct
	#if (!grep(/^.* lookup ppp_peers/,@crules)) {
	#	logmsg("creating peer rule");
	#	routecmd("rule add prio 1 table ppp_peers");
	#}
	
	link_up($link) if ($ifevent eq "UP");
	link_down($link) if ($ifevent eq "DOWN");

	#flush routing cache
	routecmd("route flush cache");
	logmsg("all done.");
}

#________________________________________________________
# main
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do "$configfile" or fatal("unable to open $configfile -- $@");

script_lock();
main();
script_unlock();

sub main {
	undef($ifreal);

	( defined($ENV{IFNAME}) || defined($ENV{dev}) || defined($ENV{IFACE}) ) 
		or fatal("called without proper pppd/openvpn environment variables");
	
	#figure out how we're run (interface up, or down mode?, and from where?)

	#pppd
	if ( defined($ENV{IFNAME}) ) {
		$ifname = $ENV{IFNAME};
		$linkname = $ENV{LINKNAME};
		$ifevent= ($ENV{CONNECT_TIME} eq "") ? "UP" : "DOWN";
		$iplocal=$ENV{IPLOCAL};
		$ipremote=$ENV{IPREMOTE};
		logmsg ("ppp event for $ifname");
	}

	#openvpn
	if ( defined($ENV{dev}) && defined($ENV{script_type}) ) {
		$ifname = $ENV{dev};
		$linkname = $ENV{linkname};
		$ifevent = ($ENV{script_type} eq "up") ? "UP" : "DOWN";
		$iplocal = $ENV{ifconfig_local};
		$ipremote = $ENV{ifconfig_remote};
		logmsg ("openvpn event for $ifname ($linkname)");
		#`set >/tmp/env`; #debug 
	}
	
	#from /etc/networks/if-up.d and /etc/networks/if-down.d
	if ( defined($ENV{IFACE}) ) {
		$ifname = $ENV{IFACE};
		$linkname = $ENV{IF_LINKNAME};
		$ifevent = ($ENV{MODE} eq "start") ? "UP" : "DOWN";
		$iplocal = $ENV{IF_ADDRESS};
		$ipremote = $ENV{IF_BALANCED_GATEWAY};
		$ping_host = $ENV{IF_PING_HOST};

		if ($ping_host ne "" && $ifevent eq "UP") {
			 logmsg("PINGHOST: adding static route for $ping_host via $ifname");
			 my @res=`$route_util add $ping_host dev $ifname`;
			 logmsg("pinghost route result:" . join("\n",@res) ) if ($debug && $#res ne -1);
		}

		#handle eth0:x device aliases, since iproute2 doesn't dig that
		$ifname=~m/(eth.):/;
		$ifreal=$1 if ($1 ne "");
		logmsg ("LAN event for $ifname ifreal:$ifreal linkname:$linkname event:$ifevent iplocal:$iplocal <---> gw:$ipremote pinghost:$ping_host ");
		#`set >/tmp/env_ifupdown`; #for debug
		#return;
	}
	$ifreal=$ifname if (!$ifreal);
	logmsg("interface $ifname ifreal:$ifreal linkname: $linkname $iplocal\<--\>$ipremote");

	#check if we manage this interface
	my $managed=0;
	foreach my $interface (@interfaces) 
	{
		if ($linkname eq $interface->{linkname}) 
		{
			$interface->{ifname}=$ifname;
			$interface->{ifreal}=$ifreal;
			$interface->{iplocal}=$iplocal;
			$interface->{ipremote}=$ipremote;
			$interface->{ifevent}=$ifevent;
			$interface->{ping_host}=$ping_host;
			
			if ($ipremote eq "") {
				logmsg("if$ifevent for managed interface $ifname ($linkname) without default gateway. Aborting");
			}


			logmsg("\"$ifevent\" event for managed interface $ifname");
			manage_interface($interface);
			$managed=1;
			
		}
	}
	logmsg("$ifname is unmanaged. no action") unless $managed;
}


