#!/usr/bin/perl
#
# a bot for controlling geekhaus
#
######################### 
# $Id: haus_bot.pl 103 2004-03-09 06:03:03Z steve $
#########################
# $Log$
# Revision 1.1  2004/03/09 06:03:03  steve
# added
#
#
#########################
use strict;

use Net::Jabber qw(Client);
use Frontier::Client;

use XML::Simple;
use Getopt::Std;

my ($version) = '$Revision: 103 $' =~ /Revision:\s*(.+)\$/;

our ( $opt_h, $opt_V, $opt_c, $opt_r );
getopts("hVc:r");

usage() if $opt_h;
die "$0 version: $version\n" if $opt_V;

my $cfgfile = "$ENV{HOME}/.hausbot.xml";
$cfgfile    = $opt_c if $opt_c;
my $register = $opt_r;

# stores the previous status so duplicates aren't entered in
my %prev_status = ();

my $xs = new XML::Simple( forcearray => ['user', 'xa', 'away', 'offline', 
					 'dnd', 'online'], 
			  keyattr => { user => "+name"} );

my $cfg;

# if there's no config file, and we're not explicitly asking for one to be 
# loaded, create a new data structure.
if( !-e $cfgfile && !$opt_c ){ 

    $cfg = { 
	     botjid   => 'hausbot@LOCALHOST/hausbot',
	     x10rpc   => 'http://warehaus:8042/RPC2', 
	     password => 'PASSWORDY',
	     port     => "5222",
	     ssl      => "0",
	 };

    my $xml = $xs->XMLout( $cfg );
    open XML_OUT, ">$cfgfile" or die "cannot open $cfgfile for writing: $!\n";
    print XML_OUT $xml, "\n";
    close XML_OUT;

    die "A template config file has been written to $cfgfile. Please edit it and rerun $0\n";
}else{
    $cfg = $xs->XMLin( $cfgfile );
}

# end config 
###############################################################################

my $x10rpc = Frontier::Client->new( url => $cfg->{x10rpc} );

my $jid = new Net::Jabber::JID( $cfg->{botjid} );

my $con = new Net::Jabber::Client();

$SIG{HUP} = \&Stop;
$SIG{KILL} = \&Stop;
$SIG{TERM} = \&Stop;
$SIG{INT} = \&Stop;

my %copts = ();

$con->SetCallBacks( presence => \&presCallback, message => \&messageCallback );

$copts{hostname} = $jid->GetServer();
$copts{port}     = $cfg->{port} if exists $cfg->{port};
$copts{ssl}      = $cfg->{ssl}  if exists $cfg->{ssl};

$con->Connect( %copts );

unless( $con->Connected() ){
    die "cannot connect to $copts{hostname} on port $copts{port}\n";
}


$con->Info( name => "Haus Bot", version => $version );


my $resource = $jid->GetResource();
$resource = "hausbot" unless $resource;

if( $register ){
    my @res = $con->RegisterSend( 
			to        => $copts{hostname}, 
			username  => $jid->GetUserID(),
			resource  => $resource,
			password  => $cfg->{password},
			email     => 'hbot@fnord.gov',
			key       => "fnord" );

    if ( $res[0] eq "ok" ){
	print "haus bot was successfully registered\n";
	exit;
    }else{
	print "error registering: \n";
	use Data::Dumper;
	print Dumper \@res;
	die "blah\n";
    } 
}

my @result = $con->AuthSend( username => $jid->GetUserID(), 
			     password => $cfg->{password},
			     resource => $resource );

unless ( $result[0] eq "ok" ){
    die "error logging in: $result[1]\n";
} 


print "Getting Roster to tell server to send presence info...\n";

$con->RosterGet();

print "sending presence\n";
$con->PresenceSend();

print "daemon started\n";
while( defined ($con->Process() ) ){

}

print "ERROR: The connection was killed...\n";

exit(0);


#### helper subs

sub messageCallback {
    my ( $sesid, $m ) = @_;

    my $from_jid = $m->GetFrom('jid');

    my $body = $m->GetBody();

    if( $body =~ /\bturn\s+(.+)($|\<)/i ){
	my $cmd = $1;
	my @args = split /\s+/, $cmd;
	my $result = $x10rpc->call('turn', @args);

	$con->Send( $m->Reply( body => "Turning $args[0] $args[1]." ) );

    }else{
	$con->Send( $m->Reply( body => "Unknown command. Try \"turn\"\n" ));
    }
}

# takes a cfg ref and a jid ref
sub get_userid( $$ ){

    my ($cfg, $from_jid) = @_;

    my $found;

    my $users = $cfg->{users}->{user};

    # look through the known users and check their mappings
    foreach my $user (keys %{$users} ){
	my $jid = $users->{$user}->{jabberid};
	
	# case-insensitive comparison
	if( lc($from_jid->GetJID('base')) eq lc($jid) ){

	    $found = $user;
	}
    }

    return $found;
}

sub presCallback {
    my ( $sesid, $pres ) = @_;

    # auto-subscribe
    if( $pres->GetType() eq "subscribe" ){
	print "subscribed ".$pres->GetFrom()."\n";
	$con->Subscription( type => "subscribed", to => $pres->GetFrom() );
	$con->Subscription( type => "subscribe", to => $pres->GetFrom() );
    }elsif( $pres->GetType() eq "unsubscribe" ){
	print "unsubscribed ".$pres->GetFrom()."\n";
	$con->Subscription( type => "unsubscribed", to => $pres->GetFrom() );
    }else{

	my $from_jid = $pres->GetFrom('jid');

    }
}

sub Stop
{
    print "Exiting...\n";
    $con->Disconnect();
    exit(0);
}


sub usage(){
    die <<USAGE;
usage: $0 [options]
 
options:
    -h          this help
    -c FILE     load FILE as the config file. default is ~/.hausbot.xml
    -r          registers the bot with the server and exits
    -V          print version information

Copyright(C) 2003 Steve Pomeroy <steve\@staticfree.info>
Licensed under the GNU GPL. See documentation for complete details.
USAGE

}

__END__

=head1 NAME

presence_bot.pl - a bot to 

=head1 SYNOPSIS

B<presence_bot.pl> S<[ B<-h> ]> S<[ -c I<file> ]> S<[ -V ]> S<[ -r ]>

=head1 DESCRIPTION

A Jabber bot that monitors one or more users and executes a command based on
status message and triggers.

It consists primarily of a set of mappings from Jabber presence events to 
user-specific events. These mappings and other configuration info is stored
in ~/.hausbot.xml. This file will be automatically created for you if one does
not exist, although B<you must edit it before use>.

Once you have configured the XML file appropriately, run the bot with the -r
flag to have it register itself on the server. After it has successfully 
registered, you can run it with no parameters just fine.

=head1 CONFIG FILE NOTES

The following mappings can be used:

<offline />
<online /> 
<dnd /> 
<xa /> 
<away />
<chat /> 

Mappings have the following attributes:

=over 8

=item status="foo"

Sets the status to be "foo"

=item ignore="1"

Any presence event matching this will be ignored

=item match="regexp"

This Perl regexp is run against the status message. The mapping is only 
applied if the regexp matches, otherwise it falls through to the next mapping. 
Matching is done in a top-down manner. All matches are case-insensative and 
treated as a single line.

=item message="foo"

Sets the status message to "foo"

=back 

=head1 OPTIONS

=over 8

=item B<-h>

This help

=item B<-c configfile>

Uses configfile instead of ~/.hausbot.xml

=item B<-r>

Registers the bot on the server.

=item B<-V>

displays the version number

=back

=head1 ENVIRONMENT

No environment variables are used.

=head1 AUTHOR

Steve Pomeroy <steve@staticfree.info>
http://staticfree.info/

=head1 LICENSE

Copyright (C) 2003 Steve Pomeroy <steve@staticfree.info>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program 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 General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA

=head1 SEE ALSO

perl(1), L<PhysStat>, L<Net::Jabber>, L<XML::Simple>

=head1 BUGS

None known.

=cut