|
Re^2: Trying to thread a daemon with threads and Thread::Queue
by jasmineaura (Initiate) on Aug 27, 2008 at 17:56 UTC
|
That's exactly what I was trying to do: use a pool of pre-existing threads.
What I was hoping to achieve is to accept more than one connection at a time, as this script currently only handles one connection at a time.
I am planning on releasing this as part of a open source project, and as some people who might run this script (as part of the implementation) might have high traffic, this may not be very desirable, I think.
For example, simulating 100 connections from the bash shell locally on the server:
time for i in `seq 1 100`; do
perl -e 'printf "<policy-file-request/>%c",0' | nc myhost.com 9999
perl -e 'printf ">%c",0' | nc myhost.com 9999; done
takes 1.990 seconds
And I believe if I was to have say a pool of 3 threads (on a dual-processor server), I could easily handle 100 client connections per second
I extended the script quite a bit from a sample script offered by someone at Adobe, who also made another standalone script in python that supports more then one user connection (both scripts in the standalone folder of the sample scripts zip file at the head of the page):
http://www.adobe.com/devnet/flashplayer/articles/socket_policy_files.html
And I was hoping to extend it a bit more to thread just like the sample python script does, as to offer different variations (threaded or non-threaded perl scripts, python, java)
So, briefly, this is what I was trying to do (iirc):
$listeners = 3;
my $Q = Thread::Queue->new;
while ($running) {
# Spawn listener threads
for (1..$listeners) {
threads->create(\&handleData)->detach;
}
# BEGIN LISTENING
socket( LISTENSOCK, PF_INET, SOCK_STREAM, getprotobyname( 'tcp' )
+) or dienice("socket() error: $!");
setsockopt( LISTENSOCK, SOL_SOCKET, SO_REUSEADDR, pack( 'l', 1 ) )
+ or dienice("setsockopt() error: $!");
bind( LISTENSOCK, sockaddr_in( $port, INADDR_ANY ) ) or dienice("b
+ind() error: $!");
listen( LISTENSOCK, SOMAXCONN ) or dienice("listen() error: $!");
$log->warning("Listening on port $port");
while ( my $clientAddr = accept( CONNSOCK, LISTENSOCK ) ) {
# put the connection on the queue
$Q->enqueue(fileno(CONNSOCK), $clientAddr );
}
}
sub handleData {
my $tid = threads->tid();
while (1) {
my ($fno, $clientAddr) = $Q->dequeue(2);
next if $fno eq 'STOP';
my ( $clientPort, $clientIp ) = sockaddr_in( $clientAddr );
my $ipStr = inet_ntoa( $clientIp );
open my $socket, '+<&=' . $fno;
while (my $request = <$socket>)
{
chomp $request;
if ($request eq '<policy-file-request/>')
{
$log->warning("($tid) : XML Policy file request from:
+$ipStr");
print $socket $content.$NULLBYTE;
close $socket;
} else
{
$log->warning("($tid) : Connection from: $ipStr");
print $socket "<data><ip>$ipStr</ip></data>".$NULLBYTE
+;
close $socket;
}
};
#close $socket;
}
return 1;
}
Then I run it, and simulate 2 connections (the handshake) from command-line shell like so:
perl -e 'printf "<policy-file-request/>%c",0' | nc myhost.com 9999 ; perl -e 'printf "%c",0' | nc myhost.com 9999
And it just hangs, instead of returning back to the shell. So I hit CTRL+C, then on the server log I see this show right after I CTRL+C'ed on the client connect simulation command:
August 27 10:33:44 xmlsockd[1722]: (1) : Connection from: x.x.x.x
And the server dies with no error/log messages :(
What am I doing wrong?
| [reply]
[d/l]
[select] |
|
|
What am I doing wrong?
Your using the "new" version of Thread::Queue which used to be a simple, reliable and fast module, but now someone has taken it upon theselves to "enhance" it, and in the process they have fu**ed up the single most useful, most reliable threading module.
Is there any process for banning people from messing with things that work?
Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
"Science is about questioning the status quo. Questioning authority".
In the absence of evidence, opinion is indistinguishable from prejudice.
| [reply] |
|
|
OH DARN!!! I was hoping I was doing something wrong :(
That might explain all the "failed to dup 'weird symbols'" i was getting in the log (while i was using another version of my script during trial and error) when i had a dienice("$_") message after:
open my $socket, '+<&=' . $fno;
Is there any workaround? alternate solution/module to use?
I can't force everyone who uses my script to downgrade to an older version of Thread::Queue just to get it to work :(
Might want to try threads::shared perhaps ?
| [reply] |
|
|
sub handleData {
my $tid = threads->tid();
my $fno = $Q->dequeue();
my $clientAddr = $Q->dequeue();
next if $fno eq 'STOP';
my ( $clientPort, $clientIp ) = sockaddr_in( $clientAddr );
my $ipStr = inet_ntoa( $clientIp );
open my $socket, '+<&=' . $fno or die $!;
my $request = <$socket>;
chomp $request;
if ($request eq '<policy-file-request/>') {
warn("($tid) : XML Policy file request from: $ipStr");
print $socket $content.$NULLBYTE;
}
else {
warn("($tid) : Connection from: $ipStr");
print $socket "<data><ip>$ipStr</ip></data>".$NULLBYTE;
}
shutdown $socket, 2;
close $socket;
return 1;
}
I don't anticipate that it will perform better than your non-threaded solution for teh reasons I stated above. Create a new thread to reply with a single line of code is never going to be quicker than replying inline, but it might just work well enough to allow you to see that for yourself.
For the application as you've posted, I am quite certain that you will not improve your performance using threads this way.
You'd almost certainly be better off using IO::Socket::INET and setting the Listener option to allow the tcpip stack to queue inbound requests.
Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
"Science is about questioning the status quo. Questioning authority".
In the absence of evidence, opinion is indistinguishable from prejudice.
| [reply]
[d/l]
[select] |
|
|
BrowserUK, an older post of yours on the subject (from 2006) enlightened me, and I was able to find out what the problem was and got a little progress. Thank you so much..
Re^5: multithreaded tcp listener with IO::Socket
You mentioned: "The main problem with this approach is that you have to ensure that the socket returned by accept() does not go out of scope (causing the socket to be closed), before the thread has had chance to reopen it. That's easily achieved by pushing a copy of the socket handle into a (non-shared) array in the accept thread, as well as queueing it."
So I went ahead and took a look at your sample code (threads::Server) from the next reply on that same thread, here:
Re^7: multithreaded tcp listener with IO::Socket
I realized you're using an associative array (hash) in the main accept thread to store the main handle and keep the socket open, and also using a seperate queue (Qclean) in another routine ( while($Qclean->pending) ) to close the socket once the thread is done with it, iiuc..
Only problem is that the "close delete $hash{$fno}" line didn't work for me, leaving the connection on the client side open, so instead I tried:
close $hash{ $fno };
delete $hash{ $fno };
And that worked, the request went through. But... The process just mysteriously died!!! No errors, no warnings in the log, nothing!
I tried taking out the line "shutdown $socket, 2;" from the end of the handleConnection() sub, and reran it, then the process doesn't die for each request, but also the client still doesn't close :(
Removed the line "shutdown $socket, 2;" from the sub, and added "shutdown $sockets{ $fileno }, 2;" right before the "close $sockets{ $fileno };" line in the main accept thread, then the process doesn't die after a request, but also leaves the client open :| I'm puzzled...
Any ideas on this one?
Below is my full code (revised and cleaned of some minor bugs).
#!/usr/bin/perl -w
use strict;
use warnings;
use IO::Socket;
use threads;
use Thread::Queue;
use POSIX qw(setsid);
use Proc::PID::File;
use Log::Dispatch;
use Log::Dispatch::File;
use Date::Format;
use File::Spec;
use FindBin qw($Bin);
sub dienice ($);
###
### Change default configuration here if needed
###
# Our server port (Any number between 1024 and 65535)
my $port = 9999;
my $timeout = 60;
# Number of listener threads to spawn
# (2 or 3 threads are sufficient to handle 100 concurrent connections
+since our duty cycle is a few milliseconds)
my $listeners = 3;
# Want to log connections? 1 = yes, 0 = no
my $log_connections = 1;
# Want to log if script is executed when it's already running?
# (You might want to set it to 0 if you run periodically from cron - t
+oo redundant)
my $log_is_running = 1;
#
# Do not change the following unless you know what you're doing!!!
#
my $content = '<?xml version="1.0"?><cross-domain-policy><allow-access
+-from domain="*" to-ports="' . $port . '" /></cross-domain-policy>';
my $NULLBYTE = pack( 'c', 0 );
###
### Detect our base directory where we create the log and pid files
###
our $BASE_DIR = $Bin;
# Get script name, chop off any preceding path it was called with and
+chop off its extension (ex: 'some/dir/script.pl' becomes 'script')
our $ME = $0; $ME =~ s|.*/||; $ME =~ s|\..*||;
our $LOG_FILE = "$ME.log";
###
### Setup a logging agent
###
my $log = new Log::Dispatch(
callbacks => sub { my %h=@_; return Date::Format::time2str('%B %e
+%T', time)." $ME\[$$]: ".$h{message}."\n"; }
);
$log->add( Log::Dispatch::File->new( name => 'file1',
min_level => 'warning',
mode => 'append',
filename => File::Spec->catfil
+e($BASE_DIR, $LOG_FILE),
)
);
###
### Fork and background daemon process
###
startDaemon();
$log->warning("Logging Started");
###
### Setup signal handlers to give us time to cleanup (and log) before
+shutting down
###
my $running = 1;
$SIG{HUP} = sub { $log->warning("Caught SIGHUP: exiting gracefully")
+; $running = 0; };
$SIG{INT} = sub { $log->warning("Caught SIGINT: exiting gracefully")
+; $running = 0; };
$SIG{QUIT} = sub { $log->warning("Caught SIGQUIT: exiting gracefully"
+); $running = 0; };
$SIG{TERM} = sub { $log->warning("Caught SIGTERM: exiting gracefully"
+); $running = 0; };
my $Q = Thread::Queue->new;
my $Qclean = Thread::Queue->new;
###
### As long as the daemon is running, listen for and handle received c
+onnections
###
while ($running) {
###
### Spawn our listener threads and detach them since we don't want
+ return values and don't to wait for them to finish
### "detach" also allows automatic cleanup of the thread and recyc
+les its memory
###
for (1..$listeners) {
threads->create(\&handleConnection)->detach;
}
###
### BEGIN LISTENING
###
my $sock = new IO::Socket::INET(
LocalPort => $port,
Proto => 'tcp',
Listen => SOMAXCONN,
ReuseAddr => 1);
$sock or dienice("Socket error :$!");
$log->warning("Listening on port $port");
###
### Handle connections
###
my %sockets = ();
while ( my ($new_sock, $clientAddr) = $sock->accept() )
{
my ( $clientPort, $clientIp ) = sockaddr_in( $clientAddr );
# put the connection on the queue for a reader thread
my $fno = fileno($new_sock);
$sockets{ $fno } = $new_sock;
$Q->enqueue( "$fno\0$clientIp" );
while( $Qclean->pending )
{
my $fileno = $Qclean->dequeue();
close $sockets{ $fileno };
delete $sockets{ $fileno };
}
}
}
###
### Mark a clean exit in the log
###
$log->warning("Logging Stopped");
###
### startDaemon
###
sub startDaemon {
# fork a child process and have the parent process exit to disasso
+ciate the process from controlling terminal or login shell
defined(my $pid = fork) or dienice("Can't fork: $!");
exit if $pid;
# setsid turns the process into a session and group leader to ensu
+re our process doesn't have a controlling terminal
POSIX::setsid() or dienice("Can't start a new session: $!");
# Get a PID file - or exit without error in case we're running per
+iodically from cron
# if ( Proc::PID::File->running(dir => "$BASE_DIR", name => "$ME",
+verify => "1") )
# {
# $log->warning("Daemon Already Running!") if ($log_is_running)
+;
# exit(0);
# }
}
###
### handleConnection
###
sub handleConnection {
my $tid = threads->tid();
$log->warning("Thread ($tid) started");
while ( my $work = $Q->dequeue() )
{
my ( $fno, $clientIp ) = split ( chr(0), $work );
my $clientIpStr = inet_ntoa( $clientIp );
local $/ = $NULLBYTE;
open my $socket, '+<&='.$fno or dienice("Thread ($tid) could n
+ot reopen socket: $!");
my $request;
if ( defined ( $request = <$socket> ) )
{
chomp $request;
if ( $request eq '<policy-file-request/>' )
{
$log->warning("($tid) : XML Policy file request from:
+$clientIpStr") if ($log_connections);
print $socket $content.$NULLBYTE;
}
elsif ( $request =~ /<request>getmyip<\/request>/ )
{
$log->warning("($tid) : XML IP request from: $clientIp
+Str") if ($log_connections);
print $socket "<data><ip>$clientIpStr</ip></data>".$NU
+LLBYTE;
}
else
{
$log->warning("($tid) : Ignoring unrecognized request
+from: $clientIpStr") if ($log_connections);
}
}
else
{
$log->warning("($tid) : Ignoring NULL connection from: $cl
+ientIpStr") if ($log_connections);
}
shutdown $socket, 2;
close $socket;
$Qclean->enqueue( $fno );
}
return 1;
}
###
### dienice
###
sub dienice ($) {
my ($package, $filename, $line) = caller;
# write die messages to the log before die'ing
$log->critical("$_[0] at line $line in $filename");
die $_[0];
}
| [reply]
[d/l]
[select] |
|
|
|
|
|
|
Hmm. Have you managed to track down what code is executing when that silent abnormal termination occurs?
Yep, with some extra logging..
First, I added this in main to prevent the abend:
$SIG{PIPE} = sub { $log->warning("Caught SIGPIPE: $!"); $running = 1;
+ };
Then added this in the handler thread:
$log->warning("In thread: Attempting to shutdown handle associ
+ated with fileno: $fno");
shutdown ($socket, 2) or $log->warning ("In thread: Shutdown e
+rror: $!");
$log->warning("In thread: Attempting to close handle associate
+d with fileno: $fno");
close $socket or $log->warning ("In thread: close error: $!");
$log->warning("In thread: Enqueing in Qclean fileno: $fno");
$Qclean->enqueue( $fno );
I simulate a connection from client:
$ perl -e 'printf "<request>getmyip</request>%c",0' | ./nc myhost.com
+9999
The connection is immediately closed as desired, but I get nothing back from the server for my request, when --according to the code in the thread-- I should be getting this back:
<data><ip>x.x.x.x</ip></data>
The output in the log:
August 29 09:12:44 xmlsockd-advanced[32652]: (1) : XML IP request from
+: x.x.x.x
August 29 09:12:44 xmlsockdx[32652]: In thread: Attempting to shutdown
+ handle associated with fileno: 5
August 29 09:12:44 xmlsockdx[32652]: In thread: Attempting to close ha
+ndle associated with fileno: 5
August 29 09:12:44 xmlsockdx[32652]: Caught SIGPIPE: Broken pipe
August 29 09:12:44 xmlsockdx[32652]: In thread: close error: Broken pi
+pe
Caused by the close() call after shutdown() in the handler thread (the code you previously suggested), not the close() in Main!
I go ahead and remove the close() call in the handler thread keeping only the shutdown() call, so it will look like this:
$log->warning("In thread: Attempting to shutdown handle associated wit
+h fileno: $fno");
shutdown ($socket, 2) or $log->warning ("In thread: shutdown error: $!
+");
$log->warning("In thread: Enqueing in Qclean fileno: $fno");
$Qclean->enqueue( $fno );
And in the main accept() loop I also remove the close() call, so it will look like this:
while ( $Qclean->pending )
{
my $fileno = $Qclean->dequeue();
delete $sockets{ $fileno };
}
Again, I simulate another connection from client via shell:
$ perl -e 'printf "<policy-file-request/>%c",0' | ./nc myhost.com 9999
I should've got this response:
<?xml version="1.0"?><cross-domain-policy><allow-access-from domain="*
+" to-ports="9999" /></cross-domain-policy>
But again, the connection is immediately closed on the client side before they even receive a response to their request as coded for in the handler thread..
This is very bad!
Now the log shows:
August 29 09:26:31 xmlsockd[7815]: (1) : XML IP request from: x.x.x.x
August 29 09:26:31 xmlsockd[7815]: In thread: Attempting to shutdown h
+andle associated with fileno: 5
August 29 09:26:31 xmlsockd[7815]: In thread: Enqueing in Qclean filen
+o: 5
August 29 09:26:31 xmlsockd[7815]: Caught SIGPIPE: Broken pipe
Probably as I said previously, having the shutdown on the dup handle in the thread causes SIGPIPE to be thrown because the main handle is still open in the main accept() thread. And for whatever reason (which I am unaware of), whatever the handler thread wrote back on the socket prior to the shutdown is lost and is not sent to the client. Hmmm???
However, if I _remove_ the shutdown() call from the handler thread (keeping only the "close $socket" line), the client's request gets back the proper response, only it doesn't get immediately closed (until another connection comes in as we previously established)
In my tests (under win32), if I dont use shutdown in the hendler thread, the client connection stays open until the main thread gets around to closing its copy of the socket.
Did you actually get a response back for your request when you have shutdown() in the handler thread?
Are you ignoring SIGPIPE?
Maybe Win32 doesn't blow up with SIGPIPE when a handle is closed somewhere in the code while it's still open elsewhere?
Still, it certainly does on *nix according to my testing...
| [reply]
[d/l]
[select] |
|
|
|
|
tried the handleData() sub you suggested. Exhibits teh same exact problem as the one I described above... It was probably one of the very first versions I tried of that sub :/
The socket doesn't receive anything, hangs, until on the client connect side I CTRL+C, then the server log would show just one log message "(3) : Connection from: x.x.x.x", and the server immediately dies with no errors/warnings right after.
I will try IO::Socket, it's something I've been meaning to do.. Perhaps two different variations, one script as you describe, and another with threads and threads::shared, kind of like the 4th point discussed on this thread:
Re: Passing an IO:Handle to a Thread
My main concern behind the limitation of handling one connection at a time is the possibility of a really slow (or dysfunctional) client that takes too long to send its request (or doesn't send a request at all) after it connects to the server, making all other incoming connections queued as long as the connected (slow/dysfunctional) client has not timed out.
| [reply] |
|
|
|
|
|
|
In an attempt to trace the problem, I modified my code a bit for the sub handleData()
Here is the relative lines from the sub:
my $tid = threads->tid();
my $fno = $Q->dequeue();
last if $fno eq 'STOP';
$log->warning("Thread ($tid) : fileno: $fno");
open my $socket, '+<&='.$fno or dienice("Thread ($tid) could not reope
+n socket: $!");
When I try to connect from client side, I see this in the server log:
Thread (1) : fileno: 5
Thread (1) could not reopen socket: Bad file descriptor at line 152
Which is the "open my $socket, '+<&='.$fno" Line..
If I try connecting again, the fileno is still 5, only the thread number changes (1..3 when running only 3 listener threads) and each thread is "terminated abnormally" due to this error.
Other instance, I get this in the log (both lines returned on one connection only)
Thread (2) : fileno: ÆD²©ê
Thread (3) : fileno: 5
Or this:
Thread (1) : fileno: 5
Thread (2) : fileno: ÆýD²©ê
And the client gets nothing back to its request.
Running:
Perl 5.8.5 and Thread::Queue 2.11
OS: Linux | [reply]
[d/l]
[select] |
|
|
|
|
shutdown $socket, 2;
From: perldoc on shutdown()
"It's also a more insistent form of close because it also disables the file descriptor in any forked copies in other processes."
The thread tries to force closing the socket using shutdown() (after the thread is done with the connection) while the main accept thread still has it open, causing the script to abnormally terminate without any errors messages.
Removing this line from the handleConnection() sub and keeping only "close socket;", re-running the script, then simulating a client connection and request returns the expected data, but the client sees the connection still open (because the socket wasn't closed from server)
This is due to the construct of the main accept thread:
while ( my ($new_sock, $clientAddr) = $sock->accept() )
{
my ( $clientPort, $clientIp ) = sockaddr_in( $clientAddr );
# put the connection on the queue for a reader thread
my $fno = fileno($new_sock);
$sockets{ $fno } = $new_sock;
$Q->enqueue( "$fno\0$clientIp" );
while ( $Qclean->pending )
{
my $fileno = $Qclean->dequeue();
$log->warning("Attempting to close handle associated with file
+no: $fileno");
close $sockets{ $fileno };
delete $sockets{ $fileno };
}
}
Basically the while ( $Qclean->pending ) is not immediately triggerd (to close the socket in the main accept thread) because it is inside the while ( ... $sock->accept() ), and won't happen until another client connects, so the first client will just hang because it sees the socket on the server is still open.
In other words, client-A connects and sends request, gets response, but the server doesn't close the socket, so the client stays connected even though the server is done sending.
Then when client-B connects, Qclean is checked and sees the socket associated with client-A needs to be closed, so it goes ahead and closes it.
I'm stumped... Any thoughts/ideas on how to fix this?
Update:
I tried adding this early in my script:
SIG{PIPE}='IGNORE';
After re-adding the shutdown() line before close() in the handleConnection() sub to avoid the script blowing up because of SIGPIPE:
shutdown $socket, 2;
close $socket;
But then the client doesn't get the response (what is written on the socket by the server thread from the handleConnection() sub), just a connection drop :S
| [reply]
[d/l]
[select] |
|
|
|
|
Meh, I just went with a totally different route..
1. Setting up IO::Socket::INET in main, and passing the $main_sock to a pool on pre-forked threads which all handle the accept()
2. Multiplexing with IO::Select in each thread to avoid the blocking nature of the accept() call. This provides us the advantage to pickup the faster client (the one who's able to send the request faster) and avoid a lazy client who takes their sweet time before they send their request (in the case of simultaneous connections/bursts)
I mentioned previously that I simulated a pair of sequential connections a 100 times with the non-threaded/non-select script which took about 1.990 seconds.
Doing the same simulation test on the new version of the script (a pre-forked pool of 3 threads and using the select method in each thread) took about 2.063 seconds.
Therefore, IMHO, the overhead is very minimal, and quite a fair trade off for having the ability to handle multiple clients simultaneously.
Only if I am wasn't so tired now, I would've quickly coded a script using threads to simulate maybe 20 or 30 simultaneous (asynchronous) connections a few times in a row and compare the results of the two versions of the script, even though I'm sure the threaded/non-blocking version would be way faster.
Here's my new threaded version of the script. Comments/Suggestions welcome..
#!/usr/bin/perl -w
use strict;
use warnings;
use IO::Socket;
use IO::Select;
use threads;
use POSIX qw(setsid);
use Proc::PID::File;
use Log::Dispatch;
use Log::Dispatch::File;
use Date::Format;
use File::Spec;
use FindBin qw($Bin);
sub dienice ($);
###
### Change default configuration here if needed
###
# Our server port (Any number between 1024 and 65535)
my $port = 9999;
# Number of listener threads to spawn
# (2 or 3 threads are sufficient to handle 100 concurrent connections
+since our duty cycle is a few milliseconds)
my $listeners = 3;
# Want to log connections? 1 = yes, 0 = no
my $log_connections = 1;
# Want to log if script is executed when it's already running?
# (You might want to set it to 0 if you run periodically from cron - t
+oo redundant)
my $log_is_running = 1;
#
# Do not change the following unless you know what you're doing!!!
#
my $content = '<?xml version="1.0"?><cross-domain-policy><allow-access
+-from domain="*" to-ports="' . $port . '" /></cross-domain-policy>';
my $NULLBYTE = pack( 'c', 0 );
###
### Detect our base directory where we create the log and pid files
###
our $BASE_DIR = $Bin;
# Get script name, chop off any preceding path it was called with and
+chop off its extension (ex: 'some/dir/script.pl' becomes 'script')
our $ME = $0; $ME =~ s|.*/||; $ME =~ s|\..*||;
our $LOG_FILE = "$ME.log";
###
### Setup a logging agent
###
my $log = new Log::Dispatch(
callbacks => sub { my %h=@_; return Date::Format::time2str('%B %e
+%T', time)." $ME\[$$]: ".$h{message}."\n"; }
);
$log->add( Log::Dispatch::File->new( name => 'file1',
min_level => 'warning',
mode => 'append',
filename => File::Spec->catfil
+e($BASE_DIR, $LOG_FILE),
)
);
###
### Fork and background daemon process
###
startDaemon();
$log->warning("Logging Started");
###
### Setup signal handlers to give us time to cleanup (and log) before
+shutting down
###
my $running = 1;
$SIG{HUP} = sub { $log->warning("Caught SIGHUP: exiting gracefully")
+; $running = 0; };
$SIG{INT} = sub { $log->warning("Caught SIGINT: exiting gracefully")
+; $running = 0; };
$SIG{QUIT} = sub { $log->warning("Caught SIGQUIT: exiting gracefully"
+); $running = 0; };
$SIG{TERM} = sub { $log->warning("Caught SIGTERM: exiting gracefully"
+); $running = 0; };
$SIG{PIPE} = sub { $log->warning("Caught SIGPIPE (Ignoring): $!"); $r
+unning = 1; };
if ( $running == 1 )
{
###
### BEGIN LISTENING
###
my $main_sock = new IO::Socket::INET(
LocalPort => $port,
Proto => 'tcp',
Listen => SOMAXCONN,
ReuseAddr => 1);
$main_sock or dienice("Socket error :$!");
$log->warning("Listening on port $port");
###
### Spawn our listener threads and detach them since we don't want
+ return values and don't to wait for them to finish
### "detach" also allows automatic cleanup of the thread and recyc
+les its memory
###
for (1..$listeners) {
threads->create(\&handleConnection, $main_sock)->detach;
}
while ($running)
{
# Keep running
}
}
###
### Mark a clean exit in the log
###
$log->warning("Logging Stopped");
###
### startDaemon
###
sub startDaemon {
# fork a child process and have the parent process exit to disasso
+ciate the process from controlling terminal or login shell
defined(my $pid = fork) or dienice("Can't fork: $!");
exit if $pid;
# setsid turns the process into a session and group leader to ensu
+re our process doesn't have a controlling terminal
POSIX::setsid() or dienice("Can't start a new session: $!");
# Get a PID file - or exit without error in case we're running per
+iodically from cron
# if ( Proc::PID::File->running(dir => "$BASE_DIR", name => "$ME",
+verify => "1") )
# {
# $log->warning("Daemon Already Running!") if ($log_is_running)
+;
# exit(0);
# }
}
###
### handleConnection
###
sub handleConnection {
my $main_sock = shift;
my $tid = threads->tid();
$log->warning("Thread ($tid) started");
# Multiplexing Using select (See: http://www.unix.com.ua/orelly/pe
+rl/advprog/ch12_03.htm)
my $s = new IO::Select( $main_sock );
my ($new_sock, $sock, $fno, $clientAddr, $clientPort, $clientIp, $
+clientIpStr, $request);
my %clients = ();
my @ready = ();
while ( @ready = $s->can_read )
{
foreach $new_sock (@ready)
{
if ($new_sock == $main_sock)
{
($sock, $clientAddr) = $main_sock->accept;
( $clientPort, $clientIp ) = sockaddr_in( $clientAddr
+);
$clientIpStr = inet_ntoa( $clientIp );
$fno = fileno($sock);
$clients{ $fno } = $clientIpStr;
$s->add($sock);
} else {
$fno = fileno($new_sock);
$clientIpStr = $clients{ $fno };
delete $clients{ $fno };
local $/ = $NULLBYTE;
if ( defined ( $request = <$new_sock> ) )
{
chomp $request;
if ( $request eq '<policy-file-request/>' )
{
$log->warning("($tid) : XML Policy file reques
+t from: $clientIpStr") if ($log_connections);
print $new_sock $content.$NULLBYTE;
} elsif ( $request =~ /<request>getmyip<\/request>
+/ ) {
$log->warning("($tid) : XML IP request from: $
+clientIpStr") if ($log_connections);
print $new_sock "<data><ip>$clientIpStr</ip></
+data>".$NULLBYTE;
} else {
$log->warning("($tid) : Ignoring unrecognized
+request from: $clientIpStr") if ($log_connections);
}
}
$s->remove($new_sock);
close $new_sock;
}
}
}
}
###
### dienice
###
sub dienice ($) {
my ($package, $filename, $line) = caller;
# write die messages to the log before die'ing
$log->critical("$_[0] at line $line in $filename");
die $_[0];
}
| [reply]
[d/l] |
|
|
|
|
|