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