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