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