Initial commit.

18 files changed, 485 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..0595a33
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+reuasmb.conf
\ No newline at end of file
diff --git a/README b/README
new file mode 100644
index 0000000..ed74d01
--- /dev/null
+++ b/README
@@ -0,0 +1,115 @@
+# -*- mode: org -*-
+
+* Overview
+A test consists of a config file, which specifies variables available
+during the execution of the test, a test plan file, which dictates the
+order of the test, and a series of templates, referenced by the test
+plan, which contain the data to be read and optionally matched. See
+the Testing section for an example of how to use it.
+
+This is intended to be used for request-response style interactions,
+where we send a request and wait for a matching response. However, not
+all requests stimulate a response, so response matching is optional.
+
+By default this program reads from standard input and writes to
+standard output, but if a command line is supplied as the final
+arguments, that will be used instead. This is useful with netcat for
+network server testing.
+
+* Config File
+The format of the config file is a list of arbitrary '$key=$value'
+pairs. Comments start with '#' and continue until the end of the line.
+
+Config keys are auto-interned as nullary functions for use in
+templates.
+
+* Test Plan
+The test plan file is a list of files to run within the templates
+directory (which defaults to 'xml'), suffixed by '.xml' for sending
+data, and, if it exists, suffixed by '.expected.xml' for matching
+responses. Thus a test plan line which consists of 'foo' would send
+data according to the template in 'xml/foo.xml' and would then wait
+for data matching the template in 'xml/foo.expected.xml' if that file
+exists.
+
+The XML stuff is not ideal, since this program doesn't care about the
+format of the data being read or written, but since it was developed
+for XMPP testing, that's what it got. This may change in the future.
+
+* Templates
+Templates are fundamentally a big regexp with thunks of Perl code
+contained within '{}' interpolated at run-time. While templates are
+used for both sending data and matching received data, the use of
+thunks changes depending on context.
+
+** Send context
+In send context (e.g., 'foo.xml'), the code called may return a string
+which will replace the thunk in the template. Assuming you have a
+function defined called bar:
+#+BEGIN
+sub bar() { "text" };
+#+END
+
+and a template:
+#+BEGIN
+Here is some {bar}!
+#+END
+
+The output would be:
+#+BEGIN
+Here is some text!
+#+END
+
+The code is arbitrary Perl 5, and doesn't have to return a string, but
+if it returns anything it should be something that can be converted to
+a string automatically, or you're likely to get an error.
+
+** Match context
+During matching, the template is processed as a regexp, where thunks
+are treated as captured wildcards (i.e., the pattern '(.*)'). After a
+successful match, the value of the capture is made available to the
+thunk in the $arg variable. This is so that the value can be compared
+with an expected value, or that more complex computation can be done
+(such as for challenge-response authentication).
+
+It is assumed that there will be cases where data that you're not
+interested in can be interleaved in data that you are interested in
+(e.g., keepalives) and match templates will ignore them.
+
+** Evaluation package
+Templates are evaluated in their own package, outside of main, to
+better isolate their side-effects. Some package-level globals are made
+available:
+  * $in - The filehandle we're reading match data from.
+  * $out - The filehandle we're sending data to.
+  * %env - The key-value pairs from the loaded config file.
+  * $arg - The value of the capture group for this thunk (in match
+           context)
+
+This package is never reinitialized during the test plan execution,
+allowing one template to modify data for subsequent templates.
+
+** XML
+In order to make XML processing easier, any type of quote, throughout
+the text is turned into the pattern ['"] during match
+context. Similarly, whitespace is condensed and replaced with the \s*
+pattern.
+
+Do note that while this program is intended to be used primarily with
+XML, it's almost totally ignorant of XML as a format besides the above
+substitutions. That means that things like attribute order within a
+tag matter, and we cannot normalize '<foo></foo>' to '<foo/>' (at
+least unless you write a big tangle of regexp in the template itself).
+
+* Testing
+The file 'testplan' contains a sample plan for a basic XMPP session
+given 'localhost.conf', using the files in the 'xml' directory. The
+corresponding server data is in 'input'. So to run a quick-and-dirty
+test, execute:
+
+#+BEGIN
+% xmpt -c localhost.conf -p testplan < input
+#+END
+
+At some point, these things should be moved into a 't' directory and
+used with Test::Harness.
diff --git a/input b/input
new file mode 100644
index 0000000..5effb70
--- /dev/null
+++ b/input
@@ -0,0 +1,29 @@
+<stream:stream xmlns:stream='http://etherx.jabber.org/streams'
+	       version='1.0'
+	       from='localhost'
+	       id='somestreamid'
+	       xmlns='jabber:client'>
+  <stream:features>
+    <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>
+      <mechanism>SCRAM-SHA-1</mechanism>
+      <mechanism>PLAIN</mechanism>
+    </mechanisms>
+    <auth xmlns='http://jabber.org/features/iq-auth'/>
+  </stream:features>
+<success xmlns='urn:ietf:params:xml:ns:xmpp-sasl'></success>
+<stream:stream xmlns:stream='http://etherx.jabber.org/streams'
+	       version='1.0'
+	       from='localhost'
+	       id='somestreamid'
+	       xmlns='jabber:client'>
+  <stream:features>
+    <bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'/>
+    <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>
+  </stream:features>
+<iq from='test0@localhost' to='test0@localhost/xmpt' id='bind' type='result'>
+  <bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'>
+    <jid>test0@localhost/xmpt</jid>
+  </bind>
+</iq>
+<iq from='test0@localhost' to='test0@localhost/xmpt' id='session' type='result'/>
+</stream>
diff --git a/localhost.conf b/localhost.conf
new file mode 100644
index 0000000..bc462d7
--- /dev/null
+++ b/localhost.conf
@@ -0,0 +1,3 @@
+# Domain and bare JID are calculated from full.
+full_jid=test0@localhost/xmpt
+password=test
diff --git a/testplan b/testplan
new file mode 100644
index 0000000..ba7fcaa
--- /dev/null
+++ b/testplan
@@ -0,0 +1,6 @@
+signin
+auth
+bind-reneg
+bind
+session
+signout
diff --git a/xml/auth.expected.xml b/xml/auth.expected.xml
new file mode 100644
index 0000000..2c1c582
--- /dev/null
+++ b/xml/auth.expected.xml
@@ -0,0 +1 @@
+<success xmlns='urn:ietf:params:xml:ns:xmpp-sasl'></success>
diff --git a/xml/auth.xml b/xml/auth.xml
new file mode 100644
index 0000000..25c8e1d
--- /dev/null
+++ b/xml/auth.xml
@@ -0,0 +1 @@
+<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl' mechanism='PLAIN'>{plain_auth}</auth>
diff --git a/xml/bind-reneg.expected.xml b/xml/bind-reneg.expected.xml
new file mode 100644
index 0000000..23774eb
--- /dev/null
+++ b/xml/bind-reneg.expected.xml
@@ -0,0 +1,9 @@
+<stream:stream xmlns:stream='http://etherx.jabber.org/streams'
+	       version='1.0'
+	       from='{domainpart}'
+	       id='.*'
+	       xmlns='jabber:client'>
+  <stream:features>
+    <bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'/>
+    <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>
+  </stream:features>
diff --git a/xml/bind-reneg.xml b/xml/bind-reneg.xml
new file mode 100644
index 0000000..cf456c0
--- /dev/null
+++ b/xml/bind-reneg.xml
@@ -0,0 +1,7 @@
+<?xml version='1.0'?>
+<stream:stream xmlns:stream='http://etherx.jabber.org/streams'
+	       xmlns:xml='http://www.w3.org/XML/1998/namespace'
+	       xmlns='jabber:client'
+	       xml:lang='en'
+	       version='1.0'
+	       to='{domainpart}'>
diff --git a/xml/bind.expected.xml b/xml/bind.expected.xml
new file mode 100644
index 0000000..9cfa434
--- /dev/null
+++ b/xml/bind.expected.xml
@@ -0,0 +1,5 @@
+<iq from='{bare_jid}' to='{full_jid}' id='bind' type='result'>
+  <bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'>
+    <jid>{full_jid}</jid>
+  </bind>
+</iq>
diff --git a/xml/bind.xml b/xml/bind.xml
new file mode 100644
index 0000000..82a2d09
--- /dev/null
+++ b/xml/bind.xml
@@ -0,0 +1,5 @@
+<iq type='set' id='bind'>
+  <bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'>
+    <resource>{resourcepart}</resource>
+  </bind>
+</iq>
diff --git a/xml/session.expected.xml b/xml/session.expected.xml
new file mode 100644
index 0000000..f1bcab2
--- /dev/null
+++ b/xml/session.expected.xml
@@ -0,0 +1 @@
+<iq from='{bare_jid}' to='{full_jid}' id='session' type='result'/>
diff --git a/xml/session.xml b/xml/session.xml
new file mode 100644
index 0000000..6f830bf
--- /dev/null
+++ b/xml/session.xml
@@ -0,0 +1,3 @@
+<iq type='set' id='session'>
+  <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>
+</iq>
diff --git a/xml/signin.expected.xml b/xml/signin.expected.xml
new file mode 100644
index 0000000..4774bbb
--- /dev/null
+++ b/xml/signin.expected.xml
@@ -0,0 +1,12 @@
+<stream:stream xmlns:stream='http://etherx.jabber.org/streams'
+	       version='1.0'
+	       from='{domainpart}'
+	       id='.*'
+	       xmlns='jabber:client'>
+  <stream:features>
+    <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>
+      <mechanism>SCRAM-SHA-1</mechanism>
+      <mechanism>PLAIN</mechanism>
+    </mechanisms>
+    <auth xmlns='http://jabber.org/features/iq-auth'/>
+  </stream:features>
diff --git a/xml/signin.xml b/xml/signin.xml
new file mode 100644
index 0000000..7b9438f
--- /dev/null
+++ b/xml/signin.xml
@@ -0,0 +1,6 @@
+<stream:stream xmlns:stream='http://etherx.jabber.org/streams'
+	       xmlns:xml='http://www.w3.org/XML/1998/namespace'
+	       xmlns='jabber:client'
+	       xml:lang='en'
+	       version='1.0'
+	       to='{domainpart}'>
diff --git a/xml/signout.expected.xml b/xml/signout.expected.xml
new file mode 100644
index 0000000..522b4a3
--- /dev/null
+++ b/xml/signout.expected.xml
@@ -0,0 +1 @@
+</stream>
diff --git a/xml/signout.xml b/xml/signout.xml
new file mode 100644
index 0000000..522b4a3
--- /dev/null
+++ b/xml/signout.xml
@@ -0,0 +1 @@
+</stream>
diff --git a/xmpt b/xmpt
new file mode 100755
index 0000000..bae4eee
--- /dev/null
+++ b/xmpt
@@ -0,0 +1,279 @@
+#!/usr/bin/env perl
+
+use Data::Dumper;
+use Getopt::Long;
+use IO::File;
+use IPC::Open2;
+use v5.10;
+
+use strict;
+use warnings;
+
+my $configpath   = 'localhost.conf';
+my $testplanpath = 'testplan';
+my $templatepath = 'xml';
+my $timeout      = 5;
+my $verbose;
+my $help;
+
+GetOptions('config|c=s'    => \$configpath,
+	   'testplan|p=s'  => \$testplanpath,
+	   'templates|d=s' => \$templatepath,
+	   'timeout|t=i'   => \$timeout,
+	   'verbose|v'     => \$verbose,
+	   'help|h'        => \$help) || usage(1);
+usage(0) if $help;
+
+my %conf = read_conf($configpath);
+my @plans = load_plans($testplanpath, $templatepath);
+
+my $curstep;
+local $SIG{CHLD} = sub {
+  my $suffix = "before test plan started.";
+  $suffix = "in $curstep step." if $curstep;
+  die "Command '@ARGV' terminated $suffix\n"
+};
+
+my ($inh, $outh) = (\*STDIN, \*STDOUT);
+my $pid;
+if (@ARGV) {
+  $inh = $outh = undef;
+  $pid = open2($inh, $outh, join(' ', @ARGV));
+}
+binmode($inh, ':utf8');
+binmode($outh, ':utf8');
+autoflush $outh 1;
+eval_in($inh, $outh, \%conf, @plans);
+waitpid($pid, 0) if $pid;
+
+# TODO: swap over to Pod::Usage.
+sub usage {
+  print STDERR "Usage: $0 [-v] [-c config] [-p testplan] [-d templatedir] [-t seconds] [command]\n";
+  exit shift;
+}
+
+sub read_conf {
+  my ($filen) = @_;
+
+  my $fh = new IO::File("<$filen") ||
+    die "Couldn't open $filen for reading: $!\n";
+  map {
+    chomp;
+    s/\#.*$//;
+    map { s/^\s*([^\s]+)\s*$/$1/; $_ } split(/=/, $_, 2);
+  } <$fh>;
+}
+
+our $testplan;
+our $line;
+sub load_plans {
+  local $testplan = shift;
+  my $dir = shift;
+
+  my $planfh = new IO::File($testplan) ||
+    die "Couldn't open $testplan for reading: $!.\n";
+  local $line = 0;
+  map {
+    $line++;
+    chomp;
+
+    my %rc = (name => $_);
+    $rc{send} = parse_template("$dir/$_.xml");
+    if (-f "$dir/$_.expected.xml") {
+      $rc{expect} = parse_template("$dir/$_.expected.xml");
+    }
+    \%rc;
+  } <$planfh>
+}
+
+sub parse_template {
+  my ($fn) = @_;
+
+  my $fh = new IO::File($fn) ||
+    die "Couldn't open $fn for reading at line $line in $testplan: $!.\n";
+  binmode($fh, ':utf8');
+
+  my @parts = split /([{}]|\n)/, do { local $/; <$fh> };
+  my $intext = 1;
+  my $curthunk;
+  my $line = 1;
+  my $thunkstart;
+  my @rc;
+  while (@parts) {
+    my $tok = shift @parts;
+
+    $line++ if $tok =~ /\n/;
+
+    if ($intext) {
+      if ($tok =~ /{/) {
+	$thunkstart = $line;
+	$intext = 0;
+      } else {
+	push @rc, text($tok);
+      }
+    } else {
+      if ($tok =~ /}/) {
+	$intext = 1;
+	push @rc, thunk($curthunk, $fn, $thunkstart);
+	$curthunk = '';
+      } else {
+	$curthunk .= $tok;
+      }
+    }
+  }
+
+  die "Error in $fn: template ended inside thunk started at line $thunkstart.\n" .
+    "\tDid you forget a '}'?\n" unless $intext;
+  \@rc;
+}
+
+sub nothing { ["text", sub { "" }] }
+
+sub text {
+  my $t = shift;
+  ['text', sub { $t }];
+}
+
+sub thunk {
+  my ($b, $fn, $line) = @_;
+  ['thunk',
+   sub {
+     package evalpkg;
+     local $evalpkg::arg = shift;
+     my $rc = eval $b;
+     $@ &&
+       die "Error in $fn:$line: $@\ttestplan: $testplanpath\n\tconfig: $configpath\n";
+     $rc;
+   }]
+}
+
+sub eval_in {
+  local ($evalpkg::in, $evalpkg::out) = (shift, shift);
+  local %evalpkg::env = %{shift @_};
+  my @plans = @_;
+
+  foreach my $k (keys %evalpkg::env) {
+    # TODO: put $k in the symbol table directly, rather than calling
+    # string eval.
+    eval "package evalpkg; sub $k() { env('$k') };";
+  }
+
+  eval {
+    foreach my $plan (@plans) {
+      $curstep = $plan->{name};
+      print STDERR "=> Executing $curstep step.\n" if $verbose;
+      do_send($plan->{name}, @{$plan->{send}});
+      do_recv($plan->{name}, @{$plan->{expect}}) if $plan->{expect};
+    }
+  };
+  $@ && die $@;
+}
+
+sub do_send {
+  my $name = shift;
+  my $s = join('', (map { $_->[1]->() } @_));
+  if ($verbose) {
+    my $l = $s;
+    chomp $l;
+    print STDERR "SEND: $l\n" unless $l =~ /^\s*$/;
+  }
+  print $evalpkg::out $s;
+}
+
+sub do_recv {
+  my $name = shift;
+  my (@reparts, @thunks);
+  foreach my $plan (@_) {
+    # Text is matched explicitly, thunks are treated as wildcards,
+    # with the match sent as an argument.
+    if ($plan->[0] eq 'text') {
+      my $t = $plan->[1]->();
+      push @reparts, $t;
+    } else {
+      push @reparts, "(.*)";
+      push @thunks, $plan->[1];
+    }
+  }
+  my $re = join '', @reparts;
+  # TODO: add CLI options for whitespace/quote substitution.
+  $re =~ s/\s+/\\s\*/g;
+  $re =~ s/'|"/\['"\]/g;
+
+  # Need a persistent buffer for reading, because we may get more data
+  # than needed when matching for expected output, so stash it here
+  # for subsequent reads after the current matcher is done.
+  state $readbuf = '';
+  local $SIG{ALRM} = sub {
+    my $b = $readbuf;
+    chomp $b;
+    die "Timed out waiting for match in $name step. Current read buffer:\n$b\n";
+  };
+  alarm $timeout;
+  my @matches;
+  while (1) {
+    @matches = ($readbuf =~ /$re/);
+    if (@matches >= @thunks) {
+      $readbuf = $';
+      last;
+    }
+    my $r;
+    my $n = sysread $evalpkg::in, $r, 2048;
+    die "Error reading data while waiting for match in $name step: $!.\n" if $n == -1;
+    die "End of file while waiting for match in $name step.\n" unless $n;
+    if ($verbose) {
+      my $l = $r;
+      chomp $l;
+      print STDERR "RECV: $l\n"
+    }
+    $readbuf .= $r;
+  }
+  alarm 0;
+
+  for (my $i = 0; $i < @thunks; $i++) {
+    $thunks[$i]->($matches[$i]);
+  }
+}
+
+sub assert_arg {
+  my ($name, $want) = @_;
+  if ($evalpkg::arg) {
+    my $got = $evalpkg::arg;
+    die "Bad $name (got '$got', want: '$want').\n" if $got ne $want;
+  }
+  $want;
+}
+
+# Stick actual execution in its own package so you don't accidentally
+# clobber stuff in main while running templates.
+package evalpkg;
+
+use MIME::Base64;
+
+our ($in, $out);
+our %env;
+our $arg;
+
+sub env {
+  my $k = shift;
+  main::assert_arg($k, $env{$k});
+}
+
+sub bare_jid() {
+  main::assert_arg('bare_jid', (split /\//, $env{full_jid}, 2)[0]);
+}
+
+sub localpart() {
+  main::assert_arg('localpart', (split /\@/, $env{full_jid}, 2)[0]);
+}
+
+sub domainpart() {
+  main::assert_arg('domainpart', (split /\//, (split /\@/, $env{full_jid}, 2)[1])[0]);
+}
+
+sub resourcepart() {
+  main::assert_arg('resourcepart', (split /\//, $env{full_jid}, 2)[1]);
+}
+
+sub plain_auth() {
+  MIME::Base64::encode(join("\0", "", bare_jid(), $env{password}));
+}