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 DXUtil;
  15 use DXDebug;
  16 use DXLog;
  17 use DXUser;
  18 use DXChannel;
  19 use Math::Round qw(nearest);
  20 use Date::Parse;
  21 use Time::HiRes qw(clock_gettime CLOCK_REALTIME);
  22
  23 our @ISA = qw(DXChannel);
  24
  25 our $startup_delay =0;#3*60;            # don't send anything out until this timer has expired
  26                                 # this is to allow the feed to "warm up" with duplicates
  27                                 # so that the "big rush" doesn't happen.
  28
  29 our $minspottime = 60*60;               # the time between respots of a callsign - if a call is
  30                                 # still being spotted (on the same freq) and it has been
  31                                 # spotted before, it's spotted again after this time
  32                                 # until the next minspottime has passed.
  33
  34 our $dwelltime = 6;                     # the amount of time to wait for duplicates before issuing
  35                                 # a spot to the user (no doubt waiting with bated breath).
  36
  37
  38 sub new
  39 {
  40         my $self = DXChannel::alloc(@_);
  41
  42         # routing, this must go out here to prevent race condx
  43         my $pkg = shift;
  44         my $call = shift;
  45
  46         DXProt::_add_thingy($main::routeroot, [$call, 0, 0, 1, undef, undef, $self->hostname], );
  47         $self->{d} = {};
  48         $self->{spot} = {};
  49         $self->{last} = 0;
  50         $self->{noraw} = 0;
  51         $self->{nospot} = 0;
  52         $self->{norbn} = 0;
  53         $self->{sort} = 'N';
  54         $self->{lasttime} = $main::systime;
  55         $self->{minspottime} = $minspottime;
  56         $self->{showstats} = 0;
  57
  58         return $self;
  59 }
  60
  61 sub start
  62 {
  63         my ($self, $line, $sort) = @_;
  64         my $user = $self->{user};
  65         my $call = $self->{call};
  66         my $name = $user->{name};
  67         my $dref = $self->{d};
  68         my $spotref = $self->{spot};
  69
  70         # log it
  71         my $host = $self->{conn}->peerhost;
  72         $host ||= "unknown";
  73         $self->{hostname} = $host;
  74
  75         $self->{name} = $name ? $name : $call;
  76         $self->state('prompt');         # a bit of room for further expansion, passwords etc
  77         $self->{lang} = $user->lang || $main::lang || 'en';
  78         if ($line =~ /host=/) {
  79                 my ($h) = $line =~ /host=(\d+\.\d+\.\d+\.\d+)/;
  80                 $line =~ s/\s*host=\d+\.\d+\.\d+\.\d+// if $h;
  81                 unless ($h) {
  82                         ($h) = $line =~ /host=([\da..fA..F:]+)/;
  83                         $line =~ s/\s*host=[\da..fA..F:]+// if $h;
  84                 }
  85                 $self->{hostname} = $h if $h;
  86         }
  87         $self->{width} = 80 unless $self->{width} && $self->{width} > 80;
  88         $self->{consort} = $line;       # save the connection type
  89
  90         LogDbg('DXCommand', "$call connected from $self->{hostname}");
  91
  92         # set some necessary flags on the user if they are connecting
  93         $self->{registered} = 1;
  94         # sort out privilege reduction
  95         $self->{priv} = 0;
  96
  97         # get the filters
  98         my $nossid = $call;
  99         $nossid =~ s/-\d+$//;
 100
 101         $self->{spotsfilter} = Filter::read_in('spots', $call, 0)
 102                 || Filter::read_in('spots', $nossid, 0)
 103                         || Filter::read_in('spots', 'user_default', 0);
 104
 105         # clean up qra locators
 106         my $qra = $user->qra;
 107         $qra = undef if ($qra && !DXBearing::is_qra($qra));
 108         unless ($qra) {
 109                 my $lat = $user->lat;
 110                 my $long = $user->long;
 111                 $user->qra(DXBearing::lltoqra($lat, $long)) if (defined $lat && defined $long);
 112         }
 113
 114         # start inrush timer
 115         $self->{inrushpreventor} = $main::systime + $startup_delay;
 116 }
 117
 118 my @queue;                                              # the queue of spots ready to send
 119
 120 sub normal
 121 {
 122         my $self = shift;
 123         my $line = shift;
 124         my @ans;
 125         my $spots = $self->{spot};
 126
 127         # save this for them's that need it
 128         my $rawline = $line;
 129
 130         # remove leading and trailing spaces
 131         chomp $line;
 132         $line =~ s/^\s*//;
 133         $line =~ s/\s*$//;
 134
 135         # add base RBN
 136
 137         my $tim = $main::systime;
 138
 139         # parse line
 140         dbg "RBN:RAW,$line" if isdbg('rbnraw');
 141         return unless $line=~/^DX\s+de/;
 142
 143         my (undef, undef, $origin, $qrg, $call, $mode, $s, $m, $spd, $u, $sort, $t, $tx) = split /[:\s]+/, $line;
 144
 145         # fix up FT8 spots from 7001
 146         $t = $u, $u = '' if !$t && is_ztime($u);
 147         $t = $sort, $sort = '' if !$t && is_ztime($sort);
 148         my $qra = $spd, $spd = '' if is_qra($spd);
 149         $u = $qra if $qra;
 150
 151         $origin =~ s/\-(?:\d{1,2}\-)?\#$//; # get rid of all the crap we aren't interested in
 152
 153
 154         $sort ||= '';
 155         $tx ||= '';
 156         $qra ||= '';
 157     dbg qq{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');
 158
 159
 160         my $b;
 161
 162         if ($t || $tx) {
 163
 164                 # fix up times for things like 'NXDXF B' etc
 165                 if ($tx && is_ztime($t)) {
 166                         if (is_ztime($tx)) {
 167                                 $b = $t;
 168                                 $t = $tx;
 169                         } else {
 170                                 dbg "RBN:ERR,$line";
 171                                 return (0);
 172                         }
 173                 }
 174                 if ($sort && $sort eq 'NCDXF') {
 175                         $mode = 'DXF';
 176                         $t = $tx;
 177                 }
 178                 if ($sort && $sort eq 'BEACON') {
 179                         $mode = 'BCN';
 180                 }
 181                 if ($mode =~ /^PSK/) {
 182                         $mode = 'PSK';
 183                 }
 184                 if ($mode eq 'RTTY') {
 185                         $mode = 'RTT';
 186                 }
 187
 188                 # We have an RBN data line, dedupe it very simply on time, ignore QRG completely.
 189                 # This works because the skimmers are NTP controlled (or should be) and will receive
 190                 # the spot at the same time (velocity factor of the atmosphere and network delays
 191                 # carefully (not) taken into account :-)
 192
 193                 # Note, there is no intelligence here, but there are clearly basic heuristics that could
 194                 # be applied at this point that reject (more likely rewrite) the call of a busted spot that would
 195                 # useful for a zonal hotspot requirement from the cluster node.
 196
 197                 # In reality, this mechanism would be incorporated within the cluster code, utilising the dxqsl database,
 198                 # and other resources in DXSpider, thus creating a zone map for an emitted spot. This is then passed through the
 199                 # normal "to-user" spot system (where normal spots are sent to be displayed per user) and then be
 200                 # processed through the normal, per user, spot filtering system - like a regular spot.
 201
 202                 # The key to this is deducing the true callsign by "majority voting" (the greater the number of spotters
 203         # the more effective this is) together with some lexical analsys probably in conjuction with DXSpider
 204                 # 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)
 205                 # and some heuristical "Kwalitee" rating given distance from the zone centres of spotter, recipient user
 206         # and spotted. A map can be generated once per user and spotter as they are essentially mostly static.
 207                 # The spotted will only get a coarse position unless other info is available. Programs that parse
 208                 # DX bulletins and the online data online databases could be be used and then cached.
 209
 210                 # Obviously users have to opt in to receiving RBN spots and other users will simply be passed over and
 211                 # ignored.
 212
 213                 # Clearly this will only work in the 'mojo' branch of DXSpider where it is possible to pass off external
 214                 # data requests to ephemeral or semi resident forked processes that do any grunt work and the main
 215                 # process to just the standard "message passing" which has been shown to be able to sustain over 5000
 216                 # per second (limited by the test program's output and network speed, rather than DXSpider's handling).
 217
 218                 my $nqrg = nearest(.5, $qrg);  # normalised to nearest Khz
 219                 my $sp = "$call|$nqrg";           # hopefully the skimmers will be calibrated at least this well!
 220
 221                 # do we have it?
 222                 my $spot = $spots->{$sp};
 223
 224                 # if we have one and there is only one slot and that slot's time isn't expired for respot then return
 225                 my $respot = 0;
 226                 if ($spot && @$spot == 1) {
 227                         unless ($self->{minspottime} > 0 && $tim - $spot->[0] >= $self->{minspottime}) {
 228                                 dbg("RBN: key: '$sp' call: $call qrg: $qrg DUPE \@ ". atime(int $spot->[0])) if isdbg('rbn');
 229                                 return;
 230                         }
 231                         dbg("RBN: key: '$sp' RESPOTTING call: $call qrg: $qrg last seen \@ ". atime(int $spot->[0])) if isdbg('rbn');
 232                         ++$respot;
 233                 }
 234
 235                 # here we either have an existing spot record buildup on the go, or we need to create the first one
 236                 unless ($spot) {
 237                         $spot = [clock_gettime(CLOCK_REALTIME)];
 238                         $spots->{$sp} = $spot;
 239                         dbg("RBN: key: '$sp' call: $call qrg: $qrg NEW") if isdbg('rbn');
 240                 }
 241
 242                 # add me to the display queue unless we are waiting for initial in rush to finish
 243                 return unless $self->{inrushpreventor} < $main::systime;
 244                 push @queue, $sp if @$spot == 1; # queue the KEY (not the record)
 245
 246                 # build up a new record and store it in the buildup
 247                 # deal with the unix time
 248                 my ($hh,$mm) = $t =~ /(\d\d)(\d\d)Z$/;
 249                 my $utz = $hh*3600 + $mm*60 + $main::systime_daystart; # possible issue with late spot from previous day
 250                 $utz -= 86400 if $utz > $tim+3600;                                         # too far ahead, drag it back one day
 251
 252                 # create record and add into the buildup
 253                 my $r = [$origin, nearest(.1, $qrg), $call, $mode, $s, $t, $utz, $respot];
 254                 dbg("RBN: key: '$sp' ADD RECORD call: $call qrg: $qrg origin: $origin") if isdbg('rbn');
 255
 256                 push @$spot, $r;
 257
 258                 # At this point we run the queue to see if anything can be sent onwards to the punter
 259                 my $now = clock_gettime(CLOCK_REALTIME);
 260
 261                 # now run the waiting queue which just contains KEYS ($call|$qrg)
 262                 foreach $sp (@queue) {
 263                         my $cand = $spots->{$sp};
 264                         if ($now >= $cand->[0]+$dwelltime ) {
 265                                 # we have a candidate, create qualitee value(s);
 266                                 unless (@$cand > 1) {
 267                                         dbg "RBN: QUEUE key '$sp' MISSING RECORDS " . dd($cand) if isdbg 'rbn';
 268                                         shift @queue;
 269                                         next;
 270                                 }
 271                                 my $savedtime = shift @$cand; # save the start time
 272                                 my $r = $cand->[0];
 273                                 my $quality = @$cand;
 274                                 $quality = 9 if $quality > 9;
 275                                 $quality = "Q:$quality";
 276                                 if (isdbg('progress')) {
 277                                         my $s = "RBN: SPOT key: '$sp' = $r->[2] on $r->[1] \@ $r->[5] $quality";
 278                                         $s .=  " route: $self->{call}";
 279                                         dbg($s);
 280                                 }
 281
 282                                 send_dx_spot($self, $quality, $cand);
 283
 284                                 # clear out the data and make this now just "spotted", but no further action required until respot time
 285                                 dbg "RBN: QUEUE key '$sp' cleared" if isdbg 'rbn';
 286                                 $spots->{$sp} = [$savedtime];
 287                                 shift @queue;
 288                         } else {
 289                                 dbg sprintf("RBN: QUEUE key: '$sp' SEND time not yet reached %.1f secs left", $spot->[0] + $dwelltime - $now) if isdbg 'rbnqueue';
 290                         }
 291                 }
 292
 293
 294         } else {
 295                 dbg "RBN:DATA,$line" if isdbg('rbn');
 296         }
 297
 298         #       # periodic clearing out of the two caches
 299         if (($tim % 60 == 0 && $tim > $self->{last}) || ($self->{last} && $tim >= $self->{last} + 60)) {
 300                 my $count = 0;
 301                 my $removed = 0;
 302                 while (my ($k,$v) = each %{$spots}) {
 303                         if ($tim - $v->[0] > $self->{minspottime}*2) {
 304                                 delete $spots->{$k};
 305                                 ++$removed;
 306                         }
 307                         else {
 308                                 ++$count;
 309                         }
 310                 }
 311                 dbg "RBN:ADMIN,spot cache: $removed removed $count remain"; # if isdbg('rbn');
 312                 dbg "RBN:" . join(',', "STAT", $self->{noraw}, $self->{norbn}, $self->{nospot}) if $self->{showstats};
 313                 $self->{noraw} = $self->{norbn} = $self->{nospot} = 0;
 314                 $self->{last} = int($tim / 60) * 60;
 315         }
 316 }
 317
 318
 319
 320 #       }
 321 # }
 322
 323 # we should get the spot record minus the time, so just an array of record (arrays)
 324 sub send_dx_spot
 325 {
 326         my $self = shift;
 327         my $quality = shift;
 328         my $spot = shift;
 329
 330         # $r = [$origin, $qrg, $call, $mode, $s, $utz, $respot];
 331
 332         my $mode = $spot->[0]->[3]; # as all the modes will be the same;
 333
 334         my @dxchan = DXChannel::get_all();
 335
 336         foreach my $dxchan (@dxchan) {
 337                 next unless $dxchan->is_user;
 338                 my $user = $dxchan->{user};
 339                 next unless $user &&  $user->wantrbn;
 340
 341                 # does this user want this sort of spot at all?
 342                 my $want = 0;
 343                 ++$want if $user->wantbeacon && $mode =~ /^BCN|DXF/;
 344                 ++$want if $user->wantcw && $mode =~ /^CW/;
 345                 ++$want if $user->wantrtty && $mode =~ /^RTT/;
 346                 ++$want if $user->wantpsk && $mode =~ /^PSK/;
 347                 ++$want if $user->wantcw && $mode =~ /^CW/;
 348                 ++$want if $user->wantft && $mode =~ /^FT/;
 349                 ++$want unless $want;   # send everything if nothing is selected.
 350
 351                 next unless $want;
 352
 353                 # send one spot to one user out of the ones that we have
 354                 $self->dx_spot($dxchan, $quality, $spot) if $want;
 355         }
 356 }
 357
 358 sub dx_spot
 359 {
 360         my $self = shift;
 361         my $dxchan = shift;
 362         my $quality = shift;
 363         my $spot = shift;
 364
 365         my $strength = 100;             # because it could if we talk about FTx
 366         my $saver;
 367
 368         my %zone;
 369
 370         foreach my $r (@$spot) {
 371                 # $r = [$origin, $qrg, $call, $mode, $s, $t, $utz, $respot];
 372                 # Spot::prepare($qrg, $call, $utz, $comment, $origin);
 373
 374                 my $comment = sprintf "%-3s %2ddB $quality", $r->[3], $r->[4];
 375                 my @s =  Spot::prepare($r->[1], $r->[2], $r->[6], $comment, $r->[0]);
 376
 377                 ++$zone{$s[11]};                # save the spotter's zone
 378
 379                 # save the highest strength one
 380                 if ($r->[4] < $strength) {
 381                         $strength = $r->[4];
 382                         $saver = \@s;
 383                         dbg("RBN: STRENGTH call: $s[1] qrg: $s[0] origin: $s[4] dB: $r->[4]") if isdbg 'rbn';
 384                 }
 385
 386                 my $filter = 0;
 387
 388                 if ($dxchan->{rbnfilter}) {
 389                         ($filter, undef) = $dxchan->{rbnfilter}->it(\@s);
 390                         next unless $filter;
 391                         $saver = \@s;
 392                         dbg("RBN: FILTERED call: $s[1] qrg: $s[0] origin: $s[4] dB: $r->[4]") if isdbg 'rbn';
 393                         last;
 394                 }
 395
 396         }
 397
 398         if ($saver) {
 399                 my $buf;
 400                 delete $zone{$saver->[11]};  # remove this spotter's zone (leaving all the other zones)
 401                 my $z = join ',', sort {$a <=> $b} keys %zone;
 402                 $saver->[3] .= " Z:$z" if length $z;
 403                 dbg("RBN: SENDING call: $saver->[1] qrg: $saver->[0] origin: $saver->[4] $saver->[3]") if isdbg 'rbn';
 404                 if ($dxchan->{ve7cc}) {
 405                         $buf = VE7CC::dx_spot($dxchan, @$saver);
 406                 } else {
 407                         $buf = $dxchan->format_dx_spot(@$saver);
 408                 }
 409                 $buf =~ s/^DX/RB/;
 410                 $dxchan->local_send('N', $buf);
 411         }
 412 }
 413
 414 1;