diff options
Diffstat (limited to 'lib/MasterServer/Core')
| -rwxr-xr-x | lib/MasterServer/Core/Core.pm | 99 | ||||
| -rwxr-xr-x | lib/MasterServer/Core/Logging.pm | 5 | ||||
| -rwxr-xr-x | lib/MasterServer/Core/Schedulers.pm | 125 | ||||
| -rwxr-xr-x | lib/MasterServer/Core/Secure.pm | 128 | ||||
| -rwxr-xr-x | lib/MasterServer/Core/Stats.pm | 39 | ||||
| -rwxr-xr-x | lib/MasterServer/Core/Util.pm | 89 | ||||
| -rwxr-xr-x | lib/MasterServer/Core/Version.pm | 11 |
7 files changed, 368 insertions, 128 deletions
diff --git a/lib/MasterServer/Core/Core.pm b/lib/MasterServer/Core/Core.pm index a20172c..3f99a3a 100755 --- a/lib/MasterServer/Core/Core.pm +++ b/lib/MasterServer/Core/Core.pm @@ -7,7 +7,7 @@ use AnyEvent; use Exporter 'import'; use DBI; -our @EXPORT = qw | halt main |; +our @EXPORT = qw | halt select_database_type main |; ################################################################################ ## Handle shutting down the program in case a fatal error occurs. @@ -34,6 +34,19 @@ sub halt { } ################################################################################ +## Set up the database connection +################################################################################ +sub select_database_type { + my $self = shift; + + # Connect to database + $self->{dbh} = $self->database_login(); + + # and test whether we succeeded. + $self->halt() unless (defined $self->{dbh}); +} + +################################################################################ ## Initialize all processes and start various functions ################################################################################ sub main { @@ -42,67 +55,69 @@ sub main { # condition var prevents or allows the program from ending $self->{must_halt} = AnyEvent->condvar; - # determine version info + # force version info $self->version(); + # print startup + print "Running...\n"; + # keep several objects alive outside their original scope $self->{scope} = (); # startup procedure information + $self->log("info", ""); + $self->log("info", ""); $self->log("info", "333networks Master Server Application."); - $self->log("info", "Build: $self->{build_type}"); - $self->log("info", "Version: $self->{build_version}"); - $self->log("info", "Written by $self->{build_author}"); - $self->log("info", "Logs are written to $self->{log_dir}"); + $self->log("info", "Hostname: $self->{masterserver_hostname}"); + $self->log("info", "Build: $self->{build_type}"); + $self->log("info", "Version: $self->{build_version}"); + $self->log("info", "Author: $self->{build_author}"); + $self->log("info", "Logs: $self->{log_dir}"); # determine the type of database and load the appropriate module - { - # read from login - my @db_type = split(':', $self->{dblogin}->[0]); - - # format supported? - if ( "Pg SQLite mysql" =~ m/$db_type[1]/i) { - - # inform us what DB we try to load - $self->log("load","Loading $db_type[1] database module."); - - # load dbd and tables/queries for this db type - MasterServer::load_recursive("MasterServer::Database::$db_type[1]"); - - # Connect to database - $self->{dbh} = $self->database_login(); - - # and test whether we succeeded. - $self->halt() unless (defined $self->{dbh}); - } - else { - # raise error and halt - $self->log("fatal", "The masterserver could not determine the chosen database type."); - $self->halt(); - } - } + $self->select_database_type(); + + # + # Prepare necessary tasks for running the masterserver + # # (re)load the list with ciphers from the config file, into the database $self->load_ciphers(); + # set first run flag to avoid ignoring servers after downtime + $self->{firstrun} = undef; + $self->{firstruntime} = time; + + ### + # + # activate all schedulers and functions + # + ### + + # + # Timers + # + # tasks that are executed once or twice per hour + $self->{scope}->{long_periodic_tasks} = $self->long_periodic_tasks(); + # + # tasks that are executed every few minutes + $self->{scope}->{short_periodic_tasks} = $self->short_periodic_tasks(); + # + # tasks that are executed every few milliseconds + $self->{scope}->{udp_ticker} = $self->udp_ticker(); + + # + # Network listeners + # # start the listening service (listen for UDP beacons) $self->{scope}->{beacon_catcher} = $self->beacon_catcher(); - - # start the beacon checker service (query entries from the pending list) - $self->{scope}->{beacon_checker} = $self->beacon_checker() if ($self->{beacon_checker_enabled}); - + # # provide server lists to clients with the browser host server $self->{scope}->{browser_host} = $self->browser_host(); - # query other masterserver applets to get more server addresses - $self->{scope}->{ucc_applet_query} = $self->ucc_applet_query_scheduler() if ($self->{master_applet_enabled}); - - # synchronize with 333networks-based masterservers - $self->{scope}->{syncer_scheduler} = $self->syncer_scheduler() if ($self->{sync_enabled}); - # all modules loaded. Running... $self->log("info", "All modules loaded. Masterserver is now running."); - + # prevent main program from ending prematurely $self->{must_halt}->recv; } diff --git a/lib/MasterServer/Core/Logging.pm b/lib/MasterServer/Core/Logging.pm index 800fa43..5aaf683 100755 --- a/lib/MasterServer/Core/Logging.pm +++ b/lib/MasterServer/Core/Logging.pm @@ -15,6 +15,9 @@ our @EXPORT = qw| log |; sub log { my ($self, $type, $msg) = @_; + # flush + $| = 1; + # parse time of log entry and prep for rotating log my $time = strftime('%Y-%m-%d %H:%M:%S',localtime); my $yearly = strftime('-%Y',localtime); @@ -26,7 +29,7 @@ sub log { return if (defined $type && $self->{suppress} =~ m/$type/i); # determine filename - my $f = "MasterServer-Perl"; + my $f = "MasterServer"; # rotate log filename according to config $f .= $daily if ($self->{log_rotate} =~ /^daily$/i ); diff --git a/lib/MasterServer/Core/Schedulers.pm b/lib/MasterServer/Core/Schedulers.pm new file mode 100755 index 0000000..97e45a5 --- /dev/null +++ b/lib/MasterServer/Core/Schedulers.pm @@ -0,0 +1,125 @@ + +package MasterServer::Core::Schedulers; + +use strict; +use warnings; +use AnyEvent; +use POSIX qw/strftime/; +use Exporter 'import'; +use DBI; + +our @EXPORT = qw | + long_periodic_tasks + short_periodic_tasks +|; + +################################################################################ +## tasks that are executed only once or twice per hour +################################################################################ +sub long_periodic_tasks { + my $self = shift; + my $num = 0; + + return AnyEvent->timer ( + after => 300, # 5 minutes grace time + interval => 1800, # execute every half hour + cb => sub { + + ## update Killing Floor stats + $self->read_kfstats(); + + # time spacer + my $t = 0; + + # clean out handles from the previous round (executed or not) + $self->{scope}->{sync} = (); + + ## Query Epic Games'-based UCC applets periodically to get an additional + ## list of online UT, Unreal (or other) game servers. + if ($self->{master_applet_enabled}) { + for my $ms (@{$self->{master_applet}}) { + + # add 3 second delay to spread network/server load + $self->{scope}->{sync}->{$t} = AnyEvent->timer( + after => 3*$t++, + cb => sub{$self->query_applet($ms)} + ); + } + } + + # do NOT reset $t, keep padding time -- you should not have more than 600 + # entries in applets/syncer in total. + + ## Request the masterlist for selected or all games from other + ## 333networks-based masterservers that uplinked to us and otherwise made + ## our list (config, manual entry, etc) + if ($self->{sync_enabled}) { + foreach my $ms (values %{$self->masterserver_list()}) { + + # add 3 second delay to spread network/server load + $self->{scope}->{sync}->{$t} = AnyEvent->timer( + after => 3*$t++, + cb => sub{$self->sync_with_master($ms) if ($ms->{tcp} > 0)} + ); + } + } + + # + # Also very long-running tasks, like once per day: + # + if ($num++ >= 47) { + # reset counter + $num = 0; + + # + # do database dump + # + my $time = strftime('%Y-%m-%d-%H-%M',localtime); + + # read db type from db login + my @db_type = split(':', $self->{dblogin}->[0]); + $db_type[2] =~ s/dbname=//; + + if ($db_type[1] eq "Pg") { + # use pg_dump to dump Postgresql databases + system("pg_dump $db_type[2] -U $self->{dblogin}->[1] > $self->{root}/data/dumps/$db_type[1]-$time.db"); + $self->log("dump", "Dumping database to /data/dumps/$db_type[1]-$time.db"); + } + } + + }, + ); +} + +################################################################################ +## tasks that are executed every few minutes +################################################################################ +sub short_periodic_tasks { + my $self = shift; + + return AnyEvent->timer ( + after => 10, + interval => 120, + cb => sub { + + ## update stats on direct beacons and total number of servers + $self->update_stats(); + + ## determine whether servers are still uplinking to us. If not, toggle. + $self->write_direct_beacons() if (defined $self->{firstrun}); + + ## delete old servers from the "pending" list (except for the first run) + $self->delete_old_pending() if (defined $self->{firstrun}); + + ## uplink to other 333networks masterservers with heartbeats, + ## that way we can index other masterservers too + $self->send_heartbeats(); + + # + # more short tasks? + # + }, + ); +} + +1; diff --git a/lib/MasterServer/Core/Secure.pm b/lib/MasterServer/Core/Secure.pm index 07e48b8..51d1832 100755 --- a/lib/MasterServer/Core/Secure.pm +++ b/lib/MasterServer/Core/Secure.pm @@ -8,11 +8,8 @@ use Exporter 'import'; our @EXPORT = qw| load_ciphers secure_string - validated_beacon - validated_request - validate_string - charshift - get_validate_string |; + validate_string + compare_challenge |; ################################################################################ ## Supported Games list ciphers @@ -21,7 +18,6 @@ our @EXPORT = qw| load_ciphers ## data/supportedgames.pl file. ## ## Only config files after 5 October 2015 work with this script. -## IMPORTANT! Afterwards, the $self->{game} hash will be cleared! ################################################################################ sub load_ciphers { my $self = shift; @@ -47,14 +43,13 @@ sub load_ciphers { $self->{dbh}->rollback; $self->halt(); } - } # commit $self->{dbh}->commit; $self->log("info", "Cipher database successfully updated!"); - # unload the game variables from memory + # unload the game variables from masterserver memory $self->{game} = undef; } @@ -78,82 +73,54 @@ sub secure_string { # authenticate the \validate\ response for the \secure\ challenge. # returns 1 on valid response, 0 on invalid ################################################################################ -sub validated_beacon { - my ($self, $gamename, $secure, $enctype, $validate) = @_; +sub compare_challenge { + my ($self, %o) = @_; # debugging enabled? Then don't care about validation return 1 if ($self->{debug_validate}); - # enctype given? - $enctype = 0 unless $enctype; + # secure string too long? (because vulnerable in UE) + return 0 if (length $o{secure} > 16); - if ($self->{ignore_beacon_key} =~ m/$gamename/i){ - $self->log("secure", "ignored beacon validation for $gamename"); - return 1; - } + # additional conditions to skip checking provided? + $o{ignore} = "" unless $o{ignore}; - # compare received response with expected response - return ($self->validate_string($gamename, $secure, $enctype) eq $validate) || 0; -} + # ignore this game if asked to do so + if ($o{ignore} =~ m/$o{gamename}/i){ + $self->log("secure", "ignored beacon validation for $o{gamename}"); + return 1; + } -################################################################################ -# authenticate the \validate\ response for the \secure\ challenge. -# returns 1 on valid response, 0 on invalid -################################################################################ -sub validated_request { - my ($self, $gamename, $secure, $enctype, $validate) = @_; - - # debugging enabled? Then don't care about validation - return 1 if ($self->{debug_validate}); + # enctype given? + $o{enctype} = 0 unless $o{enctype}; - # enctype given? - $enctype = 0 unless $enctype; + # get cipher corresponding with the gamename + my $cip = $self->get_game_props($o{gamename})->{cipher}; - # ignore games and beacons that are listed - if ($self->{ignore_browser_key} =~ m/$gamename/i){ - $self->log("secure", "ignored browser validation for $gamename"); - return 1; - } - - # compare received response with expected response - return ($self->validate_string($gamename, $secure, $enctype) eq $validate) || 0; + # calculate validate string + my $val = get_validate_string($cip, $o{secure}, $o{enctype}); + + # return whether or not they match + return ($val eq $o{validate}); } ################################################################################ -# process the validate string as a response to the secure challenge -# returns: validate string (usually 8 characters long) +# obtain the secure/validate challenge string ################################################################################ sub validate_string { - my ($self, $game, $sec, $enc) = @_; + my ($self, %o) = @_; - # get cipher from gamename - my $cip = $self->get_cipher($game); + # secure string too long? (because vulnerable in UE) + return 0 if (length $o{secure} > 16); - # don't accept challenge longer than 16 characters (because vulnerable in UE) - if (length $sec > 16) { - return "invalid!"} + # get cipher from gamename + my $cip = $self->get_game_props(lc $o{gamename})->{cipher}; - # check for valid encryption choices - my $enc_val = (defined $enc && 0 <= $enc && $enc <= 2) ? $enc : 0; + # enctype given? + $o{enctype} = 0 unless $o{enctype}; # calculate and return validate string - return $self->get_validate_string($cip, $sec, $enc_val); -} - -################################################################################ -# rotate characters as part of the secure/validate algorithm. -# arg and return: int (representing a character) -################################################################################ -sub charshift { - my ($self, $reg) = @_; - return($reg + 65) if ($reg < 26); - return($reg + 71) if ($reg < 52); - return($reg - 4) if ($reg < 62); - return(43) if ($reg == 62); - return(47) if ($reg == 63); - - # if all else fails - return(0); + return get_validate_string($cip, $o{secure}, $o{enctype}); } ################################################################################ @@ -166,14 +133,15 @@ sub charshift { # was released under the GNU General Public License, for more information, see # the original software at http://aluigi.altervista.org/papers.htm#gsmsalg # -# conversion and modification of the algorithm by Darkelarious, June 2014. +# conversion and modification of the algorithm by Darkelarious, June 2014 with +# explicit, written permission of Luigi Auriemma. # # args: game cipher, 6-char challenge string, encryption type # returns: validate string (usually 8 characters long) # !! requires cipher hash to be configured in config! (imported or otherwise) ################################################################################ sub get_validate_string { - my ($self, $cipher_string, $secure_string, $enctype) = @_; + my ($cipher_string, $secure_string, $enctype) = @_; # use pre-built rotations for enctype # -- see GSMSALG 0.3.3 reference for copyright and more information @@ -245,7 +213,7 @@ sub get_validate_string { $tmp[$i] = $sec[$i] ^ $enc[($l + $m) & 0xff]; } -# part of the enctype 1-2 process + # part of the enctype 1-2 process for($sec_len = $i; $sec_len % 3; $sec_len++) { $tmp[$sec_len] = 0; } @@ -270,10 +238,10 @@ sub get_validate_string { $m = $m % 256; $n = $tmp[$i + 2]; $n = $n % 256; - $val[$p++] = $self->charshift($l >> 2); - $val[$p++] = $self->charshift((($l & 3 ) << 4) | ($m >> 4)); - $val[$p++] = $self->charshift((($m & 15) << 2) | ($n >> 6)); - $val[$p++] = $self->charshift($n & 63); + $val[$p++] = charshift($l >> 2); + $val[$p++] = charshift((($l & 3 ) << 4) | ($m >> 4)); + $val[$p++] = charshift((($m & 15) << 2) | ($n >> 6)); + $val[$p++] = charshift($n & 63); } # return to ascii characters @@ -283,4 +251,20 @@ sub get_validate_string { return $str; } +################################################################################ +# rotate characters as part of the secure/validate algorithm. +# arg and return: int (representing a character) +################################################################################ +sub charshift { + my $reg = shift; + return($reg + 65) if ($reg < 26); + return($reg + 71) if ($reg < 52); + return($reg - 4) if ($reg < 62); + return(43) if ($reg == 62); + return(47) if ($reg == 63); + + # if all else fails + return(0); +} + 1; diff --git a/lib/MasterServer/Core/Stats.pm b/lib/MasterServer/Core/Stats.pm new file mode 100755 index 0000000..25044e8 --- /dev/null +++ b/lib/MasterServer/Core/Stats.pm @@ -0,0 +1,39 @@ + +package MasterServer::Core::Stats; + +use strict; +use warnings; +use AnyEvent::IO; +use Exporter 'import'; + +our @EXPORT = qw| update_stats |; + +################################################################################ +# Update statistics on servers and update the games table with those values +################################################################################ +sub update_stats { + my $self = shift; + + # get all gamenames where there is one or more servers online and update the + # stats per gamename. + my $games = $self->get_gamelist_stats(); + + # iterate through available stats + for my $e (@{$games}) { + + # extract gamename, number of direct uplinks and total servers + my %opt = (); + $opt{gamename} = $e->[0]; + $opt{num_uplink} = $e->[1]; + $opt{num_total} = $e->[2]; + + # write to DB + $self->write_stat(%opt); + } + + #done + $self->log("stat", "Updated all game statistics."); + +} + +1; diff --git a/lib/MasterServer/Core/Util.pm b/lib/MasterServer/Core/Util.pm index af3a551..4f64fe1 100755 --- a/lib/MasterServer/Core/Util.pm +++ b/lib/MasterServer/Core/Util.pm @@ -4,10 +4,11 @@ package MasterServer::Core::Util; use strict; use warnings; use IP::Country::Fast; +use Socket; use POSIX qw/strftime/; use Exporter 'import'; -our @EXPORT = qw| ip2country countryflag valid_address |; +our @EXPORT = qw| ip2country host2ip valid_address db_all sqlprint |; ################################################################################ ## return the abbreviated country name based on IP @@ -19,23 +20,24 @@ sub ip2country { } ################################################################################ -## return the flag of a country +## return IP of a hostname ################################################################################ -sub countryflag { - my ($self, $country) = @_; - # placeholder function to return the flag of a country +sub host2ip { + my ($self, $name) = @_; + return inet_ntoa(inet_aton($name)) if $name; } + ################################################################################ ## Verify whether a given domain name or IP address and port are valid. -## returns 1/0 if valid/invalid ip + port +## returns 1/0 if valid/invalid ip + port. IPv4 ONLY! ################################################################################ sub valid_address { my ($self, $a, $p) = @_; - + # check if ip and port are in valid range - my $val_addr = ($a =~ '\b(?:(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.){3}(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\b'); - my $val_port = (0 < $p && $p <= 65535); + my $val_addr = ($a =~ '\b(?:(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.){3}(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\b') if $a; + my $val_port = (0 < $p && $p <= 65535) if $p; # exclude addresses where we don't want people sniffing for (qw|192.168.(.\d*).(.\d*) 127.0.(.\d*).(.\d*) 10.0.(.\d*).(.\d*)|){$val_addr = 0 if ($a =~ m/$_/)} @@ -44,4 +46,73 @@ sub valid_address { return ($val_addr && $val_port); } +################################################################################ +# Adaptation of TUWF's dbAll sql function +################################################################################ +sub db_all { + my $self = shift; + my $sqlq = shift; + my $s = $self->{dbh}; + + $sqlq =~ s/\r?\n/ /g; + $sqlq =~ s/ +/ /g; + my(@q) = @_ ? sqlprint($sqlq, @_) : ($sqlq); + + my($q, $r); + my $ret = eval { + $q = $s->prepare($q[0]); + $q->execute($#q ? @q[1..$#q] : ()); + $r = $q->fetchall_arrayref({}); + $q->finish(); + 1; + }; + + $r = [] if (!$r || ref($r) ne 'ARRAY'); + return $r; +} + +################################################################################ +# sqlprint (TUWF): +# ? normal placeholder +# !l list of placeholders, expects arrayref +# !H list of SET-items, expects hashref or arrayref: format => (bind_value || \@bind_values) +# !W same as !H, but for WHERE clauses (AND'ed together) +# !s the classic sprintf %s, use with care +# This isn't sprintf, so all other things won't work, +# Only the ? placeholder is supported, so no dollar sign numbers or named placeholders +################################################################################ +sub sqlprint { # query, bind values. Returns new query + bind values + + my @a; + my $q=''; + for my $p (split /(\?|![lHWs])/, shift) { + next if !defined $p; + if($p eq '?') { + push @a, shift; + $q .= $p; + } elsif($p eq '!s') { + $q .= shift; + } elsif($p eq '!l') { + my $l = shift; + $q .= join ', ', map '?', 0..$#$l; + push @a, @$l; + } elsif($p eq '!H' || $p eq '!W') { + my $h=shift; + my @h=ref $h eq 'HASH' ? %$h : @$h; + my @r; + while(my($k,$v) = (shift(@h), shift(@h))) { + last if !defined $k; + my($n,@l) = sqlprint($k, ref $v eq 'ARRAY' ? @$v : $v); + push @r, $n; + push @a, @l; + } + $q .= ($p eq '!W' ? 'WHERE ' : 'SET ').join $p eq '!W' ? ' AND ' : ', ', @r + if @r; + } else { + $q .= $p; + } + } + return($q, @a); +} + 1; diff --git a/lib/MasterServer/Core/Version.pm b/lib/MasterServer/Core/Version.pm index ccf9491..bf12f21 100755 --- a/lib/MasterServer/Core/Version.pm +++ b/lib/MasterServer/Core/Version.pm @@ -23,17 +23,20 @@ sub version { # these fields does not count as a significant alteration. # # -- addition to the LICENCE, you are only allowed to modify these lines - # if you send Darkelarious a postcard or email with your compliments. + # if you send Darkelarious a postcard or (e)mail with your compliments. # # master type - $self->{build_type} = "333networks Masterserver-Perl (Pg-SQLite-MySQL) 20151108209"; + $self->{build_type} = "333networks Masterserver-Perl pre-release"; # version - $self->{build_version} = "2.0.9"; + $self->{build_version} = "2.2.4"; + + # short version for uplinks + $self->{short_version} = "MS-perl $self->{build_version}"; # date yyyy-mm-dd - $self->{build_date} = "2015-11-08"; + $self->{build_date} = "2016-11-17"; #author, email $self->{build_author} = "Darkelarious, darkelarious\@333networks.com"; |