source: gs2-extensions/tdb-edit/trunk/src/perllib/SocketsSwimmingThreadPoolClient.pm@ 29316

# @author Donnie Cameron (macnod)
# @url    https://github.com/macnod/DcServer
# @readme http://donnieknows.com/blog/perl-sockets-swimming-thread-pool

package SocketsSwimmingThreadPoolClient;

use IO::Socket;
use Carp;
use strict;
use warnings;

my $retry_limit = 300; # five minute
my $retry_time = 1;

sub new
{
  # Params: host, port
  my ($proto, %param)= @_;
  my $class= ref($proto) || $proto;
  bless +{%param} => $class;
}

sub stop_server
{
  shift->query('$self->stop')
}

sub open_socket
{
  my $self = shift @_;
  # There is, unfortunately, a complication when using TCP sockets - that being
  # the amount of time sockets linger after being closed. This TIME_WAIT period
  # is required to ensure the terminating ACKs (kernel level) are recieved (in
  # a graceful disconnect) and to allow time for 'wandering duplicates' to
  # finally arrive. While there are (platform/OS/hardware) methods for getting
  # rid of / shortening this grace period they aren't recommended (for both
  # stability and security reasons).
  # Thus you have the issue that, very occasionally and somewhat based upon the
  # current turnover rate of TCP connections, you may exhaust the available
  # pool of TCP sockets (as the rest are stuck waiting on TIME_WAIT timeouts).
  # While the 'reuse' flag might lead you to expect the ability to 'reuse' the
  # socket - there is one glaring caveat: you can't reuse the port from the
  # same origin address as this would be a major security flaw. So in reality
  # the reuse flag does nothing for us (which is why I removed it).
  # Instead I am forced to put the socket connection in a loop and, if the
  # first attempt to create the socket fails, wait around for SO_LINGER time
  # in the hope that the TCP socket pool will have finally purged a number of
  # the stranded TIME_WAIT connections.
  # One last kick in the daddy-bags - the *default* SO_LINGER is set to 2*MSL
  # (Maximum Segment Lifetime - the 'Time To Live of TCP' packets). This means
  # (according to RFC793) we may be waiting up to 4 minutes for TIME_WAITs to
  # be reaped. Sigh. Still - ever an optimist - I'll retry the socket
  # connection every seconds.
  # References:
  #   http://www.perlmonks.org/?node_id=771242
  #   http://hea-www.harvard.edu/~fine/Tech/addrinuse.html
  #   http://blog.port80software.com/2004/12/07/hurry-up-and-time_wait/
  #   http://www.isi.edu/touch/pubs/infocomm99/infocomm99-web/
  #   http://www.faqs.org/rfcs/rfc793.html
  while($retry_limit > 0)
  {
    my $socket= new IO::Socket::INET(PeerAddr => $self->{host} || 'localhost',
                                     PeerPort => $self->{port} || 8190,
                                     Proto => 'tcp');
    if ($socket)
    {
      return $socket;
    }
    # if we are the very first caller, and a socket didn't get created, then
    # most likely the server is still starting up... wait a little longer
    # before complaining
    if ($self->{'firstcaller'})
    {
      print "* Still waiting...\n";
    }
    else
    {
      print "Failed to create client socket: $!\n";
      print "=> Most likely cause - TCP ephemeral ports exhausted (stuck in TIME_WAITs)\n";
      print "=> Retry in " . $retry_time . " seconds.\n";
      sleep($retry_time);
    }
    $retry_limit--;
  }
  print "Error! Failed to create client socket within 5 minutes timeout.\n";
}

sub query
{
  my ($self, $query)= @_;
  my $socket = $self->open_socket();
  croak "Fatal Error! $!\nDetails: " . $self->{'host'} . ":" . $self->{'port'} . "\n" unless $socket;
  binmode($socket, ":utf8");
  print $socket $query . "\n.\n";
  my $buffer = '';
  my $reply = '';
  while($buffer = <$socket>)
  {
    $reply.= $buffer;
    last if $reply =~ s/\n\.\n$//;
  }
  close($socket);
  return $reply;
}

1;