perl/RBN.pm

   1 #
   2 # The RBN connection system
   3 #
   4 # Copyright (c) 2020 Dirk Koopman G1TLH
   5 #
   6
   7 use warnings;
   8 use strict;
   9
  10 package RBN;
  11
  12 use 5.10.1;
  13
  14 use DXUtil;
  15 use DXDebug;
  16 use DXLog;
  17 use DXUser;
  18 use DXChannel;
  19 use Math::Round qw(nearest);
  20 use Date::Parse;
  21 use Time::HiRes qw(clock_gettime CLOCK_REALTIME);
  22 use Spot;
  23
  24 our @ISA = qw(DXChannel);
  25
  26 our $startup_delay = 5*60;              # don't send anything out until this timer has expired
  27                                 # this is to allow the feed to "warm up" with duplicates
  28                                 # so that the "big rush" doesn't happen.
  29
  30 our $minspottime = 60*60;               # the time between respots of a callsign - if a call is
  31                                 # still being spotted (on the same freq) and it has been
  32                                 # spotted before, it's spotted again after this time
  33                                 # until the next minspottime has passed.
  34
  35 our $beacontime = 5*60;                 # same as minspottime, but for beacons (and shorter)
  36
  37 our $dwelltime = 6;                     # the amount of time to wait for duplicates before issuing
  38                                 # a spot to the user (no doubt waiting with bated breath).
  39
  40 our $filterdef = $Spot::filterdef; # we use the same filter as the Spot system. Can't think why.
  41
  42 sub new
  43 {
  44         my $self = DXChannel::alloc(@_);
  45
  46         # routing, this must go out here to prevent race condx
  47         my $pkg = shift;
  48         my $call = shift;
  49
  50 #       DXProt::_add_thingy($main::routeroot, [$call, 0, 0, 1, undef, undef, $self->hostname], );
  51         $self->{spot} = {};
  52         $self->{last} = 0;
  53         $self->{noraw} = 0;
  54         $self->{nospot} = 0;
  55         $self->{norbn} = 0;
  56         $self->{sort} = 'N';
  57         $self->{lasttime} = $main::systime;
  58         $self->{minspottime} = $minspottime;
  59         $self->{beacontime} = $beacontime;
  60         $self->{showstats} = 0;
  61
  62         return $self;
  63 }
  64
  65 sub start
  66 {
  67         my ($self, $line, $sort) = @_;
  68         my $user = $self->{user};
  69         my $call = $self->{call};
  70         my $name = $user->{name};
  71
  72         # log it
  73         my $host = $self->{conn}->peerhost;
  74         $host ||= "unknown";
  75         $self->{hostname} = $host;
  76
  77         $self->{name} = $name ? $name : $call;
  78         $self->state('prompt');         # a bit of room for further expansion, passwords etc
  79         $self->{lang} = $user->lang || $main::lang || 'en';
  80         if ($line =~ /host=/) {
  81                 my ($h) = $line =~ /host=(\d+\.\d+\.\d+\.\d+)/;
  82                 $line =~ s/\s*host=\d+\.\d+\.\d+\.\d+// if $h;
  83                 unless ($h) {
  84                         ($h) = $line =~ /host=([\da..fA..F:]+)/;
  85                         $line =~ s/\s*host=[\da..fA..F:]+// if $h;
  86                 }
  87                 $self->{hostname} = $h if $h;
  88         }
  89         $self->{width} = 80 unless $self->{width} && $self->{width} > 80;
  90         $self->{consort} = $line;       # save the connection type
  91
  92         LogDbg('DXCommand', "$call connected from $self->{hostname}");
  93
  94         # set some necessary flags on the user if they are connecting
  95         $self->{registered} = 1;
  96         # sort out privilege reduction
  97         $self->{priv} = 0;
  98
  99         # get the filters
 100         my $nossid = $call;
 101         $nossid =~ s/-\d+$//;
 102
 103         $self->{inrbnfilter} = Filter::read_in('rbn', $call, 1)
 104                 || Filter::read_in('rbn', 'node_default', 1);
 105
 106         # clean up qra locators
 107         my $qra = $user->qra;
 108         $qra = undef if ($qra && !DXBearing::is_qra($qra));
 109         unless ($qra) {
 110                 my $lat = $user->lat;
 111                 my $long = $user->long;
 112                 $user->qra(DXBearing::lltoqra($lat, $long)) if (defined $lat && defined $long);
 113         }
 114
 115         # start inrush timer
 116         $self->{inrushpreventor} = $main::systime + $startup_delay;
 117 }
 118
 119 my @queue;                                              # the queue of spots ready to send
 120
 121 sub normal
 122 {
 123         my $self = shift;
 124         my $line = shift;
 125         my @ans;
 126         my $spots = $self->{spot};
 127
 128         # save this for them's that need it
 129         my $rawline = $line;
 130
 131         # remove leading and trailing spaces
 132         chomp $line;
 133         $line =~ s/^\s*//;
 134         $line =~ s/\s*$//;
 135
 136         # add base RBN
 137
 138         my $tim = $main::systime;
 139
 140         # parse line
 141         dbg "RBN:RAW,$line" if isdbg('rbnraw');
 142         return unless $line=~/^DX\s+de/;
 143
 144         my (undef, undef, $origin, $qrg, $call, $mode, $s, $m, $spd, $u, $sort, $t, $tx) = split /[:\s]+/, $line;
 145
 146         # fix up FT8 spots from 7001
 147         $t = $u, $u = '' if !$t && is_ztime($u);
 148         $t = $sort, $sort = '' if !$t && is_ztime($sort);
 149         my $qra = $spd, $spd = '' if is_qra($spd);
 150         $u = $qra if $qra;
 151
 152         $origin =~ s/\-(?:\d{1,2}\-)?\#$//; # get rid of all the crap we aren't interested in
 153
 154
 155         $sort ||= '';
 156         $tx ||= '';
 157         $qra ||= '';
 158     dbg qq{or:$origin qr:$qrg ca:$call mo:$mode s:$s m:$m sp:$spd u:$u sort:$sort t:$t tx:$tx qra:$qra} if isdbg('rbn');
 159
 160
 161         my $b;
 162
 163         if ($t || $tx) {
 164
 165                 # fix up times for things like 'NXDXF B' etc
 166                 if ($tx && is_ztime($t)) {
 167                         if (is_ztime($tx)) {
 168                                 $b = $t;
 169                                 $t = $tx;
 170                         } else {
 171                                 dbg "RBN:ERR,$line";
 172                                 return (0);
 173                         }
 174                 }
 175                 if ($sort && $sort eq 'NCDXF') {
 176                         $mode = 'DXF';
 177                         $t = $tx;
 178                 }
 179                 if ($sort && $sort eq 'BEACON') {
 180                         $mode = 'BCN';
 181                 }
 182                 if ($mode =~ /^PSK/) {
 183                         $mode = 'PSK';
 184                 }
 185                 if ($mode eq 'RTTY') {
 186                         $mode = 'RTT';
 187                 }
 188
 189                 # The main de-duping key is [call, $frequency], but we probe a bit around that frequency to find a
 190                 # range of concurrent frequencies that might be in play.
 191
 192                 # The key to this is deducing the true callsign by "majority voting" (the greater the number of spotters
 193         # the more effective this is) together with some lexical analsys probably in conjuction with DXSpider
 194                 # data sources (for singleton spots) to then generate a "centre" from and to zone (whatever that will mean if it isn't the usual one)
 195                 # and some heuristical "Kwalitee" rating given distance from the zone centres of spotter, recipient user
 196         # and spotted. A map can be generated once per user and spotter as they are essentially mostly static.
 197                 # The spotted will only get a coarse position unless other info is available. Programs that parse
 198                 # DX bulletins and the online data online databases could be be used and then cached.
 199
 200                 # Obviously users have to opt in to receiving RBN spots and other users will simply be passed over and
 201                 # ignored.
 202
 203                 # Clearly this will only work in the 'mojo' branch of DXSpider where it is possible to pass off external
 204                 # data requests to ephemeral or semi resident forked processes that do any grunt work and the main
 205                 # process to just the standard "message passing" which has been shown to be able to sustain over 5000
 206                 # per second (limited by the test program's output and network speed, rather than DXSpider's handling).
 207
 208                 my $nqrg = nearest(1, $qrg);  # normalised to nearest Khz
 209                 my $sp = "$call|$nqrg";           # hopefully the skimmers will be calibrated at least this well!
 210                 my $spp = sprintf("$call|%d", $nqrg+1); # but, clearly, my hopes are rudely dashed
 211                 my $spm = sprintf("$call|%d", $nqrg-1); # in BOTH directions!
 212
 213                 # do we have it?
 214                 my $spot = $spots->{$sp};
 215                 $spot = $spots->{$spp}, $sp = $spp, dbg(qq{RBN: SPP using $spp for $sp}) if !$spot && exists $spots->{$spp};
 216                 $spot = $spots->{$spm}, $sp = $spm, dbg(qq{RBN: SPM using $spm for $sp}) if !$spot && exists $spots->{$spm};
 217
 218
 219                 # if we have one and there is only one slot and that slot's time isn't expired for respot then return
 220                 my $respot = 0;
 221                 if ($spot && ref $spot) {
 222                         if (@$spot == 1) {
 223                                 unless ($self->{minspottime} > 0 && $tim - $spot->[0] >= $self->{minspottime}) {
 224                                         dbg("RBN: key: '$sp' call: $call qrg: $qrg DUPE \@ ". atime(int $spot->[0])) if isdbg('rbn');
 225                                         return;
 226                                 }
 227
 228                                 dbg("RBN: key: '$sp' RESPOTTING call: $call qrg: $qrg last seen \@ ". atime(int $spot->[0])) if isdbg('rbn');
 229                                 undef $spot;    # it's about to be recreated (in one place)
 230                                 ++$respot;
 231                         }
 232
 233                         # otherwise we have a spot being built up at the moment
 234                 } elsif ($spot) {
 235                         dbg("RBN: key '$sp' = '$spot' not ref");
 236                         return;
 237                 }
 238
 239                 # here we either have an existing spot record buildup on the go, or we need to create the first one
 240                 unless ($spot) {
 241                         $spots->{$sp} = $spot = [clock_gettime(CLOCK_REALTIME)];;
 242                         dbg("RBN: key: '$sp' call: $call qrg: $qrg NEW" . $respot ? ' RESPOT' : '') if isdbg('rbn');
 243                 }
 244
 245                 # add me to the display queue unless we are waiting for initial in rush to finish
 246                 return unless $self->{inrushpreventor} < $main::systime;
 247                 push @{$self->{queue}}, $sp if @$spot == 1; # queue the KEY (not the record)
 248
 249                 # build up a new record and store it in the buildup
 250                 # deal with the unix time
 251                 my ($hh,$mm) = $t =~ /(\d\d)(\d\d)Z$/;
 252                 my $utz = $hh*3600 + $mm*60 + $main::systime_daystart; # possible issue with late spot from previous day
 253                 $utz -= 86400 if $utz > $tim+3600;                                         # too far ahead, drag it back one day
 254
 255                 # create record and add into the buildup
 256                 my $r = [$origin, nearest(.1, $qrg), $call, $mode, $s, $t, $utz, $respot, $u];
 257                 dbg("RBN: key: '$sp' ADD RECORD call: $call qrg: $qrg origin: $origin") if isdbg('rbn');
 258                 my @s =  Spot::prepare($r->[1], $r->[2], $r->[6], '', $r->[0]);
 259                 if ($self->{inrbnfilter}) {
 260                         my ($want, undef) = $self->{inrbnfilter}->it($s);
 261                         next unless $want;
 262                 }
 263                 $r->[9] = \@s;
 264
 265                 push @$spot, $r;
 266
 267                 # At this point we run the queue to see if anything can be sent onwards to the punter
 268                 my $now = clock_gettime(CLOCK_REALTIME);
 269
 270                 # now run the waiting queue which just contains KEYS ($call|$qrg)
 271                 foreach $sp (@{$self->{queue}}) {
 272                         my $cand = $spots->{$sp};
 273                         unless ($cand && $cand->[0]) {
 274                                 dbg "RBN Cand " . ($cand ? 'def' : 'undef') . " [0] " . ($cand->[0] ? 'def' : 'undef') . " dwell $dwelltime";
 275                                 next;
 276                         }
 277                         if ($now >= $cand->[0] + $dwelltime ) {
 278                                 # we have a candidate, create qualitee value(s);
 279                                 unless (@$cand > 1) {
 280                                         dbg "RBN: QUEUE key '$sp' MISSING RECORDS " . dd($cand) if isdbg 'rbn';
 281                                         shift @{$self->{queue}};
 282                                         next;
 283                                 }
 284                                 my $savedtime = shift @$cand; # save the start time
 285                                 my $r = $cand->[0];
 286                                 my $quality = @$cand;
 287                                 $quality = 9 if $quality > 9;
 288                                 $quality = "Q:$quality";
 289                                 if (isdbg('progress')) {
 290                                         my $s = "RBN: SPOT key: '$sp' = $r->[2] on $r->[1] \@ $r->[5] $quality";
 291                                         $s .=  " route: $self->{call}";
 292                                         dbg($s);
 293                                 }
 294
 295                                 send_dx_spot($self, $quality, $cand);
 296
 297                                 # clear out the data and make this now just "spotted", but no further action required until respot time
 298                                 dbg "RBN: QUEUE key '$sp' cleared" if isdbg 'rbn';
 299
 300                                 $spots->{$sp} = [$savedtime];
 301                                 shift @{$self->{queue}};
 302                         } else {
 303                                 dbg sprintf("RBN: QUEUE key: '$sp' SEND time not yet reached %.1f secs left", $spot->[0] + $dwelltime - $now) if isdbg 'rbnqueue';
 304                         }
 305                 }
 306
 307
 308         } else {
 309                 dbg "RBN:DATA,$line" if isdbg('rbn');
 310         }
 311
 312         #       # periodic clearing out of the two caches
 313         if (($tim % 60 == 0 && $tim > $self->{last}) || ($self->{last} && $tim >= $self->{last} + 60)) {
 314                 my $count = 0;
 315                 my $removed = 0;
 316                 while (my ($k,$v) = each %{$spots}) {
 317                         if ($tim - $v->[0] > $self->{minspottime}*2) {
 318                                 delete $spots->{$k};
 319                                 ++$removed;
 320                         }
 321                         else {
 322                                 ++$count;
 323                         }
 324                 }
 325                 dbg "RBN:ADMIN,$self->{call},spot cache remain: $count removed: $removed"; # if isdbg('rbn');
 326                 dbg "RBN:" . join(',', "STAT", $self->{noraw}, $self->{norbn}, $self->{nospot}) if $self->{showstats};
 327                 $self->{noraw} = $self->{norbn} = $self->{nospot} = 0;
 328                 $self->{last} = int($tim / 60) * 60;
 329         }
 330 }
 331
 332
 333
 334 #       }
 335 # }
 336
 337 # we should get the spot record minus the time, so just an array of record (arrays)
 338 sub send_dx_spot
 339 {
 340         my $self = shift;
 341         my $quality = shift;
 342         my $spot = shift;
 343
 344         # $r = [$origin, $qrg, $call, $mode, $s, $utz, $respot];
 345
 346         my $mode = $spot->[0]->[3]; # as all the modes will be the same;
 347
 348         my @dxchan = DXChannel::get_all();
 349
 350         foreach my $dxchan (@dxchan) {
 351                 next unless $dxchan->is_user;
 352                 my $user = $dxchan->{user};
 353                 next unless $user &&  $user->wantrbn;
 354
 355                 # does this user want this sort of spot at all?
 356                 my $want = 0;
 357                 ++$want if $user->wantbeacon && $mode =~ /^BCN|DXF/;
 358                 ++$want if $user->wantcw && $mode =~ /^CW/;
 359                 ++$want if $user->wantrtty && $mode =~ /^RTT/;
 360                 ++$want if $user->wantpsk && $mode =~ /^PSK/;
 361                 ++$want if $user->wantcw && $mode =~ /^CW/;
 362                 ++$want if $user->wantft && $mode =~ /^FT/;
 363                 ++$want unless $want;   # send everything if nothing is selected.
 364
 365                 next unless $want;
 366
 367                 # send one spot to one user out of the ones that we have
 368                 $self->dx_spot($dxchan, $quality, $spot) if $want;
 369         }
 370 }
 371
 372 sub dx_spot
 373 {
 374         my $self = shift;
 375         my $dxchan = shift;
 376         my $quality = shift;
 377         my $spot = shift;
 378
 379         my $strength = 100;             # because it could if we talk about FTx
 380         my $saver;
 381
 382         my %zone;
 383         my %qrg;
 384         my $respot;
 385         my $qra;
 386
 387         foreach my $r (@$spot) {
 388                 # $r = [$origin, $qrg, $call, $mode, $s, $t, $utz, $respot, $qra];
 389                 # Spot::prepare($qrg, $call, $utz, $comment, $origin);
 390
 391                 my $comment = sprintf "%-3s %2ddB $quality", $r->[3], $r->[4];
 392                 $respot = 1 if $r->[7];
 393                 $qra = $r->[8] if !$qra && $r->[8] && is_qra($r->[8]);
 394
 395                 my $s = $r->[9];                # the prepared spot
 396                 $s->[3] = $comment;             # apply new generated comment
 397
 398
 399                 ++$zone{$s->[11]};              # save the spotter's zone
 400                 ++$qrg{$s->[0]};                # and the qrg
 401
 402
 403                 my $want = 0;
 404                 my $rf = $dxchan->{rbnfilter} || $dxchan->{spotsfilter};
 405                 if ($rf) {
 406                         ($want, undef) = $rf->it($s);
 407                         next unless $want;
 408                         $saver = $s;
 409                         dbg("RBN: FILTERED call: $s->[1] qrg: $s->[0] origin: $s->[4] dB: $r->[4]") if isdbg 'rbn';
 410                         last;
 411                 }
 412
 413                 # save the lowest strength one
 414                 if ($r->[4] < $strength) {
 415                         $strength = $r->[4];
 416                         $saver = $s;
 417                         dbg("RBN: STRENGTH call: $s->[1] qrg: $s->[0] origin: $s->[4] dB: $r->[4]") if isdbg 'rbn';
 418                 }
 419         }
 420
 421         if ($saver) {
 422                 my $buf;
 423                 # create a zone list of spotters
 424                 delete $zone{$saver->[11]};  # remove this spotter's zone (leaving all the other zones)
 425                 my $z = join ',', sort {$a <=> $b} keys %zone;
 426
 427                 # determine the most likely qrg and then set it
 428                 my $mv = 0;
 429                 my $fk;
 430                 my $c = 0;
 431                 while (my ($k, $v) = each %qrg) {
 432                         $fk = $k, $mv = $v if $v > $mv;
 433                         ++$c;
 434                 }
 435                 $saver->[0] = $fk;
 436                 $saver->[3] .= '*' if $c > 1;
 437                 $saver->[3] .= '+' if $respot;
 438                 $saver->[3] .= " Z:$z" if $z;
 439
 440                 dbg("RBN: SENDING call: $saver->[1] qrg: $saver->[0] origin: $saver->[4] $saver->[3]") if isdbg 'rbn';
 441                 if ($dxchan->{ve7cc}) {
 442                         my $call = $saver->[4];
 443                         $saver->[4] .= '-#';
 444                         $buf = VE7CC::dx_spot($dxchan, @$saver);
 445                         $saver->[4] = $call;
 446                 } else {
 447                         $buf = $dxchan->format_dx_spot(@$saver);
 448                 }
 449                 $buf =~ s/^DX/RB/;
 450                 $dxchan->local_send('N', $buf);
 451
 452                 if ($qra) {
 453                         my $user = DXUser::get_current($saver->[1]) || DXUser->new($saver->[1]);
 454                         unless ($user->qra && is_qra($user->qra)) {
 455                                 $user->qra($qra);
 456                                 dbg("RBN: update qra on $saver->[1] to $qra");
 457                                 $user->put;
 458                         }
 459                 }
 460         }
 461 }
 462
 463 1;