Commit 5ba44ad0 authored by Angel Abad's avatar Angel Abad

New upstream version 0.810

parent de762abb
Revision history for Net::SIP
0.810 2017-08-08
- various fixes based on feedback from Richard Carver:
- RT#120816 - account for slightly different Via and Proxy-Authorization
in INVITE and CANCEL when computing via_branch
- RT#121514: fix race in SocketPool where it tried to send new data during
TCP connect or TLS handshake, which resulted in the worst case in data
sent in plain instead of encrypted
- RT#121347 - fix usage if dict in Net::SIP::Dispatcher::i2legs
- RT#121585 - fix encoding special characters in
Net::SIP::Util::sip_parts2hdrval
- RT#122588 - fix typo in Net::SIP::Debug::level
- make it possible to restrict methods when receiving DTMF using param
dtmf_methods in Simple::Call, based on feedback from Peter Linden
0.809 2017-03-14
- StatelessProxy: decrease size of resulting new contact in the default
rewrite_contact handler to better deal with implementations which severally
limit the size of contact headers they accept.
Switch _stupid_crypt from mac-then-encrypt to encrypt-then-mac
- RT#120593, StatelessProxy now handles rewriting of contacts with no '@'
- RT#120039, SocketPool callbacks now include receiving socket object for
further analysis, like getting the certificates from the SSL socket
- RT#120011, Leg::forward_outgoing - ignore (invalid) Via headers w/o branch
- RT#120009, use ReuseAddr additionally to Reuse in IO::Socket* for compatibilty
with IO::Socket::IP
0.808 2016-12-13
- make DTMF detection more robust in case of UDP reordering, duplicates etc
- make t/19_call_with_dtmf.t more robust on slooow systems
......
......@@ -4,7 +4,7 @@
"unknown"
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921",
"generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150001",
"license" : [
"perl_5"
],
......@@ -49,5 +49,5 @@
"url" : "https://github.com/noxxi/p5-net-sip"
}
},
"version" : "0.808"
"version" : "0.810"
}
......@@ -3,25 +3,25 @@ abstract: unknown
author:
- unknown
build_requires:
ExtUtils::MakeMaker: 0
ExtUtils::MakeMaker: '0'
configure_requires:
ExtUtils::MakeMaker: 0
ExtUtils::MakeMaker: '0'
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.120921'
generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150001'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
version: '1.4'
name: Net-SIP
no_index:
directory:
- t
- inc
requires:
Socket: 1.95
Socket: '1.95'
resources:
bugtracker: https://rt.cpan.org/Dist/Display.html?Queue=Net-SIP
homepage: https://github.com/noxxi/p5-net-sip
license: http://dev.perl.org/licenses/
repository: https://github.com/noxxi/p5-net-sip
version: 0.808
version: '0.810'
......@@ -2,6 +2,8 @@ Thanks to GeNUA mbh http://www.genua.de to let me work on this
code and release it to the public.
Thanks for bugreports, fixes, testing and other feedback from:
richard[DOT]carver[AT]cloudmont[DOT]co[DOT]uk
<mtve1927[AT]gmail[DOT]com>
cpan:POLETTIX
<karme[AT]berlios[DOT]de>
......
......@@ -3,7 +3,7 @@ use warnings;
use 5.010;
package Net::SIP;
our $VERSION = '0.808';
our $VERSION = '0.810';
# this includes nearly everything else
use Net::SIP::Simple ();
......
......@@ -68,8 +68,8 @@ sub level {
my $name = $1;
my $below = $2;
my @names = ( $name );
push @names, "Net::".$name if $name =m{^SIP\b};
push @names, "Net::SIP::".$name if $name !~m{^Net::SIP\b};
push @names, "Net::".$name if $name =~ m{^SIP\b};
push @names, "Net::SIP::".$name if $name !~ m{^Net::SIP\b};
foreach (@names) {
$level4package{$_} = $l;
$level4package{$_.'::'} = $l if $below;
......
......@@ -304,6 +304,52 @@ sub get_legs {
}
###########################################################################
# map leg to index in list of legs
# Args: @legs,[\$dict]
# @legs: list of legs
# $dict: string representation of dictionary, used in i2leg and others
# to make sure that it the indices come from the same list of legs.
# Will be set if given
# Returns: @ilegs
# @ilegs: index of each of @legs in dispatcher, -1 if not found
###########################################################################
sub legs2i {
my Net::SIP::Dispatcher $self = shift;
my $legs = $self->{legs};
if (ref($_[-1]) eq 'SCALAR') {
my $dict = pop @_;
$$dict = join("|",map { $_->key } @$legs);
}
my @result;
for(@_) {
my $i;
for($i=$#$legs;$i>=0;$i--) {
last if $legs->[$i] == $_;
}
push @result,$i;
}
return @result;
}
###########################################################################
# map index to leg in list of legs
# Args: @ilegs,[\$dict]
# @ilegs: list of leg indices
# $dict: optional string representation of dictionary, will return ()
# if $dict does not match current legs and order in dispatcher
# Returns: @legs
# @legs: list of legs matching indices
###########################################################################
sub i2legs {
my Net::SIP::Dispatcher $self = shift;
my $legs = $self->{legs};
if (ref($_[-1])) {
return if ${pop(@_)} ne join("|",map { $_->key } @$legs);
}
return @{$legs}[@_];
}
###########################################################################
# add timer
# propagates to add_timer of eventloop
......
......@@ -130,7 +130,7 @@ sub new {
Proto => $proto eq 'tls' ? 'tcp' : $proto,
Family => $src->{family},
LocalAddr => $src->{addr},
Reuse => 1,
Reuse => 1, ReuseAddr => 1,
);
if ($proto eq 'tcp' or $proto eq 'tls') {
# with TCP we create a listening socket
......@@ -317,6 +317,9 @@ sub forward_outgoing {
my $branch = $self->via_branch($packet,3);
foreach my $via ( @via ) {
my (undef,$param) = sip_hdrval2parts( via => $via );
# ignore via header w/o branch, although these don't conform to
# RFC 3261, sect 8.1.1.7
defined $param->{branch} or next;
if ( substr( $param->{branch},0,length($branch) ) eq $branch ) {
DEBUG( 10,'loop detected because outgoing leg is in Via. DROP' );
return [ undef,'loop detected on outgoing leg, dropping' ];
......@@ -514,15 +517,31 @@ sub via_branch {
my ($packet,$level) = @_;
my $val = $self->{branch};
$val .= substr( md5_hex( $packet->tid ),0,15 ) if $level>1;
$val .= substr( md5_hex(
( sort $packet->get_header( 'proxy-authorization' )),
( sort $packet->get_header( 'proxy-require' )),
$packet->get_header( 'route' ),
$packet->get_header( 'to' ),
$packet->get_header( 'from' ),
($packet->get_header( 'via' ))[0] || '',
($packet->as_parts())[1],
),0,15 ) if $level>2;
if ($level>2) {
my @parts;
# RT#120816 - take only known constant values from proxy-authorization
for(sort $packet->get_header('proxy-authorization')) {
my ($typ,$param) = sip_hdrval2parts('proxy-authorization' => $_);
push @parts,$typ;
for(qw(realm username domain qop algorithm)) {
push @parts,"$_=$param->{$_}" if exists $param->{$_};
}
}
# RT#120816 - include only the branch from via header if possible
if (my $via = ($packet->get_header('via'))[0]) {
my (undef,$param) = sip_hdrval2parts(via => $via);
push @parts, $param && $param->{branch} || $via;
}
push @parts,
( sort $packet->get_header('proxy-require')),
$packet->get_header('route'),
$packet->get_header('to'),
$packet->get_header('from'),
($packet->as_parts())[1];
$val .= substr(md5_hex(@parts),0,15);
}
return $val;
}
......
......@@ -50,6 +50,7 @@ use fields qw( call_cleanup rtp_cleanup ctx param );
# sip_header: hashref of SIP headers to add
# call_on_hold: one-shot parameter to set local media addr to 0.0.0.0,
# will be set to false after use
# dtmf_methods: supported DTMF methods for receiving, default 'rfc2833,audio'
# rtp_param: [ pt,size,interval,name ] RTP payload type, packet size and interval
# between packets managed in Net::SIP::Simple::RTP, default is PCMU/8000,
# e.g [ 0,160,160/8000 ]
......@@ -616,11 +617,15 @@ sub _setup_peer_rtp_socks {
push @$raddr, @socks == 1 ? $socks[0] : \@socks;
if ( $m->{media} eq 'audio' and $param->{cb_dtmf} ) {
my %rmap = (
'PCMU/8000' => 'audio_type',
'telephone-event/8000' => 'rfc2833_type'
);
my %pargs = ( audio_type => 0 ); # 0 is default type for PCMU/8000
my %mt = qw(audio PCMU/8000 rfc2833 telephone-event/8000);
my $mt = $param->{dtmf_methods} || 'audio,rfc2833';
my (%rmap,%pargs);
for($mt =~m{([\w+\-]+)}g) {
my $type = $mt{$_} or die "invalid dtmf_method: $_";
$rmap{$type} = $_.'_type';
# 0 is default type for PCMU/8000
%pargs = (audio_type => 0) if $_ eq 'audio';
}
for my $l (@{$m->{lines}}) {
$l->[0] eq 'a' or next;
my ($type,$name) = $l->[1] =~m{^rtpmap:(\d+)\s+(\S+)} or next;
......
......@@ -100,6 +100,11 @@ for the data. If this option is TRUE it will allocate a different port
for receiving data. Mainly used for testing behavior of proxies in between
the two parties.
=item dtmf_methods
If a DTMF callback is specified this is treated as a list of supported DTMF
methods for receiving DTMF. If not given it defaults to 'rfc2833,audio'.
=item recv_bye
Callback usable by B<invoke_callback> in L<Net::SIP::Util> which will be
......
......@@ -182,7 +182,7 @@ sub master {
# send packet via SocketPool
# Args: ($self,$packet,$dst,$callback)
# $packet: Net::SIP::Packet
# $dst: where to send as hash with addr,port,family]
# $dst: where to send as hash with addr,port,family
# $callback: callback to call on definite successful delivery (TCP/TLS only)
# or on error
###########################################################################
......@@ -249,7 +249,7 @@ sub sendto {
ip_parts2string($fo->{peer}));
# send over this connected socket
$fo->{wbuf} .= $data;
_tcp_send($self,$fo,$callback);
_tcp_send($self,$fo,$callback) if ! $fo->{inside_connect};
return;
}
......@@ -258,7 +258,7 @@ sub sendto {
ip_parts2string($dst));
my $clfd = INETSOCK(
Proto => 'tcp',
Reuse => 1,
Reuse => 1, ReuseAddr => 1,
LocalAddr => (ip_sockaddr2parts(getsockname($fo->{fd})))[0],
Blocking => 0,
);
......@@ -422,6 +422,7 @@ sub _handle_read_udp {
invoke_callback($self->{cb},$pkt, {
%{ ip_sockaddr2parts($from) },
proto => 'udp',
socket => $fd,
});
}
......@@ -540,6 +541,7 @@ sub _handle_read_tcp_co {
invoke_callback($self->{cb},$pkt, {
%{ ip_sockaddr2parts($from) },
proto => $self->{tls} ? 'tls' : 'tcp',
socket => $fd,
});
# continue with processing any remaining data in the buffer
......
......@@ -63,8 +63,8 @@ This method is used indirectly from B<Leg::deliver> to deliver a new packet to
its destinination.
This will deliver the L<Net::SIP::Packet> B<PKT> to the target B<DST> given as
C<< [ip, port, family] >> and will invoke B<CALLBACK> when done. Callback can be
anything accepted by B<invoke_callback> from L<Net::SIP::Util>.
hash with C<addr>, C<port>, C<family> and will invoke B<CALLBACK> when done.
Callback can be anything accepted by B<invoke_callback> from L<Net::SIP::Util>.
With TCP the B<SocketPool> will try to find an existing connected socket to the
target first before creating a new one. For response packets it will prefer the
......@@ -85,7 +85,13 @@ handler to the given B<LOOP> to handle new packets coming in through the sockets
inside the B<SocketPool>. It will accept any callback suitable for
B<invoke_callback> and will invoke it with C<< [PKT, FROM] >> where B<PKT> is
the freshly read L<Net::SIP::Packet> and B<FROM> the origin of this packet as
C<< [ip, port, family] >>.
hash.
This hash includes C<addr>, C<port> of the sender, C<family> of the socket,
C<proto> as the used protocol (i.e. 'udp', 'tcp' or 'tls') and C<socket> for the
local socket object where the packet was received on.
This socket is either an IO::Socket or IO::Socket::SSL object and is only
intended for passive use, for example to extract the certificate send by
the peer.
If B<LOOP> is undef it will just detach from the current loop.
......
......@@ -12,7 +12,7 @@ package Net::SIP::StatelessProxy;
use fields qw( dispatcher rewrite_contact nathelper force_rewrite );
use Net::SIP::Util ':all';
use Digest::MD5 qw(md5_hex md5);
use Digest::MD5 qw(md5);
use Carp 'croak';
use List::Util 'first';
use Hash::Util 'lock_ref_keys';
......@@ -29,6 +29,10 @@ use Net::SIP::Debug;
# if called on a string without @ which cannot rewritten back it
# should return undef. If not given a reasonable default will be
# used.
# rewrite_crypt: function(data,dir,add2mac) which will encrypt(dir>0) or
# decrypt(dir<0) data. Optional add2mac is added in MAC. Will return
# encrypted/decrypted data or undef if decryption failed because
# MAC did not match
# nathelper: Net::SIP::NAT::Helper used for rewrite SDP bodies.. (optional)
# force_rewrite: if true rewrite contact even if incoming and outgoing
# legs are the same
......@@ -54,46 +58,43 @@ sub new {
# default handler for rewriting, does simple XOR only,
# this is not enough if you need to hide internal addresses
sub _default_rewrite_contact {
my ($crypt,$disp,$contact,$leg_in,$leg_out) = @_;
my ($crypt,$disp,$contact,$leg_in,$leg_out,$force_rewrite) = @_;
if ( $contact =~m{\@} ) {
my $legdict;
my ($ileg_in,$ileg_out) = $disp->legs2i($leg_in,$leg_out,\$legdict);
if ($force_rewrite or $contact =~m{\@}) {
# needs to be rewritten - incorporate leg_in:leg_out
$contact = join("\|",
(map { $_->key } ($leg_in,$leg_out)),
$contact
);
# add 'r' in front of hex so it does not look like phone number
my $new = 'r'.unpack( 'H*',$crypt->($contact,1));
$contact = pack("nna*",$ileg_in,$ileg_out,$contact);
# add 'b' in front so it does not look like phone number
my $new = 'b'._encode_base32($crypt->($contact,1,$legdict));
DEBUG( 100,"rewrite $contact -> $new" );
return $new;
}
if ( $contact =~m{^r([0-9a-f]+)$} ) {
if ( $contact =~m{^b([A-Z2-7]+)$} ) {
# needs to be written back
my $old = $crypt->(pack("H*",$1),-1) or do {
my $old = $crypt->(_decode_base32($1),-1,$legdict) or do {
DEBUG(10,"no rewriting of $contact - bad encryption");
return;
};
DEBUG(100,"rewrote back $contact -> $old");
(my $old_in,my $old_out,$old) = split( m{\|},$old,3);
(my $iold_in,my $iold_out,$old) = unpack("nna*",$old);
my $new_in = $leg_in->key;
if ( $new_in ne $old_out ) {
DEBUG(10,"no rewriting of $contact - went out through $old_out, came in through $new_in");
if ($ileg_in ne $iold_out) {
DEBUG(10,"no rewriting of $contact - went out through $iold_out, came in through $ileg_in");
return;
}
if ( ref($leg_out) eq 'SCALAR' ) {
# return the old_in as the new outgoing leg
my @l = grep { $_->key eq $old_in } $disp->get_legs;
if ( @l != 1 ) {
DEBUG(10,"no rewriting of $contact - cannot find leg $old_in");
($$leg_out) = $disp->i2legs($iold_in) or do {
DEBUG(10,"no rewriting of $contact - cannot find leg $iold_in");
return;
}
$$leg_out = $l[0];
} elsif ( $leg_out ) {
} elsif ($leg_out) {
# check that it is the expected leg
my $new_out = $leg_out->key;
if ( $new_out ne $old_in ) {
DEBUG(10,"no rewriting of $contact - went in through $old_in, should got out through $new_out");
if ($ileg_out ne $iold_in) {
DEBUG(10,"no rewriting of $contact - went in through $iold_in, should got out through $ileg_out");
return;
}
}
......@@ -107,19 +108,35 @@ sub _default_rewrite_contact {
}
{
# This is only a simple implementation which is in no way cryptographic safe
# because it does use a broken cipher (RC4), pseudo-random keys and IV only
# and short keys. Nonetheless, it is probably safe for this purpose and does
# not depend on non-standard libs, but using openssl bindings might be both
# more secure and faster for this.
#
# RC4 with seed + checksum, picks random key on first use
# dir: encrypt(1),decrypt(-1), otherwise symmetric w/o seed and checksum
my @k;
my (@k,$mackey);
sub _stupid_crypt {
my ($in,$dir) = @_;
@k = map { rand(256) } (0..20) if ! @k; # create random key
my ($in,$dir,$add2mac) = @_;
$add2mac = '' if ! defined $add2mac;
if (!@k) {
# create random key
@k = map { rand(256) } (0..20);
$mackey = pack("N",rand(2**32));
}
if ($dir>0) {
$in = pack("N",rand(2**32)).$in; # add seed
$in .= substr(md5($in),0,4); # add checksum
} else {
# remove checksum and verify it
my $cksum = substr($in,-4,4,'');
substr(md5($in.$add2mac.$mackey),0,4) eq $cksum
or return; # does not match
}
# RC4
# apply RC4 for encryption/decryption
my $out = '';
my @s = (0..255);
my $x = my $y = 0;
......@@ -135,13 +152,35 @@ sub _default_rewrite_contact {
$out .= pack('C',$_^=$s[($s[$x]+$s[$y])%256]);
}
if ( $dir<0 ) {
my $cksum = substr($out,-4,4,''); # remove checksum
substr(md5($out),0,4) eq $cksum or return; # verify it
substr($out,0,4,''); # remove seed
if ($dir>0) {
# add checksum
$out .= substr(md5($out.$add2mac.$mackey),0,4);
} else {
substr($out,0,4,''); # remove seed
}
return $out;
}
sub _encode_base32 {
my $data = shift;
$data = unpack('B*',$data);
my $text;
my $padsize =
$data .= '0' x ((5 - length($data) % 5) % 5); # padding
$data =~s{(.....)}{000$1}g;
$data = pack('B*',$data);
$data =~tr{\000-\037}{A-Z2-7};
return $data;
}
sub _decode_base32 {
my $data = shift;
$data =~ tr{A-Z2-7a-z}{\000-\037\000-\031};
$data = unpack('B*',$data);
$data =~s{...(.....)}{$1}g;
$data = substr($data,0,8*int(length($data)/8));
return pack('B*',$data);
}
}
###########################################################################
......@@ -516,7 +555,7 @@ sub __forward_packet_final {
# otherwise rewrite it
} else {
$addr = invoke_callback($rewrite_contact,$addr,$incoming_leg,
$outgoing_leg);
$outgoing_leg,1);
$addr .= '@'.$outgoing_leg->laddr(2);
my $cnew = sip_parts2hdrval( 'contact', $pre.$addr.$post, $p );
DEBUG( 50,"rewrote '$c' to '$cnew'" );
......
......@@ -49,29 +49,36 @@ The L<Net::SIP::Dispatcher> object managing the proxy.
=item rewrite_contact
Callback which is used in rewriting B<Contact> headers.
If one puts user@host in it should rewrite it and if one puts
something without '@' it should try to rewrite it back
(and return B<()> if it cannot rewrite it back).
If one puts user@host in it or if it is called with B<force_rewrite> then it
should rewrite it and if one puts something without '@' it should try to rewrite
it back or return B<()> if it cannot be rewritten back.
A working default implementation is provided.
If you want to implement your own: the callbacks gets the arguments B<contact>,
B<incoming_leg> and B<outgoing_leg>. For rewriting a contact of user@host the
legs will be L<Net::SIP::Leg> objects. For rewriting the contact back
B<outgoing_leg> can be either a leg object and you should check if it is the
expected leg. Or it is a scalar reference which you should fill with the leg
extracted from the contact.
B<incoming_leg> and B<outgoing_leg> and B<force_rewrite>.
For rewriting a contact of user@host the legs will be L<Net::SIP::Leg> objects.
For rewriting the contact back B<outgoing_leg> can be either a leg object and
you should check if it is the expected leg. Or it is a scalar reference which
you should fill with the leg extracted from the contact.
The function should return the new contact or nothing if there was nothing to
rewrite or the rewrite failed.
Note that some servers apply length limitiations to the contact so the function
should not return too long values.
=item rewrite_crypt
If you want to have your own encryption for the rewritten contact you should
defined a subroutine here, which gets C<data> as the first and C<dir> as the
second parameter and should return the de/encrypted data. If C<dir> is +1 it
should encrypt and on -1 it should decrypt.
The optional third argument C<add2mac> should be included in calculation and
verification of the MAC.
The function should return the encrypted/decrypted data or undef if decryption
failed because the MAC did not match.
If not defined, then RC4 will be used with a (pseudo)random key, 4 byte
(pseudo)random seed and 4 byte "checksum" (md5) over seed and data.
(pseudo)random seed and 4 byte MAC (md5) over seed and data.
=item nathelper
......
......@@ -189,7 +189,7 @@ sub sip_parts2hdrval {
my $v = $param->{$k};
if ( defined $v ) {
# escape special chars
$v =~s{([%\r\n\t"[:^print:]])}{ sprintf "%%%02x",ord($1) }sg;
$v =~s{([%\r\n\t"[:^print:]])}{ sprintf "%%%02x",ord($1) }esg;
$v = '"'.$v.'"' if $v =~m{\s|$delim};
$val .= '='.$v
}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment