1#!/usr/bin/perl 2# make sure that ACK to error response gets passed through proxy 3 4use strict; 5use warnings; 6use Test::More; 7do './testlib.pl' || do './t/testlib.pl' || die "no testlib"; 8 9use Net::SIP ':all'; 10use Net::SIP::NATHelper::Local; 11use Net::SIP::NATHelper::Server; 12use Net::SIP::NATHelper::Client; 13use Net::SIP::Blocker; 14 15my @tests; 16for my $transport (qw(udp tcp tls)) { 17 for my $family (qw(ip4 ip6)) { 18 for my $nat ('no-nat', 'inline-nat', 'remote-nat') { 19 push @tests, [ $transport, $family, $nat ]; 20 } 21 } 22} 23#@tests = ['udp','ip4','no-nat']; 24my $testsize = 19; 25plan tests => $testsize*@tests; 26 27for my $t (@tests) { 28 my ($transport,$family,$nat) = @$t; 29 SKIP: { 30 if (my $err = test_use_config($family,$transport)) { 31 skip $err,$testsize; 32 next; 33 } 34 note("------- test with family $family transport $transport $nat"); 35 do_test($transport,$nat) 36 } 37} 38 39killall(); 40 41sub do_test { 42 my ($transport,$natspec) = @_; 43 44 my ($luac,$luas,@lproxy); 45 for ( 46 [ 'caller.sip.test', \$luac ], 47 [ 'listen.sip.test', \$luas ], 48 [ 'proxy.sip.test', \$lproxy[0] ], 49 [ 'proxy.sip.test', \$lproxy[1] ], 50 ) { 51 my ($name,$config) = @$_; 52 my ($sock,$addr) = create_socket($transport); 53 $$config = { 54 name => $name, 55 sock => $sock, 56 addr => $addr, 57 uri => test_sip_uri($addr), 58 }; 59 } 60 61 note( "UAS on $luas->{addr} " ); 62 note( "UAC on $luac->{addr} " ); 63 note( "PROXY on $lproxy[0]{addr} $lproxy[1]{addr} " ); 64 65 # restrict legs of proxy so that packets gets routed even 66 # if all is on the same interface. Enable dumping on 67 # incoing and outgoing packets to check NAT 68 for ( $luac,$luas,$lproxy[0],$lproxy[1] ) { 69 $_->{leg} = TestLeg->new( 70 sock => $_->{sock}, 71 dump_incoming => [ \&sip_dump_media,'I<' ], 72 dump_outgoing => [ \&sip_dump_media,'O>' ], 73 $_ == $lproxy[0] ? ( can_deliver_to => $luac->{addr} ) :(), 74 $_ == $lproxy[1] ? ( can_deliver_to => $luas->{addr} ) :(), 75 test_leg_args($_->{name}), 76 ); 77 } 78 79 # socket for nathelper server 80 my ($nath_sock,$nath_addr) = create_socket('tcp') or die $!; 81 82 my $natcb; 83 if ( $natspec eq 'inline-nat' ) { 84 $natcb = sub { NATHelper_Local->new( shift ) }; 85 ok(1,'no fork nathelper'); 86 } elsif ( $natspec eq 'remote-nat' ) { 87 fork_sub( 'nathelper',$nath_sock ); 88 $natcb = sub { NATHelper_Client->new( $nath_addr ) } 89 } else { 90 ok(1,'no fork nathelper'); 91 } 92 93 # start proxy and UAS and wait until they are ready 94 my $proxy = fork_sub( 'proxy', @lproxy,$luas->{uri},$natcb ); 95 my $uas = fork_sub( 'uas', $luas ); 96 fd_grep_ok( 'ready',10,$proxy ) || die; 97 fd_grep_ok( 'ready',10,$uas ) || die; 98 99 # UAC: invite 100 my $uac = fork_sub( 'uac', $luac, $lproxy[0]{uri} ); 101 fd_grep_ok( 'ready',10,$uac ) || die; 102 fd_grep_ok( qr{O>.*REQ\(INVITE\) SDP: audio=\S+},5,$uac ) || die; 103 fd_grep_ok( qr{I<.*REQ\(INVITE\) SDP: audio=\S+},5,$proxy ) || die; 104 fd_grep_ok( qr{O>.*REQ\(INVITE\) SDP: audio=\S+},1,$proxy ) || die; 105 fd_grep_ok( qr{I<.*REQ\(INVITE\) SDP: audio=\S+},1,$uas ) || die; 106 107 # UAS: reject with error 404 - propagate to uac via proxy 108 fd_grep_ok( qr{O>.*RSP\(INVITE,404\)},5,$uas) || die; 109 fd_grep_ok( qr{I<.*RSP\(INVITE,404\)},5,$proxy) || die; 110 fd_grep_ok( qr{O>.*RSP\(INVITE,404\)},1,$proxy) || die; 111 fd_grep_ok( qr{I<.*RSP\(INVITE,404\)},1,$uac) || die; 112 113 # UAC: reply with ACK to error - propagate to uas via proxy 114 fd_grep_ok( qr{O>.*REQ\(ACK\)},5,$uac ) || die; 115 fd_grep_ok( qr{I<.*REQ\(ACK\)},5,$proxy ) || die; 116 fd_grep_ok( qr{O>.*REQ\(ACK\)},1,$proxy ) || die; 117 fd_grep_ok( qr{I<.*REQ\(ACK\)},1,$uas ) || die; 118 119 killall(); 120} 121 122 123killall(); 124 125############################################################################# 126# Proxy 127############################################################################# 128sub proxy { 129 my ($lsock_c,$lsock_s,$proxy_uri,$natcb) = @_; 130 131 # need loop separately 132 my $loop = Dispatcher_Eventloop->new; 133 my $nathelper = invoke_callback( $natcb,$loop ); 134 135 # create Net::SIP::Simple object 136 my $proxy = Simple->new( 137 loop => $loop, 138 legs => [ $lsock_c->{leg}, $lsock_s->{leg} ], 139 domain2proxy => { 'example.com' => $proxy_uri }, 140 ); 141 $proxy->create_stateless_proxy( 142 nathelper => $nathelper 143 ); 144 print "ready\n"; 145 $proxy->loop; 146} 147 148 149############################################################################# 150# UAC 151############################################################################# 152 153sub uac { 154 my ($leg,$proxy_uri) = @_; 155 my $ua = Simple->new( 156 from => '<sip:me.uac@example.com>', 157 leg => $leg->{leg}, 158 outgoing_proxy => $proxy_uri, 159 ); 160 print "ready\n"; 161 162 my $done; 163 my $call = $ua->invite('<sip:you.uas@example.com>', 164 cb_final => \$done, 165 ) or die; 166 $ua->loop(10,\$done); 167 $ua->cleanup; 168} 169 170 171############################################################################# 172# UAS 173############################################################################# 174 175sub uas { 176 my ($leg) = @_; 177 print "UAS created\n"; 178 179 my $ua = Simple->new( 180 from => '<sip:me.uas@example.com>', 181 leg => $leg->{leg}, 182 ); 183 print "ready\n"; 184 $ua->listen( 185 cb_invite => sub { 186 my ($self,$request) = @_; 187 return $request->create_response('404','unknown',{}); 188 } 189 ); 190 $ua->loop(10); 191} 192 193# -------------------------------------------------------------- 194# NATHelper::Server 195# -------------------------------------------------------------- 196sub nathelper { 197 my $sock = shift; 198 NATHelper_Server->new( $sock )->loop; 199} 200