added initial implementation of wesnothd.pl
This commit is contained in:
David White
parent
ec964f03c5
commit
a1c9b8b13a
2 changed files with 395 additions and 10 deletions
247
utils/wesnothd.pl
Normal file
247
utils/wesnothd.pl
Normal file
|
|
@ -0,0 +1,247 @@
|
|||
use strict;
|
||||
use wml;
|
||||
use IO::Socket;
|
||||
use IO::Select;
|
||||
use Fcntl;
|
||||
|
||||
my %pending_handshake = ();
|
||||
my %outgoing_schemas = ();
|
||||
my %incoming_schemas = ();
|
||||
my %incoming_bufs = ();
|
||||
my %connection_nums = ();
|
||||
my %user_name_socket = ();
|
||||
my %socket_user_name = ();
|
||||
my %lobby_players = ();
|
||||
my @games = ();
|
||||
my $current_game_id = 1;
|
||||
my $current_connection_num = 1;
|
||||
my $read_set = new IO::Select();
|
||||
|
||||
my $login_response = &wml::single_child_doc('mustlogin');
|
||||
my $join_lobby_response = &wml::single_child_doc('join_lobby');
|
||||
my $gamelist = {'name' => 'gamelist', 'children' => [], 'attr' => {}};
|
||||
my $initial_response = {'name' => '', 'children' => [$gamelist], 'attr' => {}};
|
||||
my $old_initial_response = &wml::deep_copy($initial_response);
|
||||
|
||||
my $port = 15000;
|
||||
|
||||
my @disallowed_names = ('server', 'ai', 'player', 'network', 'human', 'admin', 'computer');
|
||||
|
||||
my $server_sock = new IO::Socket::INET (
|
||||
LocalHost => '',
|
||||
LocalPort => $port,
|
||||
Proto => 'tcp',
|
||||
Listen => 1,
|
||||
Reuse => 1
|
||||
) or die "could not create server sock: $!";
|
||||
|
||||
$read_set->add($server_sock);
|
||||
|
||||
sub send_data {
|
||||
my $doc = shift @_;
|
||||
return unless @_;
|
||||
print "SENDING: {{{" . &wml::write_text($doc) . "}}}\n";
|
||||
foreach my $sock (@_) {
|
||||
my $packet = &wml::write_binary($outgoing_schemas{$sock}, $doc) . chr 0;
|
||||
my $header = pack('N',length $packet);
|
||||
$packet = $header . $packet;
|
||||
my $res = syswrite($sock, $packet, length $packet);
|
||||
&socket_disconnected($sock) unless $res == length $packet;
|
||||
}
|
||||
}
|
||||
|
||||
sub send_error($$) {
|
||||
my ($sock, $msg) = @_;
|
||||
print STDERR "sending error: '$msg'\n";
|
||||
my $doc = {'name' => '', [{'name' => 'error', 'message' => $msg, 'attr' => {}}], 'attr' => {}};
|
||||
&send_data($doc,$sock);
|
||||
}
|
||||
|
||||
sub socket_connected($) {
|
||||
my ($sock) = @_;
|
||||
print STDERR "connected: $sock\n";
|
||||
$read_set->add($sock);
|
||||
$outgoing_schemas{$sock} = [];
|
||||
$incoming_schemas{$sock} = [];
|
||||
$pending_handshake{$sock} = 1;
|
||||
my $flags = '';
|
||||
fcntl($sock, F_GETFL, $flags) or die "Couldn't get flags: $!";
|
||||
$flags |= O_NONBLOCK;
|
||||
fcntl($sock, F_SETFL, $flags) or die "Couldn't set flags: $!";
|
||||
}
|
||||
|
||||
sub socket_disconnected($) {
|
||||
my ($sock) = @_;
|
||||
print STDERR "disconnected: $sock\n";
|
||||
delete $outgoing_schemas{$sock};
|
||||
delete $incoming_schemas{$sock};
|
||||
delete $incoming_bufs{$sock};
|
||||
delete $pending_handshake{$sock};
|
||||
delete $connection_nums{$sock};
|
||||
delete $lobby_players{$sock};
|
||||
if(my $username = $socket_user_name{$sock}) {
|
||||
delete $user_name_socket{$username};
|
||||
delete $socket_user_name{$sock};
|
||||
print STDERR "searching for '$username'...\n";
|
||||
my $users = $initial_response->{'children'};
|
||||
for(my $n = 0; $n != @$users; ++$n) {
|
||||
my $user = $users->[$n];
|
||||
my $attr = $user->{'attr'};
|
||||
if($user->{'name'} eq 'user' and $attr->{'name'} eq $username) {
|
||||
my $len = @$users;
|
||||
print STDERR "OLD USERS: " . (join ',', @$users) . "\n";
|
||||
print STDERR "removing item $n...\n";
|
||||
my @new_users = ();
|
||||
for(my $m = 0; $m != @$users; ++$m) {
|
||||
push @new_users, $users->[$m] unless $m == $n;
|
||||
}
|
||||
@$users = @new_users;
|
||||
print STDERR "NEW USERS: " . (join ',', @$users) . "\n";
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
&sync_lobby();
|
||||
}
|
||||
$read_set->remove($sock);
|
||||
close $sock;
|
||||
}
|
||||
|
||||
sub sync_lobby {
|
||||
my $diff = &wml::get_diff($initial_response, $old_initial_response, 'gamelist_diff');
|
||||
while(my $sock = each %lobby_players) {
|
||||
&send_data($diff, $sock);
|
||||
}
|
||||
|
||||
$old_initial_response = &wml::deep_copy($initial_response);
|
||||
}
|
||||
|
||||
sub received_packet($$) {
|
||||
my ($sock, $packet) = @_;
|
||||
printf STDERR "received %d from $sock\n", length $packet;
|
||||
chop $packet;
|
||||
my $doc = &wml::read_binary($incoming_schemas{$sock}, $packet);
|
||||
my $text = &wml::write_text($doc);
|
||||
print STDERR "RECEIVED: $text";
|
||||
|
||||
unless($socket_user_name{$sock}) {
|
||||
if(my $login = &wml::has_child($doc, 'login')) {
|
||||
print STDERR "user attempting to log in...\n";
|
||||
my $attr = $login->{'attr'};
|
||||
my $username = $attr->{'username'};
|
||||
unless($username =~ /^[A-Za-z0-9_]{1,18}$/) {
|
||||
&send_error($sock, 'This username is not valid');
|
||||
return;
|
||||
}
|
||||
|
||||
foreach my $disallowed (@disallowed_names) {
|
||||
if($disallowed eq $login) {
|
||||
&send_error($sock, 'This username is disallowed');
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
if($user_name_socket{$login}) {
|
||||
&send_error($sock, 'This uesrname is already taken');
|
||||
}
|
||||
|
||||
print STDERR "log in okay; telling to join lobby\n";
|
||||
&send_data($join_lobby_response, $sock);
|
||||
|
||||
my $users = $initial_response->{'children'};
|
||||
push @$users, {'name' => 'user', 'children' => [], 'attr' => {'name' => $username, 'available' => 'yes'}};
|
||||
&send_data($initial_response, $sock);
|
||||
&sync_lobby();
|
||||
$lobby_players{$sock} = 1;
|
||||
$user_name_socket{$username} = $sock;
|
||||
$socket_user_name{$sock} = $username;
|
||||
return;
|
||||
} else {
|
||||
&send_error($sock, 'You must login first');
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
if($lobby_players{$sock}) {
|
||||
if(my $create_game = &wml::has_child($doc, 'create_game')) {
|
||||
push @games, &create_game($create_game, $socket_user_name{$sock});
|
||||
delete $lobby_players{$sock};
|
||||
} elsif(my $message = &wml::has_child($doc, 'message')) {
|
||||
my $attr = $message->{'attr'};
|
||||
$attr->{'sender'} = $socket_user_name{$sock};
|
||||
&send_data($doc, keys %lobby_players);
|
||||
}
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
sub handshake($) {
|
||||
my ($sock) = @_;
|
||||
my $buf = '';
|
||||
my $res = sysread($sock, $buf, 4);
|
||||
if($res != 4) {
|
||||
&socket_disconnected($sock);
|
||||
} else {
|
||||
my $buf = pack('N', $current_connection_num);
|
||||
$connection_nums{$sock} = $current_connection_num++;
|
||||
my $res = syswrite($sock, $buf, 4);
|
||||
if($res != 4) {
|
||||
&socket_disconnected($sock);
|
||||
} else {
|
||||
delete $pending_handshake{$sock};
|
||||
&send_data($login_response, $sock);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub create_game
|
||||
{
|
||||
my ($level, $owner) = @_;
|
||||
my $attr = $level->{'attr'};
|
||||
$attr->{'id'} = $current_game_id;
|
||||
{'owner' => $owner, 'members' => [$owner], 'players' => {$owner => 1}, 'level' => $level, 'id' => $current_game_id++};
|
||||
}
|
||||
|
||||
while(1) {
|
||||
my ($rh_set) = IO::Select->select($read_set, undef, undef, 1000);
|
||||
foreach my $sock (@$rh_set) {
|
||||
if($sock == $server_sock) {
|
||||
my $new_sock = $sock->accept();
|
||||
&socket_connected($new_sock);
|
||||
} elsif($pending_handshake{$sock}) {
|
||||
&handshake($sock);
|
||||
} else {
|
||||
my $buffer = '';
|
||||
if(my $buf = $incoming_bufs{$sock}) {
|
||||
my $len = $buf->{'length'};
|
||||
my $new_buf = '';
|
||||
my $res = sysread($sock, $new_buf, $len - length($buf->{'buf'}));
|
||||
if(not $res) {
|
||||
&socket_disconnected($sock);
|
||||
} else {
|
||||
$buf->{'buf'} .= $new_buf;
|
||||
if(length($buf->{'buf'}) == $len) {
|
||||
$buffer = $buf->{'buf'};
|
||||
delete $incoming_bufs{$sock};
|
||||
}
|
||||
}
|
||||
} else {
|
||||
my $header = '';
|
||||
my $res = sysread($sock, $header, 4);
|
||||
if($res != 4) {
|
||||
&socket_disconnected($sock);
|
||||
} else {
|
||||
my $len = unpack('N',$header);
|
||||
print STDERR "receiving $len chars...\n";
|
||||
my $res = sysread($sock, $buffer, $len);
|
||||
if($res != $len) {
|
||||
$incoming_bufs{$sock} = {'length' => $len, 'buf' => $buffer};
|
||||
$buffer = '';
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
&received_packet($sock, $buffer) if $buffer;
|
||||
}
|
||||
}
|
||||
}
|
||||
158
utils/wml.pm
158
utils/wml.pm
|
|
@ -1,5 +1,6 @@
|
|||
package wml;
|
||||
use strict;
|
||||
use Carp qw(confess);
|
||||
|
||||
$wml::open_element = 0, $wml::close_element = 1, $wml::schema_item = 2,
|
||||
$wml::literal_word = 3, $wml::first_word = 4, $wml::end_words = 256;
|
||||
|
|
@ -20,13 +21,13 @@ sub read_literal_word
|
|||
$word .= $char;
|
||||
}
|
||||
|
||||
die "Unexpected end of input";
|
||||
confess "Unexpected end of input";
|
||||
}
|
||||
|
||||
sub read_word
|
||||
{
|
||||
my ($schema,$chars) = @_;
|
||||
@$chars or die "Unexpected end of input";
|
||||
@$chars or confess "Unexpected end of input";
|
||||
my $char = shift @$chars;
|
||||
my $code = ord $char;
|
||||
if($code == $wml::literal_word) {
|
||||
|
|
@ -36,11 +37,11 @@ sub read_word
|
|||
push @$schema, $word;
|
||||
return &read_word($schema,$chars);
|
||||
} elsif($code < $wml::first_word) {
|
||||
die "Unexpected character '$code' when word was expected";
|
||||
confess "Unexpected character '$code' when word was expected";
|
||||
} else {
|
||||
my $index = $code - $wml::first_word;
|
||||
if($index >= @$schema) {
|
||||
die "Word '$index' ($code) not found in schema";
|
||||
confess "Word '$index' ($code) not found in schema";
|
||||
}
|
||||
|
||||
return $schema->[$index];
|
||||
|
|
@ -78,8 +79,8 @@ sub read_binary
|
|||
$cur = &add_child($cur,$word);
|
||||
push @stack, $cur;
|
||||
} elsif($code == $wml::close_element) {
|
||||
pop @stack or die "Illegal close element found";
|
||||
$cur = $stack[$#stack] or die "Illegal close element found";
|
||||
pop @stack or confess "Illegal close element found";
|
||||
$cur = $stack[$#stack] or confess "Illegal close element found";
|
||||
} elsif($code == $wml::schema_item) {
|
||||
my $word = &read_literal_word(\@chars);
|
||||
push @$schema, $word;
|
||||
|
|
@ -93,7 +94,7 @@ sub read_binary
|
|||
|
||||
if($#stack != 0) {
|
||||
my $stack = $#stack;
|
||||
die "Unexpected end of input: $stack items still unclosed";
|
||||
confess "Unexpected end of input: $stack items still unclosed";
|
||||
}
|
||||
|
||||
return $doc;
|
||||
|
|
@ -179,8 +180,8 @@ sub read_text
|
|||
} elsif($state eq 'CLOSE_ELEMENT') {
|
||||
if($char eq ']') {
|
||||
my $expected = $cur->{'name'};
|
||||
$expected eq $token or die "close element '$token' doesn't match current open element '$expected'";
|
||||
pop @stack or die "illegal close element '$token'";
|
||||
$expected eq $token or confess "close element '$token' doesn't match current open element '$expected'";
|
||||
pop @stack or confess "illegal close element '$token'";
|
||||
$cur = $stack[$#stack];
|
||||
$token = '';
|
||||
$state = 'SEEK';
|
||||
|
|
@ -206,7 +207,7 @@ sub read_text
|
|||
$cur->{'attr'}->{$name} = $value;
|
||||
}
|
||||
} elsif($state ne 'SEEK' or $#stack != 0) {
|
||||
die "unexpected end of WML document: state is '$state', stack size is $#stack";
|
||||
confess "unexpected end of WML document: state is '$state', stack size is $#stack";
|
||||
}
|
||||
|
||||
return $doc;
|
||||
|
|
@ -340,4 +341,141 @@ sub get_children
|
|||
return @res;
|
||||
}
|
||||
|
||||
sub deep_copy
|
||||
{
|
||||
my ($doc) = @_;
|
||||
my $res = {'name' => $doc->{'name'}, 'children' => [], 'attr' => {}};
|
||||
my $attrsrc = $doc->{'attr'};
|
||||
my $attrdst = $res->{'attr'};
|
||||
while(my ($key,$val) = each %$attrsrc) {
|
||||
$attrdst->{$key} = $val;
|
||||
}
|
||||
|
||||
my $childsrc = $doc->{'children'};
|
||||
my $childdst = $res->{'children'};
|
||||
foreach my $child (@$childsrc) {
|
||||
push @$childdst, &deep_copy($child);
|
||||
}
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub docs_equal
|
||||
{
|
||||
my ($doc1, $doc2) = @_;
|
||||
return 0 if $doc1->{'name'} ne $doc2->{'name'};
|
||||
my $attr1 = $doc1->{'attr'};
|
||||
my $attr2 = $doc2->{'attr'};
|
||||
while(my ($key, $value) = each %$attr1) {
|
||||
return 0 if $attr2->{$key} ne $value;
|
||||
}
|
||||
|
||||
while(my ($key, $value) = each %$attr2) {
|
||||
return 0 if $attr1->{$key} ne $value;
|
||||
}
|
||||
|
||||
my $children1 = $doc1->{'children'};
|
||||
my $children2 = $doc2->{'children'};
|
||||
|
||||
if(scalar(@$children1) != scalar(@$children2)) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
for(my $n = 0; $n < @$children1; ++$n) {
|
||||
return 0 if not &docs_equal($children1->[$n], $children2->[$n]);
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub get_diff
|
||||
{
|
||||
my ($doc1, $doc2, $diff_name) = @_;
|
||||
my $diffs = {'name' => $diff_name, 'children' => [], 'attr' => {}};
|
||||
my $attr1 = $doc1->{'attr'};
|
||||
my $attr2 = $doc2->{'attr'};
|
||||
my $d = 0;
|
||||
while(my ($key, $value) = each %$attr1) {
|
||||
if($attr2->{$key} ne $value) {
|
||||
my $child = {'name' => 'insert', 'children' => [], 'attr' => {$key => $value}};
|
||||
push @{$diffs->{'children'}}, $child;
|
||||
++$d;
|
||||
}
|
||||
}
|
||||
|
||||
while(my ($key, $value) = each %$attr1) {
|
||||
if(undef $attr1->{$key}) {
|
||||
my $child = {'name' => 'delete', 'children' => [], 'attr' => {$key => 'x'}};
|
||||
push @{$diffs->{'children'}}, $child;
|
||||
++$d;
|
||||
}
|
||||
}
|
||||
|
||||
my $children1 = $doc1->{'children'};
|
||||
my $children2 = $doc2->{'children'};
|
||||
|
||||
my %childmap1 = {};
|
||||
my %childmap2 = {};
|
||||
my %entities = {};
|
||||
|
||||
foreach my $child (@$children1) {
|
||||
my $a = $childmap1{$child->{'name'}};
|
||||
if(not $a) {
|
||||
$a = [$child];
|
||||
$childmap1{$child->{'name'}} = $a;
|
||||
$entities{$child->{'name'}} = 1;
|
||||
} else {
|
||||
push @$a, $child;
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $child (@$children2) {
|
||||
my $a = $childmap2{$child->{'name'}};
|
||||
if(not $a) {
|
||||
$a = [$child];
|
||||
$childmap2{$child->{'name'}} = $a;
|
||||
$entities{$child->{'name'}} = 1;
|
||||
} else {
|
||||
push @$a, $child;
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $key (keys %entities) {
|
||||
my $ndeletes = 0;
|
||||
my $a1 = ($childmap1{$key} or []);
|
||||
my $a2 = ($childmap2{$key} or []);
|
||||
for(my $n = 0; $n < @$a1 or $n < @$a2; ++$n) {
|
||||
if($n < @$a1 and $n < @$a2) {
|
||||
if(not &docs_equal($a1->[$n], $a2->[$n])) {
|
||||
my $diff = &get_diff($a1->[$n], $a2->[$n], $key);
|
||||
my $change = {'name' => 'change_child', 'children' => [$diff], 'index' => $n};
|
||||
push @{$diffs->{'children'}}, $change;
|
||||
++$d;
|
||||
}
|
||||
} elsif($n < @$a1) {
|
||||
my $insert = {'name' => 'insert_child', 'children' => [$a1->[$n]], 'attr' => {'index' => $n}};
|
||||
|
||||
push @{$diffs->{'children'}}, $insert;
|
||||
++$d;
|
||||
} else {
|
||||
my $attr = $a2->[$n];
|
||||
my $delete = {'name' => 'delete_child', 'children' => [{'name' => $attr->{'name'}, 'children' => [], 'attr' => {}}], 'attr' => {'index' => $n - $ndeletes}};
|
||||
++$ndeletes;
|
||||
push @{$diffs->{'children'}}, $delete;
|
||||
++$d;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return undef unless $d;
|
||||
return {'name' => '', 'children' => [$diffs], 'attr' => {}};
|
||||
}
|
||||
|
||||
sub single_child_doc
|
||||
{
|
||||
my ($name) = @_;
|
||||
my $res = {'name' => '', 'children' => [{'name' => $name, 'children' => [], 'attr' => {}}], 'attr' => {}};
|
||||
return $res;
|
||||
}
|
||||
|
||||
'Wesnoth Markup Language parser';
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue