popufare/server/daemons/version_server/version_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 DBI;
use FileHandle;
use Fcntl;

use POSIX;

#my $database_path = 'DBI:mysql:busdb';
my $database_path = 'DBI:SQLite:dbname=../bus.sqlite';
my $database_user = '';
my $database_pass = '';

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

#----------------------------------------------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 CheckinServerReply
{
	my $client_query = $_[0];

	my $dbh = DBI->connect($database_path, $database_user, $database_pass)
		or die "Couldn't connect to database: " . DBI->errstr;

	my $sth ;
	my $logmsg ;
	my $response = '';
	
	my @client_values = split(/[\t]/, $client_query, -1);   #the -1 keeps split from trimming trailing blank fields
		#0.	viper_num	(0 for Phase II)
		#1.	equip_num	(usually bogus for Phase I)
		#2.	eth0_mac	(Effectively a serial number of the SBC (be it Viper, Titan, or some Atom based system)
		#3.	cell_imei	(Effectively a serial number of the Cell Modem)
		#4.	cell_imsi	(Effectively a serial number of the SIM card inserted in the modem)	
		#5.	version_strings (a concatenation of package versions)

	$client_values[0] =~ s/^[^0-9]*//;	#Strip the leading '#' (and anything else non-numeric) from our string

	$sth = $dbh->prepare('INSERT INTO bus_checkin_log (viper_num, equip_num, eth0_mac, cell_imei, cell_imsi, version_data) VALUES (?, ?, ?, ?, ?, ?)');

	#    We explicitly chop this down to the 6 fields we want to insert, rather than passing @client_values as a parameter so
	#that if some foolish version string goes and contains a tab (this should never happen!) it will be trunctated instead
	#of the whole update being shitcanned because the array has too many data fields for the quiery...
	
	try
	{
		$sth->execute(@client_values[0..5]);
		$response .= "Thanks.\n";
	}
	catch
	{
		$logmsg .= $_ . "\n";
		$response .= "Server Side Error.\n";
	};

	print $logmsg if $logmsg;
	
	return $response;
}


sub ServerReply
{
	my $client_query = $_[0];
	
	$/="\n";
	chomp($client_query);
	
	if ($client_query =~ m/^\#/) #A leading '#' signals a bus_checkin_log entry, rather than an package update checkin
	{
		return CheckinServerReply($client_query);
	}

	my $response = "";
	
	my $dbh = DBI->connect($database_path, $database_user, $database_pass)
		or die "Couldn't connect to database: " . DBI->errstr;
	my $sth ;
	my $logmsg ;

	$sth = $dbh->prepare('SELECT client_file, checksum, file_size, file_path, fileversion FROM update_level t1 WHERE (serial = (SELECT serial FROM update_level WHERE client_file = t1.client_file AND (equip_num = 0 OR equip_num = ?) ORDER BY equip_num DESC, serial DESC LIMIT 1)) ORDER BY client_file ASC');

	my @client_values = split(/[\t]/, $client_query, -1);   #the -1 keeps split from trimming trailing blank fields
		#0.	equip_num
		#1.	filename=md5sum
		#2 ...

	my $i;
	my %filetable = ();
	
	for($i = 1; $i < @client_values; $i = $i + 1)
	{
		my ($client_file, $client_checksum) = split(/=/, $client_values[$i]);
		
		if($client_file && $client_checksum)
		{
			$filetable{$client_file} = $client_checksum;
		}
	}
	
	try
	{
		$sth->execute($client_values[0]) or die "Couldn't execute statement: " . $sth->errstr;
	}
	catch
	{
		$logmsg .= $_ . "\n";	
	};
	
	
	
	while(my @data = $sth->fetchrow_array())
	{
		#0	client_file
		#1	checksum
		#2	file_size
		#3	file_path
		#4	fileversion
	
		if(defined $filetable{$data[0]} && $filetable{$data[0]} eq $data[1])
		{
			#do nothing, the client is up to date	
		}
		else
		{
			$response .= "$data[0]\t$data[1]\t$data[2]\t$data[3]\t$data[4]\n";
		}
	}

	print $logmsg if $logmsg;
	
	return $response;
}


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

	my $linebuffer;
	
	while($linebuffer = <CLIENT>) 
	{

## DEBUG
print "## version: $linebuffer\n";

		print CLIENT ServerReply($linebuffer);
	}	#while data from client
	
	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 
}