bin/stateless_proxy.pl - metacpan.org

###########################################################################
# Stateless proxy
# listens on multiple legs and forwards SIP packets between the legs
# TODO: do NAT
###########################################################################

use strict;
use warnings;
use IO::Socket::INET;
use Getopt::Long qw(:config posix_default bundling);
use List::Util 'first';

use Net::SIP;
use Net::SIP::Util ':all';
use Net::SIP::Debug;
use Net::SIP::NATHelper::Local;
use Storable;

$SIG{TERM} = $SIG{INT} = sub { exit(0) };

sub usage {
	print STDERR "ERROR: @_\n" if @_;
	print STDERR <<EOS;
usage: $0 [ basic_options ] (
	--leg ip[:port]
	[ --registrar ]
	[ --domain domain ]*
	[ --proxy host[:port]
)+

Listens on given local addresses and forwards SIP packets between
the created legs. For each leg it can specify a number of domains,
which are used on this side of the leg, if none are specified everything
is accepted. If option --registrar is given it will work as a registrar
for the specified domains on this leg.

Basic options:
  -d|--debug [level]           Enable debugging
  -h|--help                    Help (this info)
  --rdump file                 dump/restore register information into/from this file
  --nathelper                  use local NATHelper
Leg specific options:
  -L|--leg  ip[:port]          specify leg
  -D|--domain domain           specify domain on legs side
  -P|--proxy host[:port]       send all packets on leg via host as proxy
  -r|--registrar               work as registrar on this leg
  -X|--prefix DD=tgt-domain    rewrite target number DDXXXX\@domain to XXXX\@tgt-domain

Example:

  Listen on 192.168.0.2:5060 and accept requests from example.com and work
  as registrar for example.com. Route calls for example.com on this leg, all
  other calls are forwarded through leg 192.168.178.3:5060.
  Calls for recipients 0XXX\@example.com gets rewritten to 
  XXX\@sip-gateway.example.com and routed accordingly via 192.168.178.3:5060.
  On 192.168.178.3:5060 requests from everywhere, but only for example.com
  are accepted.

  $0 -d 50 \
  --leg 192.168.0.2:5060 --domain example.com -r -X 0=sip-gateway.example.com \
  --leg 192.168.178.3:5060 --proxy 192.168.178.3

EOS
	exit( @_ ? 1:0 );
}

###################################################
# Get options
###################################################

my (%legs,$debug);
my (@domains,%prefix,$be_registrar,$proxy,$leg,$rdump,$nathelper);
my $check_leg = sub {
	my (undef,$val) = @_;
	if ( $leg ) {
		$legs{$leg} = {
			domains => @domains ? [ @domains ] : undef,
			prefix => %prefix ? { %prefix }: undef,
			registrar => $be_registrar,
			proxy => $proxy,
		};
		(@domains,%prefix,$be_registrar,$proxy) = ();
	}
	$leg = $val;
};
GetOptions(
	'd|debug:i'   => \$debug,
	'h|help'      => sub { usage() },
	'rdump=s'     => \$rdump,
	'nathelper'   => \$nathelper,
	'L|leg=s'     => $check_leg,
	'r|registrar' => \$be_registrar,
	'D|domain=s'  => \@domains,
	'P|proxy=s'   => \$proxy,
	'X|prefix=s'  => sub {
		my ($prefix,$domain) = $_[1] =~m{^(\d+)=(\w[\w\-\.]+)$}
			or usage( "bad prefix $_[1]" );
		$prefix{$prefix} = $domain;
	},
) || usage( "bad option" );

$check_leg->(); #final call
Net::SIP::Debug->level( $debug || 1 ) if defined $debug;
%legs or usage( 'no addr to listen' );

###################################################
# create Legs
###################################################

my (%domain2leg,%leg2proxy,%leg2rewrite);
while ( my ($addr,$opt) = each %legs ) {
	my $leg = $opt->{leg} = Net::SIP::Leg->new( addr => $addr );
	foreach my $dom (@{ $opt->{domains} }) {
		$domain2leg{$dom}   = $leg;
		$leg2proxy{$leg} = $opt->{proxy} if $opt->{proxy};
	}
	if ( my $p = $opt->{prefix} ) {
		my %p = %{ $opt->{prefix} };
		# longest prefix first
		my @pf = sort { length($b) <=> length($a) } keys %p;
		$leg2rewrite{$leg} = sub {
			my ($user,$dom) = @_;
			$user or return;
			DEBUG( 50,"try to rewrite $user\@$dom, pf=@pf" );
			for my $pf (@pf) {
				if ( $user =~m{^\Q$pf\E(.+)} ) {
					return ($1,$p{$pf});
				}
			}
			return;
		};
	}
}

###################################################
# create Dispatcher
###################################################

my $loop = Net::SIP::Dispatcher::Eventloop->new;
my $disp = Net::SIP::Dispatcher->new(
	[ map { $_->{leg} } values(%legs) ],
	$loop,
);

$nathelper = $nathelper && Net::SIP::NATHelper::Local->new($loop);

###################################################
# create Registrars on the legs and wraps them
# together into on object
###################################################

my %savereg;
END {
	$rdump or return;
	Storable::store( \%savereg,$rdump );
}

my %registrar;
if ( my $regdata = $rdump && -f $rdump &&  Storable::retrieve($rdump)) {
	%savereg = %$regdata 
}
foreach my $opt ( values %legs ) {
	$opt->{registrar} or do {
		DEBUG( 50,"no registrar on leg $opt->{leg} ".$opt->{leg}->dump );
		next;
	};
	my $reg = $registrar{ $opt->{leg} } = Net::SIP::Registrar->new(
		dispatcher => $disp,
		domains    => $opt->{domains},
		#min_expires => 1,
		#max_expires => 15,
	);
	DEBUG( 50,"create registrar on leg $opt->{leg} ".$opt->{leg}->dump." for domains @{$opt->{domains}}" );
	my $key = $opt->{leg}->dump;
	$reg->_store( $savereg{$key} ||= {} );
}

my $registrar = %registrar
	? myRegistrar->new( %registrar )
	: undef;

###################################################
# create StatelessProxy
###################################################

my $stateless_proxy = myProxy->new(
	dispatcher    => $disp,
	domain2leg    => \%domain2leg,
	leg2rewrite   => \%leg2rewrite,
	leg2registrar => \%registrar,
	leg2proxy     => \%leg2proxy,
	nathelper     => $nathelper,
);

if ( $registrar ) {
	# create chain, where first the registrar gets the packet
	# and the proxy will handle it only, if the registrar
	# does not handle it
	my $chain = Net::SIP::ReceiveChain->new( 
		[ $registrar, $stateless_proxy ]
	);
	DEBUG( 50,"set receiver to $chain" );
	$disp->set_receiver( $chain );
} else {
	DEBUG( 50,"set receiver to $stateless_proxy" );
	$disp->set_receiver( $stateless_proxy );
}

###################################################
# run..
###################################################
$loop->loop;


###################################################
###################################################
#
# myRegistrar contains multiple registrars
# the receive method checks based on the incoming
# leg, if one of the registrars is responsable
# it will not be queried, this will be done on
# the single registrars
#
###################################################
###################################################

package myRegistrar;
use Net::SIP::Debug;

sub new {
	my ($class,%hash) = @_;
	# Net::SIP::Registrar objects indexed by string
	# representation of leg
	return bless \%hash,$class
}

sub receive {
	my myRegistrar $self = shift;
	my ($packet,$leg,$addr) = @_;
	return unless $packet->is_request and $packet->method eq 'REGISTER';
	DEBUG( 50,"Registrar got ".$packet->dump );
	# return undef if not registrar for leg, otherwise
	# let it handle by the registrar object
	my $reg = $self->{$leg} || return;
	return $reg->receive( @_ );
}

###################################################
###################################################
#
# myProxy
# special handling for domain2leg and registrars
# on the leg and for rewriting leg2rewrite and
# setting dst with leg2proxy
#
###################################################
###################################################

package myProxy;
use base 'Net::SIP::StatelessProxy';
use Net::SIP::Debug;
use Net::SIP::Util ':all';
use fields qw( domain2leg leg2registrar leg2rewrite leg2proxy );

sub new {
	my ($class,%args) = @_;
	my $d2l     = delete $args{domain2leg};
	my $reg     = delete $args{leg2registrar};
	my $rewrite = delete $args{leg2rewrite};
	my $l2p     = delete $args{leg2proxy};
	my $self = $class->SUPER::new( %args,
		rewrite_contact => \&_rewrite_contact,
	);
	$self->{domain2leg}    = $d2l;
	$self->{leg2registrar} = $reg;
	$self->{leg2rewrite}   = $rewrite;
	$self->{leg2proxy}     = $l2p;
	return $self;
}

# QUICK and DIRTY caching of contact rewrites
{
	my ($cache,$cache_old,$trotate,$random);
	sub _rewrite_contact {
		my ($contact) = @_;
		my $now = time();
		if ( ! $trotate || $now - $trotate > 600 ) {
			$cache_old = $cache;
			$trotate = $now;
		}
		my $hit = $cache->{$contact};
		if ( ! $hit && ( $hit = $cache_old->{$contact})) {
			# refresh cache
			$cache->{$contact} = $hit
		}
		$hit and do {
			DEBUG( 50,"rewrote $contact -> $hit" );
			return $hit
		};
		$contact !~m{\@} and do {
			# no hit for rewrite back found
			DEBUG( 50,"no rewrite back for $contact found" );
			return;
		};


		# create new rewrite
		$random ||= rand( 2**32 );
		for( my $try = 0;$try < 1000; $try++ ) {
			my $rw = sprintf "%x.%x",rand(2**32),$random;
			next if $cache->{$rw} || $cache_old->{$rw};
			$cache->{$rw} = $contact;
			$cache->{$contact} = $rw;
			DEBUG( 50,"rewrite $contact -> $rw (NEW)" );
			return $rw;
		}
		DEBUG( 50,"rewrite failed, cache too full..." );
		return;
	}
}

# FIXME: move to Net::SIP::Util
# reverse to sip_uri2parts
sub sip_parts2uri {
	my ($domain,$user,$sip_proto,$param) = @_;
	my $uri = "$sip_proto:$user\@$domain";
	return sip_parts2hdrval( 'to',$uri,$param )
}


sub __forward_request_getleg {
	my myProxy $self = shift;
	my $entry = shift;
	my $packet = $entry->{packet};

	# rewrite packet
	if ( my $lrw = $self->{leg2rewrite} ) {
		if ( my $rw = $lrw->{$entry->{incoming_leg}} ) {
			DEBUG( 50,"rewrite URI in request\n".$packet->dump );

			# rewrite URI
			# FIXME: this works only for RFC3261 conform requests!
			my $uri = $packet->uri;
			my ($domain,$user,$sip_proto,undef,$param) = sip_uri2parts($uri);
			if ( ($user,$domain) = $rw->($user,$domain) ) {
				my $new_uri = sip_parts2uri( $domain,$user,$sip_proto,$param);
				DEBUG( 50,"rewrite URI $uri to $new_uri" );
				$packet->set_uri($new_uri);
			}
		} else {
			DEBUG( 50,"no rewriting" );
		}
	}

	if ( my @r = $packet->get_header( 'route' )) {
		# default routing
		DEBUG( 50,"have route header, no special handling" );
		$entry->{has_route} = 1;
		return $self->SUPER::__forward_request_getleg( $entry )
	}

	my ($domain,$user,$sip_proto,undef,$param) = sip_uri2parts($packet->uri);

	my $d2l = $self->{domain2leg};
	my $disp = $self->{dispatcher};
	my @legs; # list of possible outgoing legs

	if ( $d2l && %$d2l ) {
		##### special routing based on domain2leg
		DEBUG( 50,"special routing based on domain2leg, domain=$domain" );
		my $dom = $domain;
		my $leg = $d2l->{$dom}; # exact match
		while ( ! $leg) {
			$dom =~s{^[^\.]+\.}{} or last;
			$leg = $d2l->{ "*.$dom" };
		}
		$leg ||= $d2l->{ $dom = '*'}; # catch-all
		if ( ! $leg ) {
			DEBUG( 50,"no leg found for domain $domain" );
			# limit to legs for which I have no domain2leg mapping
			my %legs = map { $_ => $_ } @{ $disp->{legs} };
			delete @legs{ values %$d2l };
			@legs = values %legs;
		} else {
			DEBUG( 50,"found leg=".$leg->dump." for domain $domain" );
			@legs = $leg
		}
		if ( ! @legs ) {
			# no available legs -> DROP
			DEBUG( 2,"no leg for domain $domain and no legs w/o domain -> DROP ".$packet->dump );
			return;
		}
	}

	if ( my $l2r = $self->{leg2registrar} ) {
		#### try if the registrar has the address on some leg
		#### if, then set the outgoing leg and rewrite the packet to
		#### reflect the new URI
		my @reg = @legs ? @{$l2r}{@legs} : values %$l2r;
		for my $leg ( @legs ? @legs : values %$l2r ) {
			my $reg = $l2r->{$leg} or next;
			DEBUG( 10,"query registrar for $sip_proto:$user\@$domain" );
			my @addr = $reg->query( "$sip_proto:$user\@$domain" ) or next;
			$packet->set_uri( $addr[0] );
			@legs = grep { $_ eq $leg } @{ $disp->{legs}};
			last;
		}
	}

	@{ $entry->{outgoing_leg}} = @legs;
	return $self->SUPER::__forward_request_getleg( $entry );
}

sub __forward_request_getdaddr {
	my myProxy $self = shift;
	my $entry = shift;
	my $legs = $entry->{outgoing_leg};

	# if leg was given by route try to check for Registrar there
	if ( @$legs && $entry->{has_route} && ( my $reg = $self->{leg2registrar}{$legs->[0]} )) {
		#### try if the registrar has the address on the leg
		#### if, then set the outgoing leg and rewrite the packet to
		#### reflect the new URI
		my $packet = $entry->{packet};
		my ($domain,$user,$sip_proto) = sip_uri2parts($packet->uri);
		DEBUG( 10,"query registrar for $sip_proto:$user\@$domain" );
		if ( my @addr = $reg->query( "$sip_proto:$user\@$domain" )) {
			$packet->set_uri( $addr[0] );
		}
	}

	# find out proxy on leg
	if (@$legs == 1 && ( my $addr = $self->{leg2proxy}{$legs->[0]} )) {
		$addr .= ':5060' if $addr !~m{:\d+$};
		DEBUG( 50,"set addr to $addr from legs proxy address" );
		@{ $entry->{dst_addr}} = $addr;
	}
	return $self->SUPER::__forward_request_getdaddr( $entry );
}
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)