#!/usr/bin/perl

use strict;
use warnings;
use Socket;
use Net::OSCAR qw(:all);
use Net::Pcap;

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" if $@;
}

my $file = shift or die "Usage: snacsnatcher pcapfile [verbose]\n";

# Quick and dirty protocol analyzer

use vars qw($packet $verbose %buffer %bufflen $datalink @blarray);
$packet = 0;
$verbose = shift;

$| = 1;

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

	$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) = "";
	} else {
		die "Unsupported datalink $datalink\n";
	}

	my($iplen) = unpack("C", $pkt);
	$iplen = ($iplen&0xF) * 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);

	$buffer{$src} ||= "";
	$bufflen{$src} ||= 0;

	substr($pkt, 0, 12) = "";
	my($tcplen, $flags) = unpack("CC", $pkt);
	$tcplen = ($tcplen>>4)*4;
	substr($pkt, 0, $tcplen - 12) = ""; #Get rid of TCP headers
	return if $flags & 0x2; # SYN

	PACKET: while($pkt) {
		if($buffer{$src}) {
			if($bufflen{$src} == -1) {
				$pkt = $buffer{$src} . $pkt;
				$buffer{$src} = "";
				$bufflen{$src} = 0;
			} else {
				if(length($pkt) < $bufflen{$src} - length($buffer{$src})) {
					$buffer{$src} .= $pkt;
					return;
				} else {
					$buffer{$src} .= substr($pkt, 0, $bufflen{$src} - length($buffer{$src}), "");
					$pkt = $buffer{$src};
					$buffer{$src} = "";
					$bufflen{$src} = 0;
				}
			}
		}

		my($flap, $channel, $seqno, $len) = unpack("CCnn", $pkt);
		$len ||= 0;
		if($flap == 0x2A) {
			if((length($pkt) - 6) < $len) {
				$buffer{$src} = $pkt;
				$bufflen{$src} = $len + 6;
				return;
			} elsif((length($pkt) - 6) > $len) {
				$buffer{$src} = substr($pkt, $len + 6, length($pkt) - $len - 6, "");
				$bufflen{$src} = -1;
			}
		}

		printf "%04d ($src, $dst)\n", $packet;

		if($flap != 0x2A) {
			print "\tNon-FLAP packet" ;
			print hexdump($pkt), "\n";
			return;
		}

		substr($pkt, 0, 6) = "";
		printf "\tchannel: 0x%X, seqno: 0x%02X, length: 0x%02X\n", $channel, $seqno, $len;

		next PACKET unless $pkt;
		if(length($pkt) < 10) {
			print hexdump($pkt);
		} else {
			my($family, $subtype, $flags1, $flags2, $reqid) = unpack("nnCCN", $pkt);
			substr($pkt, 0, 10) = "";
			$len -= 10;
			printf "\tSNAC 0x%04X/0x%04X (flags 0x%02X, 0x%02X) [reqid 0x%08X]\n", $family, $subtype, $flags1, $flags2, $reqid;
			if($len and $verbose) {
				if($family == 0x13 and $subtype == 0x6) {
					substr($pkt, 0, 3) = "";
					$len -= 3;
					substr($pkt, -4, 4) = "" if $flags2;
					$len -= 4 if $flags2;
					$blarray[$flags2] = $pkt;
					substr($pkt, 0, $len) = "" if $len;
					if($flags2) {
						print "\tGot buddylist part $flags2\n";
					} else {
						my $buddylist = join("", reverse @blarray);
						while(length($buddylist) > 4) {
							my($name) = unpack("n/a*", $buddylist);
							substr($buddylist, 0, 2+length($name)) = "";
							my($gid, $bid, $type, $sublen) = unpack("n4", substr($buddylist, 0, 8, ""));
							printf("\tGot BLI entry %s 0x%04X/0x%04X/0x%04X with %d bytes of data:%s\n", $name, $type, $gid, $bid, $sublen, hexdump(substr($buddylist, 0, $sublen, "")));
						}
					}
					print "\n";
					next PACKET;
				}

				# TLV check
				my $tlv = 1;
				for(my $pos = 0; $pos < $len;) {
					(undef) = unpack("n", substr($pkt, $pos, 2));
					$pos += 2;
					if($pos > $len) {
						$tlv = 0;
						last;
					}
					my($tlvlen) = unpack("n", substr($pkt, $pos, 2));
					$pos += 2;
					if($pos+$tlvlen > $len) {
						$tlv = 0;
						last;
					}
					$pos += $tlvlen;
				}

				if($tlv) {
					my $tlv = Net::OSCAR::Connection::tlv_decode(substr($pkt, 0, $len));
					foreach my $key(keys %$tlv) {
						printf "\t0x%04X: %s\n", $key, hexdump($tlv->{$key});
					}
				} else {
					print hexdump(substr($pkt, 0, $len));
				}
			}
		}
		print "\n";

		substr($pkt, 0, $len) = "" if $len;
	}
}

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);
