From 102b51ca564ef29e7f84d2cf65d0eaa5fdab671a Mon Sep 17 00:00:00 2001 From: Dirk Koopman Date: Sun, 10 May 2020 23:42:22 +0100 Subject: [PATCH] Initial user multiple attachments!! This will, after 3 (default) bumpoffs with 5 mins (default) it will allow up $main::allowmultiple (if set > 1) connections with different ssids BUT THE SAME user record. Strip out echo and blank cmds from progress debugging unless set/debug 'echo' is set. --- Changes | 3 ++ cmd/bye.pl | 2 +- perl/DXChannel.pm | 4 +- perl/DXCommandmode.pm | 4 +- perl/DXUser.pm | 12 ++++- perl/DXUtil.pm | 41 ++++++++++++++++- perl/cluster.pl | 101 ++++++++++++++++++++++++++++++------------ perl/console.pl | 5 ++- 8 files changed, 135 insertions(+), 37 deletions(-) diff --git a/Changes b/Changes index e88b9091..95ca1a41 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,6 @@ +10May20======================================================================= +1. Added basic changes so that users *could* have multiple connections to the + same node if it is allowed. 09May20======================================================================= 1. Show the route by which this PCxx came in progress debugging reports. In some other words: the spot/wwv/wcy/ann message arrived first from this diff --git a/cmd/bye.pl b/cmd/bye.pl index d43e257a..be2ba79c 100644 --- a/cmd/bye.pl +++ b/cmd/bye.pl @@ -9,7 +9,7 @@ my $self = shift; return (1, $self->msg('e5')) if $self->inscript || $self->remotecmd; my $fn = localdata("logout"); -dbg("fn: $fn " . (-e $fn ? 'exists' : 'missing')); +#dbg("fn: $fn " . (-e $fn ? 'exists' : 'missing')); if ($self->is_user && -e $fn) { $self->send_file($fn); diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index fbdbeee3..0e543e9c 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -161,7 +161,7 @@ sub alloc $self->{group} = $user->group; $self->{sort} = $user->sort; } - $self->{startt} = $self->{t} = time; + $self->{startt} = $self->{t} = $main::systime; $self->{state} = 0; $self->{oldstate} = 0; $self->{lang} = $main::lang if !$self->{lang}; @@ -497,7 +497,7 @@ sub disconnect my $self = shift; my $user = $self->{user}; - $user->close() if defined $user; + $user->close($self->{startt}, $self->{hostname}) if defined $user; $self->{conn}->disconnect if $self->{conn}; $self->del(); } diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 1dd868c0..18c5807b 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -547,13 +547,13 @@ sub run_cmd my $t0 = [gettimeofday]; eval { @ans = &{"${package}::handle"}($self, $args) }; if ($@) { - dbgprintring(25); + DXDebug::dbgprintring(25); return (DXDebug::shortmess($@)); } if (isdbg('progress')) { my $msecs = _diffms($t0); my $s = "CMD: '$cmd $args' by $call ip: $self->{hostname} ${msecs}mS"; - dbg($s); + dbg($s) if $cmd =~/(?:echo|blank)/ || isdbg('echo'); # cut down a bit on HRD and other clients' noise } } else { dbg("cmd: $package not present") if isdbg('command'); diff --git a/perl/DXUser.pm b/perl/DXUser.pm index d385382b..57bef501 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -30,6 +30,7 @@ $lasttime = 0; $lrusize = 2000; $tooold = 86400 * 365; # this marks an old user who hasn't given enough info to be useful $v3 = 0; +our $maxconnlist = 3; # remember this many connection time (duration) [start, end] pairs # hash of valid elements and a simple prompt %valid = ( @@ -91,6 +92,8 @@ $v3 = 0; believe => '1,Believable nodes,parray', lastping => '1,Last Ping at,ptimelist', maxconnect => '1,Max Connections', + startt => '0,Start Time,cldatetime', + connlist => '1,Connections,parraydifft', ); #no strict; @@ -395,7 +398,14 @@ sub del sub close { my $self = shift; - $self->{lastin} = time; + my $startt = shift; + my $ip = shift; + $self->{lastin} = $main::systime; + # add a record to the connect list + my $ref = [$startt || $self->{startt}, $main::systime]; + push @$ref, $ip if $ip; + push @{$self->{connlist}}, $ref; + shift @{$self->{connlist}} if @{$self->{connlist}} > $maxconnlist; $self->put(); } diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index 551a6192..b7c45519 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -27,7 +27,7 @@ require Exporter; print_all_fields cltounix unpad is_callsign is_latlong is_qra is_freq is_digits is_pctext is_pcflag insertitem deleteitem is_prefix dd is_ipaddr $pi $d2r $r2d localdata localdata_mv - diffms _diffms + diffms _diffms difft parraydifft ); @@ -522,3 +522,42 @@ sub diffms $s .= " $no lines" if $no; DXDebug::dbg($s); } + +# expects either an array reference or two times (in the correct order [start, end]) +sub difft +{ + my $b = shift; + my $t; + if (ref $b eq 'ARRAY') { + $t = $b->[1] - $b->[0]; + } else { + $t = shift() - $b; + } + return '-(ve)' if $t < 0; + my ($d,$h,$m,$s); + my $out = ''; + $d = int $t / 86400; + $out .= "${d}d" if $d; + $t -= $d * 86400; + $h = int $t / 3600; + $out .= "${h}h" if $h || $d; + $t -= $h * 3600; + $m = int $t / 60; + $out .= "${m}m" if $m || $h || $d; + $s = int $t % 60; + $out .= "${s}s"; + return $out; +} + +# print an array ref of difft refs +sub parraydifft +{ + my $r = shift; + my $out = ''; + for (@$r) { + my $s = $_->[2] ? "($_->[2])" : ''; + $out .= sprintf "%s=%s$s, ", atime($_->[0]), difft($_->[0], $_->[1]); + } + $out =~ s/,\s*$//; + return $out; +} diff --git a/perl/cluster.pl b/perl/cluster.pl index 18460f14..6c0ff3d6 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -166,6 +166,16 @@ $starttime = 0; # the starting time of the cluster @listeners = (); # list of listeners $reqreg = 0; # 1 = registration required, 2 = deregister people $bumpexisting = 1; # 1 = allow new connection to disconnect old, 0 - don't allow it +our $allowmultiple = 0; # This is used in conjunction with $bumpexisting, in a rather weird way. +our $min_reconnection_rate = 5*60; # minimum value of seconds between connections per user to allow co-existing users +our $max_ssid = 15; # highest ssid to be searched for a spare one on multiple connections + +# If $allowmultiple > 0 and the $reconnection_rate is some value of seconds +# based on the average connection time calculated from the $user->conntimel entries / frequency is +# less than $reconnection_rate then we assume that there is more than one device (probably HRD) trying +# to connect "at once". In which case we probe for a spare SSID for a user callsign to allow up to +# $allowmultiple connections per callsign. + $allowdxby = 0; # 1 = allow "dx by ", 0 - don't allow it $maxconnect_user = 3; # the maximum no of concurrent connections a user can have at a time $maxconnect_node = 0; # Ditto but for nodes. In either case if a new incoming connection @@ -220,6 +230,7 @@ sub new_channel $user->long($main::mylongitude); $user->qra($main::mylocator); } + $user->startt($main::systime); $conn->conns($call); $dxchan = Web->new($call, $conn, $user); $dxchan->enhanced(1); @@ -233,27 +244,73 @@ sub new_channel return; } + # is he locked out ? + my $basecall = $call; + $basecall =~ s/-\d+$//; # remember this for later multiple user processing + my $baseuser = DXUser::get_current($basecall); + my $lock = $user->lockout if $user; + if ($baseuser && $baseuser->lockout || $lock) { + if (!$user || !defined $lock || $lock) { + my $host = $conn->peerhost; + LogDbg('DXCommand', "$call on $host is locked out, disconnected"); + $conn->disconnect; + return; + } + } + # set up the basic channel info for "Normal" Users # is there one already connected to me - locally? - + $user = DXUser::get_current($call); $dxchan = DXChannel::get($call); + my $newcall = $call; if ($dxchan) { if ($user && $user->is_node) { already_conn($conn, $call, DXM::msg($lang, 'conother', $call, $main::mycall)); return; } - if ($bumpexisting) { - my $ip = $dxchan->hostname; - $dxchan->send_now('D', DXM::msg($lang, 'conbump', $call, $ip)); - LogDbg('DXCommand', "$call bumped off by $ip, disconnected"); - $dxchan->disconnect; - } else { - already_conn($conn, $call, DXM::msg($lang, 'conother', $call, $main::mycall)); - return; + if ($allowmultiple && $user->is_user) { + # determine whether we are a candidate, have we flip-flopped frequently enough? + my @lastconns = @{$user->connlist} if $user->connlist; + my $allow = 0; + if (@lastconns >= $DXUser::maxconnlist) { + $allow = $lastconns[-1]->[0] - $lastconns[0]->[0] < $min_reconnection_rate; + } + # search for a spare ssid + L1: for (my $count = $call =~ /-\d+$/?0:1; $allow && $count < $allowmultiple; ) { # remember we have one call already + my $lastid = 1; + for (; $lastid < $max_ssid && $count < $allowmultiple; ++$lastid) { + my $chan = DXChannel::get("$basecall-$lastid"); + if ($chan) { + ++$count; + next; + } + # we have a free call-ssid, save it + $newcall = "$basecall-$lastid"; + last L1; + } + } } + + # handle "normal" (non-multiple) connections in the existing way + if ($call eq $newcall) { + if ($bumpexisting) { + my $ip = $dxchan->hostname; + $dxchan->send_now('D', DXM::msg($lang, 'conbump', $call, $ip)); + LogDbg('DXCommand', "$call bumped off by $ip, disconnected"); + $dxchan->disconnect; + } else { + already_conn($conn, $call, DXM::msg($lang, 'conother', $call, $main::mycall)); + return; + } + } + + # make sure that the conn has the (possibly) new callsign + $conn->conns($newcall); + $msg =~ s/$call/$newcall/; } - + + # (fairly) politely disconnect people that are connected to too many other places at once my $r = Route::get($call); if ($conn->{sort} && $conn->{sort} =~ /^I/ && $r && $user) { @@ -262,7 +319,7 @@ sub new_channel my $c = $user->maxconnect; my $v; $v = defined $c ? $c : $m; - if ($v && @n >= $v) { + if ($v && @n >= $v+$allowmultiple) { my $nodes = join ',', @n; LogDbg('DXCommand', "$call has too many connections ($v) at $nodes - disconnected"); already_conn($conn, $call, DXM::msg($lang, 'contomany', $call, $v, $nodes)); @@ -270,20 +327,6 @@ sub new_channel } } - # is he locked out ? - my $basecall = $call; - $basecall =~ s/-\d+$//; - my $baseuser = DXUser::get_current($basecall); - my $lock = $user->lockout if $user; - if ($baseuser && $baseuser->lockout || $lock) { - if (!$user || !defined $lock || $lock) { - my $host = $conn->peerhost; - LogDbg('DXCommand', "$call on $host is locked out, disconnected"); - $conn->disconnect; - return; - } - } - if ($user) { $user->{lang} = $main::lang if !$user->{lang}; # to autoupdate old systems } else { @@ -291,16 +334,16 @@ sub new_channel } # create the channel + # NOTE we are SHARING the same $user if $allowmultiple is > 1 + + $user->startt($systime); # mark the start time of this connection if ($user->is_node) { $dxchan = DXProt->new($call, $conn, $user); } elsif ($user->is_user) { - $dxchan = DXCommandmode->new($call, $conn, $user); + $dxchan = DXCommandmode->new($newcall, $conn, $user); } else { die "Invalid sort of user on $call = $sort"; } - - # check that the conn has a callsign - $conn->conns($call) if $conn->isa('IntMsg'); } diff --git a/perl/console.pl b/perl/console.pl index 66361808..cd4a4492 100755 --- a/perl/console.pl +++ b/perl/console.pl @@ -261,7 +261,10 @@ sub rec_socket cease(1); } if (defined $msg) { - my ($sort, $call, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/; + my ($sort, $incall, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/; + + # change my call if my node says "tonight Michael you are Jane" or something like that... + $call = $incall if $call ne $incall; $line =~ s/[\x00-\x06\x08\x0a-\x19\x1b-\x1f\x80-\x9f]/./g; # immutable CSI sequence + control characters if ($sort && $sort eq 'D') { -- 2.34.1