=pod

this is the Wheels server, version 1.13

implementation goals:  

	read decks from decks.dat file

	abandon threaded connection acceptance and use 
	forks instead

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

	authentication leading to restoring saved state

	disregard join all threads and exit on completion of all games

	
	
=cut

package WheelsServer;

$Version = '1.13-forking';

use Socket;
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 data to the end of the wheels_log file

=cut

use Fcntl ':flock'; # import LOCK_* constants

open(LOG,">>kasey_dir/wheels_log") or die "cannot open wheels_log file for appens";

$main::NAME = 'SERVER';
$LogEntryNumber='aaa';
$LastTime = time;

sub Log(@){
	#$Parchment->enqueue( join(" ", Thread->self->tid, time, @_) );
        flock(LOG,LOCK_EX);
	seek(LOG, 0, 2);
	$LogEntryNumber='aaa' unless $LastTime == time;
	print LOG join(" ",$LastTime=time,$main::NAME,$LogEntryNumber++, @_),"\n" ;
        flock(LOG,LOCK_UN);
};

print "Log defined\n";
Log "Logging enabled";



=pod

Open the server socket for the doormen to receive connections on

=cut

sub Door();

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

$message = "Server starting ".localtime;
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

package WClient;
@ISA = qw{ WheelsServer };

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

sub New{
	Log "WCLIENT::NEW";
	my ($pack, $name, $sock) = @_;
	Log "new WClient for <$name> connecting from",
		&WheelsServer::SockData( $sock );
	my $Self = {};
	$main::NAME=$$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'};
	my $name = $$Table{'name'};
	$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;

	# Wait for the "green flag" to appear
	while (! -e "GreenFlag"){
		Log $name,"Waiting for green flag" unless  time % 25;
		sleep 1;
	};
	my $BTIME=time;
	Log "Resetting time for Green flag";
	$$Table{'connectedat'} = time;
	while( $line = <$Sock> ){
		Log $name,$line;

                # move-containing instructions are allowed once per second
                if ($line =~ m/\b[321][210]\b/){
                        if(-e "Delays" ){while ($TimeOfLastMove == time){
                                # wait a twentieth of a second for the second to come around
                                select(undef,undef,undef,0.05);
                        };};
                        $TimeOfLastMove = time;
                };
                


		@Commands = split(/\W+/, $line);
		foreach $cmd (@Commands){
			close $Sock if $cmd eq 'close';
			my $Result = $Table->Obey($cmd);
			print $Sock "$Result\n";
			Log "\n$PrevResult\n$Result" if $cmd eq 'discard' or $Result =~ m/^ERR/;
			$PrevResult = $Result;
                        # "pit stop" on errors
                        -e "Delays" and sleep(1) if $Result =~ m/^ERR/;



		};
		if(defined($$Table{'COMPLETE'})){
			Log $name, "Complete run.",time,"- $BTIME =",time-$BTIME;
			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 = {};
	$$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{'Deck'} = [split /\W+/, $WheelsServer::StandardDecks[0]];
	#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 = $WheelsServer::StandardDecks[$$Self{'DeckNo'}++];

	if (!$FirstDeck){
		${$$Self{"Pile0"}}[0] = 'FI';
		${$$Self{"Pile1"}}[0] = 'NI';
		${$$Self{"Pile2"}}[0] = 'SH';
		${$$Self{"Pile3"}}[0] = 'ED';
	
		$$Self{"COMPLETE"} = 1;	
		Log "$$Self{'name'} completed deck $$Self{'DeckNo'} of $$Self{'Decks'} in $$Self{'Round'} rounds.";

	}else{

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

	};

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

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

	return 1;
}


sub Doorman();

Doorman;	# Thread to accept clients
print " $$ Closing door\n";

print "It's curtains!\n";

print "exiting\n";
exit;




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 waiting for client";
	my $client;
	for(;;){
		until(	$client = $door->accept()){
			Log "Accepted false socket $!";
		};
		next if fork;
		
		# here we are in a new process

		close ($door);

		Log "Doorman got client";
		
		$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";
			$main::NAME = $Name;
			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";
		};
		Log "Doorman quitting";
		exit;
	};
};

# The Usher
sub Ush($$){
	my ($name, $Sock) = @_;
	my $ThisTable;
	my $SockData = SockData $Sock;
	Log "Ushing $name from", $SockData;
	Log "Assigning table for $name, game $main::games";
	$ThisTable = New WTable or die "New Wtable returned false";
	Log "Got the table";
	$$ThisTable{'name'} = $name;
	$$ThisTable{'sock'} = $Sock;
	$$ThisTable{'connectedat'} = time;
	$ThisTable->PlayAway(); 
	Log "usher returned";
};