#!/usr/bin/perl -w
use strict; # har har
use constant ERR => 0;
use constant WARN => 1;
use constant INFO => 2;
use constant DEBUG => 3;
use constant RID => 31974;
### ### ### conf ### ### ###
my $BASE_ADDRESS = "http://localhost:5280/http-bind/";
my $JABBER_SERVER = "localhost";
my $RID = RID;
my $WAIT = 60;
my $USER = "tester";
my $UPW = "mysecret";
my $DEBUG = INFO;
### ### ### END conf ### ### ###
# create an agent we can use for our requests
use LWP::UserAgent;
my $ua = new LWP::UserAgent();
# create a tree parser to parse response content
use XML::Parser;
my $p = new XML::Parser(Style => 'Tree');
### ### ### subs ### ### ###
sub doSend() {
my $content = shift;
# create a request
my $req = new HTTP::Request(POST => $BASE_ADDRESS);
$req->content_type('text/xml; charset=utf-8');
$req->content($content);
debug(DEBUG,"<< Request\n".$req->as_string."<< END Request");
# send request
my $res = $ua->request($req);
debug(DEBUG,">> Response\n" . $res->as_string .">> END Response");
return $res;
}
# getChildEls
# used to strip enclosing body element
# PARAMS: @tree - tree style array from XML::Parser
# RETURN: @children - child elements of top level element
sub getChildEls
{
my $t = $_[0];
shift @{$t->[1]};
return @{$t->[1]};
}
sub debug
{
my $lvl = shift;
my $msg = shift;
return if ($DEBUG < $lvl);
my $prefix = "[";
$prefix .= "ERROR" if ($lvl == ERR);
$prefix .= "WARNING" if ($lvl == WARN);
$prefix .= "INFO" if ($lvl == INFO);
$prefix .= "DEBUG" if ($lvl == DEBUG);
$prefix .= "] ";
$msg =~ s/\n/\n$prefix/g;
print STDERR $prefix . $msg . "\n";
}
### ### ### main ### ### ###
$| = 1; # set streaming output
# no body
print "Sending some 'foo': ";
my $res = &doSend("foo");
if ($res->code == 400) {
print "OK.\n";
} else {
print "Failed!\n";
print $res->as_string, "\n";
}
# no body
print "Sending some '': ";
$res = &doSend("");
if ($res->code == 400) {
print "OK.\n";
} else {
print "Failed!\n";
print $res->as_string, "\n";
}
# empty body
print "Sending empty body: ";
$res = &doSend("
content =~/as_string, "\n";
}
# sending empty 'to' attribute
print "Empty 'to' attribute at session creation request: ";
$res = &doSend("content =~/as_string, "\n";
}
# forget to send a rid
print "Missing 'rid' attribute at session creation request: ";
$res = &doSend("content =~/as_string, "\n";
}
# trying to connect to non-existent jabber server
print "Connecting to non-existent jabber server: ";
$res = &doSend("content =~/content =~/as_string, "\n";
}
# connection to foreign server
#print "Connecting to foreign jabber server: ";
#$res = &doSend("content =~/as_string, "\n";
#}
my %sess;
sub getSess
{
$sess{rid} = RID; # a rid to start
$res = &doSend("$USER");
my @els = (&getChildEls($p->parse($res->content)));
unless ($els[0] eq 'iq' && $els[1]->[0]->{'type'} eq 'result') {
debug(ERR, $res->content);
return 0;
}
# send auth
$sess{rid}++;
$res = &doSend("$USERtest$UPW");
@els = (&getChildEls($p->parse($res->content)));
unless ($els[0] eq 'iq' && $els[1]->[0]->{'type'} eq 'result') {
debug(ERR, $res->content);
return 0;
}
return 1;
}
print "Authenticating: ";
if (&doAuth()) {
print "OK.\n";
} else {
print "FAILED!\n";
debug(ERR, "Aborting.");
exit(1);
}
sub doPoll
{
$sess{rid}++;
return &doSend("");
debug(INFO, $res->content);
# send presence
print "sending presence\n";
$sess{rid}++;
$res = &doSend("");
debug(INFO, $res->content);
# sending bullshit
print "sending bullshit\n";
$sess{rid}++;
$res = &doSend("sending bullshit");
debug(INFO, $res->content);
# send presence
print "sending xa presence\n";
$sess{rid}++;
$res = &doSend("xa");
debug(INFO, $res->content);
# disconnect
sleep 3;
print "logout\n";
$sess{rid}++;
$res = &doSend("");
debug(INFO, $res->content);
print "Checking if session terminated: ";
$res = &doPoll();
if ($res->code != 404) {
print "FAILED!\n";
debug(ERR, "Aborting.");
exit(1);
}
print "OK.\n";