576 lines
14 KiB
Perl
576 lines
14 KiB
Perl
|
|
package Ham::APRS::IS2;
|
|
|
|
use 5.006;
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Time::HiRes qw( time sleep );
|
|
use IO::Handle '_IOFBF';
|
|
use IO::Socket::INET;
|
|
use IO::Select;
|
|
use Data::Dumper;
|
|
|
|
use Google::ProtocolBuffers;
|
|
|
|
Google::ProtocolBuffers->parsefile("../src/aprsis2.proto", { create_accessors => 1 });
|
|
|
|
our $VERSION = '0.01';
|
|
|
|
our $aprs_appname = "IS2";
|
|
our $aprs_appid = "$aprs_appname $VERSION";
|
|
|
|
our $debug = 0;
|
|
|
|
=head1 new(hostport, mycall, optionshash)
|
|
|
|
Initializes a new Ham::APRS::IS socket. Takes two mandatory arguments,
|
|
the host:port pair to connect to and your client's callsign, and one optional
|
|
argument, the filter string to be sent with the login command.
|
|
|
|
my $is = new Ham::APRS::IS('aprs.server.com:12345', 'N0CALL');
|
|
my $is = new Ham::APRS::IS('aprs.server.com:12345', 'N0CALL', 'filter' => 'f/*');
|
|
my $is = new Ham::APRS::IS('aprs.server.com:12345', 'N0CALL', 'nopass' => 1);
|
|
my $is = new Ham::APRS::IS('aprs.server.com:12345', 'N0CALL', 'udp' => 1);
|
|
|
|
=cut
|
|
|
|
sub new($$$;%)
|
|
{
|
|
my $that = shift;
|
|
my $class = ref($that) || $that;
|
|
my $self = { };
|
|
bless ($self, $class);
|
|
|
|
my($host_port, $mycall, %options) = @_;
|
|
|
|
$self->{'host_port'} = $host_port;
|
|
$self->{'mycall'} = $mycall;
|
|
$self->{'filter'} = $options{'filter'} if (defined $options{'filter'});
|
|
$self->{'udp'} = $options{'udp'} if (defined $options{'udp'});
|
|
|
|
if ($options{'nopass'}) {
|
|
$self->{'aprspass'} = -1;
|
|
} else {
|
|
$self->{'aprspass'} = aprspass($self->{'mycall'});
|
|
}
|
|
|
|
#warn "aprspass for $self->{mycall} is $self->{aprspass}\n";
|
|
|
|
$self->{'state'} = 'init';
|
|
$self->{'error'} = "No errors yet.";
|
|
$self->{'loginstate'} = 'init';
|
|
|
|
$self->{'pqueue_in'} = [];
|
|
|
|
return $self;
|
|
}
|
|
|
|
=head1 disconnect()
|
|
|
|
Disconnects from the server. Returns 1 on success, 0 on failure.
|
|
|
|
$is->disconnect() || die "Failed to disconnect: $is->{error}";
|
|
|
|
=cut
|
|
|
|
sub disconnect($)
|
|
{
|
|
my($self) = @_;
|
|
|
|
if (defined $self->{'sock'}) {
|
|
$self->{'sock'}->close;
|
|
undef $self->{'sock'};
|
|
}
|
|
|
|
$self->{'state'} = 'disconnected';
|
|
|
|
return 1;
|
|
}
|
|
|
|
=head1 connect(options)
|
|
|
|
Connects to the server. Returns 1 on success, 0 on failure.
|
|
Takes an optional options hash as a parameter. Currently knows only one parameter,
|
|
retryuntil, which specifies the number of seconds to retry the connection. After
|
|
each failed attempt the code sleeps for 0.5 seconds before trying again. Defaults
|
|
to 0 (no retries).
|
|
|
|
$is->connect('retryuntil' => 10) || die "Failed to connect: $is->{error}";
|
|
|
|
=cut
|
|
|
|
sub connect($;%)
|
|
{
|
|
my($self) = shift;
|
|
|
|
my %options = @_;
|
|
|
|
if ($self->{'state'} eq 'connected') {
|
|
$self->{'error'} = 'Already connected';
|
|
return 0;
|
|
}
|
|
|
|
$self->{'loginstate'} = 'init';
|
|
$self->{'ibuf'} = '';
|
|
|
|
my $retryuntil = defined $options{'retryuntil'} ? $options{'retryuntil'} : 0;
|
|
my $starttime = time();
|
|
|
|
if ($self->{'udp'} && !defined $self->{'usock'}) {
|
|
$self->{'usock'} = IO::Socket::INET->new(Proto => 'udp', LocalPort => $self->{'udp'});
|
|
|
|
if (!defined($self->{'usock'})) {
|
|
$self->{'error'} = "Failed to bind an UDP client socket: $@";
|
|
return 0;
|
|
}
|
|
|
|
warn "bound udp port " . $self->{'udp'} . "\n";
|
|
}
|
|
|
|
while (!defined $self->{'sock'}) {
|
|
$self->{'sock'} = IO::Socket::INET->new($self->{'host_port'});
|
|
|
|
if (!defined($self->{'sock'})) {
|
|
$self->{'error'} = "Failed to connect to $self->{host_port}: $!";
|
|
|
|
if (time() - $starttime >= $retryuntil) {
|
|
return 0;
|
|
}
|
|
|
|
select(undef, undef, undef, 0.1);
|
|
}
|
|
}
|
|
|
|
$self->{'error'} = 'Connected successfully';
|
|
|
|
# printf ( "APRS::IS->new() mycall='%s' aprspass=%d filterre='%s'\n",
|
|
# $self->{aprsmycall}, $self->{aprspass}, $self->{filterre} );
|
|
|
|
##
|
|
## * Need to send on initial connect the following logon line:
|
|
## user callsign pass passcode vers appname versionnum rest_of_line
|
|
##
|
|
## callsign = login callsign-SSID
|
|
## passcode = login passcode per APRS-IS algorithm, -1 = read-only
|
|
## appname = application name (1 word)
|
|
## versionnum = application version number (no spaces)
|
|
## rest_of_line = server command if connecting to a port that supports commands (see Server Commands)
|
|
##
|
|
## (appname and versionnum should not exceed 15 characters)
|
|
##
|
|
##
|
|
## * Need to recognize both TCPIP and TCPXX as TCP/IP stations
|
|
## * Need to provide a means to perform the user validation. This can either be a user entered password,
|
|
## or a client program can automatically figure out the password given the callsign.
|
|
## If the later is used, it is the client programmer's responsibility to be certain that non-amateurs
|
|
## are not given registrations that can validate themselves in APRS-IS.
|
|
## * Probably a good idea to perform some feedback about the limitations of TCPIP without a registration number.
|
|
##
|
|
|
|
$self->{'state'} = 'connected';
|
|
|
|
$self->{'sock'}->blocking(0);
|
|
|
|
# wait for server signature
|
|
my $t = time();
|
|
while (my $l = $self->is2_frame_in()) {
|
|
my $sig = $l->server_signature;
|
|
|
|
if ($l->type == IS2Message::Type::SERVER_SIGNATURE()) {
|
|
if (!$sig) {
|
|
$self->{'error'} = "SERVER_SIGNATURE type, but no server signature message";
|
|
return 0;
|
|
}
|
|
$self->{'loginstate'} = 'server_signature';
|
|
#warn sprintf("got server signature: serverid '%s' app '%s' version '%s'\n",
|
|
# $sig->username, $sig->app_name, $sig->app_version);
|
|
last;
|
|
} else {
|
|
$self->{'error'} = "Wrong type of message received instead of SERVER_SIGNATURE: " . $l->type;
|
|
return 0;
|
|
}
|
|
|
|
if (time() - $t > 5) {
|
|
$self->{'error'} = "Timed out waiting for server signature";
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
if ($self->{'loginstate'} ne 'server_signature') {
|
|
$self->{'error'} = "Timed out waiting for server signature";
|
|
return 0;
|
|
}
|
|
|
|
# send login request
|
|
my $lm = LoginRequest->new({
|
|
'username' => $self->{'mycall'},
|
|
'password' => $self->{'aprspass'},
|
|
'app_name' => $aprs_appname,
|
|
'app_version' => $VERSION
|
|
});
|
|
|
|
my $im = IS2Message->new({
|
|
'type' => IS2Message::Type::LOGIN_REQUEST(),
|
|
'login_request' => $lm
|
|
});
|
|
|
|
$self->{'sock'}->blocking(1);
|
|
$self->is2_frame_out($im->encode);
|
|
$self->{'sock'}->blocking(0);
|
|
|
|
while (my $l = $self->is2_frame_in()) {
|
|
my $rep = $l->login_reply;
|
|
if ($l->type == IS2Message::Type::LOGIN_REPLY()) {
|
|
if (!$rep) {
|
|
$self->{'error'} = "LOGIN_REPLY type, but no login_reply message";
|
|
return 0;
|
|
}
|
|
|
|
#warn sprintf("got login reply: result %d verified %d reason %d message '%s'\n",
|
|
# $rep->result, $rep->verified,
|
|
# defined $rep->result_code ? $rep->result_code : 0,
|
|
# defined $rep->result_message ? $rep->result_message : '');
|
|
|
|
if ($rep->result != LoginReply::LoginResult::OK()) {
|
|
$self->{'error'} = sprintf("Login reply: login failed, code %d: %s",
|
|
defined $rep->result_code ? $rep->result_code : 0,
|
|
defined $rep->result_message ? $rep->result_message : '');
|
|
return 0;
|
|
}
|
|
|
|
if ($self->{'aprspass'} != -1 && $rep->verified < 1) {
|
|
$self->{'error'} = sprintf("Login reply: login not verified (%d), code %d: %s",
|
|
$rep->verified,
|
|
defined $rep->result_code ? $rep->result_code : 0,
|
|
defined $rep->result_message ? $rep->result_message : '');
|
|
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;
|
|
return 0;
|
|
}
|
|
|
|
if (time() - $t > 5) {
|
|
$self->{'error'} = "Login command timed out";
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
$self->{'error'} = "No LOGIN_REPLY received";
|
|
return 0;
|
|
}
|
|
|
|
sub send_packets($$)
|
|
{
|
|
my($self, $packets) = @_;
|
|
|
|
my @pq;
|
|
foreach my $p (@{ $packets }) {
|
|
push @pq, ISPacket->new({
|
|
'type' => ISPacket::Type::IS_PACKET(),
|
|
'is_packet_data' => $p
|
|
});
|
|
}
|
|
|
|
my $im = IS2Message->new({
|
|
'type' => IS2Message::Type::IS_PACKET(),
|
|
'is_packet' => \@pq
|
|
});
|
|
|
|
$self->{'sock'}->blocking(1);
|
|
$self->is2_frame_out($im->encode);
|
|
$self->{'sock'}->blocking(0);
|
|
}
|
|
|
|
sub send_packet($)
|
|
{
|
|
my($self, $packet) = @_;
|
|
$self->send_packets([$packet]);
|
|
}
|
|
|
|
sub get_packets($;$)
|
|
{
|
|
my($self, $timeout) = @_;
|
|
|
|
my $t = time();
|
|
|
|
while (my $l = $self->is2_frame_in($timeout)) {
|
|
my $ips = $l->is_packet;
|
|
if ($l->type == IS2Message::Type::IS_PACKET()) {
|
|
if (!$ips) {
|
|
$self->{'error'} = "IS_PACKET type, but no packets";
|
|
return undef;
|
|
}
|
|
|
|
my @pa;
|
|
|
|
foreach my $ip (@{ $ips }) {
|
|
if ($ip->type != ISPacket::Type::IS_PACKET()) {
|
|
$self->{'error'} = sprintf("ISPacket type %d unsupported", $ip->type);
|
|
return undef;
|
|
}
|
|
|
|
push @pa, $ip->is_packet_data;
|
|
}
|
|
|
|
return @pa;
|
|
} else {
|
|
$self->{'error'} = "Wrong type of frame received: " . $l->type;
|
|
return undef;
|
|
}
|
|
|
|
if (time() - $t > $timeout) {
|
|
$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 $reqid = int(rand(2**30));
|
|
|
|
my $im = IS2Message->new({
|
|
'type' => IS2Message::Type::PARAMETER(),
|
|
'parameter' => IS2Parameter->new({
|
|
'type' => IS2Parameter::Type::PARAMETER_SET(),
|
|
'request_id' => $reqid, # todo: sequential
|
|
'filter_string' => $filter
|
|
})
|
|
});
|
|
|
|
$self->{'sock'}->blocking(1);
|
|
$self->is2_frame_out($im->encode);
|
|
$self->{'sock'}->blocking(0);
|
|
|
|
my $t = time();
|
|
while (my $l = $self->is2_frame_in()) {
|
|
my $rep = $l->parameter;
|
|
if ($l->type == IS2Message::Type::PARAMETER()) {
|
|
if (!$rep) {
|
|
$self->{'error'} = "PARAMETER type, but no parameter message";
|
|
return 0;
|
|
}
|
|
|
|
if ($rep->request_id != $reqid) {
|
|
$self->{'error'} = "PARAMETER reply, wrong request id " . $rep->request_id . ", expected $reqid";
|
|
return 0;
|
|
}
|
|
|
|
if ($rep->type != IS2Parameter::Type::PARAMETER_APPLIED()) {
|
|
$self->{'error'} = sprintf("filter set reply: not applied");
|
|
return 0;
|
|
}
|
|
|
|
# todo: check sequence
|
|
return 1;
|
|
} else {
|
|
$self->{'error'} = "Wrong type of response received for PARAMETER_SET: " . $l->type;
|
|
return 0;
|
|
}
|
|
|
|
if (time() - $t > 5) {
|
|
$self->{'error'} = "parameter command timed out";
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
$self->{'error'} = "No PARAMETER_APPLIED received";
|
|
return 0;
|
|
}
|
|
|
|
sub is2_frame_out($$)
|
|
{
|
|
my($self, $frame) = @_;
|
|
|
|
my $framelen = length($frame);
|
|
|
|
if ($framelen >= 2**24) {
|
|
$self->{'error'} = "Attempted to write too large frame: $framelen is over 2^24 bytes";
|
|
return 0;
|
|
}
|
|
|
|
my $framelen_i = pack('N', $framelen);
|
|
|
|
#warn "is2_frame_out: framelen $framelen\n";
|
|
|
|
if (!$self->{'sock'}->print(chr(0x02) . substr($framelen_i, 1) . $frame . chr(0x03))) {
|
|
$self->{'error'} = "Failed to write IS2 frame to $self->{host_port}: $!";
|
|
return 0;
|
|
}
|
|
|
|
if (!$self->{'sock'}->flush) {
|
|
$self->{'error'} = "Failed to flush IS2 frame to $self->{host_port}: $!";
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
sub is2_frame_in($;$)
|
|
{
|
|
my($self, $timeout) = @_;
|
|
|
|
return undef if ($self->{'state'} ne 'connected');
|
|
|
|
$timeout = 5 if (!defined $timeout);
|
|
|
|
my $end_t = time() + $timeout;
|
|
my $sock = $self->{'sock'};
|
|
|
|
while (1) {
|
|
if (length($self->{'ibuf'}) >= 6) {
|
|
if (substr($self->{'ibuf'}, 0, 1) ne chr(0x02)) {
|
|
$self->{'error'} = "IS2 frame does not start with STX";
|
|
#warn "is2_frame_in: " . $self->{'error'} . "\n";
|
|
$self->disconnect();
|
|
return undef;
|
|
}
|
|
my $frame_len_b = chr(0) . substr($self->{'ibuf'}, 1, 3);
|
|
my $frame_len = unpack('N', $frame_len_b);
|
|
#warn "frame len: $frame_len\n";
|
|
my $need_bytes = $frame_len + 5;
|
|
|
|
if (length($self->{'ibuf'}) >= $need_bytes) {
|
|
my $etx = substr($self->{'ibuf'}, 4 + $frame_len, 1);
|
|
if ($etx ne chr(0x03)) {
|
|
$self->{'error'} = "IS2 frame does not end with ETX";
|
|
#warn "is2_frame_in: " . $self->{'error'} . "\n";
|
|
$self->disconnect();
|
|
return undef;
|
|
}
|
|
|
|
my $frame = substr($self->{'ibuf'}, 4, $frame_len);
|
|
$self->{'ibuf'} = substr($self->{'ibuf'}, $need_bytes);
|
|
|
|
my $is2_msg = IS2Message->decode($frame);
|
|
|
|
#warn "left in ibuf: " . length($self->{'ibuf'}) . "\n";
|
|
return $is2_msg;
|
|
}
|
|
}
|
|
|
|
my($rin, $rout, $ein, $eout) = ('', '', '', '');
|
|
my $rudp = '';
|
|
vec($rin, fileno($sock), 1) = 1;
|
|
my $rtcp = $rin;
|
|
if (defined $self->{'usock'}) {
|
|
vec($rudp, fileno($self->{'usock'}), 1) = 1;
|
|
$rin |= $rudp;
|
|
}
|
|
$ein = $rtcp;
|
|
my $nfound = select($rout = $rin, undef, $eout = $ein, $timeout);
|
|
|
|
if ($nfound) {
|
|
my $rbuf;
|
|
if (($rout & $rtcp) eq $rtcp) {
|
|
my $nread = sysread($sock, $rbuf, 1024);
|
|
if (!defined $nread || $nread < 1) {
|
|
$self->{'error'} = "Failed to read from server: $!";
|
|
#warn "is2_frame_in: read error (on read): $!\n";
|
|
$self->disconnect();
|
|
return undef;
|
|
} else {
|
|
$self->{'ibuf'} .= $rbuf;
|
|
}
|
|
}
|
|
if (0 && $eout) {
|
|
$self->{'error'} = "Failed to read from server (select returned errors): $!";
|
|
#warn "is2_frame_in: read error (on select)\n";
|
|
$self->disconnect();
|
|
return undef;
|
|
}
|
|
}
|
|
|
|
if (time() > $end_t) {
|
|
#warn "is2_frame_in: timeout\n";
|
|
return undef;
|
|
}
|
|
}
|
|
}
|
|
|
|
=head1 connected()
|
|
|
|
Checks whether we're connected currently. Returns 1 for connected, 0 for not connected.
|
|
|
|
=cut
|
|
|
|
sub connected($)
|
|
{
|
|
my($self) = @_;
|
|
|
|
return 1 if $self->{'state'} eq 'connected';
|
|
return 0;
|
|
}
|
|
|
|
|
|
=head1 accepted($socket)
|
|
|
|
Accepts a socket
|
|
|
|
=cut
|
|
|
|
sub accepted($$)
|
|
{
|
|
my($self, $sock) = @_;
|
|
|
|
$self->{'sock'} = $sock;
|
|
$self->{'sock'}->blocking(0);
|
|
$self->{'state'} = 'connected';
|
|
$self->{'error'} = 'Accepted connection successfully';
|
|
$self->{'ibuf'} = '';
|
|
}
|
|
|
|
|
|
|
|
=head1 aprspass($callsign)
|
|
|
|
Calculates the APRS passcode for a given callsign. Ignores SSID
|
|
and converts the callsign to uppercase as required. Returns an integer.
|
|
|
|
my $passcode = Ham::APRS::IS::aprspass($callsign);
|
|
|
|
=cut
|
|
|
|
sub aprspass($)
|
|
{
|
|
my($call) = @_;
|
|
|
|
$call =~ s/-([^\-]+)$//;
|
|
$call = uc($call);
|
|
|
|
my ($a, $h) = (0, 0);
|
|
map($h ^= ord(uc) << ($a^=8), $call =~ m/./g);
|
|
return (($h ^ 29666) & 65535);
|
|
}
|
|
|
|
|
|
1;
|
|
|