#!/usr/bin/perl -w
use strict;
#use Smart::Comments;

=changelog

$Id: confread 342 2006-01-29 04:52:06Z daniel $

0.7
	Added 'if'
	Moved to svn

0.6
	Added the 'UNTRACKED' state

0.5
	Added 'regex'
	Fixed expansion of variables in the keys of a tree

0.4
	Added function 'icmpv6'

0.3 20051016
	Added new 'for' and 'tree' commands
	Removed 'outowner' because it was a special case of 'tree'
	Better internal representation of rules
	Added 'raw' table
	Drop root before reading config file

0.2 20050901
	Added function capabilities
	Dropped root privelages (if run with them)
	Added 'nat' table, move the old nat definitions to 'nat-def'

0.1
	Initial release

=cut

=info for v0.3
Copyright 2004-2005 Daniel De Graaf (danieldegraaf@gmail.com)
Released under GNU GPL, v2.0

This script takes input from a configuration file and produces an iptables ruleset.
The configuration file has the following format:

Any lines beginning with # (whitespace before does not matter) are ignored, as are blank lines
A section is identified by a word with no space in front of it
 All parts of that section are indented one (or more) spaces.

The following sections are defined as of v0.2:

filter (also known as action)
 <chain1>
  <rule1>
  <rule2>
 <chain2>
  ...
 This is the section where the iptables rules are defined. Each rule is a space-separated list of directives which either
 invoke a function, act as a target, or are copied onto the command line as-is.
 For example, the rule 'tcp 80 ACCEPT' will call the 'tcp' function which takes one argument (the port number or numbers)
 and will make the rule jump to the ACCEPT target. The rule would produce the following output: 
  -A INPUT -m tcp -p tcp --dport 80 -j ACCEPT
 More complex rules can be defined: 'in eth1 src 10.1.2.0/24 tcp 22,25,80 ACCEPT' would accept ssh,smtp,and http traffic from
 the subnet 10.1.2.*, but only if it comes in on the eth1 device.
 
 See the list of functions at the end of this page and the example scripts for more information

mangle
 same as fliter section, but the rules are inserted into the mangle table

nat
 same as filter section, but the rules are inserted into the nat table. Do not use with the 'nat-def' section.
 Note: not implemented as of v0.2

define
 <identifier> <text to replace with>
 Define creates variables that can be used for the remainder of the file. A variable is used with the syntax '$varname'
 For example, if the define section had 'mywebsrv 10.0.8.33', the rule 'dst $mywebsrv tcp 80 ACCEPT' would allow http traffic
 to 10.0.8.33.

function
 <name> { 
  perl subroutine
  }
 This section allows the config file to define its own functions or replace a built-in function with an altered one.
 This function can be used like a built-in function anywhere in the rule definitions. The perl code is passed one argument, a reference to an array of words, and returns a string. Any arguments used should be shifted off the list. Two example subroutines:
 limit {
  my $w = shift;
  my $t = shift @$w;
  my $i = shift @$w;
  "-m limit --limit-burst $t --limit $i";
 }						
 icmpv6 { "-p ipv6-icmp --icmpv6-type ".shift @{+shift}; }
 (the final closing brace can be indented either one or two spaces depending on your programming style)

policy
 <table>
  <chain> <action>
 Defines the policy (iptables -P <chain> <action>) for the given table. If none specified, assume filter
 If this section is not present, the default of ACCEPT is used.

nat-def
 defines a NAT router (do not use nat section if this section is used).
 This section has 2 subsections called 'snat' and 'dnat'. 
 snat
  <outbound interface> <ip to SNAT traffic to>
 dnat
  <private ip address>
   in <incoming interface>
   tcp <ports to forward>
   udp <ports to forward>

mport multiport
 this section takes only one argument, which must be on the same line. 
 This is the module (mport or multiport) that is loaded when multiple TCP or UDP ports are specified in one rule

ulogq 1
 this section takes only one argument, which must be on the same line. 
 This is the queue-threshold for the 'log' match: see the ULOG section of man iptables for more information

ipv6
 this section takes no arguments. If it is present, ip6tables-restore will passed the rules instead of iptables-restore
 This argument is the same as the '6' command-line option


Functions:
 Note: most functions are not documented, because they are simple. See the examples for a better howto. 
 Read man iptables and the function definitions below for more information. Or you could help write the help file ;)

 tcp <portlist>
  matches tcp destination ports. If the list contains a comma, the mport match is used (this can be changed by the 'mport' section)
 src <ip address, subnet, or range>
  matches source ip address. This can be any of '10.0.2.0/24', '10.0.2.8', '10.0.2.7-10.0.2.10', '10.0.0.1/255.0.255.255'
 tcp_f [!] <flags to check> <what to check for>
  --tcp-flags
 
Looping functions
 for <var> <item1>,<item2>,...,<itemN>
  <statement1>
  <statement2>
 Repeats the block of statements, assigning 'var' to each item in turn.

 tree <var> <expression involving var>
  <value1>
   <statement1>
   <statement2>
  <value2>
   <statement1>
 Prepends 'expression' to each statement, setting 'var' to be 'value'. An expanded form of 'for'
 Example:
 	tree o own $o
	 root
	  ACCEPT
	 www-data
	  log www-egress
	  DROP
 
 map <perl statement>
  statements
 Executes the perl statement (usually something like s/this/that/) before each statement

 if <perl expr>
  statements
 Executes the following statements only if the expression is true

=cut

#############################################################
# Global variables and subs
#############################################################

my ($suid,$mport,$ulogQ,$ipv6) = (65534,'multiport',1,0);

sub mkips { $_[1] =~ /\-/ ? "-m iprange --$_[0]-range $_[1]" : "--$_[0] $_[1]"; }
sub mkports { ($_[0] =~ /,/ ? "-m $mport --dports " : "--dport ").$_[0]; }
sub mksports { ($_[0] =~ /,/ ? "-m $mport --sports " : "--sport ").$_[0]; }

our (%filter,%nat,%mangle,%raw); #for non-strict refs
my (%tbl,%pol,%def,%dnat);

#############################################################
# Begin action definitons
#############################################################

my %actf = (
#Basic rule components
	'not' => sub { '!'; },
	'!' => sub { '!'; },
#network layer
	in => sub {
		'-i '.shift @{+shift};
	},
	in_ph => sub {
	    '-m physdev --physdev-in '.shift @{+shift};
	},
	out => sub {
		'-o '.shift @{+shift};
	},
	out_ph => sub {
		'-m physdev --physdev-out '.shift @{+shift};
	},
	mac => sub {
		'-m mac --mac-source '.shift @{+shift};
	},
#IP header
	dst => sub {
		mkips 'dst', shift @{+shift};
		#' -d '.shift @{+shift};
	},
	src => sub {
		mkips 'src', shift @{+shift};
		#' -s '.shift @{+shift};
	},
	prot => sub {
		'-p '.shift @{+shift};
	},
	dscp => sub {
		'-m dscp --dscp '.shift @{+shift};
	},
	tos => sub {
		'-m tos --tos '.shift @{+shift};
	},
	ttl => sub {
		'-m ttl --ttl-eq '.shift @{+shift};
	},
	'ttl>' => sub {
		'-m ttl --ttl-gt '.shift @{+shift};
	},
	'ttl<' => sub {
		'-m ttl --ttl-lt '.shift @{+shift};
	},
#protocol layer
	tcp => sub {
		'-p tcp -m tcp '.mkports shift @{+shift};
	},
	udp => sub {
		'-p udp -m udp '.mkports shift @{+shift};
	},
	tcp_s => sub {
		'-p tcp -m tcp '.mksports shift @{+shift};
	},
	udp_s => sub {
		'-p udp -m udp '.mksports shift @{+shift};
	},
	icmp => sub {
		'-m icmp -p icmp --icmp-type '.shift @{+shift};
	},
	icmpv6 => sub {
		'-p ipv6-icmp --icmpv6-type '.shift @{+shift};
    },
	tcp_f => sub {
		my $e = shift;
		my $f = shift @$e;
		$f = '! '.shift @$e if $f eq '!' || $f eq 'not';
		"-m tcp -p tcp --tcp-flags $f ".shift @$e;
	},
	tcp_syn => sub {
		'-m tcp -p tcp --tcp-flags SYN,RST,ACK SYN';
	},
	tcp_mss => sub {
		'-m tcp -p tcp --mss '.shift @{+shift};
	},
#targets
	'log' => sub {
		"-j ULOG --ulog-qthreshold $ulogQ --ulog-prefix ".shift @{+shift};
	},
	reject => sub {
		'-j REJECT --reject-with '.shift @{+shift};
	},
	class => sub {
		'-j CLASSIFY --set-class '.shift @{+shift};
	},
#NAT
	snat => sub {
		my $e = '-j SNAT';
		$e .= " --to-source $_" for split /,/, shift @{+shift};
		$e				 
	},
	'_dnat' => sub {
		my $p = shift @{+shift};
		"-p $p -m $p ".mkports $dnat{$p};
	},
#condition
	check => sub {
		'-m condition --condition '.shift @{+shift};
	},
#connrate
	rate => sub {
		'-m connrate --connrate '.shift @{+shift};
	},
#conntrack (+)
	cstate => sub {
		'-m conntrack --ctstate '.shift @{+shift};
	},
#dstlimit
#fuzzy
#geoip
#helper
#ipp2p
#length
	len => sub {
		'-m length --length '.shift @{+shift};
	},
#limit
	limit => sub {
		my $e = shift;
		my($t,$i) = (shift(@$e),shift @$e);
		"-m limit --limit-burst $t --limit $i";
	},
#mark
#nth
	osf => sub {
		'-m osf --smart --genre '.shift @{+shift};
	}
    osflog => sub {
		'-m osf --log 0';
	},
#owner
	own => sub {
		'-m owner --uid-owner '.shift @{+shift};
	},
	owng => sub {
		'-m owner --gid-owner '.shift @{+shift};
	},
#	ownp,owns,ownc broken on SMP so they should die.
#pkttype
#quota
#random
    rnd => sub {
		'-m random --average '.shift @{+shift};
	},
#set
#state
	state => sub {
		local $_ = shift @{+shift};
		s/r/RELATED/; 
		s/e/ESTABLISHED/;
		s/i/INVALID/;
		s/n/NEW/;
		s/u/UNTRACKED/;
		"-m state --state $_";
	},
#recent
	detrip => sub {
		'-m recent --remove --name '.shift @{+shift};
	},
	trip => sub {
		'-m recent --set --name '.shift @{+shift};
	},
	ban => sub {
		my $e = shift;
		my($c,$n,$s) = (shift(@$e),shift(@$e),shift @$e);
		"-m recent --update --hitcount $c --name $n".($s ? " --seconds $s" : '');
	},
	key => sub {
		my $e = shift;
		my($n,$s) = (shift(@$e),shift @$e);
		"-m recent --rcheck --name $n".($s ? " --seconds $s" : '');
	},
	unclean => sub { '-m unclean';},
);

#############################################################
# Begin conf-file read code
#############################################################

sub despc { local $_ = shift; s/\s/#2/g; $_; }

sub varsub {
	${$_[0]} =~ s/(^|[^\\])\$([a-z0-9A-Z]+)/$1.(exists $def{$2} ? $def{$2} : '$'.$2)/eg;
}

#handle spaces in quotes while splitting into words
sub qsplit {
	local $_ = shift;
	varsub \($_);
	s/#/#0/g; s/\\'/#1/g; 
	s/'(.*?)'/despc $1/eg; 
	s/\\\s/#2/g;
	map {
		s/#2/ /g; 
		s/#1/'/g; 
		s/#0/#/g; 
		$_
	} split /\s+/;
}

#read hash of lists (of lists of...) of strings
sub readl {
	local $_;
	my @c = @{+shift};
	my $l = shift;
	my @stk = [[]];
	while ($$l < $#c) {
		$_ = $c[++$$l];
		chomp;
		next if /^\s*#/ || /^\s*$/;
		$$l--, last if /^\S/;
		s/^(\s*)//;
		my $v = length $1;
		#my @q = qsplit;
		shift @stk while ($v < @stk);
		if ($$l < $#c && $c[$$l+1] =~ /^\s{$v}(\s+)/) {
			#we have a sub-entry
			for my $i (1..length $1) {
				my $e = [$_];
				push @{$stk[0]}, $e;
				unshift @stk, $e;
			}
		} else {
			push @{$stk[0]}, $_;
		}
	}
	@stk = @{pop @stk};
	my %r;
	@$_ and $r{shift @$_} = $_ for @stk;
	\%r;
}

#read hash of hash of...string value for the rest of the line
#needs error checking for bad indentation
sub readh {
	local $_;
	my @c = @{+shift};
	my $l = shift;
	my @stk = {};
	while ($$l < $#c) {
		$_ = $c[++$$l];
		next if /^\s*#/ || /^\s*$/;
		$$l--, last if /^\S/;
		s/^(\s*)//;
		my $v = length $1;
		my ($q0,@q) = qsplit $_;
		shift @stk while ($v < @stk);
		if (@q) {
			$stk[0]{$q0} = join ' ', @q; #put a value on the end of the stack
		} else {
			unshift @stk, ($stk[0]{$q0} = {}) while ($v > $#stk);
		}
	}
	pop @stk;
}

sub readfunc {
	local $_;
	my @c = @{+shift};
	my($l,$n,$x) = shift;
	while ($$l < $#c) {
		$_ = $c[++$$l];
		next if /^\s*#/;
		if (/^\S/) {
			$$l--;
			$actf{$n} = eval "sub $x" if defined $n;
			return;
		}
		s/^ }/  }/;
		s/^(\s*)//;
		if (1 == length $1) {
			$actf{$n} = eval "sub $x" if defined $n;
			$x = '';
			s/(\S+)\s*//;
			$n = $1;
		}
		$x .= $_;
	}
}

sub readdef {
	my %tp = %def = %{readh @_};
	my $foo; #prevent infinite loop
	$def{$_} =~ /\$/ or delete $tp{$_} for keys %tp;
	while (%tp && $foo++ < 20) {
		for (keys %tp) {
			varsub \($def{$_});
			$def{$_} =~ /\$/ or delete $tp{$_};
		}
	}
}

sub readconf {
	local $_;
	my $conf= shift;
	my @cfg = <$conf>;
	close $conf;

	my ($l,%oown,%natdef);
	my @p = (\@cfg,\$l);
	for ($l=0; $l < @cfg; $l++) {
		$_ = $cfg[$l];
		s/^action/filter/;
		last if /^EOF/;
	#options
		/^mport (.*)/ ? ($mport = $1) :
		/^ulogq (.*)/ ? ($ulogQ = $1) :
		/^ipv6/       ? ($ipv6 = 1) : 
	#definitions
		/^define/     ? readdef @p:
		/^function/   ? readfunc @p:
		/^policy/     ? (%pol    = %{readh @p}) :
	#auto rule creation
		/^nat-def/    ? (%natdef = %{readh @p}) :
#		/^outowner/   ? (%oown   = %{readl @p}) :		
	#tables
		/^(\S+)/      ? ($tbl{$1} = readl @p) :
#		/^mangle/     ? (%mangle = %{readl @p}) :
#		/^nat/        ? (%nat    = %{readl @p}) :
#		/^raw/        ? (%raw    = %{readl @p}) :
	#other
		undef; #undef will prevent 'useless use of scalar in void context' warnings.
	}
	@cfg = (); #free that memory NOW

	### Config file read...
	
#########################
# Post-read processing
# Set default ACCEPT policy on all chains
#########################
	exists $pol{filter}{$_} or $pol{filter}{$_} = $pol{$_} || 'ACCEPT' for qw/INPUT OUTPUT FORWARD/;
	exists $pol{mangle}{$_} or $pol{mangle}{$_} = 'ACCEPT' for qw/INPUT OUTPUT FORWARD PREROUTING POSTROUTING/;
	exists $pol{nat}{$_} or $pol{nat}{$_} = 'ACCEPT' for qw/OUTPUT PREROUTING POSTROUTING/;
	exists $pol{raw}{$_} or $pol{raw}{$_} = 'ACCEPT' for qw/OUTPUT PREROUTING/;

#rule creation sections
#	if (values %oown && !exists $filter{outowner}) {
#		my @w;
#		for my $o (keys %oown) {
#			for my $r (@{$oown{$o}}) {
#				push @w, "own $o $r";
#			}
#		}
#		$filter{outowner} = \@w;
#	}
	if (values %natdef && !values %nat) {
		### processing nat section...
		my ($t,$u) = ('','');
		for (values %{$natdef{dnat}}) {
			my %q = %{$_};
			$t .= $q{tcp}.',' if $q{tcp};
			$u .= $q{udp}.',' if $q{udp};
		}
		$t =~ s/,$//; $u =~ s/,$//;
		%dnat = ( tcp => $t, udp => $u );

		push @{$nat{POSTROUTING}}, "-o $_ SNAT --to-source $natdef{snat}{$_}" 
			for keys %{$natdef{snat}};

		for (keys %{$natdef{dnat}}) {
			my %t = %{$natdef{dnat}{$_}};
			push @{$nat{PREROUTING}}, "in $t{in} DNAT '--to-destination $_' tcp $t{tcp}"
				if exists $t{tcp};
			push @{$nat{PREROUTING}}, "in $t{in} DNAT '--to-destination $_' udp $t{udp}"
				if exists $t{udp};
		}

		for (keys %{$natdef{self}}) {
			my %t = %{$natdef{self}{$_}};
			push @{$nat{PREROUTING}}, "in $t{in} REDIRECT '--to-ports $_' tcp $t{tcp}"
				if exists $t{tcp};
			push @{$nat{PREROUTING}}, "in $t{in} REDIRECT '--to-ports $_' udp $t{udp}"
				if exists $t{udp};
		}
	}
}

#############################################################
# End conf-file read
# Begin output
#############################################################
sub evalout;
sub evalout {
	my($I,$r,$e,$chs) = @_;
	my ($c,%md)=$r;
	local $_;
	if (ref $e) {
		$_ = shift @$e;
		if (/^for / || /^list /) {
			my ($v,$lvar,@rest) = qsplit $_;
			my @over = split /,/, join ' ', @rest;
			for $v (@over) {
				$def{$lvar} = $v;
				evalout $I,$r,$_,$chs for @$e;
			}
		} elsif (s/^tree\s+//) {
			s/^(\S+)\s*//; my $lvar = $1;
			my $cmd = $_;
			for my $branch (@$e) {
				$def{$lvar} = shift @$branch;
				varsub \($def{$lvar});
				evalout $I,$r,$cmd.' '.$_,$chs for @$branch;
			}
		} elsif (/^map\s+(.*)/) {
			my $cmd = $1;
			for (@$e) {
				eval $cmd;
				evalout $I,$r,$_,$chs;
			}
		} elsif (/^if\s+(.*)/) {
			my $cond = $1;
			varsub \$cond;
			return unless eval $cond;
			evalout $I,$r,$_,$chs for @$e;
		} else {
			die "bad sublist $_\n";
		}
	} else {
		my @e = qsplit $e;
		while (@e) {
			$_ = shift @e;
			$r .= ' ' . ( 
			   exists $$chs{$_} ? "-j $_" :		     #if there is an chain, jump to that
			   exists $actf{$_} ? &{$actf{$_}}(\@e) :#if there is a function, do that
			   /^[A-Z]+$/ ? "-j $_" : $_);		     #if it is a single uppercase word, assume it is a builtin target
		}											 #otherwise it is a raw command

		$r =~ s/ -m (tcp|udp) -m $mport / -m $mport /g; #if you really want both, put an extra space in there
		$r =~ s/ -m (\S+) /$md{$1}++ ? ' ' : " -m $1 "/eg; #don't include a module twice
		$r =~ s/ ! -m (\S+) / -m $1 ! /g;
		print $I "$r\n" unless $r eq $c;
	}
}

sub mkact {
	local $_;
	my ($I,$chs) = @_;
	for my $chain (keys %$chs) {
		for my $e (@{$chs->{$chain}}) {
			evalout $I, "-A $chain", $e, $chs;
		}
	}
}

#############################################################
# End output
#
# Main program
#############################################################

my $ip6pid = open my $ip6r, '|ip6tables-restore';
my $ip6er = $!;
my $ip4pid = open my $ip4r, '|iptables-restore';
my $ip4er = $!;

#############################################################
# Get arguments and read config file
#############################################################

$_ = shift || 'ipt.conf';
my $cf;

if (/^-/) {
	open $cf, shift || 'ipt.conf' or die "Could not open config file: $!";
} else {
	open $cf, $_ or die "Could not open config file: $!";
	$_ = '';
}

#drop to uid nobody if we are root
unless ($>) {
	$( = $suid; $) = "$suid $suid";
	($<,$>) = ($suid,$suid);
}

readconf $cf;

$_ .= shift while @ARGV;

$ipv6 += /6/; #so just nobody make it negative, alright?

my $I;
/o/ && do {
	open $I, '>-' or die "You have major problems: $!";
	close $ip6r;
	close $ip4r;
} || /v/ && do {
	open $I, '|ipt-trace' or die "Can't open ipt-trace: $!";
	close $ip6r;
	close $ip4r;
} || $ipv6 && do {
	$I = $ip6r;
	close $ip4r;
	$ip6pid or die "Error opening ip6tables-restore: $ip6er";
} || do {
	$I = $ip4r;
	close $ip6r;
	$ip4pid or die "Error opening iptables-restore: $ip4er";
};

#############################################################
# Go!
#############################################################

for my $tname (keys %tbl) {
	my $t = $tbl{$tname};
	my $p = $pol{$tname};
	if (values %$t) {
		exists $$t{$_} or $$t{$_} = [] for keys %$p;
		print $I "*$tname\n";
		print $I ":$_ ". ($$p{$_} || '-') . " [0:0]\n" for sort keys %$t;
		mkact $I, $t;
		print $I "COMMIT\n";
	}
}
	
=old

for my $tbl (qw/filter mangle nat raw/) {
	no strict 'refs';
	my $t = *$tbl;
	if (values %$t) {
		exists $$t{$_} or $$t{$_} = [] for keys %{$pol{$tbl}};
		print $I "*$tbl\n";
		print $I ":$_ ". ($pol{$tbl}{$_} || '-') . " [0:0]\n" for sort keys %$t;
		mkact $I, $t;
		print $I "COMMIT\n";
	}
}

=cut

close $I;
exit $? >> 8; #pass exit value of that command to our caller