#!/usr/local/bin/perl

##############################################################################
#
# users-agent
#
#   A Jabber agent that allows users to register with it and then search
# against the database for other users.
#
##############################################################################
my $VERSION = "1.2";


##############################################################################
#
# Perl Modules to use
#
##############################################################################
use Net::Jabber 2.0;
use DBI;
use strict;
use utf8;
use Getopt::Long;

my %optctl = ();
$optctl{debug} = 0;
$optctl{config} = "/usr/local/etc/jabber-users-agent.xml";
&GetOptions(\%optctl, "debug=i","config=s");

if (!(-f $optctl{config}))
{
    print STDERR "ERROR: Config file cannot be found:\n";
    print STDERR "          $optctl{config}\n";
    exit(1);
} 

open(PIDFILE,">/var/jabberd/pid/users-agent.pid");
    print PIDFILE "$$";
close(PIDFILE);

my $Debug = new Net::Jabber::Debug(level=>$optctl{debug},
                                   header=>"Users-Agent");

##############################################################################
#
# Intercept signals so that we can close down gracefully
#
##############################################################################
$SIG{HUP} = \&Stop;
$SIG{KILL} = \&Stop;
$SIG{TERM} = \&Stop;
$SIG{INT} = \&Stop;


##############################################################################
#
# Global Variables
#
##############################################################################
my %config;
my @routes;

##############################################################################
#
# Dynamic form.  Build once, reuse many many times...
#
##############################################################################
my $registerForm = new Net::Jabber::Stanza("x");
$registerForm->SetXMLNS('jabber:x:data');
$registerForm->SetData(instructions=>'To register, please fill out the following form.  Be as accurate as possible to make it easier for people to search for you.',
                       title=>'User-Agent Registration',
                       type=>'form');
my $registerFirst = $registerForm->AddField(type=>'text-single',
                                            var=>'first',
                                            label=>'First (Given)');
my $registerLast = $registerForm->AddField(type=>'text-single',
                                           var=>'last',
                                           label=>'Last (Family)');
my $registerNick = $registerForm->AddField(type=>'text-single',
                                           var=>'nick',
                                           label=>'Nick (Alias)');
my $registerEmail = $registerForm->AddField(type=>'text-single',
                                            var=>'email',
                                            label=>'Email');

my $searchForm = new Net::Jabber::Stanza("x");
$searchForm->SetXMLNS('jabber:x:data');
$searchForm->SetData(instructions=>'To search for a user fill out at least one of the fields below and submit the form.',
                     title=>'User-Agent Search',
                     type=>'form');
$searchForm->AddField(type=>'text-single',
                      var=>'first',
                      label=>'First (Given)');
$searchForm->AddField(type=>'text-single',
                      var=>'last',
                      label=>'Last (Family)');
$searchForm->AddField(type=>'text-single',
                      var=>'nick',
                      label=>'Nick (Alias)');
$searchForm->AddField(type=>'text-single',
                      var=>'email',
                      label=>'Email');
my $speed = $searchForm->AddField(type=>'list-single',
                                  label=>'Search Speed',
                                  value=>'fast',
                                  var=>'speed',
                                  desc=>'Select the speed of the search.  "Fast" matches your string to the beginning of the field only (ie. "b" would yield Bob,Bill,etc...)  "Slower" matches your string anywhere in the field (ie. "b" would yield Bob, Bill, Caleb, Robbie, etc...)');
$speed->AddOption(label=>'Fast / Less accurate',
                  value=>'fast');
$speed->AddOption(label=>'Slower / More extensive',
                  value=>'slow');


##############################################################################
#
# Read the Settings from disk
#
##############################################################################
&readConfigXML();

my $data_source = "DBI:mysql:database=".$config{mysql}->{dbname};

if ($config{mysql}->{host} ne '') {
    $data_source .= ";host=".$config{mysql}->{host}.";port=".($config{mysql}->{port} eq '' ? '3306' : $config{mysql}->{port});
}

my $dbh = DBI->connect($data_source,$config{mysql}->{username},$config{mysql}->{password});
#$dbh->trace(2) if (($optctl{debug} > 0) && defined($dbh));

##############################################################################
#
# Create the Component and connect to the server
#
##############################################################################
my $Component = new Net::Jabber::Component(debuglevel=>$optctl{debug});

$Component->Info(name=>"Users-Agent",
                 version=>$VERSION);

$Component->SetIQCallBacks("jabber:iq:register"=>{
                                                  get=>\&iqRegisterGetCB,
                                                  set=>\&iqRegisterSetCB,
                                                 },
                           "jabber:iq:search"=>{
                                                get=>\&iqSearchGetCB,
                                                set=>\&iqSearchSetCB,
                                               },
                           "http://jabber.org/protocol/disco#info"=>{
                                                get=>\&iqDiscoInfoGetCB,
                                               },
                           "http://jabber.org/protocol/disco#items"=>{
                                                get=>\&iqDiscoItemsGetCB,
                                               },
                          );

$Component->Execute(hostname=>$config{server}->{hostname},
                    port=>$config{server}->{port},
                    secret=>$config{server}->{secret},
                    componentname=>$config{component}->{name},
                   );

$Debug->Log0("Giving up and exiting...");
exit(0);


##############################################################################
#
# Stop - exit the program gracefully.
#
##############################################################################
sub Stop
{
    $Component->Disconnect();
    $dbh->disconnect();
    exit(0);
}


##############################################################################
#
# readConfigXML - read the /usr/local/etc/jabber-users-agent.xml file, parse it, and set config hash
#                 with the proper settings.
#
##############################################################################
sub readConfigXML
{

    my $parser = new XML::Stream::Parser(style=>"node");
    my $tree = $parser->parsefile($optctl{config});

    %config = %{&XML::Stream::XML2Config($tree)};

    #---------------------------------------------------------------------------
    # Parse the route table since the XML2Config cannot parse it correctly.
    #---------------------------------------------------------------------------
    #my $routes = &XML::Stream::GetXMLData("tree",$tree,"routes","","");
    #my $index = 0;
    #foreach my $route (&XML::Stream::GetXMLData("tree array",$routes,"route","",""))
    #{
    #    $config{routes}->{route}->[$index]->{field} = &XML::Stream::GetXMLData("value",$route,"","field","");
    #    $config{routes}->{route}->[$index]->{regexp} = &XML::Stream::GetXMLData("value",$route,"","regexp","");
    #    $config{routes}->{route}->[$index]->{server} = &XML::Stream::GetXMLData("value",$route,"","server","");
    #    $index++;
    #}
}


##############################################################################
#
# iqRegisterGetCB - callback for <iq type='get'... xmlns='jabber:iq:register'
#
##############################################################################
sub iqRegisterGetCB
{
    my $sid = shift;
    my $iq = shift;
    $Debug->Log1("iqRegisterGetCB: iq(",$iq->GetXML(),")");

    my %fields;

    my $fromJID = $iq->GetFrom("jid");

    my $command = "SELECT * FROM jud WHERE jid ='".$fromJID->GetJID()."';";

    my $sth = $dbh->prepare($command);
    $sth->execute;
    my $ref = $sth->fetchrow_hashref();
    if (defined($ref))
    {
        $fields{first} = $ref->{first};
        $fields{last} = $ref->{last};
        $fields{nick} = $ref->{nick};
        $fields{email} = $ref->{email};
        $fields{registered} = 1;
    }
    $sth->finish();

    my $iqReply = $iq->Reply(type=>"result");
    my $iqReplyQuery = $iqReply->NewQuery("jabber:iq:register");
    $iqReplyQuery->SetRegister(instructions=>"Fill in all of the fields to add yourself to the JUD.",
                               first=>$fields{first},
                               last=>$fields{last},
                               nick=>$fields{nick},
                               email=>$fields{email});

    $iqReplyQuery->SetRegistered() if exists($fields{registered});

    $registerFirst->RemoveValue();
    $registerFirst->SetValue($fields{first});
    $registerLast->RemoveValue();
    $registerLast->SetValue($fields{last});
    $registerNick->RemoveValue();
    $registerNick->SetValue($fields{nick});
    $registerEmail->RemoveValue();
    $registerEmail->SetValue($fields{email});

    $iqReplyQuery->AddX($registerForm);

    $Debug->Log1("iqRegisterGetCB: reply(",$iqReply->GetXML(),")");

    $Component->Send($iqReply);
}


##############################################################################
#
# iqRegisterSetCB - callback for <iq type='set'... xmlns='jabber:iq:register'
#
##############################################################################
sub iqRegisterSetCB
{
    my $sid = shift;
    my $iq = shift;
    $Debug->Log1("iqRegisterSetCB: iq(",$iq->GetXML(),")");

    my $fromJID = $iq->GetFrom("jid");
    my $query = $iq->GetQuery();

    my $iqReply = $iq->Reply(type=>"result");
    my $iqReplyQuery = $iqReply->NewQuery("jabber:iq:register");

    $dbh->do("DELETE FROM jud WHERE jid='".$fromJID->GetJID()."';");

    my @xData = $query->GetX("jabber:x:data");
    my %fields;
    $fields{first} = "";
    $fields{last} = "";
    $fields{nick} = "";
    $fields{email} = "";

    if ($#xData > -1)
    {
        foreach my $field ($xData[0]->GetFields())
        {
            $fields{$field->GetVar()} = $field->GetValue();
        }
    }
    else
    {
        $fields{first} = $query->GetFirst() if $query->DefinedFirst();
        $fields{last} = $query->GetLast() if $query->DefinedLast();
        $fields{nick} = $query->GetNick() if $query->DefinedNick();
        $fields{email} = $query->GetEmail() if $query->DefinedEmail();
    }

    $dbh->do("INSERT INTO jud VALUES(".$dbh->quote($fromJID->GetJID()).",'',".$dbh->quote($fields{first}).",".$dbh->quote($fields{last}).",".$dbh->quote($fields{nick}).",".$dbh->quote($fields{email}).");");

    $dbh->do("OPTIMIZE TABLE jud;");
    
    $Debug->Log1("iqRegisterSetCB: reply(",$iqReply->GetXML(),")");
    $Component->Send($iqReply);
}


##############################################################################
#
# iqSearchGetCB - callback for <iq type='get'... xmlns='jabber:iq:search'
#
##############################################################################
sub iqSearchGetCB
{
    my $sid = shift;
    my $iq = shift;
    $Debug->Log1("iqSearchGetCB: iq(",$iq->GetXML(),")");

    my $fromJID = $iq->GetFrom("jid");

    my $iqReply = $iq->Reply(type=>"result");
    my $iqReplyQuery = $iqReply->NewQuery("jabber:iq:search");
    $iqReplyQuery->SetSearch(instructions=>"Fill in a field to search for any matching Jabber users.",
                             first=>"",
                             last=>"",
                             nick=>"",
                             email=>"");

    $Debug->Log1("iqSearchGetCB: reply(",$iqReply->GetXML(),")");
    $Debug->Log1("iqSearchGetCB: searchForm(",$searchForm->GetXML(),")");
    $iqReplyQuery->AddChild($searchForm);

    $Debug->Log1("iqSearchGetCB: reply(",$iqReply->GetXML(),")");
    $Component->Send($iqReply);
}


##############################################################################
#
# iqSearchSetCB - callback for <iq type='set'... xmlns='jabber:iq:search'
#
##############################################################################
sub iqSearchSetCB
{ 
    my $sid = shift;
    my $iq = shift;
    $Debug->Log1("iqSearchSetCB: iq(",$iq->GetXML(),")");

    my $fromJID = $iq->GetFrom("jid");
    my $query = $iq->GetChild();

    my $iqReply = $iq->Reply(type=>"result");
    my $iqReplyQuery = $iqReply->GetChild("jabber:iq:search");

    my @commands;

    my @xData = $query->GetChild("jabber:x:data");
    my $hasForm = 0;
    if ($#xData > -1)
    {
        $hasForm = 1;

        my $likeSpeed = "";
        foreach my $field ($xData[0]->GetFields())
        {
            next unless ($field->GetVar() eq "speed");
            if ($field->GetValue() eq "slow")
            {
                $likeSpeed = "%";
            }	
        }

        foreach my $field ($xData[0]->GetFields())
        {
            next if ($field->GetValue() eq "");
            next if ($field->GetVar() eq "speed");

            push(@commands,$field->GetVar()." LIKE ".$dbh->quote($likeSpeed.$field->GetValue()."%"));
        }
    }
    else
    {

        push(@commands,"first LIKE ".$dbh->quote("%".$query->GetFirst()."%"))
            if ($query->DefinedFirst() && ($query->GetFirst() ne ""));

        push(@commands,"last LIKE ".$dbh->quote("%".$query->GetLast()."%"))
            if ($query->DefinedLast() && ($query->GetLast() ne ""));

        push(@commands,"nick LIKE ".$dbh->quote("%".$query->GetNick()."%"))
            if ($query->DefinedNick() && ($query->GetNick() ne ""));

        push(@commands,"email LIKE ".$dbh->quote("%".$query->GetEmail()."%"))
            if ($query->DefinedEmail() && ($query->GetEmail() ne ""));
    }

    if ($#commands < 0)
    {
        $iqReply = $iq->Reply(type=>"error");
        $iqReply->SetErrorCode("405");
        $iqReply->SetError("You must specify a field to search on.");
    }
    else
    {
        my $command = "SELECT * FROM jud WHERE ".join(" AND ",@commands)." order by last";
        $command .= " limit $config{mysql}->{limit}"
            if ($config{mysql}->{limit} ne "");
        $command .= ";";

        $Debug->Log1("iqCB: command($command)\n");
        my $sth = $dbh->prepare($command);
        $sth->execute;

        my $resultsReport;
        if ($hasForm)
        {
            $resultsReport = $iqReplyQuery->NewX("jabber:x:data");
            $resultsReport->SetData(type=>'result',
                                    title=>"Users-Agent Search Results");
            my $reported = $resultsReport->AddReported();
            $reported->AddField(var=>'jid',
                                type=>'jid-single',
                                label=>'JID');
            $reported->AddField(var=>'first',
                                label=>'First (Given)');
            $reported->AddField(var=>'last',
                                label=>'Last (Family)');
            $reported->AddField(var=>'nick',
                            label=>'Nick (Alias)');
            $reported->AddField(var=>'email',
                                label=>'Email');
        }
        
        my $count = 0;
        while (my $ref = $sth->fetchrow_hashref())
        {
            if ($hasForm == 0)
            {
                $iqReplyQuery->AddItem(jid=>$ref->{jid},
                                       first=>$ref->{first},
                                       last=>$ref->{last},
                                       nick=>$ref->{nick},
                                       email=>$ref->{email});
            }
            else
            {
                my $item = $resultsReport->AddItem();
                $item->AddField(var=>"jid",
                                value=>$ref->{jid});
                $item->AddField(var=>"first",
                                value=>$ref->{first});
                $item->AddField(var=>"last",
                                value=>$ref->{last});
                $item->AddField(var=>"nick",
                                value=>$ref->{nick});
                $item->AddField(var=>"email",
                                value=>$ref->{email});
            }
            $count++;
        }
        $sth->finish();
        $iqReplyQuery->SetTruncated()
            if (($config{mysql}->{limit} ne "") &&
                ($count == $config{mysql}->{limit}));
    }

    $Component->Send($iqReply);
}


##############################################################################
#
# iqDiscoInfoGetCB - callback for disco
#
##############################################################################
sub iqDiscoInfoGetCB
{
    my $sid = shift;
    my $iq = shift;
    $Debug->Log1("iqDiscoGetCB: iq(",$iq->GetXML(),")");

    my $fromJID = $iq->GetFrom("jid");

    my $iqReply = $iq->Reply(type=>"result");
    my $iqReplyQuery = $iqReply->NewQuery("http://jabber.org/protocol/disco#info");
    $iqReplyQuery->AddIdentity(category=>"directory",
                               type=>"user",
                               name=>"Users-Agent"
                              );
    $iqReplyQuery->AddFeature(var=>"jabber:iq:register");
    $iqReplyQuery->AddFeature(var=>"jabber:iq:search");

    $Debug->Log1("iqDiscoGetCB: reply(",$iqReply->GetXML(),")");
    $Component->Send($iqReply);
}


##############################################################################
#
# iqDiscoItemsGetCB - callback for disco
#
##############################################################################
sub iqDiscoItemsGetCB
{
    my $sid = shift;
    my $iq = shift;
    $Debug->Log1("iqDiscoGetCB: iq(",$iq->GetXML(),")");

    my $toJID = $iq->GetTo("jid");
    my $fromJID = $iq->GetFrom("jid");
    my $query = $iq->GetChild("http://jabber.org/protocol/disco#items");
    
    my $iqReply = $iq->Reply(type=>"result");
    my $iqReplyQuery = $iqReply->GetChild("http://jabber.org/protocol/disco#items");

    if (!$query->DefinedNode())
    {
        $iqReplyQuery->AddItem(jid=>$toJID,
                               node=>"by-first",
                               name=>"Search by First Name"
                              );
        $iqReplyQuery->AddItem(jid=>$toJID,
                               node=>"by-last",
                               name=>"Search by Last Name"
                              );
        $iqReplyQuery->AddItem(jid=>$toJID,
                               node=>"by-email",
                               name=>"Search by Email"
                              );
        $iqReplyQuery->AddItem(jid=>$toJID,
                               node=>"by-nick",
                               name=>"Search by Nick"
                              );
    }
    elsif ($query->GetNode() =~ /^by-(first|last|email|nick)$/)
    {
        my $column = $1;

        foreach my $first ("A".."Z")
        {
            my $count = &colCount($dbh,$column,$first);
            $iqReplyQuery->AddItem(jid=>$toJID,
                                   node=>$query->GetNode()."-".$first,
                                   name=>"$first ($count)",
                                  );
        }
    }
    elsif ($query->GetNode() =~ /^by-(first|last|email|nick)-([A-Z])$/)
    {
        my $column = $1;
        my $first = $2;

        my %count;
        my $command = 'SELECT SUBSTRING(LOWER('.$column.'),1,2) AS sub FROM jud WHERE '.$column.' LIKE "'.$first.'%";';
        my $sth = $dbh->prepare($command);
        $sth->execute;
        
        while (my $ref = $sth->fetchrow_hashref())
        {
            $count{$ref->{sub}}++;
        }
        
        foreach my $second ("a".."z")
        {
            my $count = $count{lc($first.$second)};
            if ($count > 0)
            {
                $iqReplyQuery->AddItem(jid=>$toJID,
                                       node=>$query->GetNode().$second,
                                       name=>"$first$second ($count)",
                                      );
            }
        }
    }
    elsif ($query->GetNode() =~ /^by-(first|last|email|nick)-([A-Z][a-z])$/)
    {
        my $column = $1;
        my $first = $2;

        my %count;
        my $command = 'SELECT SUBSTRING(LOWER('.$column.'),1,3) AS sub FROM jud WHERE '.$column.' LIKE "'.$first.'%";';
        my $sth = $dbh->prepare($command);
        $sth->execute;
        
        while (my $ref = $sth->fetchrow_hashref())
        {
            $count{$ref->{sub}}++;
        }    
            
        foreach my $second ("a".."z")
        {
            my $count = $count{lc($first.$second)};
            if ($count > 0)
            {
                $iqReplyQuery->AddItem(jid=>$toJID,
                                       node=>$query->GetNode().$second,
                                       name=>"$first$second ($count)",
                                      );
            }
        }
    }
    elsif ($query->GetNode() =~ /^by-(first|last|email|nick)-([A-Z][a-z][a-z])$/)
    {
        my $column = $1;
        my $search = $2;

        my $command = 'SELECT jid,first,last FROM jud WHERE '.$column.' LIKE "'.$search.'%";';
        my $sth = $dbh->prepare($command);
        $sth->execute;
        
        my $items = "";
        while (my $ref = $sth->fetchrow_hashref())
        {
            my $name = $ref->{first}." ".$ref->{last};
            $name =~ s/\n//g;
            $name = &XML::Stream::EscapeXML($name);

            $items .= "<item jid='".$ref->{jid}."' name='$name'/>";
        }

        $iqReplyQuery->InsertRawXML($items);
    }

    $Component->Send($iqReply);
}


sub colCount
{
    my $dbh = shift;
    my $column = shift;
    my $like = shift;

    my $sth = $dbh->prepare("SELECT COUNT(*) AS count FROM jud WHERE $column LIKE '".$like."%';");
    $sth->execute();
    my $count = $sth->fetchrow_hashref;
    return $count->{count};
}