#!/bin/sh
#-*-Perl-*-

exec perl -w -x $0 "$@";

#!perl

### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
#
# datasink - a message archiving component
# ========================================
#
# This is an implementation of JEP-0136 (Message Archiving).
# See http://www.jabber.org/jeps/jep-0136.html for details.
#
# I implemented this for my personal use with jwchat
# (http://jwchat.sourceforge.net) a web based jabber client.
#
# Supported features:
# * uses mysql to store data
# * built in support for Service Discovery
#
# For better useability there is a slight difference with the protocol
# defined in JEP 0136. Retrieving collections honor an additional
# attribute 'jid' to get only those collections matching conversation
# with 'jid', e.g.
#
# <iq type='get' id='a1' to='server'>
#  <archive xmlns='http://jabber.org/protocol/archive' jid='zz@boyzzbrigade.org'/>
# </iq>
#
# would return only those collections for zz@boyzzbrigade.org
#
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
#
# Installation instructions
# =========================
#
# * create a database for use with datasink
# * import sql schema from datasink.sql
# * set timezone to UTC for mysql to make timestamps work correctly
# * install required perl modules
#   - Net::Jabber
#   - DBI
#   - Data::Dumper
#   - Digest::MD5
#   - Getopt::Long
# * edit your jabber server to let datasink connect as a component
# * edit config.xml to suit your needs
# * restart your jabber server
# * start datasink
#
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
#
my $VERSION = "0.2.6";

# BEGIN LICENSE BLOCK
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
#
# Copyright (C) 2004 Stefan Strigler <steve@zeank.in-berlin.de>
#
# many ideas and code taken from users-agent and ChatBot
# (thanks to Ryan Eatmon <reatmon@jabber.org>)
#
# 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.
#
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
# END LICENSE BLOCK

use strict; # har har

use Net::Jabber qw ( Component ) ;
use Digest::MD5 qw(md5_hex);
use Data::Dumper;
use Getopt::Long;
use DBI;

my %optctl = ();
$optctl{debug} = 0;
$optctl{config} = "config.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);
} 

# this one's unused atm as my own debugger is better (imo) ;-)
my $Debug = new Net::Jabber::Debug(level=>$optctl{debug},
                                   header=>"Users-Agent");
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
#
# global vars
#
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###

my %config; # holds the config

### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
#
# Setup the signals so that we can ctrl-c datasink and have it shut down
# gracefully.
#
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
$SIG{HUP} = \&Stop;
$SIG{KILL} = \&Stop;
$SIG{TERM} = \&Stop;
$SIG{INT} = \&Stop;

### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
# some little helpers
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
sub debug() {
	return unless ($config{debug});
	my $msg = shift;

	my ($package,$filename,$line,$sub) = caller(1);
	($package,$filename,$line) = caller(0);

	print STDERR "$sub\[l.$line\]: $msg\n";
}

sub cutResource() { # cut's off resource from jids
	my $jid = shift;

	if ($jid =~ /\//) {
		$jid = substr($jid,0,index($jid,'/'));
	}

	return $jid;
}

sub createCID() { # creates a new cid
	my $jid = shift;
	my $digest;

	srand();
	my $stamp = rand();

	$digest = md5_hex($stamp,$jid);

	&debug("digest: " . $digest);
	return $digest;
}

sub dbSQL {
	my ($dbh, $sql_statement) = @_;

	&debug("sql_statement: $sql_statement");

	#Prepare and error checking.
	my $sth = $dbh->prepare($sql_statement);
	$sth->execute;

	if ($sth->err) { # try to reconnect and send the query again
		&debug("trying to reconnect to DB");
		$dbh = DBI->connect("DBI:mysql:database=".$config{mysql}->{dbname},$config{mysql}->{username},$config{mysql}->{password},{AutoCommit => 1, PrintError => 1}) or die "Can't connect to $config{mysql}->{dbname}: $DBI::errstr";
		$sth = $dbh->prepare($sql_statement);
		$sth->execute;
		die $sth->errstr if $sth->err;
	}

	return $sth;
}

### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
# main()
#
# let's get it on ...
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
# create a parser
my $xml_parser = XML::Stream::Parser->new(Style => 'Node');

# get config
my $tree = $xml_parser->parsefile($optctl{config});
%config = %{&XML::Stream::XML2Config($tree)};

print "Message Archiving Component \'$config{component}->{name}\' v$VERSION starting...\n";

# get db handle
my $dbh = DBI->connect("DBI:mysql:database=".$config{mysql}->{dbname},$config{mysql}->{username},$config{mysql}->{password},{AutoCommit => 1, PrintError => 1}) or die "Can't connect to $config{mysql}->{dbname}: $DBI::errstr";

$dbh->{mysql_auto_reconnect} = 1;

# create component
my $cmp = new Net::Jabber::Component();

$cmp->Info(name=>'Message Archive',version=>$VERSION);

# register callbacks
$cmp->SetCallBacks(iq=>\&handleIQ);

# start component
$cmp->Execute(
							hostname=>$config{server}->{hostname},
							port=>$config{server}->{port},
							secret=>$config{server}->{secret},
#							connectiontype=>$config{server}->{connectiontype}, 
#							unused anyway
							componentname=>$config{component}->{name},
							connectattempts=>$config{component}->{connectattempts},
							connectsleep=>$config{component}->{connectsleep}
						 );

# component died unexpectedly
print "Giving up and Exiting ...\n";
exit(0);

### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
# Stop
#
# do a clean shutdown
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
sub Stop() {
	print "\n\n***\n\nShutting down $config{component}->{name}: ";
	$cmp->Disconnect();
	$dbh->disconnect();
	print "done.\n";
	exit(0);
}

### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
# sendError - guess what it does
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
sub sendError() {
	my $IQ = shift;
	
	my $to = $IQ->GetFrom();

	my $iqReply = XML::Stream::Node->new('iq');
	$iqReply->put_attrib('type'=>'error');
	$iqReply->put_attrib('to'=>$to);
	$iqReply->put_attrib('from'=>$config{component}->{name});
	$iqReply->put_attrib('id'=>$IQ->GetID()) if($IQ->GetID() ne '');

	my $rnode = XML::Stream::Node->new('error');
	$rnode->put_attrib('type' => 'auth');
	$rnode->put_attrib('code' => '406');

	my $nnode = XML::Stream::Node->new('not-acceptable');
	$nnode->put_attrib('xmlns'=>'urn:ietf:params:xml:ns:xmpp-stanzas');

	$rnode->add_child($nnode);

	$iqReply->add_child($rnode);

	&debug($iqReply->GetXML());

	$cmp->Send($iqReply);
}

### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
# handleDiscoInfo
#
# replies to disco request
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
sub handleDiscoInfo() {
	my $IQ = shift;
	my $iqReply = $IQ->Reply(type=>'result');
	my $iqQuery = $iqReply->NewQuery("http://jabber.org/protocol/disco#info");
	
	$iqQuery->AddIdentity(
												'category' => 'store',
												'type' => 'file',
												'name' => 'Message Archive'
											 );
	$iqQuery->AddFeature('var'=>'http://jabber.org/protocol/archive');
	
	&debug($iqReply->GetXML());

	$cmp->Send($iqReply);
}

### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
# handleIQSet
#
# handles <iq type='set' ...> i.e.: 
#
# * storing a message. if cid supplied take that if not create a new
# one
# or
# * rename a collection
# or
# * close a collection
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
sub handleIQSet() {
	my $IQ = shift;

	my $from = $IQ->GetFrom();

	my $child;
	foreach $child ($IQ->GetTree()->children()) {

		my $cid = $child->get_attrib('cid');
		my $new_cid = 0;
		
		if ($child->get_tag() eq 'archive') {
			&debug("archive: " . $child->GetXML());

			# name given?
			my $colname = $child->get_attrib('name');
			if (defined($colname)) {
				&debug("name: ".$colname);
			}

			unless (defined($cid) && $cid ne '') {
				$cid = &createCID($from);
				$new_cid = 1;
			}

			# get message
			my $message = $child->XPath('message');
			if (defined($message) && $message ne '') {
				&debug($message->GetXML());
			} else {
				&debug("no message");
				next;
			}

			my ($jid,$dir);
			if (($message->get_attrib('to') && &cutResource($message->get_attrib('to')) eq &cutResource($from)) || !$message->get_attrib('to')) {
				$jid = &cutResource($message->get_attrib('from'));
				$dir = 'from';
			} else {
				$jid = &cutResource($message->get_attrib('to'));
				$dir = 'to';
			}

			my $body = $message->XPath('body');
			next unless (defined($body) && $body ne '');
			&debug("body: ".$body->get_cdata()); 

			# add message to tree
			if ($new_cid) { # start a new collection
				
				if (defined($colname) && $colname ne '') {
					&dbSQL($dbh,"INSERT INTO item VALUES(".$dbh->quote($cid).",".$dbh->quote(&cutResource($from)).",".$dbh->quote($jid).",".$dbh->quote($colname).",NOW(),NULL)");
				} else {
					&dbSQL($dbh,"INSERT INTO item VALUES(".$dbh->quote($cid).",".$dbh->quote(&cutResource($from)).",".$dbh->quote($jid).",NULL,NOW(),NULL)");
				}
				
			} else { # lookup collection

				my $sth = &dbSQL($dbh,"SELECT cid FROM item WHERE cid=".$dbh->quote($cid));

				unless (defined($sth->fetchrow_array())) {
					&debug("no collection found for $cid");
					# send error
					&sendError($IQ);
					return;
				}
				
				if (defined($colname) && $colname ne '') { # rename this
                                                   # collection
					&dbSQL("UPDATE item SET name=$dbh->quote($colname) WHERE cid=$dbh->quote($cid)");
				}
			}

			# insert message into collection
			&dbSQL($dbh,"INSERT INTO message(item_cid,dir,body) VALUES(".$dbh->quote($cid).",'$dir',".$dbh->quote($body->get_cdata()).")");

		}	elsif ($child->get_tag() eq 'done') {
			# close collection

			unless (defined($cid) && $cid ne '') {
				# cid missing - error out
				&sendError($IQ);
				return;
			}

			my $sth = &dbSQL($dbh,"SELECT cid FROM item WHERE cid=".$dbh->quote($cid));

			unless (defined($sth->fetchrow_array())) {
				&debug("no collection found for $cid");
				# send error
				&sendError($IQ);
				return;
			}

			&dbSQL($dbh,"UPDATE item SET end=NOW() WHERE cid=".$dbh->quote($cid));

		} else {
			# unknown tag - send error
			&sendError($IQ);
			return;
		}

		# send result
		my $iqReply = XML::Stream::Node->new('iq');
		$iqReply->put_attrib('type'=>'result');
		$iqReply->put_attrib('to'=>$from);
		$iqReply->put_attrib('from'=>$config{component}->{name});
		$iqReply->put_attrib('id'=>$IQ->GetID()) if($IQ->GetID() ne '');
		my $rnode = XML::Stream::Node->new('archive');
		$rnode->put_attrib('xmlns' => 'http://jabber.org/protocol/archive');
		$rnode->put_attrib('cid' => $cid) if ($new_cid);
		$iqReply->add_child($rnode);
		&debug($iqReply->GetXML());

		$cmp->Send($iqReply);
	}
}

### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
# handleIQGet
#
# handles <iq type='get' ...>
# * retrieve a list of collections
# or
# * return a specific collection
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
sub handleIQGet() {
	my $IQ = shift;

	my $from = $IQ->GetFrom();

	my $archive = ($IQ->GetTree()->children())[0];

	if (defined($archive->get_attrib('cid'))) {
		# send collection
		my $iqReply = XML::Stream::Node->new('iq');
		$iqReply->put_attrib('type'=>'result');
		$iqReply->put_attrib('to'=>$from);
		$iqReply->put_attrib('from'=>$config{component}->{name});
		$iqReply->put_attrib('id'=>$IQ->GetID()) if($IQ->GetID() ne '');

		my $rnode = XML::Stream::Node->new('archive');
		$rnode->put_attrib('xmlns' => 'http://jabber.org/protocol/archive');
		$iqReply->add_child($rnode);


		my $sth = &dbSQL($dbh,"SELECT jid FROM item WHERE cid=".$dbh->quote($archive->get_attrib('cid')));
		my ($jid) = $sth->fetchrow_array;
		unless (defined($jid)) { # collection not found
			&sendError($IQ);
			return
		}

		$sth = &dbSQL($dbh,"SELECT dir,body FROM message WHERE item_cid=".$dbh->quote($archive->get_attrib('cid'))." ORDER BY cDate");

		my ($dir,$body);
		while (($dir,$body) = $sth->fetchrow_array) {
			my $message = XML::Stream::Node->new('message');
			if ($dir eq 'to') {
				$message->put_attrib('to'=>$jid);
			} else {
				$message->put_attrib('from'=>$jid);				
			}
			$message->add_child('body',$body);
			$rnode->add_child($message);
		}

		&debug($iqReply->GetXML());

		$cmp->Send($iqReply);
	} else {
		# list available collections
		my $iqReply = XML::Stream::Node->new('iq');
		$iqReply->put_attrib('type'=>'result');
		$iqReply->put_attrib('to'=>$from);
		$iqReply->put_attrib('from'=>$config{component}->{name});
		$iqReply->put_attrib('id'=>$IQ->GetID()) if($IQ->GetID() ne '');

		my $rnode = XML::Stream::Node->new('archive');
		$rnode->put_attrib('xmlns' => 'http://jabber.org/protocol/archive');
		$iqReply->add_child($rnode);

		my $sql = "SELECT cid,jid,name,DATE_FORMAT(start,'%Y%m%dT%H:%i:%S'),DATE_FORMAT(end,'%Y%m%dT%H:%i:%S') FROM item WHERE owner=".$dbh->quote(&cutResource($from));
		if ($archive->get_attrib('jid')) {
			$sql .= " AND jid=".$dbh->quote($archive->get_attrib('jid'));
		}

		$sql .= " ORDER BY start DESC";

		my $sth = &dbSQL($dbh,$sql);

		my ($cid,$jid,$name,$start,$end);
		while (($cid,$jid,$name,$start,$end) = $sth->fetchrow_array) {
			my $item = XML::Stream::Node->new('item');
			$item->put_attrib('cid'=>$cid);
			$item->put_attrib('jid'=>$jid);
			$item->put_attrib('name'=>$name) if (defined($name) && $name ne '');
			$item->put_attrib('start'=>$start);
			$item->put_attrib('end'=>$end) if (defined($end) && $end ne '');
			next if (defined($archive->get_attrib('start')) && str2time($item->get_attrib("start")) <= str2time($archive->get_attrib('start'))); # skip older collections
			next if (defined($archive->get_attrib('end')) && defined($item->get_attrib('end')) && str2time($item->get_attrib("end")) >= str2time($archive->get_attrib('end'))); # skip older collections
			
			$rnode->add_child($item);
		}

		&debug($iqReply->GetXML());

		$cmp->Send($iqReply);
	}
	
}

### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
# handleIQ
#
# my own IQ router as lib functions don't apply to iq's without query
# child tag
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
sub handleIQ() {
	my ($sid,$IQ) = @_;
	&debug($IQ->GetXML());

	my $type = $IQ->GetType();
	if ($type eq 'set') {
		&handleIQSet($IQ);
	} elsif ($type eq 'get') {
		my $xmlns = $IQ->GetQueryXMLNS();
		if (defined($xmlns) && $xmlns eq 'http://jabber.org/protocol/disco#info') {
			&handleDiscoInfo($IQ);
		} else {
			&handleIQGet($IQ);
		}
	}
}