X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2Fcluster.pl;h=1faef1781c955d24d0f72670935257b981a0840a;hb=01b01c20b852c5d4c7e14c13313664beedb03930;hp=87811af8457f11004dc972e114e56d728443d8b2;hpb=91a3d0439029d8bb76f3439aa9ecc0e699f5a195;p=spider.git diff --git a/perl/cluster.pl b/perl/cluster.pl index 87811af8..1faef178 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -89,11 +89,12 @@ use SysVar; use strict; -use Mojolicious 7.26; +# order here is important - DXDebug snarfs Carp et al so that Mojo errors go into the debug log +use DXDebug; +use Mojolicious 7.26; use Mojo::IOLoop; -use DXDebug; use Msg; use IntMsg; use Internet; @@ -146,6 +147,8 @@ use DXSql; use IsoTime; use BPQMsg; + + use Data::Dumper; use IO::File; use Fcntl ':flock'; @@ -163,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 @@ -217,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); @@ -230,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) { @@ -259,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)); @@ -267,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 { @@ -288,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'); } @@ -457,6 +503,9 @@ sub setup_start my $desc = $repo->command_oneline(['describe', '--long'], STDERR => 0); if ($desc) { my ($v, $s, $b, $g) = $desc =~ /^([\d.]+)(?:\.(\d+))?-(\d+)-g([0-9a-f]+)/; + $s ||= ''; + dbg("Git: $desc"); + dbg("Git: V=$v S=$s B=$b g=$g"); $version = $v; $build = $b || 0; $gitversion = "$g\[r]"; @@ -487,7 +536,7 @@ sub setup_start # initialise User file system dbg("loading user file system ..."); - DXUser::init(1); + DXUser::init(4); # version 4 == json format # look for the sysop and the alias user and complain if they aren't there { @@ -634,6 +683,8 @@ our $io_disconnected; sub idle_loop { BPQMsg::process(); +# DXCommandmode::process(); # process ongoing command mode stuff +# DXProt::process(); # process ongoing ak1a pcxx stuff if (defined &Local::process) { eval { @@ -678,10 +729,10 @@ sub per_sec $systime_daystart = $days * 86400; } IsoTime::update($systime); - DXCron::process(); # do cron jobs DXCommandmode::process(); # process ongoing command mode stuff - DXXml::process(); DXProt::process(); # process ongoing ak1a pcxx stuff + DXCron::process(); # do cron jobs + DXXml::process(); DXConnect::process(); DXMsg::process(); DXDb::process(); @@ -689,7 +740,6 @@ sub per_sec DXDupe::process(); DXCron::process(); # do cron jobs IsoTime::update($systime); - DXProt::process(); # process ongoing ak1a pcxx stuff DXConnect::process(); DXUser::process(); AGWMsg::process();