#!/usr/bin/perl

# Grouch.pl - by Jeff Jarmoc - 09/07/2009
#
# A heavily modified version of snacsnatcher.pl (http://cpansearch.perl.org/src/MATTHEWG/Net-OSCAR-1.925/snacsnatcher)
# Created for the jham corp forensics puzzle contest (http://jhamcorp.com/What%20We%27re%20Up%20To....html)

use strict;
use warnings;
use Socket;
use lib "./blib/lib";
use lib "/usr/include";
use Net::OSCAR qw(:all);
use Net::OSCAR::XML;
use Net::OSCAR::Utility qw(hexdump);
use Net::OSCAR::Constants;
use Net::Pcap;
use Digest::MD5;

our $session = Net::OSCAR->new();
our $init_time = undef;
our $outfile = undef;
our $verbose = 0;   # Increasing this GREATLY increases the data that's output about an OSCAR transfer.

sub BEGIN {
	eval {
		require "net/bpf.ph";
	};
	die "Couldn't find net/bpf.ph.\nPlease create it by doing cd /usr/include ; h2ph net/bpf.h\n$@\n" if $@;
}

my $file = shift or die "Usage: grouch pcapfile [-v]\n";

use vars qw($packet %buffer %bufflen %snacbuff %ft_states %seqnos $datalink @blarray);
$packet = "";
#0;

sub ssdump_scalar($$);
sub ssdump_list($$);
sub ssdump_hash($$);
sub docx2txt($);

sub ssdump_scalar($$) {
	my($val, $depth) = @_;

	my $hex = hexdump($val);
	if($hex and $hex ne $val) {
		if ($verbose) { 
			print join("\n",
		  		map {
		  			("\t" x $depth) . $_
				} split(/\n/,
					$hex
				)
			), "\n";
		}
	} else {
		$val ||= "";
		print "$val\n" if $verbose;
	}
}

sub ssdump_list($$) {
	my($val, $depth) = @_;

	print "\t" x $depth if $verbose;
	foreach (@$val) {
		print "[\n" if $verbose;

		if(!ref($_)) {
			print "\t" x ($depth+1) if $verbose;
			ssdump_scalar($_, $depth);
		} elsif(ref($_) eq "HASH") {
			ssdump_hash($_, $depth+1);
		} elsif(ref($_) eq "ARRAY") {
			ssdump_list($_, $depth+1);
		} elsif(ref($_) eq "SCALAR") {
			print "\t" x ($depth+1) if $verbose;
			ssdump_scalar($$_, $depth+1);
		} else {
			die "Unknown reftype: " . ref($_) . "\n";
		}

		if ($verbose) {
			print "\t" x $depth;
			print "],";
		}
	}
	print "\n" if $verbose;
}

sub ssdump_hash($$) {
	my($struct, $depth) = @_;

	if (defined $struct->{filename})  {
		if ($struct->{bytes_received}) {
			# File transfer complete, let's take a look at the file.
			my $magic_number = '';
			print "\nReceived file $struct->{filename} - $struct->{bytes_received} Bytes\n";
			close (FILE);
			open (FILE, $outfile);
			read FILE, $magic_number, 4; 
			close (FILE);
			open (FILE, $outfile);
			print "\tMagic Number: ", hexdump($magic_number), "\n";
			print "\tMD5: ", Digest::MD5->new->addfile(*FILE)->hexdigest, "\n";
			close(FILE);
			if ($outfile =~ /.*\.docx/) { 
			 print "\tPlain-text contents of $outfile follow:\n";
			 print docx2txt($outfile);
			 print "\n";
			} else {
			 # Other file interpreters could be added
			 print "\tCannot display file $outfile\n"
 			}
			
			$outfile=undef;
			return;

		} else {
			if ($struct->{flags}) {
				print "\nReceiving file $struct->{filename}\n";
				# Open a file handle for storing our file, die if the file exists.
				if (!$outfile) {
					$outfile = $struct->{filename};
					die "$outfile exists, exiting!" if (-e $outfile);
					open(FILE, ">$outfile");
					binmode(FILE);
				}
			} 
		}
	} elsif (defined $struct->{message}) {
		print "\t $struct->{message} \n\n";
		ssdump_hash($struct->{message_body}, $depth+1); 
	} elsif (defined $struct->{message_body} ) {
		print " exchange with: $struct->{screenname}\n";
		my $body = $struct->{message_body};
		ssdump_hash($body, $depth+1);
	} else {
		foreach my $key (sort keys %$struct) {
		my $val = $struct->{$key};

		if ($verbose) {
			print "\t" x $depth;
			print $key, " => ";
		}
		
		if(!ref($val)) {
			if($key =~ /ip$/ and $val =~ /^\d+$/) {
				my($q1, $q2, $q3, $q4) = (
					($val >> 24),
					(($val >> 16) & 0xFF),
					(($val >> 8) & 0xFF),
					($val & 0xFF)
				);
				$val = "$q1.$q2.$q3.$q4";
			} elsif($key eq "capability") {
				$val = OSCAR_CAPS_INVERSE()->{$val} if exists(OSCAR_CAPS_INVERSE()->{$val});
			}
		ssdump_scalar($val, $depth);
		} elsif(ref($val) eq "HASH") {
			print "\n" if $verbose;
			ssdump_hash($val, $depth+1);
		} elsif(ref($val) eq "ARRAY") {
			print "\n" if $verbose;
			if($key eq "capabilities") {
				@$val = map {
					exists(OSCAR_CAPS_INVERSE()->{$_}) ?
					OSCAR_CAPS_INVERSE()->{$_} :
					$_
				} @$val;
			} elsif($key eq "shortcaps") {
				@$val = map {
					exists(OSCAR_CAPS_SHORT_INVERSE()->{$_}) ?
					OSCAR_CAPS_SHORT_INVERSE()->{$_} :
					$_
				} @$val;
			}		

			ssdump_list($val, $depth);
		} elsif(ref($val) eq "SCALAR") {

			ssdump_scalar($$val, $depth);
		} else {
			die "Unknown reftype: " . ref($val) . "\n";
		} }
	}
}


sub got_packet($$$) {
	my($user, $hdr, $pkt) = @_;
	my($inaddr, $outaddr);
	my $tlv;

	my $time = $hdr->{tv_sec} . "." . $hdr->{tv_usec};
	$init_time ||= $time;
	$time -= $init_time;
	$time = sprintf("%0.3f", $time);

	$packet++;
	# This removes the datalink-level headers from a packet.
	# You may need to adjust this - this is a very Q&D hack.
	# Only ethernet (DLT_EN10MB) is tested.
	#
	# These are taken from tcpdump.
	#
	if($datalink == DLT_NULL or $datalink == DLT_LOOP) {
		substr($pkt, 0, 4) = "";
	} elsif($datalink == DLT_EN10MB or $datalink == DLT_IEEE802) {
		substr($pkt, 0, 14) = "";
	} elsif($datalink == DLT_SLIP) {
		substr($pkt, 0, 16) = "";
	} elsif($datalink == DLT_PPP) {
		substr($pkt, 0, 4) = "";
	} elsif($datalink == DLT_LINUX_SLL) {
		substr($pkt, 0, 16) = "";
	} else {
		die "Unsupported datalink $datalink\n";
	}

	my($iplen, $diffserv, $totlen) = unpack("CCn", $pkt);

	$iplen = ($iplen&0x0F) * 4;
	my $src = substr($pkt, 12, 4);
	my $dst = substr($pkt, 16, 4);
	substr($pkt, 0, $iplen) = ""; #Get rid of IP headers
	
	$src = inet_ntoa($src);
	$dst = inet_ntoa($dst);

	my($src_port, $dst_port, $seqno, $ack_seq, $tcplen, $flags) = 
		unpack("nnNNCC", $pkt);
	$tcplen = ($tcplen>>4)*4;
	substr($pkt, 0, $tcplen) = "";

	return if $flags & 0x2; # SYN

	my $conn_key = "$src:$src_port -> $dst:$dst_port";
	$buffer{$conn_key} ||= "";
	$bufflen{$conn_key} ||= 0;


	# Ignore retransmissions
	$seqnos{$conn_key} ||= [undef, undef, undef, undef, undef, undef, undef, undef, undef, undef];
	#return if grep {defined($_) and $_ eq $seqno} @{$seqnos{$conn_key}};
	# Above cause problems for packets with the same SEQ but different length, which appear in the .pcap i'm developing against.  Should probably check for retransmits some other way.
	shift @{$seqnos{$conn_key}};
	push @{$seqnos{$conn_key}}, $seqno;	

	PACKET: while($pkt) {
	return if ($totlen == $iplen + $tcplen);  # Ignore packet payload if TCP/IP headers say there's no payload.
	
	print " Packet Data for $packet \n" . hexdump($pkt) . "\n" if ($verbose > 2);

		if($buffer{$conn_key}) {
			$pkt = $buffer{$conn_key} . $pkt;
			$buffer{$conn_key} = "";
		}

		if($bufflen{$conn_key}) {
			if(length($pkt) < $bufflen{$conn_key}) {
				$buffer{$conn_key} = $pkt;
				return;
			} else {
				$bufflen{$conn_key} = 0;
			}
		} else {
			if(length($pkt) < $tcplen) {
				$buffer{$conn_key} = $pkt;
				$bufflen{$conn_key} = $tcplen;
				return;
			}
		}

		if ($snacbuff{$conn_key}) {
			$pkt = $snacbuff{$conn_key} . $pkt;
			$snacbuff{$conn_key} = "";
		}

		if (substr($pkt, 0, 4) eq "OFT2") {
			process_xfer($time, \$pkt, $conn_key);
		} elsif (substr($pkt, 0, 1) eq "*") {
			process_snac($time, \$pkt, $conn_key);
			#return;	
		} else {
			if($ft_states{$conn_key}) {
				print "$time: $conn_key: " . length($pkt) . " bytes of FT data $tcplen \n" if $verbose;
				print hexdump($pkt), "\n" if ($verbose);
			       if (defined $outfile) {				
					print "Writing: to $outfile\n ", hexdump($pkt), "\n" if $verbose;
                                	print FILE ($pkt);
				}
			}

			$pkt = ''; 		
		}
	}
}


sub process_xfer {
	my($time, $pkt, $conn_key) = @_;

	print "$time: $conn_key\n" if $verbose;
	$ft_states{$conn_key} = 1;

	my %ft_data = protoparse($session, "file_transfer_header")->unpack($$pkt);
	if ($verbose) {
		printf "$time: $conn_key\n" ."\t[type=%04X] [encrypt=%d] [compress=%d] [files=%d/%d] [parts=%d/%d] [bytes=%d/%d]\n",	
		delete @ft_data{qw(type encrypt compress files_left file_count parts_left part_count bytes_left byte_count)};
	}
	
	print "\tHEADER IS NOT 256 BYTES!!\n" unless $ft_data{header_length} == 256;
	substr($$pkt, 0, $ft_data{header_length} + 4) = "";
                                                               
	ssdump_hash(\%ft_data, 1);
	print "\n" if $verbose;
}

sub process_snac {
	my($time, $pkt, $conn_key) = @_;

	my($chan, $seqno, $len) = unpack("xCnn", substr($$pkt, 0, 6, ""));
	if(length($$pkt) < $len) {
		$snacbuff{$conn_key} = pack("CCnn", 42, $chan, $seqno, $len);
		$snacbuff{$conn_key} .= $$pkt;
		return;
	}
	my $snac = substr($$pkt, 0, $len, "");

	if ($verbose) { 
		print "$time: $conn_key";
		printf " ch=%02X", $chan;
	}
	
	my %snac_data = protoparse($session, "snac")->unpack($snac);
	if ($verbose) {
	printf " fl=%02X/%02X", $snac_data{flags1} || 0, $snac_data{flags2} || 0;
	printf " [%04X/%04X]", $snac_data{family} || 0, $snac_data{subtype} || 0;
	}
	
	my $protobit = snac_to_protobit(%snac_data);
	if(!$protobit) {
		if ($verbose) {
			print " == UNKNOWN\n";
			print hexdump($snac_data{data});
			
			print "\n";
		}
	} else {
		print " == $protobit\n" if $verbose;
		my %data = protoparse($session, $protobit)->unpack($snac_data{data});
		if($protobit =~ /^buddylist_(add|modify|delete)$/) {
			%data = protoparse($session, "buddylist_change")->unpack($snac_data{data});
		}

		if($protobit =~ /^(incoming|outgoing)_IM$/) {
			my $channel_data;
			print $protobit; 
			if($data{channel} == 1) {
				$channel_data = {protoparse($session, "standard_IM_footer")->unpack($data{message_body})};
			} elsif($data{channel} == 2) {
				$channel_data = {protoparse($session, "rendezvous_IM")->unpack($data{message_body})};
				my $type = OSCAR_CAPS_INVERSE()->{$channel_data->{capability}};

				if($type eq "chat") {
					$channel_data->{svcdata} = {protoparse($session, "chat_invite_rendezvous_data")->unpack($channel_data->{svcdata})};
				} elsif($type eq "filexfer") {
					$channel_data->{svcdata} = {protoparse($session, "file_transfer_rendezvous_data")->unpack($channel_data->{svcdata})};
				} elsif($type eq "sendlist") {
					$channel_data->{svcdata} = {protoparse($session, "buddy_list_transfer_rendezvous_data")->unpack($channel_data->{svcdata})};
				}
			} else {
				$channel_data = $data{message_body};
			}

			$data{message_body} = $channel_data;
		}

		ssdump_hash(\%data, 1);
	}

	print "\n" if $verbose;
}

sub docx2txt ($) {
	# VERY simple docx2text conversion.
	#
	# See Sandeep Kumar's docx2text.pl for a much more robust converter
	# http://www.textlib.com/doc2text.html
	
	my ($infile) = @_ ;
	
	my $unzip = "/usr/bin/unzip";
	my $nulldevice ="/dev/null";
	my $nl = "\n";	

 	my $content = `$unzip -p '$infile' word/document.xml 2>$nulldevice`;
	return "Failed to extract required information from $infile!\n" if ! $content;
	
	$content =~ s/<?xml .*?\?>(\r)?\n//;
	$content =~ s{<w:p [^/>]+?/>|</w:p>|<w:br/>}|$nl|og;

	$content =~ s/<.*?>//og;

	return "----\n",$content,"----\n";
}

my $pcap = Net::Pcap::open_offline($file, \$!) or die "Couldn't open $file: $!\n";
$datalink = Net::Pcap::datalink($pcap);
Net::Pcap::dispatch($pcap, 0, \&got_packet, undef);
Net::Pcap::close($pcap);