#!/usr/bin/perl

#
# ipt-gen v. 0.5.3 - IPTables GENeraor
# (C) 2006-2009, Bartosz Lis <bartoszl@ics.p.lodz.pl>
#
# Licensed according to GNU GPL v. 2.0
#
# CAUTION! This software is distributed AS IS with no warranties.
# If you use it, you are doing so ON YOUR OWN RISK.
#

use strict;
use POSIX;
use Fcntl;

my $conf_dir = "/etc/iptgen";

if ( $ARGV[0] eq "-v" )
{
    print "0.5.3\n";
    exit 0;
}
if ( $ARGV[0] eq "-c" )
{
    shift @ARGV;
    $conf_dir=shift @ARGV;
    ( $conf_dir ne "" ) || die "Configuration directory not specified";
}
( -e $conf_dir ) || die "Configuration directory '$conf_dir' does not exist";
( -d $conf_dir ) || die "Configuration directory '$conf_dir' is not a directory";
my $conf_lookup   = "$conf_dir/lookup.pl";
( -f $conf_lookup ) || die "File: '$conf_lookup' does not exist";
my $conf_src_dst  = "$conf_dir/src-dst.pl";
( -f $conf_src_dst ) || die "File: '$conf_src_dst' does not exist";
my $conf_policies = "$conf_dir/policies.pl";
( -f $conf_policies ) || die "File: '$conf_policies' does not exist";
my $conf_nat      = "$conf_dir/nat.pl";
( -f $conf_nat ) || die "File: '$conf_nat' does not exist";
my $conf_mangle   = "$conf_dir/mangle.pl";
( -f $conf_mangle ) || die "File: '$conf_mangle' does not exist";
my $conf_filter   = "$conf_dir/filter.pl";
( -f $conf_filter ) || die "File: '$conf_filter' does not exist";
my $max_chain_len = 31;

my %iptables=
(
    'nat' => {
	'PREROUTING'  => [],
	'POSTROUTING' => [],
	'OUTPUT'      => []
    },
    'filter' => {
	'INPUT'       => [],
	'FORWARD'     => [],
	'OUTPUT'      => []
    },
    'mangle' => {
	'PREROUTING'  => [],
	'POSTROUTING' => [],
	'INPUT'       => [],
	'FORWARD'     => [],
	'OUTPUT'      => []
    }    
);

my %chain_names;

foreach my $table (keys %iptables)
{
    foreach my $chain ('ACCEPT','DROP','RETURN','SNAT','DNAT') 
    { 
	$iptables{$table}{$chain}=''; 
	$chain_names{$chain}=$chain;
    }
}


sub new_translation
{
    my $chain=shift;
    my $prefix;
    my $tmp_name;
    my $len=$max_chain_len-3;
    my $num=0;
    my $max=10;
    while ($len>=0)
    {
	$prefix=substr($chain,0,$len)."__";
	while ($num<$max)
	{
	    $tmp_name=$prefix.$num;
	    if (!defined $chain_names{$tmp_name})
	    {
		$chain_names{$tmp_name}='';
		$chain_names{$chain}=$tmp_name;
		return $tmp_name;
	    }
	    ++$num;
	}
	--$len;
	$max*=10;
    }
    die "Cannot find shorter name for '$chain'";
}

sub translate_chain
{
    my $chain=shift;
    if (!defined $chain_names{$chain})
    {
	$chain_names{$chain}=(length($chain)>$max_chain_len ? new_translation($chain) : $chain)
    }
    elsif ($chain_names{$chain} eq '')
    {
	$chain_names{$chain}=new_translation($chain);
    }
    return $chain_names{$chain};
}

sub register_chain
{
    my ($table,$chain) = @_;
    if (!defined $iptables{$table}) { die "Wrong table '$table'"; }
    if (!defined $iptables{$table}{$chain})
    {
	if (`modinfo ipt_$chain 2>/dev/null` eq "") { $iptables{$table}{$chain}=[]; }
	else { $iptables{$table}{$chain}=''; $chain_names{$chain}=$chain; }
    }
    return ref $iptables{$table}{$chain};
}

sub cmp_chain
{
    my ($a,$b)=@_;
    if ($a eq "INPUT") { return -1; }
    if ($b eq "INPUT") { return 1; }
    if ($a eq "OUTPUT") { return -1; }
    if ($b eq "OUTPUT") { return 1; }
    if ($a eq "PREROUTING") { return -1; }
    if ($b eq "PREROUTING") { return 1; }
    if ($a eq "POSTROUTING") { return -1; }
    if ($b eq "POSTROUTING") { return 1; }
    if ($a eq "FORWARD") { return -1; }
    if ($b eq "FORWARD") { return 1; }
    return $a cmp $b;
}

sub add_rule
{
    my $table = shift @_;
    my $chain = shift @_;
    my @rules = @_;
    my $rule;
    my $prefix;
    my $subchain;
    my $suffix;
    if (register_chain($table,$chain))
    {
	translate_chain($subchain);
	foreach $rule (@rules)
	{
	    if ($rule =~ /^(.*\s)?(-[jg]\s+)([[:alnum:]_]+)(\s.*)?$/) 
	    { 
		$prefix=$1.$2;
		$subchain=$3;
		$suffix=$4;
		register_chain($table,$subchain);
		$rule=$prefix.translate_chain($subchain).$suffix;
	    }
	    push @{$iptables{$table}{$chain}}, $rule;
	}
    }
    else { printf STDERR "Wrong chain '$chain' in table '$table' for rule '$rule'. Rule ignored.\n"; }
}

my %chain_num;
my %logs;
my %lasts =
(
    'second' =>     1,
    's'      =>     1,
    'minute' =>    60,
    'm'      =>    60,
    'hour'   =>  3600,
    'h'      =>  3600,
    'day'    => 86400,
    'd'      => 86400,
);

sub new_chain
{
    my $chain=$_[0];
    $chain =~ tr/\-/_/; 
    if ($chain=~/^([[:alpha:]][[:alpha:]_]*)([^[:alpha:]_]|$)/) 
    { 
	$chain=$1;
	if ($chain=~/^(.*[^_])_+$/) { $chain=$1; } 
    } 
    else { $chain='CHAIN'; }
    #print "'$_[0]' '$chain'\n";
    return $chain."_".($chain_num{$chain}++);
}

sub get_log_target
{
    my ($table,$log,$limit)=@_;
    my $limit_rule;
    my $period;
    my $log_target;
    if ($limit =~ /^([[:digit:]]+)\/(.+)$/) 
    {
	$limit=$1;
	$period=$2;
	if (!defined $lasts{$period}) { die "Wrong limit period '$period' while parsing '$limit/$period'"; }
	if (length($period)==1) { ($period) = grep((length($_)>1)&&($lasts{$_}==$lasts{$period}), keys %lasts); }
    }
    else { $period='second'; }
    if ($limit eq "") { $limit=0; }
    elsif ($limit>0)
    {
	$limit_rule="-m limit --limit $limit/$period "; 
	$limit*=$lasts{$period};
    }
    elsif ($limit ne "0") { die "Wrong limit '$limit'"; }
    $log_target="$limit_rule-j LOG --log-prefix :$log: --log-level 6";
    return wantarray ? ($log_target,$table,$log,$limit) : $log_target;
}

sub get_log_chain
{
    my $target=shift @_;
    my ($log_target,$table,$log,$limit)=get_log_target(@_);
    $log=~tr/a-z/A-Z/;
    if ($log=~/^ALLOWED(.*)$/) { $log='PASS'.$1; }
    elsif ($log=~/^DENIED(.*)$/) { $log='BAN'.$1; }
    else { $log="LOG_$log"; }
    if (defined $logs{$table}{$log}{$limit}{$target}) { return $logs{$table}{$log}{$limit}{$target}; }
    $log=$logs{$table}{$log}{$limit}{$target}=new_chain($log);
    add_rule($table,$log,$log_target,$target);
    return $log;
}

sub service_acl
{
    my $name = shift @_;
    my $selector = shift @_;
    my $item;
    my @rules;
    foreach $item (@_) { push @rules,ref $item eq 'ARRAY' ? service_acl($name,@{$item}): [ $item, [ 'ACCEPT', "allowed-$name"]]; }
    return [ $selector, [ 'GOTO', "$name#", @rules, [ '', [ 'DROP', "denied-$name" ]]]];
}

sub ip_to_bits
{
    my ($ip1,$ip2,$ip3,$ip4)=@_;
    if ($ip2 eq "") { ($ip1,$ip2,$ip3,$ip4)=split /\./,$ip1;}
    return (0x100*(0x100*(0x100*$ip1+$ip2)+$ip3)+$ip4);
}

sub bits_to_ip
{
    my $bits=$_[0];
    my $ip1=($bits>>24) & 0xff;
    my $ip2=($bits>>16) & 0xff;
    my $ip3=($bits>>8) & 0xff;
    my $ip4=$bits & 0xff;
    return "$ip1.$ip2.$ip3.$ip4";
}

sub num_to_bits
{
    my $num=$_[0];
    if ($num==32) { return 0xffffffff; }
    return ((1<<$num)-1)<<(32-$num);
}

sub bits_to_num
{
    my $bits=$_[0];
    my $bit0;
    my $n0;
    my $bit1;
    my $n1;
    for ($bit0=1; ($n0<32) && !($bit0 & $bits); $bit0<<=1, ++$n0) {}
    for ($bit1=0x80000000; ($n1<32) && ($bit1 & $bits); $bit1>>=1, ++$n1) {}
    ($n0+$n1==32) || die "wrong mask: ".bits_to_ip($bits)."\n";
    return $n1;
}

sub mask_to_num
{
    return bits_to_num(ip_to_bits(@_));
}

sub num_to_mask
{
    return bits_to_ip(num_to_bits(@_));
}

sub cmp_net
{
    my ($a,$b)=@_;
    if ($a =~ /^([^:]*):/) { $a=$1; }
    if ($a eq '') { $a='0.0.0.0/0'; }
    my ($ip_a,$mask_a)=split /\//, $a;
    if ($mask_a eq '') { $mask_a=32; }
    elsif ($mask_a =~ /^([[:digit:]]+)\.([[:digit:]]+)\.([[:digit:]]+)\.([[:digit:]]+)$/) { $mask_a=mask_to_num($1,$2,$3,$4); }
    if ($b =~ /^([^:]*):/) { $b=$1; }
    if ($b eq '') { $b='0.0.0.0/0'; }
    my ($ip_b,$mask_b)=split /\//, $b;
    if ($mask_b eq '') { $mask_b=32; }
    elsif ($mask_b =~ /^([[:digit:]]+)\.([[:digit:]]+)\.([[:digit:]]+)\.([[:digit:]]+)$/) { $mask_b=mask_to_num($1,$2,$3,$4); }
    return ($mask_a==$mask_b) ? (ip_to_bits($ip_a)<=>ip_to_bits($ip_b)) : ($mask_b<=>$mask_a);
}

sub canonify_addr
{
    my $arg=$_[0];
    my $ip;
    my $ip_bits;
    my $mask;
    my $mask_bits;
    if ($arg =~ /^([[:digit:]]+)\.([[:digit:]]+)\.([[:digit:]]+)\.([[:digit:]]+)\/([[:digit:]]+)$/)
    {
	$ip=join('.',$1,$2,$3,$4);
	$mask=$5;
	$ip_bits=ip_to_bits($ip);
	$mask_bits=num_to_bits($mask);
	$mask=bits_to_ip($mask_bits);
    }
    elsif ($arg =~ /^([[:digit:]]+)\.([[:digit:]]+)\.([[:digit:]]+)\.([[:digit:]]+)\/([[:digit:]]+)\.([[:digit:]]+)\.([[:digit:]]+)\.([[:digit:]]+)$/)
    {
	$ip=join('.',$1,$2,$3,$4);
	$mask=join('.',$5,$6,$7,$8);
	$ip_bits=ip_to_bits($ip);
	$mask_bits=ip_to_bits($mask);
	bits_to_num($mask_bits);
    }
    elsif ($arg =~ /^([[:digit:]]+)\.([[:digit:]]+)\.([[:digit:]]+)\.([[:digit:]]+)$/)
    {
	$ip=join('.',$1,$2,$3,$4);
	$mask="255.255.255.255";
	$ip_bits=ip_to_bits($ip);
	$mask_bits=0xffffffff;
    }
    else { die "Wrong IP specification: $arg"; }
    ($ip_bits & (~$mask_bits&0xffffffff)) && die "wrong CIDR: $arg $ip_bits $mask_bits\n";
    #print STDERR "canonify: $ip\n";
    return $ip.(($mask_bits==0xffffffff)?"":"/".$mask);
}

my %lookup;
eval `cat $conf_lookup`; 
$lookup{'default'}='0.0.0.0/0';
$lookup{'net_mcast'}='224.0.0.0/240.0.0.0';
$lookup{'net_priv'}=
{ 
    'A' => '10.0.0.0/8', 
    'B' => '172.16.0.0/12', 
    'C' => '192.168.0.0/16',
};

sub parse_addr
{
    my $arg=$_[0];
    my $neg;
    if ($arg=~/^!(.+)$/) { $neg="!"; $arg=$1; }
    my @addr_next=split/,/,$arg;
    my @addr;
    my $i;
    my $j;
    my $n;
    my $m;
    my %ret;
    my %names;
    while (scalar @addr_next)
    {
	@addr=splice(@addr_next,0);
	foreach $i (@addr)
	{
	    if ($i=~/^[[:digit:]\.\/]+$/) { ++$ret{canonify_addr($i)}; }
	    elsif ($i=~/^(.+)\{(.+)\}$/) 
	    {
		$n=$1;
		$m=$2;
		if (!defined $lookup{$n}) { die "Wrong name '$n' in address specification '$arg'"; }
		if (!defined $lookup{$n}{$m}) { die "Wrong name '$n\{$m\}' in address specification '$arg'"; }
		if (!defined $names{$i})
		{
		    $names{$i}=1;
		    push @addr_next, split(/,/, $lookup{$n}{$m});
		}
	    }
	    elsif (!defined $lookup{$i}) { die "Wrong name '$i' in address specification '$arg'"; }
	    elsif (!defined $names{$i})
	    {
		$names{$i}=1;
		if (ref $lookup{$i} eq 'HASH') 
		{
		    foreach $j (keys %{$lookup{$i}}) 
		    { 
			if (!defined $names{"$i\{$j\}"})
			{
			    $names{"$i\{$j\}"}=1;
			    push @addr_next, split(/,/, $lookup{$i}{$j});
			}
		    }
		}
		else { push @addr_next, split(/,/, $lookup{$i}); }
	    }
	}
    }
    @addr=keys %ret;
    if ($neg) 
    { 
	if (scalar @addr==0) { die "Cannot parse address specification '$neg$arg'";} 
	if (scalar @addr>1) { die "Unsupported multiaddress negation for '$neg$arg'";} 
	$addr[0]="$neg $addr[0]";
    };
    return [ @addr ];
}

sub parse_addr_port
{
    my $addr=$_[0];
    my $ports;
    if ($addr=~/^(.*):(.*)$/)
    {
	$addr=$1;
	$ports=$2;
	if ((index($ports,"-")>=0) && (index($ports,",")>=0)) { die "Unsupported ranges in multiport specification for '$addr:$ports'";} 
	$ports=~tr/\-/:/;
	if ($ports=~/^!(.+)$/) { $ports="! $1"; }
	return [$addr,$ports];
    }
    return [$addr];
}

sub parse_nic_addr
{
    my $addr=$_[0];
    my $nics;
    if ($addr=~/^(.*)@(.*)$/)
    {
	$addr=$1;
	$nics=$2;
	if ($nics=~/^!(.+)$/) 
	{
	    if (index($nics,",")>=0) { die "Unsupported negation in multiNIC specification for '$addr\@$nics'"; } 
	    return [$addr,"! $1"];
	}
	return [$addr,split(/,/,$2)]
    }
    return [$addr];
}

sub bcast
{
    my $arg=$_[0];
    my @addr=@{parse_addr($arg)};
    my $i;
    my $addr;
    my $mask;
    for ($i=0; $i<scalar @addr; ++$i)
    {
	if ($addr[$i]=~/^(.+)\/(.+)$/)
	{
	    $addr=$1;
	    $mask=$2;
	}
	else { die ("Cannot calculate broadcast using '$addr[$i]'"); }
	$addr[$i]=ip_to_bits($addr)|(~ip_to_bits($mask)&0xffffffff);
    }
    return join ',', map {bits_to_ip($_)} @addr;
}

sub chk_intranet
{
    my @nic_intranet=@_;
    my @rules;
    my $nic;
    foreach $nic (@nic_intranet) { push @rules, [ "\@$nic>>\@$nic", 'ACC' ]; }
    return @rules;
}

sub chk_bridge
{
    my $target=shift;
    my @nic_bridge=@_;
    my @rules;
    my $nic;
    foreach $nic (@nic_bridge) { push @rules, [ "\@$nic>>\@$nic", 'RET' ]; }
    push @rules, ['', (ref $target eq 'ARR' ? $target : ['GOTO', $target])];
    return @rules;
}

sub bw_list
{
    my $target=shift @_;
    my $message=shift @_;
    my $tgt;
    my $item;
    my $rule;
    my $log;
    my $addr;
    my $proto;
    my $port;
    my @ret;
    foreach $item (@_)
    {
	if (ref $item eq 'ARRAY')
	{
	    ($rule,$log)=@{$item};
	    if ($log eq "RET") { $tgt='RETURN'; }
	    else
	    {
		if ($log eq "") { $log=$message; }
		$tgt=[$target,$log];
	    }
	}
	else 
	{ 
	    $rule=$item; 
	    $tgt=$target;
	}
	if ($rule =~ />/) { push @ret, [$rule,$tgt]; }
	else
	{
	    $port='';
	    if ($rule=~/^([^:]*):(tcp|udp)(.*)$/)
	    {
		$addr=$1;
		$proto=$2;
		if ($3 ne "") { $port=":".$3 };
	    }
	    elsif ($rule=~/^([^:]*):([[:alpha:]]+|\[[[:digit:]]+\])$/)
	    {
		$addr=$1;
		$proto=$2;
	    }
	    else
	    {
		$addr=$rule;
		$proto='';
	    }
	    if ($addr ne '') { push @ret, [">$proto>$addr$port",$tgt],["$addr>$proto>$port",$tgt]; }
	    elsif (($port ne '') || ($proto ne '')) { push @ret, [">$proto>$port",$tgt] };
	}
    }
    return @ret;
}

my %nic_spoofing;

sub gen_map
{
    my ($mapping,$matched,$missed)=@_;
    my %src;
    my @rules;
    my $subrules;
    my $inics;
    my $addr;
    my $net;
    my $chain;
    if ($matched eq '') { $matched='RETURN'; }
    if ($missed eq '') { $missed='RETURN'; }
    foreach $net (keys %{$mapping})
    {
	$inics=join(',',sort {$a cmp $b} split(/,/,$$mapping{$net}));
	foreach $addr (@{parse_addr($net)})
	{
	    if (defined $src{$addr}) { die "redefined inbound interface for source $addr"; }
	    if ($inics ne '') { $src{$addr}=$inics; }
	}
    }
    foreach $addr (sort {cmp_net($a,$b)} keys %src)
    {
	$inics=$src{$addr};
	if ($inics eq 'none') { push @rules, [ "$addr>>", $missed ]; }
	elsif ($nic_spoofing{$inics} eq '') 
	{
	    $chain="CHK_SRC_$inics";
	    $chain=~tr/:.,/___/;
	    $nic_spoofing{$inics}=$chain;
	    $subrules=[ 'GOTO', $chain ];
	    if (index($inics,',')<0) { push @{$subrules}, [ "\@!$inics>>", $missed ]; }
	    else
	    {
		push @{$subrules}, [ "\@$inics>>", $matched ];
		push @{$subrules}, [ '', $missed ];
	    }
	    push @rules, [ "$addr>>", $subrules ];
	}
	else { push @rules, [ "$addr>>", [ 'GOTO', $nic_spoofing{$inics} ]]; }
    }
    return @rules;
}

my %policies;
eval `cat $conf_policies` || die "cannot eval '$conf_policies'"; 

my $nic_out;
my @nic_intranet;
my @nic_bridge;
my @rules_out;
my %net_src; 
eval `cat $conf_src_dst` || die "cannot eval '$conf_src_dst'"; 

my @n_pre;
my @n_post;
my @n_output;
eval `cat $conf_nat` || die "cannot eval '$conf_nat'"; 

my @m_pre;
my @m_post;
my @m_input;
my @m_forward;
my @m_output;
eval `cat $conf_mangle` || die "cannot eval '$conf_mangle'"; 

my @f_input;
my @f_forward;
my @f_output;
eval `cat $conf_filter` || die "cannot eval '$conf_filter'"; 

sub parse_filter_rule
{
    my $arg=$_[0];
    my @modules=split /&/, $arg;
    my $item;
    my $rule=shift @modules;
    my @ret;
    my $src;
    my $dst;
    my $proto;
    my $src_nics;
    my $dst_nics;
    my $src_addr;
    my $dst_addr;
    my $src_port;
    my $dst_port;
    my $icmp_type;
    my $neg;
    if ($rule=~/^([^>]*)>(ip)?>([^>]*)$/)
    {
	$src=$1;
	$dst=$3;
	$src_nics=parse_nic_addr($src); 
	$src=shift(@{$src_nics});
	$dst_nics=parse_nic_addr($dst); 
	$dst=shift(@{$dst_nics});
	if ($src=~/:/) { die "unexpected source port specification in filter rule '$arg'"; }
	if ($dst=~/:/) { die "unexpected destination port specification in filter rule '$arg'"; }
	$src_addr=parse_addr($src);
	$dst_addr=parse_addr($dst);
	push @ret, [ 'ip', $src_nics, $dst_nics, $src_addr, $dst_addr ];
    }
    elsif ($rule=~/^([^>]*)>(!?)(tcp|udp)>([^>]*)$/)
    {
	$src=$1;
	$neg=($2 ne '' ? '! ' : undef);
	$proto=$3;
	$dst=$4;
	$src_nics=parse_nic_addr($src); 
	$src=shift(@{$src_nics});
	$dst_nics=parse_nic_addr($dst); 
	$dst=shift(@{$dst_nics});
	($src,$src_port)=@{parse_addr_port($src)};
	($dst,$dst_port)=@{parse_addr_port($dst)};
	$src_addr=parse_addr($src);
	$dst_addr=parse_addr($dst);
	if (($neg ne "") && (($src_port ne "") || ($dst_port ne ""))) { die "Cannot have negated protocol with specified ports in '$arg'"; }
	push @ret, [ $neg.$proto, $src_nics, $dst_nics, $src_addr, $dst_addr, $src_port, $dst_port ];
    }
    elsif ($rule=~/^([^>]*)>(!?)icmp(.*)>([^>]*)$/)
    {
	$src=$1;
	$neg=($2 ne '' ? '! ' : undef);
	$icmp_type=$3; 
	$dst=$4;
	if ($icmp_type ne "") 
	{ 
	    if ($icmp_type=~/^-([[:digit:]]+)$/) { $icmp_type=$1; } else { $icmp_type="icmp$icmp_type"; }
	    $icmp_type=$neg.$icmp_type; 
	    $neg=""; 
	}
	$src_nics=parse_nic_addr($src); 
	$src=shift(@{$src_nics});
	$dst_nics=parse_nic_addr($dst); 
	$dst=shift(@{$dst_nics});
	if ($src=~/:/) { die "unexpected source port specification in filter rule '$arg'"; }
	if ($dst=~/:/) { die "unexpected destination port specification in filter rule '$arg'"; }
	$src_addr=parse_addr($src);
	$dst_addr=parse_addr($dst);
	push @ret, [ $neg."icmp", $src_nics, $dst_nics, $src_addr, $dst_addr, $icmp_type ];
    }
    elsif ($rule=~/^([^>]*)>(!?)([[:alpha:]]+|\[[[:digit:]]+\])>([^>]*)$/)
    {
	$src=$1;
	$neg=($2 ne '' ? '! ' : undef);
	$proto=$3;
	$dst=$4;
	$src_nics=parse_nic_addr($src); 
	$src=shift(@{$src_nics});
	$dst_nics=parse_nic_addr($dst); 
	$dst=shift(@{$dst_nics});
	if ($src=~/:/) { die "unexpected source port specification in filter rule '$arg'"; }
	if ($dst=~/:/) { die "unexpected destination port specification in filter rule '$arg'"; }
	$src_addr=parse_addr($src);
	$dst_addr=parse_addr($dst);
	push @ret, [ $neg.$proto, $src_nics, $dst_nics, $src_addr, $dst_addr ];
    }
    elsif ($rule eq '') { push @ret,[]; }
    else { die "Wrong filter rule '$arg'"; }
    foreach $item (@modules) { push @ret, [split /\s+/,$item]; }
    return \@ret;
}

sub gen_rules;

sub parse_target
{
    my ($table,$chain,$ref_target)=@_;
    my $target;
    my @targets;
    if (ref $ref_target eq 'ARRAY')
    {
	@targets=@{$ref_target};
	$target=shift @targets;
    }
    else { $target=$ref_target; }
    my @spec;
    my $addr;
    my $proto;
    my $port;
    my $rej;
    my $log;
    my $spec;
    my $onic;
    my $new_chain;
    my $oper;
    my $val;
    if ($target eq '') { die "empty target"; }
    if (($target eq 'RET') || ($target eq 'RETURN')) { $target='-j RETURN'; }
    elsif (($target eq 'ACC') || ($target eq 'ACCEPT') || ($target eq 'ALLOW')) { $target='-j ACCEPT'; }
    elsif (($target eq 'DROP') || ($target eq 'DENY')) { $target='-j DROP'; }
    elsif (($target eq 'REJ') || ($target eq 'REJECT'))
    { 
	$target='-j REJECT';
	$rej=shift @targets;
	if ($rej ne "")
	{
	    $target.=" --reject-with ";
	    if ($rej eq "tcp-reset") { $target="-m tcp -p tcp $target"; }
	    elsif ($rej !~ /^icmp-/) { $target.="icmp-"; }
	    $target.="$rej";
	}
    }
    elsif ($target eq 'GOTO')
    { 
	if (!scalar @targets) { die "GOTO target requires chain name and optionaly rule list"; }
	$new_chain=shift @targets;
	if ($new_chain eq '') { $new_chain=new_chain($chain); }
	elsif ($new_chain =~ /^(.+)#/) { $new_chain=new_chain($1); }
	else { $new_chain =~ tr/\-/_/; }
	$$ref_target[1]=$new_chain;
	$target="-g $new_chain";
	if (scalar @targets)
	{ 
	    splice(@{$ref_target},2);
	    gen_rules($table,$new_chain,@targets);
	    @targets=();
	}
    }
    elsif ($target eq 'JUMP')
    {
	if (!scalar @targets) { die "JUMP target requires chain name and optionaly rule list"; }
	$new_chain=shift @targets;
	if ($new_chain eq '') { $new_chain=new_chain($chain); }
	elsif ($new_chain =~ /^(.+)#/) { $new_chain=new_chain($1); }
	else { $new_chain =~ tr/\-/_/; }
	$$ref_target[1]=$new_chain;
	$target="-j $new_chain";
	if (scalar @targets) 
	{ 
	    splice(@{$ref_target},2);
	    gen_rules($table,$new_chain,@targets);
	    @targets=();
	}
    }
    elsif ($target eq 'SNAT')
    {
	$spec=shift @targets;
	@spec=@{parse_addr_port($spec)};
	$addr=shift @spec;
	#print "SNAT addr: '$addr'\n";
	if (scalar @spec==0)
	{
	    $proto='';
	    $port='';
	}
	elsif ((scalar @spec==1) && ($spec[0] =~ /^(tcp|udp)(.+)$/))
	{
	    $proto="-m $1 -p $1 ";
	    $port=":$2";
	}
	else { die "Wrong SNAT port specification:'$spec'"; }
	@spec=@{parse_addr($addr)};
	if (scalar @spec>1) { die "Multiple SNAT addresses specified:'$spec'"; }
	$addr=$spec[0];
	if (($addr eq "") && ($port eq "")) { die "Neither SNAT address nor port specified: '$spec'"; }
	if (index($addr,'/')>=0) { die "Network address in SNAT target: '$addr'"; }
	$target="$proto-j SNAT --to-source $addr$port";
    }
    elsif ($target eq 'DNAT')
    {
	$spec=shift @targets;
	@spec=@{parse_addr_port($spec)};
	$addr=shift @spec;
	#print "DNAT addr: '$addr'\n";
	if (scalar @spec==0)
	{
	    $proto='';
	    $port='';
	}
	elsif ((scalar @spec==1) && ($spec[0] =~ /^(tcp|udp)(.+)/))
	{ 
	    $proto="-m $1 -p $1 ";
	    $port=":$2";
	}
	else { die "Wrong DNAT port specification:'$spec', '$addr', '$spec[0]', '$spec[1]', '$spec[2]'"; }
	@spec=@{parse_addr($addr)};
	if (scalar @spec>1) { die "Multiple DNAT address specified:'$spec'"; }
	$addr=$spec[0];
	if (($addr eq "") && ($port eq "")) { die "Neither DNAT address nor port specified: '$spec'"; }
	if (index($addr,'/')>=0) { die "Network address in DNAT target: '$addr'"; }
	$target="$proto-j DNAT --to-destination $addr$port";
    }
    elsif ($target eq 'ROUTE')
    {
	$target="-j ROUTE";
	$spec=shift @targets;
	my $cont;
	if ($spec =~ /^(.*)\+$/)
	{
	    $spec=$1;
	    $cont=1;
	}
	if ($spec =~ /^(.*)\@(.*)$/)
	{
	    $addr=$1;
	    $onic=$2;
	    $target.=" --oif $onic";
	}
	else { $addr=$spec; }
	@spec=@{parse_addr($addr)};
	if (scalar @spec>1) { die "Multiple gateway addresses in ROUTE target: '$addr'"; }
	if ($spec[0] ne "") 
	{
	    $addr=$spec[0];
	    if (index($addr,'/')>=0) { die "Network address in ROUTE target: '$addr'"; }
	    $target.=" --gw $addr";
	}
	elsif ($onic eq "") { die "Neither gateway address nor output interface specified in ROUTE target: '$spec'"; }
	if ($cont) { $target.=" --continue"; }
    }
    elsif ($target eq 'LOG')
    {
	$target=get_log_target($table,@targets);
	@targets=();
    }
    elsif ($target eq 'TTL')
    {
	$spec=shift @targets;
	if ($spec =~ /([+-=]?)([[:digit:]]+)/)
	{
	    $oper=( $1 eq "+" ? "inc" :
		    $1 eq "-" ? "dec" :
				"set" );
	    $val=$2;
	}
	else { die "Wrong TTL modfication specification: '$spec'"; }
	$target="-j TTL --ttl-$oper $val";
    }
    else { die "unknown target '$target'"; }
    if (scalar @targets>0) { $target='-g '.get_log_chain($target,$table,@targets); }
    return $target;
}

sub check_proto
{
    my $proto=$_[0];
    my $pnum;
    my $pname;
    if (($proto eq 'ip') || ($proto eq '')) { return 'ip'; }
    if ($proto =~ /^[[:alpha:]]+$/)
    {
	($pname,undef,$pnum)=getprotobyname $proto;
	if (!defined $pname) { die "unknown protol name: '$proto'"; }
	$proto=$pname;
    }
    elsif ($proto =~ /^\[([[:digit:]]+)\]$/)
    {
	$proto=$1;
	($pname,undef,$pnum)=getprotobynumber $proto;
	if (defined $pname) { $proto=$pname; }
    }
    else { die "unknown protol specification: '$proto'"; }
    return $proto;
}

sub add_proto
{
    my $proto=shift;
    my $rule=shift;
    if ($proto)
    {
	my $neg;
	if ($proto =~ /^!\s*(\S+)$/) 
	{
	    $neg='! ';
	    $proto=$1;
	}
	if ($rule !~ /(^| )(! )?-p $proto/) 
	{ 
	    $rule=$neg.'-p '.$proto.' '.$rule;
	}
	elsif (length($neg.$2)==2) 
	{ 
	    die "Rule should use either '$proto' or '!$proto'"; 
	}
	if ($rule !~ /-m $proto/)
	{
	    $rule='-m '.$proto.' '.$rule;
	}
    }
    return $rule;
}

sub gen_ip_nic
{
    my @opt=(undef,'-i ','-o ','-s ','-d ');
    my $opt=$opt[shift];
    my $item=shift;
    my $neg;
    if ($item=~/^!\s*(\S+)$/) 
    { 
	$neg='! ';
	$item=$1;
    }
    return $neg.$opt.$item.' ';
}

sub gen_rule
{
    my ($table,$chain,$rule,$target)=@_;
    my @ip_rule;
    my @cart;
    my $i;
    my $item;
    my $proto;
    my $cart;
    my $subrule;
    my $subproto;
    my $neg;
    my $cart;
    my $new_chain;
    $rule=parse_filter_rule($rule);
    @ip_rule=@{shift @{$rule}};
    foreach $item (@{$rule}) { $subrule.=join ' ', "-m", @{$item}, ''; }
    if (scalar @ip_rule>0)
    {
	$ip_rule[0]=~/^(!\s*)?(.+)$/;
	$neg=($1 ne '' ? '! ' : undef);
	$proto=check_proto($2);
	if ($proto eq "icmp")
	{
	    $subproto=$neg.$proto;
	    if ($ip_rule[5] ne "") { $subrule.="--icmp-type $ip_rule[5] "; }
	}
	elsif (($proto eq "tcp") || ($proto eq "udp"))
	{
	    if (($target =~ /-p $proto /) && $neg) { die "Rule should use either '$proto' or '!$proto'"; }
	    $subproto=$neg.$proto; 
	    if (index ($ip_rule[6],',')>=0)
	    {
		$subrule.="-m multiport --dports $ip_rule[6] ";
	    }
	    elsif ($ip_rule[6] ne "") { $subrule.="--dport $ip_rule[6] "; }
	    if (index ($ip_rule[5],',')>=0)
	    {
		if ($subrule =~ /-m multiport /) 
		{ 
		    $new_chain=new_chain($chain);
		    add_rule($table,$new_chain,add_proto($proto,"-m multiport --sports $ip_rule[5] $target"));
		    $target="-j $new_chain";
		}
		else
		{
		    $subrule.="-m multiport --sports $ip_rule[5] ";
		}
	    }
	    elsif ($ip_rule[5] ne "") { $subrule.="--sport $ip_rule[5] "; }
	}
	elsif ($proto ne 'ip')
	{
	    $subrule.=$neg.'-p '.$proto.' ';
	}
	for ($i=1; $i<=4; ++$i)
	{ 
	    if (scalar @{$ip_rule[$i]}==1) { $subrule.=gen_ip_nic($i,$ip_rule[$i][0]); }
	    elsif (scalar @{$ip_rule[$i]}>1) { ++$cart; }
	}
	for ($i=4; $i>0; --$i) 
	{
	    if (scalar @{$ip_rule[$i]}>1)
	    {
		if (--$cart)
		{
		    $new_chain=new_chain($chain);
		    foreach $item (@{$ip_rule[$i]}) { add_rule($table,$chain,gen_ip_nic($i,$item)."-j $new_chain"); }
		    $chain=$new_chain;
		}
		else { foreach $item (@{$ip_rule[$i]}) { push @cart,gen_ip_nic($i,$item); } }
	    }
	}
	if (scalar @cart==0) { add_rule($table,$chain,add_proto($subproto,"$subrule$target")); }
	else
	{
	    if (($subrule ne '') || ($subproto ne ''))
	    {
		$new_chain=new_chain($chain);
		add_rule($table,$chain,add_proto($subproto,"$subrule-j $new_chain"));
		$chain=$new_chain;
	    }
	    foreach $cart (@cart) { add_rule($table,$chain,"$cart$target"); }
	}
    }
    else { add_rule($table,$chain,"$subrule$target"); }
}

sub gen_rules
{
    my $table=shift @_;
    my $chain=shift @_;
    my @rules=@_;
    my @targets;
    my $rule;
    my $cond;
    my $cond_item;
    my $target;
    foreach $rule (@rules) 
    { 
	if (ref $rule ne 'ARRAY') { die "Rule should be array and not '$rule'"; }
	@targets=@{$rule};
	if (scalar @targets<2) { die "Rule '$targets[0]' should have at least a condition and a target"; }
	$cond=shift @targets;
	if (ref $cond eq 'HASH')
	{
	    if (scalar @targets!=2) { die "Map rule requires exactly two targets"; }
	    gen_rules($table,$chain,gen_map($cond,@targets)); 	
	}
	elsif (scalar @targets!=1) { die "Rule requires exactly one target"; }
	else
	{
	    $target=parse_target($table,$chain,$targets[0]);
	    if ($target eq '') { die "Rules with empty targets are foridden"; }
	    if (ref $cond eq 'ARRAY') 
	    { 
		foreach $cond_item (@{$cond}) { gen_rule($table,$chain,$cond_item,$target); } 
	    }
	    else { gen_rule($table,$chain,$cond,$target); }
	}
    }
}

sub gen_rules_all
{
    gen_rules('nat','PREROUTING', @n_pre);
    gen_rules('nat','POSTROUTING',@n_post);
    gen_rules('nat','OUTPUT',     @n_output);

    gen_rules('mangle','PREROUTING', @m_pre);
    gen_rules('mangle','POSTROUTING',@m_post);
    gen_rules('mangle','INPUT',      @m_input);
    gen_rules('mangle','FORWARD',    @m_forward);
    gen_rules('mangle','OUTPUT',     @m_output);

    gen_rules('filter','INPUT',  @f_input);
    gen_rules('filter','FORWARD',@f_forward);
    gen_rules('filter','OUTPUT', @f_output);
}

sub str2
{
    my $str=$_[0];
    if ($str<10) { $str='0'.$str; }
    return $str;
}

sub gen_iptables
{
    my $fname=shift;
    my @chains;
    my @lines;
    my @mtime;
    my $line;
    my $mtime;
    my $table;
    my $chain;
    my $policy;
    my $rule;
    my %def_policies = 
    (
	'nat' => {
	    'PREROUTING'  => 'ACCEPT',
	    'POSTROUTING' => 'ACCEPT',
	    'OUTPUT'      => 'ACCEPT'
	},
	'filter' => {
	    'INPUT'   => 'DROP',
	    'FORWARD' => 'DROP',
	    'OUTPUT'  => 'ACCEPT'
	},
	'mangle' => {
	    'PREROUTING'  => 'ACCEPT',
	    'POSTROUTING' => 'ACCEPT',
	    'INPUT'       => 'ACCEPT',
	    'FORWARD'     => 'ACCEPT',
	    'OUTPUT'      => 'ACCEPT'
	}    
    );
    foreach $table (keys %iptables)
    {
	@chains=sort {cmp_chain ($a,$b) } grep (ref $iptables{$table}{$_}, keys %{$iptables{$table}});
	push @lines, "*$table\n";
	foreach $chain (@chains)
	{
	    if (!defined $def_policies{$table}{$chain}) { $policy='-'; }
	    elsif (!defined $policies{$table}{$chain}) { $policy=$def_policies{$table}{$chain}; } 
	    else 
	    { 
		$policy=$policies{$table}{$chain};
		if (($policy ne 'ACCEPT') && ($policy ne 'DROP')) { die 'Wrong policy "$policy"'; }
	    }
	    push @lines, ":".translate_chain($chain)." $policy [0:0]\n";
	}
	foreach $chain (@chains) { foreach $rule (@{$iptables{$table}{$chain}}) { push @lines, "-A ".translate_chain($chain)." $rule\n"; } }
	push @lines, "COMMIT\n";
    }
    if ($fname eq "") { foreach $line (@lines) { print $line; } }
    else
    { 
	if (-f $fname)
	{
	    @mtime=stat($fname);
	    @mtime=localtime($mtime[9]);
	    $mtime=($mtime[5]+1900)."-".str2($mtime[4]+1)."-".str2($mtime[3])."_".str2($mtime[2]).":".str2($mtime[1]).":".str2($mtime[0]);
	    rename($fname,"$fname.$mtime");
	}
	open FILE, ">$fname" or die "Cannot open file '$fname'"; 
	foreach $line (@lines) { print FILE $line; }	
	close FILE; 
    }
}

gen_rules_all();
gen_iptables(@ARGV);
