diff --git a/c_stuff/lib/fb_net_discover.pm b/c_stuff/lib/fb_net_discover.pm new file mode 100644 index 0000000..d8ff0b0 --- /dev/null +++ b/c_stuff/lib/fb_net_discover.pm @@ -0,0 +1,376 @@ +#***************************************************************************** +# +# Frozen-Bubble +# +# Copyright (c) 2008 The Frozen-Bubble Team +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License version 2, as +# published by the Free Software Foundation. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# +# +# This module was created by Mark Glines. +# +#****************************************************************************** + +package fb_net_discover; + +use strict; +use warnings; +use IO::Socket; +use IO::Select; +use Time::HiRes qw(gettimeofday tv_interval); +use Carp; + +use fb_net; +my $proto_hdr = "FB/" . $fb_net::proto_major . "." .$fb_net::proto_minor; + +# configuration parameters +my $number_of_pings = 2; # ping each server this many times. +my $time_between_connections = 0.1; # 100ms, 10 connections per second + +# note: the ping-averaging code below assumes $number_of_pings >= 2. + + +=head1 NAME + +fb_net_discover - high performance server discovery plugin for frozen bubble + +=head1 SYNOPSIS + + my $discover = fb_net_discover->new( + { host => "1.2.3.4", port => 1511 }, + { host => "5.6.7.8", port => 1512 }, ...); + while($discover->pending()) { + my @servers = $discover->found(); + for(my $server = 0; $server < @servers; $server++) { + printf("%02i: ip %s ping %i\n", + $server, $servers[$server]{ip}, $servers[$server]{ping}); + } + $discover->work(0.1); # sit in a select loop for 100ms + + # update your screen, and all of that stuff, here. + } + + +=head1 DESCRIPTION + +B checks a list of servers, finding their versions, ping times, +and number of current clients. It uses nonblocking IO and B loop for most of its life in order to get accurate ping times, but +it will return back to your loop at intervals you specify, so you can check +for keystrokes and refresh the screen and so forth. + +In order to get consistent results on slow dialup links, this module will only +attempt to B to one server per each 200ms. This means for 18 servers +that there are 3.4 seconds of extra guaranteed lag, but it also means packets +from multiple servers are less likely to bump into eachother in the queue, so +ping reply times will be more reliable. + +In the source script, there are two configuration parameters: $number_of_pings +and $time_between_connections. These are set to 2 and 0.2, respectively. +These two parameters will determine the amount of bandwidth used, and the +amount of time taken before the user can select a server. Assuming the user's +internet connection can handle the traffic without extra latency from queueing +or retransmissions, the worst case latency will be, in seconds: + + N*L + T*(S-1) + +where + + N = $number_of_pings + L = the roundtrip time of the slowest server in the list, in seconds + T = $time_between_connections + S = the number of servers in the list + + +=head1 CONSTRUCTOR + + ...->new ({host => "server1", port => port}, {host => "server2", port => port}, ...) + +Takes a list of servers as arguments. Each server argument should be a hash +reference, consisting of {host => host, port => port}. Returns a +fb_net_discover object, which can be used within a GUI loop to discover all of +your servers. + +The host string should ideally be an IP address. A hostname string should work +too, but DNS lookups will introduce extra, unpredictable latency later on. + +=cut + +sub new { + my ($package, @servers) = @_; + my $time = [gettimeofday]; + # force the first connection immediately + $$time[0]--; + my $self = { + begin_time => $time, # used to sequence the connect()s + not_started => {}, # server entries move from here... + pending => {}, # ... to here ... + complete => {}, # ... to here. + revmapping => {}, # used after select(), to map handles to hashkeys + }; + my $servid = 1; + foreach my $server (@servers) { + croak "server $server is not a hash reference" unless ref $server eq 'HASH'; + croak "server has no 'host' field" unless exists $$server{host}; + croak "server has no 'port' field" unless exists $$server{port}; + $$server{pingtimes} = []; # we will average these results together + $$self{not_started}{$servid++} = $server; + } + return bless($self, $package); +} + + +=head1 METHODS + +These methods define the public API for instances of this class. + +=head2 found + +Returns a list of 0 or more servers found. Each return value is a hash +reference, containing the following keys: + + host: the IP address of the server + port: the TCP port of the server + pingtimes: array reference, contains the actual result times of 4 pings + ping: the average roundtrip latency of the server, in ms + freenicks: the list of players connected + freegames: the list of open games (not yet started) + free: the number of idle clients connected to this server + games: the number of clients connected to this server, who are playing games + playing: the list of players in games + geolocs: the geolocations of players in games + name: the self-proclaimed "name" reported by the server + language: the preferred language reported by the server + +=cut + +sub found { + my $self = shift; + return values %{$$self{complete}}; +} + +=head2 pending + +Returns non-zero if we are still waiting for a response from one or more +servers; returns 0 if processing is complete. + +=cut + +sub pending { + my $self = shift; + return scalar(keys %{$$self{pending}}) + + scalar(keys %{$$self{not_started}}); +} + +=head2 work(seconds) + +Enters the main loop of this module. This method requires one argument, a +numeric count of seconds to work for. This is expected to be a floating point +decimal, for sub-second precision. Returns the number of servers pending, just +like the B method does. + +=cut + +sub work { + my ($self, $timeout) = @_; + my $starttime = [gettimeofday]; + # run through it once quickly, even if $timeout is 0. + do { + # try connect if not_started servers exist, and timestamp says its time + $self->try_connect() + if(scalar(keys %{$$self{not_started}}) + && tv_interval($$self{begin_time}) >= $time_between_connections); + + # do a select, to see who has connected, and who has sent data to us + my $select = IO::Select->new(); + $select->add( map { $$_{sock} } (values %{$$self{pending}})); + my $thistime = $timeout - tv_interval($starttime); + $thistime = 0 if $thistime < 0; + my @ready = $select->can_read($thistime); + foreach my $sock (@ready) { + # the revmapping table maps stringified sockets to hash keys, so + # we don't have to do a search for it. + my $key = $$self{revmapping}{"$sock"}; + $self->server_sm($key); + } + my @dead = $select->has_exception(0); + foreach my $sock (@dead) { + my $key = $$self{revmapping}{"$sock"}; + $self->give_up_on($key); + } + } while(tv_interval($starttime) < $timeout); + return $self->pending(); +} + +=head1 INTERNAL METHODS + +These methods are only meant to be called from within the module. They are +subject to change without notice. + +=head2 try_connect + +Attempts to connect to a server. Moves the first "not_started" server to the +"pending" list, and creates a non-blocking IO::Socket::INET object for it. +Updates the begin_time timestamp, to determine when the next server should be +connected. + +=cut + +sub try_connect { + my $self = shift; + my @newkeys = sort keys %{$$self{not_started}}; + croak "try_connect called, but everything is already connected!" + unless scalar @newkeys; + # just pull the first entry off the list + my $key = shift(@newkeys); + # move server entry from not_started hash to pending hash + my $ref = $$self{not_started}{$key}; + $$self{pending}{$key} = $ref; + delete($$self{not_started}{$key}); + my $sock = IO::Socket::INET->new( + PeerAddr => $$ref{host}, + PeerPort => $$ref{port}, + Proto => 'tcp', + Blocking => 0, + ); + if(defined($sock)) { + $$ref{sock} = $sock; + $$self{revmapping}{"$sock"} = $key; + $$self{begin_time} = [gettimeofday]; + } else { + $self->give_up_on($key); + } +} + +=head2 server_sm(connection_number) + +Implements a simple state machine. Called with an index into the pending +array, to indicate that data is available for reading from this server. + +=cut + +sub server_sm { + my ($self, $connid) = @_; + my $conn = $$self{pending}{$connid}; + if(!defined($$conn{state})) { + # new connection! + $$conn{state} = 'connected'; + $$conn{rxdata} = ''; + return; # the first "PUSH" line might not arrive at the same moment as + # the connection. When it comes in, we'll will come back here. + } else { + # read some data. + my $newdata = ''; + my $sock = $$conn{sock}; + $sock->recv($newdata, 1024, 0); + $$conn{rxdata} .= $newdata; + } + + my $index; + while(($index = index($$conn{rxdata}, "\n")) > -1) { + my $str = substr($$conn{rxdata}, 0, $index); + $$conn{rxdata} = substr($$conn{rxdata}, $index+1); + + # strip off the protocol header. + if(substr($str, 0, length($proto_hdr)+1) eq "$proto_hdr ") { + $str = substr($str, length($proto_hdr) + 1); + } else { + # protocol mismatch, give up. + $self->give_up_on($connid); + } + + if ($str =~ /^PUSH: SERVER_READY (.*) (.*)/) { + $$conn{name} = $1; + $$conn{language} = $2; + $$conn{sock}->send("$proto_hdr PING\n"); + $$conn{ping_time} = [gettimeofday]; + } elsif($str =~ /^PING: PONG/) { + # nothing to parse. take a time measurement, send another one if + # necessary. + my $reply_time = tv_interval($$conn{ping_time}); + push(@{$$conn{pingtimes}}, tv_interval($$conn{ping_time})); + if(scalar @{$$conn{pingtimes}} >= $number_of_pings) { + $$conn{sock}->send("$proto_hdr LIST\n"); + delete($$conn{ping_time}); + } else { + $$conn{sock}->send("$proto_hdr PING\n"); + $$conn{ping_time} = [gettimeofday]; + } + } elsif($str =~ /LIST: (\S*) (\S*) free:(\d+) games:(\d+) playing:(\d+) at:(\S*)/) { + $$conn{freenicks} = $1; + $$conn{freegames} = $2; + $$conn{free} = $3; + $$conn{games} = $4; + $$conn{playing} = $5; + $$conn{geolocs} = $6; + # we're done, get out of here. + # move connection to "complete" list + delete($$self{pending}{$connid}); + $$self{complete}{$connid} = $conn; + # clean up temporary stuff + delete($$conn{state}); + delete($$conn{rxdata}); + # disconnect from server + delete($$conn{sock}); + # calculate average ping time from worst 2 pings + my @pingtimes = reverse sort @{$$conn{pingtimes}}; + $pingtimes[0] += $pingtimes[1]; + $$conn{ping} = $pingtimes[0] / 2; + $$conn{ping} = sprintf("%.1f", $$conn{ping} * 1000); # time in ms + return; + } else { + # drop the line, for now + } + } +} + +=head2 give_up_on(connection_number) + +Called if B