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