#!/afs/athena/contrib/perl5/p -w

use strict;
use Carp;
use DataDump;
use FileHandle;
use Socket;

use vars qw( $debug $packet $data @data $a $i %ethertype %ipproto );
use vars qw( %ip_frags %ip_complete %tcp_conn $tmp @args );

select(STDERR);			# make printout go to stderr by default
autoflush STDERR 1;		# make STDERR unbuffered

@ARGV || die "usage: $0 filename [snoop_filters]\nquitting";
$debug = 20;

map {s%'%\\'%g; s%^%'%; s%$%'%} (@args=@ARGV);
open (SNOOP, "/usr/sbin/snoop -x0 -i @args |") || die "can't run snoop";

while ($packet = parse_header(scalar(<SNOOP>))) {
  my $p = '';
  data_read($packet)
    && ether_data($packet)
      && ($p = apple_print_data($packet));
  print STDOUT $p if $p;
}

close(SNOOP);

# parse_header($line_of_data)  --  parses the snoop packet header into fields.
#    returns: a reference to a hash containing various fields.
sub parse_header {
  my ($header) = @_;
  $header || return undef;
  $header =~ s/^\s+//;
  $header =~ s/\s+$//;
  my ($data, $i) = {'raw' => $header};

  my ($n, $t, $host1, $arrow, $host2, $type, @rest)
    = split(/\s+/, $header);

  $data->{'num'} =   $n;
  $data->{'time'} =  $t;
  $data->{'src_host'} = $host1;
  $data->{'dst_host'} = $host2;
  $data->{'type'} =  $type;

 ARG:
  for $i (@rest) {
    ($i =~ /=/) || (warn "Weird field: $i\ncontinuing", next ARG);
    $data->{$`} = $';			# '
  }
  $data;
}

# data_read(\%packet)  --  read in packet body and store raw data
#    side effects: stores data in %packet
#    returns: packed raw data
sub data_read {
  my $packet = shift || {};
  local $_;
  my ($raw, $data, $type) = '';

  (scalar(<SNOOP>) =~ /^\s+$/)
    || die "Separator line is not blank: <$_>\nbarfing";

  while (($_ = <SNOOP>) && !/^\s+$/) {
    /^\s+\d+:((\s+[0-9a-zA-Z]{4}){1,8})\s+/ || die "parse error: '$_'";
    ($data = $1) =~ s/\s+//g;

    $raw .= pack("H*", $data);
  }

  $type = ((vec($raw, 12*8, 16) <= 0x05dc) ? '802.3' : 'ether');

  $packet->{$type} = {} unless $packet->{$type};
  $packet->{$type}{'data'} = $raw;
}

BEGIN { %ethertype = ('0800' => 'ip', '0806' => 'arp', '8035' => 'rarp',
		      '021d' => 'AppleHack'); }

# ether_data(\%packet)  --  read raw Ethernet data and determine protocol
#    side effects: stores data and header fields in %packet
#    returns: packed IP or other network-protocol data inside Ethernet packet
sub ether_data {
  my ($packet) = @_;
  my ($ether) = $packet->{'ether'} || return undef;
  my ($eth_src, $eth_dst, $type, $body)
    = unpack("H12 H12 H4 a*", $ether->{'data'});

  $ether->{'src'} = join(":", unpack("A2"x6, $eth_src));
  $ether->{'dst'} = join(":", unpack("A2"x6, $eth_dst));
  $ether->{'type'} = $type;

  my ($xtype) = $ethertype{$type};

  printf "  ether: %s -> %s [%s]\n", $ether->{'src'}, $ether->{'dst'},
	 ($xtype ? "\U$xtype" : "type $type")
	   if ($debug >= 12);

  if ($xtype) {
    $packet->{$xtype} = {} unless $packet->{$xtype};
    $packet->{$xtype}{'data'} = $body;
  } else {
    $body;
  }
}

# glue(@bytes)  --  re-assemble several bytes into a multi-byte numeric value
#    returns: the glued value
sub glue {
  my $i = 0;
  grep(($i <<= 8) |= $_, @_);
  $i;
}

BEGIN { %ipproto = (1 => 'icmp', 4 => 'ip-in-ip', 6 => 'tcp', 17 => 'udp'); }

# ip_data(\%packet)  --  read IP data, determine protocol, reassemble if needed
#    side effects: stores data and header fields in %packet
#    returns: contents of IP packet, as an array of bytes
sub ip_data {
  my ($packet) = @_;
  my ($ip) = $packet->{'ip'};
  my ($data) = $ip->{'data'} || return ();
  my (@data) = unpack("C*", $data);

  my $ip_hdr = ($data[0] & 0x0F) << 2;		# IP header length in bytes
  my $ip_len = glue(@data[2,3]);		# IP packet lenght in bytes

  warn "Truncated IP packet" if (scalar(@data) < $ip_len);

  splice @data, $ip_len;			# remove data added on by snoop
  my @body = splice @data, $ip_hdr;		# separate the IP header

  $ip->{'ver'} = ($data[0] >> 4);		# IP protocol version
  $ip->{'IHL*4'} = $ip_hdr;			# header size in bytes
  $ip->{'TOS'} = $data[1];			# Type Of Service
  $ip->{'length'} = $ip_len;			# total packet length
  $ip->{'ident'} = [ @data[4,5] ];		# re-assembly identification
  $ip->{'dont_frg'} = ($data[6] >> 6) & 0x1;	# shouldn't be fragmented
  $ip->{'more_frg'} = ($data[6] >> 5) & 0x1;	# this isn't the last fragment
  $ip->{'frg_off'} = glue($data[6] & 0x1F, $data[7]); # fragment offset
  $ip->{'TTL'} = $data[8];			# Time To Live
  $ip->{'proto'} = $data[9];			# protocol number
  $ip->{'xsum'} = glue(@data[10,11]);		# header checksum
  $ip->{'src'} = [ @data[12..15] ];		# source IP address
  $ip->{'dst'} = [ @data[16..19] ];		# destination IP address
  $ip->{'options'} = [ splice @data, 20 ];	# IP packet options

  my $proto = $ipproto{$ip->{'proto'}};

  printf "     ip: %s -> %s IPv%d        [%s] TOS=0x%02x frag:%d/%d\n",
	 join('.', @{$ip->{'src'}}), join('.', @{$ip->{'dst'}}),
	 $ip->{'ver'}, ($proto ? "\U$proto" : "proto=$ip->{'proto'}"),
	 $ip->{'TOS'}, $ip->{'more_frg'}, (!$ip->{'dont_frg'})
	   if ($debug >= 10);

  ($ip->{'more_frg'} || $ip->{'frg_off'})
    && (@body = ip_defrag($packet, \@body));

  return () unless @body;

  if ($proto) {
    $proto .= '/ip';
    $packet->{$proto} = {} unless $packet->{$proto};
    $packet->{$proto}{'data'} = \@body;		# (@body is my(), so it's OK)
  }
  @body;
}

# ip_defrag(\%packet, \@body)  --  reassemble fragmented IP packets
#    side effects: stores internal data in %ip_frags and %ip_complete
#    returns: re-assembled data
sub ip_defrag {
   my ($packet, $body) = @_;
   my ($ip) = $packet->{'ip'} || die "Can't defrag non-IP packets!\naborting";
   my ($ident, $data, $start, $total);

   $ident = pack("C*", @{$ip->{'src'}}, @{$ip->{'dst'}}, @{$ip->{'ident'}});
   $data = $ip_frags{$ident} || ($ip_frags{$ident} = []);
   $start = $ip->{'frg_off'} * 8;
   $total = $start + $#$body;

   $#$data = $total if ($#$data < $total);	# expand @$data if too small

   my @data = @$data;
   my (@old) = splice(@data, $ip->{'frg_off'}*8, scalar(@$body), @$body);
   @$data = @data;

   scalar(grep(defined($_), @old)) && carp "overlapping IP packet fragments";

   if ($ip->{'more_frg'} && !$ip_complete{$ident}) {
     print "ip-frag: start=$start end=$total\n"
       if ($debug >= 11);
     return ();
  }

  if (scalar(grep(!defined($_), @$data))) {
    print "ip-frag: start=$start end=$total   LAST??? (not done!)...\n"
      if ($debug >= 11);
    $ip_complete{$ident} = 1;
    return ();
  }

  print "ip-frag: start=$start end=$total   done.\n" if ($debug >= 11);
  delete $ip_frags{$ident};
  delete $ip_complete{$ident};
  @$data;
}

# udp_data(\%packet)  --  extract UDP data
#    side effects: stores data and header fields in %packet
#    returns: contents of UDP packet, as an array of bytes
sub udp_data {
  my ($packet) = @_;
  my ($udp) = $packet->{'udp/ip'};
  my ($data) = $udp->{'data'} || return ();

  $udp->{'src_port'} = glue( @$data[0,1] );	# source UDP port
  $udp->{'dst_port'} = glue( @$data[2,3] );	# destination UDP port
  $udp->{'length'} = glue( @$data[4,5] );	# datagram length
  $udp->{'xsum'} = glue( @$data[6,7] );		# datagram length

  warn "Truncated UDP packet" if (scalar(@$data) < $udp->{'length'});

  printf "    udp: port %d -> port %d  length=%d\n",
	 $udp->{'src_port'}, $udp->{'dst_port'}, $udp->{'length'}
	   if ($debug >= 8);

  my @body = @$data[8..$#$data];
  $udp->{'body'} = [ @body ];
  @body;
}

# tcp_data(\%packet)  --  extract TCP data and store it
#    side effects: stores data in %tcp_conn
#    returns: none
sub tcp_data {
  my ($packet) = @_;
  my ($tcp) = $packet->{'tcp/ip'};
  my ($data) = $tcp->{'data'} || return ();

  my $start = $data->[12] >> 4;

  $tcp->{'src_port'} = glue( @$data[0,1] );	# source TCP port
  $tcp->{'dst_port'} = glue( @$data[2,3] );	# destination TCP port
  $tcp->{'seq_num'} = glue( @$data[4..7] );	# sequence number
  $tcp->{'ack_num'} = glue( @$data[8..11] );	# acknowledgement number
  $tcp->{'data_off'} = $start;			# data offset (in bytes)
  $tcp->{'URG'} = $data->[13] & 0x20;		# URGent (urg ptr significant)
  $tcp->{'ACK'} = $data->[13] & 0x10;		# ACK (ack number significant)
  $tcp->{'PSH'} = $data->[13] & 0x08;		# PuSH function (?)
  $tcp->{'RST'} = $data->[13] & 0x04;		# ReSeT the connection
  $tcp->{'SYN'} = $data->[13] & 0x02;		# SYNchronize seq nums
  $tcp->{'FIN'} = $data->[13] & 0x01;		# FINished (no more data)
  $tcp->{'win'} = glue( @$data[14,15] );	# window (max data to recv)
  $tcp->{'xsum'} = glue( @$data[16,17] );	# TCP checksum
  $tcp->{'urg_ptr'} = glue( @$data[18,19] );	# urgent pointer

  $start <<= 2;
  $tcp->{'options'} = [ @$data[20..($start-1)] ]; # TCP options
  my @body = @$data[$start..$#$data];
  $tcp->{'body'} = [ @body ];

  my $ident = pack("C4n C4n",
		   @{$packet->{'ip'}{'src'}}, $tcp->{'src_port'},
		   @{$packet->{'ip'}{'dst'}}, $tcp->{'dst_port'});

  my $conn = $tcp_conn{$ident} || ($tcp_conn{$ident} = [0, '', undef, undef]);

  if ($tcp->{'SYN'}) {
    $conn->[0] = $tcp->{'seq_num'} - length($conn->[1]) + 1;
  }

  my $mode = '(empty)';
  if (@body) {
    if ($conn->[0] + length($conn->[1]) == $tcp->{'seq_num'}) {
      $mode = '(in seq)';
      $conn->[1] .= pack("C*", @body);
    } else {
      $mode = '(out of seq)';
      my @stream = unpack("C*", $conn->[1]);
      splice @stream, ($tcp->{'seq_num'} - $conn->[0]), scalar(@body), @body;
      $conn->[1] = pack("C*", @stream);
    }
  }
  printf "    tcp: port %d -> port %d  %20s length=%-4d  %s\n",
	 $tcp->{'src_port'}, $tcp->{'dst_port'},
	 ($tcp->{'URG'} ? 'URG ' : '').
	 ($tcp->{'PSH'} ? 'PSH ' : '').
	 ($tcp->{'RST'} ? 'RST ' : '').
	 ($tcp->{'FIN'} ? 'FIN ' : '').
	 ($tcp->{'ACK'} ? 'ACK ' : '').
	 ($tcp->{'SYN'} ? 'SYN ' : '    '),
	 scalar(@body),
	 $mode
	   if ($debug >= 8);
  printf "    tcp: seq=%d ack=%d\n", $tcp->{'seq_num'}, $tcp->{'ack_num'}
		if ($debug >= 9);

  @body;
}

# tcp_dump($dir, $size_threshold, $close)  --  save extracted TCP streams
#    side effects: retrieves data from %tcp_conn, writes files in $dir
#    returns: none
sub tcp_dump {
  my ($dir, $thresh) = @_;
  my ($ident);

  for $ident (keys %tcp_conn) {
    my $conn = $tcp_conn{$ident};

    if (length($conn->[1]) > 2*$thresh) {

      if (!defined($conn->[2])) {
	my ($src_addr, $src_port, $dst_addr, $dst_port)
	  = unpack("a4n a4n", $ident);
	my $src_host = gethostbyaddr($src_addr, AF_INET)
	  || inet_ntoa($src_addr);
	my $dst_host = gethostbyaddr($dst_addr, AF_INET)
	  || inet_ntoa($dst_addr);

	my $fn = "$dir/tcp_${src_host}:${src_port}_${dst_host}:${dst_port}";
	my $n = 1;
	while ( -e $fn ) {
	  $n++;
	  $fn = "$dir/tcp_${src_host}:${src_port}_${dst_host}:${dst_port}_$n";
	}
	$conn->[2] = new FileHandle;
	open($conn->[2], "> $fn") || die "open(): $!";
	$conn->[3] = $fn;
      }

      my $limit = ($thresh > 0) ? $thresh : 0;
      my $ssize = length($conn->[1]) - $limit;
      my ($save);

      ($save, $conn->[1]) = unpack("a$ssize a*", $conn->[1]);
      $conn->[0] += $ssize;

      print {$conn->[2]} $save;
    }
    if ($thresh < -1) {
      print "Closing $conn->[3]\n";
      close $conn->[2];
    }
  }
}

# apple_print_data(\%packet)  --  read AppleTalk print data, pretend we grok
#    side effects: stores data and header fields in %packet
#    returns: the print data stored in the packet (we hope)
sub apple_print_data {
  my ($packet) = @_;
  my ($apple) = $packet->{'AppleHack'};
  my ($data) = $apple->{'data'} || return undef;

  printf "  apple: length=%d\n", length($data);

  my ($junk, $prt) = unpack("a29 a*", $data);
  $prt;
}

# ieee802_data(\%packet)  --  read raw IEEE 802.3 data and determine protocol
#    side effects: stores data and header fields in %packet
#    returns: packed data inside 802.3+802.2+SNAP packet
sub ieee802_data {
  my ($packet) = @_;
  my ($ether) = $packet->{'802.3'} || return undef;
  my ($eth_src, $eth_dst, $type, $body)
    = unpack("H12 H12 H4 a*", $ether->{'data'});

  $ether->{'src'} = join(":", unpack("A2"x6, $eth_src));
  $ether->{'dst'} = join(":", unpack("A2"x6, $eth_dst));
  $ether->{'type'} = $type;

  my ($xtype) = $ethertype{$type};

  printf "  ether: %s -> %s [%s]\n", $ether->{'src'}, $ether->{'dst'},
	 ($xtype ? "\U$xtype" : "type $type")
	   if ($debug >= 12);

  if ($xtype) {
    $packet->{$xtype} = {} unless $packet->{$xtype};
    $packet->{$xtype}{'data'} = $body;
  } else {
    $body;
  }
}