#!/usr/bin/perl
###########################################################################
# creates a UAC, a UAS and a stateless proxy using Net::SIP::Simple
# makes call from UAC to UAS via proxy
# transfers RTP data during call, then hangs up
# tests will be done without NAT, with inline NAT and with external nathelper
###########################################################################
use strict;
use warnings;
use Test::More tests => 63*6;
do './testlib.pl' || do './t/testlib.pl' || die "no testlib";
use Net::SIP ':all';
use Net::SIP::NATHelper::Local;
use Net::SIP::NATHelper::Server;
use Net::SIP::NATHelper::Client;
use IO::Socket;
use File::Temp;
use List::Util;
my @tests;
for my $transport (qw(udp tcp tls)) {
for my $family (qw(ip4 ip6)) {
push @tests, [ $transport, $family ];
}
}
for my $t (@tests) {
my ($transport,$family) = @$t;
SKIP: {
if (my $err = test_use_config($family,$transport)) {
skip $err,63;
next;
}
note("------- test with family $family transport $transport");
do_test($transport)
}
}
killall();
sub do_test {
my $transport = shift;
my ($luac,$luas,@lproxy);
for (
[ 'caller.sip.test', \$luac ],
[ 'listen.sip.test', \$luas ],
[ 'proxy.sip.test', \$lproxy[0] ],
[ 'proxy.sip.test', \$lproxy[1] ],
) {
my ($name,$config) = @$_;
my ($sock,$addr) = create_socket($transport);
$$config = {
name => $name,
sock => $sock,
addr => $addr,
uri => test_sip_uri($addr),
};
}
note( "UAS on $luas->{addr} " );
note( "UAC on $luac->{addr} " );
note( "PROXY on $lproxy[0]{addr} $lproxy[1]{addr} " );
# restrict legs of proxy so that packets gets routed even
# if all is on the same interface. Enable dumping on
# incoing and outgoing packets to check NAT
for ( $luac,$luas,$lproxy[0],$lproxy[1] ) {
$_->{leg} = TestLeg->new(
sock => $_->{sock},
dump_incoming => [ \&sip_dump_media,'I<' ],
dump_outgoing => [ \&sip_dump_media,'O>' ],
$_ == $lproxy[0] ? ( can_deliver_to => $luac->{addr} ) :(),
$_ == $lproxy[1] ? ( can_deliver_to => $luas->{addr} ) :(),
test_leg_args($_->{name}),
);
}
# socket for nathelper server
my ($nath_sock,$nath_addr) = create_socket('tcp') or die $!;
foreach my $spec ( qw( no-nat inline-nat remote-nat )) {
my $natcb;
if ( $spec eq 'inline-nat' ) {
$natcb = sub { NATHelper_Local->new( shift ) };
} elsif ( $spec eq 'remote-nat' ) {
fork_sub( 'nathelper',$nath_sock );
$natcb = sub { NATHelper_Client->new( $nath_addr ) }
}
# start proxy and UAS and wait until they are ready
my $proxy = fork_sub( 'proxy', @lproxy,$luas->{uri},$natcb );
my $uas = fork_sub( 'uas', $luas );
fd_grep_ok( 'ready',10,$proxy ) || die;
fd_grep_ok( 'ready',10,$uas ) || die;
# UAC: invite and transfer RTP data
my $uac = fork_sub( 'uac', $luac, $lproxy[0]{uri} );
fd_grep_ok( 'ready',10,$uac ) || die;
my $uac_invite = fd_grep_ok( qr{O>.*REQ\(INVITE\) SDP: audio=\S+},5,$uac ) || die;
my $pin_invite = fd_grep_ok( qr{I<.*REQ\(INVITE\) SDP: audio=\S+},5,$proxy ) || die;
my $pout_invite = fd_grep_ok( qr{O>.*REQ\(INVITE\) SDP: audio=\S+},1,$proxy ) || die;
my $uas_invite = fd_grep_ok( qr{I<.*REQ\(INVITE\) SDP: audio=\S+},1,$uas ) || die;
s{.*audio=}{} for ( $uac_invite,$pin_invite,$pout_invite,$uas_invite );
# check for NAT
ok( $uac_invite eq $pin_invite, "outgoing on UAC must be the same as incoming on proxy" );
ok( $pout_invite eq $uas_invite, "outgoing on proxy must be the same as incoming on UAS" );
if ( $spec eq 'no-nat' ) {
ok( $uac_invite eq $uas_invite, "SDP must pass unchanged to UAS" );
} else {
# get port/range and compare
my ($sock_i,$range_i) = split( m{/},$pin_invite,2 );
my ($sock_o,$range_o) = split( m{/},$pout_invite,2 );
ok( $sock_i ne $sock_o, "allocated addr:port must be different ($sock_i|$sock_o)" );
ok( $range_i == $range_o, "ranges must stay the same" );
}
# top via must be from lproxy[1], next via from UAC
# this is to show that the request went through the proxy
fd_grep_ok( 'call created',10,$uas );
fd_grep_ok( qr{\Qvia: SIP/2.0/$transport $lproxy[1]{addr};}i,1,$uas );
fd_grep_ok( qr{\Qvia: SIP/2.0/$transport $luac->{addr};}i,1,$uas );
# done
fd_grep_ok( 'RTP done',10,$uac );
fd_grep_ok( 'RTP ok',10,$uas );
fd_grep_ok( 'END',10,$uac );
fd_grep_ok( 'END',10,$uas );
killall();
}
}
# --------------------------------------------------------------
# Proxy
# --------------------------------------------------------------
sub proxy {
my ($lsock_c,$lsock_s,$proxy_uri,$natcb) = @_;
# need loop separately
my $loop = Dispatcher_Eventloop->new;
my $nathelper = invoke_callback( $natcb,$loop );
# create Net::SIP::Simple object
my $proxy = Simple->new(
loop => $loop,
legs => [ $lsock_c->{leg}, $lsock_s->{leg} ],
domain2proxy => { 'example.com' => $proxy_uri },
);
$proxy->create_stateless_proxy(
nathelper => $nathelper
);
print "ready\n";
$proxy->loop;
}
# --------------------------------------------------------------
# UAC
# --------------------------------------------------------------
sub uac {
my ($lsock,$proxy_uri) = @_;
my $packets = 100;
my $send_something = sub {
return unless $packets-- > 0;
my $buf = sprintf "%010d",$packets;
$buf .= "1234567890" x 15;
return $buf; # 160 bytes for PCMU/8000
};
# create Net::SIP::Simple object
my $uac = Simple->new(
from => 'me.uac@example.com',
leg => $lsock->{leg},
outgoing_proxy => $proxy_uri,
) || die;
print "ready\n";
# Call UAS vi proxy
my $rtp_done;
my $call = $uac->invite(
'you.uas@example.com',
init_media => $uac->rtp( 'send_recv', $send_something ),
cb_rtp_done => \$rtp_done,
);
print "call established\n" if $call && ! $uac->error;
$call->loop( \$rtp_done, 10 );
print "RTP done\n" if $rtp_done;
my $stop;
$call->bye( cb_final => \$stop );
$call->loop( \$stop,10 );
$uac->cleanup;
print "END\n";
}
# --------------------------------------------------------------
# UAS
# --------------------------------------------------------------
sub uas {
my ($leg) = @_;
my $uas = Simple->new(
domain => 'example.com',
leg => $leg->{leg}
) || die $!;
# store received RTP data in array
my @received;
my $save_rtp = sub {
my $buf = shift;
push @received,$buf;
#warn substr( $buf,0,10)."\n";
};
# Listen
my $call_closed;
my $cb_create = sub {
my ($call,$request) = @_;
print "call created\n";
print $request->as_string;
1;
};
$uas->listen(
cb_create => $cb_create,
cb_established => sub { print "call established\n" },
cb_cleanup => sub {
print "call cleaned up\n";
$call_closed =1;
},
init_media => $uas->rtp( 'recv_echo', $save_rtp ),
);
print "ready\n";
# Loop until call is closed, at most 10 seconds
$uas->loop( \$call_closed, 10 );
$uas->cleanup;
print "received ".int(@received)."/100 packets\n";
# at least 20% of all RTP packets should come through
if ( @received > 20 ) {
print "RTP ok\n"
} else {
print "RTP received only ".int(@received)."/100 packets\n";
}
# done
if ( $call_closed ) {
print "END\n";
} else {
print "call closed by timeout not stopvar\n";
}
}
# --------------------------------------------------------------
# NATHelper::Server
# --------------------------------------------------------------
sub nathelper {
my $sock = shift;
NATHelper_Server->new( $sock )->loop;
}