line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
########################################################################### |
2
|
|
|
|
|
|
|
# Net::SIP::StatelessProxy |
3
|
|
|
|
|
|
|
# implements a simple stateless proxy |
4
|
|
|
|
|
|
|
# all packets will be forwarded between Leg#1 to Leg#2. If there is |
5
|
|
|
|
|
|
|
# only one leg it will use only this leg. |
6
|
|
|
|
|
|
|
########################################################################### |
7
|
|
|
|
|
|
|
|
8
|
41
|
|
|
41
|
|
291
|
use strict; |
|
41
|
|
|
|
|
120
|
|
|
41
|
|
|
|
|
1271
|
|
9
|
41
|
|
|
41
|
|
225
|
use warnings; |
|
41
|
|
|
|
|
76
|
|
|
41
|
|
|
|
|
1752
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
package Net::SIP::StatelessProxy; |
12
|
41
|
|
|
41
|
|
231
|
use fields qw( dispatcher rewrite_contact nathelper force_rewrite respcode ); |
|
41
|
|
|
|
|
112
|
|
|
41
|
|
|
|
|
229
|
|
13
|
|
|
|
|
|
|
|
14
|
41
|
|
|
41
|
|
3578
|
use Net::SIP::Util ':all'; |
|
41
|
|
|
|
|
76
|
|
|
41
|
|
|
|
|
7428
|
|
15
|
41
|
|
|
41
|
|
322
|
use Digest::MD5 qw(md5); |
|
41
|
|
|
|
|
79
|
|
|
41
|
|
|
|
|
1802
|
|
16
|
41
|
|
|
41
|
|
232
|
use Carp 'croak'; |
|
41
|
|
|
|
|
77
|
|
|
41
|
|
|
|
|
2419
|
|
17
|
41
|
|
|
41
|
|
257
|
use List::Util 'first'; |
|
41
|
|
|
|
|
127
|
|
|
41
|
|
|
|
|
2506
|
|
18
|
41
|
|
|
41
|
|
329
|
use Hash::Util 'lock_ref_keys'; |
|
41
|
|
|
|
|
129
|
|
|
41
|
|
|
|
|
332
|
|
19
|
41
|
|
|
41
|
|
2631
|
use Net::SIP::Debug; |
|
41
|
|
|
|
|
116
|
|
|
41
|
|
|
|
|
375
|
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
########################################################################### |
22
|
|
|
|
|
|
|
# creates new stateless proxy |
23
|
|
|
|
|
|
|
# Args: ($class,%args) |
24
|
|
|
|
|
|
|
# %args |
25
|
|
|
|
|
|
|
# dispatcher: the Net::SIP::Dispatcher object managing the proxy |
26
|
|
|
|
|
|
|
# rewrite_contact: callback to rewrite contact header. If called with from header |
27
|
|
|
|
|
|
|
# it should return a string of form \w+. If called |
28
|
|
|
|
|
|
|
# again with this string it should return the original header back. |
29
|
|
|
|
|
|
|
# if called on a string without @ which cannot rewritten back it |
30
|
|
|
|
|
|
|
# should return undef. If not given a reasonable default will be |
31
|
|
|
|
|
|
|
# used. |
32
|
|
|
|
|
|
|
# rewrite_crypt: function(data,dir,add2mac) which will encrypt(dir>0) or |
33
|
|
|
|
|
|
|
# decrypt(dir<0) data. Optional add2mac is added in MAC. Will return |
34
|
|
|
|
|
|
|
# encrypted/decrypted data or undef if decryption failed because |
35
|
|
|
|
|
|
|
# MAC did not match |
36
|
|
|
|
|
|
|
# nathelper: Net::SIP::NAT::Helper used for rewrite SDP bodies.. (optional) |
37
|
|
|
|
|
|
|
# force_rewrite: if true rewrite contact even if incoming and outgoing |
38
|
|
|
|
|
|
|
# legs are the same |
39
|
|
|
|
|
|
|
# Returns: $self |
40
|
|
|
|
|
|
|
########################################################################### |
41
|
|
|
|
|
|
|
sub new { |
42
|
2
|
|
|
2
|
1
|
19
|
my ($class,%args) = @_; |
43
|
2
|
|
|
|
|
6
|
my $self = fields::new( $class ); |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
my $disp = $self->{dispatcher} = |
46
|
2
|
|
33
|
|
|
144
|
delete $args{dispatcher} || croak 'no dispatcher given'; |
47
|
2
|
|
33
|
|
|
9
|
$self->{rewrite_contact} = delete $args{rewrite_contact} || do { |
48
|
|
|
|
|
|
|
my $crypt = $args{rewrite_crypt} || \&_stupid_crypt; |
49
|
|
|
|
|
|
|
[ \&_default_rewrite_contact, $crypt, $disp ]; |
50
|
|
|
|
|
|
|
}; |
51
|
2
|
|
|
|
|
4
|
$self->{nathelper} = delete $args{nathelper}; |
52
|
2
|
|
|
|
|
5
|
$self->{force_rewrite} = delete $args{force_rewrite}; |
53
|
2
|
|
|
|
|
6
|
$self->{respcode} = [ {},{} ]; |
54
|
|
|
|
|
|
|
|
55
|
2
|
|
|
|
|
6
|
return $self; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
# default handler for rewriting, does simple XOR only, |
60
|
|
|
|
|
|
|
# this is not enough if you need to hide internal addresses |
61
|
|
|
|
|
|
|
sub _default_rewrite_contact { |
62
|
7
|
|
|
7
|
|
19
|
my ($crypt,$disp,$contact,$leg_in,$leg_out,$force_rewrite) = @_; |
63
|
|
|
|
|
|
|
|
64
|
7
|
|
|
|
|
11
|
my $legdict; |
65
|
7
|
|
|
|
|
24
|
my ($ileg_in,$ileg_out) = $disp->legs2i($leg_in,$leg_out,\$legdict); |
66
|
|
|
|
|
|
|
|
67
|
7
|
50
|
33
|
|
|
38
|
if ($force_rewrite or $contact =~m{\@}) { |
68
|
|
|
|
|
|
|
# needs to be rewritten - incorporate leg_in:leg_out |
69
|
0
|
|
|
|
|
0
|
$contact = pack("nna*",$ileg_in,$ileg_out,$contact); |
70
|
|
|
|
|
|
|
# add 'b' in front so it does not look like phone number |
71
|
0
|
|
|
|
|
0
|
my $new = 'b'._encode_base32($crypt->($contact,1,$legdict)); |
72
|
0
|
|
|
|
|
0
|
DEBUG( 100,"rewrite $contact -> $new" ); |
73
|
0
|
|
|
|
|
0
|
return $new; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
7
|
50
|
|
|
|
27
|
if ( $contact =~m{^b([A-Z2-7]+)$} ) { |
77
|
|
|
|
|
|
|
# needs to be written back |
78
|
0
|
0
|
|
|
|
0
|
my $old = $crypt->(_decode_base32($1),-1,$legdict) or do { |
79
|
0
|
|
|
|
|
0
|
DEBUG(10,"no rewriting of $contact - bad encryption"); |
80
|
0
|
|
|
|
|
0
|
return; |
81
|
|
|
|
|
|
|
}; |
82
|
0
|
|
|
|
|
0
|
DEBUG(100,"rewrote back $contact -> $old"); |
83
|
0
|
|
|
|
|
0
|
(my $iold_in,my $iold_out,$old) = unpack("nna*",$old); |
84
|
0
|
0
|
|
|
|
0
|
if ($ileg_in ne $iold_out) { |
85
|
0
|
|
|
|
|
0
|
my ($old_out) = $disp->i2legs($iold_out); |
86
|
0
|
0
|
0
|
|
|
0
|
if ($leg_in->{contact} ne $old_out->{contact} |
87
|
|
|
|
|
|
|
&& ! sip_uri_eq($leg_in->{contact},$old_out->{contact})) { |
88
|
|
|
|
|
|
|
DEBUG(10, |
89
|
|
|
|
|
|
|
"no rewriting of %s - went out through %s, came in through %s", |
90
|
0
|
|
|
|
|
0
|
$contact, $old_out->{contact}, $leg_in->{contact}); |
91
|
0
|
|
|
|
|
0
|
return; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
} |
94
|
0
|
0
|
|
|
|
0
|
if ( ref($leg_out) eq 'SCALAR' ) { |
|
|
0
|
|
|
|
|
|
95
|
|
|
|
|
|
|
# return the old_in as the new outgoing leg |
96
|
0
|
0
|
|
|
|
0
|
($$leg_out) = $disp->i2legs($iold_in) or do { |
97
|
0
|
|
|
|
|
0
|
DEBUG(10,"no rewriting of $contact - cannot find leg $iold_in"); |
98
|
0
|
|
|
|
|
0
|
return; |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
} elsif ($leg_out) { |
101
|
|
|
|
|
|
|
# check that it is the expected leg |
102
|
0
|
0
|
|
|
|
0
|
if ($ileg_out ne $iold_in) { |
103
|
0
|
|
|
|
|
0
|
my ($old_in) = $disp->i2legs($iold_in); |
104
|
0
|
0
|
0
|
|
|
0
|
if ($leg_out->{contact} ne $old_in->{contact} |
105
|
|
|
|
|
|
|
&& ! sip_uri_eq($leg_out->{contact},$old_in->{contact})) { |
106
|
|
|
|
|
|
|
DEBUG(10, |
107
|
|
|
|
|
|
|
"no rewriting of %s - went in through %s, should got out through %s", |
108
|
0
|
|
|
|
|
0
|
$contact, $old_in->{contact}, $leg_out->{contact}); |
109
|
0
|
|
|
|
|
0
|
return; |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
} |
113
|
0
|
|
|
|
|
0
|
DEBUG( 100,"rewrite back $contact -> $old" ); |
114
|
0
|
|
|
|
|
0
|
return $old; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
# invalid format |
118
|
7
|
|
|
|
|
35
|
DEBUG( 100,"no rewriting of $contact" ); |
119
|
7
|
|
|
|
|
31
|
return; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
{ |
123
|
|
|
|
|
|
|
# This is only a simple implementation which is in no way cryptographic safe |
124
|
|
|
|
|
|
|
# because it does use a broken cipher (RC4), pseudo-random keys and IV only |
125
|
|
|
|
|
|
|
# and short keys. Nonetheless, it is probably safe for this purpose and does |
126
|
|
|
|
|
|
|
# not depend on non-standard libs, but using openssl bindings might be both |
127
|
|
|
|
|
|
|
# more secure and faster for this. |
128
|
|
|
|
|
|
|
# |
129
|
|
|
|
|
|
|
# RC4 with seed + checksum, picks random key on first use |
130
|
|
|
|
|
|
|
# dir: encrypt(1),decrypt(-1), otherwise symmetric w/o seed and checksum |
131
|
|
|
|
|
|
|
my (@k,$mackey); |
132
|
|
|
|
|
|
|
sub _stupid_crypt { |
133
|
0
|
|
|
0
|
|
0
|
my ($in,$dir,$add2mac) = @_; |
134
|
0
|
0
|
|
|
|
0
|
$add2mac = '' if ! defined $add2mac; |
135
|
|
|
|
|
|
|
|
136
|
0
|
0
|
|
|
|
0
|
if (!@k) { |
137
|
|
|
|
|
|
|
# create random key |
138
|
0
|
|
|
|
|
0
|
@k = map { rand(256) } (0..20); |
|
0
|
|
|
|
|
0
|
|
139
|
0
|
|
|
|
|
0
|
$mackey = pack("N",rand(2**32)); |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
0
|
0
|
|
|
|
0
|
if ($dir>0) { |
143
|
0
|
|
|
|
|
0
|
$in = pack("N",rand(2**32)).$in; # add seed |
144
|
|
|
|
|
|
|
} else { |
145
|
|
|
|
|
|
|
# remove checksum and verify it |
146
|
0
|
|
|
|
|
0
|
my $cksum = substr($in,-4,4,''); |
147
|
0
|
0
|
|
|
|
0
|
substr(md5($in.$add2mac.$mackey),0,4) eq $cksum |
148
|
|
|
|
|
|
|
or return; # does not match |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
# apply RC4 for encryption/decryption |
152
|
0
|
|
|
|
|
0
|
my $out = ''; |
153
|
0
|
|
|
|
|
0
|
my @s = (0..255); |
154
|
0
|
|
|
|
|
0
|
my $x = my $y = 0; |
155
|
0
|
|
|
|
|
0
|
for(0..255) { |
156
|
0
|
|
|
|
|
0
|
$y = ( $k[$_%@k] + $s[$x=$_] + $y ) % 256; |
157
|
0
|
|
|
|
|
0
|
@s[$x,$y] = @s[$y,$x]; |
158
|
|
|
|
|
|
|
} |
159
|
0
|
|
|
|
|
0
|
$x = $y = 0; |
160
|
0
|
|
|
|
|
0
|
for(unpack('C*',$in)) { |
161
|
0
|
|
|
|
|
0
|
$x++; |
162
|
0
|
|
|
|
|
0
|
$y = ( $s[$x%=256] + $y ) % 256; |
163
|
0
|
|
|
|
|
0
|
@s[$x,$y] = @s[$y,$x]; |
164
|
0
|
|
|
|
|
0
|
$out .= pack('C',$_^=$s[($s[$x]+$s[$y])%256]); |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
0
|
0
|
|
|
|
0
|
if ($dir>0) { |
168
|
|
|
|
|
|
|
# add checksum |
169
|
0
|
|
|
|
|
0
|
$out .= substr(md5($out.$add2mac.$mackey),0,4); |
170
|
|
|
|
|
|
|
} else { |
171
|
0
|
|
|
|
|
0
|
substr($out,0,4,''); # remove seed |
172
|
|
|
|
|
|
|
} |
173
|
0
|
|
|
|
|
0
|
return $out; |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
sub _encode_base32 { |
177
|
0
|
|
|
0
|
|
0
|
my $data = shift; |
178
|
0
|
|
|
|
|
0
|
$data = unpack('B*',$data); |
179
|
0
|
|
|
|
|
0
|
my $text; |
180
|
0
|
|
|
|
|
0
|
my $padsize = |
181
|
|
|
|
|
|
|
$data .= '0' x ((5 - length($data) % 5) % 5); # padding |
182
|
0
|
|
|
|
|
0
|
$data =~s{(.....)}{000$1}g; |
183
|
0
|
|
|
|
|
0
|
$data = pack('B*',$data); |
184
|
0
|
|
|
|
|
0
|
$data =~tr{\000-\037}{A-Z2-7}; |
185
|
0
|
|
|
|
|
0
|
return $data; |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
sub _decode_base32 { |
189
|
0
|
|
|
0
|
|
0
|
my $data = shift; |
190
|
0
|
|
|
|
|
0
|
$data =~ tr{A-Z2-7a-z}{\000-\037\000-\031}; |
191
|
0
|
|
|
|
|
0
|
$data = unpack('B*',$data); |
192
|
0
|
|
|
|
|
0
|
$data =~s{...(.....)}{$1}g; |
193
|
0
|
|
|
|
|
0
|
$data = substr($data,0,8*int(length($data)/8)); |
194
|
0
|
|
|
|
|
0
|
return pack('B*',$data); |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
########################################################################### |
199
|
|
|
|
|
|
|
# handle incoming packets |
200
|
|
|
|
|
|
|
# Args: ($self,$packet,$leg,$from) |
201
|
|
|
|
|
|
|
# $packet: Net::SIP::Packet |
202
|
|
|
|
|
|
|
# $leg: incoming leg |
203
|
|
|
|
|
|
|
# $from: ip:port where packet came from |
204
|
|
|
|
|
|
|
# Returns: TRUE if packet was fully handled |
205
|
|
|
|
|
|
|
########################################################################### |
206
|
|
|
|
|
|
|
sub receive { |
207
|
7
|
|
|
7
|
1
|
14
|
my Net::SIP::StatelessProxy $self = shift; |
208
|
7
|
|
|
|
|
14
|
my ($packet,$incoming_leg,$from) = @_; |
209
|
7
|
|
|
|
|
30
|
DEBUG( 10,"received ".$packet->dump ); |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
# Prepare for forwarding, e.g adjust headers |
212
|
|
|
|
|
|
|
# (add record-route) |
213
|
7
|
50
|
|
|
|
33
|
if ( my $err = $incoming_leg->forward_incoming( $packet )) { |
214
|
0
|
|
|
|
|
0
|
my ($code,$text) = @$err; |
215
|
0
|
|
|
|
|
0
|
DEBUG( 10,"ERROR while forwarding: $code, $text" ); |
216
|
0
|
|
|
|
|
0
|
return; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
7
|
|
|
|
|
14
|
my $rewrite_contact = $self->{rewrite_contact}; |
220
|
7
|
|
|
|
|
13
|
my $disp = $self->{dispatcher}; |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
# find out how to forward packet |
223
|
|
|
|
|
|
|
|
224
|
7
|
|
|
|
|
50
|
my %entry = ( |
225
|
|
|
|
|
|
|
packet => $packet, |
226
|
|
|
|
|
|
|
incoming_leg => $incoming_leg, |
227
|
|
|
|
|
|
|
from => $from, |
228
|
|
|
|
|
|
|
outgoing_leg => [], |
229
|
|
|
|
|
|
|
dst_addr => [], |
230
|
|
|
|
|
|
|
nexthop => undef, |
231
|
|
|
|
|
|
|
); |
232
|
|
|
|
|
|
|
|
233
|
7
|
50
|
|
|
|
20
|
if ( $packet->is_response ) { |
234
|
|
|
|
|
|
|
# find out outgoing leg by checking (and removing) top via |
235
|
0
|
0
|
|
|
|
0
|
if ( my ($via) = $packet->get_header( 'via' )) { |
236
|
0
|
|
|
|
|
0
|
my ($data,$param) = sip_hdrval2parts( via => $via ); |
237
|
0
|
|
|
|
|
0
|
my $branch = $param->{branch}; |
238
|
0
|
0
|
|
|
|
0
|
if ( $branch ) { |
239
|
|
|
|
|
|
|
my @legs = $self->{dispatcher}->get_legs( sub => sub { |
240
|
0
|
|
|
0
|
|
0
|
my $lb = shift->{branch}; |
241
|
0
|
|
|
|
|
0
|
$lb eq substr($branch,0,length($lb)); |
242
|
0
|
|
|
|
|
0
|
}); |
243
|
0
|
0
|
|
|
|
0
|
if (@legs) { |
244
|
0
|
|
|
|
|
0
|
$entry{outgoing_leg} = \@legs; |
245
|
|
|
|
|
|
|
# remove top via, see Leg::forward_incoming |
246
|
0
|
|
|
|
|
0
|
my $via; |
247
|
|
|
|
|
|
|
$packet->scan_header( via => [ sub { |
248
|
0
|
|
|
0
|
|
0
|
my ($vref,$hdr) = @_; |
249
|
0
|
0
|
|
|
|
0
|
if ( !$$vref ) { |
250
|
0
|
|
|
|
|
0
|
$$vref = $hdr->{value}; |
251
|
0
|
|
|
|
|
0
|
$hdr->remove; |
252
|
|
|
|
|
|
|
} |
253
|
0
|
|
|
|
|
0
|
}, \$via ]); |
254
|
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
|
} |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
|
258
|
0
|
|
|
|
|
0
|
__forward_response( $self, \%entry ); |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
} else { |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
# check if the URI was handled by rewrite_contact |
263
|
|
|
|
|
|
|
# this is the case where the Contact-Header was rewritten |
264
|
|
|
|
|
|
|
# (see below) and a new request came in using the new |
265
|
|
|
|
|
|
|
# contact header. In this case we need to rewrite the URI |
266
|
|
|
|
|
|
|
# to reflect the original contact header |
267
|
|
|
|
|
|
|
|
268
|
7
|
|
|
|
|
18
|
my ($to) = sip_hdrval2parts( uri => $packet->uri ); |
269
|
7
|
50
|
|
|
|
29
|
$to = $1 if $to =~m{<(\w+:\S+)>}; |
270
|
7
|
50
|
|
|
|
61
|
if ( my ($pre,$name) = $to =~m{^(sips?:)(\S+)?\@} ) { |
271
|
7
|
|
|
|
|
14
|
my $outgoing_leg; |
272
|
7
|
50
|
|
|
|
24
|
if ( my $back = invoke_callback( |
273
|
|
|
|
|
|
|
$rewrite_contact,$name,$incoming_leg,\$outgoing_leg )) { |
274
|
0
|
|
|
|
|
0
|
$to = $pre.$back; |
275
|
0
|
|
|
|
|
0
|
DEBUG( 10,"rewrote URI from '%s' back to '%s'", $packet->uri, $to ); |
276
|
0
|
|
|
|
|
0
|
$packet->set_uri( $to ); |
277
|
0
|
0
|
|
|
|
0
|
$entry{outgoing_leg} = [ $outgoing_leg ] if $outgoing_leg; |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
|
281
|
7
|
|
|
|
|
31
|
$self->__forward_request_getleg( \%entry ); |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
########################################################################### |
286
|
|
|
|
|
|
|
# Get destination address from Via: header in response |
287
|
|
|
|
|
|
|
# Calls __forward_response_1 either directly or after resolving hostname |
288
|
|
|
|
|
|
|
# of destination to IP |
289
|
|
|
|
|
|
|
########################################################################### |
290
|
|
|
|
|
|
|
sub __forward_response { |
291
|
0
|
|
|
0
|
|
0
|
my Net::SIP::StatelessProxy $self = shift; |
292
|
0
|
|
|
|
|
0
|
my $entry = shift; |
293
|
0
|
|
|
|
|
0
|
my $packet = $entry->{packet}; |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
# find out where to send packet by parsing the upper via |
296
|
|
|
|
|
|
|
# which should contain the addr of the next hop |
297
|
|
|
|
|
|
|
|
298
|
0
|
0
|
|
|
|
0
|
my ($via) = $packet->get_header( 'via' ) or do { |
299
|
0
|
|
|
|
|
0
|
DEBUG( 10,"no via header in packet. DROP" ); |
300
|
0
|
|
|
|
|
0
|
return; |
301
|
|
|
|
|
|
|
}; |
302
|
0
|
|
|
|
|
0
|
my ($first,$param) = sip_hdrval2parts( via => $via ); |
303
|
0
|
|
|
|
|
0
|
$first =~m{^SIP/\d\.\d(?:/(\S+))?\s+(.*)}; |
304
|
0
|
|
0
|
|
|
0
|
my $proto = lc($1) || 'udp'; |
305
|
0
|
|
|
|
|
0
|
my ($host,$port,$family) = ip_string2parts($2); |
306
|
0
|
|
0
|
|
|
0
|
my $addr = $family && $host; |
307
|
0
|
0
|
0
|
|
|
0
|
$port ||= $proto eq 'tls' ? 5061 : 5060; |
308
|
0
|
0
|
0
|
|
|
0
|
if (my $alt_addr = $param->{received} || $param->{maddr}) { |
309
|
0
|
|
|
|
|
0
|
my $alt_fam = ip_is_v46($alt_addr); |
310
|
0
|
0
|
|
|
|
0
|
if ($alt_fam) { |
311
|
0
|
|
|
|
|
0
|
$addr = $alt_addr; |
312
|
0
|
|
|
|
|
0
|
$family = $alt_fam; |
313
|
|
|
|
|
|
|
} else { |
314
|
0
|
|
|
|
|
0
|
DEBUG(10,"ignoring maddr/received because of invalid IP $alt_addr"); |
315
|
|
|
|
|
|
|
} |
316
|
|
|
|
|
|
|
} |
317
|
0
|
0
|
|
|
|
0
|
$port = $param->{rport} if $param->{rport}; # where it came from |
318
|
0
|
|
0
|
|
|
0
|
my $nexthop = lock_ref_keys({ |
319
|
|
|
|
|
|
|
proto => $proto, |
320
|
|
|
|
|
|
|
host => $host || $addr, |
321
|
|
|
|
|
|
|
addr => $addr, |
322
|
|
|
|
|
|
|
port => $port, |
323
|
|
|
|
|
|
|
family => $family |
324
|
|
|
|
|
|
|
}); |
325
|
0
|
0
|
|
|
|
0
|
if ($addr) { |
326
|
0
|
|
|
|
|
0
|
@{$entry->{dst_addr}} = $nexthop; |
|
0
|
|
|
|
|
0
|
|
327
|
0
|
0
|
|
|
|
0
|
$DEBUG && DEBUG(50, "get dst_addr from via header: %s -> %s", |
328
|
|
|
|
|
|
|
$first, ip_parts2string($nexthop)); |
329
|
0
|
|
|
|
|
0
|
return __forward_response_1($self,$entry); |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
return $self->{dispatcher}->resolve_uri( |
333
|
|
|
|
|
|
|
sip_sockinfo2uri($nexthop), |
334
|
|
|
|
|
|
|
$entry->{dst_addr}, |
335
|
|
|
|
|
|
|
$entry->{outgoing_leg}, |
336
|
0
|
|
|
|
|
0
|
[ \&__forward_response_1,$self,$entry ], |
337
|
|
|
|
|
|
|
undef, |
338
|
|
|
|
|
|
|
); |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
########################################################################### |
342
|
|
|
|
|
|
|
# Called from _forward_response directly or indirectly after resolving |
343
|
|
|
|
|
|
|
# hostname of destination. |
344
|
|
|
|
|
|
|
# Calls __forward_packet_final at the end to deliver packet |
345
|
|
|
|
|
|
|
########################################################################### |
346
|
|
|
|
|
|
|
sub __forward_response_1 { |
347
|
0
|
|
|
0
|
|
0
|
my Net::SIP::StatelessProxy $self = shift; |
348
|
0
|
|
|
|
|
0
|
my $entry = shift; |
349
|
0
|
0
|
|
|
|
0
|
if (@_) { |
350
|
|
|
|
|
|
|
$DEBUG && DEBUG( 10,"cannot resolve address %s: @_", |
351
|
0
|
0
|
|
|
|
0
|
ip_parts2string($entry->{dst_addr}[0])); |
352
|
0
|
|
|
|
|
0
|
return; |
353
|
|
|
|
|
|
|
} |
354
|
0
|
|
|
|
|
0
|
$self->__forward_packet_final($entry); |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
########################################################################### |
359
|
|
|
|
|
|
|
# Forwards request |
360
|
|
|
|
|
|
|
# try to find outgoing_leg from Route header |
361
|
|
|
|
|
|
|
# if there are more Route headers it picks the destination address from next |
362
|
|
|
|
|
|
|
########################################################################### |
363
|
|
|
|
|
|
|
sub __forward_request_getleg { |
364
|
7
|
|
|
7
|
|
14
|
my Net::SIP::StatelessProxy $self = shift; |
365
|
7
|
|
|
|
|
11
|
my $entry = shift; |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
# if the top route header points to a local leg we use this as outgoing leg |
368
|
7
|
|
|
|
|
31
|
my @route = $entry->{packet}->get_header('route'); |
369
|
7
|
100
|
|
|
|
20
|
if ( ! @route ) { |
370
|
6
|
|
|
|
|
18
|
DEBUG(50,'no route header'); |
371
|
6
|
|
|
|
|
17
|
return $self->__forward_request_getdaddr($entry) |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
|
374
|
1
|
|
33
|
|
|
14
|
my $route = $route[0] =~m{<([^\s>]+)>} && $1 || $route[0]; |
375
|
1
|
|
|
|
|
2
|
my $ol = $entry->{outgoing_leg}; |
376
|
1
|
50
|
33
|
|
|
15
|
if ( $ol && @$ol ) { |
377
|
0
|
0
|
|
|
|
0
|
if ( sip_uri_eq( $route,$ol->[0]{contact})) { |
378
|
0
|
|
|
|
|
0
|
DEBUG(50,"first route header matches choosen leg"); |
379
|
0
|
|
|
|
|
0
|
shift(@route); |
380
|
|
|
|
|
|
|
} else { |
381
|
0
|
|
|
|
|
0
|
DEBUG(50,"first route header differs from choosen leg"); |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
} else { |
384
|
1
|
|
|
|
|
6
|
my ($data,$param) = sip_hdrval2parts( route => $route ); |
385
|
|
|
|
|
|
|
my ($proto, $addr, $port, $family) = |
386
|
1
|
50
|
|
|
|
8
|
sip_uri2sockinfo($data, $param->{maddr} ? 1:0); |
387
|
1
|
0
|
33
|
|
|
5
|
$port ||= $proto eq 'tls' ? 5061 : 5060; |
388
|
|
|
|
|
|
|
my @legs = $self->{dispatcher}->get_legs( |
389
|
1
|
|
|
|
|
7
|
addr => $addr, port => $port, family => $family); |
390
|
1
|
50
|
33
|
|
|
7
|
if ( ! @legs and $param->{maddr} ) { |
391
|
|
|
|
|
|
|
@legs = $self->{dispatcher}->get_legs( |
392
|
|
|
|
|
|
|
addr => $param->{maddr}, |
393
|
1
|
|
|
|
|
4
|
port => $port |
394
|
|
|
|
|
|
|
); |
395
|
|
|
|
|
|
|
} |
396
|
1
|
50
|
|
|
|
4
|
if ( @legs ) { |
397
|
0
|
|
|
|
|
0
|
DEBUG( 50,"setting leg from our route header: $data -> ".$legs[0]->dump ); |
398
|
0
|
|
|
|
|
0
|
$entry->{outgoing_leg} = \@legs; |
399
|
0
|
|
|
|
|
0
|
shift(@route); |
400
|
|
|
|
|
|
|
} else { |
401
|
1
|
|
|
|
|
5
|
DEBUG( 50,"no legs which can deliver to $addr:$port (route)" ); |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
} |
404
|
1
|
50
|
|
|
|
5
|
if ( @route ) { |
405
|
|
|
|
|
|
|
# still routing infos. Use next route as nexthop |
406
|
1
|
|
|
|
|
4
|
my ($data,$param) = sip_hdrval2parts( route => $route[0] ); |
407
|
1
|
|
|
|
|
4
|
$entry->{nexthop} = $data; |
408
|
1
|
|
|
|
|
6
|
DEBUG(50, "setting nexthop from route $route[0] to $entry->{nexthop}"); |
409
|
|
|
|
|
|
|
} |
410
|
|
|
|
|
|
|
|
411
|
1
|
|
|
|
|
4
|
return $self->__forward_request_getdaddr($entry) |
412
|
|
|
|
|
|
|
} |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
########################################################################### |
415
|
|
|
|
|
|
|
# Forwards request |
416
|
|
|
|
|
|
|
# try to find dst addr |
417
|
|
|
|
|
|
|
# if it does not have destination address tries to resolve URI and then |
418
|
|
|
|
|
|
|
# calls __forward_request_1 |
419
|
|
|
|
|
|
|
########################################################################### |
420
|
|
|
|
|
|
|
sub __forward_request_getdaddr { |
421
|
7
|
|
|
7
|
|
12
|
my Net::SIP::StatelessProxy $self = shift; |
422
|
7
|
|
|
|
|
9
|
my $entry = shift; |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
return __forward_request_1( $self,$entry ) |
425
|
7
|
50
|
|
|
|
11
|
if @{ $entry->{dst_addr}}; |
|
7
|
|
|
|
|
22
|
|
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
$entry->{nexthop} ||= $entry->{packet}->uri, |
428
|
7
|
|
66
|
|
|
29
|
DEBUG(50,"need to resolve $entry->{nexthop}"); |
429
|
|
|
|
|
|
|
return $self->{dispatcher}->resolve_uri( |
430
|
|
|
|
|
|
|
$entry->{nexthop}, |
431
|
|
|
|
|
|
|
$entry->{dst_addr}, |
432
|
|
|
|
|
|
|
$entry->{outgoing_leg}, |
433
|
7
|
|
|
|
|
40
|
[ \&__forward_request_1,$self,$entry ], |
434
|
|
|
|
|
|
|
undef, |
435
|
|
|
|
|
|
|
); |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
########################################################################### |
439
|
|
|
|
|
|
|
# should have dst_addr now, but this might be still with non-IP hostname |
440
|
|
|
|
|
|
|
# resolve it and go to __forward_request_2 or directly to __forward_packet_final |
441
|
|
|
|
|
|
|
########################################################################### |
442
|
|
|
|
|
|
|
sub __forward_request_1 { |
443
|
7
|
|
|
7
|
|
11
|
my Net::SIP::StatelessProxy $self = shift; |
444
|
7
|
|
|
|
|
11
|
my $entry = shift; |
445
|
|
|
|
|
|
|
|
446
|
7
|
50
|
|
|
|
18
|
if (@_) { |
447
|
0
|
|
|
|
|
0
|
DEBUG(10,"failed to resolve URI %s: @_",$entry->{nexthop}); |
448
|
0
|
|
|
|
|
0
|
return; |
449
|
|
|
|
|
|
|
} |
450
|
|
|
|
|
|
|
|
451
|
7
|
|
|
|
|
12
|
my $dst_addr = $entry->{dst_addr}; |
452
|
7
|
50
|
|
|
|
18
|
if ( ! @$dst_addr ) { |
453
|
0
|
|
|
|
|
0
|
DEBUG( 10,"cannot find dst for uri ".$entry->{packet}->uri ); |
454
|
0
|
|
|
|
|
0
|
return; |
455
|
|
|
|
|
|
|
} |
456
|
7
|
|
|
|
|
11
|
my %hostnames; |
457
|
7
|
|
|
|
|
16
|
foreach (@$dst_addr) { |
458
|
13
|
50
|
|
|
|
26
|
ref($_) or Carp::confess("expected reference: $_"); |
459
|
13
|
50
|
|
|
|
30
|
$hostnames{$_->{host}} = $_->{host} if ! $_->{addr}; |
460
|
|
|
|
|
|
|
} |
461
|
7
|
50
|
|
|
|
45
|
if ( %hostnames ) { |
462
|
|
|
|
|
|
|
$self->{dispatcher}->dns_host2ip( |
463
|
0
|
|
|
|
|
0
|
\%hostnames, |
464
|
|
|
|
|
|
|
[ \&__forward_request_2,$self,$entry ] |
465
|
|
|
|
|
|
|
); |
466
|
|
|
|
|
|
|
} else { |
467
|
7
|
|
|
|
|
25
|
$self->__forward_packet_final($entry); |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
########################################################################### |
473
|
|
|
|
|
|
|
# called after hostname for destination address got resolved |
474
|
|
|
|
|
|
|
# calls __forward_packet_final |
475
|
|
|
|
|
|
|
########################################################################### |
476
|
|
|
|
|
|
|
sub __forward_request_2 { |
477
|
0
|
|
|
0
|
|
0
|
my Net::SIP::StatelessProxy $self = shift; |
478
|
0
|
|
|
|
|
0
|
my ($entry,$errno,$host2ip) = @_; |
479
|
0
|
|
|
|
|
0
|
my $dst_addr = $entry->{dst_addr}; |
480
|
0
|
|
|
|
|
0
|
while ( my ($host,$ip) = each %$host2ip ) { |
481
|
0
|
0
|
|
|
|
0
|
unless ( $ip ) { |
482
|
0
|
|
|
|
|
0
|
DEBUG( 10,"cannot resolve address $host" ); |
483
|
0
|
|
|
|
|
0
|
@$dst_addr = grep { $_->{host} ne $host } @$dst_addr; |
|
0
|
|
|
|
|
0
|
|
484
|
0
|
|
|
|
|
0
|
next; |
485
|
|
|
|
|
|
|
} else { |
486
|
0
|
|
|
|
|
0
|
DEBUG( 50,"resolved $host -> $ip" ); |
487
|
0
|
|
|
|
|
0
|
$_->{addr} = $ip for grep { $_->{host} eq $host } @$dst_addr; |
|
0
|
|
|
|
|
0
|
|
488
|
|
|
|
|
|
|
} |
489
|
|
|
|
|
|
|
} |
490
|
|
|
|
|
|
|
|
491
|
0
|
0
|
|
|
|
0
|
return unless @$dst_addr; # nothing could be resolved |
492
|
|
|
|
|
|
|
|
493
|
0
|
|
|
|
|
0
|
$self->__forward_packet_final($entry); |
494
|
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
########################################################################### |
498
|
|
|
|
|
|
|
# dst_addr is known and IP |
499
|
|
|
|
|
|
|
# if no legs given use the one which can deliver to dst_addr |
500
|
|
|
|
|
|
|
# if there are more than one try to pick best based on protocol |
501
|
|
|
|
|
|
|
# but finally pick simply the first |
502
|
|
|
|
|
|
|
# rewrite contact header |
503
|
|
|
|
|
|
|
# call forward_outgoing on the outgoing_leg |
504
|
|
|
|
|
|
|
# and finally deliver the packet |
505
|
|
|
|
|
|
|
########################################################################### |
506
|
|
|
|
|
|
|
sub __forward_packet_final { |
507
|
7
|
|
|
7
|
|
18
|
my ($self,$entry) = @_; |
508
|
|
|
|
|
|
|
|
509
|
7
|
|
|
|
|
15
|
my $dst_addr = $entry->{dst_addr}; |
510
|
7
|
|
|
|
|
12
|
my $legs = $entry->{outgoing_leg}; |
511
|
7
|
50
|
|
|
|
27
|
if ( !@$legs == @$dst_addr ) { |
512
|
|
|
|
|
|
|
# get legs from dst_addr |
513
|
0
|
|
|
|
|
0
|
my @all_legs = $self->{dispatcher}->get_legs; |
514
|
0
|
|
|
|
|
0
|
@$legs = (); |
515
|
0
|
|
|
|
|
0
|
my @addr; |
516
|
0
|
|
|
|
|
0
|
foreach my $addr (@$dst_addr) { |
517
|
0
|
|
|
0
|
|
0
|
my $leg = first { $_->can_deliver_to(%$addr) } @all_legs; |
|
0
|
|
|
|
|
0
|
|
518
|
0
|
0
|
|
|
|
0
|
if ( ! $leg ) { |
519
|
0
|
|
|
|
|
0
|
DEBUG( 50,"no leg for $addr" ); |
520
|
0
|
|
|
|
|
0
|
next; |
521
|
|
|
|
|
|
|
} |
522
|
0
|
|
|
|
|
0
|
push @addr,$addr; |
523
|
0
|
|
|
|
|
0
|
push @$legs,$leg |
524
|
|
|
|
|
|
|
} |
525
|
0
|
|
|
|
|
0
|
@$dst_addr = @addr; |
526
|
0
|
0
|
|
|
|
0
|
@$legs or do { |
527
|
0
|
|
|
|
|
0
|
DEBUG( 10,"cannot find any legs" ); |
528
|
0
|
|
|
|
|
0
|
return; |
529
|
|
|
|
|
|
|
}; |
530
|
|
|
|
|
|
|
} |
531
|
|
|
|
|
|
|
|
532
|
7
|
|
|
|
|
11
|
my $incoming_leg = $entry->{incoming_leg}; |
533
|
7
|
100
|
|
|
|
21
|
if ( @$legs > 1 ) { |
534
|
6
|
50
|
|
|
|
15
|
if ( $incoming_leg->{proto} eq 'tcp' ) { |
535
|
|
|
|
|
|
|
# prefer tcp legs |
536
|
0
|
|
|
|
|
0
|
my @tcp_legs = grep { $_->{proto} eq 'tcp' } @$legs; |
|
0
|
|
|
|
|
0
|
|
537
|
0
|
0
|
|
|
|
0
|
@$legs = @tcp_legs if @tcp_legs; |
538
|
|
|
|
|
|
|
} |
539
|
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
# pick first |
542
|
7
|
|
|
|
|
21
|
my $outgoing_leg = $legs->[0]; |
543
|
7
|
|
|
|
|
14
|
$dst_addr = $dst_addr->[0]; |
544
|
|
|
|
|
|
|
|
545
|
7
|
|
|
|
|
13
|
my $packet = $entry->{packet}; |
546
|
|
|
|
|
|
|
# rewrite contact header if outgoing leg is different to incoming leg |
547
|
7
|
50
|
66
|
|
|
40
|
if ( ( $outgoing_leg != $incoming_leg or $self->{force_rewrite} ) and |
|
|
|
66
|
|
|
|
|
548
|
|
|
|
|
|
|
(my @contact = $packet->get_header( 'contact' ))) { |
549
|
|
|
|
|
|
|
|
550
|
0
|
|
|
|
|
0
|
my $rewrite_contact = $self->{rewrite_contact}; |
551
|
0
|
|
|
|
|
0
|
foreach my $c (@contact) { |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
# rewrite all sip(s) contacts |
554
|
0
|
|
|
|
|
0
|
my ($data,$p) = sip_hdrval2parts( contact => $c ); |
555
|
0
|
0
|
|
|
|
0
|
my ($pre,$addr,$post) = |
|
|
0
|
|
|
|
|
|
556
|
|
|
|
|
|
|
$data =~m{^(.*\s]+)(>.*)}i ? ($1,$2,$3) : |
557
|
|
|
|
|
|
|
$data =~m{^(sips?:)([^>\s]+)$}i ? ($1,$2,'') : |
558
|
|
|
|
|
|
|
next; |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
# if contact was rewritten rewrite back |
561
|
0
|
0
|
0
|
|
|
0
|
if ( $addr =~m{^(\w+)(\@.*)} and my $newaddr = invoke_callback( |
562
|
|
|
|
|
|
|
$rewrite_contact,$1,$incoming_leg,$outgoing_leg)) { |
563
|
0
|
|
|
|
|
0
|
my $cnew = sip_parts2hdrval( 'contact', $pre.$newaddr.$post, $p ); |
564
|
0
|
|
|
|
|
0
|
DEBUG( 50,"rewrote back '$c' to '$cnew'" ); |
565
|
0
|
|
|
|
|
0
|
$c = $cnew; |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
# otherwise rewrite it |
568
|
|
|
|
|
|
|
} else { |
569
|
0
|
|
|
|
|
0
|
$addr = invoke_callback($rewrite_contact,$addr,$incoming_leg, |
570
|
|
|
|
|
|
|
$outgoing_leg,1); |
571
|
0
|
|
|
|
|
0
|
$addr .= '@'.$outgoing_leg->laddr(2); |
572
|
0
|
|
|
|
|
0
|
my $cnew = sip_parts2hdrval( 'contact', $pre.$addr.$post, $p ); |
573
|
0
|
|
|
|
|
0
|
DEBUG( 50,"rewrote '$c' to '$cnew'" ); |
574
|
0
|
|
|
|
|
0
|
$c = $cnew; |
575
|
|
|
|
|
|
|
} |
576
|
|
|
|
|
|
|
} |
577
|
0
|
|
|
|
|
0
|
$packet->set_header( contact => \@contact ); |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
|
580
|
7
|
100
|
66
|
|
|
37
|
if ( $outgoing_leg != $incoming_leg and $packet->is_request ) { |
581
|
6
|
|
|
|
|
25
|
$incoming_leg->add_via($packet); |
582
|
|
|
|
|
|
|
} |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
# prepare outgoing packet |
585
|
7
|
50
|
|
|
|
37
|
if ( my $err = $outgoing_leg->forward_outgoing( $packet,$incoming_leg )) { |
586
|
0
|
|
|
|
|
0
|
my ($code,$text) = @$err; |
587
|
0
|
0
|
|
|
|
0
|
DEBUG( 10,"ERROR while forwarding: ".( defined($code) ? "$code, $text" : $text )); |
588
|
0
|
|
|
|
|
0
|
return; |
589
|
|
|
|
|
|
|
} |
590
|
|
|
|
|
|
|
|
591
|
7
|
50
|
|
|
|
24
|
if ( my $err = $self->do_nat( $packet,$incoming_leg,$outgoing_leg ) ) { |
592
|
0
|
|
|
|
|
0
|
my ($code,$text) = @$err; |
593
|
0
|
|
|
|
|
0
|
DEBUG( 10,"ERROR while doing NAT: $code, $text" ); |
594
|
0
|
|
|
|
|
0
|
return; |
595
|
|
|
|
|
|
|
} |
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
# Just forward packet via the outgoing_leg |
598
|
7
|
|
|
|
|
43
|
$self->{dispatcher}->deliver( $packet, |
599
|
|
|
|
|
|
|
leg => $outgoing_leg, |
600
|
|
|
|
|
|
|
dst_addr => $dst_addr, |
601
|
|
|
|
|
|
|
do_retransmits => 0 |
602
|
|
|
|
|
|
|
); |
603
|
|
|
|
|
|
|
} |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
############################################################################ |
606
|
|
|
|
|
|
|
# If a nathelper is given try to rewrite SDP bodies. If this fails |
607
|
|
|
|
|
|
|
# (not enough resources) just drop packet, the sender will retry later |
608
|
|
|
|
|
|
|
# (FIXME: this is only true in case of UDP, but not TCP) |
609
|
|
|
|
|
|
|
# |
610
|
|
|
|
|
|
|
# Args: ($self,$packet,$incoming_leg,$outgoing_leg) |
611
|
|
|
|
|
|
|
# $packet: packet to forward |
612
|
|
|
|
|
|
|
# $incoming_leg: where packet came in |
613
|
|
|
|
|
|
|
# $outgoing_leg: where packet will be send out |
614
|
|
|
|
|
|
|
# Returns: $error |
615
|
|
|
|
|
|
|
# $error: undef | [ $code,$text ] |
616
|
|
|
|
|
|
|
############################################################################ |
617
|
|
|
|
|
|
|
sub do_nat { |
618
|
7
|
|
|
7
|
1
|
13
|
my Net::SIP::StatelessProxy $self = shift; |
619
|
7
|
|
|
|
|
16
|
my ($packet,$incoming_leg,$outgoing_leg) = @_; |
620
|
|
|
|
|
|
|
|
621
|
7
|
|
33
|
|
|
22
|
my $nathelper = $self->{nathelper} || do { |
622
|
|
|
|
|
|
|
DEBUG( 100, "no nathelper" ); |
623
|
|
|
|
|
|
|
return; |
624
|
|
|
|
|
|
|
}; |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
# no NAT if outgoing leg is same as incoming leg |
627
|
0
|
0
|
|
|
|
|
if ( $incoming_leg == $outgoing_leg ) { |
628
|
0
|
|
|
|
|
|
DEBUG( 100,"no NAT because incoming leg is outgoing leg" ); |
629
|
0
|
|
|
|
|
|
return; |
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
|
632
|
|
|
|
|
|
|
|
633
|
0
|
0
|
|
|
|
|
my $body = eval { $packet->cseq =~m{\b(?:INVITE|ACK)\b} |
|
0
|
|
|
|
|
|
|
634
|
|
|
|
|
|
|
&& $packet->sdp_body }; |
635
|
0
|
0
|
|
|
|
|
if ( $@ ) { |
636
|
0
|
|
|
|
|
|
DEBUG( 10, "malformed SDP body" ); |
637
|
0
|
|
|
|
|
|
return [ 500,"malformed SDP body" ]; |
638
|
|
|
|
|
|
|
} |
639
|
|
|
|
|
|
|
|
640
|
0
|
0
|
|
|
|
|
my ($request,$response) = $packet->is_request |
641
|
|
|
|
|
|
|
? ( $packet,undef ) |
642
|
|
|
|
|
|
|
: ( undef,$packet ) |
643
|
|
|
|
|
|
|
; |
644
|
0
|
0
|
|
|
|
|
my $method = $request ? $request->method : ''; |
645
|
0
|
|
|
|
|
|
my $track_resp_code; |
646
|
0
|
0
|
0
|
|
|
|
if ($response and $response->method eq 'INVITE') { |
647
|
0
|
|
|
|
|
|
my $code = $response->code; |
648
|
0
|
0
|
|
|
|
|
$track_resp_code = $code if $code>=400; |
649
|
|
|
|
|
|
|
} |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
# NAT for anything with SDP body |
652
|
|
|
|
|
|
|
# activation and close of session will be done on ACK|CANCEL|BYE |
653
|
0
|
0
|
0
|
|
|
|
unless ( $body |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
654
|
|
|
|
|
|
|
or $method eq 'ACK' |
655
|
|
|
|
|
|
|
or $method eq 'CANCEL' |
656
|
|
|
|
|
|
|
or $method eq 'BYE' ) { |
657
|
0
|
|
|
|
|
|
DEBUG( 100, "no NAT because no SDP body and method is $method" ); |
658
|
0
|
0
|
|
|
|
|
return if ! $track_resp_code; |
659
|
|
|
|
|
|
|
} |
660
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
# find NAT data for packet: |
663
|
|
|
|
|
|
|
# $idfrom and $idto are the IDs for FROM|TO which consist of |
664
|
|
|
|
|
|
|
# the SIP address + (optional) Tag + Contact-Info from responsable |
665
|
|
|
|
|
|
|
# Leg, delimited by "\0" |
666
|
0
|
|
|
|
|
|
my ($idfrom,$idto); |
667
|
|
|
|
|
|
|
|
668
|
0
|
|
|
|
|
|
for([from => \$idfrom], [to => \$idto]) { |
669
|
0
|
|
|
|
|
|
my ($k,$idref) = @$_; |
670
|
0
|
0
|
|
|
|
|
if (my $v = $packet->get_header($k) ) { |
671
|
0
|
|
|
|
|
|
my ($uri,$param) = sip_hdrval2parts(from => $v); |
672
|
0
|
|
|
|
|
|
my ($dom,$user,$proto) = sip_uri2parts($uri); |
673
|
0
|
|
0
|
|
|
|
$$idref = "$proto:$user\@$dom\0".($param->{tag} || ''); |
674
|
|
|
|
|
|
|
} else { |
675
|
0
|
|
|
|
|
|
return [ 0,'no '.uc($k).' header in packet' ] |
676
|
|
|
|
|
|
|
} |
677
|
|
|
|
|
|
|
} |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
# side is either 0 (request) or 1 (response) |
681
|
|
|
|
|
|
|
# If a request comes in 'from' points to the incoming_leg while |
682
|
|
|
|
|
|
|
# 'to' points to the outgoing leg. For responses it's the other |
683
|
|
|
|
|
|
|
# way around |
684
|
|
|
|
|
|
|
|
685
|
0
|
|
|
|
|
|
my $side; |
686
|
0
|
|
|
|
|
|
my $ileg = $incoming_leg->laddr(1); |
687
|
0
|
|
|
|
|
|
my $oleg = $outgoing_leg->laddr(1); |
688
|
0
|
0
|
|
|
|
|
if ( $request ) { |
689
|
0
|
|
|
|
|
|
$idfrom .= "\0".$ileg; |
690
|
0
|
|
|
|
|
|
$idto .= "\0".$oleg; |
691
|
0
|
|
|
|
|
|
$side = 0; |
692
|
|
|
|
|
|
|
} else { |
693
|
0
|
|
|
|
|
|
$idfrom .= "\0".$oleg; |
694
|
0
|
|
|
|
|
|
$idto .= "\0".$ileg; |
695
|
0
|
|
|
|
|
|
$side = 1; |
696
|
|
|
|
|
|
|
} |
697
|
|
|
|
|
|
|
|
698
|
0
|
0
|
|
|
|
|
my ($cseq) = $packet->get_header( 'cseq' ) =~m{^(\d+)} |
699
|
|
|
|
|
|
|
or return [ 0,'no CSEQ in packet' ]; |
700
|
0
|
|
|
|
|
|
my $callid = $packet->callid; |
701
|
|
|
|
|
|
|
|
702
|
0
|
0
|
|
|
|
|
if ($track_resp_code) { |
703
|
0
|
|
|
|
|
|
my $rc = $self->{respcode}[0]; |
704
|
0
|
0
|
|
|
|
|
if (keys(%$rc)>5000) { |
705
|
|
|
|
|
|
|
# expire entries |
706
|
0
|
|
|
|
|
|
$self->{respcode}[1] = $rc; |
707
|
0
|
|
|
|
|
|
$rc = $self->{respcode}[0] = {}; |
708
|
|
|
|
|
|
|
} |
709
|
0
|
|
|
|
|
|
$rc->{$callid,$cseq,$idfrom,$idto} = $track_resp_code; |
710
|
|
|
|
|
|
|
|
711
|
|
|
|
|
|
|
# No NAT to do, we just needed to track the response code |
712
|
|
|
|
|
|
|
# The session should be closed though since it will not be completed |
713
|
0
|
0
|
|
|
|
|
DEBUG( 50,"close session $callid|$cseq because of ".( $request ? $method : $response->code." $method")); |
714
|
0
|
|
|
|
|
|
$nathelper->close_session( $callid,$cseq,$idfrom,$idto ); |
715
|
0
|
|
|
|
|
|
return; |
716
|
|
|
|
|
|
|
} |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
# CANCEL|BYE will be handled first to close session |
719
|
|
|
|
|
|
|
# no NAT will be done, even if the packet contains SDP (which makes no sense) |
720
|
0
|
0
|
|
|
|
|
if ( $method eq 'CANCEL' ) { |
|
|
0
|
|
|
|
|
|
721
|
|
|
|
|
|
|
# keep cseq for CANCEL |
722
|
0
|
|
|
|
|
|
DEBUG( 50,"close session $callid|$cseq because of CANCEL" ); |
723
|
0
|
|
|
|
|
|
$nathelper->close_session( $callid,$cseq,$idfrom,$idto ); |
724
|
0
|
|
|
|
|
|
return; |
725
|
|
|
|
|
|
|
} elsif ( $method eq 'BYE' ) { |
726
|
|
|
|
|
|
|
# no cseq for BYE, eg close all sessions in call |
727
|
0
|
|
|
|
|
|
DEBUG( 50,"close call $callid because of BYE" ); |
728
|
0
|
|
|
|
|
|
$nathelper->close_session( $callid,undef,$idfrom,$idto ); |
729
|
0
|
|
|
|
|
|
return; |
730
|
|
|
|
|
|
|
} |
731
|
|
|
|
|
|
|
|
732
|
0
|
0
|
|
|
|
|
if ( $body ) { |
733
|
0
|
|
|
|
|
|
DEBUG( 100,"need to NAT SDP body: ".$body->as_string ); |
734
|
|
|
|
|
|
|
|
735
|
0
|
0
|
|
|
|
|
DEBUG( 50,"allocate sockets $callid|$cseq because of SDP body in ".($request ? $method : $response->code)); |
736
|
0
|
|
|
|
|
|
my $new_media = $nathelper->allocate_sockets( |
737
|
|
|
|
|
|
|
$callid,$cseq,$idfrom,$idto,$side,$outgoing_leg->laddr(0), |
738
|
|
|
|
|
|
|
scalar( $body->get_media) ); |
739
|
0
|
0
|
|
|
|
|
if ( ! $new_media ) { |
740
|
0
|
|
|
|
|
|
DEBUG( 10,"allocation of RTP session failed for $callid|$cseq $idfrom|$idto|$side" ); |
741
|
0
|
|
|
|
|
|
return [ 0,'allocation of RTP sockets failed' ]; |
742
|
|
|
|
|
|
|
} |
743
|
|
|
|
|
|
|
|
744
|
0
|
|
|
|
|
|
$body->replace_media_listen( $new_media ); |
745
|
0
|
|
|
|
|
|
$packet->set_body( $body ); |
746
|
0
|
|
|
|
|
|
DEBUG( 100, "new SDP body: ".$body->as_string ); |
747
|
|
|
|
|
|
|
} |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
# Try to activate session as early as possible (for early data). |
750
|
|
|
|
|
|
|
# In a lot of cases this will be too early, because I only have one |
751
|
|
|
|
|
|
|
# site, but only in the case of ACK an incomplete session is invalid. |
752
|
|
|
|
|
|
|
|
753
|
0
|
0
|
|
|
|
|
if ( $method eq 'ACK' ) { |
|
|
0
|
|
|
|
|
|
754
|
|
|
|
|
|
|
my $code = $self->{respcode}[0]{$callid,$cseq,$idfrom,$idto} |
755
|
0
|
|
0
|
|
|
|
|| $self->{respcode}[1]{$callid,$cseq,$idfrom,$idto} |
756
|
|
|
|
|
|
|
|| -1; |
757
|
0
|
0
|
|
|
|
|
if ($code > 400) { |
|
|
0
|
|
|
|
|
|
758
|
|
|
|
|
|
|
# ACK to response with error code, should be closed already |
759
|
0
|
|
|
|
|
|
DEBUG( 100, "session $callid|$cseq $idfrom -> ACK to failure response" ); |
760
|
|
|
|
|
|
|
} elsif (! $nathelper->activate_session($callid,$cseq,$idfrom,$idto)) { |
761
|
0
|
|
|
|
|
|
DEBUG( 50,"session $callid|$cseq $idfrom -> $idto still incomplete in ACK" ); |
762
|
0
|
|
|
|
|
|
return [ 0,'incomplete session in ACK' ] |
763
|
|
|
|
|
|
|
} |
764
|
|
|
|
|
|
|
} elsif (! $nathelper->activate_session($callid,$cseq,$idfrom,$idto)) { |
765
|
|
|
|
|
|
|
# ignore problem, session not yet complete |
766
|
0
|
|
|
|
|
|
DEBUG( 100, "session $callid|$cseq $idfrom -> $idto not yet complete" ); |
767
|
|
|
|
|
|
|
} else { |
768
|
0
|
|
|
|
|
|
DEBUG( 50,"activated session $callid|$cseq $idfrom -> $idto" ) |
769
|
|
|
|
|
|
|
} |
770
|
|
|
|
|
|
|
|
771
|
0
|
|
|
|
|
|
return; |
772
|
|
|
|
|
|
|
} |
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
############################################################################ |
775
|
|
|
|
|
|
|
# convert idside (idfrom,idto) to hash |
776
|
|
|
|
|
|
|
# Args: ?$class,$idside |
777
|
|
|
|
|
|
|
# Returns: \%hash |
778
|
|
|
|
|
|
|
# %hash: extracted info with keys address (sip address), tag, leg (ip:port) |
779
|
|
|
|
|
|
|
############################################################################ |
780
|
|
|
|
|
|
|
sub idside2hash { |
781
|
0
|
|
|
0
|
1
|
|
my $idside = pop; |
782
|
0
|
|
|
|
|
|
my %hash; |
783
|
0
|
|
|
|
|
|
@hash{qw/ address tag leg /} = split( "\0",$idside,3 ); |
784
|
0
|
|
|
|
|
|
return \%hash; |
785
|
|
|
|
|
|
|
} |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
1; |