=pod

this is the Wheels server, version 1.07

implementation goals:  

	read decks from decks.dat file

	threaded connection acceptance

	game handling:  lay, discard, NN, NNNN, win, status

	authentication leading to restoring saved state

	join all threads and exit on completion of all games
	
=cut

package WheelsServer;

$Version = '1.07';

use Socket;
use Fcntl ':flock';
use Thread;
use Thread 'async';
use Thread::Queue;
use IO::Handle;
use IO::Socket;
use Carp;
require "ctime.pl";


# Things to do before starting any async anything:  The socket, the log queue

=pod

The Log function adds entries to the $Parchment queue,

=cut

# The Logging Function
$Parchment = new Thread::Queue;


# Good threads add themselves to this list before exiting
$JoinMe = new Thread::Queue;

sub Scribe();

sub Log(@){
	$Parchment->enqueue( join(" ", Thread->self->tid, time, @_) );
};

print "Log defined\n";

Log "Logging enabled";

=pod

Open the server socket for the doormen to receive connections on

=cut

sub Door();
$main::doormen = 0;
sub doormenincrement();
sub doormendecrement();

print "opening server socket for listen\n";
Door; 	# accept new incoming connections 
print "server socket listen now open\n";


$ScribeThread = async{ Scribe; };
print "Scribe running in thread ", $ScribeThread->tid,"\n";

$message = "Server starting ".`date`;
chomp($message); 
Log($message);

=pod

The server reads the decks in from the decks.dat file which exists in the
current directory.

=cut

open DECKS,"decks.dat" or die "Run ./shuffle.pl first\n"; 
chomp(@StandardDecks = (<DECKS>));
Log("Read in $#StandardDecks decks");

=pod

Every line in passwd is username:password, there is no encryption
Doorman will see if the data it gets appears in $PasswdHash
before passing the socket to Usher

=cut

open PASSWD, "passwd" or die "Need to create ./passwd file\n";
my ($pline,$ptally);
foreach $pline (<PASSWD>){ $ptally++; chomp $pline; $PasswdHash{$pline} = 1}; 
Log("Read in $ptally passwords");
map {Log $_} keys %PasswdHash;

=pod

Have plenty of fresh tables for the usher to assign incoming clients to

=cut

sub TablePrep();
Log "Starting tableprep";
$FreeTables = new Thread::Queue;
$MoreTables = new Thread::Queue;
async{ TablePrep; };	# prepare new game tables


package WClient;
@ISA = qw{ WheelsServer };

sub Log(@){&WheelsServer::Log( @_ )};
#use WheelsServer 'Log';

sub New{
	Log "WCLIENT:::NEW";
	my ($pack, $name, $sock) = @_;
	Log "new WClient for <$name> connecting from",
		&WheelsServer::SockData( $sock );
	my $Self = {};
	$$Self{'name'} = $name;
	$$Self{'sock'} = $sock;
	bless $Self;
};


package WTable;

@ISA = qw{ WheelsServer };
sub Log(@){&WheelsServer::Log( @_);};

$Tally = 0;


sub PlayAway{
	my $Table = shift;
	ref($Table) eq 'WTable' or Croak("Weird table");
	my $Sock = $$Table{'sock'};
	$SockData = &WheelsServer::SockData( $Sock );
=pod

provide the Stateful Wheels Protocol interface to
the client connected to the other end of $Sock
using the game state object $Table

=cut

	$Sock->autoflush(1);
	my $line;
	my @Commands;
	while( $line = <$Sock> ){
		@Commands = split(/\W+/, $line);
		foreach $cmd (@Commands){
			close $Sock if $cmd eq 'close';
			my $Result = $Table->Obey($cmd);
			print $Sock "$Result\n";
		};
		if(defined($$Table{'COMPLETE'})){
			Log "Closing connection for",$$Table{'name'};
			print "Closing connection for $$Table{'name'}\n";
			close $Sock;
			$main::COMPLETEs++ unless defined ($$Table{'notedCOMPLETION'});
			$$Table{'notedCOMPLETION'} = 1;
			return;
		};
	};
	Log "Reading $SockData produced error $!";
	close $Sock;
};

sub New{
	my $Self = {};
	lock $Tally;
	$$Self{'TableNo'} = ++$Tally;
	#print "building table number $$Self{'TableNo'}\n";
	Log "building table number $$Self{'TableNo'}";

	$$Self{'Decks'} = 1 + $#WheelsServer::StandardDecks; 
	$$Self{'DeckNo'} = 1; 
	#Log "we are on Deck number",$$Self{'DeckNo'},'of',$$Self{'Decks'};

	$$Self{'DeckList'} = [@WheelsServer::StandardDecks]; 
	my $FirstDeck = shift @{$$Self{'DeckList'}};
	#print "FirstDeck is <$FirstDeck>\n";
	$$Self{'Deck'} = [split /\W+/, $FirstDeck];
	#Log "The deck in hand is",@{$$Self{'Deck'}};

	my $n;
	for $n (0..3){
		@{$$Self{"Pile$n"}}=();
	};

	$$Self{'Round'} = $$Self{'Move'} = 0;

	bless $Self;
};

sub dump{
	my $Self = shift;
	# print out the entire game state
	Log "Table $$Self{'TableNo'} on Deck $$Self{'DeckNo'} of $$Self{'Decks'}";
	Log "deck  :",@{$$Self{'Deck'}};
	my $n;
	for $n (0..3){
		Log "Pile $n:",@{$$Self{"Pile$n"}};
	};
};

sub PileTops($){
	my $Self = shift;
	my $pile0 = ${$$Self{"Pile0"}}[0] || '__';
	my $pile1 = ${$$Self{"Pile1"}}[0] || '__';
	my $pile2 = ${$$Self{"Pile2"}}[0] || '__';
	my $pile3 = ${$$Self{"Pile3"}}[0] || '__';
	return "$pile0 $pile1 $pile2 $pile3";
};

sub status{
	my $Self = shift;
	my $piletops = PileTops($Self);
	my $elapsed = time - $$Self{'connectedat'};
	my $D =  $$Self{'DeckNo'};
	my $DD =  $$Self{'Decks'};
	my $R =  $$Self{'Round'};
	my $M =  $$Self{'Move'};
	my $C = ($#{$$Self{'Deck'}} + 1) /4 ;
	#Log "giving status for table $$Self{'TableNo'}";
	return "OK $piletops time $elapsed round $R move $M $C sets left in deck $D of $DD decks"; 
};
$CommandHash{'status'} = \&status;

sub pickup{
	my ($Self, $order) = @_;
	my @order = split '',$order;
	return "ERR cannot pickup $order" unless join('',sort @order) eq '0123';

=pod

	this routine gathers the piles of cards on the table,
	and adds them to the bottom of the deck.

	The cards will come off the deck in the order that they are listed
	in the instruction, left to right.

=cut
	
	# uncomment this line see that the above paragraph is accurate $Self->dump;
	$$Self{'Deck'} = [
		@{$$Self{"Pile$order[3]"}},
		@{$$Self{"Pile$order[2]"}},
		@{$$Self{"Pile$order[1]"}},
		@{$$Self{"Pile$order[0]"}},
		@{$$Self{'Deck'}}
	];
 	my $n;
        for $n (0..3){
                @{$$Self{"Pile$n"}}=();
        };
	$$Self{'Round'}++;
	# this one too $Self->dump;
	return $Self->status;
};

sub move{
	my ($Self, $order0) = @_;
	my ($order) = $order0 =~ m/([0123]{2})/ or return "ERR cannot move $order0";
	my ($origin, $destination) = split '',$order;
	unless(defined($origin) and defined($destination)){
		Log "Very odd happening; move for $$Self{'name'} took arg of $order0";
		return "ERR cannot move $order0";
	};
	return "ERR cannot move $order0" unless $origin gt $destination;

	return "ERR cannot move $order0" unless defined ${$$Self{"Pile$destination"}}[0] ;
	return "ERR cannot move $order0" unless defined ${$$Self{"Pile$origin"}}[0] ;
	return "ERR cannot move $order0" unless substr(${$$Self{"Pile$destination"}}[0],0,1) eq substr( ${$$Self{"Pile$origin"}}[0],0,1);
	unshift @{$$Self{"Pile$destination"}}, shift @{$$Self{"Pile$origin"}};
	$$Self{'Move'}++;

	return $Self->status;
};

sub lay{
	my $Self = shift;
	unless (@{$$Self{'Deck'}}){
		return $Self->pickup(3210) if 3 < $$Self{'OUTOFCARDS'}++;
		return "ERR out of cards --  $$Self{'OUTOFCARDS'}";
	};
	unshift @{$$Self{"Pile0"}}, pop @{$$Self{'Deck'}};
	unshift @{$$Self{"Pile1"}}, pop @{$$Self{'Deck'}};
	unshift @{$$Self{"Pile2"}}, pop @{$$Self{'Deck'}};
	unshift @{$$Self{"Pile3"}}, pop @{$$Self{'Deck'}};
	return $Self->status;
};
$CommandHash{'lay'} = \&lay;
$CommandHash{'dump'} = \&dump;

sub discard{
	my $Self = shift;
	my $pile0 = ${$$Self{"Pile0"}}[0] || '__';
	my $pile1 = ${$$Self{"Pile1"}}[0] || '__';
	my $pile2 = ${$$Self{"Pile2"}}[0] || '__';
	my $pile3 = ${$$Self{"Pile3"}}[0] || '__';

	return "ERR cannot discard" if $pile3 eq '__';
	return "ERR cannot discard" if substr($pile3,0,1) ne substr($pile2,0,1) ;
	return "ERR cannot discard" if substr($pile0,0,1) ne substr($pile1,0,1) ;
	return "ERR cannot discard" if substr($pile1,0,1) ne substr($pile2,0,1) ;

	shift @{$$Self{"Pile0"}};
	shift @{$$Self{"Pile1"}};
	shift @{$$Self{"Pile2"}};
	shift @{$$Self{"Pile3"}};
	return $Self->status;
};

$CommandHash{'discard'} = \&discard;
sub win{
	my $Self = shift;
	my @deck = (	@{$$Self{'Deck'}},
		@{$$Self{"Pile0"}},
		@{$$Self{"Pile1"}},
		@{$$Self{"Pile2"}},
		@{$$Self{"Pile3"}}
	);
	return "ERR there are still cards in this deck" if @deck;

        my $FirstDeck = shift @{$$Self{'DeckList'}};

	if (!$FirstDeck){
		${$$Self{"Pile0"}}[0] = 'FI';
		${$$Self{"Pile1"}}[0] = 'NI';
		${$$Self{"Pile2"}}[0] = 'SH';
		${$$Self{"Pile3"}}[0] = 'ED';
	
		$$Self{"COMPLETE"} = 1;	

	}else{

	        $$Self{'Deck'} = [split /\W+/, $FirstDeck];
		Log "$$Self{'name'} completed deck $$Self{'DeckNo'} of $$Self{'Decks'}.";
		$$Self{'DeckNo'}++;

	};

	my $WinRes = $Self->status;
	Log $WinRes;
	return $WinRes;
};
$CommandHash{'win'} = \&win;

sub sclose{
	 my $Self = shift;
	close($$Self{'sock'});
};
$CommandHash{'close'} = \&sclose;

sub echo{
	my $Self = shift;
	my $arg = shift;
	"OK, synching $arg";
};

sub Obey{
	my ($Self,$command) = @_;
	#Log "trying to Obey $command";
	#$Self->dump;
	#return "OK the function is getting called allright -- this time with $command";

	return $Self->pickup($command) if $command =~ m/\d\d\d\d/;
	return $Self->move($command) if $command =~ m/\d\d/;
	return $Self->echo($command) if $command =~ m/^sync/;

	unless (defined $CommandHash{$command}){
		Log "trying to Obey $command";
		return "ERR what is \"$command\"?  I know: status lay win discard NN NNNN sync... close";
	};
	return &{$CommandHash{$command}}($Self) ;


};

package WheelsServer;

sub Door(){

        my $PortNumber  = $ENV{'SWP_SERVERPORT'} || 5200;

	$door = IO::Socket::INET->new(
				Proto     => 'tcp',
                                LocalPort => $PortNumber,
                                Listen    => SOMAXCONN,
                                Reuse     => 1
	);

 	die "can't setup server" unless $door;
 	Log "Server accepting clients";
}

$main::COMPLETEs = 0;
sub Curtains(){	# Determine time to exit the program
	return 0 unless  (defined($main::games) and $main::games ==  $main::COMPLETEs);

	$main::Curtains = 1;

	Log "Curtains has happened; the game should now end";

	return 1;
}

sub FreeTable(){
	Log $FreeTables->pending, "free tables";
	my $NewTable = &WTable::New;
	defined($NewTable) or Log "Table came back undefined!";
	$FreeTables->enqueue($NewTable);
	Log $FreeTables->pending, "free tables";
	#$NewTable->dump;
}

sub TablePrep(){
	Log "Tableprep running ",Thread->self->tid;
	$MoreTables->enqueue(1..4);
	while($MoreTables->dequeue){	#Shut down by putting a zero in $moreTables
		FreeTable ;
        };
	Log "TablePrep thread exiting"
};

sub Doorman();
$DoormanRequired = new Thread::Queue;
sub Doormen(){
	$DoormanRequired->enqueue(1..5);
	while($DoormanRequired->dequeue){
		return if defined( $main::Curtains );
		async{ Doorman };
        };
};
sub Bouncer();

async{ Doormen; };	# Thread to produce client acceptors
while (sleep 20 and !Curtains){
	Bouncer;	# join completed threads on the JoinMe queue
};
print "Closing door\n";
$door->close;			# what does this do for the doormen?
$MoreTables->enqueue(0);	# shut down table producer
$DoormanRequired->enqueue(0);	# shut down doorman producer

print "It's curtains!\n";
print  "One minute delay for scribe to shut down\n";
foreach $_ (Thread->list){

	next if $_->tid == Thread->self->tid; 
	next if $_->tid == $ScribeThread->tid; 
	$JoinMe->enqueue($_);

};

print "Doing last joins as sockets time out\n";
$LastBouncer = async{Bouncer;};
print "joining scribe thread\n";
while($main::doormen > 0){
	print "Sending self a IOT to kill a doorman\n";
	kill 6,$$;
};
$LastBouncer->join;
$ScribeThread->join;
print "exiting\n";
exit;




# The Logging Daemon
sub Scribe(){
	# this function handles the $Parchment queue and writes
	# anything found therein out to the log file.
	my $FileName = $ENV{'W_LogFileName'} || "W_Server_Log";
	open(LOG,">>$FileName");
	LOG->autoflush(1);
	Log " Scribe starting ",`date`;
	my $Datum;
	while($Datum = $Parchment->dequeue){
		flock(LOG,LOCK_EX);
		seek(LOG,0,2);	# write to end of file if we have multiple procs
		print LOG "$$ $Datum\n";
		if (defined( $main::Curtains )){
			Log "Shutting down Scribe";
			sleep 30;	# give everything else plenty of time to finish
			while($Parchment->pending){
				print LOG "$$",$Parchment->dequeue,"\n";
			};
			return;
		};
		flock(LOG,LOCK_UN);
	};
};

# The Bouncer
sub Bouncer(){
=pod
any periodic cleanups that need doing will be done
here, so far there are none
=cut
	my $Time = &ctime(time);
	chomp $Time;
	Log "Timestamp: $Time";
	my($j, $t, $tid,$rval);
# join 	reported exiting threads
	while ($JoinMe->pending){
		$j = $JoinMe->dequeue;	
		$tid = $j->tid;
		Log "joining thread $tid";
		$rval = eval {$j->join};
		defined($rval) or $rval = 'undef';
		Log defined($@)?"Thread $tid joined $rval: $@":"Thread $tid joined $rval";
	};
}	 

sub SockData($){
	my $client = shift;
    	my $hersockaddr    = getpeername($client);
    	my ($port, $iaddr) = unpack_sockaddr_in($hersockaddr);
    	my $herhostname    = gethostbyaddr($iaddr, AF_INET);
    	my $herstraddr     = inet_ntoa($iaddr);
	return "$herhostname $herstraddr";
};

sub Ush($$);
# The Doorman
sub Doorman(){
	Log "Doorman ",Thread->self->tid," waiting for client";
	my $client;
	doormenincrement;
	until(	$client = $door->accept()){
		print "Accepted false socket $!";
		doormendecrement;
		return if defined( $main::Curtains );
	};
	Log "Doorman ",Thread->self->tid," got client";
	$DoormanRequired->enqueue(1);
	$client->autoflush();
	print $client "Stateful Wheels Protocol Server version $Version: Authenticate yourself please\n";
	my $Data = <$client>;
	my($Name,$Pass) =  $Data =~ m/^(\w+):(\w*)/;
	if($PasswdHash{"$Name\:$Pass"}){
		print $client "OK password matched\n";
		Log "Good auth $Data";
		print "Received connection from $Name\n";
		Ush($Name,$client);
		Log "returned from playing";
	}else{
		Log "Received bad auth data <$Data>";
		Log "closing connection from", SockData $client;
		print $client "ERR sorry, ", SockData $client ," password mismatch\n";
		close $client;
	};
	Log "Doorman ",Thread->self->tid," quitting";
	$JoinMe->enqueue(Thread->self);
	doormendecrement;
};
sub doormenincrement(){
	
	lock $main::doormen;
	print "There are now ",++$main::doormen," doormen\n"
};
sub doormendecrement(){
	lock $main::doormen;
	print "There are now ",--$main::doormen," doormen\n"
};

# The Usher
sub Ush($$){
	my ($name, $Sock) = @_;
=pod

Take sockets from the $LineForUshers queue and issue them
a table from the Tables queue or reattach them with their
table should they have lost their connection.

=cut
	my $ThisTable;
	my $SockData = SockData $Sock;
	Log "Ushing $name from", $SockData;
	if ($TableAssignment{$name}){
		$ThisTable = $TableAssignment{$name};
		# Verify that the old socket is closed, by printing to it and failing
		my $OldSock = $$ThisTable{'sock'};
		my $Perr = print $OldSock "ERR Second connection for $name attempted from $SockData\n";
		if ($Perr){
			print $NewSock "ERR Sorry, you already have a connection, from ",SockData $$ThisTable{'sock'}," it must be closed before you can open a new connection.\n";
			close $NewSock;
			return;
		};

		$$ThisTable{'sock'} = $Sock;
		Log "reassigning table $$ThisTable{'TableNo'} to $name";
		$ThisTable->PlayAway(); 
		Log "usher returned from UseTable";
	}else{
		$main::games++;
		Log "Assigning table for $name, game $main::games";
		$MoreTables->enqueue(1);
		until($ThisTable = $FreeTables->dequeue){
			Log "FreeTables dequeued false object";
		};
		Log "Got the table";
		$$ThisTable{'name'} = $name;
		$$ThisTable{'sock'} = $Sock;
		$$ThisTable{'connectedat'} = time;
		$TableAssignment{$name}=$ThisTable;
		$ThisTable->PlayAway(); 
		Log "usher returned from UseTable: $main::games games, $main::COMPLETEs complete ";
	};
};