#!/usr/bin/perl

package iptdaemon;

use strict;
use threads;
use feature qw(switch);
use threads::shared;
use Thread::Queue::Duplex;
use Array::Utils qw(:all);
use List::Util qw(first shuffle);
use Data::GUID;
use Net::Server::PreFork;
use POSIX qw(setsid);
use Sys::Syslog qw(:DEFAULT :standard :macros setlogsock);
use POSIX ":sys_wait_h";
use vars qw(@ISA);
@ISA = qw(Net::Server::PreFork);

&daemonize;

sub daemonize() {
    chdir '/'                 or die "Can't chdir to /: $!";
    defined(my $pid = fork)   or die "Can't fork: $!";
    exit if $pid;
    setsid                    or die "Can't start a new session: $!";
    umask 0;

    open PIDFILE, ">/var/run/perl-iptdaemon.pid";
    print PIDFILE $$;
    close PIDFILE;
}

#local $SIG{CHLD} = 'IGNORE'; # ignore SIGCHLD signals
sub REAPER { waitpid(-1 , WNOHANG); }
$SIG{CHLD} = \&REAPER;

my $iptables = "/sbin/iptables";
my $ipbin = "/sbin/ip";

my $__port = $ARGV[0] || 8000;
my $__interface = $ARGV[1] || "eth0";

my %eip:shared; # hash, contains external ip addresses and forwarded ports on them
my %iip:shared; # hash, contains internal ip addresses and forwarded ports on them
my @aip:shared; # array, containing all external IP addresses for faster lookups

my $queue;   # main task queue
my $monitor; # queue thread listener

setlogsock('unix');
#openlog("$0", "pid", LOG_LOCAL0);
openlog('iptdaemon', 'cons,pid', 'user');

my $server = bless {
	server => {
		port => [ $__port ],
		max_servers => 20,
		min_servers => 5,
		max_requests => 1000,
		child_communication => 1,
		reverse_lookups => 0,
		host => "127.0.0.1"
	},
}, 'iptdaemon';

$server->run();

exit;

###
### Net::Server overrides
###

# Bootstraps parent hook executed by Net::Server on startup
# Description: analyses existing iptables NAT rules, external IP addresses and 
# putting them into internal data structures; starts service threads and initlizes main work queue
sub configure_hook {
	my $self = shift;
	
	# read active iptables NAT rules and initializae internal data structures
	bootstrap();
	
	# main task queue initialization
	$queue = Thread::Queue::Duplex->new(ListenerRequired => 1);
	
	# starts main queue listener thread
	$monitor = threads->create(\&monitor, $queue)->detach;
}

# Child to parent communication hook executed by Net::Server. Executed when child is talking to it's parent
# Description: data is passed to the queue that's handled by "monitor" thread
sub child_is_talking_hook {
	my ($self, $sock) = @_;
	my $msg = $sock->getline();
	chomp($msg);
	
	# queueing request to be processed and waiting for the response
	my $response = $queue->enqueue_and_wait($msg) if (length($msg) > 0);

	# sending processed response back to the client	
	$sock->print($response->[0]."\n");
	$sock->flush;

	# releasing memory
	undef @$response;
}

# Main child processing routine executed by Net::Server
# Description: reads and parses input request from the client, performs validation 
# and sends to the parent socket if request data is valid
sub process_request {
	my $self = shift;
	my @data;
	
	my $clientsock = $self->{server}->{client}; 
	my $parentsock = $self->{server}->{parent_sock};
	
	$clientsock->autoflush(1);
	$parentsock->autoflush(1);
		
	# generating request UUID
	my $uuid = Data::GUID->new();

	syslog('info', "read_data: Accepted new connection $uuid");

	# processing raw input data from client
  	while (<$clientsock>) {
		chomp;
		s/\s{2,}/ /g;
		s/(^\s+|\s+$)//g;
		s/(=\s+$)/=/g;
		push(@data, $_) if (/=/);
		last if /exit/i;
	}
	push(@data, "uuid=$uuid");
	my $args = join(',', @data);

	# checking and validating data
	if (scalar(@data) > 1) {
		my $isvalid = validate_packet($args, $self);
		
		if (!$isvalid) {
			syslog('warning', "invalid packet: $args");
			return;
		}
		syslog('info', "accepted packet: $args") if $isvalid;
	}
	
	# passing data to the parent
	$parentsock->print("$args\n");
	$parentsock->flush;
	
	# reading parent response	
	my $msg = $parentsock->getline();
	$clientsock->print("$msg\n");
	$clientsock->flush;
}

###
### Helper functions
###

# Monitors work queue and handles incoming packets
# Description: reads packets from queue and passes them to the packet handler
sub monitor {
	my ($queue) = @_;
	$queue->listen();
	while (1) {
		while ($queue->pending) {
			my $deq = $queue->dequeue;
			my ($qid, $data) = ($deq->[0], $deq->[1]);
			
			# performing requested action
			my @response = handle($data);

			# responding back to the caller
			$queue->respond($qid, join(',', @response));
		}
		sleep 1;
	}
}

# Validates incoming packets for syntatic correctness
sub validate_packet {
	my ($data, $self) = @_;
	my $isvalid = 1;
	
	# parses $data into hashmap
	my %pref = map {(split('='))[0] => (split('='))[1]} (split(',',$data));
	
	# each packet should have action, otherwise packet is not valid
	# no point to process further
	unless (defined($pref{'action'})) {
		undef %pref;
		return 0;
	}
        
	foreach (keys %pref) {
		given ($_) {
			when ('uuid') {}
			when ('sockd') {}
			when ('action')  {
				# validating "action parameter"
				$isvalid = 0 unless grep /^initclient|removeclient$/, $pref{$_};
				
				given ($pref{$_}) {
					# if initclient is specified, then internalip, externalip and type should be specified as well
					when ('initclient') {
						for my $o (qw(internalip externalip type)) {
							$isvalid = 0 unless (defined($pref{$o}));
						}
					}
					# if removeclient is specified, then internalip should be specified as well
					when ('removeclient') {
						$isvalid = 0 unless (defined($pref{'internalip'}));
					}
				}
			}
			when ('internalip') { $isvalid = 0 unless grep /^[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}$/, $pref{$_}; }
			when ('externalip') { $isvalid = 0 unless grep /^[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}$/, $pref{$_}; }
			when ('realip')     { $isvalid = 0 unless grep /^[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}$/, $pref{$_}; }
			when ('type')       { $isvalid = 0 unless grep /^dynamic|static$/, $pref{$_}; }
			when ('ports')      { $isvalid = 0 unless grep /^[0-9 ]+$/, $pref{$_}; }
			default { syslog('warning', "validate_packet: unexpected parameter token '$pref{$_}'"); }
		}
	}
	
	undef %pref;
	return $isvalid;
}

# Handles client request
sub handle {
	my ($data) = @_;
	my @response = ();
	
	# parses $data into hashmap
	my %pref = map {(split('='))[0] => (split('='))[1]} (split(',',$data));
	
	my $external = $pref{"externalip"};
	push(@response, "action=".$pref{"action"});
        
	given ($pref{"action"}) {
		when ('initclient') {
			$external = tbladd( $pref{"externalip"},
					$pref{"internalip"},
					$pref{"realip"},
					$pref{"ports"},
					$pref{"type"},
					undef);
		}
		when ('removeclient') {
			$external = tblremove($pref{"internalip"});
		}
	}

	push(@response, "externalip=$external");
	push(@response, "ts=".time);
	push(@response, "status=done");

	undef %pref;
	
	return @response;
}

# Initializing base data structures and initial rules available at the start time
sub bootstrap
{
	# looping through all allocated external IP addresses
	# and putting thm into internal hash arrays
	open IP, "$ipbin addr show|grep -E \"$__interface:[0-9]+\"|sed -e 's/\\/[0-9]*//g'|awk '{print \$2}' |";
	while (<IP>) {
		chomp;
		$eip{$_} = &share([]);
		push(@aip, $_);
	}
	close IP;

	# looping through all existing SNAT rules
	# and putting them into internal hash arrays
	open IPTABLES, "$iptables -n -t nat -L POSTROUTING|grep SNAT|sed -e 's/dpt://g' -e 's/to://g'|awk '{print \$6\",\"\$4}' |";
	syslog('info', "tblinit: Looking for existing SNAT rules on startup ...");
	
	while (<IPTABLES>) {
		chomp;
		my @data = split(",");
		my ($external, $internal) = ($data[0], $data[1]);

		syslog('info', "    ->  found forward rule $external -> $internal");
		tbladdsingle_snat($external, $internal, "static");
                        
		undef @data;
	}
	close IPTABLES;
        
	# looping through all existing forwarding rules
	# and putting them into internal hash arrays
	open IPTABLES, "$iptables -n -t nat -L PREROUTING|grep DNAT|grep tcp|sed -e 's/dpt://g' -e 's/to://g' -e 's/:.*\\b//g'|awk '{print \$5\",\"\$7\",\"\$8}' |";
	syslog('info', "tblinit: Looking for existing DNAT rules on startup ...");
	while (<IPTABLES>) {
		chomp;
		my @data = split(",");
		my ($external, $port, $internal) = ($data[0], $data[1], $data[2]);
                        
		syslog('info', "    ->  found forward rule $external:$port -> $internal:$port");
		tbladdsingle($external, $internal, $port, "static");

		undef @data;
	}
	close IPTABLES;
}

# Checks and resolves port clashes
sub preprocess
{
	&preprocess_dynamic_hook; # handle clients with dynamic ip addresses
	&preprocess_clashes_hook; # handle port clashes
}

# Handle dynamic IP clients
sub preprocess_dynamic_hook
{
	# $external and $ports are references
	my ($external, $internal, $ports, $type) = @_;

	# handling dynamic users
	if ($type eq "dynamic") {
		my $randip = int(rand(scalar(@aip)));
		$$external = $aip[$randip];
		
		syslog('info', "tbladd: found dynamic IP '$$external' for the client");
	}
}

# Handle port clash process
sub preprocess_clashes_hook
{
	# $external and $ports are references
	my ($external, $internal, $ports, $type) = @_;

	# checking for port clashes
	my @isect = intersect(@{$eip{$$external}}, @{$ports});
	if ($#isect > -1) {
		syslog('warning', "tbladd: forwarded ports (".join(',', @isect).") are clashing on IP $$external. Looking for different external IP.");
                
		# looking for external IP on which requested ports are available
		my @shuffled = shuffle(@aip);
		my $found = 0;

		foreach (@shuffled) {
			unless (intersect(@{$eip{$_}}, @$ports)) {
				syslog('warning', "tbladd: found suitable IP '$_', will be used instead of $$external");
				$$external = $_;
				$found = 1;
				last;
			}
		}

		undef @shuffled;
                
		# suitable IP not found
		if (!$found) {
			@$ports = array_diff(@$ports, @isect);
			syslog('warning', "tbladd: couldn't find any suitable IP, using given $$external. Ports: '".join(',', @isect)."' will not be forwarded");
		}
	} 

	undef @isect;
}

# Initializes client on iptables level
sub tbladd
{
	my($external, $internal, $real, $ports, $type, $isinit) = @_;

	syslog('warning', "tbladd: passed external IP address not bind to any interface '$external'") and
	return unless defined $eip{$external};
        
	if (defined $iip{$internal}) {
		syslog('warning', "tbladd: passed internal IP address '$internal' that already marked as active. Removing IP and associated data");
		tblremove($internal);
	}
        
	my @p = split(' ', $ports);

	# if is on init phase, i.e. reading current iptables rules, no actuall iptables changes not needed
	# only poppulating internal data structures
	if (not defined $isinit) {
		# making preprocess actions
		# may change external IP and port set depending on environment state
		preprocess(\$external, $internal, \@p, $type);
                
		# setting iptables rules
		setnat($external, $internal);
		setpfleak($real, $internal);
		setforward($external, $internal, $_) foreach (@p);
	}

	if (scalar(@p) > 0) {
		# adding rules to the internal data structures
		tbladdsingle($external, $internal, $_, $type) foreach @p;       
	} else {
		tbladdsingle_snat($external, $internal, $type);
	}
        
	undef @p;
	
	return $external;
}

# Adds single record to system hashes
sub tbladdsingle_snat
{
	my($external, $internal, $type) = @_;

	$iip{$internal} = &share({});
	$iip{$internal}{"externalip"} = $external;
	$iip{$internal}{"type"} = $type;
}

# Adds single record to system hashes
sub tbladdsingle
{
	my($external, $internal, $port, $type) = @_;

	push(@{$eip{$external}}, $port);

	unless (defined $iip{$internal}) {
		$iip{$internal} = &share({});
		$iip{$internal}{"externalip"} = $external;
		$iip{$internal}{"type"} = $type;
		$iip{$internal}{"ports"} = $port;
	} else {
		$iip{$internal}{"ports"} .= " $port";
	}
}

# Deinitializes client
sub tblremove 
{
	my ($internal) = @_;

	syslog('warning'," tblremove: received request to remove IP that doesn't exists in internal tables '$internal'") and
	return unless defined $iip{$internal};
        
	my $external = $iip{$internal}{"externalip"};
	my $ports = $iip{$internal}{"ports"};

	# unsetting iptables
	unsetnat($internal);
	unsetpfleak($internal);
	unsetforward($internal);
        
	# unsetting internal data structures
	my @arr = @{$eip{$external}};
	foreach (split(' ', $ports)) {
		my $port = $_;
		my $offset = first { $arr[$_] eq $port } 0 .. $#arr;
		splice @arr, $offset, 1;
	}
	undef @{$eip{$external}};
	delete $eip{$external};
        
	# reassigning array, as thread::shared doesn't implement splice natively
	$eip{$external} = &share([]);
	push(@{$eip{$external}}, $_) foreach (@arr);
        
	undef @arr;
	undef %{$iip{$internal}};
	delete $iip{$internal};

	return $external;
}

# Sets up NAT for user
sub setnat
{
	my($external, $internal) = @_;
	syslog('info', "setnat: $iptables -t nat -A POSTROUTING -s $internal/32 -o $__interface -j SNAT --to-source $external");
	system("$iptables -t nat -A POSTROUTING -s $internal/32 -o $__interface -j SNAT --to-source $external");
}

# Protects against pfleak
sub setpfleak
{
	my($real, $internal) = @_;

	syslog('info', "pfleak: $iptables -A FORWARD -s $real ! -d $internal -j DROP");
	system("$iptables -A FORWARD -s $real ! -d $internal -j DROP");
}

# Sets up port forwarding for a user
sub setforward
{
	my($external, $internal, $port) = @_;
	syslog('info', "setforward: $iptables -t nat -A PREROUTING -d $external/32 -i $__interface -p tcp -m tcp --dport $port -j DNAT --to-destination $internal:$port");
	syslog('info', "setforward: $iptables -t nat -A PREROUTING -d $external/32 -i $__interface -p udp -m udp --dport $port -j DNAT --to-destination $internal:$port");
	system("$iptables -t nat -A PREROUTING -d $external/32 -i $__interface -p tcp -m tcp --dport $port -j DNAT --to-destination $internal:$port");
	system("$iptables -t nat -A PREROUTING -d $external/32 -i $__interface -p udp -m udp --dport $port -j DNAT --to-destination $internal:$port");
}

# Goes through NAT table and removes client associated rules from POSTROUTING chain
# which is related to NAT itself and user ability to go out to the network
sub unsetnat
{
	my $internal = shift;
	open SNAT, "$iptables -n -t nat -L POSTROUTING --line-numbers|grep -E \"\\b$internal\\b\"|awk '{print \$1}'|sort -n -r |";
	while (<SNAT>) {
		syslog('info', "unsetnat: $iptables -t nat -D POSTROUTING $_");
		system("$iptables -t nat -D POSTROUTING $_");
	}
	close SNAT;
}

# Goes through NAT table and removes client associated rules from PREROUTING chain
# which is related to port forwarding
sub unsetforward
{
	my $internal = shift;
	open DNAT, "$iptables -n -t nat -L PREROUTING --line-numbers|grep -E \"\\b$internal\\b\"|awk '{print \$1}'|sort -n -r |";
	while (<DNAT>) {
		syslog('info', "unsetforward: $iptables -t nat -D PREROUTING $_");
		system("$iptables -t nat -D PREROUTING $_");
	}
	close DNAT;
}

# Removes pfleak protection in FORWARD chain
sub unsetpfleak
{
	my $internal = shift;
	open PFLEAK, "$iptables -n -L FORWARD --line-numbers|grep -E \"\\b$internal\\b\"|awk '{print \$1}'|sort -n -r |";
	while (<PFLEAK>) {
		syslog('info', "unsetpfleak: $iptables -D FORWARD $_");
		system("$iptables -D FORWARD $_");
	}
	close PFLEAK;
}
