#!/usr/bin/perl 
#
# Copyright (C) 2005-2006 Daniel De Graaf
#
# Released under the GNU GPL (http://www.gnu.org/licenses/gpl.txt)
# 
# $Id: ipt-trace 716 2006-07-22 02:24:55Z daniel $
use strict;
use IPTables 'load';

my $sw = @ARGV && $ARGV[0] =~ /^-/ ? shift : '';

if ($sw =~ /h/) {
	print 'traces packets through an iptables-save file',
	"\nUse: $0 [-evdtf] [table chain] [exprfile] [ruleset]",'
        -v               print the rules as they are passed by the packet
        -d               print debugging information on the outcome of each match
        -e               expression mode - input the last line from a previous run
        -f exprfile      expression mode with a file as input; each line of the file that starts
                         with one of [iolf] will be interpreted as an input line.
        -t table chain   start in given table and chain
                         ex: -t filter INPUT
        ruleset          a file containing the output of "itpables-save"
                         if not specified and uid=0, uses the current table
';
	exit 0;
}

my ($manT,$manC) = (shift,shift) if $sw =~ /t/;
my $exprfile = shift if $sw =~ /f/;

open my $I, shift || ($> ? die 'please specify a ruleset' : 'iptables-save|') or die "Error getting ruleset: $!";
	#get the real table if we're root, otherwise try a default filename

my $tbl = load $I;
normalize $tbl;

close $I;

my @direct = qw(in-interface out-interface physdev-in physdev-out protocol uid-owner gid-owner icmp-type);
	#must match exactly. I'll implement interfaces like 'eth+' later, like when I ever find a script that uses it...
my @lists  = qw(state dport sport);
	#contains lists of the form value1,value2,value3 - the packet matches if it matches one of the values
my @ignores= qw(match name seconds rsource hitcount log-level set-ttl set-dscp set-tos);
	#don't ask the user about these or tell the user about them
my @targetp= qw(jump goto ulog-qthreshold ulog-prefix log-prefix reject-with to-source to-destination 
                log-ip-options log-uid log-tcp-sequence log-tcp-options limit-burst);

$|=0;

my %info;
my %manual;

sub inlist {
	local $_;
	my ($l,$e) = @_;
	$_ eq $e && return 1 for split /,/,$l;
	0;
}

sub ip6tolist {
	local $_ = shift;
	s/::/:0::/ or die "um, bad ipv6 addr" until /:.*:.*:.*:.*:.*:.*:/;
	s/::/:0:/; s/:$/:0/;
	my @e = split /:/;
	map $_ = hex $_, @e;
	@e;
}

sub ipmatch {
	local $_;
	return 0 unless shift =~ m#(.*)/(.*)#;
	my ($a,$b,$m) = (shift,$1,$2);
	if ($a =~ /:/) {
		my @a = ip6tolist $a;
		my @b = ip6tolist $b;
		my @m = (0,0,0,0,0,0,0,0);
		if ($m =~ /:/) {
			@m = ip6tolist $m;
		} else {
			$m[$_] = 65535 for 0..$m/16;
			$m[$m/16] = 65536-(1 << 16-$m%16);
		}
		if ($sw =~ /d/) {
			print "[$a[$_]=$b[$_]/$m[$_] ".(($a[$_] & $m[$_]) != ($b[$_] & $m[$_])).']' for 0..7;
		}
		($a[$_] & $m[$_]) != ($b[$_] & $m[$_]) and return 0 for 0..7;
	} else {
		my @a = split /\./,$a;
		my @b = split /\./,$b;
		my @m = split /\./,$m;
		map {$_ = 0+$_} @m; 
			#you get very bad errors - comment this out, use -d, and go through a ruleset
			#with '-A INPUT -d 0.0.0.0/0.0.0.255 -j DROP' and packet dst=1.2.3.4
		if ($sw =~ /d/) {
			print "[$a[$_]=$b[$_]/$m[$_] ".($a[$_] & $m[$_]).'='.($b[$_] & $m[$_]).' '.
				(($a[$_] & $m[$_]) != ($b[$_] & $m[$_])?'n':'y').']' for 0..3;
		}
		(($a[$_] & $m[$_]) != ($b[$_] & $m[$_])) and return 0 for 0..3;
	}
	1;
}

sub tcp_flag {
	local $_ = shift;
	s/NONE//g;
	my ($n,$m,$e) = /(!?) *(\S*) +(\S*)$/;
	my $p = shift;
	print "[$n$p=$e/$m]" if $sw =~ /d/;
	for (qw(SYN ACK FIN RST URG PSH)) {
		next unless $m =~ /$_/;
		print "[$_:", (($e =~ /$_/) xor ($p =~ /$_/)) ? 'n]':'y]' if $sw =~ /d/;
		next unless ($e =~ /$_/) xor ($p =~ /$_/);
		return $n eq '!';
	}
	return $n ne '!';
}

sub ttl_test {
	local $_ = shift;
	my $u = shift;
	my ($op,$v) = /([a-z]+)-([0-9]+)/ or warn "bad TTL syntax: $_";
	return 
		$op eq 'lt' ? $u < $v : 
		$op eq 'gt' ? $u > $v :
		$op eq 'eq' ? $u ==$v :
		warn "unknown operation '$op' for TTL";
}

sub check {
	my($m,$t)=@_;
	my $u = $info{$m};
	# m = match
	# t = rule text
	# u = user text
	return ($u =~ /y/) if $m eq 'f' || $m =~ /:/;           # : is recent
	($m eq 'TTL') && return ttl_test $t,$u;                 # TTL must go up here, because a direct match may not mean anything
	
	return 1 if $t eq $u;	                                # direct match?
	$m eq $_ and return 0 for @direct;                      # these must be direct
	$m eq $_ and return inlist $t,$u for @lists;            # these are a list
	($m eq 'src' || $m eq 'dst') && return ipmatch $t,$u;   # must be direct unless it has a mask
	($m eq 'tcp-flags') && return tcp_flag $t,$u;
	return $manual{$m}{$t} if exists $manual{$m}{$t};

	print "$m: does '$t' match '$u'? (y/N) ";
	$manual{$m}{$t} = (<> =~ /y/);
}

sub askmatch {
	local $_;
	my ($m,$t) = @_;
	if ($m eq 'limit') {
		print "limit $t (Y/n)? ";
		return !(<> =~ /n/);
	} elsif (!exists $info{$m})  {
		print "$m=";
		<> =~ /(.*)/;
		$info{$m} = $1;
	}

	print "\e[1;35m$m '$t' = '$info{$m}': " if $sw =~ /d/;
	my $e = !check @_;
	print ' '.($e?'n':'y')."\e[m\n" if $sw =~ /d/;
	!$e;
}

sub xchn;

sub pxchn {
	return unless exists $_[1]{$_[0]};
	print "\e[1mFall:$_[1]{$_[0]}[0]{_POLICY} policy\e[m\n" unless xchn @_;
}

sub xchn {
	local $_;
	my $chain = shift;
	my $rule = shift;
	unless (exists $$rule{$chain}) {
		print "\e[1mExit to $chain\e[m\n" if $sw =~ /d/;
		return 1;
	}
	my @chn = @{$$rule{$chain}};
	print "\e[1mEnter chain $chain\e[m\n" if $sw =~ /d/;
	LINE: for my $line (@chn) {
		my %l = %$line;
		next if exists $l{_POLICY};
		print "\e[1;32m$l{_RULE}\e[m\n" if $sw =~ /[vd]/;
		my $ex;
		$l{jump} = $l{goto} if defined $l{goto}; #I don't really want to rewrite everything to use both
		next unless exists $l{jump};
		MATCH: for my $m_real (@{$l{_MATCHES}}) {
			my($m,$v) = ($m_real,$l{$m_real});
			$m =~ s/^~//g;
			$_ eq $m and next MATCH for @ignores;
			$_ eq $m and ($ex .= "$m:$v "), next MATCH for @targetp;
			if ($m eq 'set') {
				$ex .= "recent module sets $l{name}";
				next MATCH;
			}
			$m .= ':'.($l{name} || 'DEFAULT') if $m eq 'rcheck' || $m eq 'update';
			if ($m =~ s/^ttl-(.*)/TTL/) {
				$v = "$1-$v";
				print "Modifying TTL match: $v\n" if $sw =~ /d/;
			} 
			my $not = $m =~ s/^!//;
			next LINE unless $not xor askmatch $m, $v;
		}
		print "\e[1m$ex\e[m\n" if defined $ex;
		
		if ($l{jump} eq 'LOG' || $l{jump} eq 'ULOG') {
			next LINE;
		} elsif ($l{jump} eq 'DNAT') {
			$_ = $l{to} || $l{'to-destination'};
			$info{_dport} = $info{dport};
			$info{_dst} = $info{dst};
			$info{dport} = $1 if /:([0-9]+)/;
			$info{dst} = $1 if /^([0-9.]+)/;
		} elsif ($l{jump} eq 'SNAT') {
			$_ = $l{to} || $l{'to-source'};
			$info{_sport} = $info{sport};
			$info{_src} = $info{src};
			$info{sport} = $1 if /:([0-9]+)/;
			$info{src} = $1 if /^([0-9.]+)/;
		} elsif ($l{jump} eq 'MASQUERADE') {
			print "Address to masquerade to:";
			<> =~ /(.*)/ or return 1;
			$info{dst} = $1;
		} elsif ($l{jump} eq 'NOTRACK') {
			$info{state} = 'UNTRACKED';
		} elsif ($l{jump} eq 'RETURN') {
			return 0;
		}
		return 1 if xchn $l{jump}, $rule;
		return 0 if defined $l{goto}; #goto means RETURN if it ever comes back
	}
	return 0;
}

sub ask_state {
	return if defined $info{state};
	print "state (NEW,RELATED,ESTABLISHED,INVALID)=";
	$_ = <>;
	chomp;
	s/n/NEW/; s/e/ESTABLISHED/; s/r/RELATED/;s/i/INVALID/;s/u/UNTRACKED/;
	$info{state} = $_;
}

sub line {
	my $t = shift;
	return unless $t =~ /[ifol]/i;

	if (keys %info) {
		print "\e[1;31m$t";
		print " $_=$info{$_}" for sort keys %info;
		print "\e[m\n";
	}

	if ($t eq 'l') {
		$info{'out-interface'} = $info{'in-interface'} = 'lo';
		pxchn OUTPUT => $$tbl{raw};
		my $nat = ask_state;
		pxchn OUTPUT => $$tbl{mangle};
		pxchn OUTPUT => $$tbl{nat} if $nat;
		pxchn OUTPUT => $$tbl{filter};
		pxchn POSTROUTING => $$tbl{mangle};
		pxchn POSTROUTING => $$tbl{nat} if $nat;
		pxchn PREROUTING => $$tbl{mangle}; #verify that this is correct
		pxchn INPUT => $$tbl{mangle};
		pxchn INPUT => $$tbl{filter};
	} elsif ($t eq 'i') {
		pxchn PREROUTING => $$tbl{raw};
		my $nat = ask_state;
		pxchn PREROUTING => $$tbl{mangle};
		pxchn PREROUTING => $$tbl{nat} if $nat;
		pxchn INPUT => $$tbl{mangle};
		pxchn INPUT => $$tbl{filter};
	} elsif ($t eq 'o') {
		pxchn OUTPUT => $$tbl{raw};
		my $nat = ask_state;
		pxchn OUTPUT => $$tbl{nat} if $nat;
		pxchn OUTPUT => $$tbl{filter};
		pxchn POSTROUTING => $$tbl{mangle};
		pxchn POSTROUTING => $$tbl{nat} if $nat;
	} elsif ($t eq 'f') {
		pxchn PREROUTING => $$tbl{raw};
		my $nat = ask_state;
		pxchn PREROUTING => $$tbl{mangle};
		pxchn PREROUTING => $$tbl{nat} if $nat;
		pxchn FORWARD => $$tbl{mangle};
		pxchn FORWARD => $$tbl{filter};
		pxchn POSTROUTING => $$tbl{mangle};
		pxchn POSTROUTING => $$tbl{nat} if $nat;
	}
	print "\e[1;36m$t";
	print " $_=$info{$_}" for sort keys %info;
	print "\e[m\n"
}

if ($sw =~ /t/) {
	xchn $manC, $$tbl{$manT};
	exit;
} elsif ($sw =~ /e/) {
	print '> ';
	my ($t, $e) = (<> =~ /^(\S)\S* +(.*)/);
	/(.*?)=(.*)/ and $info{$1}=$2 for split /\s+/, $e;
	line $t;
} elsif ($sw =~ /f/) {
	open F, $exprfile or die "Can't open exprfile: $!";
	my %prev;
	my %persist;
	while (<F>) {
		chomp;
		print "\e[33;1m$_\e[0m\n";
		my ($t, $e) = /^(\S)\S* +(.*)/;
		eval $e if $t eq '!';
		if ($t eq 'm') { #map
			for (split /\s+/, $e) {
				/(.*?)=(.*)/;
				$info{$1} = $prev{$2} if defined $prev{$2};
			}	
		} elsif ($t eq 's') { #store
			for (split /\s+/, $e) {
				/(.*?)=(.*)/;
				$persist{$1} = $prev{$2} if defined $prev{$2};
			}
		} elsif ($t eq 'r') { #restore/recall
			for (split /\s+/, $e) {
				/(.*?)=(.*)/;
				$info{$1} = $persist{$2} if defined $persist{$2};
			}
		}
		next unless $t =~ /[ifol]/i;
		/(.*?)=(.*)/ and $info{$1}=$2 for split /\s+/, $e;
		line $t;
		%prev = %info;
		%info = ();
	}
	close F;
} else {
	print "Packet type (in, forwarded, out, local)? ";
	<> =~ /(.)/;
	line $1;
}