use strict;
use warnings;
use Socket;

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 ($);

my $port = 9999;
my $log_connections = 1;
# Want to log if script is executed when it's already running?
my $log_is_running = 1;

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),
                                    )
);
$log->warning("Logging Started");

###
### Fork and background daemon process
###
startDaemon();

###
### 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; };


###
### As long as the daemon is running, listen for and handle received c
+onnections
###
while ($running) {
    ###
    ### 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");

    ###
    ### HANDLE CONNECTIONS
    ###
    while ( my $clientAddr = accept( CONNSOCK, LISTENSOCK ) )
    {
        my ( $clientPort, $clientIp ) = sockaddr_in( $clientAddr );
        my $clientIpStr = inet_ntoa( $clientIp );
        
        local $/ = $NULLBYTE;

        my $request = <CONNSOCK>;
        chomp $request;

        if ( $request eq '<policy-file-request/>' )
        {
            $log->warning("XML Policy file request from: $clientIpStr"
+) if ($log_connections);
            print CONNSOCK $content.$NULLBYTE;
            close CONNSOCK;
        }
        else
        {
            $log->warning("Connection from: $clientIpStr") if ($log_co
+nnections);
            print CONNSOCK "<data><ip>$clientIpStr</ip></data>".$NULLB
+YTE;
            close CONNSOCK;
            next;
        }
    }
}

###
### Mark a clean exit in the log
###
$log->warning("Logging Stopped");

###
### startDaemon
###
sub startDaemon {
    defined(my $pid = fork) or dienice("Can't fork: $!");
    exit if $pid;
    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", v
+erify => "1") )
    {
        $log->warning("Daemon Already Running!") if ($log_is_running);
        exit(0);
    }
}

###
### 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];
}
[download]