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 lib qw {.};
  15
  16 use DXDebug;
  17 use DXUtil;
  18 use DXLog;
  19 use DXUser;
  20 use DXChannel;
  21 use Math::Round qw(nearest nearest_floor);
  22 use Date::Parse;
  23 use Time::HiRes qw(gettimeofday);
  24 use Spot;
  25 use DXJSON;
  26 use IO::File;
  27
  28 use constant {
  29                           ROrigin => 0,
  30                           RQrg => 1,
  31                           RCall => 2,
  32                           RMode => 3,
  33                           RStrength => 4,
  34                           RTime => 5,
  35                           RUtz => 6,
  36                           Respot => 7,
  37                           RQra => 8,
  38                           RSpotData => 9,
  39                          };
  40
  41 use constant {
  42                           SQrg => 0,
  43                           SCall => 1,
  44                           STime => 2,
  45                           SComment => 3,
  46                           SOrigin => 4,
  47                           SZone => 11,
  48                          };
  49 use constant {
  50                           OQual => 0,
  51                           OAvediff => 1,
  52                           OSpare => 2,
  53                           ODiff => 3,
  54                          };
  55 use constant {
  56                           CTime => 0,
  57                           CQual => 1,
  58                           CData => 2,
  59                          };
  60
  61 use constant {
  62                           DScore => 0,
  63                           DGood => 1,
  64                           DBad => 2,
  65                           DLastin => 3,
  66                           DEviants => 4,
  67                          };
  68
  69
  70 our $DATA_VERSION = 1;
  71
  72 our @ISA = qw(DXChannel);
  73
  74 our $startup_delay = 5*60;              # don't send anything out until this timer has expired
  75                                 # this is to allow the feed to "warm up" with duplicates
  76                                 # so that the "big rush" doesn't happen.
  77
  78 our $minspottime = 30*60;               # the time between respots of a callsign - if a call is
  79                                 # still being spotted (on the same freq) and it has been
  80                                 # spotted before, it's spotted again after this time
  81                                 # until the next minspottime has passed.
  82
  83 our $beacontime = 5*60;                 # same as minspottime, but for beacons (and shorter)
  84
  85 our $dwelltime = 10;                    # the amount of time to wait for duplicates before issuing
  86                                 # a spot to the user (no doubt waiting with bated breath).
  87
  88 our $limbotime = 5*60;                  # if there are fewer than $minqual candidates and $dwelltime
  89                                 # has expired then allow this spot to live a bit longer. It may
  90                                 # simply be that it is not in standard spot coverage. (ask G4PIQ
  91                                 # about this).
  92
  93 our $filterdef = $Spot::filterdef; # we use the same filter as the Spot system. Can't think why :-).
  94
  95 my $spots;                                              # the GLOBAL spot cache
  96
  97 my %runtime;                                    # how long each channel has been running
  98
  99 our $cachefn = localdata('rbn_cache');
 100 our $cache_valid = 4*60;                # The cache file is considered valid if it is not more than this old
 101
 102 our $maxqrgdiff = 10;                   # the maximum
 103 our $minqual = 2;                               # the minimum quality we will accept for output
 104 our $maxqual = 9;                               # if there is enough quality, then short circuit any remaining dwelltime.
 105
 106 my $json;
 107 my $noinrush = 0;                               # override the inrushpreventor if set
 108 our $maxdeviants = 5;                   # the number of deviant QRGs to record for skimmer records
 109
 110 sub init
 111 {
 112         $json = DXJSON->new;
 113         $json->canonical(0);
 114         if (check_cache()) {
 115                 $noinrush = 1;
 116         } else {
 117                 $spots = {VERSION=>$DATA_VERSION};
 118         }
 119         if (defined $DB::VERSION) {
 120                 $noinrush = 1;
 121                 $json->indent(1);
 122         }
 123
 124 }
 125
 126 sub new
 127 {
 128         my $self = DXChannel::alloc(@_);
 129
 130         # routing, this must go out here to prevent race condx
 131         my $pkg = shift;
 132         my $call = shift;
 133
 134         $self->{last} = 0;
 135         $self->{noraw} = 0;
 136         $self->{nospot} = 0;
 137         $self->{nouser} = {};
 138         $self->{norbn} = 0;
 139         $self->{noraw10} = 0;
 140         $self->{nospot10} = 0;
 141         $self->{nouser10} = {};
 142         $self->{norbn10} = 0;
 143         $self->{nospothour} = 0;
 144         $self->{nouserhour} = {};
 145         $self->{norbnhour} = 0;
 146         $self->{norawhour} = 0;
 147         $self->{sort} = 'N';
 148         $self->{lasttime} = $main::systime;
 149         $self->{minspottime} = $minspottime;
 150         $self->{beacontime} = $beacontime;
 151         $self->{showstats} = 0;
 152         $self->{pingint} = 0;
 153         $self->{nopings} = 0;
 154         $self->{queue} = {};
 155
 156         return $self;
 157 }
 158
 159 sub start
 160 {
 161         my ($self, $line, $sort) = @_;
 162         my $user = $self->{user};
 163         my $call = $self->{call};
 164         my $name = $user->{name};
 165
 166         # log it
 167         my $host = $self->{conn}->peerhost;
 168         $host ||= "unknown";
 169         $self->{hostname} = $host;
 170
 171         $self->{name} = $name ? $name : $call;
 172         $self->state('prompt');         # a bit of room for further expansion, passwords etc
 173         $self->{lang} = $user->lang || $main::lang || 'en';
 174         if ($line =~ /host=/) {
 175                 my ($h) = $line =~ /host=(\d+\.\d+\.\d+\.\d+)/;
 176                 $line =~ s/\s*host=\d+\.\d+\.\d+\.\d+// if $h;
 177                 unless ($h) {
 178                         ($h) = $line =~ /host=([\da..fA..F:]+)/;
 179                         $line =~ s/\s*host=[\da..fA..F:]+// if $h;
 180                 }
 181                 if ($h) {
 182                         $h =~ s/^::ffff://;
 183                         $self->{hostname} = $h;
 184                 }
 185         }
 186         $self->{width} = 80 unless $self->{width} && $self->{width} > 80;
 187         $self->{consort} = $line;       # save the connection type
 188
 189         LogDbg('DXCommand', "$call connected from $self->{hostname}");
 190
 191         # set some necessary flags on the user if they are connecting
 192         $self->{registered} = 1;
 193         # sort out privilege reduction
 194         $self->{priv} = 0;
 195
 196         # get the filters
 197         my $nossid = $call;
 198         $nossid =~ s/-\d+$//;
 199
 200         $self->{inrbnfilter} = Filter::read_in('rbn', $call, 1)
 201                 || Filter::read_in('rbn', 'node_default', 1);
 202
 203         # clean up qra locators
 204         my $qra = $user->qra;
 205         $qra = undef if ($qra && !DXBearing::is_qra($qra));
 206         unless ($qra) {
 207                 my $lat = $user->lat;
 208                 my $long = $user->long;
 209                 $user->qra(DXBearing::lltoqra($lat, $long)) if (defined $lat && defined $long);
 210         }
 211
 212         # if we have been running and stopped for a while
 213         # if the cache is warm enough don't operate the inrush preventor
 214         $self->{inrushpreventor} = exists $runtime{$call} && $runtime{$call} > $startup_delay || $noinrush ?  0 : $main::systime + $startup_delay;
 215         dbg("RBN: noinrush: $noinrush, setting inrushpreventor on $self->{call} to $self->{inrushpreventor}");
 216 }
 217
 218 my @queue;                                              # the queue of spots ready to send
 219
 220 sub normal
 221 {
 222         my $self = shift;
 223         my $line = shift;
 224         my @ans;
 225         my $dbgrbn = isdbg('rbn');
 226
 227         # remove leading and trailing spaces
 228         chomp $line;
 229         $line =~ s/^\s*//;
 230         $line =~ s/\s*$//;
 231
 232         # add base RBN
 233
 234         my $now = $main::systime;
 235
 236         # parse line
 237         dbg "RBN:RAW,$line" if isdbg('rbnraw');
 238         return unless $line=~/^DX\s+de/;
 239
 240         my (undef, undef, $origin, $qrg, $call, $mode, $s, $m, $spd, $u, $sort, $t, $tx) = split /[:\s]+/, $line;
 241
 242         # fix up FT8 spots from 7001
 243         $t = $u, $u = '' if !$t && is_ztime($u);
 244         $t = $sort, $sort = '' if !$t && is_ztime($sort);
 245         my $qra = $spd, $spd = '' if is_qra($spd);
 246         $u = $qra if $qra;
 247
 248         # is this anything like a callsign?
 249         unless (is_callsign($call)) {
 250                 dbg("RBN: ERROR $call from $origin on $qrg is invalid, dumped");
 251                 return;
 252         }
 253
 254         # remove all extraneous crap from the origin - just leave the base callsign
 255         my $norigin = basecall($origin);
 256         unless ($norigin) {
 257                 dbg("RBN: ERROR '$origin' is an invalid callsign, dumped");
 258                 return;
 259         }
 260         $origin = $norigin;
 261
 262         # is this callsign in badspotter list?
 263         if ($DXProt::badspotter->in($origin) || $DXProt::badnode->in($origin)) {
 264                 dbg("RBN: ERROR $origin is a bad spotter/node, dumped");
 265                 return;
 266         }
 267
 268         # is the qrg valid
 269         unless ($qrg =~ /^\d+\.\d{1,3}$/) {
 270                 dbg("RBN: ERROR qrg $qrg from $origin invalid, dumped");
 271                 return;
 272         }
 273
 274         $sort ||= '';
 275         $tx ||= '';
 276         $qra ||= '';
 277     dbg qq{RBN:input decode 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 $dbgrbn && isdbg('rbn');
 278
 279         ++$self->{noraw};
 280         ++$self->{noraw10};
 281         ++$self->{norawhour};
 282
 283         my $b;
 284
 285         if ($t || $tx) {
 286
 287                 # fix up times for things like 'NXDXF B' etc
 288                 if ($tx && is_ztime($t)) {
 289                         if (is_ztime($tx)) {
 290                                 $b = $t;
 291                                 $t = $tx;
 292                         } else {
 293                                 dbg "RBN:ERR,$line";
 294                                 return (0);
 295                         }
 296                 }
 297                 if ($sort && $sort eq 'NCDXF') {
 298                         $mode = 'DXF';
 299                         $t = $tx;
 300                 }
 301                 if ($sort && $sort eq 'BEACON') {
 302                         $mode = 'BCN';
 303                 }
 304                 if ($mode =~ /^PSK/) {
 305                         $mode = 'PSK';
 306                 }
 307                 if ($mode eq 'RTTY') {
 308                         $mode = 'RTT';
 309                 }
 310
 311                 # The main de-duping key is [call, $frequency], but we probe a bit around that frequency to find a
 312                 # range of concurrent frequencies that might be in play.
 313
 314                 # The key to this is deducing the true callsign by "majority voting" (the greater the number of spotters
 315         # the more effective this is) together with some lexical analsys probably in conjuction with DXSpider
 316                 # 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)
 317                 # and some heuristical "Kwalitee" rating given distance from the zone centres of spotter, recipient user
 318         # and spotted. A map can be generated once per user and spotter as they are essentially mostly static.
 319                 # The spotted will only get a coarse position unless other info is available. Programs that parse
 320                 # DX bulletins and the online data online databases could be be used and then cached.
 321
 322                 # Obviously users have to opt in to receiving RBN spots and other users will simply be passed over and
 323                 # ignored.
 324
 325                 # Clearly this will only work in the 'mojo' branch of DXSpider where it is possible to pass off external
 326                 # data requests to ephemeral or semi resident forked processes that do any grunt work and the main
 327                 # process to just the standard "message passing" which has been shown to be able to sustain over 5000
 328                 # per second (limited by the test program's output and network speed, rather than DXSpider's handling).
 329
 330                 my $search = 5;
 331                 my $nqrg = nearest(1, $qrg * 10);  # normalised to nearest Khz
 332                 my $sp = "$call|$nqrg";           # hopefully the skimmers will be calibrated at least this well!
 333
 334                 # find it?
 335                 my $cand = $spots->{$sp};
 336                 unless ($cand) {
 337                         my ($i, $new);
 338                         for ($i = $nqrg; !$cand && $i <= $nqrg+$search; $i += 1) {
 339                                 $new = "$call|$i";
 340                                 $cand = $spots->{$new}, last if exists $spots->{$new};
 341                         }
 342                         if ($cand) {
 343                                 my $diff = $i - $nqrg;
 344                                 dbg(qq{RBN: QRG Diff using $new (+$diff) for $sp for qrg $qrg}) if (isdbg('rbnqrg') || ($dbgrbn && isdbg('rbn')));
 345                                 $sp = $new;
 346                         }
 347                 }
 348                 unless ($cand) {
 349                         my ($i, $new);
 350                         for ($i = $nqrg; !$cand && $i >= $nqrg-$search; $i -= 1) {
 351                                 $new = "$call|$i";
 352                                 $cand = $spots->{$new}, last if exists $spots->{$new};
 353                         }
 354                         if ($cand) {
 355                                 my $diff = $nqrg - $i;
 356                                 dbg(qq{RBN: QRG Diff using $new (-$diff) for $sp for qrg $qrg}) if (isdbg('rbnqrg') || ($dbgrbn && isdbg('rbn')));
 357                                 $sp = $new;
 358                         }
 359                 }
 360
 361                 # if we have one and there is only one slot and that slot's time isn't expired for respot then return
 362                 my $respot = 0;
 363                 if ($cand && ref $cand) {
 364                         if (@$cand <= CData) {
 365                                 if ($self->{minspottime} > 0 && $now - $cand->[CTime] < $self->{minspottime}) {
 366                                         dbg("RBN: key: '$sp' call: $call qrg: $qrg DUPE \@ ". atime(int $cand->[CTime])) if $dbgrbn && isdbg('rbn');
 367                                         return;
 368                                 }
 369
 370                                 dbg("RBN: key: '$sp' RESPOTTING call: $call qrg: $qrg last seen \@ ". atime(int $cand->[CTime])) if $dbgrbn && isdbg('rbn');
 371                                 $cand->[CTime] = $now;
 372                                 ++$respot;
 373                         }
 374
 375                         # otherwise we have a spot being built up at the moment
 376                 } elsif ($cand) {
 377                         dbg("RBN: key '$sp' = '$cand' not ref");
 378                         return;
 379                 } else {
 380                         # new spot / frequency
 381                         $spots->{$sp} = $cand = [$now, 0];
 382                         dbg("RBN: key: '$sp' call: $call qrg: $qrg NEW" . ($respot ? ' RESPOT' : '')) if $dbgrbn && isdbg('rbn');
 383                 }
 384
 385                 # add me to the display queue unless we are waiting for initial in rush to finish
 386                 return unless $noinrush || $self->{inrushpreventor} < $main::systime;
 387
 388                 # build up a new record and store it in the buildup
 389                 # deal with the unix time
 390                 my ($hh,$mm) = $t =~ /(\d\d)(\d\d)Z$/;
 391                 my $utz = $hh*3600 + $mm*60 + $main::systime_daystart; # possible issue with late spot from previous day
 392                 $utz -= 86400 if $utz > $now+3600;                                         # too far ahead, drag it back one day
 393
 394                 # create record and add into the buildup
 395                 my $r = [$origin, nearest(.1, $qrg), $call, $mode, $s, $t, $utz, $respot, $u];
 396                 my @s =  Spot::prepare($r->[RQrg], $r->[RCall], $r->[RUtz], '', $r->[ROrigin]);
 397                 if ($s[5] == 666) {
 398                         dbg("RBN: ERROR invalid prefix/callsign $call from $origin-# on $qrg, dumped");
 399                         return;
 400                 }
 401
 402                 if ($self->{inrbnfilter}) {
 403                         my ($want, undef) = $self->{inrbnfilter}->it($s);
 404                         return unless $want;
 405                 }
 406                 $r->[RSpotData] = \@s;
 407
 408                 ++$self->{queue}->{$sp};# unless @$cand>= CData; # queue the KEY (not the record)
 409
 410                 dbg("RBN: key: '$sp' ADD RECORD call: $call qrg: $qrg origin: $origin respot: $respot") if $dbgrbn && isdbg('rbn');
 411
 412                 push @$cand, $r;
 413
 414         } else {
 415                 dbg "RBN:DATA,$line" if $dbgrbn && isdbg('rbn');
 416         }
 417 }
 418
 419 # we should get the spot record minus the time, so just an array of record (arrays)
 420 sub send_dx_spot
 421 {
 422         my $self = shift;
 423         my $quality = shift;
 424         my $cand = shift;
 425
 426         ++$self->{norbn};
 427         ++$self->{norbn10};
 428         ++$self->{norbnhour};
 429
 430         # $r = [$origin, $qrg, $call, $mode, $s, $utz, $respot];
 431
 432         my $mode = $cand->[CData]->[RMode]; # as all the modes will be the same;
 433
 434         my @dxchan = DXChannel::get_all();
 435
 436         foreach my $dxchan (@dxchan) {
 437                 next unless $dxchan->is_user;
 438                 my $user = $dxchan->{user};
 439                 next unless $user &&  $user->wantrbn;
 440
 441                 # does this user want this sort of spot at all?
 442                 my $want = 0;
 443                 ++$want if $user->wantbeacon && $mode =~ /^BCN|DXF/;
 444                 ++$want if $user->wantcw && $mode =~ /^CW/;
 445                 ++$want if $user->wantrtty && $mode =~ /^RTT/;
 446                 ++$want if $user->wantpsk && $mode =~ /^PSK|FSK|MSK/;
 447                 ++$want if $user->wantft && $mode =~ /^FT/;
 448
 449                 dbg(sprintf("RBN: spot selection for $dxchan->{call} mode: '$mode' want: $want flags rbn:%d ft:%d bcn:%d cw:%d psk:%d rtty:%d",
 450                                         $user->wantrbn,
 451                                         $user->wantft,
 452                                         $user->wantbeacon,
 453                                         $user->wantcw,
 454                                         $user->wantpsk,
 455                                         $user->wantrtty,
 456                                    )) if isdbg('rbnll');
 457
 458                 # send one spot to one user out of the ones that we have
 459                 $self->dx_spot($dxchan, $quality, $cand) if $want;
 460         }
 461 }
 462
 463 sub dx_spot
 464 {
 465         my $self = shift;
 466         my $dxchan = shift;
 467         my $quality = shift;
 468         my $cand = shift;
 469         my $call = $dxchan->{call};
 470         my $seeme = $dxchan->user->rbnseeme();
 471         my $strength = 100;             # because it could if we talk about FTx
 472         my $saver;
 473         my %zone;
 474         my $respot;
 475         my $qra;
 476
 477         ++$self->{nousers}->{$call};
 478         ++$self->{nousers10}->{$call};
 479         ++$self->{nousershour}->{$call};
 480
 481         my $filtered;
 482         my $rf = $dxchan->{rbnfilter} || $dxchan->{spotsfilter};
 483         my $comment;
 484
 485         foreach my $r (@$cand) {
 486                 # $r = [$origin, $qrg, $call, $mode, $s, $t, $utz, $respot, $qra];
 487                 # Spot::prepare($qrg, $call, $utz, $comment, $origin);
 488                 next unless $r && ref $r;
 489
 490                 $qra = $r->[RQra] if !$qra && $r->[RQra] && is_qra($r->[RQra]);
 491
 492                 $comment = sprintf "%-3s %2ddB $quality", $r->[RMode], $r->[RStrength];
 493                 my $s = $r->[RSpotData];                # the prepared spot
 494                 $s->[SComment] = $comment;              # apply new generated comment
 495
 496                 ++$zone{$s->[SZone]};           # save the spotter's zone
 497
 498                 # if the 'see me' flag is set, then show all the spots without further adornment (see set/rbnseeme for more info)
 499                 if ($seeme) {
 500                         send_final($dxchan, $s);
 501                         next;
 502                 }
 503
 504                 # save the lowest strength one
 505                 if ($r->[RStrength] < $strength) {
 506                         $strength = $r->[RStrength];
 507                         $saver = $s;
 508                         dbg("RBN: STRENGTH spot: $s->[SCall] qrg: $s->[SQrg] origin: $s->[SOrigin] dB: $r->[RStrength] < $strength") if isdbg 'rbnll';
 509                 }
 510
 511                 if ($rf) {
 512                         my ($want, undef) = $rf->it($s);
 513                         dbg("RBN: FILTERING for $call spot: $s->[SCall] qrg: $s->[SQrg] origin: $s->[SOrigin] dB: $r->[RStrength] com: '$s->[SComment]' want: " . ($want ? 'YES':'NO')) if isdbg 'rbnll';
 514                         next unless $want;
 515                         $filtered = $s;
 516                 }
 517         }
 518
 519         if ($rf) {
 520                 $saver = $filtered;             # if nothing passed the filter's lips then $saver == $filtered == undef !
 521         }
 522
 523         if ($saver) {
 524                 my $buf;
 525                 # create a zone list of spotters
 526                 delete $zone{$saver->[SZone]};  # remove this spotter's zone (leaving all the other zones)
 527                 my $z = join ',', sort {$a <=> $b} keys %zone;
 528
 529                 # alter spot data accordingly
 530                 $saver->[SComment] .= " Z:$z" if $z;
 531
 532                 send_final($dxchan, $saver);
 533
 534                 ++$self->{nospot};
 535                 ++$self->{nospot10};
 536                 ++$self->{nospothour};
 537
 538                 if ($qra) {
 539                         my $user = DXUser::get_current($saver->[SCall]) || DXUser->new($saver->[SCall]);
 540                         unless ($user->qra && is_qra($user->qra)) {
 541                                 $user->qra($qra);
 542                                 dbg("RBN: update qra on $saver->[SCall] to $qra");
 543                                 $user->put;
 544                         }
 545                 }
 546         }
 547 }
 548
 549 sub send_final
 550 {
 551         my $dxchan = shift;
 552         my $saver = shift;
 553         my $call = $dxchan->{call};
 554         my $buf;
 555
 556         dbg("RBN: SENDING to $call spot: $saver->[SCall] qrg: $saver->[SQrg] origin: $saver->[SOrigin] $saver->[SComment]") if isdbg 'rbnll';
 557         if ($dxchan->{ve7cc}) {
 558                 my $call = $saver->[SOrigin];
 559                 $saver->[SOrigin] .= '-#';
 560                 $buf = VE7CC::dx_spot($dxchan, @$saver);
 561                 $saver->[SOrigin] = $call;
 562         } else {
 563                 my $call = $saver->[SOrigin];
 564                 $saver->[SOrigin] = substr($call, 0, 6);
 565                 $saver->[SOrigin] .= '-#';
 566                 $buf = $dxchan->format_dx_spot(@$saver);
 567                 $saver->[SOrigin] = $call;
 568         }
 569         $dxchan->local_send('N', $buf);
 570 }
 571
 572 # per second
 573 sub process
 574 {
 575         my $rbnskim = isdbg('rbnskim');
 576
 577         foreach my $dxchan (DXChannel::get_all()) {
 578                 next unless $dxchan->is_rbn;
 579
 580                 # At this point we run the queue to see if anything can be sent onwards to the punter
 581                 my $now = $main::systime;
 582                 my $ta = [gettimeofday];
 583                 my $items = 0;
 584
 585                 # now run the waiting queue which just contains KEYS ($call|$qrg)
 586                 foreach my $sp (keys %{$dxchan->{queue}}) {
 587                         my $cand = $spots->{$sp};
 588                         ++$items;
 589
 590                         unless ($cand && $cand->[CTime]) {
 591                                 dbg "RBN Cand $sp " . ($cand ? 'def' : 'undef') . " [CTime] " . ($cand->[CTime] ? 'def' : 'undef') . " dwell $dwelltime";
 592                                 delete $spots->{$sp};
 593                                 delete $dxchan->{queue}->{$sp};    # remove
 594                                 next;
 595                         }
 596
 597                         my $ctime = $cand->[CTime];
 598                         my $quality = @$cand - CData;
 599                         my $dwellsecs =  $now - $ctime;
 600                         if ($quality >= $maxqual || $dwellsecs >= $dwelltime || $dwellsecs >= $limbotime) {
 601                                 # we have a candidate, create qualitee value(s);
 602                                 unless (@$cand > CData) {
 603                                         dbg "RBN: QUEUE key '$sp' MISSING RECORDS, IGNORED" . dd($cand) if isdbg 'rbnqueue';
 604                                         delete $spots->{$sp}; # don't remember it either - this means that a spot HAS to come in with sufficient spotters to be processed.
 605                                         delete $dxchan->{queue}->{$sp};
 606                                         next;
 607                                 }
 608                                 dbg "RBN: QUEUE PROCESSING key: '$sp' $now >= $cand->[CTime]" if isdbg 'rbnqueue';
 609                                 my $spotters = $quality;
 610
 611                                 # dump it and remove it from the queue if it is of unadequate quality, but only if it is no longer in Limbo and can be reasonably passed on to its demise
 612                                 my $r = $cand->[CData];
 613                                 if ($dwellsecs > $limbotime && $quality < $minqual) {
 614                                         if ( $rbnskim && isdbg('rbnskim')) {
 615                                                 $r = $cand->[CData];
 616                                                 if ($r) {
 617                                                         my $lastin = difft($ctime, $now, 2);
 618                                                         my $s = "RBN:SKIM time in Limbo exceeded DUMPED (lastin: $lastin Q:$quality < Q:$minqual) key: '$sp' = $r->[RCall] on $r->[RQrg] by $r->[ROrigin] \@ $r->[RTime] route: $dxchan->{call}";
 619                                                         dbg($s);
 620                                                 }
 621                                         }
 622                                         delete $spots->{$sp}; # don't remember it either - this means that a spot HAS to come in with sufficient spotters to be processed.
 623                                         delete $dxchan->{queue}->{$sp};
 624                                         next;
 625                                 }
 626
 627                                 # we have a possible removal from Limbo, check for more than one skimmer and reset the quality if required
 628                                 # DOES THIS TEST CAUSE RACES?
 629                                 if (!$r->[Respot] && $quality >= $minqual && $dwellsecs > $dwelltime+1) {
 630
 631                                         # because we don't need to check for repeats by the same skimmer in the normal case, we do here
 632                                         my %seen;
 633                                         my @origin;
 634                                         foreach my $wr (@$cand) {
 635                                                 next unless ref $wr;
 636                                                 push @origin, $wr->[ROrigin];
 637                                                 if (exists $seen{$wr->[ROrigin]}) {
 638                                                         next;
 639                                                 }
 640                                                 $seen{$wr->[ROrigin]} = $wr;
 641                                         }
 642                                         # reset the quality to ignore dupes
 643                                         my $oq = $quality;
 644                                         $quality = keys %seen;
 645                                         if ($quality >= $minqual) {
 646                                                 if ( $rbnskim && isdbg('rbnskim')) {
 647                                                         my $lastin = difft($ctime, $now, 2);
 648                                                         my $sk = join ' ', keys %seen;
 649                                                         my $or = join ' ', @origin;
 650                                                         my $s = "RBN:SKIM promoted from Limbo - key: '$sp' (lastin: $lastin Q now: $quality was $oq skimmers now: $sk";
 651                                                         $s .= " was $or" if $or ne $sk;
 652                                                         $s .= ')';
 653                                                         dbg($s);
 654                                                 }
 655                                         } elsif ($oq != $quality) {
 656                                                 if ( $rbnskim && isdbg('rbnskim')) {
 657                                                         my $lastin = difft($ctime, $now, 2);
 658                                                         my $sk = join ' ', keys %seen;
 659                                                         my $or = join ' ', @origin;
 660                                                         my $s = "RBN:SKIM quality reset key: '$sp' (lastin: $lastin Q now: $quality was $oq skimmers now: $sk was: $or)";
 661                                                         dbg($s);
 662                                                 }
 663                                                 # remove the excess
 664                                                 my @ncand = (@$cand[CTime, CQual], values %seen);
 665                                                 $spots->{$sp} = \@ncand;
 666                                         }
 667                                 }
 668
 669                                 # we now kick this spot into Limbo
 670                                 if ($quality < $minqual) {
 671                                         next;
 672                                 }
 673
 674                                 $quality = 9 if $quality > 9;
 675                                 $cand->[CQual] = $quality if $quality > $cand->[CQual];
 676
 677                                 # this scores each candidate according to its skimmer's QRG score (i.e. how often it agrees with its peers)
 678                                 # what happens is hash of all QRGs in candidates are incremented by that skimmer's reputation for "accuracy"
 679                                 # or, more exactly, past agreement with the consensus. This score can be from -5 -> +5.
 680                                 my %qrg = ();
 681                                 my $skimmer;
 682                                 my $sk;
 683                                 my $band;
 684                                 my %seen = ();
 685                                 foreach $r (@$cand) {
 686                                         next unless ref $r;
 687                                         if (exists $seen{$r->[ROrigin]}) {
 688                                                 $r = 0;
 689                                                 next;
 690                                         }
 691                                         $seen{$r->[ROrigin]} = 1;
 692                                         $band ||= int $r->[RQrg] / 1000;
 693                                         $sk = "SKIM|$r->[ROrigin]|$band"; # thus only once per set of candidates
 694                                         $skimmer = $spots->{$sk};
 695                                         unless ($skimmer) {
 696                                                 $skimmer = $spots->{$sk} = [1, 0, 0, $now, []]; # this first time, this new skimmer gets the benefit of the doubt on frequency.
 697                                                 dbg("RBN:SKIM new slot $sk " . $json->encode($skimmer)) if  $rbnskim && isdbg('rbnskim');
 698                                         }
 699                                         $qrg{$r->[RQrg]} += ($skimmer->[DScore] || 1);
 700                                 }
 701
 702                                 # determine the most likely qrg and then set it - NOTE (-)ve votes, generated by the skimmer scoring system above, are ignored
 703                                 my @deviant;
 704                                 my $c = 0;
 705                                 my $mv = 0;
 706                                 my $qrg = 0;
 707                                 while (my ($k, $votes) = each %qrg) {
 708                                         if ($votes >= $mv) {
 709                                                 $qrg = $k;
 710                                                 $mv = $votes;
 711                                         }
 712                                         ++$c;
 713                                 }
 714
 715                                 # Ignore possible spots with 0 QRG score - as determined by the skimmer scoring system above -  as they are likely to be wrong
 716                                 unless ($qrg > 0) {
 717                                         if ( $rbnskim && isdbg('rbnskim')) {
 718                                                 my $keys;
 719                                                 while (my ($k, $v) = (each %qrg)) {
 720                                                         $keys .= "$k=>$v, ";
 721                                                 }
 722                                                 $keys =~ /,\s*$/;
 723                                                 my $i = 0;
 724                                                 foreach $r (@$cand) {
 725                                                         next unless $r && ref $r;
 726                                                         dbg "RBN:SKIM cand $i QRG likely wrong from '$sp' = $r->[RCall] on $r->[RQrg] by $r->[ROrigin] \@ $r->[RTime] (qrgs: $keys c: $c) route: $dxchan->{call}, ignored";
 727                                                         ++$i;
 728                                                 }
 729                                         }
 730                                         delete $spots->{$sp}; # get rid
 731                                         delete $dxchan->{queue}->{$sp};
 732                                         next;
 733                                 }
 734
 735                                 # detemine and spit out the deviants. Then adjust the scores according to whether it is a deviant or good
 736                                 # NOTE: deviant nodes can become good (or less bad), and good nodes bad (or less good) on each spot that
 737                                 # they generate. This is based solely on each skimmer's agreement (or not) with the "consensus" score generated
 738                                 # above ($qrg). The resultant score + good + bad is stored per band and will be used the next time a spot
 739                                 # appears on this band from each skimmer.
 740                                 foreach $r (@$cand) {
 741                                         next unless $r && ref $r;
 742                                         my $diff = $c > 1 ? nearest(.1, $r->[RQrg] - $qrg) : 0;
 743                                         $sk = "SKIM|$r->[ROrigin]|$band";
 744                                         $skimmer = $spots->{$sk};
 745                                         if ($diff) {
 746                                                 ++$skimmer->[DBad] if $skimmer->[DBad] < $maxdeviants;
 747                                                 --$skimmer->[DGood] if $skimmer->[DGood] > 0;
 748                                                 push @deviant, sprintf("$r->[ROrigin]:%+.1f", $diff);
 749                                                 push @{$skimmer->[DEviants]}, $diff;
 750                                                 shift @{$skimmer->[DEviants]} while @{$skimmer->[DEviants]} > $maxdeviants;
 751                                         } else {
 752                                                 ++$skimmer->[DGood] if $skimmer->[DGood] < $maxdeviants;
 753                                                 --$skimmer->[DBad] if $skimmer->[DBad] > 0;
 754                                                 shift @{$skimmer->[DEviants]};
 755                                         }
 756                                         $skimmer->[DScore] = $skimmer->[DGood] - $skimmer->[DBad];
 757                                         if ($rbnskim && isdbg('rbnskim')) {
 758                                                 my $lastin = difft($skimmer->[DLastin], $now, 2);
 759                                                 my $difflist = join(', ', @{$skimmer->[DEviants]});
 760                                                 $difflist = " band qrg diffs: $difflist" if $difflist;
 761                                                 dbg("RBN:SKIM key $sp slot $sk $r->[RQrg] - $qrg = $diff Skimmer score: $skimmer->[DGood] - $skimmer->[DBad] = $skimmer->[DScore] lastseen:$lastin ago$difflist");
 762                                         }
 763                                         $skimmer->[DLastin] = $now;
 764                                         $r->[RSpotData]->[SQrg] = $qrg if $qrg && $c > 1; # set all the QRGs to the agreed value
 765                                 }
 766
 767                                 $qrg = (sprintf "%.1f",  $qrg)+0;
 768                                 $r = $cand->[CData];
 769                                 $r->[RQrg] = $qrg;
 770                                 my $squality = "Q:$cand->[CQual]";
 771                                 $squality .= '*' if $c > 1;
 772                                 $squality .= '+' if $r->[Respot];
 773
 774                                 if (isdbg('progress')) {
 775                                         my $rt = difft($ctime, $now, 2);
 776                                         my $s = "RBN: SPOT key: '$sp' = $r->[RCall] on $r->[RQrg] by $r->[ROrigin] \@ $r->[RTime] $squality route: $dxchan->{call} dwell:$rt";
 777                                         my $td = @deviant;
 778                                         $s .= " QRGScore: $mv Deviants: $td/$spotters";
 779                                         $s .= ' (' . join(', ', sort @deviant) . ')' if $td;
 780                                         dbg($s);
 781                                 }
 782
 783                                 # finally send it out to any waiting public
 784                                 send_dx_spot($dxchan, $squality, $cand);
 785
 786                                 # clear out the data and make this now just "spotted", but no further action required until respot time
 787                                 dbg "RBN: QUEUE key '$sp' cleared" if isdbg 'rbn';
 788
 789                                 delete $dxchan->{queue}->{$sp};
 790
 791                                 # calculate new sp (which will be 70% likely the same as the old one)
 792                                 # we do this to cope with the fact that the first spotter may well be "wrongly calibrated" giving a qrg that disagrees with the majority.
 793                                 # and we want to store the key that corresponds to majority opinion.
 794                                 my $nqrg = nearest(1, $qrg * 10);  # normalised to nearest Khz
 795                                 my $nsp = "$r->[RCall]|$nqrg";
 796                                 if ($sp ne $nsp) {
 797                                         dbg("RBN:SKIM CHANGE KEY sp '$sp' -> '$nsp' for storage") if  $rbnskim && isdbg('rbnskim');
 798                                         delete $spots->{$sp};
 799                                         $spots->{$nsp} = [$now, $cand->[CQual]];
 800                                 } else {
 801                                         $spots->{$sp} = [$now, $cand->[CQual]];
 802                                 }
 803                         }
 804                         else {
 805                                 dbg sprintf("RBN: QUEUE key: '$sp' SEND time not yet reached %.1f secs left", $cand->[CTime] + $dwelltime - $now) if isdbg 'rbnqueue';
 806                         }
 807                 }
 808                 if (isdbg('rbntimer')) {
 809                         my $diff = _diffus($ta);
 810                         dbg "RBN: TIMER process queue for call: $dxchan->{call} $items spots $diff uS";
 811                 }
 812         }
 813 }
 814
 815 sub per_minute
 816 {
 817         foreach my $dxchan (DXChannel::get_all()) {
 818                 next unless $dxchan->is_rbn;
 819                 dbg "RBN:STATS minute $dxchan->{call} raw: $dxchan->{noraw} retrieved spots: $dxchan->{norbn} delivered: $dxchan->{nospot} after filtering to users: " . scalar keys %{$dxchan->{nousers}} if isdbg('rbnstats');
 820                 if ($dxchan->{noraw} == 0 && $dxchan->{lasttime} > 60) {
 821                         LogDbg('RBN', "RBN: no input from $dxchan->{call}, disconnecting");
 822                         $dxchan->disconnect;
 823                 }
 824                 $dxchan->{noraw} = $dxchan->{norbn} = $dxchan->{nospot} = 0; $dxchan->{nousers} = {};
 825                 $runtime{$dxchan->{call}} += 60;
 826         }
 827
 828         # save the spot cache
 829         write_cache() unless $main::systime + $startup_delay < $main::systime;;
 830 }
 831
 832 sub per_10_minute
 833 {
 834         my $count = 0;
 835         my $removed = 0;
 836         while (my ($k,$cand) = each %{$spots}) {
 837                 next if $k eq 'VERSION';
 838                 next if $k =~ /^O\|/;
 839                 next if $k =~ /^SKIM\|/;
 840
 841                 if ($main::systime - $cand->[CTime] > $minspottime*2) {
 842                         delete $spots->{$k};
 843                         ++$removed;
 844                 }
 845                 else {
 846                         ++$count;
 847                 }
 848         }
 849         dbg "RBN:STATS spot cache remain: $count removed: $removed"; # if isdbg('rbn');
 850         foreach my $dxchan (DXChannel::get_all()) {
 851                 next unless $dxchan->is_rbn;
 852                 my $nq = keys %{$dxchan->{queue}};
 853                 my $pc = $dxchan->{noraw10} ? sprintf("%.1f%%",$dxchan->{norbn10}*100/$dxchan->{noraw10}) : '0.0%';
 854                 dbg "RBN:STATS 10-minute $dxchan->{call} queue: $nq raw: $dxchan->{noraw10} retrieved spots: $dxchan->{norbn10} ($pc) delivered: $dxchan->{nospot10} after filtering to  users: " . scalar keys %{$dxchan->{nousers10}};
 855                 $dxchan->{noraw10} = $dxchan->{norbn10} = $dxchan->{nospot10} = 0; $dxchan->{nousers10} = {};
 856         }
 857 }
 858
 859 sub per_hour
 860 {
 861         foreach my $dxchan (DXChannel::get_all()) {
 862                 next unless $dxchan->is_rbn;
 863                 my $nq = keys %{$dxchan->{queue}};
 864                 my $pc = $dxchan->{norawhour} ? sprintf("%.1f%%",$dxchan->{norbnhour}*100/$dxchan->{norawhour}) : '0.0%';
 865                 dbg "RBN:STATS hour $dxchan->{call} queue: $nq raw: $dxchan->{norawhour} retrieved spots: $dxchan->{norbnhour} ($pc) delivered: $dxchan->{nospothour} after filtering to users: " . scalar keys %{$dxchan->{nousershour}};
 866                 $dxchan->{norawhour} = $dxchan->{norbnhour} = $dxchan->{nospothour} = 0; $dxchan->{nousershour} = {};
 867         }
 868 }
 869
 870 sub finish
 871 {
 872         write_cache();
 873 }
 874
 875 sub write_cache
 876 {
 877         my $ta = [ gettimeofday ];
 878         $json->indent(1)->canonical(1) if isdbg 'rbncache';
 879         my $s = eval {$json->encode($spots)};
 880         if ($s) {
 881                 my $fh = IO::File->new(">$cachefn") or confess("writing $cachefn $!");
 882                 $fh->print($s);
 883                 $fh->close;
 884         } else {
 885                 dbg("RBN:Write_cache error '$@'");
 886                 return;
 887         }
 888         $json->indent(0)->canonical(0);
 889         my $diff = _diffms($ta);
 890         my $size = sprintf('%.3fKB', (length($s) / 1000));
 891         dbg("RBN:WRITE_CACHE size: $size time to write: $diff mS");
 892 }
 893
 894 sub check_cache
 895 {
 896         if (-e $cachefn) {
 897                 my $mt = (stat($cachefn))[9];
 898                 my $t = $main::systime - $mt || 1;
 899                 my $p = difft($mt, 2);
 900                 if ($t < $cache_valid) {
 901                         dbg("RBN:check_cache '$cachefn' spot cache exists, created $p ago and not too old");
 902                         my $fh = IO::File->new($cachefn);
 903                         my $s;
 904                         if ($fh) {
 905                                 local $/ = undef;
 906                                 $s = <$fh>;
 907                                 dbg("RBN:check_cache cache read size " . length $s);
 908                                 $fh->close;
 909                         } else {
 910                                 dbg("RBN:check_cache file read error $!");
 911                                 return undef;
 912                         }
 913                         if ($s) {
 914                                 eval {$spots = $json->decode($s)};
 915                                 if ($spots && ref $spots) {
 916                                         if (exists $spots->{VERSION} && $spots->{VERSION} == $DATA_VERSION) {
 917                                                 # now clean out anything that has spot build ups in progress
 918                                                 while (my ($k, $cand) = each %$spots) {
 919                                                         next if $k eq 'VERSION';
 920                                                         next if $k =~ /^O\|/;
 921                                                         next if $k =~ /^SKIM\|/;
 922                                                         if (@$cand > CData) {
 923                                                                 $spots->{$k} = [$cand->[CTime], $cand->[CQual]];
 924                                                         }
 925                                                 }
 926                                                 dbg("RBN:check_cache spot cache restored");
 927                                                 return 1;
 928                                         }
 929                                 }
 930                                 dbg("RBN::checkcache error decoding $@");
 931                         }
 932                 } else {
 933                         my $d = difft($main::systime-$cache_valid);
 934                         dbg("RBN::checkcache '$cachefn' created $p ago is too old (> $d), ignored");
 935                 }
 936         } else {
 937                 dbg("RBN:check_cache '$cachefn' spot cache not present");
 938         }
 939
 940         return undef;
 941 }
 942
 943 1;