#!/usr/bin/perl
#
# updates status based on jabber presence
#
######################### 
# $Id: presence_bot.pl 133 2005-03-25 19:42:27Z steve $
#########################
# $Log$
# Revision 1.9  2005/03/25 19:42:27  steve
# moved config file loading to a sub and added a "reload" command
#
# Revision 1.8  2004/08/17 02:27:55  steve
# minor bug fix
#
# Revision 1.7  2004/03/26 15:13:44  steve
# should hopefully not pester the user with reminders when there are none
#
# Revision 1.6  2004/02/12 06:19:21  steve
# cleaned up "remind" such that it only sends one message on connect
#
# Revision 1.5  2003/11/03 20:20:52  steve
# added a simple reminder system. put:
#   remind="1" in any of the modes and the reminders will be triggered then
#
# Revision 1.4  2003/10/11 01:27:11  steve
# added message parsing. first command "will be" for future offline messages
#
# Revision 1.3  2003/10/11 01:11:23  steve
# reworked the config a bit
#
# Revision 1.2  2003/08/11 06:31:35  steve
# fixed JID error and updated documentation
#
# Revision 1.1  2003/08/11 06:14:18  steve
# initial revision
#
#########################
use strict;

use Net::Jabber qw(Client);
use XML::Simple;
use Getopt::Std;

my ($version) = '$Revision: 133 $' =~ /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}/.presbot.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;

$cfg = load_config( $cfgfile );

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

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 => "Presence Bot", version => $version );


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

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

    if ( $res[0] eq "ok" ){
	print "presence bot was successfully registered\n";
	exit;
    }else{
	die "error registering: $res[1]\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 $users = $cfg->{users}->{user};
    my $user = get_userid( $cfg, $from_jid );
    return unless $user;

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

    return unless $user;

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

    if( $body =~ /\bwill\s+be\s+(.+)($|\<)/i ){
	my $nxtmsg = $1;
	$con->Send( $m->Reply( body => "Your next logoff message will be \"$nxtmsg\"." ) );
	$user_dat->{offline_override} = $nxtmsg;
	
    # removal
    }elsif( $body =~ /\bremind(?:\s+me)?\s+remove\b\s*(all\b\s*)?(.*)/i ){
	my $all  = $1;
	my $what = $2;
	my @found;

	if( !$all && !$what ){
	    $con->Send( $m->Reply( body => "What reminder do you want me to remove?" ));
	    return;
	} 
	$what = "." if( !$what && $all ); 
	@found = grep {$_->{act} =~ /$what/i} @{$user_dat->{remind}};
    

	if( ! @found && !( !$what && $all ) ){
	    $con->Send( $m->Reply( body => "No reminders found matching \"$what\"" ));
	    
	}elsif( @found == 1 || $all ){
	    my $message = "Removing: ";
	    my $l = shift @found;

	    # commify all the inner ones
	    foreach my $f (@found){
		$message .= $f->{act} .", ";
	    }
	    $message .= $l->{act};

	    $con->Send( $m->Reply( body => $message ));

	    my @remove = grep {$_->{act} !~ /$what/i} @{$user_dat->{remind}};
	    $user_dat->{remind} = \@remove;


	}elsif( @found > 1 ){
	    $con->Send( $m->Reply( body => "More than one reminder match \"$what\". Either be more specific, or ask me to 'remove all' of them." ));
	}

    }elsif( $body =~ /\bremind\s+(?:me\b\s*(?:(to|that)\b\s*)?)?(.*?)\s*$/i ){
	my $remind = {};
	$remind->{type} = $1;
	$remind->{act}  = $2;

	unless( $remind->{act} ){
	    $con->Send( $m->Reply( body => "Remind you to what?" ));
	    return;
	} 
	$remind->{type} = 'to' unless $remind->{type};

	$con->Send( $m->Reply( body => "You will be reminded ".
			       $remind->{type}." ".$remind->{act}.
			       " the next time you log in." ) );

	$user_dat->{remind} = [] unless exists $user_dat->{remind};
	push @{$user_dat->{remind}}, $remind;
	
    # print out reminders
    }elsif( $body =~ /\bremind(?:\s+me)?/i ){
	if( exists $user_dat->{remind} && @{$user_dat->{remind}} ){
	    my $message = "Current reminders:\n";
	    $message .= enum_reminders( $user_dat );
	    $con->Send( $m->Reply( body => $message ) );
	}else{
	    $con->Send( $m->Reply( body => "You do not currently have any reminders." ) );
	}
    }elsif( $body =~ /\breload\b/ ){
	$cfg = load_config( $cfgfile );
	$con->Send( $m->Reply( body => "Reloaded from \"$cfgfile\"." ));
    }else{
	$con->Send( $m->Reply( body => "Unknown command" ));
    }
}

sub load_config{
    my( $cfg_file ) = @_;

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   => 'presbot@LOCALHOST/presbot',
	     password => 'PASSWORDY',
	     port     => "5222",
	     ssl      => "0",
	     command  => "YOUR PROGRAM HERE",
	     flags    => "-f",
	     users => {  
		 user => {
		     $ENV{USER} => {
			 jabberid => "PUT YOUR JABBER ID HERE",
			 filters => {
			     phone => "s/(?:\d{3,3}[\.\-]\d{3,3}[\.\-]\d{4,4})//g",
			 },
			 mappings => {
			     online  => { status => 'here'},
			     offline => { status => 'away'},
			 }
		     }
		 } 
	     }
	 };

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

    return $cfg;
}

sub enum_reminders{
    my( $user_dat ) = @_;

    my $message = "";

    my $count = 1;
    foreach my $reminder (@{$user_dat->{remind}}) {
	$message .= "  ".($count++).". ".$reminder->{type}." ".$reminder->{act}.".\n";
    }

    return $message;
}

# 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');
	my $users = $cfg->{users}->{user};
	my $user = get_userid( $cfg, $from_jid );
	return unless $user;

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

	
	my $stat; # the name of the mapping
	$stat = "online" unless $pres->GetType();
	$stat = $pres->GetShow() if $pres->GetShow();
	$stat = "offline" if $pres->GetType() eq "unavailable";

	if( exists $user_dat->{mappings}->{$stat} ){
	    foreach my $map ( @{$user_dat->{mappings}->{$stat}} ){
		my $match;
		$match = $map->{match} if exists $map->{match};
		next if ( $match && $pres->GetStatus() !~ /$match/is );
		last if exists $map->{ignore};
		my $pstat = $map->{status};
		# the message is the status message of the presence
		my $pmessage = $pres->GetStatus() if $pres->GetStatus();
		$pmessage = $stat unless $pmessage; # a good default
		$pmessage = $map->{message} if exists $map->{message};


		# an override for offline messages
		if( $stat eq "offline" && $user_dat->{offline_override} ){
		    $pmessage = $user_dat->{offline_override};
		    delete $user_dat->{offline_override};

		}
		my @flags;
		push @flags, $cfg->{flags} if exists $cfg->{flags};
		my ($prev_pstat, $prev_pmesg ) 
		    = @{$prev_status{ $user }} 
		if exists $prev_status{ $user };

		if( exists $user_dat->{remind} 
		    && @{$user_dat->{remind}}
		    && exists $map->{remind} 
		    && $map->{remind} == 1 ){
		    my $message = "Current reminders:\n";
		    $message .= enum_reminders( $user_dat );
		    $con->MessageSend( to => $pres->GetFrom(), 
				       body => $message );
		}
		if( $prev_pstat ne $pstat && $prev_pmesg ne $pmessage ){
		    print "Setting $user\'s status to $pstat: $pmessage\n";
		    system( $cfg->{command}, @flags, $user, $pstat, $pmessage ); 
		    $prev_status{ $user } = [$pstat, $pmessage];
		}
		last;
	    }
	}
    }
}

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 ~/.presbot.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 ~/.presbot.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 ~/.presbot.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