perl/RBN.pm

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