popufare/server/daemons/buspass_server/buspass_server.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 Switch;
use Carp;
use DBI;
use FileHandle;
use Fcntl;
use Compress::Zlib;

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	  = 7277;

#----------------------------------------------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 ServerReply
{
	my $client_query = $_[0];
	chomp($client_query);
	my $response = "";
	my $hangup_flag=0;

	#Turning this on will use FLUSH instead of ZFLUSH, which is much slower
	my $do_legacy_flush = 0;

	switch ($client_query) 
	{
		case /^QUERY\t[0-9][0-9]*$/ 
		{
			my $sequence_number = $client_query;
			$sequence_number =~  s/^QUERY\t//;

			my $dbh = DBI->connect($database_path, $database_user, $database_pass)
				or die "Couldn't connect to database: " . DBI->errstr;
			
			#A query to check for the validity of the queried sequence number
			my $seqcheck = $dbh->prepare('SELECT seq_num FROM active_rider_table WHERE seq_num = ?') or die "Couldn't prepare statement: " . $dbh->errstr;
			
			#Prepare to send records
			my $sth = $dbh->prepare('SELECT deleted, seq_num, logical_card_id, mag_token, rfid_token, rule_name, rule_param FROM active_rider_table a1 WHERE seq_num = ' .
						'(SELECT MAX(seq_num) FROM active_rider_table a2 WHERE a1.logical_card_id= a2.logical_card_id) AND seq_num > ? ORDER BY seq_num ASC')
				or die "Couldn't prepare statement: " . $dbh->errstr;

			$seqcheck->execute($sequence_number);

			#Check if the client is on the same page as us
			#if not, tell them to flush everything and send it all again
			my $flushdata = 0;
			if ($sequence_number == 0) 
			{
				$flushdata = 1;

				$sth->execute($sequence_number)             # Execute the query
					or die "Couldn't execute statement: " . $sth->errstr;
				
			} 
			elsif (!$seqcheck->fetchrow_array()) 
			{
				$sth->execute(0) # Get everything
				or die "Couldn't execute statement: " . $sth->errstr;
				$flushdata = 1;
			}
			else
			{
				$sth->execute($sequence_number)             # Execute the query
					or die "Couldn't execute statement: " . $sth->errstr;
			}

			# Read the matching records and print them out
			# $data[0] = deleted
			# $data[1] = seq_num
			# $data[2] = logical_card_id 
			# $data[3] = mag_token
			# $data[4] = rfid_token
			# $data[5] = rule_name
			# $data[6] = rule_param
			my @data ;
			
			
			#If we are doing a flush
			if($flushdata)
			{
				if($do_legacy_flush)
				{
					$response .= "FLUSH\n" if $flushdata;
					while (@data = $sth->fetchrow_array()) 
					{
						if (!$data[0]) 
						{
							$data[3] = "" unless defined $data[3];		#populate any NULL mag_token with ""
							$data[4] = "" unless defined $data[4];		#populate any NULL rfid_token with ""
							$data[6] = "" unless defined $data[6];		#populate any NULL rule_param with ""
							$response .= "UPDATE\t$data[1]\t$data[2]\t$data[3]\t$data[4]\t$data[5]\t$data[6]\n"; 
						}
					}
					$response .= "FLUSHDONE\n" if $flushdata;
				}
				else
				{
					my $z = deflateInit( -Level => Z_BEST_COMPRESSION ) or die "Cannot create a deflation stream\n";
					my $size = 0;
					my $dat = "";
					my ($zout, $stat);
					my $cmpdat;
				
					while (@data = $sth->fetchrow_array()) 
					{
						if (!$data[0]) 
						{
							$data[3] = "" unless defined $data[3];		#populate any NULL mag_token with ""
							$data[4] = "" unless defined $data[4];		#populate any NULL rfid_token with ""
							$data[6] = "" unless defined $data[6];		#populate any NULL rule_param with ""
							$dat .= "UPDATE\t$data[1]\t$data[2]\t$data[3]\t$data[4]\t$data[5]\t$data[6]\n"; 
						}
					}
				
					($zout, $stat) = $z->deflate($dat);
					$stat == Z_OK or die "deflation failed...";
					$cmpdat = $zout;
				
					($zout, $stat) = $z->flush();
					$stat == Z_OK or die "deflation failed...";
					$cmpdat .= $zout;
				
					$size = $z->total_out();
				
					$response .= "ZFLUSH\t$size\n";
					$response .= $cmpdat;
					$response .= "ZFLUSHDONE\n";
					
					#Set the "HANG-UP" flag to make the server hang up on a client who has just done a ZFLUSH
					#so that the client will start a fresh server session with its shiny new database
					$hangup_flag = 1;
				}
				
			}
			else
			{
				while (@data = $sth->fetchrow_array()) 
				{
					if ($data[0]) 
					{
						$response .= "DELETE\t$data[1]\t$data[2]\n";
					} else 
					{
						$data[3] = "" unless defined $data[3];		#populate any NULL mag_token with ""
						$data[4] = "" unless defined $data[4];		#populate any NULL rfid_token with ""
						$data[6] = "" unless defined $data[6];		#populate any NULL rule_param with ""
						$response .= "UPDATE\t$data[1]\t$data[2]\t$data[3]\t$data[4]\t$data[5]\t$data[6]\n"; 
					}
				}
			}
			

			$seqcheck->finish;
			$sth->finish;
			$dbh->disconnect;
		}
		else
		{
                        $response = "ERROR\n" . $client_query;
		}
	}
	
	if($response eq "")
	{
		$response .= "NOP\n";
	}
	
	return ($response, $hangup_flag);
}


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

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

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

		my ($reply, $hangup_flag) = ServerReply($linebuffer);
		print CLIENT $reply;
	
		if($hangup_flag)
		{
                        sleep(60);
			shutdown(CLIENT, 2);
			close CLIENT;
			return 0;
		}

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