Volity::Bot - A framework for creating automated Volity players

package Volity::Bot;

############################################################################
# LICENSE INFORMATION - PLEASE READ
############################################################################
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License as published by the Free Software Foundation; either
# version 2.1 of the License, or (at your option) any later version.
#
# This library 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
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
############################################################################

# A package for automated Volity players.
# Should be suitable for both 'ronin' and 'retainer' bots.

use warnings;
use strict;
use base qw( Volity::Jabber Class::Data::Inheritable );
use fields qw( muc_jid referee_jid name_modifier nickname am_seated am_ready occupied_seats seat_id );

use Carp qw( croak );
use POE;
use Time::HiRes qw(gettimeofday);

foreach (qw( name description algorithm )) {
    __PACKAGE__->mk_classdata($_);
}

# seat: This is here for backwards compatibility.
sub seat {
    my $self = shift;
    return $self->seat_id(@_);
}

# We override the constructor to perform some sanity checks, and
# insert additional config information based on class data.
sub new {
    my $invocant = shift;
    my $class    = ref($invocant) || $invocant;
    my ($config) = @_;
    foreach (qw( user host password resource )) {
        if ( defined( $$config{$_} ) ) {
            next;
        }
        else {
            unless ( defined( $class->$_ ) ) {
                croak("The $class class doesn't have any $_ data defined!!");
            }
            $$config{$_} = $class->$_;
        }
    }
    my $self = $class->SUPER::new($config);
    $self->name_modifier(q{});
    $self->occupied_seats({});
    return $self;
}

sub init_finish {
    my $self = $_[OBJECT];
    $self->logger->debug("New bot, reporting for duty.");
    $self->logger->debug(
        "I will try to join the MUC at this JID: " . $self->muc_jid );

    # XXX This doesn't handle the case for when the bot fails to join, due
    # to someone using its nickname already present in the MUC.
    # I'll need to add an error handler for when this happens.
    $self->join_table;

}

sub stop {
    my $self = shift;
    $self->kernel->post( $self->alias, 'shutdown_socket', 0 );
}

# This presence handler detects a table's referee through MUC attributes.
# It also watches for general presence updates, and updates the user's
# internal roster object as needed.
sub jabber_presence {
    my $self = shift;
    my ($node) = @_;
    my $x;    # Hey, that's the name of the element, OK?
    if ( defined( $node->attr('type') ) and $node->attr('type') eq 'error' ) {

        # Ruh roh. Just print an error message.
        my $error = $node->get_tag('error');
        my $code  = $error->attr('code');
        $self->logger->debug("Got an error ($code):");
        my $message = $error->data || "Something went wrong.";
        $self->logger->debug($message);
        if ( $code == 409 ) {

            # Aha, we have failed to join the conf.
            # Change our name and try again.
            if ( $self->name_modifier ) {
                $self->name_modifier( $self->name_modifier + 1 );
            }
            else {
                $self->name_modifier(1);
            }
            $self->join_table;
        }
        return;
    }
    if (
        ( $node->get_tag('x') )
        and (
            ($x) =
            grep( { $_->attr('xmlns') eq "http://jabber.org/protocol/muc#user" }
                $node->get_tag('x') )
        )
        )
    {

        # Aha, someone has joined the table.
        my $affiliation = $x->get_tag('item')->attr('affiliation');
        $self->logger->debug( "I see presence from " . $node->attr('from') );
	
	# See if they have a caps (JEP-0115) element in their presence.
	# If so, this may clue us in to what sort of Volity entity this is.
	if ((my $c = $node->get_tag('c')) && 
	    ($node->get_tag('c')->attr('node') eq "http://volity.org/protocol/caps")) {
	    my $volity_role = $c->attr('ext');
	    if ($volity_role eq "referee") {
		# We've found the referee!
#		$self->referee_jid( $node->attr('from') );
                $self->referee_jid( $x->get_tag('item')->attr('jid') );

		# Inform the referee that we're a volity-aware entity, rather
		# than just a regular jabber client, so that it will honour us
		# with RPC messages
		$self->send_volity_rpc_to_referee("send_state");
	    }
        }
	
	
    }
}

# We override Volity::Jabber's send_presence in order to attach some
# additional JEP-0115 information.
sub send_presence {
    my $self = shift;
    my ($config) = @_;
    $config ||= {};
    $$config{caps} = {
	node => "http://volity.org/protocol/caps",
	ext => "bot",
	ver => "1.0",
    };
    return $self->SUPER::send_presence($config);
}

sub join_table {
    my $self = shift;

    # Attempt to join the MUC with our best idea of a nickname.
    # If this fails, the error handler will increment the nick-
    # modifier.
    my $nick = $self->name . $self->name_modifier;
    $self->join_muc( { jid => $self->muc_jid, nick => $nick } );
    $self->nickname($nick);
}

sub is_jid {
    my ($jid) = @_;
    if ( $jid =~ /^[\w-]+@[\w-]+(?:\.[\w-]+)*(?:\/[\w-]+)?/ ) {
        return $jid;
    }
    else {
        return;
    }
}

sub declare_readiness {
    my $self = shift;
    $self->logger->debug(
        "Sending a declaration of readiness to " . $self->referee_jid );
    $self->send_rpc_request(
        {
            to         => $self->referee_jid,
            id         => 'ready-request',
            methodname => 'volity.ready',
            handler    => 'ready',
        }
        );
}

sub sit {
    my $self = shift;
    $self->logger->debug(
        "Sitting down at table with referee " . $self->referee_jid );
    $self->send_rpc_request(
        {
            to         => $self->referee_jid,
            id         => 'sit',
            methodname => 'volity.sit',
            args       => [ $self->jid ],
            handler    => 'seat',
        }
        );
}

sub handle_rpc_request {
    my $self       = shift;
    my ($rpc_info) = @_;
    my $method     = $$rpc_info{method};

    my @response;

    eval {
    if ( $method =~ /^game\.(.*)$/ ) {
        my $subclass_method = "game_rpc_$1";

        @response = $self->try_to_call_subclass_method($subclass_method, @{$$rpc_info{args}});
    }
    elsif ( $method =~ /^volity\.(.*)$/ ) {
        my $subclass_method = "volity_rpc_$1";
	@response = $self->try_to_call_subclass_method($subclass_method, @{$$rpc_info{args}});
	if ( $self->am_seated && not( $self->am_ready ) ) {
	    $self->declare_readiness;
	}
    }
	
    # All this stuff about @response is copied from Volity::Bookkeeper.
    # This uses the callback's return value (or lack thereof) to
    # decide on what sort of response to make. It's not all that important
    # because usually nobody cares what the bot's responses are, but there 
    # are some RPCs (like volity.leave_table) where it can be important.
    if (@response) {
	my $response_flag = $response[0];
	if ($response_flag eq 'fault') {
	    # Oh, there's some in-game problem with the player's request.
	    # (This is here for backwards compatibility.)
	    $self->send_rpc_fault($$rpc_info{from}, $$rpc_info{id}, @response[1..$#response]);
	} elsif ($response_flag =~ /^\d\d\d$/) {
	    # Looks like a fault error code. So, send back a fault.
	    $self->send_rpc_fault($$rpc_info{from}, $$rpc_info{id}, @response);
	} else {
	    # The game has a specific, non-fault response to send back.
	    $self->send_rpc_response($$rpc_info{from}, $$rpc_info{id}, [@response]);
	}
    } else {
	# We have silently approved the request,
	# so send back a minimal positive response.
	$self->send_rpc_response($$rpc_info{from}, $$rpc_info{id}, ["volity.ok"]);
    }	
    }; # End of eval block.
    if ($@) {
	$self->report_rpc_error(@_);
	return;
    }
}

sub try_to_call_subclass_method {
    my $self = shift;
    my ($subclass_method, @args) = @_;
    if ($self->can($subclass_method)) {
	$self->$subclass_method(@args);
    }
    else {
	$self->logger->warn("I seem to be lacking a $subclass_method method.");
    }
}

sub rpc_response_ready {
    my $self      = shift;
    my ($message) = @_;
    my ($flag)    = @{ $$message{response} };

    $self->logger->debug("Got a $flag response to my ready request.");
}

sub rpc_response_seat {
    my $self      = shift;
    my ($message) = @_;
    my ($flag)    = @{ $$message{response} };
    $self->logger->debug("Got a $flag response to my seat request.");

    # Possibly babble to the MUC, if I can't sit down.
    # XXX This should be internationalized.
    my $chat_message;
    if ( $flag eq 'volity.no_seats' ) {
        $chat_message = "I can't sit down; all the seats are full.";
    }
    if ($chat_message) {
        $self->send_message(
            {
                to   => $self->muc_jid,
                type => "groupchat",
                body => $message,
            }
            );
    }
}

# Here are some methods defining default behavior for basic volity.* calls.

sub volity_rpc_player_sat {
    my $self = shift;
    my ($player_jid, $seat_id) = @_;

    $self->logger->debug("volity_rpc_player_sat");
    # update the list of sitting players -- first remove the player from the
    # seat it's occupying (only a sat rpc gets sent when a player changes
    # seats without standing in between)
    foreach my $seat (keys(%{$self->occupied_seats})) {
	my $players = $self->occupied_seats->{$seat};
	@$players = grep($_ ne $player_jid, @$players);
	delete $self->occupied_seats->{$seat} unless @$players;
    }

    # now add the player to its new seat
    $self->occupied_seats->{$seat_id} = [] 
    	unless exists($self->occupied_seats->{$seat_id});
    push(@{$self->occupied_seats->{$seat_id}}, $player_jid);

    # find ourselves
    if ( $player_jid eq $self->jid ) {
	$self->am_seated(1);
	$self->seat( $seat_id );
    }

    # a player sitting unreadies everyone at the table
    $self->am_ready(0);
}

sub volity_rpc_player_stood {
    my $self = shift;
    my ($player_jid) = @_;

    $self->logger->debug("volity_rpc_player_stood");
    # update the list of sitting players. Not the most efficient code, but for
    # the number & size of the lists we'll be dealing with it should still be
    # fast enough.
    foreach my $seat (keys(%{$self->occupied_seats})) {
	my $players = $self->occupied_seats->{$seat};
	@$players = grep($_ ne $player_jid, @$players);
	delete $self->occupied_seats->{$seat} unless @$players;
    }

    if ( $player_jid eq $self->jid ) {
	$self->am_seated(0);
    }

    # the python referee doesn't send player_unready RPCs when someone
    # stands. "...when handling RPCs that are documented as automatically 
    # unreadying all players. (Sit, stand, and so on.) The client is 
    # required to know about this automatic unreadying, so there's no 
    # need for us to send out notices about it..."
    $self->am_ready(0); 
}

sub volity_rpc_player_unready {
    my $self = shift;
    my ($player_jid) = @_;
    if ( $player_jid eq $self->jid ) {
	$self->am_ready(0);
    }

}

sub volity_rpc_player_ready {
    my $self = shift;
    my ($player_jid) = @_;
    if ( $player_jid eq $self->jid ) {
	$self->am_ready(1);
    }
}

sub volity_rpc_end_game {
    my $self = shift;
    $self->am_ready(0);
}

sub volity_rpc_suspend_game {
    my $self = shift;
    $self->am_ready(0);
}

sub volity_rpc_resume_game {
    my $self = shift;
    $self->am_ready(0);
}

sub volity_rpc_kill_game {
    my $self = shift;
    $self->am_ready(0);
}

sub volity_rpc_show_table {
    my $self = shift;
    $self->am_ready(0);
}

sub volity_rpc_record_games {
    my $self = shift;
    $self->am_ready(0);
}

sub volity_rpc_language {
    my $self = shift;
    $self->am_ready(0);
}

sub volity_rpc_leave_table {
    my $self = shift;
    if ($self->seat) {
	return ("609", "I can't leave while I'm sitting down.");
    }
    # So long, suckers.
    $self->stop;
}

sub send_game_rpc_to_referee {
    my $self = shift;
    my ($method, @args) = @_;
    my %args = (
		to=>$self->referee_jid,
		id=>scalar(gettimeofday()),
		methodname=>"game.$method",
		args=>\@args,
		);
    my $response_callback_method = "rpc_response_game_" . $method;
    if ($self->can($response_callback_method)) {
	$args{handler} = "game_" . $method;
    }
    else {
	$self->logger->warn("Calling RPC method game.$method without a corresponding callback method defined. (It would be called $response_callback_method.)");
    }

    $self->make_rpc_request(\%args);
}

sub send_volity_rpc_to_referee {
    my $self = shift;
    my ($method, @args) = @_;
    my %args = (
		to=>$self->referee_jid,
		id=>scalar(gettimeofday()),
		methodname=>"volity.$method",
		args=>\@args,
		);
    my $response_callback_method = "rpc_response_volity_" . $method;
    if ($self->can($response_callback_method)) {
	$args{handler} = "volity_" . $method;
    }
    else {
	$self->logger->warn("Calling RPC method volity.$method without a corresponding callback method defined. (It would be called $response_callback_method.)");
    }

    $self->make_rpc_request(\%args);
}

# We want to respond to disco info requests with a declaration that we are
# a bot, in an attached JEP-0128 form with a "volity-role" field.
sub handle_disco_info_request {
    my $self = shift;
    my ($iq) = @_;
    my $query = $iq->get_tag('query');
    $self->logger->debug("I got a disco info request from " . $iq->attr('from'));
    # Build the list of disco items to return.
    my @items;
    my $identity = Volity::Jabber::Disco::Identity->new({category=>'volity',
							 type=>'bot',
						     });
    push (@items, $identity);

    my $role_field = Volity::Jabber::Form::Field->new({var=>"volity-role"});
    $role_field->values("bot");

    # Send them off.
    $self->send_disco_info({
	to=>$iq->attr('from'),
	id=>$iq->attr('id'),
	items=>\@items,
	fields=>[$role_field],
    });
}


1;