popufare/server/daemons/hello_daemon/hello_daemon.pl

#!/usr/bin/perl -Tw 
#
# Copyright (c) 2019 Clementine Computing LLC.
# 
# This file is part of PopuFare.
# 
# PopuFare is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
# 
# PopuFare is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Affero General Public License for more details.
# 
# You should have received a copy of the GNU Affero General Public License
# along with PopuFare.  If not, see <https://www.gnu.org/licenses/>.
#

require 5.002; 
use strict; 
use Socket; 
use Carp;
use FileHandle;
use Fcntl;

use POSIX;

my $bind_ip  	  = '127.0.0.1';
my $bind_port	  = 3556;

#----------------------------------------------Ugly exception handling logic using closures and anonymous functions----
#-------------------------------------------This is in there to deal with the fact that CreditCall uses the die("error")
#-------------------------------------------function instead of returning an error message in many cases...

#       This utility function returns the passed string sans any leading or trailing whitespace.
#
sub strip_whitespace
{
	my $str = shift;        #grab our first parameter
        
        $str =~ s/^\s+//;       #strip leading whitespace
        $str =~ s/\s+$//;       #strip trailing whitespace
                        
        return $str;            #return the improved string
}
                                

#    This function takes two coderef parameters, the second of which is usually an explicit call to the 
# 'catch' function which itself takes a coderef parameter.  This allows the code employing this suite of 
# functions to look somewhat like a conventional exception handling mechanism:
#
# try
# {
#    do_something_that_might_die();
# }
# catch
# {
#   my $errmsg = $_;
#   log_the_error_message($errmsg);
#   perform_some_cleanup();
# };
#
# DO NOT FORGET THAT LAST SEMICOLON, EVERYTHING GOES TO HELL IF YOU DO!
#   
sub try(&$)
{
	my ($attempt, $handler) = @_;
  
	eval
	{
		&$attempt;
	};
        
	if($@)
	{
		do_catch($handler);
	}
}

#    This function strips off the whitespace from the exception message reported by die()
# and places the result into the default variable such that the code in the catch block can
# just examine $_ to figure out what the cause of the error is, or to display or log
# the error message.
#
sub do_catch(&$)
{
	my ($handler) = @_;

	local $_ = strip_whitespace($@);
	
	&$handler;
}

#    This just takes an explicit coderef and returns it unharmed.  The only
# purpose of this is so the try/catch structure looks pretty and familiar.                                          
#
sub catch(&) {$_[0]}

#--------------------------------------------------------------------------------------------------------------------


#my $DebugMode = 1;
my $DebugMode = 0;

#	This function only executes the passed code reference if the global variable $DebugMode is non-zero.
# The reason for this is that any calculation (like a FooBar::ComplexObject->toString call) will not be
# performed if we are not in debug mode, sort of like a very limited form of lazy evaluation.
#
sub ifdebug(&@)
{
	my ($cmd) = @_;
	&$cmd() if($DebugMode);
}

sub handle_client() 
{
	close SERVER;
	CLIENT->autoflush(1);

	print CLIENT 'Hello.';
	
	close CLIENT;
}


my $waitedpid = 0; 
my $sigreceived = 0;


sub REAPER 
{ 
	while (($waitedpid = waitpid(-1, WNOHANG))>0) { }
	$SIG{CHLD} = \&REAPER; # loathe sysV 
	$sigreceived = 1;
} 


sub spawn
{ 
	my $coderef = shift; 						#grab the first parameter
	unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') 	#verify that it consists of a non-null block of executable perl code
	{ 
		confess "usage: spawn CODEREF"; 			#complain if this is not the case
	} 
	my $pid; 
	if (!defined($pid = fork)) 					#attempt a fork, remembering the returned PID value
	{
		close CLIENT;
		return; 						#failed to fork, we'd better close the client
	} 
	elsif ($pid) 							#If the returned process ID is non-zero, that indicates that we are the parent process
	{ 
		return; # i'm the parent 
	}  
	else								#otherwise, if the returned process ID is 0, that means we're the child process
	{
		exit &$coderef();					#in which case, we want to execute the child handler that was passed in, and then
									#exit this (child) process when we've finished our conversation(s) with the
									#other (client) end of the socket.
	}
} 

#----------------------------------------------------------------------
#   Local network settings for Inter-Process communication.
#----------------------------------------------------------------------
my $proto = getprotobyname('tcp'); 
my $addr = sockaddr_in( $bind_port ,inet_aton($bind_ip));;
#----------------------------------------------------------------------

my $max_retries = 10;		#Maximum number of address-binding retries before we give up.
my $retry_count = $max_retries;	#number of retries left...
my $retry_delay = 3;		#number of seconds to wait between retries at binding to our designated IPC address
my $got_network = 0;		#flag to let us know that we can quit retrying once we have gotten a valid listening socket

while( ($retry_count > 0) && (!$got_network) )
{
	try	#Try and allocate a socket, bind it to our IPC address, and set it to listen for connections
	{
		socket(SERVER,PF_INET,SOCK_STREAM,$proto) || die "socket: $!"; 
		setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR,  1);
		bind (SERVER, $addr) || die "bind: $!"; 
		listen(SERVER,5) || die "listen: $!";
		$got_network = 1;
	}
	catch	#If that didn't work for some reason, log the error, clean up, and prepair to retry
	{
		my $errmsg = $_;	#Remember the error message
		
		close(SERVER);		#Clean up the server socket if it needs it
		
		#Decrement our remaining retry counter
		$retry_count = $retry_count - 1;
		
		#Log the message to our debug log
		print "Failed to allocate socket, will retry $retry_count times: $errmsg\n";
		
		#Wait a reasonable period before trying again
		sleep $retry_delay;
	};
}

if($got_network)	#If we met with success binding to the network, report it
{
	my $logmsg = "Socket setup successful.  Listening for clients at $bind_ip:$bind_port\n";
	
	print $logmsg;	
	
}
else			#If we ran out of patience and gave up, report that as well and exit
{
	my $errmsg = "Could not allocate and bind listening socket at $bind_ip:$bind_port after $max_retries attempts.\n";
	
	die $errmsg;
}

#    Set up our signal handler which will clean up defunct child processes and let the main
# accept() loop know that the reason accept returned was due to a signal, not a legit connection.
$SIG{CHLD} = \&REAPER; 

#This for loop is efficient, but confusting, so I'll break it down by clause
#
#    The first clause ($sigreceived = 0) clears the signal received flag that will be set if the 
# accept() call was interrupted by a signal.  This clause runs once before the first run of the loop
#
#    The second clause is the test clause, it will process the contents of the loop if EITHER
# accept() has returned (presumably generating a valid file handle for the CLIENT end of the
# socket, OR the signal received flag is set (thus accept would have returned early without
# having actually accepted a connection.
#
#    The third clause (the 'incrementer') is run after each time the body is executed, before the 
# test clause is executed again (deciding whether to run the body or drop out...  This test
# clause will close the parent process' copy of the CLIENT file handle since (see body below)
# after the body executes, all communication with the socket referred to by that file handle
# will be carried out by the spawned child process.  This frees the parent's copy of the CLIENT
# file handle to be used again in the parent process for the next accepted incoming connection.

for ( $sigreceived = 0; accept(CLIENT,SERVER) || $sigreceived; $sigreceived = 0, close CLIENT) 
{ 
	next if $sigreceived; 			#If we were interrupted by a signal, there is no real client, just go back and try to accept a new one
	print "connection received.\n";		#Print a diagnostic message confirming that we have made a connection
	spawn sub {handle_client();};		#fork() off a child process that will handle communication with the socket pointed to by the CLIENT file handle 
}