perl/RBN.pm

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