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         $origin =~ basecall($origin);
 256
 257         # is this callsign in badspotter list?
 258         if ($DXProt::badspotter->in($origin) || $DXProt::badnode->in($origin)) {
 259                 dbg("RBN: ERROR $origin is a bad spotter/node, dumped");
 260                 return;
 261         }
 262
 263         # is the qrg valid
 264         unless ($qrg =~ /^\d+\.\d{1,2}$/) {
 265                 dbg("RBN: ERROR qrg $qrg from $origin invalid, dumped");
 266                 return;
 267         }
 268
 269         $sort ||= '';
 270         $tx ||= '';
 271         $qra ||= '';
 272     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');
 273
 274         ++$self->{noraw};
 275         ++$self->{noraw10};
 276         ++$self->{norawhour};
 277
 278         my $b;
 279
 280         if ($t || $tx) {
 281
 282                 # fix up times for things like 'NXDXF B' etc
 283                 if ($tx && is_ztime($t)) {
 284                         if (is_ztime($tx)) {
 285                                 $b = $t;
 286                                 $t = $tx;
 287                         } else {
 288                                 dbg "RBN:ERR,$line";
 289                                 return (0);
 290                         }
 291                 }
 292                 if ($sort && $sort eq 'NCDXF') {
 293                         $mode = 'DXF';
 294                         $t = $tx;
 295                 }
 296                 if ($sort && $sort eq 'BEACON') {
 297                         $mode = 'BCN';
 298                 }
 299                 if ($mode =~ /^PSK/) {
 300                         $mode = 'PSK';
 301                 }
 302                 if ($mode eq 'RTTY') {
 303                         $mode = 'RTT';
 304                 }
 305
 306                 # The main de-duping key is [call, $frequency], but we probe a bit around that frequency to find a
 307                 # range of concurrent frequencies that might be in play.
 308
 309                 # The key to this is deducing the true callsign by "majority voting" (the greater the number of spotters
 310         # the more effective this is) together with some lexical analsys probably in conjuction with DXSpider
 311                 # 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)
 312                 # and some heuristical "Kwalitee" rating given distance from the zone centres of spotter, recipient user
 313         # and spotted. A map can be generated once per user and spotter as they are essentially mostly static.
 314                 # The spotted will only get a coarse position unless other info is available. Programs that parse
 315                 # DX bulletins and the online data online databases could be be used and then cached.
 316
 317                 # Obviously users have to opt in to receiving RBN spots and other users will simply be passed over and
 318                 # ignored.
 319
 320                 # Clearly this will only work in the 'mojo' branch of DXSpider where it is possible to pass off external
 321                 # data requests to ephemeral or semi resident forked processes that do any grunt work and the main
 322                 # process to just the standard "message passing" which has been shown to be able to sustain over 5000
 323                 # per second (limited by the test program's output and network speed, rather than DXSpider's handling).
 324
 325                 my $search = 5;
 326                 my $nqrg = nearest(1, $qrg * 10);  # normalised to nearest Khz
 327                 my $sp = "$call|$nqrg";           # hopefully the skimmers will be calibrated at least this well!
 328
 329                 # find it?
 330                 my $cand = $spots->{$sp};
 331                 unless ($cand) {
 332                         my ($i, $new);
 333                         for ($i = $nqrg; !$cand && $i <= $nqrg+$search; $i += 1) {
 334                                 $new = "$call|$i";
 335                                 $cand = $spots->{$new}, last if exists $spots->{$new};
 336                         }
 337                         if ($cand) {
 338                                 my $diff = $i - $nqrg;
 339                                 dbg(qq{RBN: QRG Diff using $new (+$diff) for $sp for qrg $qrg}) if (isdbg('rbnqrg') || ($dbgrbn && isdbg('rbn')));
 340                                 $sp = $new;
 341                         }
 342                 }
 343                 unless ($cand) {
 344                         my ($i, $new);
 345                         for ($i = $nqrg; !$cand && $i >= $nqrg-$search; $i -= 1) {
 346                                 $new = "$call|$i";
 347                                 $cand = $spots->{$new}, last if exists $spots->{$new};
 348                         }
 349                         if ($cand) {
 350                                 my $diff = $nqrg - $i;
 351                                 dbg(qq{RBN: QRG Diff using $new (-$diff) for $sp for qrg $qrg}) if (isdbg('rbnqrg') || ($dbgrbn && isdbg('rbn')));
 352                                 $sp = $new;
 353                         }
 354                 }
 355
 356                 # if we have one and there is only one slot and that slot's time isn't expired for respot then return
 357                 my $respot = 0;
 358                 if ($cand && ref $cand) {
 359                         if (@$cand <= CData) {
 360                                 if ($self->{minspottime} > 0 && $now - $cand->[CTime] < $self->{minspottime}) {
 361                                         dbg("RBN: key: '$sp' call: $call qrg: $qrg DUPE \@ ". atime(int $cand->[CTime])) if $dbgrbn && isdbg('rbn');
 362                                         return;
 363                                 }
 364
 365                                 dbg("RBN: key: '$sp' RESPOTTING call: $call qrg: $qrg last seen \@ ". atime(int $cand->[CTime])) if $dbgrbn && isdbg('rbn');
 366                                 $cand->[CTime] = $now;
 367                                 ++$respot;
 368                         }
 369
 370                         # otherwise we have a spot being built up at the moment
 371                 } elsif ($cand) {
 372                         dbg("RBN: key '$sp' = '$cand' not ref");
 373                         return;
 374                 } else {
 375                         # new spot / frequency
 376                         $spots->{$sp} = $cand = [$now, 0];
 377                         dbg("RBN: key: '$sp' call: $call qrg: $qrg NEW" . ($respot ? ' RESPOT' : '')) if $dbgrbn && isdbg('rbn');
 378                 }
 379
 380                 # add me to the display queue unless we are waiting for initial in rush to finish
 381                 return unless $noinrush || $self->{inrushpreventor} < $main::systime;
 382
 383                 # build up a new record and store it in the buildup
 384                 # deal with the unix time
 385                 my ($hh,$mm) = $t =~ /(\d\d)(\d\d)Z$/;
 386                 my $utz = $hh*3600 + $mm*60 + $main::systime_daystart; # possible issue with late spot from previous day
 387                 $utz -= 86400 if $utz > $now+3600;                                         # too far ahead, drag it back one day
 388
 389                 # create record and add into the buildup
 390                 my $r = [$origin, nearest(.1, $qrg), $call, $mode, $s, $t, $utz, $respot, $u];
 391                 my @s =  Spot::prepare($r->[RQrg], $r->[RCall], $r->[RUtz], '', $r->[ROrigin]);
 392                 if ($s[5] == 666) {
 393                         dbg("RBN: ERROR invalid prefix/callsign $call from $origin-# on $qrg, dumped");
 394                         return;
 395                 }
 396
 397                 if ($self->{inrbnfilter}) {
 398                         my ($want, undef) = $self->{inrbnfilter}->it($s);
 399                         return unless $want;
 400                 }
 401                 $r->[RSpotData] = \@s;
 402
 403                 ++$self->{queue}->{$sp};# unless @$cand>= CData; # queue the KEY (not the record)
 404
 405                 dbg("RBN: key: '$sp' ADD RECORD call: $call qrg: $qrg origin: $origin respot: $respot") if $dbgrbn && isdbg('rbn');
 406
 407                 push @$cand, $r;
 408
 409         } else {
 410                 dbg "RBN:DATA,$line" if $dbgrbn && isdbg('rbn');
 411         }
 412 }
 413
 414 # we should get the spot record minus the time, so just an array of record (arrays)
 415 sub send_dx_spot
 416 {
 417         my $self = shift;
 418         my $quality = shift;
 419         my $cand = shift;
 420
 421         ++$self->{norbn};
 422         ++$self->{norbn10};
 423         ++$self->{norbnhour};
 424
 425         # $r = [$origin, $qrg, $call, $mode, $s, $utz, $respot];
 426
 427         my $mode = $cand->[CData]->[RMode]; # as all the modes will be the same;
 428
 429         my @dxchan = DXChannel::get_all();
 430
 431         foreach my $dxchan (@dxchan) {
 432                 next unless $dxchan->is_user;
 433                 my $user = $dxchan->{user};
 434                 next unless $user &&  $user->wantrbn;
 435
 436                 # does this user want this sort of spot at all?
 437                 my $want = 0;
 438                 ++$want if $user->wantbeacon && $mode =~ /^BCN|DXF/;
 439                 ++$want if $user->wantcw && $mode =~ /^CW/;
 440                 ++$want if $user->wantrtty && $mode =~ /^RTT/;
 441                 ++$want if $user->wantpsk && $mode =~ /^PSK|FSK|MSK/;
 442                 ++$want if $user->wantft && $mode =~ /^FT/;
 443
 444                 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",
 445                                         $user->wantrbn,
 446                                         $user->wantft,
 447                                         $user->wantbeacon,
 448                                         $user->wantcw,
 449                                         $user->wantpsk,
 450                                         $user->wantrtty,
 451                                    )) if isdbg('rbnll');
 452
 453                 # send one spot to one user out of the ones that we have
 454                 $self->dx_spot($dxchan, $quality, $cand) if $want;
 455         }
 456 }
 457
 458 sub dx_spot
 459 {
 460         my $self = shift;
 461         my $dxchan = shift;
 462         my $quality = shift;
 463         my $cand = shift;
 464         my $call = $dxchan->{call};
 465         my $seeme = $dxchan->user->rbnseeme();
 466         my $strength = 100;             # because it could if we talk about FTx
 467         my $saver;
 468         my %zone;
 469         my $respot;
 470         my $qra;
 471
 472         ++$self->{nousers}->{$call};
 473         ++$self->{nousers10}->{$call};
 474         ++$self->{nousershour}->{$call};
 475
 476         my $filtered;
 477         my $rf = $dxchan->{rbnfilter} || $dxchan->{spotsfilter};
 478         my $comment;
 479
 480         foreach my $r (@$cand) {
 481                 # $r = [$origin, $qrg, $call, $mode, $s, $t, $utz, $respot, $qra];
 482                 # Spot::prepare($qrg, $call, $utz, $comment, $origin);
 483                 next unless $r && ref $r;
 484
 485                 $qra = $r->[RQra] if !$qra && $r->[RQra] && is_qra($r->[RQra]);
 486
 487                 $comment = sprintf "%-3s %2ddB $quality", $r->[RMode], $r->[RStrength];
 488                 my $s = $r->[RSpotData];                # the prepared spot
 489                 $s->[SComment] = $comment;              # apply new generated comment
 490
 491                 ++$zone{$s->[SZone]};           # save the spotter's zone
 492
 493                 # if the 'see me' flag is set, then show all the spots without further adornment (see set/rbnseeme for more info)
 494                 if ($seeme) {
 495                         send_final($dxchan, $s);
 496                         next;
 497                 }
 498
 499                 # save the lowest strength one
 500                 if ($r->[RStrength] < $strength) {
 501                         $strength = $r->[RStrength];
 502                         $saver = $s;
 503                         dbg("RBN: STRENGTH spot: $s->[SCall] qrg: $s->[SQrg] origin: $s->[SOrigin] dB: $r->[RStrength] < $strength") if isdbg 'rbnll';
 504                 }
 505
 506                 if ($rf) {
 507                         my ($want, undef) = $rf->it($s);
 508                         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';
 509                         next unless $want;
 510                         $filtered = $s;
 511                 }
 512         }
 513
 514         if ($rf) {
 515                 $saver = $filtered;             # if nothing passed the filter's lips then $saver == $filtered == undef !
 516         }
 517
 518         if ($saver) {
 519                 my $buf;
 520                 # create a zone list of spotters
 521                 delete $zone{$saver->[SZone]};  # remove this spotter's zone (leaving all the other zones)
 522                 my $z = join ',', sort {$a <=> $b} keys %zone;
 523
 524                 # alter spot data accordingly
 525                 $saver->[SComment] .= " Z:$z" if $z;
 526
 527                 send_final($dxchan, $saver);
 528
 529                 ++$self->{nospot};
 530                 ++$self->{nospot10};
 531                 ++$self->{nospothour};
 532
 533                 if ($qra) {
 534                         my $user = DXUser::get_current($saver->[SCall]) || DXUser->new($saver->[SCall]);
 535                         unless ($user->qra && is_qra($user->qra)) {
 536                                 $user->qra($qra);
 537                                 dbg("RBN: update qra on $saver->[SCall] to $qra");
 538                                 $user->put;
 539                         }
 540                 }
 541         }
 542 }
 543
 544 sub send_final
 545 {
 546         my $dxchan = shift;
 547         my $saver = shift;
 548         my $call = $dxchan->{call};
 549         my $buf;
 550
 551         dbg("RBN: SENDING to $call spot: $saver->[SCall] qrg: $saver->[SQrg] origin: $saver->[SOrigin] $saver->[SComment]") if isdbg 'rbnll';
 552         if ($dxchan->{ve7cc}) {
 553                 my $call = $saver->[SOrigin];
 554                 $saver->[SOrigin] .= '-#';
 555                 $buf = VE7CC::dx_spot($dxchan, @$saver);
 556                 $saver->[SOrigin] = $call;
 557         } else {
 558                 my $call = $saver->[SOrigin];
 559                 $saver->[SOrigin] = substr($call, 0, 6);
 560                 $saver->[SOrigin] .= '-#';
 561                 $buf = $dxchan->format_dx_spot(@$saver);
 562                 $saver->[SOrigin] = $call;
 563         }
 564         $dxchan->local_send('N', $buf);
 565 }
 566
 567 # per second
 568 sub process
 569 {
 570         my $rbnskim = isdbg('rbnskim');
 571
 572         foreach my $dxchan (DXChannel::get_all()) {
 573                 next unless $dxchan->is_rbn;
 574
 575                 # At this point we run the queue to see if anything can be sent onwards to the punter
 576                 my $now = $main::systime;
 577                 my $ta = [gettimeofday];
 578                 my $items = 0;
 579
 580                 # now run the waiting queue which just contains KEYS ($call|$qrg)
 581                 foreach my $sp (keys %{$dxchan->{queue}}) {
 582                         my $cand = $spots->{$sp};
 583                         ++$items;
 584
 585                         unless ($cand && $cand->[CTime]) {
 586                                 dbg "RBN Cand $sp " . ($cand ? 'def' : 'undef') . " [CTime] " . ($cand->[CTime] ? 'def' : 'undef') . " dwell $dwelltime";
 587                                 delete $spots->{$sp};
 588                                 delete $dxchan->{queue}->{$sp};    # remove
 589                                 next;
 590                         }
 591
 592                         my $ctime = $cand->[CTime];
 593                         my $quality = @$cand - CData;
 594                         my $dwellsecs =  $now - $ctime;
 595                         if ($quality >= $maxqual || $dwellsecs >= $dwelltime || $dwellsecs >= $limbotime) {
 596                                 # we have a candidate, create qualitee value(s);
 597                                 unless (@$cand > CData) {
 598                                         dbg "RBN: QUEUE key '$sp' MISSING RECORDS, IGNORED" . dd($cand) if isdbg 'rbnqueue';
 599                                         delete $spots->{$sp}; # don't remember it either - this means that a spot HAS to come in with sufficient spotters to be processed.
 600                                         delete $dxchan->{queue}->{$sp};
 601                                         next;
 602                                 }
 603                                 dbg "RBN: QUEUE PROCESSING key: '$sp' $now >= $cand->[CTime]" if isdbg 'rbnqueue';
 604                                 my $spotters = $quality;
 605
 606                                 # 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
 607                                 my $r = $cand->[CData];
 608                                 if ($dwellsecs > $limbotime && $quality < $minqual) {
 609                                         if ( $rbnskim && isdbg('rbnskim')) {
 610                                                 $r = $cand->[CData];
 611                                                 if ($r) {
 612                                                         my $lastin = difft($ctime, $now, 2);
 613                                                         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}";
 614                                                         dbg($s);
 615                                                 }
 616                                         }
 617                                         delete $spots->{$sp}; # don't remember it either - this means that a spot HAS to come in with sufficient spotters to be processed.
 618                                         delete $dxchan->{queue}->{$sp};
 619                                         next;
 620                                 }
 621
 622                                 # we have a possible removal from Limbo, check for more than one skimmer and reset the quality if required
 623                                 # DOES THIS TEST CAUSE RACES?
 624                                 if (!$r->[Respot] && $quality >= $minqual && $dwellsecs > $dwelltime+1) {
 625
 626                                         # because we don't need to check for repeats by the same skimmer in the normal case, we do here
 627                                         my %seen;
 628                                         my @origin;
 629                                         foreach my $wr (@$cand) {
 630                                                 next unless ref $wr;
 631                                                 push @origin, $wr->[ROrigin];
 632                                                 if (exists $seen{$wr->[ROrigin]}) {
 633                                                         next;
 634                                                 }
 635                                                 $seen{$wr->[ROrigin]} = $wr;
 636                                         }
 637                                         # reset the quality to ignore dupes
 638                                         my $oq = $quality;
 639                                         $quality = keys %seen;
 640                                         if ($quality >= $minqual) {
 641                                                 if ( $rbnskim && isdbg('rbnskim')) {
 642                                                         my $lastin = difft($ctime, $now, 2);
 643                                                         my $sk = join ' ', keys %seen;
 644                                                         my $or = join ' ', @origin;
 645                                                         my $s = "RBN:SKIM promoted from Limbo - key: '$sp' (lastin: $lastin Q now: $quality was $oq skimmers now: $sk";
 646                                                         $s .= " was $or" if $or ne $sk;
 647                                                         $s .= ')';
 648                                                         dbg($s);
 649                                                 }
 650                                         } elsif ($oq != $quality) {
 651                                                 if ( $rbnskim && isdbg('rbnskim')) {
 652                                                         my $lastin = difft($ctime, $now, 2);
 653                                                         my $sk = join ' ', keys %seen;
 654                                                         my $or = join ' ', @origin;
 655                                                         my $s = "RBN:SKIM quality reset key: '$sp' (lastin: $lastin Q now: $quality was $oq skimmers now: $sk was: $or)";
 656                                                         dbg($s);
 657                                                 }
 658                                                 # remove the excess
 659                                                 my @ncand = (@$cand[CTime, CQual], values %seen);
 660                                                 $spots->{$sp} = \@ncand;
 661                                         }
 662                                 }
 663
 664                                 # we now kick this spot into Limbo
 665                                 if ($quality < $minqual) {
 666                                         next;
 667                                 }
 668
 669                                 $quality = 9 if $quality > 9;
 670                                 $cand->[CQual] = $quality if $quality > $cand->[CQual];
 671
 672                                 # this scores each candidate according to its skimmer's QRG score (i.e. how often it agrees with its peers)
 673                                 # what happens is hash of all QRGs in candidates are incremented by that skimmer's reputation for "accuracy"
 674                                 # or, more exactly, past agreement with the consensus. This score can be from -5 -> +5.
 675                                 my %qrg = ();
 676                                 my $skimmer;
 677                                 my $sk;
 678                                 my $band;
 679                                 my %seen = ();
 680                                 foreach $r (@$cand) {
 681                                         next unless ref $r;
 682                                         if (exists $seen{$r->[ROrigin]}) {
 683                                                 $r = 0;
 684                                                 next;
 685                                         }
 686                                         $seen{$r->[ROrigin]} = 1;
 687                                         $band ||= int $r->[RQrg] / 1000;
 688                                         $sk = "SKIM|$r->[ROrigin]|$band"; # thus only once per set of candidates
 689                                         $skimmer = $spots->{$sk};
 690                                         unless ($skimmer) {
 691                                                 $skimmer = $spots->{$sk} = [1, 0, 0, $now, []]; # this first time, this new skimmer gets the benefit of the doubt on frequency.
 692                                                 dbg("RBN:SKIM new slot $sk " . $json->encode($skimmer)) if  $rbnskim && isdbg('rbnskim');
 693                                         }
 694                                         $qrg{$r->[RQrg]} += ($skimmer->[DScore] || 1);
 695                                 }
 696
 697                                 # determine the most likely qrg and then set it - NOTE (-)ve votes, generated by the skimmer scoring system above, are ignored
 698                                 my @deviant;
 699                                 my $c = 0;
 700                                 my $mv = 0;
 701                                 my $qrg = 0;
 702                                 while (my ($k, $votes) = each %qrg) {
 703                                         if ($votes >= $mv) {
 704                                                 $qrg = $k;
 705                                                 $mv = $votes;
 706                                         }
 707                                         ++$c;
 708                                 }
 709
 710                                 # Ignore possible spots with 0 QRG score - as determined by the skimmer scoring system above -  as they are likely to be wrong
 711                                 unless ($qrg > 0) {
 712                                         if ( $rbnskim && isdbg('rbnskim')) {
 713                                                 my $keys;
 714                                                 while (my ($k, $v) = (each %qrg)) {
 715                                                         $keys .= "$k=>$v, ";
 716                                                 }
 717                                                 $keys =~ /,\s*$/;
 718                                                 my $i = 0;
 719                                                 foreach $r (@$cand) {
 720                                                         next unless $r && ref $r;
 721                                                         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";
 722                                                         ++$i;
 723                                                 }
 724                                         }
 725                                         delete $spots->{$sp}; # get rid
 726                                         delete $dxchan->{queue}->{$sp};
 727                                         next;
 728                                 }
 729
 730                                 # detemine and spit out the deviants. Then adjust the scores according to whether it is a deviant or good
 731                                 # NOTE: deviant nodes can become good (or less bad), and good nodes bad (or less good) on each spot that
 732                                 # they generate. This is based solely on each skimmer's agreement (or not) with the "consensus" score generated
 733                                 # above ($qrg). The resultant score + good + bad is stored per band and will be used the next time a spot
 734                                 # appears on this band from each skimmer.
 735                                 foreach $r (@$cand) {
 736                                         next unless $r && ref $r;
 737                                         my $diff = $c > 1 ? nearest(.1, $r->[RQrg] - $qrg) : 0;
 738                                         $sk = "SKIM|$r->[ROrigin]|$band";
 739                                         $skimmer = $spots->{$sk};
 740                                         if ($diff) {
 741                                                 ++$skimmer->[DBad] if $skimmer->[DBad] < $maxdeviants;
 742                                                 --$skimmer->[DGood] if $skimmer->[DGood] > 0;
 743                                                 push @deviant, sprintf("$r->[ROrigin]:%+.1f", $diff);
 744                                                 push @{$skimmer->[DEviants]}, $diff;
 745                                                 shift @{$skimmer->[DEviants]} while @{$skimmer->[DEviants]} > $maxdeviants;
 746                                         } else {
 747                                                 ++$skimmer->[DGood] if $skimmer->[DGood] < $maxdeviants;
 748                                                 --$skimmer->[DBad] if $skimmer->[DBad] > 0;
 749                                                 shift @{$skimmer->[DEviants]};
 750                                         }
 751                                         $skimmer->[DScore] = $skimmer->[DGood] - $skimmer->[DBad];
 752                                         if ($rbnskim && isdbg('rbnskim')) {
 753                                                 my $lastin = difft($skimmer->[DLastin], $now, 2);
 754                                                 my $difflist = join(', ', @{$skimmer->[DEviants]});
 755                                                 $difflist = " band qrg diffs: $difflist" if $difflist;
 756                                                 dbg("RBN:SKIM key $sp slot $sk $r->[RQrg] - $qrg = $diff Skimmer score: $skimmer->[DGood] - $skimmer->[DBad] = $skimmer->[DScore] lastseen:$lastin ago$difflist");
 757                                         }
 758                                         $skimmer->[DLastin] = $now;
 759                                         $r->[RSpotData]->[SQrg] = $qrg if $qrg && $c > 1; # set all the QRGs to the agreed value
 760                                 }
 761
 762                                 $qrg = (sprintf "%.1f",  $qrg)+0;
 763                                 $r = $cand->[CData];
 764                                 $r->[RQrg] = $qrg;
 765                                 my $squality = "Q:$cand->[CQual]";
 766                                 $squality .= '*' if $c > 1;
 767                                 $squality .= '+' if $r->[Respot];
 768
 769                                 if (isdbg('progress')) {
 770                                         my $rt = difft($ctime, $now, 2);
 771                                         my $s = "RBN: SPOT key: '$sp' = $r->[RCall] on $r->[RQrg] by $r->[ROrigin] \@ $r->[RTime] $squality route: $dxchan->{call} dwell:$rt";
 772                                         my $td = @deviant;
 773                                         $s .= " QRGScore: $mv Deviants: $td/$spotters";
 774                                         $s .= ' (' . join(', ', sort @deviant) . ')' if $td;
 775                                         dbg($s);
 776                                 }
 777
 778                                 # finally send it out to any waiting public
 779                                 send_dx_spot($dxchan, $squality, $cand);
 780
 781                                 # clear out the data and make this now just "spotted", but no further action required until respot time
 782                                 dbg "RBN: QUEUE key '$sp' cleared" if isdbg 'rbn';
 783
 784                                 delete $dxchan->{queue}->{$sp};
 785
 786                                 # calculate new sp (which will be 70% likely the same as the old one)
 787                                 # 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.
 788                                 # and we want to store the key that corresponds to majority opinion.
 789                                 my $nqrg = nearest(1, $qrg * 10);  # normalised to nearest Khz
 790                                 my $nsp = "$r->[RCall]|$nqrg";
 791                                 if ($sp ne $nsp) {
 792                                         dbg("RBN:SKIM CHANGE KEY sp '$sp' -> '$nsp' for storage") if  $rbnskim && isdbg('rbnskim');
 793                                         delete $spots->{$sp};
 794                                         $spots->{$nsp} = [$now, $cand->[CQual]];
 795                                 } else {
 796                                         $spots->{$sp} = [$now, $cand->[CQual]];
 797                                 }
 798                         }
 799                         else {
 800                                 dbg sprintf("RBN: QUEUE key: '$sp' SEND time not yet reached %.1f secs left", $cand->[CTime] + $dwelltime - $now) if isdbg 'rbnqueue';
 801                         }
 802                 }
 803                 if (isdbg('rbntimer')) {
 804                         my $diff = _diffus($ta);
 805                         dbg "RBN: TIMER process queue for call: $dxchan->{call} $items spots $diff uS";
 806                 }
 807         }
 808 }
 809
 810 sub per_minute
 811 {
 812         foreach my $dxchan (DXChannel::get_all()) {
 813                 next unless $dxchan->is_rbn;
 814                 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');
 815                 if ($dxchan->{noraw} == 0 && $dxchan->{lasttime} > 60) {
 816                         LogDbg('RBN', "RBN: no input from $dxchan->{call}, disconnecting");
 817                         $dxchan->disconnect;
 818                 }
 819                 $dxchan->{noraw} = $dxchan->{norbn} = $dxchan->{nospot} = 0; $dxchan->{nousers} = {};
 820                 $runtime{$dxchan->{call}} += 60;
 821         }
 822
 823         # save the spot cache
 824         write_cache() unless $main::systime + $startup_delay < $main::systime;;
 825 }
 826
 827 sub per_10_minute
 828 {
 829         my $count = 0;
 830         my $removed = 0;
 831         while (my ($k,$cand) = each %{$spots}) {
 832                 next if $k eq 'VERSION';
 833                 next if $k =~ /^O\|/;
 834                 next if $k =~ /^SKIM\|/;
 835
 836                 if ($main::systime - $cand->[CTime] > $minspottime*2) {
 837                         delete $spots->{$k};
 838                         ++$removed;
 839                 }
 840                 else {
 841                         ++$count;
 842                 }
 843         }
 844         dbg "RBN:STATS spot cache remain: $count removed: $removed"; # if isdbg('rbn');
 845         foreach my $dxchan (DXChannel::get_all()) {
 846                 next unless $dxchan->is_rbn;
 847                 my $nq = keys %{$dxchan->{queue}};
 848                 my $pc = $dxchan->{noraw10} ? sprintf("%.1f%%",$dxchan->{norbn10}*100/$dxchan->{noraw10}) : '0.0%';
 849                 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}};
 850                 $dxchan->{noraw10} = $dxchan->{norbn10} = $dxchan->{nospot10} = 0; $dxchan->{nousers10} = {};
 851         }
 852 }
 853
 854 sub per_hour
 855 {
 856         foreach my $dxchan (DXChannel::get_all()) {
 857                 next unless $dxchan->is_rbn;
 858                 my $nq = keys %{$dxchan->{queue}};
 859                 my $pc = $dxchan->{norawhour} ? sprintf("%.1f%%",$dxchan->{norbnhour}*100/$dxchan->{norawhour}) : '0.0%';
 860                 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}};
 861                 $dxchan->{norawhour} = $dxchan->{norbnhour} = $dxchan->{nospothour} = 0; $dxchan->{nousershour} = {};
 862         }
 863 }
 864
 865 sub finish
 866 {
 867         write_cache();
 868 }
 869
 870 sub write_cache
 871 {
 872         my $ta = [ gettimeofday ];
 873         $json->indent(1)->canonical(1) if isdbg 'rbncache';
 874         my $s = eval {$json->encode($spots)};
 875         if ($s) {
 876                 my $fh = IO::File->new(">$cachefn") or confess("writing $cachefn $!");
 877                 $fh->print($s);
 878                 $fh->close;
 879         } else {
 880                 dbg("RBN:Write_cache error '$@'");
 881                 return;
 882         }
 883         $json->indent(0)->canonical(0);
 884         my $diff = _diffms($ta);
 885         my $size = sprintf('%.3fKB', (length($s) / 1000));
 886         dbg("RBN:WRITE_CACHE size: $size time to write: $diff mS");
 887 }
 888
 889 sub check_cache
 890 {
 891         if (-e $cachefn) {
 892                 my $mt = (stat($cachefn))[9];
 893                 my $t = $main::systime - $mt || 1;
 894                 my $p = difft($mt, 2);
 895                 if ($t < $cache_valid) {
 896                         dbg("RBN:check_cache '$cachefn' spot cache exists, created $p ago and not too old");
 897                         my $fh = IO::File->new($cachefn);
 898                         my $s;
 899                         if ($fh) {
 900                                 local $/ = undef;
 901                                 $s = <$fh>;
 902                                 dbg("RBN:check_cache cache read size " . length $s);
 903                                 $fh->close;
 904                         } else {
 905                                 dbg("RBN:check_cache file read error $!");
 906                                 return undef;
 907                         }
 908                         if ($s) {
 909                                 eval {$spots = $json->decode($s)};
 910                                 if ($spots && ref $spots) {
 911                                         if (exists $spots->{VERSION} && $spots->{VERSION} == $DATA_VERSION) {
 912                                                 # now clean out anything that has spot build ups in progress
 913                                                 while (my ($k, $cand) = each %$spots) {
 914                                                         next if $k eq 'VERSION';
 915                                                         next if $k =~ /^O\|/;
 916                                                         next if $k =~ /^SKIM\|/;
 917                                                         if (@$cand > CData) {
 918                                                                 $spots->{$k} = [$cand->[CTime], $cand->[CQual]];
 919                                                         }
 920                                                 }
 921                                                 dbg("RBN:check_cache spot cache restored");
 922                                                 return 1;
 923                                         }
 924                                 }
 925                                 dbg("RBN::checkcache error decoding $@");
 926                         }
 927                 } else {
 928                         my $d = difft($main::systime-$cache_valid);
 929                         dbg("RBN::checkcache '$cachefn' created $p ago is too old (> $d), ignored");
 930                 }
 931         } else {
 932                 dbg("RBN:check_cache '$cachefn' spot cache not present");
 933         }
 934
 935         return undef;
 936 }
 937
 938 1;