Add IS2 messaging test, works now when filters are implemented
This commit is contained in:
Heikki Hannikainen
parent
1714b70911
commit
f9c6b77aa1
|
|
@ -325,6 +325,21 @@ sub getline_noncomment($;$)
|
|||
}
|
||||
}
|
||||
|
||||
sub send_packet($$)
|
||||
{
|
||||
my($self, $line) = @_;
|
||||
|
||||
return $self->sendline($line);
|
||||
}
|
||||
|
||||
|
||||
sub get_packet($;$)
|
||||
{
|
||||
my($self, $timeout) = @_;
|
||||
|
||||
return $self->getline_noncomment($timeout);
|
||||
}
|
||||
|
||||
sub sendline($$;$$)
|
||||
{
|
||||
my($self, $line, $raw, $noflush) = @_;
|
||||
|
|
|
|||
|
|
@ -61,6 +61,7 @@ sub new($$$;%)
|
|||
$self->{'error'} = "No errors yet.";
|
||||
$self->{'loginstate'} = 'init';
|
||||
|
||||
$self->{'pqueue_in'} = [];
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
|
@ -246,6 +247,10 @@ sub connect($;%)
|
|||
return 0;
|
||||
}
|
||||
|
||||
if (defined $self->{'filter'}) {
|
||||
return $self->set_filter($self->{'filter'});
|
||||
}
|
||||
|
||||
return 1;
|
||||
} else {
|
||||
$self->{'error'} = "Wrong type of response received for LOGIN_REPLY: " . $l->type;
|
||||
|
|
@ -284,6 +289,12 @@ sub send_packets($$)
|
|||
$self->{'sock'}->blocking(0);
|
||||
}
|
||||
|
||||
sub send_packet($)
|
||||
{
|
||||
my($self, $packet) = @_;
|
||||
$self->send_packets([$packet]);
|
||||
}
|
||||
|
||||
sub get_packets($;$)
|
||||
{
|
||||
my($self, $timeout) = @_;
|
||||
|
|
@ -311,17 +322,55 @@ sub get_packets($;$)
|
|||
|
||||
return @pa;
|
||||
} else {
|
||||
$self->{'error'} = "Wrong type of response received for LOGIN_REPLY: " . $l->type;
|
||||
return 0;
|
||||
$self->{'error'} = "Wrong type of frame received: " . $l->type;
|
||||
return undef;
|
||||
}
|
||||
|
||||
if (time() - $t > $timeout) {
|
||||
$self->{'error'} = "Login command timed out";
|
||||
return 0;
|
||||
$self->{'error'} = "get_packets timed out";
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub get_packet($;$)
|
||||
{
|
||||
my($self, $timeout) = @_;
|
||||
|
||||
if (@{ $self->{'pqueue_in'} }) {
|
||||
return shift @{ $self->{'pqueue_in'} };
|
||||
}
|
||||
|
||||
my @p = $self->get_packets($timeout);
|
||||
|
||||
if (@p) {
|
||||
my $r = shift @p;
|
||||
$self->{'pqueue_in'} = \@p;
|
||||
return $r;
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub set_filter($$)
|
||||
{
|
||||
my($self, $filter) = @_;
|
||||
|
||||
my $im = IS2Message->new({
|
||||
'type' => IS2Message::Type::PARAMETER(),
|
||||
'parameter' => IS2Parameter->new({
|
||||
'type' => IS2Parameter::Type::PARAMETER_SET(),
|
||||
'request_id' => 1, # todo: sequential
|
||||
'filter_string' => $filter
|
||||
})
|
||||
});
|
||||
|
||||
$self->{'sock'}->blocking(1);
|
||||
$self->is2_frame_out($im->encode);
|
||||
$self->{'sock'}->blocking(0);
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub is2_frame_out($$)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -132,7 +132,14 @@ sub sendline($$)
|
|||
{
|
||||
my($self, $line) = @_;
|
||||
|
||||
#warn "udp sendline: $line\n";
|
||||
$self->send_packet($line);
|
||||
}
|
||||
|
||||
sub send_packet($$)
|
||||
{
|
||||
my($self, $line) = @_;
|
||||
|
||||
#warn "udp send_packet: $line\n";
|
||||
|
||||
return undef if ($self->{'state'} ne 'connected');
|
||||
|
||||
|
|
@ -143,5 +150,4 @@ sub sendline($$)
|
|||
return 1;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ sub txrx($$$$$)
|
|||
my($ok, $i_tx, $i_rx, $tx, $rx) = @_;
|
||||
|
||||
warn "sending: $tx\n" if ($debug);
|
||||
my $sent = $i_tx->sendline($tx);
|
||||
my $sent = $i_tx->send_packet($tx);
|
||||
|
||||
warn "sent\n" if ($debug);
|
||||
|
||||
|
|
@ -34,7 +34,7 @@ sub txrx($$$$$)
|
|||
|
||||
warn "receiving\n" if ($debug);
|
||||
|
||||
my $received = $i_rx->getline_noncomment();
|
||||
my $received = $i_rx->get_packet();
|
||||
|
||||
if (!defined $received) {
|
||||
if ($i_rx->{'state'} eq 'connected') {
|
||||
|
|
@ -63,7 +63,7 @@ sub should_drop($$$$$;$$)
|
|||
$drop_key .= ' drop.' . int(rand(1000000)) if (!$no_random_drop);
|
||||
my $tx_drop = $tx . $drop_key;
|
||||
warn "sending for drop: $tx_drop\n" if ($debug);
|
||||
my $sent = $i_tx->sendline($tx_drop);
|
||||
my $sent = $i_tx->send_packet($tx_drop);
|
||||
|
||||
if (!$sent) {
|
||||
&$ok($sent, 1, "Failed to send line to server: '$tx'");
|
||||
|
|
@ -74,14 +74,14 @@ sub should_drop($$$$$;$$)
|
|||
my $helper_l = $helper;
|
||||
$helper_l .= ' ' . $helper_key if (!$no_random_helper);
|
||||
warn "sending for pass: $helper_l\n" if ($debug);
|
||||
$sent = $i_tx->sendline($helper_l);
|
||||
$sent = $i_tx->send_packet($helper_l);
|
||||
|
||||
if (!$sent) {
|
||||
&$ok($sent, 1, "Failed to send helper line to server: '$helper_l'");
|
||||
return;
|
||||
}
|
||||
|
||||
my $received = $i_rx->getline_noncomment();
|
||||
my $received = $i_rx->get_packet();
|
||||
|
||||
if (!defined $received) {
|
||||
if ($i_rx->{'state'} eq 'connected') {
|
||||
|
|
@ -129,7 +129,7 @@ sub should_drop($$$$$;$$)
|
|||
}
|
||||
|
||||
# since we received an extra packet, get one more line to receive the helper
|
||||
$i_rx->getline_noncomment();
|
||||
$i_rx->get_packet();
|
||||
}
|
||||
|
||||
sub read_and_disconnect($)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,237 @@
|
|||
|
||||
#
|
||||
# Test messaging features:
|
||||
#
|
||||
# On a filtered igate port (14580), no messages should come out at first.
|
||||
# When a position of a station has been heard, messages for that station
|
||||
# should come out.
|
||||
# After such a message, the next following position transmitted within
|
||||
# 30 minutes by the originator should be passed to the recipient's socket, too.
|
||||
#
|
||||
# Messages transmitted to any SSID must be passed?
|
||||
#
|
||||
# Are messages transmitted to objects passed, too? No.
|
||||
#
|
||||
# When a position has been heard, positions for the same callsign-ssid
|
||||
# from other igates should come out too, to assist TX igates to know
|
||||
# the station is on the Internet.
|
||||
#
|
||||
|
||||
use Test;
|
||||
BEGIN { plan tests => 8 + 9 + 1 + 2 + 3 + 2 + 6 + 4 + 1 };
|
||||
use runproduct;
|
||||
use istest;
|
||||
use Ham::APRS::IS2;
|
||||
use Encode;
|
||||
use utf8;
|
||||
|
||||
my $enc_utf8 = find_encoding("UTF-8") || die "Could not load encoding UTF-8"; # note: strict UTF-8
|
||||
|
||||
ok(1); # If we made it this far, we're ok.
|
||||
|
||||
my $p = new runproduct('is2-basic');
|
||||
|
||||
ok(defined $p, 1, "Failed to initialize product runner");
|
||||
ok($p->start(), 1, "Failed to start product");
|
||||
|
||||
my $server_call = "TESTING";
|
||||
|
||||
my $login_tx = "N0GATE";
|
||||
my $i_tx = new Ham::APRS::IS2("localhost:56580", $login_tx,
|
||||
'filter' => 'r/60.4752/25.0947/1');
|
||||
ok(defined $i_tx, 1, "Failed to initialize Ham::APRS::IS2");
|
||||
|
||||
# We set a filter on the rx so that the helper packets get through
|
||||
my $login_rx = "N1GATE";
|
||||
my $i_rx = new Ham::APRS::IS2("localhost:56580", $login_rx,
|
||||
'filter' => 'r/60.4752/25.0947/1');
|
||||
ok(defined $i_rx, 1, "Failed to initialize Ham::APRS::IS2");
|
||||
|
||||
my $ret;
|
||||
$ret = $i_tx->connect('retryuntil' => 8);
|
||||
ok($ret, 1, "Failed to connect to the server: " . $i_tx->{'error'});
|
||||
|
||||
$ret = $i_rx->connect('retryuntil' => 8);
|
||||
ok($ret, 1, "Failed to connect to the server: " . $i_rx->{'error'});
|
||||
|
||||
# do the actual tests
|
||||
|
||||
my $msg_src = "M1SRC";
|
||||
my $msg_dst = "M1DST";
|
||||
my($tx, $rx, $helper);
|
||||
|
||||
# 8. first, verify that a message packet is not passed to a filtered port
|
||||
$tx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,$login_tx,I::%-9.9s:message", $msg_dst);
|
||||
$helper = "H1LP>APRS,OH2RDG*,WIDE:!6028.51N/02505.68E# should pass";
|
||||
istest::should_drop(\&ok, $i_tx, $i_rx, $tx, $helper);
|
||||
|
||||
# 9. verify that a position packet from the message originator is not passed
|
||||
# to a filtered port
|
||||
$tx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,$login_tx,I:!6428.51N/02545.98E#");
|
||||
$helper = "H1LP-5>APRS,OH2RDG*,WIDE:!6028.51N/02505.68E# should pass";
|
||||
istest::should_drop(\&ok, $i_tx, $i_rx, $tx, $helper);
|
||||
|
||||
# now, transmit a position packet on the receiving filtered port
|
||||
$tx = "$msg_dst-2>APRS,OH2RDG*,WIDE,$login_rx,I:!6028.51N/02505.68E# should pass";
|
||||
$rx = "$msg_dst-2>APRS,OH2RDG*,WIDE,qAR,$login_rx:!6028.51N/02505.68E# should pass";
|
||||
istest::txrx(\&ok, $i_rx, $i_tx, $tx, $rx);
|
||||
|
||||
sleep(1);
|
||||
|
||||
# now, transmit a position packet on the receiving filtered port
|
||||
$tx = "$msg_dst>APRS,OH2RDG*,WIDE,$login_rx,I:!6028.51N/02505.68E# should pass";
|
||||
$rx = "$msg_dst>APRS,OH2RDG*,WIDE,qAR,$login_rx:!6028.51N/02505.68E# should pass";
|
||||
istest::txrx(\&ok, $i_rx, $i_tx, $tx, $rx);
|
||||
|
||||
# now, transmit a position packet on the receiving filtered port
|
||||
$tx = "$msg_dst-3>APRS,OH2RDG*,WIDE,$login_rx,I:!6028.51N/02505.68E# should pass";
|
||||
$rx = "$msg_dst-3>APRS,OH2RDG*,WIDE,qAR,$login_rx:!6028.51N/02505.68E# should pass";
|
||||
istest::txrx(\&ok, $i_rx, $i_tx, $tx, $rx);
|
||||
|
||||
# then, a message packet should magically pass!
|
||||
$tx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,%s,I::%-9.9s:message{123", $login_tx, $msg_dst);
|
||||
$rx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,qAR,%s::%-9.9s:message{123", $login_tx, $msg_dst);
|
||||
istest::txrx(\&ok, $i_tx, $i_rx, $tx, $rx);
|
||||
|
||||
# and, its ACK packet should pass, too...
|
||||
$tx = sprintf("$msg_dst>APRS,OH2RDG*,WIDE,%s,I::%-9.9s:ack123", $login_rx, $login_tx);
|
||||
$rx = sprintf("$msg_dst>APRS,OH2RDG*,WIDE,qAR,%s::%-9.9s:ack123", $login_rx, $login_tx);
|
||||
istest::txrx(\&ok, $i_rx, $i_tx, $tx, $rx);
|
||||
|
||||
# Another message! With UTF-8 content.
|
||||
$tx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,%s,I::%-9.9s:Blää blåå 日本語{1d", $login_tx, $msg_dst);
|
||||
$rx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,qAR,%s::%-9.9s:Blää blåå 日本語{1d", $login_tx, $msg_dst);
|
||||
$tx = $enc_utf8->encode($tx);
|
||||
$rx = $enc_utf8->encode($rx);
|
||||
istest::txrx(\&ok, $i_tx, $i_rx, $tx, $rx);
|
||||
|
||||
# Another message! With high-value binary content.
|
||||
$tx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,qAR,%s::%-9.9s:binary ", $login_tx, $msg_dst);
|
||||
for (my $d = 127; $d <= 255; $d++) {
|
||||
$tx .= chr($d);
|
||||
}
|
||||
$rx = $tx;
|
||||
istest::txrx(\&ok, $i_tx, $i_rx, $tx, $rx);
|
||||
|
||||
# Also, it should pass to another SSID!
|
||||
# NO, javaprssrvr does not pass this.
|
||||
$tx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,%s,I::%-9.9s:message with SSID{a", $login_tx, $msg_dst . '-5');
|
||||
#$rx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,qAR,%s::%-9.9s:message with SSID{a", $login_tx, $msg_dst . '-5');
|
||||
#istest::txrx(\&ok, $i_tx, $i_rx, $tx, $rx);
|
||||
$helper = "H1LP>APRS,OH2RDG*,WIDE:!6028.51N/02505.68E# should pass5";
|
||||
istest::should_drop(\&ok, $i_tx, $i_rx, $tx, $helper);
|
||||
|
||||
# now, after a message has been transmitted, the complimentary position should pass
|
||||
$tx = "$msg_src>APRS,OH2RDG*,WIDE,$login_tx,I:!5528.51N/00505.68E# should pass compl";
|
||||
$rx = "$msg_src>APRS,OH2RDG*,WIDE,qAR,$login_tx:!5528.51N/00505.68E# should pass compl";
|
||||
istest::txrx(\&ok, $i_tx, $i_rx, $tx, $rx);
|
||||
|
||||
# try a second complimentary position - it must be dropped.
|
||||
$tx = "$msg_src>APRS,OH2RDG*,WIDE,$login_tx,I:!5628.51N/00505.68E# should drop compl2";
|
||||
$helper = "H1LP-C>APRS,OH2RDG*,WIDE:!6028.51N/02505.68E# should pass";
|
||||
istest::should_drop(\&ok, $i_tx, $i_rx, $tx, $helper);
|
||||
|
||||
# A position packet having TCPIP* in the path, coming from another connection,
|
||||
# should be passed to the port where the station was heard without TCPIP*.
|
||||
# "This is so the IGate can determine if there is a station it is hearing
|
||||
# on RF is also directly connected to APRS-IS. If the RF station is heard
|
||||
# directly on APRS-IS, the IGate should NOT gate messages for that station
|
||||
# to RF." (Pete Loveall, 17 May 2012, APRSSIG)
|
||||
|
||||
$rx = $tx = "$msg_src>APRS,TCPIP*,qAC,$msg_src:!5528.51N/00505.68E# should pass TCPIP*";
|
||||
istest::txrx(\&ok, $i_rx, $i_tx, $tx, $rx);
|
||||
|
||||
#
|
||||
# Message to the client's callsign
|
||||
#
|
||||
|
||||
$tx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,%s,I::%-9.9s:message", $login_tx, $login_rx);
|
||||
$rx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,qAR,%s::%-9.9s:message", $login_tx, $login_rx);
|
||||
istest::txrx(\&ok, $i_tx, $i_rx, $tx, $rx);
|
||||
|
||||
# with a different SSID
|
||||
$tx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,%s,I::%-9.9s:message with ssid", $login_tx, $login_rx . "-9");
|
||||
$rx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,qAR,%s::%-9.9s:message with ssid", $login_tx, $login_rx. "-9");
|
||||
$helper = "H1LP>APRS,OH2RDG*,WIDE:!6028.51N/02505.68E# should pass diff ssid";
|
||||
istest::should_drop(\&ok, $i_tx, $i_rx, $tx, $helper);
|
||||
|
||||
#
|
||||
# Message to an OBJECT
|
||||
#
|
||||
|
||||
my $msg_obj = 'OBJDST';
|
||||
# transmit the object on the receiving filtered port
|
||||
$tx = sprintf("$msg_dst>APRS,OH2RDG*,WIDE,$login_rx,I:;%-9.9s*111111z6028.51N/02505.68Ercomment", $msg_obj);
|
||||
$rx = sprintf("$msg_dst>APRS,OH2RDG*,WIDE,qAR,$login_rx:;%-9.9s*111111z6028.51N/02505.68Ercomment", $msg_obj);
|
||||
istest::txrx(\&ok, $i_rx, $i_tx, $tx, $rx);
|
||||
|
||||
# no, it should not pass at the moment
|
||||
$tx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,%s,I::%-9.9s:message to object", $login_tx, $msg_obj);
|
||||
#$rx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,qAR,%s::%-9.9s:message to object", $login_tx, $msg_obj);
|
||||
#istest::txrx(\&ok, $i_tx, $i_rx, $tx, $rx);
|
||||
$helper = "H1LP>APRS,OH2RDG*,WIDE:!6028.51N/02505.68E# should pass6";
|
||||
istest::should_drop(\&ok, $i_tx, $i_rx, $tx, $helper);
|
||||
|
||||
#
|
||||
# Message to an ITEM
|
||||
#
|
||||
|
||||
my $msg_item = 'ITEDST';
|
||||
# transmit the item on the receiving filtered port
|
||||
$tx = sprintf("$msg_dst>APRS,OH2RDG*,WIDE,$login_rx,I:)%s!6028.51N/02505.68Ercomment", $msg_item);
|
||||
$rx = sprintf("$msg_dst>APRS,OH2RDG*,WIDE,qAR,$login_rx:)%s!6028.51N/02505.68Ercomment", $msg_item);
|
||||
istest::txrx(\&ok, $i_rx, $i_tx, $tx, $rx);
|
||||
|
||||
# no, it should not pass at the moment
|
||||
$tx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,%s,I::%-9.9s:message to item", $login_tx, $msg_item);
|
||||
#$rx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,qAR,%s::%-9.9s:message to item", $login_tx, $msg_item);
|
||||
#istest::txrx(\&ok, $i_tx, $i_rx, $tx, $rx);
|
||||
$helper = "H1LP>APRS,OH2RDG*,WIDE:!6028.51N/02505.68E# should pass7";
|
||||
istest::should_drop(\&ok, $i_tx, $i_rx, $tx, $helper);
|
||||
|
||||
#
|
||||
# Connect another igate and see what happens when there are
|
||||
# two gates hearing the same station!
|
||||
#
|
||||
|
||||
# We set a filter on the rx so that the helper packets get through
|
||||
my $login_rx2 = "N2GATE";
|
||||
my $i_rx2 = new Ham::APRS::IS2("localhost:56580", $login_rx2,
|
||||
'filter' => 'r/60.4752/25.0947/1');
|
||||
ok(defined $i_rx2, 1, "Failed to initialize Ham::APRS::IS");
|
||||
|
||||
$ret = $i_rx2->connect('retryuntil' => 8);
|
||||
ok($ret, 1, "Failed to connect to the server: " . $i_rx2->{'error'});
|
||||
|
||||
# Now, transmit a position packet on the second receiving filtered port.
|
||||
# It will come out on the first receiving filtered port due to the
|
||||
# range filter *and* due to it being heard there, too.
|
||||
$tx = "$msg_dst>APRS,OH2RDG*,WIDE,$login_rx,I:!6028.51N/02505.68E# should pass 2nd";
|
||||
$rx = "$msg_dst>APRS,OH2RDG*,WIDE,qAr,$login_rx:!6028.51N/02505.68E# should pass 2nd";
|
||||
istest::txrx(\&ok, $i_rx2, $i_tx, $tx, $rx);
|
||||
my $read1 = $i_rx->get_packet(1);
|
||||
ok($read1, $rx, "Got wrong line from first rx port");
|
||||
|
||||
# then, a message packet should magically pass! To both!
|
||||
$tx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,%s,I::%-9.9s:two gates", $login_tx, $msg_dst);
|
||||
$rx = sprintf("$msg_src>APRS,OH2RDG*,WIDE,qAR,%s::%-9.9s:two gates", $login_tx, $msg_dst);
|
||||
istest::txrx(\&ok, $i_tx, $i_rx2, $tx, $rx);
|
||||
$read1 = $i_rx->get_packet(1);
|
||||
ok($read1, $rx, "Got wrong message line from first rx port");
|
||||
|
||||
|
||||
# disconnect
|
||||
|
||||
$ret = $i_rx->disconnect();
|
||||
ok($ret, 1, "Failed to disconnect from the server: " . $i_rx->{'error'});
|
||||
|
||||
$ret = $i_rx2->disconnect();
|
||||
ok($ret, 1, "Failed to disconnect from the server: " . $i_rx2->{'error'});
|
||||
|
||||
$ret = $i_tx->disconnect();
|
||||
ok($ret, 1, "Failed to disconnect from the server: " . $i_tx->{'error'});
|
||||
|
||||
# stop
|
||||
|
||||
ok($p->stop(), 1, "Failed to stop product");
|
||||
|
||||
Loading…
Reference in New Issue