[perl] Add XMPP subscription support

We will need some kind of message queue system to allow test results
to be reported via a variety of means (HTTP requests, SMB magic file
creation, syslog messages, etc.).  Select XMPP as the central message
queue system, and add the ability to subscribe to test results.

Signed-off-by: Michael Brown <mbrown@fensystems.co.uk>

perl/Makefile.PL

@@ -20,6 +20,7 @@ requires "Sys::Virt";
 requires "XML::LibXML";
 requires "Net::SSH::Perl";
 requires "Net::SFTP";
+requires "Net::XMPP";
 requires "Data::UUID";
 
 WriteAll;

perl/lib/Net/XMPP/PubSub.pm

@@ -0,0 +1,33 @@
+package Net::XMPP::PubSub;
+
+use Net::XMPP;
+use namespace::autoclean;
+use strict;
+use warnings;
+
+use parent qw ( Exporter );
+our @EXPORT_OK = qw ( XMPP_PUBSUB_NS XMPP_PUBSUB_OWNER_NS );
+
+use constant XMPP_PUBSUB_NS => "http://jabber.org/protocol/pubsub";
+use constant XMPP_PUBSUB_OWNER_NS => "http://jabber.org/protocol/pubsub#owner";
+
+Net::XMPP::Protocol->AddNamespace (
+  ns => XMPP_PUBSUB_NS,
+  tag => "pubsub",
+  xpath => {
+    CreateNode => { type => "scalar", path => 'create/@node' },
+    Configure => { type => "flag", path => 'configure' },
+    SubscribeNode => { type => "scalar", path => 'subscribe/@node' },
+    SubscribeJID => { type => "jid", path => 'subscribe/@jid' },
+    UnsubscribeNode => { type => "scalar", path => 'unsubscribe/@node' },
+    UnsubscribeJID => { type => "jid", path => 'unsubscribe/@jid' },
+  } );
+
+Net::XMPP::Protocol->AddNamespace (
+  ns => XMPP_PUBSUB_OWNER_NS,
+  tag => "pubsub",
+  xpath => {
+    DeleteNode => { type => "scalar", path => 'delete/@node' },
+  } );
+
+1;

perl/lib/qPXE/Machine/cartman.pm

@@ -8,7 +8,7 @@ use strict;
 use warnings;
 
 extends qw ( qPXE::Machine );
-with qw ( qPXE::Role::SSH qPXE::Role::Dhcpd );
+with qw ( qPXE::Role::SSH qPXE::Role::XMPP qPXE::Role::Dhcpd );
 
 __PACKAGE__->meta->make_immutable();
 

perl/lib/qPXE/Role/XMPP.pm

@@ -0,0 +1,51 @@
+package qPXE::Role::XMPP;
+
+=head1 NAME
+
+qPXE::Role::XMPP - A machine providing an XMPP server for monitoring tests
+
+=head1 SYNOPSIS
+
+    package qPXE::Machine::foo;
+    use Moose;
+    extends qw ( qPXE::Machine );
+    with qw ( qPXE::Role::XMPP );
+
+=cut
+
+use Moose::Role;
+use MooseX::Method::Signatures;
+use MooseX::MarkAsMethods autoclean => 1;
+use qPXE::XMPP;
+use strict;
+use warnings;
+
+requires qw ( hostname );
+
+=head1 ATTRIBUTES
+
+=over
+
+=item C<xmpp>
+
+The C<qPXE::XMPP> object representing the XMPP server.
+
+=cut
+
+has "xmpp" => (
+  is => "ro",
+  isa => "qPXE::XMPP",
+  lazy => 1,
+  builder => "_build_xmpp",
+  init_arg => undef,
+);
+
+method _build_xmpp () {
+  return qPXE::XMPP->new ( machine => $self );
+}
+
+=back
+
+=cut
+
+1;

perl/lib/qPXE/Test/BasicDhcpHttp.pm

@@ -14,9 +14,13 @@ method execute () {
       "filename \"http://cartman/boot/demo.ipxe\";",
       "option ipxe.testid ".$self->uuid_colons.";" ] );
 
+
+  $self->cartman->xmpp->subscribe ( $self );
+
   # Start DUT
   $self->butters->domain->create();
-
+
+  $self->cartman->xmpp->unsubscribe ( $self );
 }
 
 __PACKAGE__->meta->make_immutable();

perl/lib/qPXE/XMPP.pm

@@ -0,0 +1,198 @@
+package qPXE::XMPP;
+
+=head1 NAME
+
+qPXE::XMPP - An instance of an XMPP server
+
+=head1 SYNOPSIS
+
+    use qPXE::Lab;
+
+    my $lab = qPXE::Lab->new ( uri => "qemu:///system" );
+    my $machine = $lab->machine ( "cartman" );
+    my $xmpp = $cartman->xmpp;
+
+
+=cut
+
+use Moose;
+use MooseX::StrictConstructor;
+use MooseX::Method::Signatures;
+use MooseX::MarkAsMethods autoclean => 1;
+use Net::XMPP;
+use Net::XMPP::PubSub qw ( XMPP_PUBSUB_NS XMPP_PUBSUB_OWNER_NS );
+use Data::UUID;
+use Carp;
+use strict;
+use warnings;
+
+=head1 ATTRIBUTES
+
+=over
+
+=item C<machine>
+
+The <qPXE::Machine> object representing the machine running DHCPD.
+
+=cut
+
+has "machine" => (
+  is => "ro",
+  isa => "qPXE::Machine",
+  required => 1,
+  weak_ref => 1,
+);
+
+=item C<jid>
+
+The C<Net::XMPP::JID> object representing the Jabber ID used by the
+C<client>.
+
+=cut
+
+has "jid" => (
+  is => "ro",
+  isa => "Net::XMPP::JID",
+  lazy => 1,
+  builder => "_build_jid",
+  init_arg => undef,
+);
+
+method _build_jid () {
+  my $jid = Net::XMPP::JID->new();
+  $jid->SetJID ( userid => "anonymous", server => $self->machine->hostname,
+		 resource => lc Data::UUID->new()->create_str() );
+  return $jid;
+}
+
+has "pubsub_jid" => (
+  is => "ro",
+  isa => "Net::XMPP::JID",
+  lazy => 1,
+  builder => "_build_pubsub_jid",
+  init_arg => undef,
+);
+
+method _build_pubsub_jid () {
+  my $jid = Net::XMPP::JID->new();
+  $jid->SetJID ( server => "pubsub.".$self->machine->hostname );
+  return $jid;
+}
+
+=item C<client>
+
+The C<Net::XMPP::Client> object representing the connection to the
+XMPP server.
+
+=cut
+
+has "client" => (
+  is => "ro",
+  isa => "Net::XMPP::Client",
+  lazy => 1,
+  builder => "_build_client",
+  init_arg => undef,
+);
+
+method _build_client () {
+
+  # Create XMPP client
+  my $client = Net::XMPP::Client->new();
+
+  $client->SetCallBacks ( send => sub { print "TX ".join ( ",", @_ )."\n" },
+			  receive => sub { print "RX ".join ( ",", @_ )."\n" });
+
+  # Connect to server
+  $client->Connect ( hostname => $self->machine->hostname )
+      or croak "Could not connect to ".$self->machine->hostname.": $!";
+
+  # Authenticate
+  my @result = $client->AuthSend ( username => $self->jid->GetUserID(),
+				   resource => $self->jid->GetResource(),
+				   password => "" );
+  croak "XMPP authorization failed: ".$result[0]." - ".$result[1]
+      unless $result[0] eq "ok";
+
+  return $client;
+}
+
+=back
+
+=head1 METHODS
+
+=over
+
+=item C<< subscribe ( $test ) >>
+
+Subscribe to the results for the specified test, which must be a
+C<qPXE::Test> object.
+
+=cut
+
+method subscribe ( qPXE::Test $test ) {
+
+  # Create test UUID node
+  my $iq = Net::XMPP::IQ->new();
+  my $pubsub = $iq->NewChild ( XMPP_PUBSUB_NS );
+  $iq->SetType ( "set" );
+  $iq->SetTo ( $self->pubsub_jid );
+  $pubsub->SetCreateNode ( $test->uuid );
+  $pubsub->SetConfigure();
+  $iq = $self->client->SendAndReceiveWithID ( $iq )
+      or croak "No reply to XMPP node creation";
+  croak "Could not create XMPP node: ".$iq->GetErrorCode()
+      if $iq->GetType() eq "error";  
+
+  # Subscribe to test UUID node
+  $iq = Net::XMPP::IQ->new();
+  $pubsub = $iq->NewChild ( XMPP_PUBSUB_NS );
+  $iq->SetType ( "set" );
+  $iq->SetTo ( $self->pubsub_jid );
+  $pubsub->SetSubscribeNode ( $test->uuid );
+  $pubsub->SetSubscribeJID ( $self->jid );
+  $iq = $self->client->SendAndReceiveWithID ( $iq )
+      or croak "No reply to XMPP node subscription";
+  croak "Could not subscribe to XMPP node: ".$iq->GetErrorCode()
+      if $iq->GetType() eq "error";
+}
+
+=item C<< subscribe ( $test ) >>
+
+Unsubscribe from the results for the specified test, which must be a
+C<qPXE::Test> object.
+
+=cut
+
+method unsubscribe ( qPXE::Test $test ) {
+
+  # Unsubscribe from test UUID node
+  my $iq = Net::XMPP::IQ->new();
+  my $pubsub = $iq->NewChild ( XMPP_PUBSUB_NS );
+  $iq->SetType ( "set" );
+  $iq->SetTo ( $self->pubsub_jid );
+  $pubsub->SetUnsubscribeNode ( $test->uuid );
+  $pubsub->SetUnsubscribeJID ( $self->jid );
+  $iq = $self->client->SendAndReceiveWithID ( $iq )
+      or croak "No reply to XMPP node unsubscription";
+  croak "Could not unsubscribe from XMPP node: ".$iq->GetErrorCode()
+      if $iq->GetType() eq "error";
+
+  # Delete test UUID node
+  $iq = Net::XMPP::IQ->new();
+  $pubsub = $iq->NewChild ( XMPP_PUBSUB_OWNER_NS );
+  $iq->SetType ( "set" );
+  $iq->SetTo ( $self->pubsub_jid );
+  $pubsub->SetDeleteNode ( $test->uuid );
+  $iq = $self->client->SendAndReceiveWithID ( $iq )
+      or croak "No reply to XMPP node deletion";
+  croak "Could not delete XMPP node: ".$iq->GetErrorCode()
+      if $iq->GetType() eq "error";  
+}
+
+=back
+
+=cut
+
+__PACKAGE__->meta->make_immutable();
+
+1;