File Coverage

blib/lib/Net/SIP/StatelessProxy.pm
Criterion Covered Total %
statement 114 372 30.6
branch 29 170 17.0
condition 16 75 21.3
subroutine 17 27 62.9
pod 4 4 100.0
total 180 648 27.7


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 43     43   269 use strict;
  43         80  
  43         1142  
9 43     43   193 use warnings;
  43         78  
  43         1604  
10              
11             package Net::SIP::StatelessProxy;
12 43     43   220 use fields qw( dispatcher rewrite_contact nathelper force_rewrite respcode );
  43         71  
  43         204  
13              
14 43     43   3114 use Net::SIP::Util ':all';
  43         97  
  43         6886  
15 43     43   270 use Digest::MD5 qw(md5);
  43         71  
  43         1620  
16 43     43   206 use Carp 'croak';
  43         78  
  43         1996  
17 43     43   2733 use List::Util 'first';
  43         86  
  43         2266  
18 43     43   248 use Hash::Util 'lock_ref_keys';
  43         125  
  43         344  
19 43     43   2326 use Net::SIP::Debug;
  43         79  
  43         258  
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 16 my ($class,%args) = @_;
43 2         7 my $self = fields::new( $class );
44              
45             my $disp = $self->{dispatcher} =
46 2   33     120 delete $args{dispatcher} || croak 'no dispatcher given';
47 2   33     8 $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         7 $self->{nathelper} = delete $args{nathelper};
52 2         3 $self->{force_rewrite} = delete $args{force_rewrite};
53 2         6 $self->{respcode} = [ {},{} ];
54              
55 2         5 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   15 my ($crypt,$disp,$contact,$leg_in,$leg_out,$force_rewrite) = @_;
63              
64 7         9 my $legdict;
65 7         21 my ($ileg_in,$ileg_out) = $disp->legs2i($leg_in,$leg_out,\$legdict);
66              
67 7 50 33     37 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       14 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         25 DEBUG( 100,"no rewriting of $contact" );
119 7         24 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 10 my Net::SIP::StatelessProxy $self = shift;
208 7         14 my ($packet,$incoming_leg,$from) = @_;
209 7         33 DEBUG( 10,"received ".$packet->dump );
210              
211             # Prepare for forwarding, e.g adjust headers
212             # (add record-route)
213 7 50       25 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         25 my $rewrite_contact = $self->{rewrite_contact};
220 7         10 my $disp = $self->{dispatcher};
221              
222             # find out how to forward packet
223              
224 7         31 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       17 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         15 my ($to) = sip_hdrval2parts( uri => $packet->uri );
269 7 50       22 $to = $1 if $to =~m{<(\w+:\S+)>};
270 7 50       67 if ( my ($pre,$name) = $to =~m{^(sips?:)(\S+)?\@} ) {
271 7         10 my $outgoing_leg;
272 7 50       22 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         28 $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         8 my $entry = shift;
366              
367             # if the top route header points to a local leg we use this as outgoing leg
368 7         21 my @route = $entry->{packet}->get_header('route');
369 7 100       16 if ( ! @route ) {
370 6         14 DEBUG(50,'no route header');
371 6         15 return $self->__forward_request_getdaddr($entry)
372             }
373              
374 1   33     10 my $route = $route[0] =~m{<([^\s>]+)>} && $1 || $route[0];
375 1         2 my $ol = $entry->{outgoing_leg};
376 1 50 33     5 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         3 my ($data,$param) = sip_hdrval2parts( route => $route );
385             my ($proto, $addr, $port, $family) =
386 1 50       11 sip_uri2sockinfo($data, $param->{maddr} ? 1:0);
387 1 0 33     8 $port ||= $proto eq 'tls' ? 5061 : 5060;
388             my @legs = $self->{dispatcher}->get_legs(
389 1         6 addr => $addr, port => $port, family => $family);
390 1 50 33     11 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       3 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       3 if ( @route ) {
405             # still routing infos. Use next route as nexthop
406 1         3 my ($data,$param) = sip_hdrval2parts( route => $route[0] );
407 1         3 $entry->{nexthop} = $data;
408 1         4 DEBUG(50, "setting nexthop from route $route[0] to $entry->{nexthop}");
409             }
410              
411 1         10 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   10 my Net::SIP::StatelessProxy $self = shift;
422 7         14 my $entry = shift;
423              
424             return __forward_request_1( $self,$entry )
425 7 50       8 if @{ $entry->{dst_addr}};
  7         17  
426              
427             $entry->{nexthop} ||= $entry->{packet}->uri,
428 7   66     34 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         31 [ \&__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   9 my Net::SIP::StatelessProxy $self = shift;
444 7         10 my $entry = shift;
445              
446 7 50       14 if (@_) {
447 0         0 DEBUG(10,"failed to resolve URI %s: @_",$entry->{nexthop});
448 0         0 return;
449             }
450              
451 7         16 my $dst_addr = $entry->{dst_addr};
452 7 50       13 if ( ! @$dst_addr ) {
453 0         0 DEBUG( 10,"cannot find dst for uri ".$entry->{packet}->uri );
454 0         0 return;
455             }
456 7         10 my %hostnames;
457 7         10 foreach (@$dst_addr) {
458 13 50       23 ref($_) or Carp::confess("expected reference: $_");
459 13 50       25 $hostnames{$_->{host}} = $_->{host} if ! $_->{addr};
460             }
461 7 50       13 if ( %hostnames ) {
462             $self->{dispatcher}->dns_host2ip(
463 0         0 \%hostnames,
464             [ \&__forward_request_2,$self,$entry ]
465             );
466             } else {
467 7         22 $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   13 my ($self,$entry) = @_;
508              
509 7         9 my $dst_addr = $entry->{dst_addr};
510 7         9 my $legs = $entry->{outgoing_leg};
511 7 50       15 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       13 if ( @$legs > 1 ) {
534 6 50       13 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         10 my $outgoing_leg = $legs->[0];
543 7         11 $dst_addr = $dst_addr->[0];
544              
545 7         8 my $packet = $entry->{packet};
546             # rewrite contact header if outgoing leg is different to incoming leg
547 7 50 66     31 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     28 if ( $outgoing_leg != $incoming_leg and $packet->is_request ) {
581 6         20 $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       17 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         24 $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         13 my ($packet,$incoming_leg,$outgoing_leg) = @_;
620              
621 7   33     20 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             # no NAT to do, we just needed to track the response code
711 0           return;
712             }
713              
714             # CANCEL|BYE will be handled first to close session
715             # no NAT will be done, even if the packet contains SDP (which makes no sense)
716 0 0         if ( $method eq 'CANCEL' ) {
    0          
717             # keep cseq for CANCEL
718 0           DEBUG( 50,"close session $callid|$cseq because of CANCEL" );
719 0           $nathelper->close_session( $callid,$cseq,$idfrom,$idto );
720 0           return;
721             } elsif ( $method eq 'BYE' ) {
722             # no cseq for BYE, eg close all sessions in call
723 0           DEBUG( 50,"close call $callid because of BYE" );
724 0           $nathelper->close_session( $callid,undef,$idfrom,$idto );
725 0           return;
726             }
727              
728 0 0         if ( $body ) {
729 0           DEBUG( 100,"need to NAT SDP body: ".$body->as_string );
730              
731 0           my $new_media = $nathelper->allocate_sockets(
732             $callid,$cseq,$idfrom,$idto,$side,$outgoing_leg->laddr(0),
733             scalar( $body->get_media) );
734 0 0         if ( ! $new_media ) {
735 0           DEBUG( 10,"allocation of RTP session failed for $callid|$cseq $idfrom|$idto|$side" );
736 0           return [ 0,'allocation of RTP sockets failed' ];
737             }
738              
739 0           $body->replace_media_listen( $new_media );
740 0           $packet->set_body( $body );
741 0           DEBUG( 100, "new SDP body: ".$body->as_string );
742             }
743              
744             # Try to activate session as early as possible (for early data).
745             # In a lot of cases this will be too early, because I only have one
746             # site, but only in the case of ACK an incomplete session is invalid.
747              
748 0 0         if ( ! $nathelper->activate_session( $callid,$cseq,$idfrom,$idto ) ) {
749 0 0         if ( $method eq 'ACK' ) {
750             my $code = $self->{respcode}[0]{$callid,$cseq,$idfrom,$idto}
751 0   0       || $self->{respcode}[1]{$callid,$cseq,$idfrom,$idto}
752             || -1;
753 0 0         if ($code < 400) {
754 0           DEBUG( 50,"session $callid|$cseq $idfrom -> $idto still incomplete in ACK" );
755 0           return [ 0,'incomplete session in ACK' ]
756             } else {
757             # ignore problem, ACK to response with error code
758 0           DEBUG( 100, "session $callid|$cseq $idfrom -> ACK to failure response" );
759             }
760             } else {
761             # ignore problem, session not yet complete
762 0           DEBUG( 100, "session $callid|$cseq $idfrom -> $idto not yet complete" );
763             }
764             } else {
765 0           DEBUG( 50,"activated session $callid|$cseq $idfrom -> $idto" )
766             }
767              
768 0           return;
769             }
770              
771             ############################################################################
772             # convert idside (idfrom,idto) to hash
773             # Args: ?$class,$idside
774             # Returns: \%hash
775             # %hash: extracted info with keys address (sip address), tag, leg (ip:port)
776             ############################################################################
777             sub idside2hash {
778 0     0 1   my $idside = pop;
779 0           my %hash;
780 0           @hash{qw/ address tag leg /} = split( "\0",$idside,3 );
781 0           return \%hash;
782             }
783              
784              
785             1;