File Coverage

blib/lib/JOAP/Server.pm

Criterion	Covered	Total	%
statement	3	3	100.0
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	4	4	100.0

# JOAP::Server -- Base Class for JOAP Object Servers
#
# Copyright (c) 2003, Evan Prodromou
#
# 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

# tag: JOAP server class

package JOAP::Server;
use base qw/Exporter JOAP::Server::Object/;

use 5.008;
use strict;
use warnings;
use Net::Jabber qw/Component/;
use JOAP;
use JOAP::Server::Object;

# necessary Exporter hoohaw

our %EXPORT_TAGS = ( 'all' => [ ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw();
our $VERSION = $JOAP::VERSION;

JOAP::Server->mk_classdata('Name');
JOAP::Server->mk_classdata('Version');
JOAP::Server->mk_classdata('Classes');

JOAP::Server->Name('JOAP::Server');
JOAP::Server->Version($VERSION);
JOAP::Server->Classes({});

# These are a couple of default attributes, kinda just for show.

sub version_info;

JOAP::Server->Attributes(
    {time => {type => 'dateTime.iso8601',
              writable => 0,
              getter => \&time_info,
	      desc => 'Current time at this server.'},
    version => {type => 'struct',
	        writable => 0,
	        getter => \&version_info,
	        desc => 'Version info for this server. Name of software and version number.'},
    });

sub new {

    my($proto) = shift;
    my($package) = ref($proto) || $proto;
    my($self) = JOAP::Server::Object::new($package, @_);

    $self->{component} = new Net::Jabber::Component(@_)
      unless $self->{component};

    $self->{component}->SetIQCallBacks($JOAP::NS =>
                                       {
                                        get => sub { $self->handle_joap($_[1]) },
                                        set => sub { $self->handle_joap($_[1]) },
                                       },
                                       'jabber:iq:rpc' =>
                                       {
                                        set => sub { $self->handle_joap($_[1]) },
                                       });

    $self->{component}->Info($self->name, $self->version);

    return $self;
}

# Just pass these through to the component.

sub execute { shift->{component}->Execute(@_) }
sub connect { shift->{component}->Connect(@_) }
sub disconnect { shift->{component}->Disconnect(@_) }
sub connected { shift->{component}->Connected(@_) }

# translucent accessors

sub name {

    my($self) = shift;

    if (ref($self)) {
        $self->{name} = shift if @_;
        return (defined $self->{name}) ?
          $self->{name} : $self->Name;
    } else {
        return $self->Name(@_);
    }
}

sub version {

    my($self) = shift;

    if (ref($self)) {
        $self->{version} = shift if @_;
        return (defined $self->{version}) ?
          $self->{version} : $self->Version;
    } else {
        return $self->Version(@_);
    }
}

sub classes {

    my($self) = shift;

    if (ref($self)) {
        $self->{classes} = shift if @_;
        return (defined $self->{classes}) ?
          $self->{classes} : $self->Classes;
    } else {
        return $self->Classes(@_);
    }
}

sub version_info {
    my $self = shift;
    return {name => $self->name, version => $self->version};
}

sub time_info {
    my $self = shift;
    return time;
}

sub on_joap {

    my $self = shift;
    my $iq = shift;

    my $recipient = $self->_jid_to_object($iq->GetTo('jid'));

    my $respiq = undef;

    if (!$recipient) {
	$respiq = $self->reply($iq);
	$respiq->SetType('error');
	$respiq->SetErrorCode(404); # not found
	$respiq->SetError('Not found');
    }
    else {
	$respiq = $recipient->on_iq($iq);
    }

    return $respiq;
}

sub handle_joap {

    my $self = shift;
    my $iq = shift;

    my $respiq = $self->on_joap($iq);

    $self->{component}->Send($respiq) if ($respiq);

    my $le = $self->log_entry($iq, $respiq);

    # XXX: use Net::Jabber::Log instead of debug

    $self->{component}->{DEBUG}->Log0($le);
}

# We have to add classes.

sub on_describe {

    my($self) = shift;
    my($iq) = shift;
    my($respiq) = $self->SUPER::on_describe($iq);

    my $addr = $iq->GetTo;

    if ($respiq->GetType() ne 'error') { # If that worked out OK...
	my $qry = $respiq->GetQuery;
        foreach my $class (keys %{$self->Classes}) {
	    my $jid = new Net::Jabber::JID($addr);
	    $jid->SetUserID($class);
            $qry->SetClass($jid->GetJID('full'));
        }
	$qry->SetTimestamp($self->timestamp);
    }

    return $respiq;
}

sub make_address {

    my($self) = shift;
    my(%args) = @_;

    my($jid) = new Net::Jabber::JID();

    $jid->SetServer(($args{server}) ? $args{server} : $self->componentname);

    $jid->SetUserID(($args{classname}) ? $args{classname} :
                    ($args{class}) ? $self->get_class($args{class}) :
                    ($args{instance}) ? $self->get_class(ref($args{instance})) : undef);

    $jid->SetResource(($args{instid}) ? $args{instid} :
                      ($args{instance}) ? $args{instance}->id() : undef);
}

sub get_class {

    my($self) = shift;
    my($classname) = shift;

    return $self->classes->{$classname};
}

# Note: this is kind of dodgy, since more than one classname can come
# to a class.

sub get_classname {

    my($self) = shift;
    my($class) = shift;

    my %rev = (reverse %{$self->classes});

    return $rev{$class};
}

sub _jid_to_object {

    my($self) = shift;
    my($jid) = shift;

    my($classname) = $jid->GetUserID();

    if (!$classname) {
        return $self;           # Stuff without a classname is for the server
    } else {

        my($class) = $self->get_class($classname);

        return undef unless $class;

	# XXX: require class here?

        my($instid) = $jid->GetResource();

        if ($instid) {
            return $class->get($instid);
        } else {
            return $class;
        }
    }
}

# XXX: make this work with jabberd component logging

sub log_entry {

    my $self = shift;
    my $iq = shift;
    my $resp = shift;
    my $le = {};

    my $timestamp = JOAP->int_to_datetime(time);
    my $from = $iq->GetFrom;
    my $to = $iq->GetTo;
    my $input = $self->_summarize_input($iq);
    my $output = $self->_summarize_output($resp);
    my $error = $self->_error($resp);

    # FIXME: print to a configurable log file

    return sprintf("%s : \"%s\" - \"%s\" : %s -> %s (%s)", $timestamp, $from, $to,
      $input, $output, $error);
}

sub _error {

    my $self = shift;
    my $iq = shift;

    if ($iq->GetType ne 'error') {
	return "OK";
    }
    else {
	return $iq->GetErrorCode;
    }
}

sub _summarize_input {

    my $self = shift;
    my $iq = shift;
    my $ns = $iq->GetQuery->GetXMLNS;

    if ($ns eq 'jabber:iq:rpc') {
	return $self->_summarize_method_in($iq);
    } elsif ($ns eq $JOAP::NS) {
        my($verb) = $iq->GetQuery->GetTag;
        if ($verb eq 'read') {
            return $self->_summarize_read_in($iq);
        } elsif ($verb eq 'edit') {
            return $self->_summarize_edit_in($iq);
        } elsif ($verb eq 'add') {
            return $self->_summarize_add_in($iq);
        } elsif ($verb eq 'search') {
            return $self->_summarize_search_in($iq);
        } elsif ($verb eq 'delete') {
            return $self->_summarize_delete_in($iq);
        } elsif ($verb eq 'describe') {
            return $self->_summarize_describe_in($iq);
        }
    }

    return undef;
}

sub _summarize_output {

    my $self = shift;
    my $iq = shift;
    my $ns = $iq->GetQuery->GetXMLNS;

    if ($iq->GetType eq 'error') {
	return $iq->GetError;
    } else {
	if ($ns eq 'jabber:iq:rpc') {
	    return $self->_summarize_method_out($iq);
	} elsif ($ns eq $JOAP::NS) {
	    my($verb) = $iq->GetQuery->GetTag;
	    if ($verb eq 'read') {
		return $self->_summarize_read_out($iq);
	    } elsif ($verb eq 'edit') {
		return $self->_summarize_edit_out($iq);
	    } elsif ($verb eq 'add') {
		return $self->_summarize_add_out($iq);
	    } elsif ($verb eq 'search') {
		return $self->_summarize_search_out($iq);
	    } elsif ($verb eq 'delete') {
		return $self->_summarize_delete_out($iq);
	    } elsif ($verb eq 'describe') {
		return $self->_summarize_describe_out($iq);
	    }
	}
    }

    return undef;
}

sub _summarize_method_in {

    my $self = shift;
    my $iq = shift;
    my $qry = $iq->GetQuery;
    my $call = $qry->GetMethodCall || return "(method -- bad format)";
    my $name = $call->GetMethodName || return "(method -- bad format)";

    my @actuals = $call->GetParams->GetParams;

    my @params = map { $self->_summarize_param($_) } @actuals;

    return "method $name (" . join(", ", @params) . ")";
}

sub _summarize_method_out {

    my $self = shift;
    my $iq = shift;
    my $qry = $iq->GetQuery;
    my $resp = $qry->GetMethodResponse || return "(method -- bad format)";

    if ($resp->DefinedFault) {
	my $fs = JOAP->decode($resp->GetFault->GetValue);
	return ("FAULT #" . $fs->{faultCode} . ": " . $fs->{faultString});
    }
    else {
	my @actuals = $resp->GetParams->GetParams;
	my @params = map { $self->_summarize_param($_) } @actuals;
	return "(" . join(", ", @params) . ")";
    }
}

sub _summarize_read_in {

    my $self = shift;
    my $iq = shift;
    my $qry = $iq->GetQuery;
    my @names = $qry->GetName;

    return "read (" . ((@names) ? join(", ", @names) : "*") . ")";
}

sub _summarize_read_out {

    my $self = shift;
    my $iq = shift;
    my $qry = $iq->GetQuery;
    my @attrs = $qry->GetAttribute;

    my @attrsums = map { $self->_summarize_attr($_) } @attrs;

    return "(" . join(", ", @attrsums) . ")";
}

sub _summarize_edit_in {

    my $self = shift;
    my $iq = shift;
    my $qry = $iq->GetQuery;
    my @attrs = $qry->GetAttribute;

    my @attrsums = map { $self->_summarize_attr($_) } @attrs;

    return "edit (" . join(", ", @attrsums) . ")";
}

sub _summarize_edit_out {

    my $self = shift;
    my $iq = shift;
    my $qry = $iq->GetQuery;

    if ($qry->DefinedNewAddress) {
	return $qry->GetNewAddress;
    } else {
	return "";
    }
}

sub _summarize_add_in {

    my $self = shift;
    my $iq = shift;
    my $qry = $iq->GetQuery;
    my @attrs = $qry->GetAttribute;

    my @attrsums = map { $self->_summarize_attr($_) } @attrs;

    return "add (" . join(", ", @attrsums) . ")";
}

sub _summarize_add_out {

    my $self = shift;
    my $iq = shift;
    my $qry = $iq->GetQuery;

    return $qry->GetNewAddress;
}

sub _summarize_delete_in {
    return "delete";
}

sub _summarize_delete_out {
    return "";
}

sub _summarize_search_in {

    my $self = shift;
    my $iq = shift;
    my $qry = $iq->GetQuery;
    my @attrs = $qry->GetAttribute;

    my @attrsums = map { $self->_summarize_attr($_) } @attrs;

    return "search (" . ((@attrs) ? join(", ", @attrsums) : "*") . ")";
}

sub _summarize_search_out {

    my $self = shift;
    my $iq = shift;
    my $qry = $iq->GetQuery;
    my @items = $qry->GetItem;
    my $size = scalar(@items);

    if ($size > 4) {
	return "(" . join(",", @items[0,3]) . "... [$size total])";
    } else {
	return "(" . join(",", @items) . ")";
    }
}

sub _summarize_describe_in {
    return "describe";
}

sub _summarize_describe_out {
    # FIXME: actually write out description, wimp!
    return "[description]";
}

sub _summarize_attr {

    my $self = shift;
    my $attr = shift;
    my $name = $attr->GetName;
    my $value = $attr->GetValue;
    my $type = JOAP->value_type($value);
    my $val = JOAP->decode($value);

    return $name . " => \"" . $self->_ellipsize($val) . "\" [" . $type . "]";
}

sub _summarize_param {

    my $self = shift;
    my $param = shift;
    my $value = $param->GetValue;
    my $type = JOAP->value_type($value);
    my $val = JOAP->decode($value);

    return "\"" . $self->_ellipsize($val) . "\" [" . $type . "]";
}

sub _ellipsize {

    my $self = shift;
    my $string = shift;

    if (length($string) > 32) {
	return (substr($string, 29) . "...");
    } else {
	return $string;
    }
}

1;

__END__