perl/DXProt.pm

   1 #!/usr/bin/perl
   2 #
   3 # This module impliments the protocal mode for a dx cluster
   4 #
   5 # Copyright (c) 1998 Dirk Koopman G1TLH
   6 #
   7 # $Id$
   8 #
   9
  10 package DXProt;
  11
  12 @ISA = qw(DXChannel);
  13
  14 use DXUtil;
  15 use DXChannel;
  16 use DXUser;
  17 use DXM;
  18 use DXCluster;
  19 use DXProtVars;
  20 use DXCommandmode;
  21 use DXLog;
  22 use Spot;
  23 use DXProtout;
  24 use Carp;
  25
  26 use strict;
  27 use vars qw($me $pc11_max_age $pc11_dup_age %dup $last_hour);
  28
  29 $me = undef;                # the channel id for this cluster
  30 $pc11_max_age = 1*3600;     # the maximum age for an incoming 'real-time' pc11
  31 $pc11_dup_age = 24*3600;    # the maximum time to keep the dup list for
  32 %dup = ();                  # the pc11 and 26 dup hash
  33 $last_hour = time;          # last time I did an hourly periodic update
  34
  35 sub init
  36 {
  37   my $user = DXUser->get($main::mycall);
  38   $me = DXProt->new($main::mycall, undef, $user);
  39 #  $me->{sort} = 'M';    # M for me
  40 }
  41
  42 #
  43 # obtain a new connection this is derived from dxchannel
  44 #
  45
  46 sub new
  47 {
  48   my $self = DXChannel::alloc(@_);
  49   $self->{sort} = 'A';   # in absence of how to find out what sort of an object I am
  50   return $self;
  51 }
  52
  53 # this is how a pc connection starts (for an incoming connection)
  54 # issue a PC38 followed by a PC18, then wait for a PC20 (remembering
  55 # all the crap that comes between).
  56 sub start
  57 {
  58   my ($self, $line, $sort) = @_;
  59   my $call = $self->{call};
  60   my $user = $self->{user};
  61
  62   # remember type of connection
  63   $self->{consort} = $line;
  64   $self->{outbound} = $sort eq 'O';
  65   $self->{priv} = $user->priv;
  66   $self->{lang} = $user->lang;
  67   $self->{consort} = $line;                # save the connection type
  68   $self->{here} = 1;
  69
  70   # set unbuffered
  71   $self->send_now('B',"0");
  72
  73   # send initialisation string
  74   if (!$self->{outbound}) {
  75           $self->send(pc38()) if DXNode->get_all();
  76           $self->send(pc18());
  77   }
  78   $self->state('init');
  79   $self->pc50_t(time);
  80   Log('DXProt', "$call connected");
  81 }
  82
  83 #
  84 # This is the normal pcxx despatcher
  85 #
  86 sub normal
  87 {
  88   my ($self, $line) = @_;
  89   my @field = split /[\^\~]/, $line;
  90
  91   # ignore any lines that don't start with PC
  92   return if !$field[0] =~ /^PC/;
  93
  94   # process PC frames
  95   my ($pcno) = $field[0] =~ /^PC(\d\d)/;          # just get the number
  96   return if $pcno < 10 || $pcno > 51;
  97
  98   SWITCH: {
  99     if ($pcno == 10) {             # incoming talk
 100
 101       # is it for me or one of mine?
 102           my $call = ($field[5] gt ' ') ? $field[5] : $field[2];
 103           if ($call eq $main::mycall || grep $_ eq $call, get_all_user_calls()) {
 104
 105                 # yes, it is
 106                 my $text = unpad($field[3]);
 107                 my $ref = DXChannel->get($call);
 108                 $ref->send("$call de $field[1]: $text") if $ref;
 109                 Log('talk', $call, $field[1], $field[6], $text);
 110           } else {
 111             route($field[2], $line);       # relay it on its way
 112           }
 113           return;
 114         }
 115
 116     if ($pcno == 11 || $pcno == 26) {             # dx spot
 117
 118       # if this is a 'nodx' node then ignore it
 119           last SWITCH if grep $field[7] =~ /^$_/,  @DXProt::nodx_node;
 120
 121       # convert the date to a unix date
 122           my $d = cltounix($field[3], $field[4]);
 123           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
 124
 125           # strip off the leading & trailing spaces from the comment
 126           my $text = unpad($field[5]);
 127
 128           # store it away
 129           my $spotter = $field[6];
 130           $spotter =~ s/-\d+$//o;         # strip off the ssid from the spotter
 131
 132       # do some de-duping
 133           my $dupkey = "$field[1]$field[2]$d$text$field[6]";
 134           return if $dup{$dupkey};
 135           $dup{$dupkey} = $d;
 136
 137           my $spot = Spot::add($field[1], $field[2], $d, $text, $spotter);
 138
 139           # send orf to the users
 140       if ($spot && $pcno == 11) {
 141             my $buf = Spot::formatb($field[1], $field[2], $d, $text, $spotter);
 142         broadcast_users("$buf\a\a");
 143           }
 144
 145           last SWITCH;
 146         }
 147
 148     if ($pcno == 12) {             # announces
 149
 150           if ($field[2] eq '*' || $field[2] eq $main::mycall) {
 151
 152         # strip leading and trailing stuff
 153             my $text = unpad($field[3]);
 154                 my $target;
 155                 my $to = 'To ';
 156                 my @list;
 157
 158             if ($field[4] eq '*') {          # sysops
 159                   $target = "Sysops";
 160                   @list = map { $_->priv >= 5 ? $_ : () } get_all_users();
 161                 } elsif ($field[4] gt ' ') {     # speciality list handling
 162                   my ($name) = split /\./, $field[4];
 163           $target = "$name";          # put the rest in later (if bothered)
 164         }
 165
 166                 if ($field[6] eq '1') {
 167                         $target = "WX";
 168                         $to = '';
 169                 }
 170                 $target = "All" if !$target;
 171
 172                 if (@list > 0) {
 173                   broadcast_list("$to$target de $field[1]: $text", @list);
 174                 } else {
 175                   broadcast_users("$target de $field[1]: $text");
 176                 }
 177                 Log('ann', $target, $field[1], $text);
 178
 179                 return if $field[2] eq $main::mycall;   # it's routed to me
 180           } else {
 181             route($field[2], $line);
 182                 return;                     # only on a routed one
 183           }
 184
 185           last SWITCH;
 186         }
 187
 188     if ($pcno == 13) {last SWITCH;}
 189     if ($pcno == 14) {last SWITCH;}
 190     if ($pcno == 15) {last SWITCH;}
 191
 192     if ($pcno == 16) {              # add a user
 193           my $node = DXCluster->get($field[1]);
 194           last SWITCH if !$node;        # ignore if havn't seen a PC19 for this one yet
 195           my $i;
 196
 197           for ($i = 2; $i < $#field; $i++) {
 198             my ($call, $confmode, $here) = $field[$i] =~ /^(\w+) (-) (\d)/o;
 199                 next if length $call < 3;
 200                 next if !$confmode;
 201                 $call = uc $call;
 202         $call =~ s/-\d+$//o;        # remove ssid
 203                 next if DXCluster->get($call);    # we already have this (loop?)
 204
 205                 $confmode = $confmode eq '*';
 206                 DXNodeuser->new($self, $node, $call, $confmode, $here);
 207
 208                 # add this station to the user database, if required
 209                 my $user = DXUser->get_current($call);
 210                 $user = DXUser->new($call) if !$user;
 211                 $user->node($node->call) if !$user->node;
 212                 $user->put;
 213           }
 214
 215           # queue up any messages (look for privates only)
 216           DXMsg::queue_msg(1) if $self->state eq 'normal';
 217           last SWITCH;
 218         }
 219
 220     if ($pcno == 17) {              # remove a user
 221           my $ref = DXCluster->get($field[1]);
 222           $ref->del() if $ref;
 223           last SWITCH;
 224         }
 225
 226     if ($pcno == 18) {              # link request
 227           $self->send_local_config();
 228           $self->send(pc20());
 229       $self->state('init');
 230           last SWITCH;
 231         }
 232
 233     if ($pcno == 19) {               # incoming cluster list
 234       my $i;
 235           for ($i = 1; $i < $#field-1; $i += 4) {
 236             my $here = $field[$i];
 237             my $call = uc $field[$i+1];
 238                 my $confmode = $field[$i+2] eq '*';
 239                 my $ver = $field[$i+3];
 240
 241                 # now check the call over
 242                 next if DXCluster->get($call);   # we already have this
 243
 244                 # check for sane parameters
 245                 next if $ver < 5000;             # only works with version 5 software
 246                 next if length $call < 3;        # min 3 letter callsigns
 247         DXNode->new($self, $call, $confmode, $here, $ver);
 248
 249         # unbusy and stop and outgoing mail (ie if somehow we receive another PC19 without a disconnect)
 250                 my $mref = DXMsg::get_busy($call);
 251                 $mref->stop_msg($self) if $mref;
 252
 253                 # add this station to the user database, if required
 254                 my $user = DXUser->get_current($call);
 255                 $user = DXUser->new($call) if !$user;
 256                 $user->node($call) if !$user->node;
 257                 $user->sort('A');
 258                 $user->put;
 259           }
 260
 261           # queue up any messages
 262           DXMsg::queue_msg() if $self->state eq 'normal';
 263           last SWITCH;
 264         }
 265
 266     if ($pcno == 20) {              # send local configuration
 267           $self->send_local_config();
 268           $self->send(pc22());
 269           $self->state('normal');
 270
 271           # queue mail
 272           DXMsg::queue_msg();
 273           return;
 274         }
 275
 276     if ($pcno == 21) {             # delete a cluster from the list
 277           my $call = uc $field[1];
 278           if ($call ne $main::mycall) {              # don't allow malicious buggers to disconnect me!
 279             my $ref = DXCluster->get($call);
 280             $ref->del() if $ref;
 281           }
 282           last SWITCH;
 283         }
 284
 285     if ($pcno == 22) {last SWITCH;}
 286
 287     if ($pcno == 23 || $pcno == 27) {  # WWV info
 288           Geomag::update(@field[1..$#field]);
 289       last SWITCH;
 290         }
 291
 292     if ($pcno == 24) {             # set here status
 293           my $call = uc $field[1];
 294           $call =~ s/-\d+//o;
 295           my $ref = DXCluster->get($call);
 296           $ref->here($field[2]) if $ref;
 297           last SWITCH;
 298         }
 299
 300     if ($pcno == 25) {last SWITCH;}
 301
 302     if (($pcno >= 28 && $pcno <= 33) || $pcno == 40 || $pcno == 42) {   # mail/file handling
 303                 DXMsg::process($self, $line);
 304                 return;
 305         }
 306
 307     if ($pcno == 34 || $pcno == 36) {   # remote commands (incoming)
 308                 if ($field[1] eq $main::mycall) {
 309                         my $ref = DXUser->get_current($field[2]);
 310                         Log('rcmd', 'in', $ref->{priv}, $field[2], $field[3]);
 311                         if ($ref->{priv}) {        # you have to have SOME privilege, the commands have further filtering
 312                                 $self->{remotecmd} = 1; # for the benefit of any command that needs to know
 313                                 my @in = (DXCommandmode::run_cmd($self, $field[3]));
 314                                 for (@in) {
 315                                         s/\s*$//og;
 316                                         $self->send(pc35($main::mycall, $field[2], "$main::mycall:$_"));
 317                                         Log('rcmd', 'out', $field[2], $_);
 318                                 }
 319                                 delete $self->{remotecmd};
 320                         }
 321                 } else {
 322                         route($field[1], $line);
 323                 }
 324                 return;
 325         }
 326
 327     if ($pcno == 35) {                  # remote command replies
 328                 if ($field[1] eq $main::mycall) {
 329                         my $s = DXChannel::get($main::myalias);
 330                         my @ref = grep { $_->pc34to eq $field[2] } DXChannel::get_all();     # people that have rcmded someone
 331                         push @ref, $s if $s;
 332
 333                         foreach (@ref) {
 334                                 $_->send($field[3]);
 335                         }
 336                 } else {
 337                         route($field[1], $line);
 338                 }
 339                 return;
 340         }
 341
 342     if ($pcno == 37) {last SWITCH;}
 343
 344         if ($pcno == 38) {                  # node connected list from neighbour
 345           return;
 346         }
 347
 348     if ($pcno == 39) {              # incoming disconnect
 349       $self->disconnect();
 350           return;
 351         }
 352
 353     if ($pcno == 41) {              # user info
 354       # add this station to the user database, if required
 355           $field[1] =~ s/-\d+$//o;
 356           my $user = DXUser->get_current($field[1]);
 357           $user = DXUser->new($field[1]) if !$user;
 358
 359           if ($field[2] == 1) {
 360             $user->name($field[3]);
 361           } elsif ($field[2] == 2) {
 362             $user->qth($field[3]);
 363           } elsif ($field[2] == 3) {
 364         my ($latd, $latm, $latl, $longd, $longm, $longl) = split /\s+/, $field[3];
 365                 $longd += ($longm/60);
 366                 $longd = 0-$longd if (uc $longl) eq 'W';
 367                 $user->long($longd);
 368                 $latd += ($latm/60);
 369                 $latd = 0-$latd if (uc $latl) eq 'S';
 370                 $user->lat($latd);
 371           } elsif ($field[2] == 4) {
 372             $user->node($field[3]);
 373           }
 374           $user->put;
 375           last SWITCH;
 376         }
 377     if ($pcno == 43) {last SWITCH;}
 378     if ($pcno == 44) {last SWITCH;}
 379     if ($pcno == 45) {last SWITCH;}
 380     if ($pcno == 46) {last SWITCH;}
 381     if ($pcno == 47) {last SWITCH;}
 382     if ($pcno == 48) {last SWITCH;}
 383     if ($pcno == 49) {last SWITCH;}
 384
 385     if ($pcno == 50) {              # keep alive/user list
 386           my $ref = DXCluster->get($field[1]);
 387           $ref->update_users($field[2]) if $ref;
 388           last SWITCH;
 389         }
 390
 391     if ($pcno == 51) {              # incoming ping requests/answers
 392
 393           # is it for us?
 394           if ($field[1] eq $main::mycall) {
 395             my $flag = $field[3];
 396             $flag ^= 1;
 397             $self->send($self->pc51($field[2], $field[1], $flag));
 398           } else {
 399             # route down an appropriate thingy
 400                 route($field[1], $line);
 401           }
 402           return;
 403         }
 404   }
 405
 406   # if get here then rebroadcast the thing with its Hop count decremented (if
 407   # there is one). If it has a hop count and it decrements to zero then don't
 408   # rebroadcast it.
 409   #
 410   # NOTE - don't arrive here UNLESS YOU WANT this lump of protocol to be
 411   #        REBROADCAST!!!!
 412   #
 413
 414   my $hops;
 415   if (($hops) = $line =~ /H(\d+)\^\~?$/o) {
 416         my $newhops = $hops - 1;
 417         if ($newhops > 0) {
 418           $line =~ s/\^H$hops(\^\~?)$/\^H$newhops$1/;       # change the hop count
 419           broadcast_ak1a($line, $self);             # send it to everyone but me
 420         }
 421   }
 422 }
 423
 424 #
 425 # This is called from inside the main cluster processing loop and is used
 426 # for despatching commands that are doing some long processing job
 427 #
 428 sub process
 429 {
 430   my $t = time;
 431   my @chan = DXChannel->get_all();
 432   my $chan;
 433
 434   foreach $chan (@chan) {
 435     next if !$chan->is_ak1a();
 436
 437     # send a pc50 out on this channel
 438     if ($t >= $chan->pc50_t + $DXProt::pc50_interval) {
 439       $chan->send(pc50());
 440           $chan->pc50_t($t);
 441         }
 442   }
 443
 444   my $key;
 445   my $val;
 446   my $cutoff;
 447   if ($main::systime - 3600 > $last_hour) {
 448     $cutoff  = $main::systime - $pc11_dup_age;
 449         while (($key, $val) = each %dup) {
 450           delete $dup{$key} if $val < $cutoff;
 451         }
 452         $last_hour = $main::systime;
 453   }
 454 }
 455
 456 #
 457 # finish up a pc context
 458 #
 459 sub finish
 460 {
 461   my $self = shift;
 462   my $ref = DXCluster->get($self->call);
 463
 464   # unbusy and stop and outgoing mail
 465   my $mref = DXMsg::get_busy($self->call);
 466   $mref->stop_msg($self) if $mref;
 467
 468   # broadcast to all other nodes that all the nodes connected to via me are gone
 469   my @gonenodes = map { $_->dxchan == $self ? $_ : () } DXNode::get_all();
 470   my $node;
 471
 472   foreach $node (@gonenodes) {
 473     next if $node->call eq $self->call;
 474     broadcast_ak1a(pc21($node->call, 'Gone'), $self);    # done like this 'cos DXNodes don't have a pc21 method
 475         $node->del();
 476   }
 477
 478   # now broadcast to all other ak1a nodes that I have gone
 479   broadcast_ak1a(pc21($self->call, 'Gone.'), $self);
 480   Log('DXProt', $self->call . " Disconnected");
 481   $ref->del() if $ref;
 482 }
 483
 484 #
 485 # some active measures
 486 #
 487
 488 sub send_local_config
 489 {
 490   my $self = shift;
 491   my $n;
 492
 493   # send our nodes
 494   my @nodes = DXNode::get_all();
 495
 496   # create a list of all the nodes that are not connected to this connection
 497   @nodes = grep { $_->dxchan != $self } @nodes;
 498   $self->send($me->pc19(@nodes));
 499
 500   # get all the users connected on the above nodes and send them out
 501   foreach $n (@nodes) {
 502     my @users = values %{$n->list};
 503     $self->send(DXProt::pc16($n, @users));
 504   }
 505 }
 506
 507 #
 508 # route a message down an appropriate interface for a callsign
 509 #
 510 # is called route(to, pcline);
 511 #
 512 sub route
 513 {
 514   my ($call, $line) = @_;
 515   my $cl = DXCluster->get($call);
 516   if ($cl) {
 517     my $hops;
 518         my $dxchan = $cl->{dxchan};
 519         if (($hops) = $line =~ /H(\d+)\^\~?$/o) {
 520           my $newhops = $hops - 1;
 521           if ($newhops > 0) {
 522             $line =~ s/\^H$hops(\^\~?)$/\^H$newhops$1/;       # change the hop count
 523                 $dxchan->send($line) if $dxchan;
 524           }
 525         } else {
 526           $dxchan->send($line) if $dxchan;                    # for them wot don't have Hops
 527         }
 528   }
 529 }
 530
 531 # broadcast a message to all clusters [except those mentioned after buffer]
 532 sub broadcast_ak1a
 533 {
 534   my $s = shift;                  # the line to be rebroadcast
 535   my @except = @_;                # to all channels EXCEPT these (dxchannel refs)
 536   my @chan = get_all_ak1a();
 537   my $chan;
 538
 539   foreach $chan (@chan) {
 540      next if grep $chan == $_, @except;
 541          $chan->send($s);              # send it if it isn't the except list
 542   }
 543 }
 544
 545 # broadcast to all users
 546 sub broadcast_users
 547 {
 548   my $s = shift;                  # the line to be rebroadcast
 549   my @except = @_;                # to all channels EXCEPT these (dxchannel refs)
 550   my @chan = get_all_users();
 551   my $chan;
 552
 553   foreach $chan (@chan) {
 554     next if grep $chan == $_, @except;
 555         $chan->send($s);              # send it if it isn't the except list
 556   }
 557 }
 558
 559 # broadcast to a list of users
 560 sub broadcast_list
 561 {
 562   my $s = shift;
 563   my $chan;
 564
 565   foreach $chan (@_) {
 566         $chan->send($s);              # send it
 567   }
 568 }
 569
 570 #
 571 # gimme all the ak1a nodes
 572 #
 573 sub get_all_ak1a
 574 {
 575   my @list = DXChannel->get_all();
 576   my $ref;
 577   my @out;
 578   foreach $ref (@list) {
 579     push @out, $ref if $ref->is_ak1a;
 580   }
 581   return @out;
 582 }
 583
 584 # return a list of all users
 585 sub get_all_users
 586 {
 587   my @list = DXChannel->get_all();
 588   my $ref;
 589   my @out;
 590   foreach $ref (@list) {
 591     push @out, $ref if $ref->is_user;
 592   }
 593   return @out;
 594 }
 595
 596 # return a list of all user callsigns
 597 sub get_all_user_calls
 598 {
 599   my @list = DXChannel->get_all();
 600   my $ref;
 601   my @out;
 602   foreach $ref (@list) {
 603     push @out, $ref->call if $ref->is_user;
 604   }
 605   return @out;
 606 }
 607
 608 #
 609 # obtain the hops from the list for this callsign and pc no
 610 #
 611
 612 sub get_hops
 613 {
 614   my ($pcno) = @_;
 615   my $hops = $DXProt::hopcount{$pcno};
 616   $hops = $DXProt::def_hopcount if !$hops;
 617   return "H$hops";
 618 }
 619
 620 # remove leading and trailing spaces from an input string
 621 sub unpad
 622 {
 623   my $s = shift;
 624   $s =~ s/^\s+|\s+$//;
 625   return $s;
 626 }
 627 1;
 628 __END__