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