diff options
Diffstat (limited to 'lib/MasterWebInterface')
20 files changed, 2707 insertions, 0 deletions
diff --git a/lib/MasterWebInterface/Database/Pg/Games.pm b/lib/MasterWebInterface/Database/Pg/Games.pm new file mode 100755 index 0000000..38650b2 --- /dev/null +++ b/lib/MasterWebInterface/Database/Pg/Games.pm @@ -0,0 +1,55 @@ +package MasterWebInterface::Database::Pg::Games; +use strict; +use warnings; +use Exporter 'import'; +our @EXPORT = qw| dbGameListGet dbGetGameDesc |; + +################################################################################ +## get list of game details +## opt: filter first letter +################################################################################ +sub dbGameListGet { + my $s = shift; + my %o = (page => 1, results => 50, sort => '', @_); + + my %where = ( + $o{firstchar} + ? ('upper(SUBSTRING(description from 1 for 1)) = ?' => $o{firstchar} ) : (), + !$o{firstchar} && defined $o{firstchar} + ? ('ASCII(description) < 97 OR ASCII(description) > 122' => 1 ) : (), + $o{search} + ? ('description ILIKE ?' => "%$o{search}%") : (), + ); + + my @select = ( qw| description gamename num_uplink num_total |); + my $order = sprintf { + description => 'description %s', + gamename => 'gamename %s', + num_uplink => 'num_uplink %s', + num_total => 'num_total %s', + }->{ $o{sort}||'num_total' }, $o{reverse} ? 'DESC' : 'ASC'; + + my($r, $np) = $s->dbPage(\%o, q| + SELECT !s FROM games + !W + ORDER BY !s|, + join(', ', @select), \%where, $order + ); + + my $p = $s->dbAll( q| + SELECT COUNT(*) AS num + FROM games + !W|, \%where, + )->[0]{num}; + return wantarray ? ($r, $np, $p) : $r; +} + +################################################################################ +## get description for a game by gamename +################################################################################ +sub dbGetGameDesc { +my ($self, $gn) = @_; + return $self->dbAll("SELECT description FROM games WHERE gamename = ?", $gn)->[0]{description}; +} + +1; diff --git a/lib/MasterWebInterface/Database/Pg/ServerInfo.pm b/lib/MasterWebInterface/Database/Pg/ServerInfo.pm new file mode 100755 index 0000000..8c6ba6f --- /dev/null +++ b/lib/MasterWebInterface/Database/Pg/ServerInfo.pm @@ -0,0 +1,178 @@ +package MasterWebInterface::Database::Pg::ServerInfo; +use strict; +use warnings; +use Exporter 'import'; +our @EXPORT = qw| dbGetServerListInfo dbGetServerDetails dbGetPlayerInfo |; + +################################################################################ +## get server details for one or multiple servers +################################################################################ +sub dbGetServerListInfo { + my $s = shift; + my %o = ( sort => '', @_ ); + + my %where = ( + $o{id} ? ( 'id = ?' => $o{id}) : (), + $o{ip} ? ( 'ip = ?' => $o{ip}) : (), + $o{port} ? ( 'port = ?' => $o{port}) : (), + $o{gamename} ? ( 'gamename = ?' => lc $o{gamename}) : (), + $o{gamever} ? ( 'gamever = ?' => $o{gamever}) : (), + $o{hostname} ? ( 'hostname = ?' => $o{hostname}) : (), + $o{hostport} ? ( 'hostport = ?' => $o{hostport}) : (), + $o{country} ? ( 'country = ?' => $o{country}) : (), + $o{b333ms} ? ( 'b333ms = ?' => $o{b333ms}) : (), + $o{blacklisted} ? ('blacklisted = ?' => $o{blacklisted}) : (), + $o{added} ? ( 'added < to_timestamp(?)' => (time-$o{added})) : (), + $o{beacon} ? ( 'beacon > to_timestamp(?)' => (time-$o{beacon})) : (), + $o{updated} ? ('updated > to_timestamp(?)' => (time-$o{updated})) : (), + $o{before} ? ('updated < to_timestamp(?)' => (time-$o{before})) : (), + ); + + my @select = ( qw| id ip port serverlist.gamename gamever hostname hostport country b333ms blacklisted description |, + "extract('epoch' from added) as e_added", + "extract('epoch' from updated) as e_updated", + "extract('epoch' from CURRENT_TIMESTAMP - added) as addiff", + "extract('epoch' from CURRENT_TIMESTAMP - updated) as updiff", + ); + + my $order = sprintf { + id => 'id %s', + ip => 'ip %s', + port => 'port %s', + gamename => 'serverlist.gamename %s', + gamever => 'gamever %s', + hostname => 'hostname %s', + hostport => 'hostport %s', + country => 'country %s', + b333ms => 'b333ms %s', + blacklisted => 'blacklisted %s', + added => 'added %s', + beacon => 'beacon %s', + updated => 'updated %s', + }->{ $o{sort}||'id' }, $o{reverse} ? 'DESC' : 'ASC'; + + return $s->dbAll( q|SELECT !s FROM serverlist + JOIN games ON serverlist.gamename = games.gamename + !W ORDER BY !s|.($o{limit} ? " LIMIT ?" : ""), + join(', ', @select), \%where, $order, ($o{limit} ? $o{limit} : ()), + ); +} + +################################################################################ +## get server details for one or multiple UT servers +################################################################################ +sub dbGetServerDetails { + my $s = shift; + my %o = (sort => '', @_ ); + + my %where = ( + $o{id} ? ('server_id = ?' => $o{id}) : (), + $o{minnetver} ? ('minnetver = ?' => $o{minnetver}) : (), + $o{location} ? ('location = ?' => $o{location}) : (), + $o{listenserver} ? ('listenserver = ?' => $o{listenserver}) : (), + $o{adminname} ? ('adminname = ?' => $o{adminname}) : (), + $o{adminemail} ? ('adminemail = ?' => $o{adminemail}) : (), + $o{password} ? ('password = ?' => $o{password}) : (), + $o{gametype} ? ('gametype = ?' => $o{gametype}) : (), + $o{gamestyle} ? ('gamestyle = ?' => $o{gamestyle}) : (), + $o{changelevels} ? ('changelevels = ?' => $o{changelevels}) : (), + $o{maptitle} ? ('maptitle = ?' => $o{maptitle}) : (), + $o{mapname} ? ('mapname = ?' => $o{mapname}) : (), + $o{numplayers} ? ('numplayers = ?' => $o{numplayers}) : (), + $o{maxplayers} ? ('maxplayers = ?' => $o{maxplayers}) : (), + $o{minplayers} ? ('minplayers = ?' => $o{minplayers}) : (), + $o{botskill} ? ('botskill = ?' => $o{botskill}) : (), + $o{balanceteams} ? ('balanceteams = ?' => $o{balanceteams}) : (), + $o{playersbalanceteams} ? ('playersbalanceteams = ?' => $o{playersbalanceteams}) : (), + $o{friendlyfire} ? ('friendlyfire = ?' => $o{friendlyfire}) : (), + $o{maxteams} ? ('maxteams = ?' => $o{maxteams}) : (), + $o{timelimit} ? ('timelimit = ?' => $o{timelimit}) : (), + $o{goalteamscore} ? ('goalteamscore = ?' => $o{goalteamscore}) : (), + $o{fraglimit} ? ('fraglimit = ?' => $o{fraglimit}) : (), + $o{mutators} ? ('mutators ILIKE ?' => "%$o{mutators}%") : (), + $o{updated} ? ('updated > to_timestamp(?)'=> (time-$o{updated})) : (), + ); + + my @select = ( qw| server_id minnetver location listenserver adminname adminemail + password gametype gamestyle changelevels maptitle mapname numplayers maxplayers + minplayers botskill balanceteams playersbalanceteams friendlyfire maxteams + timelimit goalteamscore fraglimit mutators |, + "extract('epoch' from updated) as e_updated2", + "extract('epoch' from CURRENT_TIMESTAMP - updated) as updiff2", + ); + + my $order = sprintf { + server_id => 'server_id %s', + minnetver => 'minnetver %s', + location => 'location %s', + listenserver => 'listenserver %s', + adminname => 'adminname %s', + adminemail => 'adminemail %s', + password => 'password %s', + gametype => 'gametype %s', + gamestyle => 'gamestyle %s', + changelevels => 'changelevels %s', + maptitle => 'maptitle %s', + mapname => 'mapname %s', + numplayers => 'numplayers %s', + maxplayers => 'maxplayers %s', + minplayers => 'minplayers %s', + botskill => 'botskill %s', + balanceteams => 'balanceteams %s', + playersbalanceteams => 'playersbalanceteams %s', + friendlyfire => 'friendlyfire %s', + maxteams => 'maxteams %s', + timelimit => 'timelimit %s', + goalteamscore => 'goalteamscore %s', + fraglimit => 'fraglimit %s', + mutators => 'mutators %s', + updated => 'updated %s', + }->{ $o{sort}||'server_id' }, $o{reverse} ? 'DESC' : 'ASC'; + + return $s->dbAll( q| + SELECT !s FROM extended_info + !W + ORDER BY !s| + .($o{limit} ? " LIMIT ?" : ""), + join(', ', @select), \%where, $order, ($o{limit} ? $o{limit} : ()), + ); +} + +################################################################################ +## get player details for one particular server +################################################################################ +sub dbGetPlayerInfo { + my $s = shift; + my %o = (sort => '', @_ ); + + my %where = ( + $o{server_id} ? ('server_id = ?' => $o{server_id}): (), + $o{player} ? ( 'player = ?' => $o{player}) : (), + $o{team} ? ( 'team = ?' => $o{team}) : (), + $o{frags} ? ( 'frags = ?' => $o{frags}) : (), + $o{mesh} ? ( 'mesh = ?' => $o{mesh}) : (), + $o{skin} ? ( 'skin = ?' => $o{skin}) : (), + $o{face} ? ( 'face = ?' => $o{face}) : (), + $o{ping} ? ( 'ping = ?' => $o{ping}) : (), + $o{ngsecret} ? ( 'ngsecret = ?' => $o{ngsecret}) : (), + ); + + my @select = ( qw| server_id player team frags mesh skin face ping ngsecret | ); + my $order = sprintf { + server_id => 'server_id %s', + player => 'player %s', + team => 'team %s', + frags => 'frags %s', + mesh => 'mesh %s', + skin => 'skin %s', + face => 'face %s', + ping => 'ping %s', + ngsecret => 'ngsecret %s', + }->{ $o{sort}||'team' }, $o{reverse} ? 'DESC' : 'ASC'; + + return $s->dbAll( q|SELECT !s FROM player_info !W ORDER BY !s|.($o{limit} ? " LIMIT ?" : ""), + join(', ', @select), \%where, $order, ($o{limit} ? $o{limit} : ()), + ); +} + +1; diff --git a/lib/MasterWebInterface/Database/Pg/Servers.pm b/lib/MasterWebInterface/Database/Pg/Servers.pm new file mode 100755 index 0000000..0ed47b1 --- /dev/null +++ b/lib/MasterWebInterface/Database/Pg/Servers.pm @@ -0,0 +1,91 @@ +package MasterWebInterface::Database::Pg::Servers; +use strict; +use warnings; +use Exporter 'import'; +our @EXPORT = qw| dbAddServer dbServerListGet |; + +################################################################################ +## check if an ip, port/hostport combination is recent in the serverlist. +## if not, add the address to the pending list +################################################################################ +sub dbAddServer { + my $self = shift; + my %o = (updated => 3600, @_ ); + + my %where = ( + $o{ip} ? ( 'ip = ?' => $o{ip}) : (), + $o{port} ? ( 'port = ?' => $o{port}) : (), + $o{updated} ? ('updated > to_timestamp(?)' => (time-$o{updated})) : (), + ); + + # determine if it already exsits + my $u = $self->dbAll("SELECT id FROM serverlist !W", \%where)->[0]; + return 0 if $u; + + # else, insert in pending (duplicates may exist -- see remove_pending) + $self->dbExec("INSERT INTO pending (ip, heartbeat) VALUES (?, ?)", $o{ip}, $o{port}); + return 1; +} + +################################################################################ +## get the serverlist. default 2 hours time limit +################################################################################ +sub dbServerListGet { + my $s = shift; + my %o = ( page => 1, results => 50, sort => '', updated => '7200', @_ ); + + my %where = ( + defined $o{gamename} && $o{gamename} !~ /all/ + ? ('serverlist.gamename = ?' => $o{gamename}) : (), + $o{firstchar} + ? ('upper(SUBSTRING(hostname from 1 for 1)) = ?' => $o{firstchar} ) : (), + !$o{firstchar} && defined $o{firstchar} + ? ('ASCII(hostname) < 97 OR ASCII(hostname) > 122' => 1 ) : (), + $o{search} + ? ('hostname ILIKE ?' => "%$o{search}%") : (), + $o{updated} + ? ('serverlist.updated > to_timestamp(?)' => (time-$o{updated}) ) : (), + ('length(hostname) > ?' => 1), # don't allow empty hostnames + ('hostport > ?' => 0), # or games with empty hostport + ); + + my @select = ( qw| id ip hostport hostname serverlist.gamename country numplayers maxplayers maptitle mapname gametype added description |, + "extract('epoch' from CURRENT_TIMESTAMP - serverlist.updated) as diff", + "extract('epoch' from serverlist.updated) as updated", + "extract('epoch' from serverlist.added) as added"); + + my $order = sprintf { + id => 'id %s', + ip => 'ip %s', + hostport => 'hostport %s', + hostname => 'hostname %s', + gamename => 'serverlist.gamename %s', + country => 'country %s', + diff => 'diff %s', + added => 'serverlist.added %s', + updated => 'updated %s', + gametype => 'gametype %s', + numplayers => 'numplayers %s', + maxplayers => 'maxplayers %s', + mapname => 'mapname %s', + description => 'description %s', + }->{ $o{sort}||'hostname' }, $o{reverse} ? 'DESC' : 'ASC'; + + my($r, $np) = $s->dbPage(\%o, q| + SELECT !s FROM serverlist + JOIN games ON serverlist.gamename = games.gamename + JOIN extended_info ON serverlist.id = extended_info.server_id + !W + ORDER BY !s|, + join(', ', @select), \%where, $order + ); + + my $p = $s->dbAll( q| + SELECT COUNT(*) AS num + FROM serverlist + !W|, \%where, + )->[0]{num}; + return wantarray ? ($r, $np, $p) : $r; +} + +1; diff --git a/lib/MasterWebInterface/Database/SQLite/Games.pm b/lib/MasterWebInterface/Database/SQLite/Games.pm new file mode 100755 index 0000000..db820f6 --- /dev/null +++ b/lib/MasterWebInterface/Database/SQLite/Games.pm @@ -0,0 +1,53 @@ +package MasterWebInterface::Database::SQLite::Games; +use strict; +use warnings; +use Exporter 'import'; +our @EXPORT = qw| dbGameListGet dbGetGameDesc |; + +################################################################################ +## get list of game details +## opt: filter first letter +################################################################################ +sub dbGameListGet { + my $s = shift; + my %o = (page => 1, results => 50, sort => '', @_); + + my %where = ( + $o{firstchar} + ? ('upper(SUBSTR(description, 1, 1)) = ?' => $o{firstchar} ) : (), + $o{search} + ? ('lower(description) LIKE lower(?)' => "%$o{search}%") : (), + ); + + my @select = ( qw| description gamename num_uplink num_total |); + my $order = sprintf { + description => 'description %s', + gamename => 'gamename %s', + num_uplink => 'num_uplink %s', + num_total => 'num_total %s', + }->{ $o{sort}||'num_total' }, $o{reverse} ? 'DESC' : 'ASC'; + + my($r, $np) = $s->dbPage(\%o, q| + SELECT !s FROM games + !W + ORDER BY !s|, + join(', ', @select), \%where, $order + ); + + my $p = $s->dbAll( q| + SELECT COUNT(*) AS num + FROM games + !W|, \%where, + )->[0]{num}; + return wantarray ? ($r, $np, $p) : $r; +} + +################################################################################ +## get description for a game by gamename +################################################################################ +sub dbGetGameDesc { +my ($self, $gn) = @_; + return $self->dbAll("SELECT description FROM games WHERE gamename = ?", $gn)->[0]{description}; +} + +1; diff --git a/lib/MasterWebInterface/Database/SQLite/ServerInfo.pm b/lib/MasterWebInterface/Database/SQLite/ServerInfo.pm new file mode 100755 index 0000000..31c9d57 --- /dev/null +++ b/lib/MasterWebInterface/Database/SQLite/ServerInfo.pm @@ -0,0 +1,178 @@ +package MasterWebInterface::Database::SQLite::ServerInfo; +use strict; +use warnings; +use Exporter 'import'; +our @EXPORT = qw| dbGetServerListInfo dbGetServerDetails dbGetPlayerInfo |; + +################################################################################ +## get server details for one or multiple servers +################################################################################ +sub dbGetServerListInfo { + my $s = shift; + my %o = ( sort => '', @_ ); + + my %where = ( + $o{id} ? ( 'id = ?' => $o{id}) : (), + $o{ip} ? ( 'ip = ?' => $o{ip}) : (), + $o{port} ? ( 'port = ?' => $o{port}) : (), + $o{gamename} ? ( 'gamename = ?' => lc $o{gamename}) : (), + $o{gamever} ? ( 'gamever = ?' => $o{gamever}) : (), + $o{hostname} ? ( 'hostname = ?' => $o{hostname}) : (), + $o{hostport} ? ( 'hostport = ?' => $o{hostport}) : (), + $o{country} ? ( 'country = ?' => $o{country}) : (), + $o{b333ms} ? ( 'b333ms = ?' => $o{b333ms}) : (), + $o{blacklisted} ? ('blacklisted = ?' => $o{blacklisted}) : (), + $o{added} ? ( 'added < datetime(?, \'unixepoch\')' => (time-$o{added})) : (), + $o{beacon} ? ( 'beacon > datetime(?, \'unixepoch\')' => (time-$o{beacon})) : (), + $o{updated} ? ('updated > datetime(?, \'unixepoch\')' => (time-$o{updated})) : (), + $o{before} ? ('updated < datetime(?, \'unixepoch\')' => (time-$o{before})) : (), + ); + + my @select = ( qw| id ip port serverlist.gamename gamever hostname hostport country b333ms blacklisted description |, + "strftime('\%s', added) as e_added", + "strftime('\%s', updated) as e_updated", + "strftime('\%s', CURRENT_TIMESTAMP) - strftime('\%s', added) as addiff", + "strftime('\%s', CURRENT_TIMESTAMP) - strftime('\%s', updated) as updiff", + ); + + my $order = sprintf { + id => 'id %s', + ip => 'ip %s', + port => 'port %s', + gamename => 'serverlist.gamename %s', + gamever => 'gamever %s', + hostname => 'hostname %s', + hostport => 'hostport %s', + country => 'country %s', + b333ms => 'b333ms %s', + blacklisted => 'blacklisted %s', + added => 'added %s', + beacon => 'beacon %s', + updated => 'updated %s', + }->{ $o{sort}||'id' }, $o{reverse} ? 'DESC' : 'ASC'; + + return $s->dbAll( q|SELECT !s FROM serverlist + JOIN games ON serverlist.gamename = games.gamename + !W ORDER BY !s|.($o{limit} ? " LIMIT ?" : ""), + join(', ', @select), \%where, $order, ($o{limit} ? $o{limit} : ()), + ); +} + +################################################################################ +## get server details for one or multiple UT servers +################################################################################ +sub dbGetServerDetails { + my $s = shift; + my %o = (sort => '', @_ ); + + my %where = ( + $o{id} ? ('server_id = ?' => $o{id}) : (), + $o{minnetver} ? ('minnetver = ?' => $o{minnetver}) : (), + $o{location} ? ('location = ?' => $o{location}) : (), + $o{listenserver} ? ('listenserver = ?' => $o{listenserver}) : (), + $o{adminname} ? ('adminname = ?' => $o{adminname}) : (), + $o{adminemail} ? ('adminemail = ?' => $o{adminemail}) : (), + $o{password} ? ('password = ?' => $o{password}) : (), + $o{gametype} ? ('gametype = ?' => $o{gametype}) : (), + $o{gamestyle} ? ('gamestyle = ?' => $o{gamestyle}) : (), + $o{changelevels} ? ('changelevels = ?' => $o{changelevels}) : (), + $o{maptitle} ? ('maptitle = ?' => $o{maptitle}) : (), + $o{mapname} ? ('mapname = ?' => $o{mapname}) : (), + $o{numplayers} ? ('numplayers = ?' => $o{numplayers}) : (), + $o{maxplayers} ? ('maxplayers = ?' => $o{maxplayers}) : (), + $o{minplayers} ? ('minplayers = ?' => $o{minplayers}) : (), + $o{botskill} ? ('botskill = ?' => $o{botskill}) : (), + $o{balanceteams} ? ('balanceteams = ?' => $o{balanceteams}) : (), + $o{playersbalanceteams} ? ('playersbalanceteams = ?' => $o{playersbalanceteams}) : (), + $o{friendlyfire} ? ('friendlyfire = ?' => $o{friendlyfire}) : (), + $o{maxteams} ? ('maxteams = ?' => $o{maxteams}) : (), + $o{timelimit} ? ('timelimit = ?' => $o{timelimit}) : (), + $o{goalteamscore} ? ('goalteamscore = ?' => $o{goalteamscore}) : (), + $o{fraglimit} ? ('fraglimit = ?' => $o{fraglimit}) : (), + $o{mutators} ? ('mutators ILIKE ?' => "%$o{mutators}%") : (), + $o{updated} ? ('updated > to_timestamp(?)'=> (time-$o{updated})) : (), + ); + + my @select = ( qw| server_id minnetver location listenserver adminname adminemail + password gametype gamestyle changelevels maptitle mapname numplayers maxplayers + minplayers botskill balanceteams playersbalanceteams friendlyfire maxteams + timelimit goalteamscore fraglimit mutators |, + "strftime('\%s', updated) as e_updated2", + "strftime('\%s', CURRENT_TIMESTAMP) - strftime('\%s', updated) as updiff2", + ); + + my $order = sprintf { + server_id => 'server_id %s', + minnetver => 'minnetver %s', + location => 'location %s', + listenserver => 'listenserver %s', + adminname => 'adminname %s', + adminemail => 'adminemail %s', + password => 'password %s', + gametype => 'gametype %s', + gamestyle => 'gamestyle %s', + changelevels => 'changelevels %s', + maptitle => 'maptitle %s', + mapname => 'mapname %s', + numplayers => 'numplayers %s', + maxplayers => 'maxplayers %s', + minplayers => 'minplayers %s', + botskill => 'botskill %s', + balanceteams => 'balanceteams %s', + playersbalanceteams => 'playersbalanceteams %s', + friendlyfire => 'friendlyfire %s', + maxteams => 'maxteams %s', + timelimit => 'timelimit %s', + goalteamscore => 'goalteamscore %s', + fraglimit => 'fraglimit %s', + mutators => 'mutators %s', + updated => 'updated %s', + }->{ $o{sort}||'server_id' }, $o{reverse} ? 'DESC' : 'ASC'; + + return $s->dbAll( q| + SELECT !s FROM extended_info + !W + ORDER BY !s| + .($o{limit} ? " LIMIT ?" : ""), + join(', ', @select), \%where, $order, ($o{limit} ? $o{limit} : ()), + ); +} + +################################################################################ +## get player details for one particular server +################################################################################ +sub dbGetPlayerInfo { + my $s = shift; + my %o = (sort => '', @_ ); + + my %where = ( + $o{server_id} ? ('server_id = ?' => $o{server_id}): (), + $o{player} ? ( 'player = ?' => $o{player}) : (), + $o{team} ? ( 'team = ?' => $o{team}) : (), + $o{frags} ? ( 'frags = ?' => $o{frags}) : (), + $o{mesh} ? ( 'mesh = ?' => $o{mesh}) : (), + $o{skin} ? ( 'skin = ?' => $o{skin}) : (), + $o{face} ? ( 'face = ?' => $o{face}) : (), + $o{ping} ? ( 'ping = ?' => $o{ping}) : (), + $o{ngsecret} ? ( 'ngsecret = ?' => $o{ngsecret}) : (), + ); + + my @select = ( qw| server_id player team frags mesh skin face ping ngsecret | ); + my $order = sprintf { + server_id => 'server_id %s', + player => 'player %s', + team => 'team %s', + frags => 'frags %s', + mesh => 'mesh %s', + skin => 'skin %s', + face => 'face %s', + ping => 'ping %s', + ngsecret => 'ngsecret %s', + }->{ $o{sort}||'team' }, $o{reverse} ? 'DESC' : 'ASC'; + + return $s->dbAll( q|SELECT !s FROM player_info !W ORDER BY !s|.($o{limit} ? " LIMIT ?" : ""), + join(', ', @select), \%where, $order, ($o{limit} ? $o{limit} : ()), + ); +} + +1; diff --git a/lib/MasterWebInterface/Database/SQLite/Servers.pm b/lib/MasterWebInterface/Database/SQLite/Servers.pm new file mode 100755 index 0000000..041c4d9 --- /dev/null +++ b/lib/MasterWebInterface/Database/SQLite/Servers.pm @@ -0,0 +1,89 @@ +package MasterWebInterface::Database::SQLite::Servers; +use strict; +use warnings; +use Exporter 'import'; +our @EXPORT = qw| dbAddServer dbServerListGet |; + +################################################################################ +## check if an ip, port/hostport combination is recent in the serverlist. +## if not, add the address to the pending list +################################################################################ +sub dbAddServer { + my $self = shift; + my %o = (updated => 3600, @_ ); + + my %where = ( + $o{ip} ? ( 'ip = ?' => $o{ip}) : (), + $o{port} ? ( 'port = ?' => $o{port}) : (), + $o{updated} ? ('updated > datetime(?, \'unixepoch\')' => (time-$o{updated})) : (), + ); + + # determine if it already exsits + my $u = $self->dbAll("SELECT id FROM serverlist !W", \%where)->[0]; + return 0 if $u; + + # else, insert in pending (duplicates may exist -- see remove_pending) + $self->dbExec("INSERT INTO pending (ip, heartbeat) VALUES (?, ?)", $o{ip}, $o{port}); + return 1; +} + +################################################################################ +## get the serverlist. default 2 hours time limit +################################################################################ +sub dbServerListGet { + my $s = shift; + my %o = ( page => 1, results => 50, sort => '', updated => '7200', @_ ); + + my %where = ( + defined $o{gamename} && $o{gamename} !~ /all/ + ? ('serverlist.gamename = ?' => $o{gamename}) : (), + $o{firstchar} + ? ('upper(SUBSTR(hostname, 1, 1)) = ?' => $o{firstchar} ) : (), + $o{search} + ? ('lower(hostname) LIKE lower(?)' => "%$o{search}%") : (), + $o{updated} + ? ('serverlist.updated > datetime(?, \'unixepoch\')' => (time-$o{updated})) : (), +# ('length(hostname) > ?' => 1), # don't show empty hostnames + ('hostport > ?' => 0), # or games with empty hostport + ); + + my @select = ( qw| id ip hostport hostname serverlist.gamename country numplayers maxplayers maptitle mapname gametype added description |, + "strftime('\%s', CURRENT_TIMESTAMP) - strftime('\%s', serverlist.updated) as diff", + "strftime('\%s', serverlist.updated) as updated", + "strftime('\%s', serverlist.added) as added"); + + my $order = sprintf { + id => 'id %s', + ip => 'ip %s', + hostport => 'hostport %s', + hostname => 'hostname %s', + gamename => 'serverlist.gamename %s', + country => 'country %s', + diff => 'diff %s', + added => 'serverlist.added %s', + updated => 'updated %s', + gametype => 'gametype %s', + numplayers => 'numplayers %s', + maxplayers => 'maxplayers %s', + mapname => 'mapname %s', + description => 'description %s', + }->{ $o{sort}||'hostname' }, $o{reverse} ? 'DESC' : 'ASC'; + + my($r, $np) = $s->dbPage(\%o, q| + SELECT !s FROM serverlist + JOIN games ON serverlist.gamename = games.gamename + JOIN extended_info ON serverlist.id = extended_info.server_id + !W + ORDER BY !s|, + join(', ', @select), \%where, $order + ); + + my $p = $s->dbAll( q| + SELECT COUNT(*) AS num + FROM serverlist + !W|, \%where, + )->[0]{num}; + return wantarray ? ($r, $np, $p) : $r; +} + +1; diff --git a/lib/MasterWebInterface/Handler/Extra/ExtraModules.txt b/lib/MasterWebInterface/Handler/Extra/ExtraModules.txt new file mode 100644 index 0000000..7f2de62 --- /dev/null +++ b/lib/MasterWebInterface/Handler/Extra/ExtraModules.txt @@ -0,0 +1,6 @@ +You can opt to add extra modules in this folder. See http://git.333networks.com/ for more. + +Currently available modules: + Extra/KFstats.pm - Killing Floor statistics for the UT2004 mod + Extra/JSON.pm - JSON API to allow access to the Json interface (included) + UpdateServer.pm - UpdateServer compatibility for a variety of games diff --git a/lib/MasterWebInterface/Handler/Extra/JSON.pm b/lib/MasterWebInterface/Handler/Extra/JSON.pm new file mode 100755 index 0000000..9d6c56f --- /dev/null +++ b/lib/MasterWebInterface/Handler/Extra/JSON.pm @@ -0,0 +1,404 @@ +package MasterWebInterface::Handler::Extra::JSON; +use strict; +use TUWF ':html'; +use Exporter 'import'; +use JSON; + +TUWF::register( + qr{json/(.[\w]*)} => \&serverlist_json, + qr{json/(.[\w]*)/(all|[0a-z])} => \&serverlist_json, + qr{json/(.[\w]*)/([\.\w]+):(\d+)} => \&json_serverinfo, + qr{json} => \&json_docs, +); + +################################################################################ +# LIST SERVERS +# Generate a list of selected games in the database per game (arg: gamename) +# Same as &serverlist, but with json output. +################################################################################ +sub serverlist_json { + my($self, $gamename, $char) = @_; + + # default list if nothing defined + $char = "all" unless $char; + + # process additional query information, such as order, sorting, page, etc + my $f = $self->formValidate( + { get => 'p', required => 0, default => 1, template => 'page' }, + { get => 'r', required => 0, default => 100, template => 'page' }, + { get => 'q', required => 0, default => '', maxlength => 90 }, + ); + return $self->resNotFound if $f->{_err}; + + # load server list from database + my($list, $np, $p) = $self->dbServerListGet( + reverse => $f->{o} eq 'd', + $char ne 'all' ? ( firstchar => $char ) : (), + results => $f->{r}, + search => $f->{q}, + gamename => $gamename, + page => $f->{p}, + ); + + # return json data as the response + my $json_data = encode_json [$list, {total => $p}]; + print { $self->resFd() } $json_data; + + # set content type and allow off-domain access (for example jQuery) + $self->resHeader("Access-Control-Allow-Origin", "*"); + $self->resHeader("Content-Type", "application/json; charset=UTF-8"); +} + +################################################################################ +# Server Info +# Show server info for an individual server +# Same as &server_info, but with json output. +# returns "error:1" if errors occurred +################################################################################ +sub json_serverinfo { + my ($self, $gamename, $s_addr, $s_port) = @_; + + # break address apart in valid ip, port + my ($ip,$port) = $self->valid_address($s_addr, $s_port); + + # select server from database + my $info = $self->dbGetServerListInfo( + ip => $ip, + hostport => $port, + limit => 1, + )->[0] if ($ip && $port); + + # display an error in case of an invalid IP or port + unless ($ip && $port && $info) { + my %err = (error => 1); + my $e = \%err; + my $json_data = encode_json $e; + my $json_data_size = keys %$e; + + # return json data as the response + print { $self->resFd() } $json_data; + + # set content type at the end + $self->resHeader("Access-Control-Allow-Origin", "*"); + $self->resHeader("Content-Type", "application/json; charset=UTF-8"); + return; + } + + # load additional information if available + my $details = $self->dbGetServerDetails(id => $info->{id})->[0]; + $info = { %$info, %$details } if $details; + my $json_data = encode_json $info; + my $json_data_size = keys %$info; + + # return json data as the response + print { $self->resFd() } $json_data; + + # set content type and allow off-domain access (for example jQuery) + $self->resHeader("Access-Control-Allow-Origin", "*"); + $self->resHeader("Content-Type", "application/json; charset=UTF-8"); +} + + +################################################################################ +# Json Documentation +# Minimalistic documentation about the JSON API +################################################################################ +sub json_docs { + my $self = shift; + $self->htmlHeader(title => "JSON API"); + div class => "mainbox"; + div class => "header"; + h1 "Json API"; + p class => "alttitle", "On this page you can find documentation about the 333networks masterserver JSON API."; + end; + + p "333networks has a JSON API. With this API, it is possible to obtain server lists and specific server information for your own banners, ubrowser or other application."; + + h2 "Permission & Terms of Use"; + p; + txt "In addition to our "; + a href => "/disclaimer", "Terms of Use"; + txt ", the following permissions and conditions are in effect: "; + end; + p "You are allowed to access our API with any application and/or script, self-made or not, to obtain our server lists and server information on the condition that somewhere, anywhere in your application or script you mention that the information is obtained from 333networks."; + p "You are not allowed to flood the API with requests or query our API continuously or with a short interval. If you draw too much network traffic from 333networks, we consider this flooding and will terminate your ability to query our API."; + p "Intended use: use the serverlist request to get show a list of all servers. After loading the list, your visitors/users can select a single server to display detailed information. Do NOT use the serverlist to immediately show detailed information for ALL servers, this causes a ludicrous amount of information requests and will get you excluded from our API."; + + h2 "Serverlist request"; + p "The JSON API consists of two functions to query for information. Both methods occur over HTTP and are presented as JSON data. The first method returns a list of servers and can be manipulated by gamename, first letter and number of results. 333networks applies the following regex to process your request:"; + + div class => "code"; + ul; + li "$self->{url}/json/(.[\w]*)"; + li "$self->{url}/json/(.[\w]*)/(all|[0a-z])"; + end; + end; + + p; + txt "In this regex, "; + span class => "code", "(.[\w]*)"; + txt " refers to the "; + span class => "ext", "gamename"; + txt ". This is the abbreviation that every game specifies in their masterserver protocol. A comprehensive list of gamenames is found on the "; + a href => "/g/all", "games"; + txt " page. The request can be augmented with a prefix of the "; + span class => "ext", "first letter"; + txt " of the server. For example, specifying the "; + span class => "code", "a"; + txt " will result in all server names starting with an \"a\" at the start of the name being returned."; + end; + + p; + txt "It is also possible to provide "; + span class => "code", "GET"; + txt " information in the url. Allowed options are:"; + end; + + ul; + li; span class => "code", "r"; txt " - number of results. Defaults to 50 if not specified. Minimum 1, maximum 1000."; end; + li; span class => "code", "p"; txt " - page. Show the specified page with results. Total number of entries is included in the result."; end; + li; span class => "code", "q"; txt " - search query. Identical to the search query on the "; a href => "/servers", "servers"; txt " page. Maximum query length is 90 characters."; end; + end; + + h3 "Request:"; + p; + txt "The following examples have different outcomes. In the first example, we request a serverlist of "; + span class => "code", "all"; + txt " servers, regardless of type and/or name. The second example requests only servers of the game "; + span class => "code", "Unreal"; + txt " that start with the letter "; + span class => "code", "a"; + txt ". In the last example, we request a serverlist with the gamename "; + span class => "code", "333networks"; + txt ", with only "; + span class => "code", "2"; + txt " results per page, page "; + span class => "code", "1"; + txt " and with the search word "; + span class => "code", "master"; + txt "."; + end; + + div class => "code"; + ul; + li; + txt "$self->{url}/json/"; + span class => "ext", "all"; + end; + li; + txt "$self->{url}/json/"; + span class => "ext", "unreal"; + txt "/"; + span class => "ext", "a"; + end; + li; + txt "$self->{url}/json/"; + span class => "ext", "333networks"; + txt "?r="; + span class => "ext", "2"; + txt "&p="; + span class => "ext", "1"; + txt "&q="; + span class => "ext", "master"; + end; + end; + end; + + h3 "Result:"; + p "The API returns JSON data in the following format, using the third request as an example. This is example data and may vary from what you receive when performing the same query."; + div class => "code"; + pre '[ + [ + { + "gametype":"MasterServer", + "description":"333networks MasterServer (Synchronization Protocol)", + "hostport":28905, + "updated":"1506087218", + "hostname":"dev.333networks.com (333networks Development MasterServer)", + "maxplayers":2965, + "country":"NL", + "mapname":"333networks", + "added":"1500485970.98186", + "numplayers":20, + "gamename":"333networks", + "diff":"82", + "id":869, + "ip":"84.83.176.234", + "maptitle":null + }, + { + "diff":"102", + "id":870, + "gamename":"333networks", + "numplayers":21, + "added":"1500485971.17096", + "maptitle":null,"ip":"84.83.176.234", + "hostname":"master.333networks.com (333networks Main MasterServer)", + "updated":"1506087198", + "description":"333networks MasterServer (Synchronization Protocol)", + "hostport":28900, + "gametype":"MasterServer", + "mapname":null,"country":"NL", + "maxplayers":2965 + } + ], + {"total":"3"} +]'; + end; + + p; + txt "The result contains an array of server entries and the "; + span class => "code", "total"; + txt " amount of entries. In this case, that is "; + span class => "code", "2"; + txt " entries listed and "; + span class => "code", "3"; + txt " total entries, implying that there is one more server not shown or on a next page. With the specified number of results specified by the user and the total amount of servers provided by the API, you can calculate how many pages there are to be specified. Every server entry has a number of unsorted keywords. The available keywords are:"; + end; + + ul; + li; span class => "code", "id"; txt " - server ID in our database"; end; + li; span class => "code", "ip"; txt " - IPv4 address"; end; + li; span class => "code", "hostport"; txt " - hostport to join the game. This port is also used to query specific server information (read more below)"; end; + li; span class => "code", "hostname"; txt " - name of the server"; end; + li; span class => "code", "gamename"; txt " - gamename of the server"; end; + li; span class => "code", "description"; txt " - gamename of the server as comprehensible game title"; end; + li; span class => "code", "country"; txt " - 2-letter country code where the server is hosted"; end; + li; span class => "code", "numplayers"; txt " - current number of players"; end; + li; span class => "code", "maxplayers"; txt " - maximum number of players"; end; + li; span class => "code", "mapname"; txt " - filename of current map"; end; + li; span class => "code", "maptitle"; txt " - title or description of current map"; end; + li; span class => "code", "gametype"; txt " - type of game: capture the flag, deathmatch, etc"; end; + li; span class => "code", "added"; txt " - date that the server was added to our database"; end; + li; span class => "code", "updated"; txt " - date that the server was updated in our database"; end; + li; span class => "code", "diff"; txt " - amount of seconds since this server was updated in our database"; end; + end; + p "There are more keywords available for the individual servers. Detailed information about a server is obtained with the Server Information request as described below."; + + h2 "Server Information request"; + p "Your application or script can also request detailed information for a single server. This is done in a similar way as requesting a server list. The following general regex is used by 333networks:"; + div class => "code"; + ul; + li "$self->{url}/json/(.[\w]*)/([\.\w]+):(\d+)"; + end; + end; + + p; + txt "This restricts requests to the correct url with a "; + span class => "code", "gamename"; + txt ", an "; + span class => "ext", "IP address"; + txt " or "; + span class => "ext", "domain name"; + txt " and a "; + span class => "ext", "decimal number"; + txt ". There are no additional query options or GET options. It is possible that the gamename specified does not match the "; + txt "gamename"; + txt " as stored in our database. The result will include the gamename that was specified in our database."; + end; + + p "The following two examples both request detailed information by IP address and domain name."; + h3 "Request:"; + div class => "code"; + ul; + li; + txt "$self->{url}/json/"; + span class => "ext", "333networks"; + txt "/"; + span class => "ext", "84.83.176.234"; + txt ":"; + span class => "ext", "28900"; + end; + li; + txt "$self->{url}/json/"; + span class => "ext", "333networks"; + txt "/"; + span class => "ext", "master.333networks.com"; + txt ":"; + span class => "ext", "28900"; + end; + end; + end; + + h3 "Result:"; + p "The API returns JSON data in the following format, using the requests above as an example. This is example data and may vary from what you receive when performing the same query."; + div class => "code"; + pre '{ + "beacon":"2017-09-22 16:49:18+02", + "updated":"2017-09-22 16:49:18+02", + "numplayers":21, + "country":"NL", + "hostport":28900, + "added":"2017-07-19 19:39:31.170957+02", + "maxplayers":2965, + "gamename":"333networks", + "gamever":"MS-perl 2.3.1", + "hostname":"master.333networks.com (333networks Main MasterServer)", + "friendlyfire":null, + "listenserver":null, + "updiff":"48", + "adminname":"Darkelarious", + "minplayers":0, + "mutators":"333networks synchronization, master applet synchronization", + "mapname":null, + "maxteams":null, + "fraglimit":null, + "blacklisted":0, + "playersbalanceteams":null, + "ip":"84.83.176.234", + "minnetver":null, + "maptitle":null, + "port":27900, + "password":null, + "b333ms":1, + "botskill":null, + "server_id":870, + "adminemail":"info@333networks.com", + "id":870, + "gametype":"MasterServer", + "gamestyle":null, + "balanceteams":null, + "changelevels":null, + "goalteamscore":null, + "timelimit":null, + "location":null, +}'; + end; + p "The result has a single entry of parameters with a number of unsorted keywords. The available keywords are in addition to the keywords specified in the serverlist:"; + ul; + li; span class => "code", "server_id"; txt " - detailed server ID in our database"; end; + li; span class => "code", "minnetver"; txt " - minimal required game version to join"; end; + li; span class => "code", "location"; txt " - geographical area (GameSpy)"; end; + li; span class => "code", "listenserver"; txt " - dedicated server?"; end; + li; span class => "code", "adminname"; txt " - server administrator's name"; end; + li; span class => "code", "adminemail"; txt " - server administrator's contact information"; end; + li; span class => "code", "password"; txt " - passworded/locked server"; end; + li; span class => "code", "gamestyle"; txt " - in-game playing style"; end; + li; span class => "code", "changelevels"; txt " - automatically change levels after match end"; end; + li; span class => "code", "minplayers"; txt " - number of bots"; end; + li; span class => "code", "botskill"; txt " - skill level of bots"; end; + li; span class => "code", "balanceteams"; txt " - team balancing on join"; end; + li; span class => "code", "playersbalanceteams"; txt " - players can toggle automatic team balancing"; end; + li; span class => "code", "friendlyfire"; txt " - friendly fire rate"; end; + li; span class => "code", "maxteams"; txt " - maximum number of teams"; end; + li; span class => "code", "timelimit"; txt " - time limit per match"; end; + li; span class => "code", "goalteamscore"; txt " - score limit per match"; end; + li; span class => "code", "fraglimit"; txt " - score limit per deathmatch"; end; + li; span class => "code", "mutators"; txt " - comma-separated mutator/mod list"; end; + li; span class => "code", "b333ms"; txt " - direct beacon to the masterserver"; end; + li; span class => "code", "beacon"; txt " - date that the last beacon was received"; end; + li; span class => "code", "blacklisted"; txt " - server is blacklisted at 333networks"; end; + end; + + h2 "Feedback"; + p; + txt "We wrote the JSON API with the intention to make the 333networks masterserver data as accessible as possible. If you feel like any functionality is missing or incorrectly shared, do not hesitate to "; + a href => "/contact", "contact"; + txt " us and to provide feedback. Additionally, we request that you follow the advise on usage as we described under the Terms of Use on top of this page, so we can keep providing this API."; + end; + + end; # mainbox + $self->htmlFooter(last_change => "Sep 2017"); +} + +1; diff --git a/lib/MasterWebInterface/Handler/FrontPage.pm b/lib/MasterWebInterface/Handler/FrontPage.pm new file mode 100755 index 0000000..f57c8e1 --- /dev/null +++ b/lib/MasterWebInterface/Handler/FrontPage.pm @@ -0,0 +1,220 @@ +package MasterWebInterface::Handler::FrontPage; +use strict; +use warnings; +use utf8; +use TUWF ':html'; +use Exporter 'import'; +our @EXPORT = qw| _box_content |; + +TUWF::register( + qr{} => \&main, +); + +################################################################################ +# Front page +# Contains list of new servers and boxes with information and stats. +################################################################################ +sub main { + my ($self, @args) = @_; + + # workaround for lists -- record options, but don't use them. + my $f = $self->formValidate( + { get => 's', required => 0, default => '', enum => [ ] }, + { get => 'o', required => 0, default => 'd', enum => [ 'a','d' ] }, + { get => 'p', required => 0, default => 1, template => 'page' }, + { get => 'q', required => 0, default => '', maxlength => 30 }, + ); + + $self->htmlHeader(title => "Welcome"); + + # load NEW SERVERS list from database + my ($list, $np, $p) = $self->dbServerListGet(results => 8, sort => 'added', reverse => 1); + my $odd = 0; + + # print list of new servers added to the database + $self->htmlBrowse( + items => $list, + options => $f, + total => $p, + nextpage => 0, + pageurl => "/s/all/all", + sorturl => "/s/all/all", + class => "newservers", + footer => sub { + Tr ++$odd % 2 ? (class => 'even') : (class => 'odd'), id => "tfooter"; + td colspan => 4; + txt "Add your server "; + a href => '/new', 'here'; + txt "!"; + end; + end 'tr';}, + ($p <= 0) ? (footer => sub {Tr;td colspan => 4, class => 'tc2', 'No recent servers found';end 'tr';}) : (), + header => [ + [ '', 'country' ], + [ 'Newest servers', 'hostname'], + [ 'Game', 'description'], + [ 'Added', 'added' ], + ], + row => sub { + my($s, $n, $l) = @_; + Tr $n % 2 ? (class => 's odd') : (class => 's'); + my ($flag, $country) = $self->countryflag($l->{country}); + td class => "tc1 flag", style => "background-image: url(/flag/$flag.svg);", title => $country, ''; + td class => "tc2"; a href => "/$l->{gamename}/$l->{ip}:$l->{hostport}", $l->{hostname}; end; + td class => "tc3"; a href => "/s/$l->{gamename}", $l->{description};end; + td $self->date_new($l->{added}); + end; + $odd = $n; # for footer + }, + ); + + # opening and welcome + div class => "mainbox"; + div class => "header"; + h2 "Welcome to $self->{site_name}"; + end; + p "On this website, you find a plain overview of all server addresses that are listed in our masterserver and all games that are currently supported. On this website you can also find links to instructions to add your online server to the masterserver, and how to receive the list from our masterserver as game player."; + end; + br style => "clear:both"; + +# div class => 'notice'; +# h2 "Generic Title"; +# p "Generic paragraph."; +# end; + + # + # two-sided pane with multiple boxes + div class => "frontcontainer"; + div class => "frontleft"; + $self->_box_content("populargames", $f); + $self->_box_content("errorist"); + end; + + div class => "frontright"; + $self->_box_content("onlinemasters", $f); + $self->_box_content("instructions"); + end; + end; + br style => "clear:both"; + + $self->htmlFooter(); +} + + +################################################################################ +## Content Boxes for front page +## (not in a specific order) +################################################################################ +sub _box_content { + my ($self, $k, $f) = @_; + + # + # Online Masterservers + if ($k eq 'onlinemasters') { + # load server list from database + my ($list, $np, $p) = $self->dbServerListGet( + results => 15, + sort => "hostname", + reverse => 0, + gamename => "333networks", + updated => 1800 + ); + + # print list + $self->htmlBrowse( + items => $list, + options => $f, + total => $p, + nextpage => 0, + pageurl => "/s/all/all", + sorturl => "/s/all/all", + class => "frontmasterlist", + ($p <= 0) ? (footer => sub {Tr;td colspan => 3, class => 'tc2', 'No masterservers found!';end 'tr';}) : (), + header => [ + [ '', 'country' ], + [ 'Masterserver Address', 'hostname'], + [ 'Last seen', 'updated' ], + ], + row => sub { + my($s, $n, $l) = @_; + Tr $n % 2 ? (class => 's odd') : (class => 's'); + my ($flag, $country) = $self->countryflag($l->{country}); + td class => "tc1 flag", style => "background-image: url(/flag/$flag.svg);", title => $country, ''; + td class => "tc2"; a href => "/$l->{gamename}/$l->{ip}:$l->{hostport}", (split(' ', $l->{hostname}))[0]; end; + td $self->timeformat($l->{diff}); + end; + }, + ); + return; + } + + # + # Instructions + if ($k eq 'instructions') { + div class => "mainbox"; + $self->figurelink("masterserver", "ubrowser2.jpg", "http://333networks.com/instructions"); + h2 "Instructions"; + p; + txt "In order to make online games work again after GameSpy ceased all services a lot of online multiplayer games were no longer supported. 333networks provides an alternative masterserver. This masterserver needs to be "; + span class => "ext", "manually"; + txt " activated in your settings. This can be done by adding one of the following masterserver addresses to your client settings:"; + end; + ul; + li "master.333networks.com:28900"; + li "master.errorist.tk:28900"; + #li "master.noccer.de:28900"; + li "master.newbiesplayground.net:28900"; + end; + p "As player, you can configure your game in the following way: find your configuration file and update your masterserver entries."; + p;a href => "http://333networks.com/instructions", "[Read the quick instruction here]";end; + end; + return; + } + + # + # Popular games + if ($k eq 'populargames') { + # load server list from database + my($list, $np, $p) = $self->dbGameListGet(results => 15, sort => 'num_total', reverse => 1); + # print list + $self->htmlBrowse( + items => $list, + options => $f, + total => $p, + nextpage => 0, + pageurl => "/g/all", + sorturl => "/g/all", + class => "frontpage", + ($p <= 0) ? (footer => sub {Tr;td colspan => 3, class => 'tc1', 'No games found.';end 'tr';}) : (), + header => [ + [ 'Top 10 popular games', 'description' ], + [ 'Direct', 'num_uplink' ], + [ 'Total', 'num_total' ], + ], + row => sub { + my($s, $n, $l) = @_; + Tr $n % 2 ? (class => 's odd') : (class => 's'); + td class => "tc1 flag"; a href => "/s/$l->{gamename}", $l->{description};end; + td $l->{num_uplink}; + td $l->{num_total}; + end; + }, + ); + return; + } + + # + # Errorist Forum + if ($k eq 'errorist') { + div class => "mainbox"; + $self->figurelink("other", "erroristforum.jpg", "http://forum.errorist.tk"); + h2 "The Errorist Network"; + p "Together with Errorist, we started and share our own forum. This platform is a development corner for UEngine games and the 333networks masterserver + games using it. Visit us at forum.errorist.tk and sign up!"; + p; + a href => "http://forum.errorist.tk", "[Join the talks!]"; + end; + end; + return; + } +} +1; diff --git a/lib/MasterWebInterface/Handler/Games.pm b/lib/MasterWebInterface/Handler/Games.pm new file mode 100755 index 0000000..54837eb --- /dev/null +++ b/lib/MasterWebInterface/Handler/Games.pm @@ -0,0 +1,97 @@ +package MasterWebInterface::Handler::Games; +use strict; +use TUWF ':html'; +use Exporter 'import'; +use Geography::Countries; + +TUWF::register( + qr{g} => \&gamelist, + qr{g/} => \&gamelist, + qr{g/(all|[a-z])} => \&gamelist, + qr{g/(.[\w]*)} => \&redirect_game, +); + +# redirect to /s/gamename (compatibility with old urls -- remove eventually) +sub redirect_game { + my ($self, $g) = @_; + return $self->resRedirect("/s/$g"); +} + +################################################################################ +# LIST GAMES +# Generate a list of games in the database (arg: gamename) +################################################################################ +sub gamelist { + my($self, $char) = @_; + + # default list if nothing defined + $char = "all" unless $char; + + # process additional query information, such as order, sorting, page, etc + my $f = $self->formValidate( + { get => 's', required => 0, default => 'num_total', enum => [ qw| description gamename num_uplink num_total | ] }, + { get => 'o', required => 0, default => 'd', enum => [ 'a','d' ] }, + { get => 'p', required => 0, default => 1, template => 'page' }, + { get => 'q', required => 0, default => '', maxlength => 30 }, + ); + return $self->resNotFound if $f->{_err}; + + # load server list from database + my($list, $np, $p) = $self->dbGameListGet( + sort => $f->{s}, + reverse => $f->{o} eq 'd', + $char ne 'all' ? ( + firstchar => uc $char ) : (), + results => 50, + search => $f->{q}, + page => $f->{p}, + ); + + $self->htmlHeader(title => "Browse Games"); + + div class => 'mainbox'; + div class => "header"; + h1 'Browse Games'; + p class => "alttitle", "An overview of all registered games, direct uplinks to our masterserver and the total amount of servers seen."; + end; + + form action => "/g/$char", 'accept-charset' => 'UTF-8', method => 'get'; + $self->htmlSearchBox('g', $f->{q}); + end; + p class => 'browseopts'; + for ('all', 'a'..'z') { + a href => "/g/$_", $_ eq $char ? (class => 'optselected') : (), $_ eq 'all' ? ('all') : $_ ? uc $_ : '#'; + } + end; + end; + + # print list + $self->htmlBrowse( + items => $list, + options => $f, + total => $p, + nextpage => [$p,50],#$np, + pageurl => "/g/$char?o=$f->{o};s=$f->{s};q=$f->{q}", + sorturl => "/g/$char?q=$f->{q}", + class => "gamelist", + ($p <= 0) ? (footer => sub {Tr;td colspan => 4, class => 'tc2', 'No games found.';end 'tr';}) : (), + header => [ + [ 'Game', 'description' ], + [ 'Code', 'gamename' ], + [ 'Direct', 'num_uplink' ], + [ 'Total', 'num_total' ], + ], + row => sub { + my($s, $n, $l) = @_; + Tr $n % 2 ? (class => 's odd') : (class => 's'); + td class => "tc1"; a href => "/s/$l->{gamename}", $l->{description};end; + td $l->{gamename}; + td $l->{num_uplink}; + td $l->{num_total}; + end; + }, + ); + + $self->htmlFooter; +} +1; diff --git a/lib/MasterWebInterface/Handler/ServInfo.pm b/lib/MasterWebInterface/Handler/ServInfo.pm new file mode 100755 index 0000000..e0aff47 --- /dev/null +++ b/lib/MasterWebInterface/Handler/ServInfo.pm @@ -0,0 +1,438 @@ +package MasterWebInterface::Handler::ServInfo; +use strict; +use warnings; +use utf8; +use TUWF ':html'; +use URI::Escape; +use POSIX 'strftime'; +use Exporter 'import'; +our @EXPORT = qw| serverError |; + +TUWF::register( + qr{(.[\w]*)/([\.\w]+):(\d+)} => \&show_server, +); + +################################################################################ +# Display server information +# Verify if game and server (ip:hostport) exist. Display as many available +# values as possible. +# Display error pages if not found or incorrect. +################################################################################ +sub show_server { + # self, gamename, "ip:port" + my ($self, $gamename, $s_addr, $s_port) = @_; + + # break address apart in valid ip, port + my ($ip,$port) = $self->valid_address($s_addr, $s_port); + + # display an error in case of an invalid IP or port + unless ($ip && $port) { + $self->serverError( + ip => ($ip ? 0 : 1), + port => ($port ? 0 : 1), + ); + return; + } + + # select server from database + my $info = $self->dbGetServerListInfo( + ip => $ip, + hostport => $port, + limit => 1, + )->[0]; + + # either redirect or show error when no info was found + if (!defined $info) { + # try if query port was provided instead + my $attempt = $self->dbGetServerListInfo( + ip => $ip, + port => $port, + limit => 1 + )->[0]; + + # if it exists now, automatically redirect to this page (don't show info here) + if (defined $attempt && defined $attempt->{hostport}) { + $self->resRedirect("/$gamename/$ip:$attempt->{hostport}"); + return; + } + + # otherwise, it was not found in the database at all. Notify. + $self->serverError(db => 1); + return; + } + + # load additional information if available + my $details = $self->dbGetServerDetails(id => $info->{id})->[0]; + $info = { %$info, %$details } if $details; + + # + # generate info page + # + $self->htmlHeader(title => $info->{hostname} || "Yet Another Server"); + div class => "mainbox detail"; + div class => "header"; + h1 $info->{hostname} || "Yet Another Server"; + end; + + # if no detailed info was found, the server was not updated or + # the game is not supported. + if (!defined $details) { + div class => 'warning'; + h2 'Detailed information missing!'; + p "Additional information could not be loaded. Either the server was not updated in our database, or detailed information for this game is not yet supported. The information on this page may not be accurate!"; + end; + } + + # + # Map thumbnail and bot info + # + div class => "container"; + div class => "thumbnail"; + + # find the correct thumbnail, otherwise standard 333 esrb pic + my $mapfig = "$self->{map_url}/default/333esrb.jpg"; + + # get prefix and mapname + my $mapname = lc $info->{mapname}; + my ($pre,$post) = $mapname =~ /^(DM|CTF\-BT|BT|CTF|DOM|AS|JB|TO|SCR|MH)-(.*)/i; + my $prefix = ($pre ? uc $pre : "other"); + + # if map figure exists, use it + if (-e "$self->{map_dir}/$info->{gamename}/$prefix/$mapname.jpg") { + $mapfig = "$self->{map_url}/$info->{gamename}/$prefix/$mapname.jpg"; + } + + # if not, game default image + elsif (-e "$self->{map_dir}/default/$info->{gamename}.jpg") { + $mapfig = "$self->{map_url}/default/$info->{gamename}.jpg"; + } + + img src => $mapfig, + alt => $mapfig, + title => ($info->{mapname} || "Unknown"); + span ($info->{maptitle} || ($info->{mapname} || "Unknown")); + end; + + table class => "mapinfo"; + if ($info->{maxplayers}) { + Tr; + td class => "wc1", "Players:"; + td; + txt $info->{numplayers} || 0; + txt "/"; + txt $info->{maxplayers} || 0; + end; + end; + } + if ($info->{botskill} && $info->{minplayers}) { + Tr; + td "Bots:"; + td; + txt $info->{minplayers} || 0; + txt " "; + txt ($info->{botskill} || "Standard"); + txt " bot"; txt ($info->{minplayers} == 1 ? "" : "s"); + end; + end; + } + end; + end; # container + + # + # Specific server entry information + # + table class => "serverinfo"; + Tr; + th class => "wc1", title => "Server ID: ".$info->{id}, "Server Info"; + th ""; + end; + Tr; + td "Address:"; + td title => $info->{port}, (($info->{ip} || $ip). ":". ($info->{hostport} || $port)); + end; + if ($info->{adminname}) { + Tr; + td "Admin:"; + td $info->{adminname}; + end; + } + Tr; + td class => "wc1", "Contact:"; + td; + if ($info->{adminemail}) {txt $info->{adminemail}} else { + i; + txt "This server has no contact information listed "; + a href => "https://ut99.org/viewtopic.php?f=33&t=6660", "[?]"; + end; + } + end; + end; + Tr; + td class => "wc1", "Location:"; + my ($flag, $country) = $self->countryflag($info->{country} || ""); + td; + img class => "flag", src => "/flag/$flag.svg"; + txt " ". $country; + end; + end; + Tr; { + td "Added:"; + my @t = gmtime($info->{addiff}); + my $sig = 0; + my $diff = ""; + if ($t[5]-70){$diff.=$t[5]-70 ." year".(($t[5]-70==1)?"":"s"); $sig++} + if ($t[7]){$diff.=($sig?", ":""). $t[7]." day".(($t[7]==1)?"":"s")} + if ($diff eq "") {$diff = "Less than one day";} + td $diff." ago (".(strftime "%e %b %Y", gmtime $info->{e_added}).")";} + end; + Tr; + td "Last seen:"; + td;{ + my @t = gmtime($info->{updiff}); + if ($t[5]-70 || $t[7]) { + # more than 1 day? show date + span class => "r", (strftime "%e %b %Y", gmtime $info->{e_updated}); + } else { + # less than 1 day? show "time ago" + my $diff = ""; + $diff .= ($t[2] ? $t[2]." hour".($t[2]>1?"s, ":", ") : ""); + $diff .= ($t[1] ? $t[1]." minute".($t[1]>1?"s, ":", ") : ""); + $diff .= ($t[0] ? $t[0]." second".($t[0]>1?"s":" ") : "0 seconds"); + $diff .= " ago"; + span $diff; + } + end;} + end; + Tr; + td "Flags: "; + td; + i ($info->{b333ms} ? "direct uplink, " : "applet or manual, "); + i ($info->{blacklisted} ? "blacklisted, " : "not blacklisted, "); + i ($info->{password} ? "passworded" : "not passworded"); + end; + end; + end; + + # + # Specific game and version information + # + table class => "gameinfo"; + Tr; + th class => "wc1", "Game Info"; + th ""; + end; + Tr; + td "Game:"; + td $info->{description} || $gamename; + end; + if ($info->{gametype}) { + Tr; + td "Type:"; + td $info->{gametype}; + end; + } + if ($info->{gamestyle}) { + Tr; + td "Style:"; + td $info->{gamestyle}; + end; + } + if ($info->{gamever}) { + Tr; + td "Version:"; + td $info->{gamever}; + end; + } + end; + + # + # Mutator list + # + table class => "mutators"; + Tr; + th "Mutators"; + end; + Tr; + td; + if (defined $info->{mutators} && $info->{mutators} ne "None") { + txt $info->{mutators};} + else {i "This server does not have any mutators listed.";} + end; + end; + end; + + table class => "players"; + my $player = $self->dbGetPlayerInfo(server_id => $info->{id}); + my %team = ( 0 => "#e66", + 1 => "#66e", + 2 => "#6e6", + 3 => "#ee6", + 4 => "#fe6" ); + + # loop through players and print them in a nicely formatted table with funky colors + Tr; + th class => "wc1", "Player Info"; + th class => "frags", 'Frags'; + th class => "mesh", 'Mesh'; + th class => "skin", 'Skin'; + th class => "ping", 'Ping'; + end; + + for (my $i=0; defined $player->[$i]->{player}; $i++) { + Tr $i % 2 ? (class => 'odd') : (), style => 'color:'.$team{$player->[$i]->{team}} || "#aaa"; + td class => "wc1", $player->[$i]->{player} . (($player->[$i]->{ngsecret} =~ m/^bot$/i) ? " (bot)" : ""); + td class => "frags", $player->[$i]->{frags}; + td class => "mesh", $player->[$i]->{mesh}; + td class => "skin", $player->[$i]->{skin}; + td class => "ping", $player->[$i]->{ping}; + end; + } + if (!defined $player->[0]->{player}) { Tr; td colspan => 5; lit '<i>There is no player information available.</i>'; end; end;} + end; + + + + # + # Share options (copy fields) + # + my $url = $self->{url}. "/". $gamename. "/". $info->{ip}. ":". $info->{hostport}; + table class => "shareopts"; + Tr; + th class => "wc1", "Share"; + th ""; + end; + Tr; + td class => "tc1", "Link"; + td class => "tc2"; + input type => 'text', class => 'text', name => 'url', value => $url; + end; + end; + Tr; + td class => "tc1"; + txt "Json API "; + a href => "/json", title => "The url to access this server over the 333networks Json API", "*"; + end; + td class => "tc2"; + input type => 'text', class => 'text', name => 'url', value => $self->{url}. "/json/". $gamename. "/". $info->{ip}. ":". $info->{hostport}; + end; + end; + Tr; + td "Forum Link"; + td; + textarea type => 'textarea', class => 'text', rows => 3, name => 'paste'; + txt "\[url=$url\]";lit "\n"; + lit "\t";txt $info->{hostname};lit "\n"; + txt "\[/url\]"; + end; + end; + end; + Tr; + td "HTML Code"; + td; + textarea type => 'textarea', class => 'text', rows => 3, name => 'paste'; + txt "<a href=\"$url\">";lit "\n"; + lit "\t"; txt $info->{hostname};lit "\n"; + txt "</a>"; + end; + end; + end; + end; + +=pod + Optional information blocks: + + # + # Teams + # + table class => "teaminfo"; + Tr; + th class => "wc1", "Team Info"; + th ""; + end; + Tr; + td "Balance Teams:"; + td ($info->{balanceteams} ? "Yes" : "No"); + end; + Tr; + td "Players Balance Teams:"; + td ($info->{playersbalanceteams} ? "Yes" : "No"); + end; + Tr; + td "Friendly Fire:"; + td ($info->{friendlyfire} || "0%"); + end; + Tr; + td "Max Teams:"; + td ($info->{maxteams} || 1); + end; + end; + + # + # Game Limits + # + table class => "limits"; + Tr; + th class => "wc1", "Limits"; + th ""; + end; + Tr; + td "Time Limit:"; + td (($info->{timelimit} || 0). ":00 min"); + end; + Tr; + td "Score Limit:"; + td ($info->{goalteamscore} || 0); + end; + Tr; + td "Frag Limit:"; + td ($info->{fraglimit} || 0); + end; + end; + + div class => "code"; + use Data::Dumper 'Dumper'; + pre; + txt Dumper [$info, $player]; + end; + end; + + if ($self->debug) { + use Data::Dumper 'Dumper'; + lit "<!--\n"; + lit Dumper $info; + lit Dumper $player; + lit "\n-->"; + } + +=cut + end; # mainbox details + $self->htmlFooter; +} + +################################################################################ +# Display server errors +# Generates error pages in case of faulty gamename, server or other vagueness +################################################################################ +sub serverError{ + my ($self, %error) = @_; + + $self->htmlHeader(title => "Server Info"); + div class => 'warning'; + h2 'An error occurred while trying to display the server.'; + ul; + if (!%error) { + li "Not even the error message works. Please contact the administrator.";} + if ($error{ip}) { + li "The provided address is incorrect or does not resolve.";} + if ($error{port}) { + li "The provided port is not valid.";} + if ($error{gamename}) { + li "The game was not found in our database.";} + if ($error{db}) { + li "The server was not found in our database.";} + end; + end; + $self->htmlFooter; +} + +1; diff --git a/lib/MasterWebInterface/Handler/Servers.pm b/lib/MasterWebInterface/Handler/Servers.pm new file mode 100755 index 0000000..306a2c8 --- /dev/null +++ b/lib/MasterWebInterface/Handler/Servers.pm @@ -0,0 +1,105 @@ +package MasterWebInterface::Handler::Servers; +use strict; +use utf8; +use TUWF ':html'; +use Exporter 'import'; +use Geography::Countries; + +TUWF::register( + qr{s/(.[\w]*)} => \&serverlist, + qr{s/(.[\w]*)/(all|[0a-z])} => \&serverlist, +); + +################################################################################ +# List servers +# Generate a list of selected games in the database per game (arg: gamename) +################################################################################ +sub serverlist { + my($self, $gamename, $char) = @_; + + # default list if nothing defined + $char = "all" unless $char; + + # process additional query information, such as order, sorting, page, etc + my $f = $self->formValidate( + { get => 's', required => 0, default => 'diff', enum => [ qw| country hostname description gamename gametype ip hostport numplayers mapname diff added | ] }, + { get => 'o', required => 0, default => 'a', enum => [ 'a','d' ] }, + { get => 'p', required => 0, default => 1, template => 'page' }, + { get => 'q', required => 0, default => '', maxlength => 90 }, + ); + return $self->resNotFound if $f->{_err}; + + # load server list from database + my($list, $np, $p) = $self->dbServerListGet( + sort => $f->{s}, + reverse => $f->{o} eq 'd', + $char ne 'all' ? ( + firstchar => uc $char ) : (), + results => 50, + search => $f->{q}, + gamename => $gamename, + page => $f->{p}, + ); + + # game name description in title + my $gn_desc = $self->dbGetGameDesc($gamename) || $gamename; + + # Write page + $self->htmlHeader(title => "Browse $gn_desc game servers"); + + div class => 'mainbox'; + div class => "header"; + h1 'Browse Servers'; + p class => "alttitle"; + txt "Servers listed for "; + span class => "acc", $gn_desc; + txt " games. Can be sorted by location, server name, gametype, players and current map."; + end; + end; + + form action => "/s/$gamename/all", 'accept-charset' => 'UTF-8', method => 'get'; + $self->htmlSearchBox('s', $f->{q}); + end; + p class => 'browseopts'; + for ('all', 'a'..'z', 0) { + a href => "/s/$gamename/$_", $_ eq $char ? (class => 'optselected') : (), $_ eq 'all' ? ('all') : $_ ? uc $_ : '#'; + } + end; + end; + + # print list + $self->htmlBrowse( + items => $list, + options => $f, + total => $p, + nextpage => [$p,50],#$np, + pageurl => "/s/$gamename/$char?o=$f->{o};s=$f->{s};q=$f->{q}", + sorturl => "/s/$gamename/$char?q=$f->{q}", + class => "serverlist", + ($p <= 0) ? (footer => sub {Tr;td colspan => 6, class => 'tc2', 'No online servers found';end 'tr';}) : (), + header => [ + [ '', 'country' ], + [ 'Server Name', 'hostname' ], + [ 'Game', 'gamename' ], + [ 'Gametype', 'gametype' ], + [ 'Players', 'numplayers' ], + [ 'Map', 'mapname' ], + ], + row => sub { + my($s, $n, $l) = @_; + Tr $n % 2 ? (class => 's odd') : (class => 's'); + my ($flag, $country) = $self->countryflag($l->{country}); + td class => "tc1 flag", style => "background-image: url(/flag/$flag.svg);", title => $country, ''; + td class => "tc2"; a href => "/$l->{gamename}/$l->{ip}:$l->{hostport}", $l->{hostname}; end; + td class => "tc3", title => $l->{description}; a href => "/s/$l->{gamename}", $l->{gamename};end; + td class => "tc4", title => $l->{gametype}, $l->{gametype}; + td class => "tc5"; txt $l->{numplayers}; txt "/"; txt $l->{maxplayers}; end; + td class => "tc6", title => ( $l->{maptitle} || $l->{mapname}), ($l->{maptitle} || $l->{mapname}); + end; + }, + ); + + $self->htmlFooter; +} + +1; diff --git a/lib/MasterWebInterface/Handler/Static/ErrorPages.pm b/lib/MasterWebInterface/Handler/Static/ErrorPages.pm new file mode 100755 index 0000000..02dfd15 --- /dev/null +++ b/lib/MasterWebInterface/Handler/Static/ErrorPages.pm @@ -0,0 +1,141 @@ +package MasterWebInterface::Handler::Static::ErrorPages; +use strict; +use TUWF ':html'; + +################################################################################ +# TUWF: +# Set the default error pages for errors +################################################################################ +TUWF::set( + error_400_handler => \&handle400, + error_404_handler => \&handle404, + error_405_handler => \&handle405, + error_413_handler => \&handle413, + error_500_handler => \&handle500, +); + +TUWF::register( + qr{500} => sub {die "Process died on purpose"}, + qr{unavailable} => \&handle_unavailable, + qr{nospam} => \&nospam, +); + +################################################################################ +# Catch malformed links that were not replaced by the javascript tool +# Can also be the result of no javascript. +################################################################################ +sub nospam { + my $self = shift; + $self->htmlHeader(title => 'Go Away!', noindex => 1); + + div class => 'warning'; + h1 'Form Error'; + p 'The form could not be sent. Either you are a robot or you do not have Javascript enabled in your browser.'; + end; + + $self->htmlFooter; +} + +################################################################################ +# Not yet available +################################################################################ +sub handle_unavailable { + my $self = shift; + + $self->htmlHeader(title => 'Function Unavailable'); + div class => 'warning'; + h1 'Function Unavailable'; + p "The function you tried to access was set unavailable. This action is either not written yet, or was disabled by the server administrator. As soon as this function becomes available, it will be announced on the front page."; + end; + $self->htmlFooter; +} + +################################################################################ +# Error 400 +################################################################################ +sub handle400 { + my $self = shift; + + $self->resStatus(400); + $self->htmlHeader(title => '400 - Bad Request'); + div class => 'warning'; + h1 '400 - Bad Request'; + p "The server was unable to understand the request and process it."; + end; + $self->htmlFooter; +} + +################################################################################ +# Error 404 +# I either screwed up with a link, or the page you are looking for does not +# exist. A little more content would be nice, and perhaps a funny picture. +################################################################################ +sub handle404 { + my $self = shift; + + $self->resStatus(404); + $self->htmlHeader(title => '404 - Not Found'); + div class => 'warning'; + h1 '404 - Not Found'; + p; + txt 'It seems the page you were looking for does not exist,'; + br; + txt 'you may want to try using the menu to find what you are looking for.'; + end; + end; + $self->htmlFooter; +} + +################################################################################ +# Error 405 +################################################################################ +sub handle405 { + my $self = shift; + + $self->resStatus(405); + $self->htmlHeader(title => '405 - Method Not Allowed'); + div class => 'warning'; + h1 '405 - Method Not Allowed'; + p "The submitted method is not allowed."; + end; + $self->htmlFooter; +} + +################################################################################ +# Error 413 +################################################################################ +sub handle413 { + my $self = shift; + + $self->resStatus(413); + $self->htmlHeader(title => '413 - Request Entity Too Large'); + div class => 'warning'; + h1 '413 - Request Entity Too Large'; + p "The requested entity contains too many bytes."; + end; + $self->htmlFooter; +} + +################################################################################ +# Error 500 +# Internal server error, most likely due to a database freezing/being busy +################################################################################ +sub handle500 { + my($self, $error) = @_; + + $self->resStatus(500); + $self->htmlHeader(title => '500 - Internal Server Error'); + div class => 'warning'; + h1 '500 - Internal Server Error'; + p 'Something went wrong on our side. The problem was logged and will be fixed shortly. Please try again later.'; + + if ($self->debug) { + div class => "code"; + pre $error; + end; + } + end; + $self->htmlFooter; +} + +1; diff --git a/lib/MasterWebInterface/Handler/Tools/AddNew.pm b/lib/MasterWebInterface/Handler/Tools/AddNew.pm new file mode 100755 index 0000000..dbeaa90 --- /dev/null +++ b/lib/MasterWebInterface/Handler/Tools/AddNew.pm @@ -0,0 +1,280 @@ +package MasterWebInterface::Handler::Tools::AddNew; +use strict; +use warnings; +use Encode; +use Socket; +use IP::Country::Fast; +use TUWF ':html'; + +TUWF::register( + qr{new} => \&addnewserver, + qr{new/([\.\w]+):(\d+)/(\d+)} => \&valnewserver, +); + +################################################################################ +# Helper page to add server addresses to the masterserver manually +# Uses the valnewserver page/function to validate an active server. +################################################################################ +sub addnewserver { + my $self = shift; + $self->htmlHeader(title => "Add a new server"); + + div class => "mainbox detail"; + div class => "header"; + h1 "Manually add a server"; + p class => "alttitle", "333networks allows you to add supported servers manually. On this page is explained how to add your server to our masterserver."; + end; + + p "You can add your server to our site in two ways:"; + ol; + li; + txt "Follow the instructions on the "; + a href => "/masterserver", "MasterServer"; + txt " page. This also allows other players to see your server online."; + end; + li "Follow the instructions below. This allows you to share links to your server page."; + end; + + p; + txt "To link to your serverstatus, fill in your gameserver's IP and your gameserver's queryport, usually the game port +1. If your server does not show up, check for typos and verify that your firewall is not blocking your server. Your ip is "; + span class => "ext", $ENV{'REMOTE_ADDR'}; + txt "."; + end; + + table class => "shareopts new"; + Tr; + td "IP address:"; + td; input type => "text", class => "text", id => "ip", value => $ENV{'REMOTE_ADDR'}; end; + end; + Tr; + td "Query port (game port + 1):"; + td; input type => "text", class => "text", id => "port", value => "7778"; end; + end; + Tr; + td ""; + td; input type => "submit", class => "submit", value => "Search Server", onclick => "QueryLink()"; end; + end; + end; + + p id => "newlink", class => "ext"; + txt "Please enter the server's ip and port in the fields above."; + end; + + end; + + div id => "validate"; + end; + + $self->htmlFooter; +} + + +################################################################################ +# Query and validate a manually added server. +# Arguments passed on via javascript (unsafe) +# Random number prevents some browsers from caching the request and also +# prevents the /gamename/ip:port regex from catching this function/page. +################################################################################ +sub valnewserver { + my ($self, $s_addr, $s_port, $s_rand) = @_; + my ($ip,$port) = $self->valid_address($s_addr, $s_port); + + # return "invalid" if no valid ip/port + if (!$ip || !$port){die "invalid";return;} + + # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # + # DANGEROUS CODE: DO NOT EDIT UNLESS YOU KNOW WHAT YOU ARE DOING + # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # + # + # Query the game server here on the spot. This may cause timeouts/errors with + # slow or unresponsive servers. Will generate an error in the browser if so. + # + # TODO: consider safer code for this part. + # + # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # + + # prepare target + my $qaddr = sockaddr_in($port, inet_aton($ip) ); + my ($data, $buf) = ("",""); + + eval { + # return error stats on time-out + local $SIG{ALRM} = sub {die "timeout"}; + + alarm 2; + socket(SERVER, PF_INET, SOCK_DGRAM, getprotobyname("udp")) or die "timeout"; + connect(SERVER, $qaddr); + send(SERVER, "\\status\\", 0, $qaddr); + + #receive server info + while($data !~ /\\final\\/) { + recv(SERVER, $data, 0xFFFF, 0); + $buf .= $data; + } + shutdown(SERVER, 2); + alarm 0; + }; + + # turn buffer into hashref + my @a = split /\\/, encode('UTF-8', $buf || ""); + shift @a; + my %h = (@a, (scalar @a % 2 == 1) ? "dummy" : () ); + %h = map { lc $_ => $h{$_} } keys %h; + my $r = \%h; + + # any text received? + # check for some random, supposedly existing tags like gamename, gamever + if ($r->{gamename} || $r->{gamever}) { + div class => "mainbox detail"; + div class => "header"; + h1 $r->{hostname} || "Unnamed Server"; + end; + + div class => "container"; + div class => "thumbnail"; + + # find the correct thumbnail, otherwise standard 333 esrb pic + my $mapfig = "$self->{map_url}/default/333esrb.jpg"; + + # get prefix and mapname + my $mapname = lc $r->{mapname}; + my ($pre,$post) = $mapname =~ /^(DM|CTF\-BT|BT|CTF|DOM|AS|JB|TO|SCR|MH)-(.*)/i; + my $prefix = ($pre ? uc $pre : "other"); + + # if map figure exists, use it + if (-e "$self->{map_dir}/$r->{gamename}/$prefix/$mapname.jpg") { + $mapfig = "$self->{map_url}/$r->{gamename}/$prefix/$mapname.jpg"; + } + + # if not, game default image + elsif (-e "$self->{map_dir}/default/$r->{gamename}.jpg") { + $mapfig = "$self->{map_url}/default/$r->{gamename}.jpg"; + } + + img src => $mapfig, + alt => $mapfig, + title => ($r->{mapname} || "Unknown"); + span ($r->{maptitle} || "Unknown"); + end; + + table class => "mapinfo"; + if ($r->{maxplayers}) { + Tr; + td class => "wc1", "Players:"; + td; + txt $r->{numplayers} || 0; + txt "/"; + txt $r->{maxplayers} || 0; + end; + end; + } + if ($r->{botskill} && $r->{minplayers}) { + Tr; + td "Bots:"; + td; + txt $r->{minplayers} || 0; + txt " "; + txt ($r->{botskill} || "Standard"); + txt " bot"; txt ($r->{minplayers} == 1 ? "" : "s"); + end; + end; + } + end; + end; # container + + # + # Specific server entry information + # + table class => "serverinfo"; + Tr; + th class => "wc1", "Server Info"; + th ""; + end; + Tr; + td "Address:"; + td title => $r->{port}, (($r->{ip} || $ip). ":". ($r->{hostport} || $port)); + end; + if ($r->{adminname}) { + Tr; + td "Admin:"; + td $r->{adminname}; + end; + } + Tr; + td class => "wc1", "Contact:"; + td; + if ($r->{adminemail}) {txt $r->{adminemail}} + end; + end; + Tr; + td class => "wc1", "Location:"; + my $reg = IP::Country::Fast->new(); + my ($flag, $country) = $self->countryflag($reg->inet_atocc($ip) || ""); + td; + img class => "flag", src => "/flag/$flag.svg"; + txt " ". $country; + end; + end; + end; + + # + # Specific game and version information + # + table class => "gameinfo"; + Tr; + th class => "wc1", "Game Info"; + th ""; + end; + Tr; + td "Game:"; + td $self->dbGetGameDesc($r->{gamename}) || "unknown game"; + end; + if ($r->{gametype}) { + Tr; + td "Type:"; + td $r->{gametype}; + end; + } + if ($r->{gamestyle}) { + Tr; + td "Style:"; + td $r->{gamestyle}; + end; + } + if ($r->{gamever}) { + Tr; + td "Version:"; + td $r->{gamever}; + end; + } + end; + + # + # Mutator list + # + table class => "mutators"; + Tr; + th "Mutators"; + end; + Tr; + td; + if (defined $r->{mutators}) { + txt $r->{mutators};} + else {i "This server does not have any mutators listed.";} + end; + end; + end; + + # add this server to the list of pending IPs if it does not exist in the db already + p class => "ext", ( $self->dbAddServer(ip => $ip, port => $port) ? "The server was added to the database." : "The server already exists in the database." ); + end; # mainbox detail + + } + else { + # else return "invalid" to make AJAX understand that the query failed. + txt "invalid"; + } +} + +1; + diff --git a/lib/MasterWebInterface/Handler/Tools/Version.pm b/lib/MasterWebInterface/Handler/Tools/Version.pm new file mode 100755 index 0000000..9ffe41a --- /dev/null +++ b/lib/MasterWebInterface/Handler/Tools/Version.pm @@ -0,0 +1,50 @@ +package MasterWebInterface::Handler::Tools::Version; +use strict; +use warnings; +use TUWF ':html'; + +TUWF::register( + qr{version}, \&version, +); + +sub version { + my $self = shift; + $self->htmlHeader(title => 'Version information', noindex => 1); + + div class => "mainbox contact"; + div class => "header"; + h1 "Version Information"; + p class => "alttitle", ""; + end; + + # version and author information + # + # You are not allowed to modify these variables without making (significant) + # alterations to the source code of this master server program. Only changing + # 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 (e)mail with your compliments. + # + + p "This MasterServer Interface has the following version information:"; + table; + Tr; td "build_type"; td "333networks Masterserver Development Interface ";end; + Tr; td "build_version"; td "3.0.0";end; + Tr; td "build_date"; td "2017-09-25";end; + Tr; td "build_author"; td "Darkelarious, darkelarious\@333networks.com";end; + end; + + p "This MasterServer Interface is compatible since the following MasterServer type(s):"; + table; + Tr; td "build_type"; td "333networks Masterserver-Perl";end; + Tr; td "build_version"; td "2.4.1";end; + Tr; td "build_date"; td "2017-09-25";end; + Tr; td "build_author"; td "Darkelarious, darkelarious\@333networks.com";end; + end; + + end; +} + +1; + diff --git a/lib/MasterWebInterface/Util/BrowseHTML.pm b/lib/MasterWebInterface/Util/BrowseHTML.pm new file mode 100755 index 0000000..32d773e --- /dev/null +++ b/lib/MasterWebInterface/Util/BrowseHTML.pm @@ -0,0 +1,126 @@ +package MasterWebInterface::Util::BrowseHTML; +use strict; +use warnings; +use TUWF ':html', 'xml_escape'; +use Exporter 'import'; +use POSIX 'ceil'; +our @EXPORT = qw| htmlBrowse htmlBrowseNavigate |; + +# generates a browse box, arguments: +# items => arrayref with the list items +# options => hashref containing at least the keys s (sort key), o (order) and p (page) +# nextpage => whether there's a next page or not +# sorturl => base URL to append the sort options to (if there are any sortable columns) +# pageurl => base URL to append the page option to +# class => classname of the mainbox +# header => +# can be either an arrayref or subroutine reference, +# in the case of a subroutine, it will be called when the header should be written, +# in the case of an arrayref, the array should contain the header items. Each item +# can again be either an arrayref or subroutine ref. The arrayref would consist of +# two elements: the name of the header, and the name of the sorting column if it can +# be sorted +# row => subroutine ref, which is called for each item in $list, arguments will be +# $self, $item_number (starting from 0), $item_value +# footer => subroutine ref, called after all rows have been processed +# Mostly written by Yorhel --> https://g.blicky.net/vndb.git/tree/COPYING +sub htmlBrowse { + my($self, %opt) = @_; + + $opt{sorturl} .= $opt{sorturl} =~ /\?/ ? ';' : '?' if $opt{sorturl}; + + # top navigation + $self->htmlBrowseNavigate($opt{pageurl}, $opt{options}{p}, $opt{nextpage}, 't') if $opt{pageurl}; + + div class => 'mainbox browse'.($opt{class} ? ' '.$opt{class} : ''); + table class => 'stripe'; + + # header + thead; + Tr; + if(ref $opt{header} eq 'CODE') { + $opt{header}->($self); + } else { + for(0..$#{$opt{header}}) { + if(ref $opt{header}[$_] eq 'CODE') { + $opt{header}[$_]->($self, $_+1); + } elsif ($opt{simple}) { + td class => $opt{header}[$_][3]||'tc'.($_+1), $opt{header}[$_][2] ? (colspan => $opt{header}[$_][2]) : (); + if($opt{header}[$_][1]) { + lit qq|<a href="$opt{sorturl}o=d;s=$opt{header}[$_][1]">$opt{header}[$_][0]</a>|;} + else { + txt $opt{header}[$_][0];} + end; + } else { + td class => $opt{header}[$_][3]||'tc'.($_+1), $opt{header}[$_][2] ? (colspan => $opt{header}[$_][2]) : (); + lit $opt{header}[$_][0]; + if($opt{header}[$_][1]) { + lit ' '; + $opt{options}{s} eq $opt{header}[$_][1] && $opt{options}{o} eq 'a' ? lit "\x{25B4}" : a href => "$opt{sorturl}o=a;s=$opt{header}[$_][1]", "\x{25B4}"; + $opt{options}{s} eq $opt{header}[$_][1] && $opt{options}{o} eq 'd' ? lit "\x{25BE}" : a href => "$opt{sorturl}o=d;s=$opt{header}[$_][1]", "\x{25BE}"; + } + end; + } + } + } + end; + end 'thead'; + + # footer + if($opt{footer}) { + tfoot; + $opt{footer}->($self); + end; + } + + # rows + $opt{row}->($self, $_+1, $opt{items}[$_]) + for 0..$#{$opt{items}}; + + end 'table'; + end 'div'; + + # bottom navigation + $self->htmlBrowseNavigate($opt{pageurl}, $opt{options}{p}, $opt{nextpage}, 'b') if $opt{pageurl}; +} + + +# creates next/previous buttons (tabs), if needed +# Arguments: page url, current page (1..n), nextpage (0/1 or [$total, $perpage]), alignment (t/b), noappend (0/1) +# Mostly written by Yorhel --> https://g.blicky.net/vndb.git/tree/COPYING +sub htmlBrowseNavigate { + my($self, $url, $p, $np, $al, $na) = @_; + my($cnt, $pp) = ref($np) ? @$np : ($p+$np, 1); + return if $p == 1 && $cnt <= $pp; + + $url .= $url =~ /\?/ ? ';p=' : '?p=' unless $na; + + my $tab = sub { + my($left, $page, $label) = @_; + li $left ? (class => 'left') : (); + a href => $url.$page; lit $label; end; + end; + }; + my $ell = sub { + use utf8; + li class => 'ellipsis'.(shift() ? ' left' : ''); + b '⋯'; + end; + }; + my $nc = 5; # max. number of buttons on each side + + ul class => 'maintabs browsetabs ' . ($al eq 't' ? 'notfirst' : 'bottom'); + $p > 2 and ref $np and $tab->(1, 1, '« first'); + $p > $nc+1 and ref $np and $ell->(1); + $p > $_ and ref $np and $tab->(1, $p-$_, $p-$_) for (reverse 2..($nc>$p-2?$p-2:$nc-1)); + $p > 1 and $tab->(1, $p-1, '‹ previous'); + + my $l = ceil($cnt/$pp)-$p+1; + $l > 2 and $tab->(0, $l+$p-1, ('last').' »'); + $l > $nc+1 and $ell->(0); + $l > $_ and $tab->(0, $p+$_, $p+$_) for (reverse 2..($nc>$l-2?$l-2:$nc-1)); + $l > 1 and $tab->(0, $p+1, ('next').' ›'); + end 'ul'; +} + +1; diff --git a/lib/MasterWebInterface/Util/CommonHTML.pm b/lib/MasterWebInterface/Util/CommonHTML.pm new file mode 100755 index 0000000..5390740 --- /dev/null +++ b/lib/MasterWebInterface/Util/CommonHTML.pm @@ -0,0 +1,26 @@ +package MasterWebInterface::Util::CommonHTML; +use strict; +use warnings; +use TUWF ':html'; +use Exporter 'import'; +our @EXPORT = qw| htmlSearchBox |; + +################################################################################ +# Search box with first letters +# for games, servers and possibly later on players +################################################################################ +sub htmlSearchBox { + my($self, $sel, $v) = @_; + + fieldset class => 'search'; + p id => 'searchtabs'; + a href => '/g/all', $sel eq 'g' ? (class => 'sel') : (), 'Games'; + a href => '/s/all', $sel eq 's' ? (class => 'sel') : (), 'Servers'; + #a href => '/p/all', $sel eq 'p' ? (class => 'sel') : (), 'Players'; + end; + input type => 'text', name => 'q', id => 'q', class => 'text', value => $v; + input type => 'submit', class => 'submit', value => 'search'; + end 'fieldset'; +} + +1; diff --git a/lib/MasterWebInterface/Util/Figures.pm b/lib/MasterWebInterface/Util/Figures.pm new file mode 100755 index 0000000..a3f3e5f --- /dev/null +++ b/lib/MasterWebInterface/Util/Figures.pm @@ -0,0 +1,38 @@ +package MasterWebInterface::Util::Figures; +use strict; +use warnings; +use TUWF ':html'; +use Exporter 'import'; +use Image::Size; +our @EXPORT = qw| figure figurelink |; + +################################################################################ +# Load image in Yorhel's IV. +################################################################################ +sub figure { + my ($self, $d, $f, $s) = @_; + my $extra_css = (defined($s)) ? "style=\"$s\"" : ""; + my ($w, $h) = imgsize("$self->{img_path}/$d/$f"); + # make a link and show a thumbnail if exists, else photo itself + if (-e "$self->{img_path}/t/$f") { + lit "<a rel=\"iv:$w"."x"."$h\" href=\"/img/$d/$f\"><img $extra_css src=\"/img/t/$f\" alt=\"$f\"/></a> " + } + else{ + lit "<a rel=\"iv:$w"."x"."$h\" href=\"/img/$d/$f\"><img $extra_css src=\"/img/$d/$f\" alt=\"$f\"/></a> "} +} + +################################################################################ +# Have a picture $f link to destination $dest -- wrapper function +################################################################################ +sub figurelink { + my ($self, $d, $f, $dest) = @_; + # make a link and show a thumbnail if exists, else photo itself + if (-e "$self->{img_path}/t/$f") { + lit "<a href=\"$dest\"><img src=\"/img/t/$f\" alt=\"$f\"/></a> " + } + else{ + lit "<a href=\"$dest\"><img src=\"/img/$d/$f\" alt=\"$f\"/></a> "} +} + + +1; diff --git a/lib/MasterWebInterface/Util/Layout.pm b/lib/MasterWebInterface/Util/Layout.pm new file mode 100755 index 0000000..4f62d5e --- /dev/null +++ b/lib/MasterWebInterface/Util/Layout.pm @@ -0,0 +1,60 @@ +package MasterWebInterface::Util::Layout; +use strict; +use warnings; +use TUWF ':html'; +use Exporter 'import'; +our @EXPORT = qw| htmlHeader htmlFooter |; + +################################################################################ +# htmlHeader +# options: title, noindex +################################################################################ +sub htmlHeader { + my($self, %o) = @_; + + html lang => "en"; + head; + title "$o{title} :: $self->{site_title}"; + Link rel => 'shortcut icon', href => "$self->{url}/favicon.ico", type => 'image/x-icon'; + Link rel => 'stylesheet', href => "$self->{url}/style/$self->{style}/style.css", type => "text/css", media => "all"; + meta name => "google-site-verification", content => "tkhIW87EwqNKSGEumMbK-O3vqhwaANWbNxkdLBDGZvI";end; + meta name => 'robots', content => 'noindex,nofollow,nosnippet,noodp,noarchive,noimageindex';end; #FIXME set proper robots params + script type => 'text/javascript', src => "$self->{url}/interface-scripts.js", ''; + end; # head + + body; + div class => 'nav'; + ul; + li; a href => "/", "home"; end; + li; a href => "/g/all", "games"; end; + li; a href => "/s/all", "servers"; end; + end; + end; + + div id => "body"; + # start the page content with a header logo box + div class => "titlebox"; + end; +} + +################################################################################ +# htmlFooter +# options: last edited (not shown) +# General html layout header (bottom) +################################################################################ +sub htmlFooter { + my $self = shift; + br style => "clear:both"; + + div id => 'footer'; + txt "$self->{site_title} | Powered by "; + a href => "http://333networks.com", "333networks"; + txt " & "; + a href => "http://dev.yorhel.nl/tuwf", "TUWF"; + end; + end 'div'; # body + end 'body'; + end 'html'; +} + +1; diff --git a/lib/MasterWebInterface/Util/Misc.pm b/lib/MasterWebInterface/Util/Misc.pm new file mode 100755 index 0000000..0be7aae --- /dev/null +++ b/lib/MasterWebInterface/Util/Misc.pm @@ -0,0 +1,72 @@ +package MasterWebInterface::Util::Misc; +use strict; +use warnings; +use TUWF ':html'; +use POSIX 'strftime'; +use Exporter 'import'; +use Encode 'encode_utf8'; +use Geography::Countries; +use Unicode::Normalize 'NFKD'; +use Socket 'inet_pton', 'inet_ntop', 'AF_INET', 'AF_INET6'; +our @EXPORT = qw| date_new timeformat countryflag valid_address |; + +################################################################################ +# time formatting for when a server was added +################################################################################ +sub date_new { + my ($s, $d) = @_; + #return (strftime "%a %H:%M:%S", gmtime $d); + return (strftime "%a %H:%M", gmtime $d); # no seconds +} + +################################################################################ +# time formatting for when a server was added / last updated +################################################################################ +sub timeformat { + my ($self, $time) = @_; + + # parse seconds with gmtime + my @t = gmtime($time); + my $r = ""; + + # parse into d HH:mm:SS format + if ($t[7]){$r .= $t[7]."d "} + if ($t[2]){$r .= ($t[2] > 9) ? $t[2].":" : "0".$t[2].":" } + if ($t[1]){$r .= ($t[1] > 9) ? $t[1].":" : "0".$t[1].":" } else {$r .= "00:";} + if ($t[0]){$r .= ($t[0] > 9) ? $t[0] : "0".$t[0] } else {$r .= "00";} + + return $r; +} + +################################################################################ +# returns flag, country name +################################################################################ +sub countryflag { + my ($self, $c) = @_; + my $flag = ($c ? lc $c : 'earth'); + my $coun = $c ? ( $c eq 'EU' ? 'Europe' : country $c ) : 'Earth' ; + return $flag, $coun; +} + +################################################################################ +# Verify whether a given domain name or IP address and port are valid. +# returns the valid ip-address + port, or 0 when not. +################################################################################ +sub valid_address { + my ($self, $a, $p) = @_; + + # check if ip and port are in valid range + my $val_addr = ($a =~ '^(?:(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)\.){3}(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)$') if $a; + my $val_port = ($p =~ m/^\d+$/ && 0 < $p && $p <= 65535) if $p; + + # exclude local addresses + if ($a =~ m/192.168.(\d).(\d)/ || $a =~ m/127.0.(\d).(\d)/ || $a =~ m/10.0.(\d).(\d)/) { $val_addr = 0; } + + # return valid params + return ( + $val_addr ? $a : 0, + $val_port ? $p : 0 + ); +} + +1; |