mirror of https://github.com/sipwise/rtpengine.git
Richard Fuchs
10 years ago
parent
942966b463
commit
1f8d8d7325
@ -0,0 +1,209 @@
|
||||
package DTLS;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use SRTP;
|
||||
use File::Temp;
|
||||
use Crypt::OpenSSL::RSA;
|
||||
use IO::Socket::INET;
|
||||
use IPC::Open3;
|
||||
use IO::Multiplex;
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub new_cert {
|
||||
my ($self) = @_;
|
||||
|
||||
my $rsa_key = Crypt::OpenSSL::RSA->generate_key(1024);
|
||||
my $priv_key = $rsa_key->get_private_key_string();
|
||||
my $key_file = File::Temp->new();
|
||||
print $key_file $priv_key;
|
||||
close($key_file);
|
||||
|
||||
my $cert_file = File::Temp->new();
|
||||
system(qw(openssl req -key), $key_file->filename(), '-out', $cert_file->filename(),
|
||||
qw(-new -x509 -days 30 -subj /CN=tester -batch));
|
||||
my $cert;
|
||||
read($cert_file, $cert, 10000);
|
||||
close($cert_file);
|
||||
|
||||
my $cert_key_file = File::Temp->new();
|
||||
print $cert_key_file $cert;
|
||||
print $cert_key_file $priv_key;
|
||||
close($cert_key_file);
|
||||
|
||||
$self->set_cert($cert_key_file);
|
||||
return $cert_key_file;
|
||||
}
|
||||
|
||||
sub get_cert {
|
||||
my ($self) = @_;
|
||||
return $self->{_cert_key_file};
|
||||
}
|
||||
|
||||
sub set_cert {
|
||||
my ($self, $file) = @_;
|
||||
$self->{_cert_key_file} = $file;
|
||||
}
|
||||
|
||||
sub check_cert {
|
||||
my ($self, $file) = @_;
|
||||
$self->{_cert_key_file} and return;
|
||||
$self->new_cert();
|
||||
}
|
||||
|
||||
sub connect {
|
||||
my ($self, $local, $dest) = @_;
|
||||
$self->check_cert();
|
||||
|
||||
$self->{_connected} and return 1;
|
||||
|
||||
$self->_kill_openssl_child();
|
||||
|
||||
my $near = $self->{_near};
|
||||
my $far = $self->{_far};
|
||||
|
||||
if (!$far) {
|
||||
if (ref($local)) {
|
||||
$far = $local;
|
||||
}
|
||||
else {
|
||||
$far = IO::Socket::INET->new(Type => SOCK_DGRAM, PeerAddr => $dest,
|
||||
LocalAddr => $local, Proto => 'udp');
|
||||
}
|
||||
$self->{_far} = $far;
|
||||
}
|
||||
|
||||
$near or ($near = $self->{_near} = IO::Socket::INET->new(Type => SOCK_DGRAM, LocalAddr => 'localhost',
|
||||
Proto => 'udp'));
|
||||
|
||||
my $near_port = $near->sockport();
|
||||
|
||||
my ($openssl_in, $openssl_out);
|
||||
$self->{_openssl_pid} = open3($openssl_in, $openssl_out, undef,
|
||||
qw(openssl s_client -connect),
|
||||
"localhost:$near_port",
|
||||
'-cert', $self->{_cert_key_file}->filename(), qw(-dtls1 -use_srtp
|
||||
SRTP_AES128_CM_SHA1_80:SRTP_AES128_CM_SHA1_32 -keymatexport EXTRACTOR-dtls_srtp
|
||||
-keymatexportlen 60));
|
||||
$self->{_openssl_out} = $openssl_out;
|
||||
$self->{_openssl_in} = $openssl_in;
|
||||
$self->{_openssl_buf} = '';
|
||||
|
||||
my $mux = IO::Multiplex->new();
|
||||
$mux->add($near);
|
||||
$mux->add($far);
|
||||
$mux->add($openssl_out);
|
||||
|
||||
$mux->set_callback_object($self);
|
||||
$mux->loop;
|
||||
|
||||
$self->{_connected} or return 0;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _kill_openssl_child {
|
||||
my ($self) = @_;
|
||||
|
||||
if ($self->{_openssl_pid}) {
|
||||
kill(9, $self->{_openssl_pid});
|
||||
waitpid($self->{_openssl_pid}, 0);
|
||||
}
|
||||
delete($self->{_openssl_pid});
|
||||
delete($self->{_openssl_in});
|
||||
delete($self->{_openssl_out});
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my ($self) = @_;
|
||||
|
||||
$self->_kill_openssl_child();
|
||||
}
|
||||
|
||||
sub mux_input {
|
||||
my ($self, $mux, $fh, $input) = @_;
|
||||
|
||||
if ($fh == $self->{_openssl_out}) {
|
||||
$self->{_openssl_buf} .= $$input;
|
||||
}
|
||||
elsif ($fh == $self->{_near}) {
|
||||
send($self->{_far}, $$input, 0);
|
||||
if (!$self->{_near_peer}) {
|
||||
$self->{_near_peer} = $mux->udp_peer($fh);
|
||||
CORE::connect($self->{_near}, $self->{_near_peer});
|
||||
}
|
||||
}
|
||||
if ($fh == $self->{_far}) {
|
||||
if (is_dtls($$input) && $self->{_near_peer}) {
|
||||
send($self->{_near}, $$input, 0);
|
||||
}
|
||||
}
|
||||
|
||||
$$input = '';
|
||||
|
||||
if ($self->{_openssl_buf} =~ /Server certificate\n(-----BEGIN CERTIFICATE-----\n.*?\n-----END CERTIFICATE-----\n).*SRTP Extension negotiated, profile=(\S+).*Keying material: ([0-9a-fA-F]{120})/s) {
|
||||
$self->{_peer_cert} = $1;
|
||||
$self->{_profile} = $2;
|
||||
$self->{_keys} = pack('H*', $3);
|
||||
$self->{_connected} = 1;
|
||||
$mux->endloop();
|
||||
}
|
||||
if ($self->{_openssl_buf} =~ /\nDONE\n/s) {
|
||||
$mux->endloop();
|
||||
}
|
||||
}
|
||||
|
||||
sub peer_cert {
|
||||
my ($self) = @_;
|
||||
$self->{_peer_cert_file} and return $self->{_peer_cert_file};
|
||||
$self->{_peer_cert} or return;
|
||||
|
||||
my $cert_file = File::Temp->new();
|
||||
print $cert_file $self->{_peer_cert};
|
||||
close($cert_file);
|
||||
|
||||
return ($self->{_peer_cert_file} = $cert_file);
|
||||
}
|
||||
|
||||
sub cert_fingerprint {
|
||||
my ($cert_file) = @_;
|
||||
my $fd;
|
||||
open($fd, '-|', qw(openssl x509 -in), $cert_file->filename(), qw(-fingerprint -noout));
|
||||
my $fp = <$fd>;
|
||||
close($fd);
|
||||
$fp =~ /SHA1 Fingerprint=([0-9a-f:]+)/i or return;
|
||||
return $1;
|
||||
}
|
||||
|
||||
sub mux_eof {
|
||||
my ($self, $mux, $fh) = @_;
|
||||
|
||||
if ($fh == $self->{_openssl_out}) {
|
||||
$mux->endloop();
|
||||
}
|
||||
}
|
||||
|
||||
sub get_keys {
|
||||
my ($self) = @_;
|
||||
|
||||
$self->{_keys} =~ /^(.{16})(.{16})(.{14})(.{14})$/s or return;
|
||||
return ($self->{_profile}, $1, $2, $3, $4);
|
||||
}
|
||||
|
||||
sub is_dtls {
|
||||
my ($s) = @_;
|
||||
length($s) < 1 and return 0;
|
||||
my $c = ord(substr($s, 0, 1));
|
||||
$c < 20 and return 0;
|
||||
$c > 63 and return 0;
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,803 @@
|
||||
package ICE;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Socket;
|
||||
use Socket6;
|
||||
use IO::Socket;
|
||||
use IO::Multiplex;
|
||||
use Math::BigInt;
|
||||
use Digest::HMAC_SHA1 qw(hmac_sha1);
|
||||
use Digest::CRC qw(crc32);
|
||||
use Time::HiRes qw(time);
|
||||
|
||||
my @ice_chars = ('A' .. 'Z', 'a' .. 'z', '0' .. '9');
|
||||
my %type_preferences = (
|
||||
host => 126,
|
||||
srflx => 100,
|
||||
prflx => 110,
|
||||
relay => 0,
|
||||
);
|
||||
my %protocols = ( 17 => 'UDP' );
|
||||
|
||||
sub random_string {
|
||||
my ($len) = @_;
|
||||
return join('', (map {$ice_chars[rand(@ice_chars)]} (1 .. $len)));
|
||||
}
|
||||
|
||||
sub new {
|
||||
my ($class, $components, $controlling) = @_;
|
||||
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
|
||||
$self->{my_ufrag} = random_string(8);
|
||||
$self->{my_pwd} = random_string(26);
|
||||
$self->{controlling} = $controlling;
|
||||
$self->{components} = $components;
|
||||
$self->{tie_breaker} = i64from32(rand(2**32), rand(2**32));
|
||||
|
||||
$self->{candidates} = {}; # foundation -> candidate
|
||||
$self->{remote_candidates} = {}; # foundation -> candidate
|
||||
$self->{candidate_pairs} = {}; # foundation pairs -> pair
|
||||
$self->{remote_peers} = {}; # peer_hash_key -> component
|
||||
$self->{changed_foundations} = {}; # old -> new
|
||||
|
||||
$self->{triggered_checks} = [];
|
||||
$self->{last_timer} = 0;
|
||||
|
||||
$self->debug("created, controll" . ($controlling ? "ing" : "ed")
|
||||
. ", tie breaker " . $self->{tie_breaker}->bstr() . "\n");
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub i64from32 {
|
||||
my ($hi, $lo) = @_;
|
||||
my $i = Math::BigInt->new(int($hi));
|
||||
$i->blsft(32);
|
||||
$i->badd(int($lo));
|
||||
return $i;
|
||||
}
|
||||
|
||||
sub calc_priority {
|
||||
my ($type, $local_pref, $component) = @_;
|
||||
defined($type_preferences{$type}) or die;
|
||||
return (2 ** 24) * $type_preferences{$type} + (2 ** 8) * $local_pref + (256 - $component);
|
||||
}
|
||||
|
||||
sub add_candidate {
|
||||
my ($self, $local_pref, $type, @components) = @_;
|
||||
# highest local pref = 65535, lowest = 0
|
||||
|
||||
@components == $self->{components} or die;
|
||||
defined($type_preferences{$type}) or die;
|
||||
|
||||
my $foundation = random_string(16);
|
||||
my $cands = $self->{candidates};
|
||||
$cands->{$foundation} and die;
|
||||
|
||||
my $comps = [];
|
||||
my $comp_id = 1;
|
||||
for my $c (@components) {
|
||||
my $comp = { socket => $c, component => $comp_id,
|
||||
priority => calc_priority($type, $local_pref, $comp_id),
|
||||
foundation => $foundation,
|
||||
protocol => 'UDP', af => $c->sockdomain(),
|
||||
address => $c->sockhost(), port => $c->sockport() };
|
||||
push(@$comps, $comp);
|
||||
$self->debug("$foundation/$comp_id is $comp->{address}/$comp->{port}\n");
|
||||
|
||||
$comp_id++;
|
||||
}
|
||||
|
||||
$cands->{$foundation} = { foundation => $foundation, preference => $local_pref,
|
||||
base_priority => calc_priority($type, $local_pref, 0),
|
||||
type => $type, components => $comps, protocol => 'UDP',
|
||||
af => $comps->[0]->{af}, address => $comps->[0]->{address} };
|
||||
|
||||
$self->pair_candidates();
|
||||
}
|
||||
|
||||
sub encode {
|
||||
my ($self) = @_;
|
||||
|
||||
my @ret;
|
||||
|
||||
push(@ret, "a=ice-ufrag:$self->{my_ufrag}");
|
||||
push(@ret, "a=ice-pwd:$self->{my_pwd}");
|
||||
|
||||
for my $cand (values(%{$self->{candidates}})) {
|
||||
for my $comp (@{$cand->{components}}) {
|
||||
my $prot = $comp->{socket}->protocol();
|
||||
my $sa = $comp->{socket}->sockhost();
|
||||
my $sp = $comp->{socket}->sockport();
|
||||
push(@ret, "a=candidate:$cand->{foundation} $comp->{component} $protocols{$prot} $comp->{priority} $sa $sp typ $cand->{type}");
|
||||
}
|
||||
}
|
||||
|
||||
return @ret;
|
||||
}
|
||||
|
||||
sub remote_foundation_change {
|
||||
my ($self, $old, $new, $type) = @_;
|
||||
|
||||
if ($self->{changed_foundations}->{$old}) {
|
||||
$self->{changed_foundations}->{$old} eq $new or die;
|
||||
return;
|
||||
}
|
||||
$self->debug("changing remote candidate foundation from $old to $new\n");
|
||||
my $old_cand = $self->{remote_candidates}->{$old} or die;
|
||||
$old_cand->{type} = $type;
|
||||
$old_cand->{foundation} = $new;
|
||||
|
||||
for my $comp (@{$old_cand->{components}}) {
|
||||
$comp->{foundation} = $new;
|
||||
}
|
||||
|
||||
for my $foundation_pair (keys(%{$self->{candidate_pairs}})) {
|
||||
my $pair = $self->{candidate_pairs}->{$foundation_pair};
|
||||
$pair->{remote} == $old_cand or next;
|
||||
|
||||
my $new_foundation = $pair->{local}->{foundation} . $new;
|
||||
delete($self->{candidate_pairs}->{$foundation_pair});
|
||||
$self->{candidate_pairs}->{$new_foundation} = $pair;
|
||||
|
||||
for my $comp (@{$pair->{components}}) {
|
||||
$comp->{foundation} = $new_foundation;
|
||||
}
|
||||
}
|
||||
|
||||
$self->{remote_candidates}->{$new} = $old_cand;
|
||||
delete($self->{remote_candidates}->{$old});
|
||||
$self->{changed_foundations}->{$old} = $new;
|
||||
}
|
||||
|
||||
sub new_remote_candidate {
|
||||
my ($self, $cand_str) = @_;
|
||||
$self->_new_remote_candidates_start();
|
||||
my $ret = $self->_new_remote_candidate($cand_str);
|
||||
$self->_got_new_candidates();
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub _new_remote_candidates_start {
|
||||
my ($self) = @_;
|
||||
$self->{new_candidates} = {};
|
||||
}
|
||||
|
||||
sub _new_remote_candidate {
|
||||
my ($self, $c) = @_;
|
||||
|
||||
$self->debug("adding remote candidate $c\n");
|
||||
my ($foundation, $component, $protocol, $priority, $address, $port, $type)
|
||||
= $c =~ /^(\w+) (\d) (\w+) (\d+) ([0-9a-fA-F:.]+) (\d+) typ (\w+)/ or die $c;
|
||||
|
||||
$protocol = uc($protocol);
|
||||
my $phk = "$protocol/$address/$port";
|
||||
|
||||
if (my $old = $self->{remote_peers}->{$phk}) {
|
||||
# must be a previously learned prflx candidate
|
||||
$old = $old->{candidate};
|
||||
$old->{type} eq 'prflx' or die;
|
||||
# replace the learned prflx candidate with the new one
|
||||
$self->remote_foundation_change($old->{foundation}, $foundation, $type);
|
||||
return;
|
||||
}
|
||||
|
||||
my $f = ($self->{new_candidates}->{$foundation} // (
|
||||
$self->{new_candidates}->{$foundation} = {
|
||||
foundation => $foundation,
|
||||
type => $type,
|
||||
protocol => $protocol,
|
||||
components => [],
|
||||
}));
|
||||
|
||||
$f->{type} eq $type or die;
|
||||
$f->{protocol} eq $protocol or die;
|
||||
|
||||
$f->{components}->[$component - 1] and die;
|
||||
my $comp = $f->{components}->[$component - 1] = {
|
||||
candidate => $f,
|
||||
foundation => $foundation,
|
||||
component => $component,
|
||||
priority => $priority,
|
||||
address => $address,
|
||||
port => $port,
|
||||
peer_hash_key => $phk,
|
||||
};
|
||||
|
||||
if ($address =~ /^\d+\.\d+\.\d+\.\d+$/) {
|
||||
$f->{af} = $comp->{af} = &AF_INET;
|
||||
$comp->{packed_peer} = pack_sockaddr_in($port, inet_pton(&AF_INET, $address));
|
||||
}
|
||||
elsif ($address =~ /^[0-9a-fA-F:]+$/) {
|
||||
$f->{af} = $comp->{af} = &AF_INET6;
|
||||
$comp->{packed_peer} = pack_sockaddr_in6($port, inet_pton(&AF_INET6, $address));
|
||||
}
|
||||
else {
|
||||
die;
|
||||
}
|
||||
|
||||
$self->{remote_peers}->{$phk} = $comp;
|
||||
|
||||
return $comp;
|
||||
}
|
||||
|
||||
sub _got_new_candidates {
|
||||
my ($self) = @_;
|
||||
|
||||
# validate received info and eliminate duplicates
|
||||
my $r_cand = $self->{remote_candidates};
|
||||
my $r_peers = $self->{remote_peers};
|
||||
for my $c (values(%{$self->{new_candidates}})) {
|
||||
# @{$c->{components}} == $self->{components} or die;
|
||||
|
||||
if (my $exist = $r_cand->{$c->{foundation}}) {
|
||||
# duplicate. OK if this is a learned prflx
|
||||
if ($exist->{type} eq 'prflx' && $c->{type} eq 'prflx') {
|
||||
# merge components
|
||||
for my $idx (0 .. $#{$c->{components}}) {
|
||||
defined($c->{components}->[$idx]) or next;
|
||||
defined($exist->{components}->[$idx]) and die;
|
||||
$exist->{components}->[$idx] = $c->{components}->[$idx];
|
||||
}
|
||||
next;
|
||||
}
|
||||
warn;
|
||||
next;
|
||||
}
|
||||
$r_cand->{$c->{foundation}} = $c;
|
||||
}
|
||||
|
||||
delete($self->{new_candidates});
|
||||
$self->pair_candidates();
|
||||
};
|
||||
|
||||
sub decode {
|
||||
my ($self, $h) = @_;
|
||||
# $h is output of SDP::Media->decode_ice()
|
||||
|
||||
$self->{other_ufrag} = $h->{ufrag} or die;
|
||||
$self->{other_pwd} = $h->{pwd} or die;
|
||||
|
||||
my $cands = $h->{candidates} or die;
|
||||
$self->_new_remote_candidates_start();
|
||||
for my $c (@$cands) {
|
||||
$self->_new_remote_candidate($c);
|
||||
}
|
||||
$self->_got_new_candidates();
|
||||
}
|
||||
|
||||
sub pair_candidates {
|
||||
my ($self) = @_;
|
||||
|
||||
my $pairs = $self->{candidate_pairs};
|
||||
|
||||
for my $rem (values(%{$self->{remote_candidates}})) {
|
||||
for my $loc (values(%{$self->{candidates}})) {
|
||||
$loc->{protocol} eq $rem->{protocol} or next;
|
||||
$loc->{af} == $rem->{af} or next;
|
||||
|
||||
@{$loc->{components}} == $self->{components} or die;
|
||||
|
||||
my $foundation = $loc->{foundation} . $rem->{foundation};
|
||||
my $pair = $pairs->{$foundation} || ($pairs->{$foundation} =
|
||||
{ foundation => $foundation, local => $loc, remote => $rem,
|
||||
components => []}
|
||||
);
|
||||
my $comps = $pair->{components};
|
||||
|
||||
for my $idx (0 .. ($self->{components} - 1)) {
|
||||
defined($loc->{components}->[$idx]) or next;
|
||||
defined($rem->{components}->[$idx]) or next;
|
||||
|
||||
my $c = $comps->[$idx] || ($comps->[$idx] =
|
||||
{ foundation => $foundation,
|
||||
local => $loc->{components}->[$idx],
|
||||
remote => $rem->{components}->[$idx] });
|
||||
$c->{state} = $c->{state} || ($idx == 0 ? 'waiting' : 'frozen');
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub pair_priority {
|
||||
my ($self, $pair) = @_;
|
||||
# could be a candidate pair or a component pair. only components have priorities
|
||||
my $gk = $self->{controlling} ? 'local' : 'remote';
|
||||
my $dk = $self->{controlling} ? 'remote' : 'local';
|
||||
my $gc = $pair->{$gk};
|
||||
my $dc = $pair->{$dk};
|
||||
if (exists($gc->{components})) {
|
||||
$gc = $gc->{components}->[0];
|
||||
$dc = $dc->{components}->[0];
|
||||
}
|
||||
my $g = $gc->{priority};
|
||||
my $d = $dc->{priority};
|
||||
return (($g < $d ? $g : $d) << 32) + (($g > $d ? $g : $d) * 2) + ($g > $d ? 1 : 0);
|
||||
}
|
||||
|
||||
sub get_pair {
|
||||
my ($self, $local, $remote, $component) = @_;
|
||||
my $found = "$local$remote";
|
||||
my $pair = $self->{candidate_pairs}->{$found} or return;
|
||||
$component or return $pair;
|
||||
return $pair->{components}->[$component - 1];
|
||||
}
|
||||
|
||||
sub is_ice {
|
||||
my ($s) = @_;
|
||||
|
||||
length($s) < 20 and return 0;
|
||||
my $c = ord(substr($s, 0, 1));
|
||||
($c & 0xb0) != 0 and return 0;
|
||||
$c = ord(substr($s, 3, 1));
|
||||
($c & 0x03) != 0 and return 0;
|
||||
$c = substr($s, 4, 4);
|
||||
$c ne "\x21\x12\xA4\x42" and return 0;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub input {
|
||||
my ($self, $fh, $s_r, $peer) = @_;
|
||||
|
||||
$$s_r eq '' and return;
|
||||
is_ice($$s_r) or return;
|
||||
|
||||
for my $cands (values(%{$self->{candidates}})) {
|
||||
for my $comp (@{$cands->{components}}) {
|
||||
$fh == $comp->{socket} or next;
|
||||
$self->do_input($comp, $$s_r, $peer);
|
||||
$$s_r = '';
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my %attr_handlers = (
|
||||
0x0006 => \&stun_handler_USERNAME,
|
||||
0x0008 => \&stun_handler_MESSAGE_INTEGRITY,
|
||||
0x0009 => \&stun_handler_ERROR_CODE,
|
||||
0x000a => \&stun_handler_UNKNOWN_ATTRIBUTES,
|
||||
0x0020 => \&stun_handler_XOR_MAPPED_ADDRESS,
|
||||
0x0024 => \&stun_handler_PRIORITY,
|
||||
0x0025 => \&stun_handler_USE_CANDIDATE,
|
||||
0x8022 => \&stun_handler_SOFTWARE,
|
||||
0x8028 => \&stun_handler_FINGERPRINT,
|
||||
0x8029 => \&stun_handler_ICE_CONTROLLED,
|
||||
0x802a => \&stun_handler_ICE_CONTROLLING,
|
||||
);
|
||||
|
||||
my %type_handlers = (
|
||||
1 => \&stun_handler_binding_request,
|
||||
17 => \&stun_handler_binding_indication,
|
||||
257 => \&stun_handler_binding_success,
|
||||
273 => \&stun_handler_binding_error,
|
||||
);
|
||||
|
||||
sub do_input {
|
||||
my ($self, $comp, $s, $peer) = @_;
|
||||
|
||||
my $hdr = substr($s, 0, 20, '');
|
||||
my ($mtype, $mlen, $cookie, $tid) = unpack('nnNa12', $hdr);
|
||||
$cookie == 0x2112A442 or return;
|
||||
|
||||
my (@stack, %hash);
|
||||
|
||||
while (my ($type, $len) = unpack('nn', $s)) {
|
||||
my $padding = 4 - ($len % 4);
|
||||
$padding == 4 and $padding = 0;
|
||||
|
||||
my $raw = substr($s, 0, 4 + $len + $padding);
|
||||
|
||||
substr($s, 0, 4) = '';
|
||||
my $data = substr($s, 0, $len, '');
|
||||
substr($s, 0, $padding) = '';
|
||||
|
||||
my $handler = $attr_handlers{$type};
|
||||
if (!$handler) {
|
||||
warn("unknown STUN attribute $type data $data");
|
||||
next;
|
||||
}
|
||||
|
||||
my $parsed = $handler->($data, $tid) or die;
|
||||
$parsed->{raw} = $raw;
|
||||
|
||||
push(@stack, $parsed);
|
||||
$hash{$parsed->{name}} = $parsed;
|
||||
}
|
||||
|
||||
$stack[$#stack]->{name} eq 'fingerprint' or die;
|
||||
$stack[$#stack - 1]->{name} eq 'integrity' or die;
|
||||
|
||||
my $pwd_check = $mtype == 1 ? $self->{my_pwd} : $self->{other_pwd};
|
||||
# XXX unify these with sub integrity/fingerprint ?
|
||||
my $int_check = join('', (map {$_->{raw}} @stack[0 .. ($#stack - 2)]));
|
||||
$int_check = pack('nnNa12', $mtype, length($int_check) + 24, $cookie, $tid) . $int_check;
|
||||
my $digest = hmac_sha1($int_check, $pwd_check);
|
||||
$digest eq $hash{integrity}->{digest} or die;
|
||||
|
||||
my $fp_check = join('', (map {$_->{raw}} @stack[0 .. ($#stack - 1)]));
|
||||
$fp_check = pack('nnNa12', $mtype, length($fp_check) + 8, $cookie, $tid) . $fp_check;
|
||||
my $crc = crc32($fp_check);
|
||||
($crc ^ 0x5354554e) == $hash{fingerprint}->{crc} or die;
|
||||
|
||||
# decode peer address
|
||||
my $domain = $comp->{af};
|
||||
my (@peer, $address);
|
||||
if ($domain == &AF_INET) {
|
||||
@peer = unpack_sockaddr_in($peer);
|
||||
}
|
||||
elsif ($domain == &AF_INET6) {
|
||||
@peer = unpack_sockaddr_in6($peer);
|
||||
}
|
||||
else {
|
||||
die;
|
||||
}
|
||||
$address = inet_ntop($domain, $peer[1]);
|
||||
|
||||
# process it
|
||||
my $handler = $type_handlers{$mtype} or die;
|
||||
my $response = $handler->($self, $comp, \@stack, \%hash, $tid, $peer, $peer[1], $address, $peer[0]);
|
||||
|
||||
if ($response) {
|
||||
# construct and send response packet
|
||||
$self->integrity($response->{attrs}, $response->{mtype}, $tid, $self->{my_pwd});
|
||||
$self->fingerprint($response->{attrs}, $response->{mtype}, $tid);
|
||||
|
||||
# XXX unify
|
||||
my $packet = join('', @{$response->{attrs}});
|
||||
$packet = pack('nnNa12', $response->{mtype}, length($packet), 0x2112A442, $tid) . $packet;
|
||||
$comp->{socket}->send($packet, 0, $peer);
|
||||
}
|
||||
}
|
||||
|
||||
sub stun_reply {
|
||||
my ($self, $attrs, $mtype) = @_;
|
||||
|
||||
unshift(@$attrs, attr(0x8022, 'perl:ICE.pm'));
|
||||
|
||||
my $response = { mtype => $mtype, attrs => $attrs };
|
||||
}
|
||||
|
||||
sub stun_success {
|
||||
my ($self, $attrs) = @_;
|
||||
return $self->stun_reply($attrs, 257);
|
||||
}
|
||||
|
||||
sub stun_error {
|
||||
my ($self, $code, $msg) = @_;
|
||||
return $self->stun_reply([ attr(0x0009, pack('Na*', ((($code / 100) << 8) | ($code % 100)), $msg)) ], 273);
|
||||
}
|
||||
|
||||
sub debug {
|
||||
my ($self, @rest) = @_;
|
||||
print("ICE agent", ' ', $self->{my_ufrag}, ' - ', @rest);
|
||||
}
|
||||
|
||||
sub dummy_foundation {
|
||||
my ($protocol, $address) = @_;
|
||||
return $protocol . unpack('H*', $address);
|
||||
}
|
||||
|
||||
sub stun_handler_binding_request {
|
||||
my ($self, $comp, $stack, $hash, $tid, $packed_peer, $packed_host, $address, $port) = @_;
|
||||
|
||||
$hash->{username}->{my_ufrag} eq $self->{my_ufrag} or die;
|
||||
|
||||
# check role
|
||||
if ($self->{controlling} && $hash->{controlling}) {
|
||||
if ($self->{tie_breaker}->bcmp($hash->{controlling}->{tie_breaker}) >= 0) {
|
||||
$self->debug("returning 487 role conflict\n");
|
||||
return $self->stun_error(487, "Role conflict");
|
||||
}
|
||||
$self->debug("role conflict, switching to controlled\n");
|
||||
$self->{controlling} = 0;
|
||||
}
|
||||
elsif (!$self->{controlling} && $hash->{controlled}) {
|
||||
if ($self->{tie_breaker}->bcmp($hash->{controlled}->{tie_breaker}) < 0) {
|
||||
$self->debug("returning 487 role conflict\n");
|
||||
return $self->stun_error(487, "Role conflict");
|
||||
}
|
||||
$self->debug("role conflict, switching to controlling\n");
|
||||
$self->{controlling} = 1;
|
||||
}
|
||||
|
||||
$self->debug("binding request from $address/$port\n");
|
||||
|
||||
# check if peer is known - learn prflx candidates
|
||||
my $cand = $self->{remote_peers}->{"UDP/$address/$port"};
|
||||
if (!$cand) {
|
||||
$cand = $self->new_remote_candidate(dummy_foundation('UDP', $packed_host)
|
||||
. " $comp->{component} UDP "
|
||||
. "$hash->{priority}->{priority} $address $port typ prflx");
|
||||
# this also pairs up the new candidate, which goes against 7.2.1.3
|
||||
}
|
||||
|
||||
# get candidate pair and trigger check
|
||||
my $pair = $self->get_pair($comp->{foundation}, $cand->{foundation}, $comp->{component});
|
||||
$pair or die;
|
||||
$self->trigger_check($pair);
|
||||
|
||||
# set and check nominations
|
||||
if ($hash->{use}) {
|
||||
$pair->{nominated} = 1;
|
||||
$self->debug("$pair->{foundation} - got nominated\n");
|
||||
$self->{controlling} or $self->check_nominations();
|
||||
}
|
||||
|
||||
# construct response
|
||||
my $attrs = [];
|
||||
|
||||
if ($comp->{af} == &AF_INET) {
|
||||
push(@$attrs, attr(0x0020, pack('nna4', 1, $port ^ 0x2112, $packed_host ^ "\x21\x12\xa4\x42")));
|
||||
}
|
||||
elsif ($comp->{af} == &AF_INET6) {
|
||||
push(@$attrs, attr(0x0020, pack('nna16', 2, $port ^ 0x2112,
|
||||
$packed_host ^ ("\x21\x12\xa4\x42" . $tid))));
|
||||
}
|
||||
|
||||
return $self->stun_success($attrs);
|
||||
}
|
||||
|
||||
sub check_nominations {
|
||||
my ($self) = @_;
|
||||
|
||||
my @nominated;
|
||||
|
||||
for my $pair (values(%{$self->{candidate_pairs}})) {
|
||||
my @comps = @{$pair->{components}};
|
||||
my @nominated_comps = grep {$_->{nominated}} @comps;
|
||||
@comps < $self->{components} and next;
|
||||
$self->debug("got fully nominated pair $pair->{foundation}\n");
|
||||
push(@nominated, $pair);
|
||||
}
|
||||
|
||||
if (!@nominated) {
|
||||
$self->debug("no fully nominated pairs yet\n");
|
||||
return;
|
||||
}
|
||||
|
||||
@nominated = $self->sort_pairs(\@nominated);
|
||||
my $pair = $nominated[0];
|
||||
$self->debug("highest priority nominated pair is $pair->{foundation}\n");
|
||||
}
|
||||
|
||||
sub stun_handler_binding_success {
|
||||
my ($self, $comp, $stack, $hash, $tid, $packed_peer, $packed_host, $address, $port) = @_;
|
||||
|
||||
$self->debug("binding success from $address/$port\n");
|
||||
|
||||
# check xor address
|
||||
$comp->{address} eq $hash->{address}->{address} or die;
|
||||
$comp->{port} == $hash->{address}->{port} or die;
|
||||
|
||||
# we must have remote candidate and a pair
|
||||
my $cand = $self->{remote_peers}->{"UDP/$address/$port"};
|
||||
$cand or die;
|
||||
my $pair = $self->get_pair($comp->{foundation}, $cand->{foundation}, $comp->{component});
|
||||
$pair or die;
|
||||
$tid eq $pair->{transaction} or die;
|
||||
|
||||
$self->debug("$pair->{foundation} succeeded\n");
|
||||
$pair->{state} = 'succeeded';
|
||||
|
||||
# unfreeze other components
|
||||
my $parent_pair = $self->{candidate_pairs}->{$pair->{foundation}};
|
||||
my $components = $parent_pair->{components};
|
||||
my @frozen_pairs = grep {$_->{state} eq 'frozen'} @$components;
|
||||
for my $p (@frozen_pairs) {
|
||||
$self->debug("unfreezing $p->{local}->{port}\n");
|
||||
$p->{state} = 'waiting';
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub integrity {
|
||||
my ($self, $attrs, $mtype, $tid, $pwd) = @_;
|
||||
|
||||
my $int_check = join('', @$attrs);
|
||||
$int_check = pack('nnNa12', $mtype, length($int_check) + 24, 0x2112A442, $tid) . $int_check;
|
||||
my $digest = hmac_sha1($int_check, $pwd);
|
||||
push(@$attrs, attr(0x0008, $digest));
|
||||
}
|
||||
|
||||
sub fingerprint {
|
||||
my ($self, $attrs, $mtype, $tid) = @_;
|
||||
|
||||
my $fp_check = join('', @$attrs);
|
||||
$fp_check = pack('nnNa12', $mtype, length($fp_check) + 8, 0x2112A442, $tid) . $fp_check;
|
||||
my $crc = crc32($fp_check);
|
||||
push(@$attrs, attr(0x8028, pack('N', ($crc ^ 0x5354554e))));
|
||||
}
|
||||
|
||||
sub attr {
|
||||
my ($id, $data) = @_;
|
||||
my $len = length($data);
|
||||
my $padding = 4 - ($len % 4);
|
||||
$padding == 4 and $padding = 0;
|
||||
return pack('nn a*a*', $id, $len, $data, "\0" x $padding);
|
||||
}
|
||||
|
||||
sub stun_handler_SOFTWARE {
|
||||
my ($data, $out) = @_;
|
||||
return { name => 'software', data => $data };
|
||||
}
|
||||
sub stun_handler_USE_CANDIDATE {
|
||||
my ($data, $out) = @_;
|
||||
return { name => 'use' };
|
||||
}
|
||||
sub stun_handler_ICE_CONTROLLED {
|
||||
my ($data) = @_;
|
||||
my $out = { name => 'controlled' };
|
||||
$out->{controlled} = 1;
|
||||
($out->{tie_breaker_hi}, $out->{tie_breaker_lo}) = unpack('NN', $data);
|
||||
$out->{tie_breaker} = i64from32($out->{tie_breaker_hi}, $out->{tie_breaker_lo});
|
||||
return $out;
|
||||
}
|
||||
sub stun_handler_ICE_CONTROLLING {
|
||||
my ($data) = @_;
|
||||
my $out = { name => 'controlling' };
|
||||
$out->{controlling} = 1;
|
||||
($out->{tie_breaker_hi}, $out->{tie_breaker_lo}) = unpack('NN', $data);
|
||||
$out->{tie_breaker} = i64from32($out->{tie_breaker_hi}, $out->{tie_breaker_lo});
|
||||
return $out;
|
||||
}
|
||||
sub stun_handler_USERNAME {
|
||||
my ($data) = @_;
|
||||
my $out = { name => 'username' };
|
||||
$data =~ /^(.*):(.*)$/ or die;
|
||||
$out->{my_ufrag} = $1;
|
||||
$out->{other_ufrag} = $2;
|
||||
return $out;
|
||||
}
|
||||
sub stun_handler_PRIORITY {
|
||||
my ($data) = @_;
|
||||
my $out = { name => 'priority' };
|
||||
($out->{priority}) = unpack('N', $data);
|
||||
return $out;
|
||||
}
|
||||
sub stun_handler_MESSAGE_INTEGRITY {
|
||||
my ($data) = @_;
|
||||
my $out = { name => 'integrity' };
|
||||
$out->{digest} = $data;
|
||||
return $out;
|
||||
}
|
||||
sub stun_handler_FINGERPRINT {
|
||||
my ($data) = @_;
|
||||
my $out = { name => 'fingerprint' };
|
||||
($out->{crc}) = unpack('N', $data);
|
||||
return $out;
|
||||
}
|
||||
sub stun_handler_ERROR_CODE {
|
||||
my ($data) = @_;
|
||||
my $out = { name => 'error' };
|
||||
my ($code, $msg) = unpack('Na*', $data);
|
||||
$out->{msg} = $msg;
|
||||
$out->{code} = (($code & 0x700) >> 8) * 100 + ($code & 0x0ff);
|
||||
return $out;
|
||||
}
|
||||
sub stun_handler_XOR_MAPPED_ADDRESS {
|
||||
my ($data, $tid) = @_;
|
||||
my $out = { name => 'address' };
|
||||
if (length($data) == 8) {
|
||||
my ($fam, $port, $addr) = unpack('nna4', $data);
|
||||
$fam == 1 or die;
|
||||
$out->{af} = &AF_INET;
|
||||
$out->{port} = $port ^ 0x2112;
|
||||
$out->{address} = $addr ^ "\x21\x12\xa4\x42";
|
||||
}
|
||||
elsif (length($data) == 20) {
|
||||
my ($fam, $port, $addr) = unpack('nna16', $data);
|
||||
$fam == 2 or die;
|
||||
$out->{af} = &AF_INET6;
|
||||
$out->{port} = $port ^ 0x2112;
|
||||
$out->{address} = $addr ^ ("\x21\x12\xa4\x42" . $tid);
|
||||
}
|
||||
else {
|
||||
die;
|
||||
}
|
||||
$out->{address} = inet_ntop($out->{af}, $out->{address});
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub timer {
|
||||
my ($self) = @_;
|
||||
my $now = time();
|
||||
$now - $self->{last_timer} < 0.02 and return;
|
||||
$self->{last_timer} = $now;
|
||||
|
||||
# run checks
|
||||
|
||||
defined($self->{other_ufrag}) && defined($self->{other_pwd}) or return; # not enough info
|
||||
|
||||
if (my $pair = shift(@{$self->{triggered_checks}})) {
|
||||
$self->debug("$pair->{foundation} - running triggered check\n");
|
||||
$self->run_check($pair);
|
||||
return;
|
||||
}
|
||||
|
||||
# get all component pairs, sort by their priority and run check for the highest waiting one
|
||||
|
||||
my @candidate_pairs = values(%{$self->{candidate_pairs}});
|
||||
my @component_pairs = map {@{$_->{components}}} @candidate_pairs;
|
||||
my @sorted_pairs = $self->sort_pairs(\@component_pairs);
|
||||
my @waiting_pairs = grep {$_->{state} eq 'waiting'} @sorted_pairs;
|
||||
|
||||
if (my $pair = shift(@waiting_pairs)) {
|
||||
$self->debug("$pair->{foundation} - running scheduled check (waiting state)\n");
|
||||
$self->run_check($pair);
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
sub sort_pairs {
|
||||
my ($self, $pair_list) = @_;
|
||||
return sort {$self->pair_priority($a) <=> $self->pair_priority($b)} @$pair_list;
|
||||
}
|
||||
|
||||
sub trigger_check {
|
||||
my ($self, $pair) = @_;
|
||||
$self->debug("$pair->{foundation} - trigger check\n");
|
||||
if ($pair->{state} eq 'succeeded') {
|
||||
$self->debug("$pair->{foundation} - already succeeded\n");
|
||||
return;
|
||||
}
|
||||
if ($pair->{state} eq 'in progress') {
|
||||
$self->cancel_check($pair);
|
||||
}
|
||||
push(@{$self->{triggered_checks}}, $pair);
|
||||
}
|
||||
|
||||
sub run_check {
|
||||
my ($self, $pair) = @_;
|
||||
|
||||
$pair->{state} eq 'in progress' and return;
|
||||
|
||||
$self->debug("$pair->{foundation} - running check\n");
|
||||
$pair->{state} = 'in progress';
|
||||
$pair->{transaction} = random_string(12);
|
||||
$self->send_check($pair);
|
||||
}
|
||||
|
||||
sub cancel_check {
|
||||
my ($self, $pair) = @_;
|
||||
$self->debug("$pair->{foundation} - canceling existing check $pair->{transaction}\n");
|
||||
$pair->{previous_transactions}->{$pair->{transaction}} = 1;
|
||||
delete $pair->{transaction};
|
||||
$pair->{state} = 'waiting';
|
||||
}
|
||||
|
||||
sub send_check {
|
||||
my ($self, $pair) = @_;
|
||||
|
||||
$self->debug("$pair->{foundation} - sending check $pair->{transaction}\n");
|
||||
|
||||
$pair->{last_transmit} = time();
|
||||
my $local_comp = $pair->{local};
|
||||
my $remote_comp = $pair->{remote};
|
||||
my $local_cand = $self->{candidates}->{$local_comp->{foundation}};
|
||||
|
||||
my $attrs = [];
|
||||
unshift(@$attrs, attr(0x8022, 'perl:ICE.pm'));
|
||||
my $hexbrk = $self->{tie_breaker}->as_hex();
|
||||
$hexbrk =~ s/^0x// or die;
|
||||
$hexbrk = ('0' x (16 - length($hexbrk))) . $hexbrk;
|
||||
unshift(@$attrs, attr($self->{controlling} ? 0x802a : 0x8029, pack('H*', $hexbrk)));
|
||||
unshift(@$attrs, attr(0x0024, pack('N', calc_priority('prflx',
|
||||
$local_cand->{preference}, $local_comp->{component}))));
|
||||
unshift(@$attrs, attr(0x0006, "$self->{other_ufrag}:$self->{my_ufrag}"));
|
||||
|
||||
$self->integrity($attrs, 1, $pair->{transaction}, $self->{other_pwd});
|
||||
$self->fingerprint($attrs, 1, $pair->{transaction});
|
||||
|
||||
my $packet = join('', @$attrs);
|
||||
$packet = pack('nnNa12', 1, length($packet), 0x2112A442, $pair->{transaction}) . $packet;
|
||||
$local_comp->{socket}->send($packet, 0, $remote_comp->{packed_peer});
|
||||
}
|
||||
|
||||
# XXX use multiple packages here for candidates, components and pairs
|
||||
|
||||
1;
|
||||
@ -0,0 +1,6 @@
|
||||
package RTP;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
1;
|
||||
@ -0,0 +1,55 @@
|
||||
package Rtpengine;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use IO::Socket::IP;
|
||||
use Bencode;
|
||||
use Data::Dumper;
|
||||
|
||||
sub new {
|
||||
my ($class, $addr, $port) = @_;
|
||||
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
|
||||
if (ref($addr)) {
|
||||
$self->{socket} = $addr;
|
||||
}
|
||||
else {
|
||||
$self->{socket} = IO::Socket::IP->new(Type => SOCK_DGRAM, Proto => 'udp',
|
||||
PeerHost => $addr, PeerPort => $port);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub req {
|
||||
my ($self, $packet) = @_;
|
||||
|
||||
my $cookie = rand() . ' ';
|
||||
my $p = $cookie . Bencode::bencode($packet);
|
||||
$self->{socket}->send($p, 0) or die $!;
|
||||
my $ret;
|
||||
$self->{socket}->recv($ret, 65535) or die $!;
|
||||
$ret =~ s/^\Q$cookie\E//s or die $ret;
|
||||
my $resp = Bencode::bdecode($ret, 1);
|
||||
|
||||
$resp->{result} or die Dumper $resp;
|
||||
|
||||
if ($resp->{result} eq 'error') {
|
||||
die "Error reason: \"$resp->{'error-reason'}\"";
|
||||
}
|
||||
|
||||
return $resp;
|
||||
}
|
||||
|
||||
sub offer {
|
||||
my ($self, $packet) = @_;
|
||||
return $self->req( { %$packet, command => 'offer' } );
|
||||
}
|
||||
sub answer {
|
||||
my ($self, $packet) = @_;
|
||||
return $self->req( { %$packet, command => 'answer' } );
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,221 @@
|
||||
package SDP;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use IO::Socket;
|
||||
use Time::HiRes qw(gettimeofday);
|
||||
|
||||
sub new {
|
||||
my ($class, $origin, $connection) = @_;
|
||||
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
|
||||
$self->{version} = 1;
|
||||
$self->{medias} = [];
|
||||
$self->{origin} = $origin;
|
||||
$self->{connection} = $connection;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub decode {
|
||||
my ($class, $body) = @_;
|
||||
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
|
||||
my $medias = $self->{medias} = [];
|
||||
|
||||
my @lines = split(/\r\n/, $body);
|
||||
|
||||
my ($media, $attr_store);
|
||||
|
||||
for my $line (@lines) {
|
||||
$attr_store = $media ? $media : $self;
|
||||
|
||||
if ($line =~ /^[ost]=/) {
|
||||
# ignore
|
||||
next;
|
||||
}
|
||||
if ($line =~ /^m=(\S+) (\d+) (\S+) (\d+(?: \d+)*)$/s) {
|
||||
$media = $self->add_media(SDP::Media->new_remote($1, $2, $3, $4));
|
||||
next;
|
||||
}
|
||||
if ($line =~ /^c=(.*)$/) {
|
||||
$attr_store->{connection} = decode_address($1);
|
||||
next;
|
||||
}
|
||||
if ($line =~ /^a=(([\w-]+)(?::(.*))?)$/) {
|
||||
my $full = $1;
|
||||
my $name = $2;
|
||||
my $cont = $3;
|
||||
|
||||
push(@{$attr_store->{attributes_list}}, $full);
|
||||
push(@{$attr_store->{attributes_hash}->{$name}}, $cont);
|
||||
}
|
||||
}
|
||||
|
||||
for my $m (@$medias) {
|
||||
$m->decode();
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub add_media {
|
||||
my ($self, $media) = @_;
|
||||
|
||||
push(@{$self->{medias}}, $media);
|
||||
$media->{parent} = $self;
|
||||
|
||||
return $media;
|
||||
}
|
||||
|
||||
sub encode {
|
||||
my ($self) = @_;
|
||||
|
||||
my ($secs, $msecs) = gettimeofday();
|
||||
|
||||
my @out;
|
||||
|
||||
push(@out, 'v=0');
|
||||
push(@out, 'o=- ' . ($secs ^ $msecs) . ' ' . ($self->{version}++) . ' ' . encode_address($self->{origin}));
|
||||
push(@out, 's=tester');
|
||||
$self->{connection} and push(@out, 'c=' . encode_address($self->{connection}));
|
||||
push(@out, 't=0 0');
|
||||
|
||||
for my $m (@{$self->{medias}}) {
|
||||
push(@out, $m->encode($self->{connection}));
|
||||
}
|
||||
|
||||
return join("\r\n", @out) . "\r\n";
|
||||
}
|
||||
|
||||
sub encode_address {
|
||||
my ($sock) = @_;
|
||||
|
||||
my $domain = $sock->sockdomain();
|
||||
my $addr = $sock->sockhost();
|
||||
|
||||
$domain == &AF_INET and return "IN IP4 $addr";
|
||||
$domain == &AF_INET6 and return "IN IP6 $addr";
|
||||
die "$domain $addr";
|
||||
}
|
||||
|
||||
sub decode_address {
|
||||
my ($s) = @_;
|
||||
if ($s =~ /^IN IP4 (\d+\.\d+\.\d+\.\d+)$/s) {
|
||||
return $1;
|
||||
}
|
||||
if ($s =~ /^IN IP6 ([0-9a-fA-F:]+)$/s) {
|
||||
return $1;
|
||||
}
|
||||
die $s;
|
||||
}
|
||||
|
||||
|
||||
package SDP::Media;
|
||||
|
||||
sub new {
|
||||
my ($class, $rtp, $rtcp, $protocol, $type) = @_;
|
||||
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
|
||||
$self->{rtp} = $rtp; # main transport
|
||||
$self->{rtcp} = $rtcp; # optional
|
||||
$self->{protocol} = $protocol // 'RTP/AVP';
|
||||
$self->{type} = $type // 'audio';
|
||||
$self->{payload_types} = [0];
|
||||
|
||||
$self->{additional_attributes} = [];
|
||||
|
||||
return $self;
|
||||
};
|
||||
|
||||
sub new_remote {
|
||||
my ($class, $protocol, $port, $type, $payload_types) = @_;
|
||||
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
|
||||
$self->{protocol} = $protocol;
|
||||
$self->{port} = $port;
|
||||
$self->{type} = $type;
|
||||
$self->{payload_types} = [split(/ /, $payload_types)];
|
||||
|
||||
return $self;
|
||||
};
|
||||
|
||||
sub add_attrs {
|
||||
my ($self, @list) = @_;
|
||||
push(@{$self->{additional_attributes}}, @list);
|
||||
}
|
||||
|
||||
sub encode {
|
||||
my ($self, $parent_connection) = @_;
|
||||
|
||||
my $pconn = $parent_connection ? SDP::encode_address($parent_connection) : '';
|
||||
my @out;
|
||||
|
||||
push(@out, "m=$self->{type} " . $self->{rtp}->sockport() . ' ' . $self->{protocol} . ' '
|
||||
. join(' ', @{$self->{payload_types}}));
|
||||
|
||||
my $rtpconn = SDP::encode_address($self->{rtp});
|
||||
$rtpconn eq $pconn or push(@out, "c=$rtpconn");
|
||||
|
||||
push(@out, 'a=sendrecv');
|
||||
|
||||
if ($self->{rtcp}) {
|
||||
my $rtcpconn = SDP::encode_address($self->{rtcp});
|
||||
push(@out, 'a=rtcp:' . $self->{rtcp}->sockport()
|
||||
. ($rtcpconn eq $rtpconn ? '' : (' ' . SDP::encode_address($self->{rtcp}))));
|
||||
}
|
||||
|
||||
push(@out, @{$self->{additional_attributes}});
|
||||
|
||||
return @out;
|
||||
}
|
||||
|
||||
sub decode {
|
||||
my ($self) = @_;
|
||||
|
||||
my $attrs = $self->{attributes_hash};
|
||||
|
||||
if ($attrs->{rtcp}) {
|
||||
my $a = $attrs->{rtcp}->[0];
|
||||
$a =~ /^(\d+)(?: (IN .*))?$/ or die $a;
|
||||
$self->{rtcp_port} = $1;
|
||||
$2 and $self->{rtcp_connection} = decode_address($2);
|
||||
}
|
||||
}
|
||||
|
||||
sub connection {
|
||||
my ($self) = @_;
|
||||
$self->{connection} and return $self->{connection};
|
||||
return $self->{parent}->{connection};
|
||||
}
|
||||
|
||||
sub rtcp_port {
|
||||
my ($self) = @_;
|
||||
$self->{rtcp_port} and return $self->{rtcp_port};
|
||||
return $self->{port} + 1;
|
||||
}
|
||||
|
||||
sub rtcp_connection {
|
||||
my ($self) = @_;
|
||||
$self->{rtcp_connection} and return $self->{rtcp_connection};
|
||||
return $self->connection();
|
||||
}
|
||||
|
||||
sub decode_ice {
|
||||
my ($self) = @_;
|
||||
my $ret = {};
|
||||
$ret->{ufrag} = $self->{attributes_hash}->{'ice-ufrag'}->[0];
|
||||
$ret->{pwd} = $self->{attributes_hash}->{'ice-pwd'}->[0];
|
||||
$ret->{candidates} = $self->{attributes_hash}->{'candidate'};
|
||||
return $ret;
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,184 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use DTLS;
|
||||
use ICE;
|
||||
use RTP;
|
||||
use SDP;
|
||||
use Rtpengine;
|
||||
use IO::Socket::IP;
|
||||
use IO::Multiplex;
|
||||
use Time::HiRes qw(time);
|
||||
|
||||
my $mux = IO::Multiplex->new();
|
||||
$mux->set_callback_object(__PACKAGE__);
|
||||
|
||||
# create local sockets for A and B sides
|
||||
|
||||
my @A_interfaces = qw(
|
||||
192.168.1.90
|
||||
10.10.8.18
|
||||
2001:470:1d:76c:feaa:14ff:fe97:be6b
|
||||
fdd5:725c:61d7:0:feaa:14ff:fe97:be6b
|
||||
2a02:1b8:7:1:9847:efff:fe2e:f17d
|
||||
);
|
||||
my @B_interfaces = @A_interfaces;
|
||||
|
||||
@A_interfaces = sort {rand() <=> rand()} @A_interfaces;
|
||||
@B_interfaces = sort {rand() <=> rand()} @B_interfaces;
|
||||
|
||||
my $sport = 2000;
|
||||
|
||||
my (@A_sockets, @B_sockets);
|
||||
|
||||
for my $a (@A_interfaces) {
|
||||
my $rtp = IO::Socket::IP->new(Type => SOCK_DGRAM, Proto => 'udp',
|
||||
LocalHost => $a, LocalPort => $sport++) or die($a);
|
||||
my $rtcp = IO::Socket::IP->new(Type => SOCK_DGRAM, Proto => 'udp',
|
||||
LocalHost => $a, LocalPort => $sport++) or die($a);
|
||||
print("local interface side A: " . $rtp->sockhost() . '/' . $rtp->sockport() . '/'
|
||||
. $rtcp->sockport() . "\n");
|
||||
push(@A_sockets, [$rtp, $rtcp]);
|
||||
$mux->add($rtp);
|
||||
$mux->add($rtcp);
|
||||
$mux->set_timeout($rtp, 0.01);
|
||||
}
|
||||
|
||||
print("-\n");
|
||||
|
||||
for my $a (@B_interfaces) {
|
||||
my $rtp = IO::Socket::IP->new(Type => SOCK_DGRAM, Proto => 'udp',
|
||||
LocalHost => $a, LocalPort => $sport++) or die($a);
|
||||
my $rtcp = IO::Socket::IP->new(Type => SOCK_DGRAM, Proto => 'udp',
|
||||
LocalHost => $a, LocalPort => $sport++) or die($a);
|
||||
print("local interface side B: " . $rtp->sockhost() . '/' . $rtp->sockport() . '/'
|
||||
. $rtcp->sockport() . "\n");
|
||||
push(@B_sockets, [$rtp, $rtcp]);
|
||||
$mux->add($rtp);
|
||||
$mux->add($rtcp);
|
||||
$mux->set_timeout($rtp, 0.01);
|
||||
}
|
||||
|
||||
# create outgoing SDP for side A
|
||||
|
||||
my $A_main = $A_sockets[0]; # for o= and m= line details
|
||||
my $A_local_sdp = SDP->new($A_main->[0]); # no global connection given
|
||||
|
||||
# rtp and rtcp, everything else default
|
||||
my $A_local_media = $A_local_sdp->add_media(SDP::Media->new($A_main->[0], $A_main->[1]));
|
||||
|
||||
# create side A ICE agent
|
||||
|
||||
my $A_ice = ICE->new(2, 1); # 2 components, controlling
|
||||
my $pref = 65535;
|
||||
for my $s (@A_sockets) {
|
||||
$A_ice->add_candidate($pref--, 'host', @$s); # 2 components
|
||||
}
|
||||
|
||||
$A_local_media->add_attrs($A_ice->encode());
|
||||
|
||||
# send side A SDP to rtpengine
|
||||
|
||||
my $A_local_sdp_body = $A_local_sdp->encode();
|
||||
# XXX validate SDP
|
||||
|
||||
my $rtpengine = Rtpengine->new('localhost', 2223);
|
||||
|
||||
my $callid = rand();
|
||||
my $fromtag = rand();
|
||||
my $totag = rand();
|
||||
|
||||
print("doing rtpengine offer\n");
|
||||
my $offer_sent = time();
|
||||
my $A_offer = { command => 'offer', ICE => 'force', 'call-id' => $callid, 'from-tag' => $fromtag,
|
||||
sdp => $A_local_sdp_body };
|
||||
|
||||
my $B_offer = $rtpengine->req($A_offer);
|
||||
my $offer_done = time();
|
||||
|
||||
# decode incoming SDP for side B
|
||||
|
||||
my $B_remote_sdp_body = $B_offer->{sdp};
|
||||
my $B_remote_sdp = SDP->decode($B_remote_sdp_body);
|
||||
# XXX validate SDP
|
||||
@{$B_remote_sdp->{medias}} == 1 or die;
|
||||
my $B_remote_media = $B_remote_sdp->{medias}->[0];
|
||||
|
||||
# create side B ICE agent
|
||||
|
||||
my $B_ice = ICE->new(2, 0); # 2 components, controlled
|
||||
$pref = 65535;
|
||||
for my $s (@B_sockets) {
|
||||
$B_ice->add_candidate($pref--, 'host', @$s); # 2 components
|
||||
}
|
||||
|
||||
# add remote ICE infos for side B
|
||||
|
||||
$B_ice->decode($B_remote_media->decode_ice());
|
||||
|
||||
# run the machine and simulate delayed answer
|
||||
|
||||
my $do_answer = time() + 3;
|
||||
|
||||
$mux->loop();
|
||||
|
||||
|
||||
|
||||
sub mux_input {
|
||||
my ($self, $mux, $fh, $input) = @_;
|
||||
my $peer = $mux->udp_peer($fh);
|
||||
$A_ice->input($fh, $input, $peer);
|
||||
$B_ice->input($fh, $input, $peer);
|
||||
}
|
||||
|
||||
sub mux_timeout {
|
||||
my ($self, $mux, $fh) = @_;
|
||||
|
||||
$A_ice->timer();
|
||||
$B_ice->timer();
|
||||
|
||||
if ($do_answer && time() >= $do_answer) {
|
||||
do_answer();
|
||||
}
|
||||
|
||||
$mux->set_timeout($fh, 0.01);
|
||||
}
|
||||
|
||||
sub do_answer {
|
||||
$do_answer = 0;
|
||||
|
||||
# create answer from B to A
|
||||
|
||||
my $B_main = $B_sockets[0]; # for o= and m= line details
|
||||
my $B_local_sdp = SDP->new($B_main->[0]); # no global connection given
|
||||
|
||||
# rtp and rtcp, everything else default
|
||||
my $B_local_media = $B_local_sdp->add_media(SDP::Media->new($B_main->[0], $B_main->[1]));
|
||||
|
||||
$B_local_media->add_attrs($B_ice->encode());
|
||||
|
||||
# send side A SDP to rtpengine
|
||||
my $B_local_sdp_body = $B_local_sdp->encode();
|
||||
# XXX validate SDP
|
||||
|
||||
my $B_answer = { command => 'answer', ICE => 'force', 'call-id' => $callid, 'from-tag' => $fromtag,
|
||||
'to-tag' => $totag, sdp => $B_local_sdp_body };
|
||||
|
||||
print("doing rtpengine answer\n");
|
||||
my $A_answer = $rtpengine->req($B_answer);
|
||||
|
||||
# decode incoming SDP for side A
|
||||
|
||||
my $A_remote_sdp_body = $A_answer->{sdp};
|
||||
my $A_remote_sdp = SDP->decode($A_remote_sdp_body);
|
||||
# XXX validate SDP
|
||||
@{$A_remote_sdp->{medias}} == 1 or die;
|
||||
my $A_remote_media = $A_remote_sdp->{medias}->[0];
|
||||
|
||||
# add remote ICE infos for side B
|
||||
|
||||
$A_ice->decode($A_remote_media->decode_ice());
|
||||
|
||||
# return to IO handler loop
|
||||
}
|
||||
Loading…
Reference in new issue