mirror of https://github.com/sipwise/rtpengine.git
Change-Id: Ia615394c9c87c797a0ee58ccc67074f9caba4093changes/35/25935/6
Richard Fuchs
8 years ago
parent
5de8229a17
commit
84f152bc62
@ -0,0 +1,110 @@
|
||||
package NGCP::Rtpclient::SDES;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use NGCP::Rtpclient::SRTP;
|
||||
use MIME::Base64;
|
||||
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
|
||||
# our list of crypto suites
|
||||
|
||||
if (!$args{suites} || !@{$args{suites}}) {
|
||||
$self->{suites} = [@NGCP::Rtpclient::SRTP::crypto_suites];
|
||||
}
|
||||
else {
|
||||
$self->{suites} = [];
|
||||
for my $s (@{$args{suites}}) {
|
||||
my $o = $NGCP::Rtpclient::SRTP::crypto_suites{$s};
|
||||
$o or die;
|
||||
push(@{$self->{suites}}, $o);
|
||||
}
|
||||
}
|
||||
|
||||
# duplicate content and generate random keys
|
||||
|
||||
my $id = 1;
|
||||
for my $s (@{$self->{suites}}) {
|
||||
$s = {%$s};
|
||||
$s->{id} = $id++;
|
||||
$s->{master_key} = join('', map {chr(rand(256))} (1 .. $s->{key_length}));
|
||||
$s->{master_salt} = join('', map {chr(rand(256))} (1 .. $s->{salt_length}));
|
||||
}
|
||||
|
||||
return $self
|
||||
}
|
||||
|
||||
sub encode {
|
||||
my ($self) = @_;
|
||||
my @ret;
|
||||
for my $s (@{$self->{suites}}) {
|
||||
push(@ret, "a=crypto:$s->{id} $s->{str} inline:" .
|
||||
encode_base64($s->{master_key} . $s->{master_salt}, ''));
|
||||
}
|
||||
return @ret;
|
||||
}
|
||||
|
||||
sub decode {
|
||||
my ($self, $sdp_media) = @_;
|
||||
$self->{remote_suites} = [];
|
||||
my $suites = $sdp_media->get_attrs('crypto');
|
||||
for my $line (@{$suites}) {
|
||||
my ($id, $s, $b64) = $line =~ /^(\S+) (\S+) inline:(\S+)$/ or next;
|
||||
$s = $NGCP::Rtpclient::SRTP::crypto_suites{$s};
|
||||
$s or next; # crypto suite not supported by perl mod
|
||||
$s = {%$s};
|
||||
$s->{id} = $id;
|
||||
($s->{master_key}, $s->{master_salt}) = NGCP::Rtpclient::SRTP::decode_inline_base64($b64, $s);
|
||||
push(@{$self->{remote_suites}}, $s);
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
# construct ->suites to match suites from ->remote_suites after an offer
|
||||
sub offered {
|
||||
my ($self) = @_;
|
||||
my @out;
|
||||
for my $r (@{$self->{remote_suites}}) {
|
||||
for my $s (@{$self->{suites}}) {
|
||||
if ($r->{str} eq $s->{str}) {
|
||||
my $dup = {%$s};
|
||||
$dup->{remote} = $r;
|
||||
$dup->{id} = $r->{id};
|
||||
push(@out, $dup);
|
||||
}
|
||||
}
|
||||
}
|
||||
@{$self->{suites}} = @out;
|
||||
$self->{suite} = $out[0];
|
||||
return;
|
||||
}
|
||||
|
||||
# prunes ->suites to contain only matching suites from ->remote_suites after an answer
|
||||
sub answered {
|
||||
my ($self) = @_;
|
||||
my @out;
|
||||
for my $s (@{$self->{suites}}) {
|
||||
for my $r (@{$self->{remote_suites}}) {
|
||||
if ($r->{id} eq $s->{id} && $r->{str} eq $s->{str}) {
|
||||
$s->{remote} = $r;
|
||||
push(@out, $s);
|
||||
}
|
||||
}
|
||||
}
|
||||
@{$self->{suites}} = @out;
|
||||
$self->{suite} = $out[0];
|
||||
return;
|
||||
}
|
||||
|
||||
# after an offer, trims the list of suites to just the one shared/supported one
|
||||
sub trim {
|
||||
my ($self) = @_;
|
||||
splice(@{$self->{suites}}, 1);
|
||||
splice(@{$self->{remote_suites}}, 1);
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,34 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use NGCP::Rtpengine::Test;
|
||||
use IO::Socket;
|
||||
|
||||
my $r = NGCP::Rtpengine::Test->new();
|
||||
my ($a, $b) = $r->client_pair(
|
||||
{},
|
||||
{sdes => 1}
|
||||
);
|
||||
|
||||
@{$b->{sdes}->{suites}} >= 7 or die; # all that we support
|
||||
|
||||
$r->timer_once(10, sub { $r->stop(); });
|
||||
|
||||
$a->offer($b, ICE => 'remove', 'transport-protocol' => 'RTP/SAVP');
|
||||
|
||||
@{$b->{sdes}->{remote_suites}} >= 7 or die; # all that we support
|
||||
|
||||
$b->answer($a, ICE => 'remove');
|
||||
|
||||
@{$b->{sdes}->{remote_suites}} >= 7 or die; # still the full list
|
||||
@{$b->{sdes}->{suites}} >= 7 or die; # still the full list
|
||||
|
||||
$a->start_rtp();
|
||||
$a->start_rtcp();
|
||||
$b->start_rtp();
|
||||
$b->start_rtcp();
|
||||
|
||||
$r->run();
|
||||
|
||||
$a->teardown();
|
||||
@ -0,0 +1,37 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use NGCP::Rtpengine::Test;
|
||||
use IO::Socket;
|
||||
|
||||
my $r = NGCP::Rtpengine::Test->new();
|
||||
my ($a, $b) = $r->client_pair(
|
||||
{},
|
||||
{sdes => 1}
|
||||
);
|
||||
|
||||
@{$b->{sdes}->{suites}} >= 7 or die; # all that we support
|
||||
|
||||
$r->timer_once(10, sub { $r->stop(); });
|
||||
|
||||
$a->offer($b, ICE => 'remove', 'transport-protocol' => 'RTP/SAVP');
|
||||
|
||||
@{$b->{sdes}->{remote_suites}} >= 7 or die; # all that we support
|
||||
$b->{sdes}->trim();
|
||||
@{$b->{sdes}->{remote_suites}} == 1 or die; # just 1 for answer
|
||||
@{$b->{sdes}->{suites}} == 1 or die; # just 1 for answer
|
||||
|
||||
$b->answer($a, ICE => 'remove');
|
||||
|
||||
@{$b->{sdes}->{remote_suites}} == 1 or die; # just 1 answer
|
||||
@{$b->{sdes}->{suites}} == 1 or die; # just 1 after negotiation
|
||||
|
||||
$a->start_rtp();
|
||||
$a->start_rtcp();
|
||||
$b->start_rtp();
|
||||
$b->start_rtcp();
|
||||
|
||||
$r->run();
|
||||
|
||||
$a->teardown();
|
||||
@ -0,0 +1,34 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use NGCP::Rtpengine::Test;
|
||||
use IO::Socket;
|
||||
|
||||
my $r = NGCP::Rtpengine::Test->new();
|
||||
my ($a, $b) = $r->client_pair(
|
||||
{sdes => 1},
|
||||
{}
|
||||
);
|
||||
|
||||
@{$a->{sdes}->{suites}} >= 7 or die; # all that we support
|
||||
|
||||
$r->timer_once(10, sub { $r->stop(); });
|
||||
|
||||
$a->offer($b, ICE => 'remove', 'transport-protocol' => 'RTP/AVP');
|
||||
|
||||
@{$a->{sdes}->{suites}} >= 7 or die; # all that we support
|
||||
|
||||
$b->answer($a, ICE => 'remove');
|
||||
|
||||
@{$a->{sdes}->{remote_suites}} == 1 or die; # just 1 answer
|
||||
@{$a->{sdes}->{suites}} == 1 or die; # just 1 after negotiation
|
||||
|
||||
$a->start_rtp();
|
||||
$a->start_rtcp();
|
||||
$b->start_rtp();
|
||||
$b->start_rtcp();
|
||||
|
||||
$r->run();
|
||||
|
||||
$a->teardown();
|
||||
@ -0,0 +1,46 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use NGCP::Rtpengine::Test;
|
||||
use IO::Socket;
|
||||
|
||||
my $r = NGCP::Rtpengine::Test->new();
|
||||
my ($a, $b) = $r->client_pair(
|
||||
{sdes => 1, sdes_args => {suites => [qw(
|
||||
AES_CM_256_HMAC_SHA1_80 AES_CM_256_HMAC_SHA1_32
|
||||
AES_CM_128_HMAC_SHA1_80 AES_CM_128_HMAC_SHA1_32
|
||||
)]}},
|
||||
{sdes => 1}
|
||||
);
|
||||
|
||||
@{$a->{sdes}->{suites}} == 4 or die; # the ones we selected
|
||||
@{$b->{sdes}->{suites}} >= 7 or die; # all that we support
|
||||
|
||||
$r->timer_once(10, sub { $r->stop(); });
|
||||
|
||||
$a->offer($b, ICE => 'remove', flags => [qw(SDES-no-AES_CM_256_HMAC_SHA1_80 SDES-no-AES_CM_256_HMAC_SHA1_32)]);
|
||||
|
||||
@{$a->{sdes}->{suites}} == 4 or die; # the ones we selected
|
||||
|
||||
@{$b->{sdes}->{remote_suites}} >= 5 or die; # all that we support (our selected + added by rtpengine - restrict)
|
||||
$b->{sdes}->trim();
|
||||
@{$b->{sdes}->{remote_suites}} == 1 or die; # just 1 for answer
|
||||
@{$b->{sdes}->{suites}} == 1 or die; # just 1 for answer
|
||||
|
||||
$b->answer($a, ICE => 'remove');
|
||||
|
||||
@{$a->{sdes}->{remote_suites}} == 1 or die; # just 1 answer
|
||||
@{$a->{sdes}->{suites}} == 1 or die; # just 1 after negotiation
|
||||
|
||||
@{$b->{sdes}->{remote_suites}} == 1 or die; # just 1 answer
|
||||
@{$b->{sdes}->{suites}} == 1 or die; # just 1 after negotiation
|
||||
|
||||
$a->start_rtp();
|
||||
$a->start_rtcp();
|
||||
$b->start_rtp();
|
||||
$b->start_rtcp();
|
||||
|
||||
$r->run();
|
||||
|
||||
$a->teardown();
|
||||
@ -0,0 +1,46 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use NGCP::Rtpengine::Test;
|
||||
use IO::Socket;
|
||||
|
||||
my $r = NGCP::Rtpengine::Test->new();
|
||||
my ($a, $b) = $r->client_pair(
|
||||
{sdes => 1, sdes_args => {suites => [qw(
|
||||
AES_CM_256_HMAC_SHA1_80 AES_CM_256_HMAC_SHA1_32
|
||||
AES_CM_128_HMAC_SHA1_80 AES_CM_128_HMAC_SHA1_32
|
||||
)]}},
|
||||
{sdes => 1}
|
||||
);
|
||||
|
||||
@{$a->{sdes}->{suites}} == 4 or die; # the ones we selected
|
||||
@{$b->{sdes}->{suites}} >= 7 or die; # all that we support
|
||||
|
||||
$r->timer_once(10, sub { $r->stop(); });
|
||||
|
||||
$a->offer($b, ICE => 'remove');
|
||||
|
||||
@{$a->{sdes}->{suites}} == 4 or die; # the ones we selected
|
||||
|
||||
@{$b->{sdes}->{remote_suites}} >= 7 or die; # all that we support (our selected + added by rtpengine)
|
||||
$b->{sdes}->trim();
|
||||
@{$b->{sdes}->{remote_suites}} == 1 or die; # just 1 for answer
|
||||
@{$b->{sdes}->{suites}} == 1 or die; # just 1 for answer
|
||||
|
||||
$b->answer($a, ICE => 'remove');
|
||||
|
||||
@{$a->{sdes}->{remote_suites}} == 1 or die; # just 1 answer
|
||||
@{$a->{sdes}->{suites}} == 1 or die; # just 1 after negotiation
|
||||
|
||||
@{$b->{sdes}->{remote_suites}} == 1 or die; # just 1 answer
|
||||
@{$b->{sdes}->{suites}} == 1 or die; # just 1 after negotiation
|
||||
|
||||
$a->start_rtp();
|
||||
$a->start_rtcp();
|
||||
$b->start_rtp();
|
||||
$b->start_rtcp();
|
||||
|
||||
$r->run();
|
||||
|
||||
$a->teardown();
|
||||
@ -0,0 +1,43 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use NGCP::Rtpengine::Test;
|
||||
use IO::Socket;
|
||||
|
||||
my $r = NGCP::Rtpengine::Test->new();
|
||||
my ($a, $b) = $r->client_pair(
|
||||
{sdes => 1},
|
||||
{sdes => 1}
|
||||
);
|
||||
|
||||
@{$a->{sdes}->{suites}} >= 7 or die; # all that we support
|
||||
@{$b->{sdes}->{suites}} >= 7 or die; # all that we support
|
||||
|
||||
$r->timer_once(10, sub { $r->stop(); });
|
||||
|
||||
$a->offer($b, ICE => 'remove');
|
||||
|
||||
@{$a->{sdes}->{suites}} >= 7 or die; # all that we support
|
||||
|
||||
@{$b->{sdes}->{remote_suites}} >= 7 or die; # all that we support
|
||||
$b->{sdes}->trim();
|
||||
@{$b->{sdes}->{remote_suites}} == 1 or die; # just 1 for answer
|
||||
@{$b->{sdes}->{suites}} == 1 or die; # just 1 for answer
|
||||
|
||||
$b->answer($a, ICE => 'remove');
|
||||
|
||||
@{$a->{sdes}->{remote_suites}} == 1 or die; # just 1 answer
|
||||
@{$a->{sdes}->{suites}} == 1 or die; # just 1 after negotiation
|
||||
|
||||
@{$b->{sdes}->{remote_suites}} == 1 or die; # just 1 answer
|
||||
@{$b->{sdes}->{suites}} == 1 or die; # just 1 after negotiation
|
||||
|
||||
$a->start_rtp();
|
||||
$a->start_rtcp();
|
||||
$b->start_rtp();
|
||||
$b->start_rtcp();
|
||||
|
||||
$r->run();
|
||||
|
||||
$a->teardown();
|
||||
Loading…
Reference in new issue