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