X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXProt.pm;h=ed5e417150724e9c1bb91ce75efeee1a4de2cba8;hb=fa57f72c26032aae4c1a20358e829ba9afbf460c;hp=3001d263f5dc60878ec65a91a6ea733601b5989f;hpb=1cf4bd14be226274d5deb05da8480ab91a5dac52;p=spider.git diff --git a/perl/DXProt.pm b/perl/DXProt.pm index 3001d263..ed5e4171 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -18,8 +18,26 @@ use DXM; use DXCluster; use DXProtVars; use DXCommandmode; +use DXLog; +use Spot; +use DXProtout; +use Carp; use strict; +use vars qw($me $pc11_max_age $pc11_dup_age %dup $last_hour); + +$me = undef; # the channel id for this cluster +$pc11_max_age = 1*3600; # the maximum age for an incoming 'real-time' pc11 +$pc11_dup_age = 24*3600; # the maximum time to keep the dup list for +%dup = (); # the pc11 and 26 dup hash +$last_hour = time; # last time I did an hourly periodic update + +sub init +{ + my $user = DXUser->get($main::mycall); + $me = DXProt->new($main::mycall, undef, $user); + # $me->{sort} = 'M'; # M for me +} # # obtain a new connection this is derived from dxchannel @@ -27,9 +45,9 @@ use strict; sub new { - my $self = DXChannel::alloc(@_); - $self->{sort} = 'A'; # in absence of how to find out what sort of an object I am - return $self; + my $self = DXChannel::alloc(@_); + $self->{sort} = 'A'; # in absence of how to find out what sort of an object I am + return $self; } # this is how a pc connection starts (for an incoming connection) @@ -37,19 +55,29 @@ sub new # all the crap that comes between). sub start { - my ($self, $line) = shift; - my $call = $self->call; - - # remember type of connection - $self->{consort} = $line; - - # set unbuffered - $self->send_now('B',"0"); - - # send initialisation string - $self->send($self->pc38()) if DXNode->get_all(); - $self->send($self->pc18()); - $self->{state} = 'incoming'; + my ($self, $line, $sort) = @_; + my $call = $self->{call}; + my $user = $self->{user}; + + # remember type of connection + $self->{consort} = $line; + $self->{outbound} = $sort eq 'O'; + $self->{priv} = $user->priv; + $self->{lang} = $user->lang; + $self->{consort} = $line; # save the connection type + $self->{here} = 1; + + # set unbuffered + $self->send_now('B',"0"); + + # send initialisation string + if (!$self->{outbound}) { + $self->send(pc38()) if DXNode->get_all(); + $self->send(pc18()); + } + $self->state('init'); + $self->pc50_t(time); + Log('DXProt', "$call connected"); } # @@ -57,95 +85,379 @@ sub start # sub normal { - my ($self, $line) = @_; - my @field = split /[\^\~]/, $line; - - # ignore any lines that don't start with PC - return if !$field[0] =~ /^PC/; - - # process PC frames - my ($pcno) = $field[0] =~ /^PC(\d\d)/; # just get the number - return if $pcno < 10 || $pcno > 51; - - SWITCH: { - if ($pcno == 10) {last SWITCH;} - if ($pcno == 11) {last SWITCH;} - if ($pcno == 12) {last SWITCH;} - if ($pcno == 13) {last SWITCH;} - if ($pcno == 14) {last SWITCH;} - if ($pcno == 15) {last SWITCH;} - if ($pcno == 16) {last SWITCH;} - if ($pcno == 17) {last SWITCH;} - if ($pcno == 18) {last SWITCH;} - if ($pcno == 19) {last SWITCH;} - if ($pcno == 20) { # send local configuration - - # set our data (manually 'cos we only have a psuedo channel [at the moment]) - my $hops = $self->get_hops(); - $self->send("PC19^1^$main::mycall^0^$DXProt::myprot_version^$hops^"); - - # get all the local users and send them out - my @list; - for (@list = DXCommandmode::get_all(); @list; ) { - @list = $self->pc16(@list); - my $out = shift @list; - $self->send($out); - } - $self->send($self->pc22()); - last SWITCH; + my ($self, $line) = @_; + my @field = split /[\^\~]/, $line; + + # ignore any lines that don't start with PC + return if !$field[0] =~ /^PC/; + + # process PC frames + my ($pcno) = $field[0] =~ /^PC(\d\d)/; # just get the number + return if $pcno < 10 || $pcno > 51; + + SWITCH: { + if ($pcno == 10) { # incoming talk + + # is it for me or one of mine? + my $call = ($field[5] gt ' ') ? $field[5] : $field[2]; + if ($call eq $main::mycall || grep $_ eq $call, get_all_user_calls()) { + + # yes, it is + my $text = unpad($field[3]); + Log('talk', $call, $field[1], $field[6], $text); + $call = $main::myalias if $call eq $main::mycall; + my $ref = DXChannel->get($call); + $ref->send("$call de $field[1]: $text") if $ref; + } else { + route($field[2], $line); # relay it on its way + } + return; + } + + if ($pcno == 11 || $pcno == 26) { # dx spot + + # if this is a 'nodx' node then ignore it + last SWITCH if grep $field[7] =~ /^$_/, @DXProt::nodx_node; + + # convert the date to a unix date + my $d = cltounix($field[3], $field[4]); + return if !$d || ($pcno == 11 && $d < $main::systime - $pc11_max_age); # bang out (and don't pass on) if date is invalid or the spot is too old + + # strip off the leading & trailing spaces from the comment + my $text = unpad($field[5]); + + # store it away + my $spotter = $field[6]; + $spotter =~ s/-\d+$//o; # strip off the ssid from the spotter + + # do some de-duping + my $dupkey = "$field[1]$field[2]$d$text$field[6]"; + return if $dup{$dupkey}; + $dup{$dupkey} = $d; + + my $spot = Spot::add($field[1], $field[2], $d, $text, $spotter); + + # send orf to the users + if ($spot && $pcno == 11) { + my $buf = Spot::formatb($field[1], $field[2], $d, $text, $spotter); + broadcast_users("$buf\a\a"); + } + + last SWITCH; + } + + if ($pcno == 12) { # announces + + if ($field[2] eq '*' || $field[2] eq $main::mycall) { + + # strip leading and trailing stuff + my $text = unpad($field[3]); + my $target; + my $to = 'To '; + my @list; + + if ($field[4] eq '*') { # sysops + $target = "Sysops"; + @list = map { $_->priv >= 5 ? $_ : () } get_all_users(); + } elsif ($field[4] gt ' ') { # speciality list handling + my ($name) = split /\./, $field[4]; + $target = "$name"; # put the rest in later (if bothered) + } + + if ($field[6] eq '1') { + $target = "WX"; + $to = ''; + } + $target = "All" if !$target; + + if (@list > 0) { + broadcast_list("$to$target de $field[1]: $text", @list); + } else { + broadcast_users("$target de $field[1]: $text"); + } + Log('ann', $target, $field[1], $text); + + return if $field[2] eq $main::mycall; # it's routed to me + } else { + route($field[2], $line); + return; # only on a routed one + } + + last SWITCH; + } + + if ($pcno == 13) { + last SWITCH; + } + if ($pcno == 14) { + last SWITCH; + } + if ($pcno == 15) { + last SWITCH; + } + + if ($pcno == 16) { # add a user + my $node = DXCluster->get_exact($field[1]); + last SWITCH if !$node; # ignore if havn't seen a PC19 for this one yet + my $i; + + for ($i = 2; $i < $#field; $i++) { + my ($call, $confmode, $here) = $field[$i] =~ /^(\S+) (-) (\d)/o; + next if length $call < 3; + next if !$confmode; + $call = uc $call; + next if DXCluster->get_exact($call); # we already have this (loop?) + + $confmode = $confmode eq '*'; + DXNodeuser->new($self, $node, $call, $confmode, $here); + + # add this station to the user database, if required + $call =~ s/-\d+$//o; # remove ssid for users + my $user = DXUser->get_current($call); + $user = DXUser->new($call) if !$user; + $user->node($node->call); + $user->homenode($node->call) if !$user->homenode; + $user->put; + } + + # queue up any messages (look for privates only) + DXMsg::queue_msg(1) if $self->state eq 'normal'; + last SWITCH; + } + + if ($pcno == 17) { # remove a user + + my $ref = DXCluster->get_exact($field[1]); + $ref->del() if $ref; + last SWITCH; + } + + if ($pcno == 18) { # link request + $self->send_local_config(); + $self->send(pc20()); + $self->state('init'); + last SWITCH; + } + + if ($pcno == 19) { # incoming cluster list + my $i; + for ($i = 1; $i < $#field-1; $i += 4) { + my $here = $field[$i]; + my $call = uc $field[$i+1]; + my $confmode = $field[$i+2] eq '*'; + my $ver = $field[$i+3]; + + # now check the call over + next if DXCluster->get_exact($call); # we already have this + + # check for sane parameters + next if $ver < 5000; # only works with version 5 software + next if length $call < 3; # min 3 letter callsigns + DXNode->new($self, $call, $confmode, $here, $ver); + + # unbusy and stop and outgoing mail (ie if somehow we receive another PC19 without a disconnect) + my $mref = DXMsg::get_busy($call); + $mref->stop_msg($self) if $mref; + + # add this station to the user database, if required (don't remove SSID from nodes) + my $user = DXUser->get_current($call); + if (!$user) { + $user = DXUser->new($call); + $user->sort('A'); + $user->node($call); + $user->homenode($call); + $user->put; + } + } + + # queue up any messages + DXMsg::queue_msg() if $self->state eq 'normal'; + last SWITCH; + } + + if ($pcno == 20) { # send local configuration + $self->send_local_config(); + $self->send(pc22()); + $self->state('normal'); + + # queue mail + DXMsg::queue_msg(); + return; + } + + if ($pcno == 21) { # delete a cluster from the list + my $call = uc $field[1]; + if ($call ne $main::mycall) { # don't allow malicious buggers to disconnect me! + my $ref = DXCluster->get_exact($call); + $ref->del() if $ref; + } + last SWITCH; + } + + if ($pcno == 22) { + $self->state('normal'); + + # queue mail + DXMsg::queue_msg(); + return; + } + + if ($pcno == 23 || $pcno == 27) { # WWV info + Geomag::update(@field[1..$#field]); + last SWITCH; + } + + if ($pcno == 24) { # set here status + my $call = uc $field[1]; + my $ref = DXCluster->get_exact($call); + $ref->here($field[2]) if $ref; + last SWITCH; + } + + if ($pcno == 25) { + last SWITCH; + } + + if (($pcno >= 28 && $pcno <= 33) || $pcno == 40 || $pcno == 42) { # mail/file handling + DXMsg::process($self, $line); + return; + } + + if ($pcno == 34 || $pcno == 36) { # remote commands (incoming) + if ($field[1] eq $main::mycall) { + my $ref = DXUser->get_current($field[2]); + Log('rcmd', 'in', $ref->{priv}, $field[2], $field[3]); + if ($ref->{priv}) { # you have to have SOME privilege, the commands have further filtering + $self->{remotecmd} = 1; # for the benefit of any command that needs to know + my @in = (DXCommandmode::run_cmd($self, $field[3])); + for (@in) { + s/\s*$//og; + $self->send(pc35($main::mycall, $field[2], "$main::mycall:$_")); + Log('rcmd', 'out', $field[2], $_); + } + delete $self->{remotecmd}; + } + } else { + route($field[1], $line); + } + return; + } + + if ($pcno == 35) { # remote command replies + if ($field[1] eq $main::mycall) { + my $s = DXChannel::get($main::myalias); + my @ref = grep { $_->pc34to eq $field[2] } DXChannel::get_all(); # people that have rcmded someone + push @ref, $s if $s; + + foreach (@ref) { + $_->send($field[3]); + } + } else { + route($field[1], $line); + } + return; + } + + if ($pcno == 37) { + last SWITCH; + } + + if ($pcno == 38) { # node connected list from neighbour + return; + } + + if ($pcno == 39) { # incoming disconnect + $self->disconnect(); + return; + } + + if ($pcno == 41) { # user info + # add this station to the user database, if required + my $user = DXUser->get_current($field[1]); + if (!$user) { + # then try without an SSID + $field[1] =~ s/-\d+$//o; + $user = DXUser->get_current($field[1]); + } + $user = DXUser->new($field[1]) if !$user; + + if ($field[2] == 1) { + $user->name($field[3]); + } elsif ($field[2] == 2) { + $user->qth($field[3]); + } elsif ($field[2] == 3) { + my ($latd, $latm, $latl, $longd, $longm, $longl) = split /\s+/, $field[3]; + $longd += ($longm/60); + $longd = 0-$longd if (uc $longl) eq 'W'; + $user->long($longd); + $latd += ($latm/60); + $latd = 0-$latd if (uc $latl) eq 'S'; + $user->lat($latd); + } elsif ($field[2] == 4) { + $user->homenode($field[3]); + } + $user->put; + last SWITCH; + } + if ($pcno == 43) { + last SWITCH; + } + if ($pcno == 44) { + last SWITCH; + } + if ($pcno == 45) { + last SWITCH; + } + if ($pcno == 46) { + last SWITCH; + } + if ($pcno == 47) { + last SWITCH; + } + if ($pcno == 48) { + last SWITCH; + } + if ($pcno == 49) { + last SWITCH; + } + + if ($pcno == 50) { # keep alive/user list + my $ref = DXCluster->get_exact($field[1]); + $ref->update_users($field[2]) if $ref; + last SWITCH; + } + + if ($pcno == 51) { # incoming ping requests/answers + + # is it for us? + if ($field[1] eq $main::mycall) { + my $flag = $field[3]; + $flag ^= 1; + $self->send($self->pc51($field[2], $field[1], $flag)); + } else { + # route down an appropriate thingy + route($field[1], $line); + } + return; + } } - if ($pcno == 21) {last SWITCH;} - if ($pcno == 22) {last SWITCH;} - if ($pcno == 23) {last SWITCH;} - if ($pcno == 24) {last SWITCH;} - if ($pcno == 25) {last SWITCH;} - if ($pcno == 26) {last SWITCH;} - if ($pcno == 27) {last SWITCH;} - if ($pcno == 28) {last SWITCH;} - if ($pcno == 29) {last SWITCH;} - if ($pcno == 30) {last SWITCH;} - if ($pcno == 31) {last SWITCH;} - if ($pcno == 32) {last SWITCH;} - if ($pcno == 33) {last SWITCH;} - if ($pcno == 34) {last SWITCH;} - if ($pcno == 35) {last SWITCH;} - if ($pcno == 36) {last SWITCH;} - if ($pcno == 37) {last SWITCH;} - if ($pcno == 38) {last SWITCH;} - if ($pcno == 39) {last SWITCH;} - if ($pcno == 40) {last SWITCH;} - if ($pcno == 41) {last SWITCH;} - if ($pcno == 42) {last SWITCH;} - if ($pcno == 43) {last SWITCH;} - if ($pcno == 44) {last SWITCH;} - if ($pcno == 45) {last SWITCH;} - if ($pcno == 46) {last SWITCH;} - if ($pcno == 47) {last SWITCH;} - if ($pcno == 48) {last SWITCH;} - if ($pcno == 49) {last SWITCH;} - if ($pcno == 50) {last SWITCH;} - if ($pcno == 51) {last SWITCH;} - } - - # if get here then rebroadcast the thing with its Hop count decremented (if - # the is one). If it has a hop count and it decrements to zero then don't - # rebroadcast it. - # - # NOTE - don't arrive here UNLESS YOU WANT this lump of protocol to be - # REBROADCAST!!!! - # - - my $hopfield = pop @field; - push @field, $hopfield; - - if ($hopfield =~ /H\d\d./o) { - my ($hops) = $hopfield =~ /H(\d+)/o; - $hops--; - if ($hops > 0) { - $line =~ s/\^H\d+(\^\~.)$/\^H$hops$1/; # change the hop count - DXProt->broadcast($line, $self); # send it to everyone but me + + # if get here then rebroadcast the thing with its Hop count decremented (if + # there is one). If it has a hop count and it decrements to zero then don't + # rebroadcast it. + # + # NOTE - don't arrive here UNLESS YOU WANT this lump of protocol to be + # REBROADCAST!!!! + # + + my $hops; + if (($hops) = $line =~ /H(\d+)\^\~?$/o) { + my $newhops = $hops - 1; + if ($newhops > 0) { + $line =~ s/\^H$hops(\^\~?)$/\^H$newhops$1/; # change the hop count + broadcast_ak1a($line, $self); # send it to everyone but me + } } - } } # @@ -154,19 +466,30 @@ sub normal # sub process { - my $t = time; - my @chan = DXChannel->get_all(); - my $chan; - - foreach $chan (@chan) { - next if !$chan->is_ak1a(); - - # send a pc50 out on this channel - if ($t >= $chan->t + $DXProt::pc50_interval) { - $chan->send(pc50()); - $chan->t($t); + my $t = time; + my @chan = DXChannel->get_all(); + my $chan; + + foreach $chan (@chan) { + next if !$chan->is_ak1a(); + + # send a pc50 out on this channel + if ($t >= $chan->pc50_t + $DXProt::pc50_interval) { + $chan->send(pc50()); + $chan->pc50_t($t); + } + } + + my $key; + my $val; + my $cutoff; + if ($main::systime - 3600 > $last_hour) { + $cutoff = $main::systime - $pc11_dup_age; + while (($key, $val) = each %dup) { + delete $dup{$key} if $val < $cutoff; + } + $last_hour = $main::systime; } - } } # @@ -174,188 +497,171 @@ sub process # sub finish { - -} - -# -# add a (local) user to the cluster -# - -sub adduser -{ - + my $self = shift; + my $ref = DXCluster->get_exact($self->call); + + # unbusy and stop and outgoing mail + my $mref = DXMsg::get_busy($self->call); + $mref->stop_msg($self) if $mref; + + # broadcast to all other nodes that all the nodes connected to via me are gone + my @gonenodes = map { $_->dxchan == $self ? $_ : () } DXNode::get_all(); + my $node; + + foreach $node (@gonenodes) { + next if $node->call eq $self->call; + broadcast_ak1a(pc21($node->call, 'Gone'), $self); # done like this 'cos DXNodes don't have a pc21 method + $node->del(); + } + + # now broadcast to all other ak1a nodes that I have gone + broadcast_ak1a(pc21($self->call, 'Gone.'), $self); + Log('DXProt', $self->call . " Disconnected"); + $ref->del() if $ref; } # -# delete a (local) user to the cluster +# some active measures # -sub deluser +sub send_local_config { - + my $self = shift; + my $n; + + # send our nodes + my @nodes = DXNode::get_all(); + + # create a list of all the nodes that are not connected to this connection + @nodes = grep { $_->dxchan != $self } @nodes; + $self->send($me->pc19(@nodes)); + + # get all the users connected on the above nodes and send them out + foreach $n (@nodes) { + my @users = values %{$n->list}; + $self->send(DXProt::pc16($n, @users)); + } } # -# add a (locally connected) node to the cluster +# route a message down an appropriate interface for a callsign # - -sub addnode -{ - -} - +# is called route(to, pcline); # -# delete a (locally connected) node to the cluster -# -sub delnode +sub route { - + my ($call, $line) = @_; + my $cl = DXCluster->get_exact($call); + if ($cl) { + my $hops; + my $dxchan = $cl->{dxchan}; + if (($hops) = $line =~ /H(\d+)\^\~?$/o) { + my $newhops = $hops - 1; + if ($newhops > 0) { + $line =~ s/\^H$hops(\^\~?)$/\^H$newhops$1/; # change the hop count + $dxchan->send($line) if $dxchan; + } + } else { + $dxchan->send($line) if $dxchan; # for them wot don't have Hops + } + } } -# -# some active measures -# - # broadcast a message to all clusters [except those mentioned after buffer] -sub broadcast +sub broadcast_ak1a { - my $pkg = shift; # ignored - my $s = shift; # the line to be rebroadcast - my @except = @_; # to all channels EXCEPT these (dxchannel refs) - my @chan = DXChannel->get_all(); - my ($chan, $except); - -L: foreach $chan (@chan) { - next if !$chan->sort eq 'A'; # only interested in ak1a channels - foreach $except (@except) { - next L if $except == $chan; # ignore channels in the 'except' list - } - chan->send($s); # send it - } + my $s = shift; # the line to be rebroadcast + my @except = @_; # to all channels EXCEPT these (dxchannel refs) + my @chan = get_all_ak1a(); + my $chan; + + foreach $chan (@chan) { + next if grep $chan == $_, @except; + $chan->send($s); # send it if it isn't the except list + } } -# -# gimme all the ak1a nodes -# -sub get_all +# broadcast to all users +sub broadcast_users { - my @list = DXChannel->get_all(); - my $ref; - my @out; - foreach $ref (@list) { - push @out, $ref if $ref->sort eq 'A'; - } - return @out; + my $s = shift; # the line to be rebroadcast + my @except = @_; # to all channels EXCEPT these (dxchannel refs) + my @chan = get_all_users(); + my $chan; + + foreach $chan (@chan) { + next if grep $chan == $_, @except; + $chan->send($s); # send it if it isn't the except list + } } -# -# obtain the hops from the list for this callsign and pc no -# - -sub get_hops +# broadcast to a list of users +sub broadcast_list { - my ($self, $pcno) = @_; - return "H$DXProt::def_hopcount"; # for now + my $s = shift; + my $chan; + + foreach $chan (@_) { + $chan->send($s); # send it + } } # -# All the PCxx generation routines -# - -# -# add one or more users (I am expecting references that have 'call', -# 'confmode' & 'here' method) -# -# NOTE this sends back a list containing the PC string (first element) -# and the rest of the users not yet processed -# -sub pc16 -{ - my $self = shift; - my @list = @_; # list of users - my @out = ('PC16', $main::mycall); - my $i; - - for ($i = 0; @list && $i < $DXProt::pc16_max_users; $i++) { - my $ref = shift @list; - my $call = $ref->call; - my $s = sprintf "%s %s %d", $call, $ref->confmode ? '*' : '-', $ref->here; - push @out, $s; - } - push @out, $self->get_hops(); - my $str = join '^', @out; - $str .= '^'; - return ($str, @list); -} - -# Request init string -sub pc18 -{ - return "PC18^wot a load of twaddle^$DXProt::myprot_version^~"; -} - +# gimme all the ak1a nodes # -# add one or more nodes -# -# NOTE this sends back a list containing the PC string (first element) -# and the rest of the nodes not yet processed (as PC16) -# -sub pc19 +sub get_all_ak1a { - my $self = shift; - my @list = @_; # list of users - my @out = ('PC19', $main::mycall); - my $i; - - for ($i = 0; @list && $i < $DXProt::pc19_max_nodes; $i++) { - my $ref = shift @list; - push @out, $ref->here, $ref->call, $ref->confmode, $ref->pcversion; - } - push @out, $self->get_hops(); - my $str = join '^', @out; - $str .= '^'; - return ($str, @list); + my @list = DXChannel->get_all(); + my $ref; + my @out; + foreach $ref (@list) { + push @out, $ref if $ref->is_ak1a; + } + return @out; } -# end of Rinit phase -sub pc20 +# return a list of all users +sub get_all_users { - return 'PC20^'; + my @list = DXChannel->get_all(); + my $ref; + my @out; + foreach $ref (@list) { + push @out, $ref if $ref->is_user; + } + return @out; } -# delete a node -sub pc21 +# return a list of all user callsigns +sub get_all_user_calls { - my ($self, $ref, $reason) = @_; - my $call = $ref->call; - my $hops = $self->get_hops(); - return "PC21^$call^$reason^$hops^"; + my @list = DXChannel->get_all(); + my $ref; + my @out; + foreach $ref (@list) { + push @out, $ref->call if $ref->is_user; + } + return @out; } -# end of init phase -sub pc22 -{ - return 'PC22^'; -} +# +# obtain the hops from the list for this callsign and pc no +# -# send all the DX clusters I reckon are connected -sub pc38 +sub get_hops { - my @list = DXNode->get_all(); - my $list; - my @nodes; - - foreach $list (@list) { - push @nodes, $list->call; - } - return "PC38^" . join(',', @nodes) . "^~"; + my ($pcno) = @_; + my $hops = $DXProt::hopcount{$pcno}; + $hops = $DXProt::def_hopcount if !$hops; + return "H$hops"; } -sub pc50 +# remove leading and trailing spaces from an input string +sub unpad { - my $n = DXNodeuser->count; - return "PC50^$main::mycall^$n^H99^"; + my $s = shift; + $s =~ s/^\s+|\s+$//; + return $s; } - 1; __END__