diff --git a/tests/simulator-ng.pl b/tests/simulator-ng.pl new file mode 100755 index 000000000..de80959ce --- /dev/null +++ b/tests/simulator-ng.pl @@ -0,0 +1,237 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use Socket; +use UUID; +use BSD::Resource; +use Getopt::Long; +use Socket6; +use Bencode qw( bencode bdecode ); + +my ($NUM, $RUNTIME) = (1000, 30); +my ($NODEL, $IP, $IPV6, $KEEPGOING, $REINVITES, $BRANCHES); +GetOptions( + 'no-delete' => \$NODEL, + 'num-calls=i' => \$NUM, + 'local-ip=s' => \$IP, + 'local-ipv6=s' => \$IPV6, + 'runtime=i' => \$RUNTIME, + 'keep-going' => \$KEEPGOING, # don't stop sending rtp if a packet doesn't go through + 'reinvites' => \$REINVITES, + 'branches' => \$BRANCHES, +) or die; + +($IP || $IPV6) or die("at least one of --local-ip or --local-ipv6 must be given"); + +$SIG{ALRM} = sub { print "alarm!\n"; }; +setrlimit(RLIMIT_NOFILE, 8000, 8000); + +my @chrs = ('a' .. 'z', 'A' .. 'Z', '0' .. '9'); +sub rand_str { + my ($len) = @_; + return join('', (map {$chrs[rand(@chrs)]} (1 .. $len))); +} + +my $fd; +sub msg { + my ($d) = @_; + my $l = bencode($d); + my $cookie = $$ . '_' . rand_str(10); + my $r; + while (1) { + send($fd, "$cookie $l", 0) or die $!; + my $err = ''; + alarm(1); + recv($fd, $r, 0xffff, 0) or $err = "$!"; + alarm(0); + $err =~ /interrupt/i and next; + $err and die $err; + last; + } + $r =~ s/^\Q$cookie\E +//s or die $r; + $r =~ s/[\r\n]+$//s; + return $r ? bdecode($r, 1) : undef; +} + +socket($fd, AF_INET, SOCK_DGRAM, 0) or die $!; +connect($fd, sockaddr_in(2223, inet_aton("127.0.0.1"))) or die $!; + +msg({command => 'ping'})->{result} eq 'pong' or die; + +my (@calls, %branches); + +sub do_rtp { + print("sending rtp\n"); + for my $c (@calls) { + $c or next; + my ($fds,$outputs,$protos) = @$c[0,4,6]; + for my $i ([0,1],[1,0]) { + my ($a, $b) = @$i; + my $pr = $$protos[$a]; + my $payload = rand_str(100); + send($$fds[$a], $payload, 0, $$pr{sockaddr}($$outputs[$b][0], + inet_pton($$pr{family}, $$outputs[$b][1]))) or die $!; + my $x; + my $err = ''; + alarm(1); + recv($$fds[$b], $x, 0xffff, 0) or $err = "$!"; + alarm(0); + $err && $err !~ /interrupt/i and die $err; + if (($x || '') ne $payload) { + warn("no rtp reply received, ports $$outputs[$b][0] and $$outputs[$a][0]"); + $KEEPGOING or undef($c); + } + } + } +} + +my %proto_defs = ( + ipv4 => { + code => 'I', + family => AF_INET, + reply => '4', + address => $IP, + sockaddr => \&sockaddr_in, + family_str => 'IP4', + direction => 'internal', + }, + ipv6 => { + code => 'E', + family => AF_INET6, + reply => '6', + address => $IPV6, + sockaddr => \&sockaddr_in6, + family_str => 'IP6', + direction => 'external', + }, +); +my @protos_avail; +$IP and push(@protos_avail, $proto_defs{ipv4}); +$IPV6 and push(@protos_avail, $proto_defs{ipv6}); +my @sides = qw(A B); + +sub callid { + my $i = rand_str(50); + $BRANCHES or return [$i]; + rand() < .5 and return [$i]; + if (rand() < .5) { + my @k = keys(%branches); + @k and $i = $k[rand(@k)]; + } + my $b = rand_str(20); + push(@{$branches{$i}}, $b); + return [$i, $b]; +} + +sub update_lookup { + my ($c, $i) = @_; + my $j = $i ^ 1; + + my $c_v = $$c[5] || ($$c[5] = callid()); + my ($callid, $viabranch) = @$c_v; + + my $protos = $$c[6] || ($$c[6] = []); + my $fds = $$c[0] || ($$c[0] = []); + for my $x (0,1) { + $$protos[$x] and next; + $$protos[$x] = $protos_avail[rand(@protos_avail)]; + undef($$fds[$x]); + } + my ($pr, $pr_o) = @$protos[$i, $j]; + my @commands = qw(offer answer); + + my $ports = $$c[1] || ($$c[1] = []); + my $ips = $$c[2] || ($$c[2] = []); + if (!$$fds[$i]) { + socket($$fds[$i], $$pr{family}, SOCK_DGRAM, 0) or die $!; + while (1) { + my $port = rand(0x7000) << 1 + 1024; + bind($$fds[$i], $$pr{sockaddr}($port, + inet_pton($$pr{family}, $$pr{address}))) and last; + } + my $addr = getsockname($$fds[$i]); + my $ip; + ($$ports[$i], $ip) = $$pr{sockaddr}($addr); + $$ips[$i] = inet_ntop($$pr{family}, $ip); + } + + my $tags = $$c[3] || ($$c[3] = []); + $$tags[$i] or $$tags[$i] = rand_str(15); + + my $sdp = <<"!"; +v=0 +o=blah 123 123 IN $$pr{family_str} $$ips[$i] +s=session +c=IN $$pr{family_str} $$ips[$i] +t=0 0 +m=audio $$ports[$i] RTP/AVP 8 +a=rtpmap:8 PCMA/8000 +! + + my $dict = {sdp => $sdp, command => $commands[$i], 'call-id' => $callid, + 'from-tag' => $$tags[0], + flags => [ qw( trust-address ) ], + replace => [ qw( origin session-connection ) ], + direction => [ $$pr{direction}, $$pr_o{direction} ], + 'received-from' => [ qw(IP4 127.0.0.1) ], + }; + $viabranch and $dict->{'via-branch'} = $viabranch; + $i == 1 and $dict->{'to-tag'} = $$tags[1]; + + my $o = msg($dict); + $$o{result} eq 'ok' or die; + my ($rp_af, $rp_add, $rp_port) = $$o{sdp} =~ /c=IN IP([46]) (\S+).*m=audio (\d+)/s or die; + $rp_port == 0 and die "mediaproxy ran out of ports"; + $rp_af ne $$pr_o{reply} and die "incorrect address family reply code"; + $$c[4][$i] = [$rp_port,$rp_add]; +} + +for my $iter (1 .. $NUM) { + ($iter % 10 == 0) and print("$iter\n"), do_rtp(); + + my $c = []; + update_lookup($c, 0); + update_lookup($c, 1); + push(@calls, $c); +} + +my $end = time() + $RUNTIME; +while (time() < $end) { + sleep(1); + do_rtp(); + + @calls = sort {rand() < .5} grep(defined, @calls); + + if ($REINVITES) { + my $c = $calls[rand(@calls)]; + print("simulating re-invite on $$c[5][0]"); + for my $i (0,1) { + if (rand() < .5) { + print(", side $sides[$i]: new port"); + undef($$c[0][$i]); + } + else { + print(", side $sides[$i]: same port"); + } + } + print("\n"); + update_lookup($c, 0); + update_lookup($c, 1); + } +} + +if (!$NODEL) { + print("deleting\n"); + for my $c (@calls) { + $c or next; + my ($tags, $c_v) = @$c[3,5]; + my ($callid, $viabranch) = @$c_v; + my $dict = { command => 'delete', 'call-id' => $callid, 'from-tag' => $$tags[0], + 'to-tag' => $$tags[1], + }; + $BRANCHES && rand() < .7 and $$dict{'via-branch'} = $viabranch; + msg($dict); + } +} +print("done\n");