close $hash{ $fno };
delete $hash{ $fno };

##</code><code>##

#!/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 - too 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->catfile($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 connections
###
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 recycles 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 disassociate 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 ensure 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 periodically 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 not 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: $clientIpStr") if ($log_connections);
				print $socket "<data><ip>$clientIpStr</ip></data>".$NULLBYTE;
			}
			else
			{
				$log->warning("($tid) : Ignoring unrecognized request from: $clientIpStr") if ($log_connections);
			}
		}
		else
		{
			$log->warning("($tid) : Ignoring NULL connection from: $clientIpStr") 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];
}