root/gs2-extensions/tdb-edit/trunk/src/perllib/SocketsSwimmingThreadPoolClient.pm @ 25410

Revision 25410, 3.2 KB (checked in by jmt12, 7 years ago)

Adding a new infodbtype, tdbserver, to allow Greenstone to interact with a centralized TDBServer instance on systems that don't support multiple writers over NFS

Line 
1# @author Donnie Cameron (macnod)
2# @url    https://github.com/macnod/DcServer
3# @readme http://donnieknows.com/blog/perl-sockets-swimming-thread-pool
4
5package SocketsSwimmingThreadPoolClient;
6
7use IO::Socket;
8use Carp;
9use strict;
10use warnings;
11
12my $retry_time = 30;
13
14sub new
15{
16  # Params: host, port
17  my ($proto, %param)= @_;
18  my $class= ref($proto) || $proto;
19  bless +{%param} => $class;
20}
21
22sub stop_server
23{
24  shift->query('$self->stop')
25}
26
27sub open_socket
28{
29  my $self = shift @_;
30  # There is, unfortunately, a complication when using TCP sockets - that being
31  # the amount of time sockets linger after being closed. This TIME_WAIT period
32  # is required to ensure the terminating ACKs (kernel level) are recieved (in
33  # a graceful disconnect) and to allow time for 'wandering duplicates' to
34  # finally arrive. While there are (platform/OS/hardware) methods for getting
35  # rid of / shortening this grace period they aren't recommended (for both
36  # stability and security reasons).
37  # Thus you have the issue that, very occasionally and somewhat based upon the
38  # current turnover rate of TCP connections, you may exhaust the available
39  # pool of TCP sockets (as the rest are stuck waiting on TIME_WAIT timeouts).
40  # While the 'reuse' flag might lead you to expect the ability to 'reuse' the
41  # socket - there is one glaring caveat: you can't reuse the port from the
42  # same origin address as this would be a major security flaw. So in reality
43  # the reuse flag does nothing for us (which is why I removed it).
44  # Instead I am forced to put the socket connection in a loop and, if the
45  # first attempt to create the socket fails, wait around for SO_LINGER time
46  # in the hope that the TCP socket pool will have finally purged a number of
47  # the stranded TIME_WAIT connections.
48  # One last kick in the daddy-bags - the *default* SO_LINGER is set to 2*MSL
49  # (Maximum Segment Lifetime - the 'Time To Live of TCP' packets). This means
50  # (according to RFC793) we may be waiting up to 4 minutes for TIME_WAITs to
51  # be reaped. Sigh. Still - ever an optimist - I'll retry the socket
52  # connection every 30 seconds.
53  # References:
54  #   http://www.perlmonks.org/?node_id=771242
55  #   http://hea-www.harvard.edu/~fine/Tech/addrinuse.html
56  #   http://blog.port80software.com/2004/12/07/hurry-up-and-time_wait/
57  #   http://www.isi.edu/touch/pubs/infocomm99/infocomm99-web/
58  #   http://www.faqs.org/rfcs/rfc793.html
59  while(1)
60  {
61    my $socket= new IO::Socket::INET(PeerAddr => $self->{host} || 'localhost',
62                                     PeerPort => $self->{port} || 8190,
63                                     Proto => 'tcp');
64    if ($socket)
65    {
66      return $socket;
67    }
68    print "Failed to create client socket: $!\n";
69    print "=> Most likely cause - TCP ephemeral ports exhausted (stuck in TIME_WAITs)\n";
70    print "=> Retry in " . $retry_time . " seconds.\n";
71  }
72}
73
74sub query
75{
76  my ($self, $query)= @_;
77  my $socket = $self->open_socket();
78  croak "Fatal Error! $!\nDetails: " . $self->{'host'} . ":" . $self->{'port'} . "\n" unless $socket;
79  binmode($socket, ":utf8");
80  print $socket $query . "\n.\n";
81  my $buffer = '';
82  my $reply = '';
83  while($buffer = <$socket>)
84  {
85    $reply.= $buffer;
86    last if $reply =~ s/\n\.\n$//;
87  }
88  close($socket);
89  return $reply;
90}
91
921;
Note: See TracBrowser for help on using the browser.