deckard-and-company/Server/server.pl

#!/usr/bin/perl -w
use strict;
use warnings;
use POSIX;
use Net::WebSocket::Server;
use JSON;

use Data::Dumper; # For debuging only, REMOVE WHEN INITIAL CODE IS FINISH

#########################Game Logic starts here##########################

my %sessions = ();

sub generateSession {
	my $newSession = shift;
	unless (defined $newSession) { my $uniquifyer = sprintf("%.0f",rand()*1000); $newSession = time.$uniquifyer; }
	if ( grep( /$newSession/, keys %sessions ) ) {
		return 0 #failur to create session
	} else {
		print "Adding session ".$newSession." to database\n";
		$sessions{$newSession} = {
			"id" => $newSession,
			"connections" => {},
			"users" => {},
			"decks" => {},
			"pools" => {},
		};

	}
	return $newSession;
}

sub generateSingle {
	my $DDF = shift;
	my @cards = ("");
	for (@$DDF) {
		my @tempcards = ();
		my %datablock = %$_;
		for (@cards) {
			my $current = $_;
			for (@{$datablock{data}}) {
				push(@tempcards,$current.$_);
			}
		}
		@cards = @tempcards;
	}
	return @cards;
}

sub generateDeck {
	my $DDF = from_json(shift);
	if ("ARRAY" eq ref($DDF->[0])) {
		my @deck = ();
		for (@$DDF) {
			push(@deck,generateSingle($_));
		}
		return @deck;
	} else {
		return generateSingle($DDF);
	}
}

sub shuffle {
	my @deck = @_;
	my $index = 0;
	for (@deck) {
		my $swapCardIndex = floor(rand() * @deck);
		my $swapCard = $deck[$swapCardIndex];
		$deck[$swapCardIndex] = $_;
		$deck[$index] = $swapCard;
		$index++;
	}
	return \@deck;
}

sub shuffleDeck {
	my ($sessionID, $deckID) = @_;
	my @cards = @{$sessions{$sessionID}{"decks"}{$deckID}->{cards}};
	$sessions{$sessionID}{"decks"}{$deckID}->{cards} = shuffle(@cards);
}

sub shufflePool {
	my ($sessionID, $poolID) = @_;
	my @cards = @{$sessions{$sessionID}{"pools"}{$poolID}->{cards}};
	@{$sessions{$sessionID}{"pools"}{$poolID}->{cards}} = shuffle(@cards);;
}

sub shuffleHand {
	my ($sessionID, $userID, $handID) = @_;
	my @cards = @{$sessions{$sessionID}{"users"}{$userID}->{hands}{$handID}->{cards}};
	$sessions{$sessionID}{"users"}{$userID}->{hands}{$handID}->{cards} = shuffle(@cards);
}

sub addUser {
	my ($sessionID,$userID) = @_;
	if (grep( /$userID/, keys %{$sessions{$sessionID}{"users"}})) { print "ERROR: Duplicate user\n"; return 0; }
	$sessions{$sessionID}{"users"}{$userID} = {
		name => "$userID",
		hands => {}
	};
	addHand($sessionID,$userID,"default");
	return 1;
}

sub addCards {
	my ($sessionID,$deckID, $cards) = @_;
	push(@{$sessions{$sessionID}{"decks"}{$deckID}->{cards}}, @$cards);
}

sub addDeck {
	my ($sessionID,$deckID) = @_;
	$sessions{$sessionID}{"decks"}{$deckID} = { name => "$deckID", cards => [] };
}

sub delDeck {
	my ($sessionID,$deckID) = @_;
	delete($sessions{$sessionID}{"decks"}{$deckID});
}

sub uploadDDF {
	my ($sessionID, $deckID, $DDF) = @_;
	addCards($sessionID,$deckID,\@{generateDeck($DDF)});
}

sub addPool {
	my ($sessionID,$poolID) = @_;
	$sessions{$sessionID}{"pools"}{$poolID} = { name => "$poolID", cards => [] };
}

sub delPool {
	my ($sessionID,$poolID) = @_;
	my @reapedCards = splice(@{$sessions{$sessionID}{"pools"}{$poolID}{cards}});
	delete($sessions{$sessionID}{"pools"}{$poolID});
	return @reapedCards;
}

sub getUsers {
	my $sessionID = $_[0];
	return keys %{$sessions{$sessionID}{"users"}};
}

sub getDecks {
	my $sessionID = $_[0];
	return keys %{$sessions{$sessionID}{"decks"}};
}

sub getPools {
	my $sessionID = $_[0];
	return keys %{$sessions{$sessionID}{"pools"}};
}

sub getDeckName {
	my ($sessionID, $deckID) = @_;
	return $sessions{$sessionID}{"decks"}{$deckID}{name};
}

sub getUserName {
	my ($sessionID, $userID) = @_;
	return $sessions{$sessionID}{"users"}{$userID}{name};
}

sub getPoolName {
	my ($sessionID, $poolID) = @_;
	return $sessions{$sessionID}{"pools"}{$poolID}{name};
}

sub renameDeck {
	my ($sessionID, $deckID, $newName) = @_;
	unless (defined($newName)) { return print "ERROR: No name provided"; }
	$sessions{$sessionID}{"decks"}{$deckID}{name} = $newName;
}

sub renameUser {
	my ($sessionID, $userID, $newName) = @_;
	unless (defined($newName)) { return print "ERROR: No name provided"; }
	$sessions{$sessionID}{"users"}{$userID}{name} = $newName;
}

sub renamePool {
	my ($sessionID, $poolID, $newName) = @_;
	unless (defined($newName)) { return print "ERROR: No name provided"; }
	$sessions{$sessionID}{"pools"}{$poolID}{name} = $newName;
}

sub addHand {
	my ($sessionID, $userID, $handID) = @_;
	$sessions{$sessionID}{"users"}{$userID}{hands}{$handID} = { cards => [] };
}

sub delHand {
	my ($sessionID, $userID, $handID) = @_;
	my @leftoverCards = splice(@{$sessions{$sessionID}{"users"}{$userID}->{hands}{$handID}->{cards}});
	delete($sessions{$sessionID}{"users"}{$userID}{hands}{$handID});
	return @leftoverCards;
}

sub getHands {
	my ($sessionID, $userID) = @_;
	return keys %{$sessions{$sessionID}{"users"}{$userID}{hands}};
}

sub moveCard {
	my ($originStackRef, $originIndex, $destStackRef, $destIndex) = @_;
	unless(defined($originStackRef)) { return print "ERROR: No Origin Stack\n"; }
	unless(defined($originIndex)) { return print "ERROR: No Origin Index\n"; }
	unless(defined($destStackRef)) { return print "ERROR: No Destination Stack\n"; }
	unless(defined($destIndex)) { return print "ERROR: No Destination Index\n"; }
	my $card = splice(@$originStackRef,$originIndex,1);
	unless(defined($card)) { return print "ERROR: No Card available to be pulled\n"; }
	splice(@$destStackRef,$destIndex,0,$card);
}

sub drawCard {
	my ($sessionID, $deckID, $userID, $handID) = @_;
	moveCard(
		$sessions{$sessionID}{"decks"}{$deckID}->{cards}, 0,
		$sessions{$sessionID}{"users"}{$userID}->{hands}{$handID}->{cards}, 0
	);
}

sub playCard {
	my ($sessionID, $userID, $handID, $cardIndex, $poolID) = @_;
	moveCard(
		\@{$sessions{$sessionID}{"users"}{$userID}->{hands}{$handID}->{cards}}, $cardIndex,
		\@{$sessions{$sessionID}{"pools"}{$poolID}->{cards}},0
	);
}

sub delUser {
	my ($sessionID,$userID) = @_;
	my @hands = getHands($sessionID,$userID);
	my @reaped = ();
	for (@hands) {
		push(@reaped,delHand($sessionID,$userID,$_));
	}
	delete($sessions{$sessionID}{"users"}{$userID});
	return @reaped;
}

sub getDeckSize {
	my ($sessionID, $deckID) = @_;
	return scalar @{$sessions{$sessionID}{"decks"}{$deckID}->{cards}};
}

sub getPoolTop {
	my ($sessionID, $poolID) = @_;
	return @{$sessions{$sessionID}{"pools"}{$poolID}->{cards}}[0];
}

########################Game Logic ends here#############################

#########################Server Logic below##############################

my $origin = 'ws://localhost';

sub joinSession {
	my ($sessionID, $userID) = @_;
	unless (defined($sessions{$sessionID})) {
		print $sessionID." does not exsist, attempting to create...\n";
		if (generateSession($sessionID)) {
			print "Session ".$sessionID." has been created.\n";

		} else {
			print "ERROR: Could not create session ".$sessionID."\n";
			return 0;
		}
	}
	unless (addUser($sessionID,$userID)) {
		#assume rejoining user
	}
	return 1;
}

my $server = Net::WebSocket::Server->new(
    listen => 8080,
    on_connect => sub {
        my ($serv, $conn) = @_;
        $conn->on(
	    handshake => sub {
		my ($conn,$handshake) = @_;
		$conn->{"initHand"} = $handshake;
	    },
            ready => sub {
		my ($conn) = @_;
		$conn->send_utf8('{"request":"user"}');
		$conn->send_utf8('{"request":"session"}');
            },
            utf8 => sub {
		my ($conn, $msg) = @_;
		my $sessionID = $conn->{"currentSession"}{"id"};
		my $messageData = "";
		eval { $messageData = from_json($msg) };
		if ($@) { $conn->send_utf8('{"error":100, "message":"ERROR: Invalid json"}'); return 0;}

		if (defined($messageData->{user})) {
			$conn->{user} = $messageData->{user};
			# Need to check if userID is unique
			$conn->send_utf8('{"info":"user success"}');
		}
		if (defined($messageData->{session})) {
			unless(defined($conn->{user})) { $conn->send_utf8('{"error":200, "message":"Could not join session, no user defined", "request":"user"}'); $conn->send_utf8('{"request":"session"}'); return 0; }
			$conn->{session} = $messageData->{session};
			$conn->send_utf8('{"info":"session success", "request":"join"}');
		}
		if (defined($messageData->{action})) {
			if ($messageData->{action} =~ /join/ ) { if (joinSession($conn->{session},$conn->{user})) { $conn->send_utf8('{"info":"join success", "request":"update"}'); } }
			if ($messageData->{action} =~ /update/ ) { my $sessionID = $conn->{session}; for ($conn->server->connections) { if ($_->{session} == $conn->{session}) {
						#This might be a lot to do at once, might need to break it up in the future. 
				# Update all connections joined to this session.
				# User List
				my @users = getUsers($sessionID);
				my @userNames;
				my $current = $_;
				for (@users) {
					push(@userNames,getUserName($sessionID,$_));
				}
				$current->send_utf8('{"users":["'.join('","',@userNames).'"]}');
				# Deck List
				my @decks = getDecks($sessionID);
				my %deckStats = ();
				for (@decks) {
					$deckStats{$_}{name} = $sessions{$sessionID}{"decks"}{$_}{name};
					$deckStats{$_}{size} = getDeckSize($sessionID,$_);
				}
				$current->send_utf8('{"decks":'.to_json(\%deckStats).'}');
				# Pool List
				my @pools = getPools($sessionID);
				my %poolStats = ();
				for (@pools) {
					$poolStats{$_}{name} = $sessions{$sessionID}{"pools"}{$_}{name};
					$poolStats{$_}{top} = getPoolTop($sessionID,$_); 
				}
				$current->send_utf8('{"pools":'.to_json(\%poolStats).'}');
				# Users Hands
				my @hands = getHands($sessionID,$_->{user});
				my %handStats = ();
				for (@hands) {
					$handStats{$_}{name} = $_;
					$handStats{$_}{cards} = [];
				}
				$current->send_utf8('{"hands":'.to_json(\%handStats).'}');
				# for each hand
				for (@hands) {
					my $handID = $_;
					my @hand = @{$sessions{$sessionID}{"users"}{$current->{user}}{hands}{$handID}{cards}};
				# 	each card (so we scale better)
					if (@hand) { for (@hand) {
						my $card = $_;
						$current->send_utf8('{"action":"addCard","hand":"'.$handID.'", "card":"'.$card.'"}');
					}}
				}
			}}}
			if ($messageData->{action} =~ /draw/) {
				drawCard($conn->{session},$messageData->{deck},$conn->{user},$messageData->{hand});
				$conn->send_utf8('{"info":"card drawn", "request":"update"}');
			}
			if ($messageData->{action} =~ /play/) {
				playCard($conn->{session},$conn->{user},$messageData->{hand},$messageData->{cardID},$messageData->{pool});
				$conn->send_utf8('{"info":"card played", "request":"update"}');
			}
			if ($messageData->{action} =~ /clear/) {
				my @cards = delPool($conn->{session},$messageData->{pool});
				addCards($conn->{session},$messageData->{deck},\@cards);
				addPool($conn->{session},$messageData->{pool});
				$conn->send_utf8('{"info":"pool cleared", "request":"update"}');
			}
		}
            },
	    disconnect => sub {
		my ($conn, $code, $reason) = @_;
	    }
	);
    }
);

my $ses = generateSession(50);
addDeck($ses,"default");
my @tCards = generateDeck('[{"data":["Male ","Female "]},{"data":["Ardvark ","Platipus ","Cat "]},{"data":["Jumping","Falling","Flying"]}]');
addCards($ses,"default",\@tCards);
addPool($ses,"default");
addUser($ses,"Sergiy");
drawCard($ses,"default","Sergiy","default");
drawCard($ses,"default","Sergiy","default");
playCard($ses,"Sergiy","default",0,"default");

$server->start;