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);
  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
  62 our $DATA_VERSION = 1;
  63
  64 our @ISA = qw(DXChannel);
  65
  66 our $startup_delay = 5*60;              # don't send anything out until this timer has expired
  67                                 # this is to allow the feed to "warm up" with duplicates
  68                                 # so that the "big rush" doesn't happen.
  69
  70 our $minspottime = 15*60;               # the time between respots of a callsign - if a call is
  71                                 # still being spotted (on the same freq) and it has been
  72                                 # spotted before, it's spotted again after this time
  73                                 # until the next minspottime has passed.
  74
  75 our $beacontime = 5*60;                 # same as minspottime, but for beacons (and shorter)
  76
  77 our $dwelltime = 10;                    # the amount of time to wait for duplicates before issuing
  78                                 # a spot to the user (no doubt waiting with bated breath).
  79
  80 our $filterdef = $Spot::filterdef; # we use the same filter as the Spot system. Can't think why :-).
  81
  82 my $spots;                                              # the GLOBAL spot cache
  83
  84 my %runtime;                                    # how long each channel has been running
  85
  86 our $cachefn = localdata('rbn_cache');
  87 our $cache_valid = 4*60;                # The cache file is considered valid if it is not more than this old
  88
  89 our $maxqrgdiff = 10;                   # the maximum
  90 our $minqual = 2;                               # the minimum quality we will accept for output
  91
  92 my $json;
  93 my $noinrush = 0;                               # override the inrushpreventor if set
  94
  95 sub init
  96 {
  97         $json = DXJSON->new;
  98         if (check_cache()) {
  99                 $noinrush = 1;
 100         } else {
 101                 $spots = {VERSION=>$DATA_VERSION};
 102         }
 103         if (defined $DB::VERSION) {
 104                 $noinrush = 1;
 105                 $json->indent(1);
 106         }
 107
 108 }
 109
 110 sub new
 111 {
 112         my $self = DXChannel::alloc(@_);
 113
 114         # routing, this must go out here to prevent race condx
 115         my $pkg = shift;
 116         my $call = shift;
 117
 118         $self->{last} = 0;
 119         $self->{noraw} = 0;
 120         $self->{nospot} = 0;
 121         $self->{nouser} = {};
 122         $self->{norbn} = 0;
 123         $self->{noraw10} = 0;
 124         $self->{nospot10} = 0;
 125         $self->{nouser10} = {};
 126         $self->{norbn10} = 0;
 127         $self->{nospothour} = 0;
 128         $self->{nouserhour} = {};
 129         $self->{norbnhour} = 0;
 130         $self->{norawhour} = 0;
 131         $self->{sort} = 'N';
 132         $self->{lasttime} = $main::systime;
 133         $self->{minspottime} = $minspottime;
 134         $self->{beacontime} = $beacontime;
 135         $self->{showstats} = 0;
 136         $self->{pingint} = 0;
 137         $self->{nopings} = 0;
 138         $self->{queue} = {};
 139
 140         return $self;
 141 }
 142
 143 sub start
 144 {
 145         my ($self, $line, $sort) = @_;
 146         my $user = $self->{user};
 147         my $call = $self->{call};
 148         my $name = $user->{name};
 149
 150         # log it
 151         my $host = $self->{conn}->peerhost;
 152         $host ||= "unknown";
 153         $self->{hostname} = $host;
 154
 155         $self->{name} = $name ? $name : $call;
 156         $self->state('prompt');         # a bit of room for further expansion, passwords etc
 157         $self->{lang} = $user->lang || $main::lang || 'en';
 158         if ($line =~ /host=/) {
 159                 my ($h) = $line =~ /host=(\d+\.\d+\.\d+\.\d+)/;
 160                 $line =~ s/\s*host=\d+\.\d+\.\d+\.\d+// if $h;
 161                 unless ($h) {
 162                         ($h) = $line =~ /host=([\da..fA..F:]+)/;
 163                         $line =~ s/\s*host=[\da..fA..F:]+// if $h;
 164                 }
 165                 if ($h) {
 166                         $h =~ s/^::ffff://;
 167                         $self->{hostname} = $h;
 168                 }
 169         }
 170         $self->{width} = 80 unless $self->{width} && $self->{width} > 80;
 171         $self->{consort} = $line;       # save the connection type
 172
 173         LogDbg('DXCommand', "$call connected from $self->{hostname}");
 174
 175         # set some necessary flags on the user if they are connecting
 176         $self->{registered} = 1;
 177         # sort out privilege reduction
 178         $self->{priv} = 0;
 179
 180         # get the filters
 181         my $nossid = $call;
 182         $nossid =~ s/-\d+$//;
 183
 184         $self->{inrbnfilter} = Filter::read_in('rbn', $call, 1)
 185                 || Filter::read_in('rbn', 'node_default', 1);
 186
 187         # clean up qra locators
 188         my $qra = $user->qra;
 189         $qra = undef if ($qra && !DXBearing::is_qra($qra));
 190         unless ($qra) {
 191                 my $lat = $user->lat;
 192                 my $long = $user->long;
 193                 $user->qra(DXBearing::lltoqra($lat, $long)) if (defined $lat && defined $long);
 194         }
 195
 196         # if we have been running and stopped for a while
 197         # if the cache is warm enough don't operate the inrush preventor
 198         $self->{inrushpreventor} = exists $runtime{$call} && $runtime{$call} > $startup_delay || $noinrush ?  0 : $main::systime + $startup_delay;
 199         dbg("RBN: noinrush: $noinrush, setting inrushpreventor on $self->{call} to $self->{inrushpreventor}");
 200 }
 201
 202 my @queue;                                              # the queue of spots ready to send
 203
 204 sub normal
 205 {
 206         my $self = shift;
 207         my $line = shift;
 208         my @ans;
 209 #       my $spots = $self->{spot};
 210
 211         # remove leading and trailing spaces
 212         chomp $line;
 213         $line =~ s/^\s*//;
 214         $line =~ s/\s*$//;
 215
 216         # add base RBN
 217
 218         my $now = $main::systime;
 219
 220         # parse line
 221         dbg "RBN:RAW,$line" if isdbg('rbnraw');
 222         return unless $line=~/^DX\s+de/;
 223
 224         my (undef, undef, $origin, $qrg, $call, $mode, $s, $m, $spd, $u, $sort, $t, $tx) = split /[:\s]+/, $line;
 225
 226         # fix up FT8 spots from 7001
 227         $t = $u, $u = '' if !$t && is_ztime($u);
 228         $t = $sort, $sort = '' if !$t && is_ztime($sort);
 229         my $qra = $spd, $spd = '' if is_qra($spd);
 230         $u = $qra if $qra;
 231
 232         # is this anything like a callsign?
 233         unless (is_callsign($call)) {
 234                 dbg("RBN: ERROR $call from $origin on $qrg is invalid, dumped");
 235                 return;
 236         }
 237
 238         $origin =~ s/\-(?:\d{1,2}\-)?\#$//; # get rid of all the crap we aren't interested in
 239
 240
 241         $sort ||= '';
 242         $tx ||= '';
 243         $qra ||= '';
 244     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 isdbg('rbn');
 245
 246         ++$self->{noraw};
 247         ++$self->{noraw10};
 248         ++$self->{norawhour};
 249
 250         my $b;
 251
 252         if ($t || $tx) {
 253
 254                 # fix up times for things like 'NXDXF B' etc
 255                 if ($tx && is_ztime($t)) {
 256                         if (is_ztime($tx)) {
 257                                 $b = $t;
 258                                 $t = $tx;
 259                         } else {
 260                                 dbg "RBN:ERR,$line";
 261                                 return (0);
 262                         }
 263                 }
 264                 if ($sort && $sort eq 'NCDXF') {
 265                         $mode = 'DXF';
 266                         $t = $tx;
 267                 }
 268                 if ($sort && $sort eq 'BEACON') {
 269                         $mode = 'BCN';
 270                 }
 271                 if ($mode =~ /^PSK/) {
 272                         $mode = 'PSK';
 273                 }
 274                 if ($mode eq 'RTTY') {
 275                         $mode = 'RTT';
 276                 }
 277
 278                 # The main de-duping key is [call, $frequency], but we probe a bit around that frequency to find a
 279                 # range of concurrent frequencies that might be in play.
 280
 281                 # The key to this is deducing the true callsign by "majority voting" (the greater the number of spotters
 282         # the more effective this is) together with some lexical analsys probably in conjuction with DXSpider
 283                 # 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)
 284                 # and some heuristical "Kwalitee" rating given distance from the zone centres of spotter, recipient user
 285         # and spotted. A map can be generated once per user and spotter as they are essentially mostly static.
 286                 # The spotted will only get a coarse position unless other info is available. Programs that parse
 287                 # DX bulletins and the online data online databases could be be used and then cached.
 288
 289                 # Obviously users have to opt in to receiving RBN spots and other users will simply be passed over and
 290                 # ignored.
 291
 292                 # Clearly this will only work in the 'mojo' branch of DXSpider where it is possible to pass off external
 293                 # data requests to ephemeral or semi resident forked processes that do any grunt work and the main
 294                 # process to just the standard "message passing" which has been shown to be able to sustain over 5000
 295                 # per second (limited by the test program's output and network speed, rather than DXSpider's handling).
 296
 297                 my $nearest = 1;
 298                 my $search = 5;
 299                 my $mult = 10;
 300                 my $tqrg = $qrg * $mult;
 301                 my $nqrg = nearest($nearest, $tqrg);  # normalised to nearest Khz
 302 #               my $nqrg = nearest_even($qrg);  # normalised to nearest Khz
 303                 my $sp = "$call|$nqrg";           # hopefully the skimmers will be calibrated at least this well!
 304
 305                 # find it?
 306                 my $cand = $spots->{$sp};
 307                 unless ($cand) {
 308                         my ($i, $new);
 309                         for ($i = $tqrg; !$cand && $i <= $tqrg+$search; $i += 1) {
 310                                 $new = "$call|$i";
 311                                 $cand = $spots->{$new}, last if exists $spots->{$new};
 312                         }
 313                         if ($cand) {
 314                                 my $diff = $i - $tqrg;
 315                                 dbg(qq{RBN: QRG Diff using $new (+$diff) for $sp for qrg $qrg}) if (isdbg('rbnqrg') || isdbg('rbn'));
 316                                 $sp = $new;
 317                         }
 318                 }
 319                 unless ($cand) {
 320                         my ($i, $new);
 321                         for ($i = $tqrg; !$cand && $i >= $tqrg-$search; $i -= 1) {
 322                                 $new = "$call|$i";
 323                                 $cand = $spots->{$new}, last if exists $spots->{$new};
 324                         }
 325                         if ($cand) {
 326                                 my $diff = $tqrg - $i;
 327                                 dbg(qq{RBN: QRG Diff using $new (-$diff) for $sp for qrg $qrg}) if (isdbg('rbnqrg') || isdbg('rbn'));
 328                                 $sp = $new;
 329                         }
 330                 }
 331
 332                 # if we have one and there is only one slot and that slot's time isn't expired for respot then return
 333                 my $respot = 0;
 334                 if ($cand && ref $cand) {
 335                         if (@$cand <= CData) {
 336                                 unless ($self->{minspottime} > 0 && $now - $cand->[CTime] >= $self->{minspottime}) {
 337                                         dbg("RBN: key: '$sp' call: $call qrg: $qrg DUPE \@ ". atime(int $cand->[CTime])) if isdbg('rbn');
 338                                         return;
 339                                 }
 340
 341                                 dbg("RBN: key: '$sp' RESPOTTING call: $call qrg: $qrg last seen \@ ". atime(int $cand->[CTime])) if isdbg('rbn');
 342                                 $cand->[CTime] = $now;
 343                                 ++$respot;
 344                         }
 345
 346                         # otherwise we have a spot being built up at the moment
 347                 } elsif ($cand) {
 348                         dbg("RBN: key '$sp' = '$cand' not ref");
 349                         return;
 350                 }
 351
 352                 # here we either have an existing spot record buildup on the go, or we need to create the first one
 353                 unless ($cand) {
 354                         $spots->{$sp} = $cand = [$now, 0];
 355                         dbg("RBN: key: '$sp' call: $call qrg: $qrg NEW" . ($respot ? ' RESPOT' : '')) if isdbg('rbn');
 356                 }
 357
 358                 # add me to the display queue unless we are waiting for initial in rush to finish
 359                 return unless $noinrush || $self->{inrushpreventor} < $main::systime;
 360
 361                 # build up a new record and store it in the buildup
 362                 # deal with the unix time
 363                 my ($hh,$mm) = $t =~ /(\d\d)(\d\d)Z$/;
 364                 my $utz = $hh*3600 + $mm*60 + $main::systime_daystart; # possible issue with late spot from previous day
 365                 $utz -= 86400 if $utz > $now+3600;                                         # too far ahead, drag it back one day
 366
 367                 # create record and add into the buildup
 368                 my $r = [$origin, nearest(.1, $qrg), $call, $mode, $s, $t, $utz, $respot, $u];
 369                 my @s =  Spot::prepare($r->[RQrg], $r->[RCall], $r->[RUtz], '', $r->[ROrigin]);
 370                 if ($s[5] == 666) {
 371                         dbg("RBN: ERROR invalid prefix/callsign $call from $origin-# on $qrg, dumped");
 372                         return;
 373                 }
 374
 375                 if ($self->{inrbnfilter}) {
 376                         my ($want, undef) = $self->{inrbnfilter}->it($s);
 377                         return unless $want;
 378                 }
 379                 $r->[RSpotData] = \@s;
 380
 381                 ++$self->{queue}->{$sp};# unless @$cand>= CData; # queue the KEY (not the record)
 382
 383                 dbg("RBN: key: '$sp' ADD RECORD call: $call qrg: $qrg origin: $origin") if isdbg('rbn');
 384
 385                 push @$cand, $r;
 386
 387         } else {
 388                 dbg "RBN:DATA,$line" if isdbg('rbn');
 389         }
 390 }
 391
 392 # we should get the spot record minus the time, so just an array of record (arrays)
 393 sub send_dx_spot
 394 {
 395         my $self = shift;
 396         my $quality = shift;
 397         my $cand = shift;
 398
 399         ++$self->{norbn};
 400         ++$self->{norbn10};
 401         ++$self->{norbnhour};
 402
 403         # $r = [$origin, $qrg, $call, $mode, $s, $utz, $respot];
 404
 405         my $mode = $cand->[CData]->[RMode]; # as all the modes will be the same;
 406
 407         my @dxchan = DXChannel::get_all();
 408
 409         foreach my $dxchan (@dxchan) {
 410                 next unless $dxchan->is_user;
 411                 my $user = $dxchan->{user};
 412                 next unless $user &&  $user->wantrbn;
 413
 414                 # does this user want this sort of spot at all?
 415                 my $want = 0;
 416                 ++$want if $user->wantbeacon && $mode =~ /^BCN|DXF/;
 417                 ++$want if $user->wantcw && $mode =~ /^CW/;
 418                 ++$want if $user->wantrtty && $mode =~ /^RTT/;
 419                 ++$want if $user->wantpsk && $mode =~ /^PSK|FSK|MSK/;
 420                 ++$want if $user->wantft && $mode =~ /^FT/;
 421
 422                 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",
 423                                         $user->wantrbn,
 424                                         $user->wantft,
 425                                         $user->wantbeacon,
 426                                         $user->wantcw,
 427                                         $user->wantpsk,
 428                                         $user->wantrtty,
 429                                    )) if isdbg('rbnll');
 430
 431                 # send one spot to one user out of the ones that we have
 432                 $self->dx_spot($dxchan, $quality, $cand) if $want;
 433         }
 434 }
 435
 436 sub dx_spot
 437 {
 438         my $self = shift;
 439         my $dxchan = shift;
 440         my $quality = shift;
 441         my $cand = shift;
 442         my $call = $dxchan->{call};
 443
 444
 445         my $strength = 100;             # because it could if we talk about FTx
 446         my $saver;
 447
 448         my %zone;
 449         my %qrg;
 450         my $respot;
 451         my $qra;
 452
 453         ++$self->{nousers}->{$call};
 454         ++$self->{nousers10}->{$call};
 455         ++$self->{nousershour}->{$call};
 456
 457         my $filtered;
 458         my $rf = $dxchan->{rbnfilter} || $dxchan->{spotsfilter};
 459         my $comment;
 460
 461         foreach my $r (@$cand) {
 462                 # $r = [$origin, $qrg, $call, $mode, $s, $t, $utz, $respot, $qra];
 463                 # Spot::prepare($qrg, $call, $utz, $comment, $origin);
 464                 next unless ref $r;
 465
 466                 $respot = 1 if $r->[Respot];
 467                 $qra = $r->[RQra] if !$qra && $r->[RQra] && is_qra($r->[RQra]);
 468
 469                 $comment = sprintf "%-3s %2ddB $quality", $r->[RMode], $r->[RStrength];
 470                 my $s = $r->[RSpotData];                # the prepared spot
 471                 $s->[SComment] = $comment;              # apply new generated comment
 472
 473
 474                 ++$zone{$s->[SZone]};           # save the spotter's zone
 475                 ++$qrg{$s->[SQrg]};             # and the qrg
 476
 477
 478                 # save the lowest strength one
 479                 if ($r->[RStrength] < $strength) {
 480                         $strength = $r->[RStrength];
 481                         $saver = $s;
 482                         dbg("RBN: STRENGTH spot: $s->[SCall] qrg: $s->[SQrg] origin: $s->[SOrigin] dB: $r->[RStrength] < $strength") if isdbg 'rbnll';
 483                 }
 484
 485                 if ($rf) {
 486                         my ($want, undef) = $rf->it($s);
 487                         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';
 488                         next unless $want;
 489                         $filtered = $s;
 490 #                       last;
 491                 }
 492         }
 493
 494         if ($rf) {
 495                 $saver = $filtered;             # if nothing passed the filter's lips then $saver == $filtered == undef !
 496         }
 497
 498         if ($saver) {
 499                 my $buf;
 500                 # create a zone list of spotters
 501                 delete $zone{$saver->[SZone]};  # remove this spotter's zone (leaving all the other zones)
 502                 my $z = join ',', sort {$a <=> $b} keys %zone;
 503
 504                 # determine the most likely qrg and then set it
 505                 my $mv = 0;
 506                 my $fk;
 507                 my $c = 0;
 508                 while (my ($k, $v) = each %qrg) {
 509                         $fk = $k, $mv = $v if $v > $mv;
 510                         ++$c;
 511                 }
 512                 $saver->[SQrg] = $fk;
 513                 $saver->[SComment] .= '*' if $c > 1;
 514                 $saver->[SComment] .= '+' if $respot;
 515                 $saver->[SComment] .= " Z:$z" if $z;
 516                 if ($c > 1 && (isdbg('rbnqrg') || isdbg('rbn'))) {
 517
 518                 }
 519
 520                 dbg("RBN: SENDING to $call spot: $saver->[SCall] qrg: $saver->[SQrg] origin: $saver->[SOrigin] $saver->[SComment]") if isdbg 'rbnll';
 521                 if ($dxchan->{ve7cc}) {
 522                         my $call = $saver->[SOrigin];
 523                         $saver->[SOrigin] .= '-#';
 524                         $buf = VE7CC::dx_spot($dxchan, @$saver);
 525                         $saver->[SOrigin] = $call;
 526                 } else {
 527                         my $call = $saver->[SOrigin];
 528                         $saver->[SOrigin] = substr($call, 0, 6);
 529                         $saver->[SOrigin] .= '-#';
 530                         $buf = $dxchan->format_dx_spot(@$saver);
 531                         $saver->[SOrigin] = $call;
 532                 }
 533 #               $buf =~ s/^DX/RB/;
 534                 $dxchan->local_send('N', $buf);
 535
 536                 ++$self->{nospot};
 537                 ++$self->{nospot10};
 538                 ++$self->{nospothour};
 539
 540                 if ($qra) {
 541                         my $user = DXUser::get_current($saver->[SCall]) || DXUser->new($saver->[SCall]);
 542                         unless ($user->qra && is_qra($user->qra)) {
 543                                 $user->qra($qra);
 544                                 dbg("RBN: update qra on $saver->[SCall] to $qra");
 545                                 $user->put;
 546                         }
 547                 }
 548         }
 549 }
 550
 551 # per second
 552 sub process
 553 {
 554         foreach my $dxchan (DXChannel::get_all()) {
 555                 next unless $dxchan->is_rbn;
 556
 557                 # At this point we run the queue to see if anything can be sent onwards to the punter
 558                 my $now = $main::systime;
 559
 560                 # now run the waiting queue which just contains KEYS ($call|$qrg)
 561                 foreach my $sp (keys %{$dxchan->{queue}}) {
 562                         my $cand = $spots->{$sp};
 563                         unless ($cand && $cand->[CTime]) {
 564                                 dbg "RBN Cand $sp " . ($cand ? 'def' : 'undef') . " [CTime] " . ($cand->[CTime] ? 'def' : 'undef') . " dwell $dwelltime";
 565                                 next;
 566                         }
 567                         if ($now >= $cand->[CTime] + $dwelltime ) {
 568                                 # we have a candidate, create qualitee value(s);
 569                                 unless (@$cand > CData) {
 570                                         dbg "RBN: QUEUE key '$sp' MISSING RECORDS, IGNORED" . dd($cand) if isdbg 'rbn';
 571                                         next;
 572                                 }
 573                                 dbg "RBN: QUEUE PROCESSING key: '$sp' $now >= $cand->[CTime]" if isdbg 'rbnqueue';
 574                                 my $r = $cand->[CData];
 575                                 my $quality = @$cand - CData;
 576                                 $quality = 9 if $quality > 9;
 577                                 $cand->[CQual] = $quality if $quality > $cand->[CQual];
 578                                 my $squality = "Q:$cand->[CQual]";
 579
 580                                 if ($cand->[CQual] >= $minqual) {
 581                                         if (isdbg('progress')) {
 582                                                 my $s = "RBN: SPOT key: '$sp' = $r->[RCall] on $r->[RQrg] by $r->[ROrigin] \@ $r->[RTime] $squality route: $dxchan->{call}";
 583                                                 dbg($s);
 584                                         }
 585                                         send_dx_spot($dxchan, $squality, $cand);
 586                                 } elsif (isdbg('rbn')) {
 587                                         my $s = "RBN: SPOT IGNORED(Q $cand->[CQual] < $minqual) key: '$sp' = $r->[RCall] on $r->[RQrg] by $r->[ROrigin] \@ $r->[RTime] $squality route: $dxchan->{call}";
 588                                         dbg($s);
 589                                 }
 590
 591                                 # clear out the data and make this now just "spotted", but no further action required until respot time
 592                                 dbg "RBN: QUEUE key '$sp' cleared" if isdbg 'rbn';
 593
 594                                 $spots->{$sp} = [$now, $cand->[CQual]];
 595                                 delete $dxchan->{queue}->{$sp};
 596                         } else {
 597                                 dbg sprintf("RBN: QUEUE key: '$sp' SEND time not yet reached %.1f secs left", $cand->[CTime] + $dwelltime - $now) if isdbg 'rbnqueue';
 598                         }
 599                 }
 600         }
 601
 602 }
 603
 604 sub per_minute
 605 {
 606         foreach my $dxchan (DXChannel::get_all()) {
 607                 next unless $dxchan->is_rbn;
 608                 dbg "RBN:STATS minute $dxchan->{call} raw: $dxchan->{noraw} sent: $dxchan->{norbn} delivered: $dxchan->{nospot} users: " . scalar keys %{$dxchan->{nousers}} if isdbg('rbnstats');
 609                 if ($dxchan->{noraw} == 0 && $dxchan->{lasttime} > 60) {
 610                         LogDbg('RBN', "RBN: no input from $dxchan->{call}, disconnecting");
 611                         $dxchan->disconnect;
 612                 }
 613                 $dxchan->{noraw} = $dxchan->{norbn} = $dxchan->{nospot} = 0; $dxchan->{nousers} = {};
 614                 $runtime{$dxchan->{call}} += 60;
 615         }
 616
 617         # save the spot cache
 618         write_cache() unless $main::systime + $startup_delay < $main::systime;;
 619 }
 620
 621 sub per_10_minute
 622 {
 623         my $count = 0;
 624         my $removed = 0;
 625         while (my ($k,$cand) = each %{$spots}) {
 626                 next if $k eq 'VERSION';
 627                 next if $k =~ /^O\|/;
 628
 629                 if ($main::systime - $cand->[CTime] > $minspottime*2) {
 630                         delete $spots->{$k};
 631                         ++$removed;
 632                 }
 633                 else {
 634                         ++$count;
 635                 }
 636         }
 637         dbg "RBN:STATS spot cache remain: $count removed: $removed"; # if isdbg('rbn');
 638         foreach my $dxchan (DXChannel::get_all()) {
 639                 next unless $dxchan->is_rbn;
 640                 my $nq = keys %{$dxchan->{queue}};
 641                 dbg "RBN:STATS 10-minute $dxchan->{call} queue: $nq raw: $dxchan->{noraw10} sent: $dxchan->{norbn10} delivered: $dxchan->{nospot10} users: " . scalar keys %{$dxchan->{nousers10}};
 642                 $dxchan->{noraw10} = $dxchan->{norbn10} = $dxchan->{nospot10} = 0; $dxchan->{nousers10} = {};
 643         }
 644 }
 645
 646 sub per_hour
 647 {
 648         foreach my $dxchan (DXChannel::get_all()) {
 649                 next unless $dxchan->is_rbn;
 650                 my $nq = keys %{$dxchan->{queue}};
 651                 dbg "RBN:STATS hour $dxchan->{call} queue: $nq raw: $dxchan->{norawhour} sent: $dxchan->{norbnhour} delivered: $dxchan->{nospothour} users: " . scalar keys %{$dxchan->{nousershour}};
 652                 $dxchan->{norawhour} = $dxchan->{norbnhour} = $dxchan->{nospothour} = 0; $dxchan->{nousershour} = {};
 653         }
 654 }
 655
 656 sub finish
 657 {
 658         write_cache();
 659 }
 660
 661 sub write_cache
 662 {
 663         my $fh = IO::File->new(">$cachefn") or confess("writing $cachefn $!");
 664         my $s = $json->encode($spots);
 665         $fh->print($s);
 666         $fh->close;
 667 }
 668
 669 sub check_cache
 670 {
 671         if (-e $cachefn) {
 672                 my $mt = (stat($cachefn))[9];
 673                 my $t = $main::systime - $mt || 1;
 674                 my $p = difft($mt, 2);
 675                 if ($t < $cache_valid) {
 676                         dbg("RBN:check_cache '$cachefn' spot cache exists, created $p ago and not too old");
 677                         my $fh = IO::File->new($cachefn);
 678                         my $s;
 679                         if ($fh) {
 680                                 local $/ = undef;
 681                                 $s = <$fh>;
 682                                 dbg("RBN:check_cache cache read size " . length $s);
 683                                 $fh->close;
 684                         } else {
 685                                 dbg("RBN:check_cache file read error $!");
 686                                 return undef;
 687                         }
 688                         if ($s) {
 689                                 eval {$spots = $json->decode($s)};
 690                                 if ($spots && ref $spots) {
 691                                         if (exists $spots->{VERSION} && $spots->{VERSION} == $DATA_VERSION) {
 692                                                 # now clean out anything that is current
 693                                                 while (my ($k, $cand) = each %$spots) {
 694                                                         next if $k eq 'VERSION';
 695                                                         next if $k =~ /^O\|/;
 696                                                         if (@$cand > CData) {
 697                                                                 $spots->{$k} = [$cand->[CTime], $cand->[CQual]];
 698                                                         }
 699                                                 }
 700                                                 dbg("RBN:check_cache spot cache restored");
 701                                                 return 1;
 702                                         }
 703                                 }
 704                         }
 705                         dbg("RBN::checkcache error decoding $@");
 706                 } else {
 707                         my $d = difft($main::systime-$cache_valid);
 708                         dbg("RBN::checkcache '$cachefn' created $p ago is too old (> $d), ignored");
 709                 }
 710         } else {
 711                 dbg("RBN:check_cache '$cachefn' spot cache not present");
 712         }
 713
 714         return undef;
 715 }
 716
 717 1;