package Net::Pcap::Reassemble;

require 5.002;
use strict;
use vars qw($VERSION %pending $callback $linktype $debug);

use Net::Pcap;

#
# Copyright (c) 2006 James Raftery <james@now.ie>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
# Please submit bug reports, patches and comments to the author.
#
# $Id: Reassemble.pm,v 1.13 2008/06/09 13:52:22 james Exp $
#
# This module is a wrapper for the loop() function of the Net::Pcap
# module. It performs IP fragment reassembly for fragmented datagrams
# in the libpcap dump data. You require the Net::Pcap module to use
# Net::Pcap::Reassemble. See the Net::Pcap::Reassemble(3) man page for
# more information.
#

$VERSION = '0.03';
$debug   =  0;

####

#
# Wrapper around Net::Pcap's loop() function. This takes the same
# arguments as Net::Pcap's loop().
#
sub loop ($$&$) {

	my ($pcap_t, $num, $user_data);

	($pcap_t, $num, $callback, $user_data) = @_ or
		croak("Missing arguments to loop()");

	defined ($linktype = Net::Pcap::datalink($pcap_t)) or die;

	#
	# A reference to the user's callback is in $callback, which is
	# declared as a package global. We call Net::Pcap::loop,
	# specifying instead our own _reassemble() sub as its callback.
	# _reassemble() will give a packet to the sub referenced in
	# $callback when it has a complete datagram.
	#
	return Net::Pcap::loop($pcap_t, $num, \&_reassemble, $user_data);
}

sub flush () {
	undef %pending;
}

#
# Callback function. Read the IP version from the packet header and call
# the appropriate function to read it. If that function returns data
# (i.e. a complete datagram) then summon up the user's callback,
# supplying the packet.
#
sub _reassemble ($$$) {

	my ($user_data, $header, $packet, $ver, $l2);

	($user_data, $header, $packet) = @_ or
		croak("Missing arguments to _reassemble()");

	if ($linktype == DLT_EN10MB) {
		# discard the ethernet header (14 bytes)
		$l2 = 14;
	} elsif ($linktype == DLT_LOOP or $linktype == DLT_NULL) {
		# discard the loopback header (4 bytes)
		$l2 = 4;
	} else {
		# XXX barf
		die "unsupported linktype: $linktype";
	}
	$ver = unpack("x".$l2." C", $packet);
	$ver = ($ver & 0xf0) >> 4;

	VER: {
		if ($ver == 4)	{
			$packet = _readIPv4pkt($packet, $l2);
			last VER;
		}

		if ($ver == 6)	{
			$packet = _readIPv6pkt($packet, $l2);
			last VER;
		}

		# default:
			return;

	} # End: VER

	&$callback($user_data, $header, $packet) if $packet;
}

#
# Read an IPv4 packet.
#
sub _readIPv4pkt ($$) {

	my ($packet, $l2, $i, $ver, $ihl, $pktlen, $id, $mf, $offset, $proto,
	    $src, $dst, $payload, $datalen);

	($packet, $l2) = @_ or croak("Missing argument to _readIPv4pkt()");

	# The x's are: layer2 header, tos, ttl, chksum, options+data
	($i, $pktlen, $id, $offset, $proto, $src, $dst) = 
				unpack("x".$l2." C x n n n x C x2 N N", $packet);

	$ver     = ($i & 0xf0) >> 4;
	$ihl     = ($i & 0x0f)  * 4;
	$mf      = ($offset >> 13) & 0x01;	# More fragments flag
	$offset  = ($offset & 0x1fff) << 3;
	$src     = join(".", unpack("C*", pack("N", $src)));
	$dst     = join(".", unpack("C*", pack("N", $dst)));
	$datalen = $pktlen - $ihl;

	print "ver:$ver ihl:$ihl packetlen:$pktlen id:$id mf:$mf " .
		"offset:$offset datalen:$datalen proto:$proto\n".
		"src:$src dst:$dst\n" if $debug;

	#
	# Fragment 1:			MF == 1, offset == 0
	# Fragment 2..(n-1):	MF == 1, offset >  0
	# Fragment n:			MF == 0, offset >  0
	#

	#
	# Can you encounter a negative offset? Maybe if we unpack the
	# data incorrectly.
	#
	# If this isn't a fragment we drop down to the return statement
	# which passes back the unmodified $packet data.
	#
	if (($mf and $offset >= 0) or ($offset > 0)) {
		print "Fragment! ver:$ver ihl:$ihl packetlen:$pktlen id:$id mf:$mf ".
			"offset:$offset datalen:$datalen proto:$proto\n".
			"src:$src dst:$dst\n" if $debug;

		$i = "$src $dst $id $proto";

		#
		# If initial fragment - use the whole packet as the data.
		# XXX The user callback gets a packet with the header
		#     from the first fragment. 'total length' and MF
		#     are going to be wrong w.r.t. the reassembled
		#     packet.
		#
		if ($offset == 0) {
			$payload = $packet;
		} else {
			$payload = substr($packet, 14+$ihl, $datalen);
		}

		#
		# XXX We don't expunge old entries
		#
		if (exists $pending{$i}) {
			$pending{$i}->addfragment($offset, $datalen, $mf, $payload) or
				print STDERR "addfragment: $offset $datalen $mf failed\n";
		} else {
			$pending{$i} = Net::Pcap::Reassemble::Packet->new(
					$i, $offset, $datalen, $mf, $payload) or
				print STDERR "new Packet: $i $offset $datalen, $mf failed\n";
		}

		print $pending{$i}->listfragments if $debug;

		# We get a packet if all the fragments have arrived, or
		# an empty string if not.
		$packet = $pending{$i}->iscomplete;
		if ($packet) {
			delete $pending{$i};
			print "Fragment '$i' is complete.\n" if $debug;
		}
	}

	return $packet;
}

#
# Read an IPv6 header/packet.
#
sub _readIPv6pkt ($$) {

	my ($packet, $l2, $ver, $payloadlen, $nexthdr, $src, $dst, $payload, $i,
	    $offset, $id, $m, $hdrlen, $exthdrlentotal, $unfrag,
	    $unfragoffset, $prevhdr, $prevhdrlen);

	($packet, $l2) = @_ or croak("Missing argument to _readIPv6pkt()");
	$prevhdr       = 0;	# Hackity, hack, hack

	# The x's are: layer2 header, class, label, hlim
	($ver, $payloadlen, $nexthdr, $src, $dst, $payload) = 
			unpack("x".$l2." C x3 n C x H32 H32 a*", $packet);

	$ver            = ($ver & 0xf0) >> 4;
	$src            = join(":", unpack("H4"x8, pack("H32", $src)));
	$dst            = join(":", unpack("H4"x8, pack("H32", $dst)));
	$exthdrlentotal = 0;	# extension header bytes read so far

	print "ver:$ver payloadlen:$payloadlen nexthdr:$nexthdr\n" .
			"src:$src\ndst:$dst\n" if $debug;

	#
	# Since this module isn't a v6 capable end-host it doesn't
	# implement TCP or UDP or any other `upper-layer' protocol. How
	# do we decide when to stop looking ahead to the next header
	# (and return some data to the caller)? We stop when we find
	# a `next header' which isn't a known Extension Header:
	#
	#  0 Hop-by-Hop Options
	# 43 Routing
	# 44 Fragment
	# 50 Encapsulating Security Payload
	# 51 Authentication
	# 60 Destination Options
	#
	# This means this will fail to deal with any subsequently added
	# Extension Headers, which is sucky, but the alternative is to
	# list all the other `next header' values and then break when a
	# new one of them is defined :)
	#
	EXTHEADER: for (;;) {

		if ($nexthdr ==  0 or $nexthdr == 43 or $nexthdr == 50 or
		    $nexthdr == 51 or $nexthdr == 60) {

			$prevhdr         = $nexthdr;
			$prevhdrlen      = $hdrlen;
			$exthdrlentotal += $hdrlen;
			($nexthdr, $hdrlen, $payload) = _readIPv6Extheader($payload);

			next EXTHEADER;
		}

		last EXTHEADER if ($nexthdr != 44);

		#
		# Fragment Header
		#
		($nexthdr, $offset, $id, $m, $payload) = _readIPv6Fragheader($payload);

		$i = "$src $dst $id";

		#
		# Initial fragment - use the whole packet minus the Fragment
		# header as the data.
		# Munge the Next Header value from 44 (Fragment Header) to that
		# of the subsequent header.
		#
		# XXX The user callback gets a packet with the header from the
		#     first fragment. `length' is going to be wrong w.r.t. the
		#     reassembled packet.
		#
		if ($offset == 0) {

			# Offset to the start of the unfragmentable part
			$unfragoffset = 14+40+$exthdrlentotal;
			$unfrag = substr($packet, 0, $unfragoffset);

			if ($prevhdr == 0) {
				# Ethernet header + 6 bytes into IPv6 header
				substr($unfrag, 14+6, 1) = $nexthdr;
			} else {
				# XXX not tested
				# We've read N extension headers
				# Wind back one header length ($prevhdrlen) from the
				# start of the unfragmentable part ($unfragoffset).
				substr($unfrag, $unfragoffset-$prevhdrlen, 1) = $nexthdr;
			}

			$payload = $unfrag . $payload;
		}

		#
		# Fragmentable part length =
		#       packet payload length - length of extension headers read
		#		(add 8 bytes for the Fragment header)
		#
		$payloadlen -= ($exthdrlentotal+8);

		#
		# XXX We don't expunge old entries
		#
		if (exists $pending{$i}) {
			$pending{$i}->addfragment($offset, $payloadlen, $m, $payload) or
				print STDERR "addfrag: $i $offset $payloadlen $m failed\n";
		} else {
			$pending{$i} = Net::Pcap::Reassemble::Packet->new($i, $offset,
					$payloadlen, $m, $payload) or
				print STDERR "Packet: $i $offset $payloadlen $m failed\n";
		}

		print $pending{$i}->listfragments if $debug;

		# We get a packet if all the fragments have arrived or an
		# empty string if not.
		$packet = $pending{$i}->iscomplete;
		if ($packet) {
			delete $pending{$i};
			print "Fragment '$i' is complete.\n" if $debug;
		}

		last EXTHEADER;

	} # End: EXTHEADER

	return $packet;
}

#
# Read a standard IPv6 Extension Header. Extract the Next Header and
# Header Length values, and the payload.
#
sub _readIPv6Extheader ($) {

	my ($packet, $nexthdr, $hdrlen, $payload);

	$packet = shift or croak("Missing argument to _readIPv6Extheader()");

	($nexthdr, $hdrlen) = unpack("CC", $packet);

	$hdrlen = $hdrlen*8 + 8;
	print "Extension header is $hdrlen octets, nexthdr: $nexthdr\n" if $debug;

	# XXX not tested
	#     use substr?
	$payload = unpack(("x"x $hdrlen)."a*", $packet);

	return($nexthdr, $hdrlen, $payload);
}

#
# Read an IPv6 Fragment Header. Extract the fragment's offset, ID, M
# flag and payload.
#
sub _readIPv6Fragheader ($) {

	my ($packet, $nexthdr, $offset, $m, $id, $payload);

	$packet = shift or croak("Missing argument to _readIPv6Fragheader()");

	($nexthdr, $offset, $id, $payload) = unpack("C x n N a*", $packet);

	$m        = $offset & 0x0001;
	$offset >>= 3;
	$offset  *= 8;

	print "Fragment! header: nexthdr:$nexthdr offset:$offset ".
		"id:$id,0x". unpack("H*", pack("N", $id)) ." m:$m ".
		length($packet) . " " . length($payload) ."\n" if $debug;

	$nexthdr = pack("C", $nexthdr);
	return ($nexthdr, $offset, $id, $m, $payload);
}

####

package Net::Pcap::Reassemble::Packet;

use strict;
use Carp;

#
# Constructor for a `Packet' object.
#
sub new ($$$$$$) {
	my $proto  = shift or croak;
	my $class  = ref($proto) || $proto;
	defined(my $id     = shift) or croak "No ID in $class constructor";
	defined(my $offset = shift) or croak "No offset in $class constructor";
	defined(my $length = shift) or croak "No length in $class constructor";
	defined(my $mf     = shift) or croak "No MF in $class constructor";
	defined(my $data   = shift) or croak "No data in $class constructor";

	#
	# Each `Packet' object contains:
	#  1. ID: IPv4: 'srcip dstip IPid protocol'
	#         IPv6: 'srcip dstip IPid'
	#  2. A list of Net::Pcap::Reassemble::Fragment object references
	#  3. The final octet, learned from the packet with MF==0.
	#  4. A `sorted' flag to indicate if the fragment list is sorted
	#
	my $self = {
		ID		=> $id,
		FRAGS		=> [],
		LASTOCTET	=> undef,
		SORTED		=> 1,
	};

	bless($self, $class);

	return undef if !$self->addfragment($offset, $length, $mf, $data);

	return $self;
}

#
# Add a fragment to a Packet object.
#
sub addfragment ($$$$$) {
	my $self = shift;
	ref($self) or croak;

	my ($offset, $length, $mf, $data) = @_ or croak;

	my $frag =
	  Net::Pcap::Reassemble::Fragment->new($offset, $length, $mf, $data);
	return undef if !$frag;

	# If this is the last fragment, save the last octet value in the
	# object.
	# XXX Check for more than one fragment with MF==0?
	$self->{LASTOCTET} = $offset+$length if !$mf;

	# The list can't be considered sorted any more.
	$self->{SORTED} = 0;

	# XXX Test for overlap?
	return push(@{$self->{FRAGS}}, $frag);
}

#
# Return a string showing the fragments that have been recieved by the object.
#
sub listfragments ($) {
	my $self = shift;
	ref($self) or croak;

	my ($s, $frag);

	$s .= "Packet ID:$self->{ID}\n";
	$s .= "Last octet:$self->{LASTOCTET}\n" if (defined $self->{LASTOCTET});
	foreach $frag (@{$self->{FRAGS}}) {
		$s .= "Fragment " . $frag->vitals . "\n";
	}

	return $s;
}

#
# Check if all the fragments for a Packet have been received. If they have,
# splice the fragment data back together and return to the caller. If they
# have not, return no data.
#
sub iscomplete ($) {
	my $self = shift;
	ref($self) or croak;

	my $nextfrag = 0;	# The first fragment starts at octet zero
	my $data     = "";
	my $frag;

	#
	# If we don't know LASTOCTET yet then we're missing at least the
	# final (MF==0) fragment so we don't need to proceed any further.
	#
	return if (!defined $self->{LASTOCTET});

	#
	# Sort the fragment list so we only need to scan it once.
	# If it was unordered we would need to scan through it repeatedly.
	# That said, sort() is pretty slow :)
	#
	FRAGMENT: foreach $frag (@{$self->_sortfragments}) {

		#
		# If the first octet in this fragment is the octet we're
		# searching for and the last octet is the last octet of the
		# complete datagram then we have all the packet data. If not,
		# the next fragment we search for is the one that starts where
		# this one ends.
		#
		if ($frag->start == $nextfrag) {
			last FRAGMENT if ($frag->end == $self->{LASTOCTET});
			$nextfrag = $frag->end;
			next FRAGMENT;
		}

		#
		# If we reach here, we're missing at least one fragment so
		# just give up.
		#
		return;
	}

	#
	# The datagram is complete. Splice the fragments' data together
	# to return the complete packet.
	#
	return $self->_data;
}

#
# Return concatenated fragment data.
# Warning: missing fragments are blithely ignored. Use iscomplete() for
#          a sanity-checked interface!
#
sub _data ($) {
	my $self = shift;
	ref($self) or croak;

	my ($frag, $data);

	foreach $frag (@{$self->_sortfragments}) {
		$data .= $frag->data;
	}

	return $data;
}

#
# Sort the fragment list by starting octet value and return a reference
# the list.
#
sub _sortfragments ($) {
	my $self = shift;
	ref($self) or croak;

	if (!$self->{SORTED}) {
		@{$self->{FRAGS}} = sort {$a->start<=>$b->start} @{$self->{FRAGS}};
		$self->{SORTED} = 1;
	}
	return $self->{FRAGS};
}

####

package Net::Pcap::Reassemble::Fragment;

use strict;
use Carp;

#
# Constructor for a `Fragment' object.
#
sub new ($$$$$) {
	my $proto  = shift or croak;
	my $class  = ref($proto) || $proto;
	defined(my $offset = shift) or croak "No offset in $class constructor";
	defined(my $length = shift) or croak "No length in $class constructor";
	defined(my $mf     = shift) or croak "No MF in $class constructor";
	defined(my $data   = shift) or croak "No data in $class constructor";

	#
	# Each `Fragment' object contains:
	#  1. Start octet
	#  2. End octet
	#  3. (M)ore (F)ragments flag (`MF' in IPv4; `M' in IPv6)
	#  4. Payload data
	#
	my $self = {
		START	=> $offset,
		END	=> $offset+$length,
		MF	=> $mf,
		DATA	=> $data,
	};

	bless($self, $class);
	return $self;
}

#
# Accessor function for start octet value.
#
sub start ($) {
	my $self = shift;
	ref($self) or croak;
	return $self->{START}
}

#
# Accessor function for end octet value.
#
sub end ($) {
	my $self = shift;
	ref($self) or croak;
	return $self->{END}
}

#
# Accessor function for MF/M flag.
#
sub mf ($) {
	my $self = shift;
	ref($self) or croak;
	return $self->{MF}
}

#
# Accessor function for fragment data.
#
sub data ($) {
	my $self = shift;
	ref($self) or croak;
	return $self->{DATA}
}

#
# Return a string listing a fragment's vital statistics.
#
sub vitals ($) {
	my $self = shift;
	ref($self) or croak;
	return "start:". $self->start ." end:". $self->end ." mf:". $self->mf;
}

####

1;

__END__

####

=head1 NAME

Net::Pcap::Reassemble - IP fragment reassembly for Net::Pcap

=head1 SYNOPSIS

 use Net::Pcap::Reassemble;

 my $pcap_t = Net::Pcap::open_offline($opt_p, \$err);
 if (!defined($pcap_t)) {
   print STDERR "Net::Pcap::open_offline returned error: $err\n";
   exit 1;
 }

 Net::Pcap::Reassemble::loop($pcap_t, -1, \&callback, "user data");

=head1 DESCRIPTION

This module performs reassembly of fragmented datagrams in libpcap
packet capture data returned by the B<Net::Pcap> C<loop()> function.
This module supports reassembly of IPv4 and IPv6 fragments.

=head1 FUNCTIONS

=over 4

=item loop($pcap, $count, \&callback, $user_data)

The C<loop()> function in B<Net::Pcap::Reassemble> is intended as a
seamless wrapper around the same function from B<Net::Pcap> and as such
it takes the same arguments. B<Net::Pcap::Reassemble>, however, will
only invoke the C<&callback> function when it has a complete packet.

The module will print debug information to stdout (mainly packet header
values) if the C<$debug> variable in the package namespace evaluates to
true:

 $Net::Pcap::Reassemble::debug = 1;

=item flush()

The C<flush()> function destroys the data structures storing any
incomplete datagrams. This function can be called after C<loop()> has
returned to release memory used by the fragments of incomplete datagrams
(assuming your program continues executing after the C<loop()> finishes).

=back

=head1 OBJECTS

Data is represented internally using C<Net::Pcap::Reassemble::Packet>
and C<Net::Pcap::Reassemble::Fragment> class objects.

=over 4

=item Net::Pcap::Reassemble::Packet

Each `Packet' object represents a complete captured packet and contains:

=over 2

=item 1

An ID: 'srcip dstip IPid protocol' for IPv4; 'srcip dstip IPid' for IPv6

=item 2

A list of C<Net::Pcap::Reassemble::Fragment> object references

=item 3

The final octet, learned from the packet with MF==0

=item 4

A flag to indicate if the fragment list is sorted

=back

It has class functions to add a fragment to the Packet
(C<addfragment()>), return a string with information on the fragments
received so far (C<listfragments()>), and to test whether a datagram is
complete and return its data if it is (C<iscomplete()>).

=item Net::Pcap::Reassemble::Fragment

Each `Fragment' object represents an IP datagram fragment and contains:

=over 2

=item 1

Start octet

=item 2

End octet

=item 3

(M)ore (F)ragments flag (`MF' in IPv4; `M' in IPv6)

=item 4

Payload data

=back

It has class functions to return the data above (C<start()>, C<end()>,
C<mf()> and C<data()>), and a summary string for debugging (C<vitals()>).

=back

=head1 SEE ALSO

L<Net::Pcap>

=head1 BUGS

=over 4

=item *

Stale fragments are not aged out of the pending fragment list.

=item *

This module offers no resistance against fragment overlap attacks, and
other such malarky.

=item *

loop() should accept an optional anonymous hash reference for option
passing.

=item *

Incomplete datagrams are left in limbo. Should be able to signal via an
option that the callback be invoked for individual fragments aswell as
the complete datagram.

=back

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. (Being a speaker of British english,
I'd call it a "licence" though)

=head1 AUTHOR

James Raftery <james@now.ie>.

=cut

####
