[perl] Allow for reporting of test results via HTTP

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

perl/Makefile.PL

@@ -10,6 +10,7 @@ install_script "qpxe-dhcpd", "qpxe-demo";
 
 requires "Carp";
 requires "Carp::Clan";
+requires "TryCatch";
 requires "Moose";
 requires "Moose::Util::TypeConstraints";
 requires "MooseX::StrictConstructor";
@@ -22,5 +23,6 @@ requires "Net::SSH::Perl";
 requires "Net::SFTP";
 requires "Net::XMPP";
 requires "Data::UUID";
+requires "Catalyst";
 
 WriteAll;

perl/lib/Net/XMPP/PubSub.pm

@@ -6,21 +6,76 @@ use strict;
 use warnings;
 
 use parent qw ( Exporter );
-our @EXPORT_OK = qw ( XMPP_PUBSUB_NS XMPP_PUBSUB_OWNER_NS );
+our %EXPORT_TAGS = (
+  ns => [ qw ( XMPP_PUBSUB_NS XMPP_PUBSUB_OWNER_NS XMPP_PUBSUB_EVENT_NS ) ],
+);
+our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
 
 use constant XMPP_PUBSUB_NS => "http://jabber.org/protocol/pubsub";
 use constant XMPP_PUBSUB_OWNER_NS => "http://jabber.org/protocol/pubsub#owner";
+use constant XMPP_PUBSUB_EVENT_NS => "http://jabber.org/protocol/pubsub#event";
+
+Net::XMPP::Protocol->AddNamespace (
+  ns => "__netxmpp__:iq:pubsub:publish:item",
+  tag => "item",
+  xpath => {
+    ID => { type => "scalar", path => '@id' },    
+    Raw => { type => "raw" },
+  } );
+
+Net::XMPP::Protocol->AddNamespace (
+  ns => "__netxmpp__:iq:pubsub:publish",
+  tag => "publish",
+  xpath => {
+    Node => { type => "scalar", path => '@node' },
+    Item => { type => "child", path => 'item',
+	      child => { ns => "__netxmpp__:iq:pubsub:publish:item" },
+	      calls => [ qw ( Add Get Defined ) ] },
+  } );
+
+Net::XMPP::Protocol->AddNamespace (
+  ns => "__netxmpp__:iq:pubsub:configure:x:field",
+  tag => "field",
+  xpath => {
+    Var => { type => "scalar", path => '@var' },
+    Value => { type => "scalar", path => 'value/text()' },
+  } );
+
+Net::XMPP::Protocol->AddNamespace (
+  ns => "jabber:x:data",
+  tag => "x",
+  xpath => {
+    Type => { type => "scalar", path => '@type' },
+    Field => { type => "child", path => 'field',
+	       child => { ns => "__netxmpp__:iq:pubsub:configure:x:field" },
+	       calls => [ qw ( Add Get Defined ) ] },
+  } );
+
+Net::XMPP::Protocol->AddNamespace (
+  ns => "__netxmpp__:iq:pubsub:configure",
+  tag => "configure",
+  xpath => {
+    Node => { type => "scalar", path => '@node' },
+    X => { type => "child", path => 'x',
+	   child => { ns => "jabber:x:data" },
+	   calls => [ qw ( Add Get Defined ) ] },
+  } );
 
 Net::XMPP::Protocol->AddNamespace (
   ns => XMPP_PUBSUB_NS,
   tag => "pubsub",
   xpath => {
     CreateNode => { type => "scalar", path => 'create/@node' },
-    Configure => { type => "flag", path => 'configure' },
+    Configure => { type => "child", path => 'configure',
+		   child => { ns => "__netxmpp__:iq:pubsub:configure" },
+		   calls => [ qw ( Add Get Defined ) ] },
     SubscribeNode => { type => "scalar", path => 'subscribe/@node' },
     SubscribeJID => { type => "jid", path => 'subscribe/@jid' },
     UnsubscribeNode => { type => "scalar", path => 'unsubscribe/@node' },
     UnsubscribeJID => { type => "jid", path => 'unsubscribe/@jid' },
+    Publish => { type => "child", path => 'publish',
+		 child => { ns => "__netxmpp__:iq:pubsub:publish" },
+		 calls => [ qw ( Add Get Defined ) ] },
   } );
 
 Net::XMPP::Protocol->AddNamespace (
@@ -30,4 +85,23 @@ Net::XMPP::Protocol->AddNamespace (
     DeleteNode => { type => "scalar", path => 'delete/@node' },
   } );
 
+Net::XMPP::Protocol->AddNamespace (
+  ns => "__netxmpp__:message:pubsub:items",
+  tag => "items",
+  xpath => {
+    Node => { type => "scalar", path => '@node' },
+    Item => { type => "child", path => 'item',
+	      child => { ns => "__netxmpp__:iq:pubsub:publish:item" },
+	      calls => [ qw ( Add Get Defined ) ] },
+  } );
+
+Net::XMPP::Protocol->AddNamespace (
+  ns => XMPP_PUBSUB_EVENT_NS,
+  tag => "event",
+  xpath => {
+    Items => { type => "child", path => 'items',
+	       child => { ns => "__netxmpp__:message:pubsub:items" },
+	       calls => [ qw ( Add Get Defined ) ] },
+  } );
+
 1;

perl/lib/qPXE/Dhcpd.pm

@@ -19,12 +19,8 @@ qPXE::Dhcpd - An instance of ISC DHCPD
 
 =cut
 
-use Moose;
-use MooseX::StrictConstructor;
-use MooseX::Method::Signatures;
-use MooseX::MarkAsMethods autoclean => 1;
+use qPXE::Moose;
 use File::Temp;
-use Carp;
 use strict;
 use warnings;
 

perl/lib/qPXE/Error.pm

@@ -0,0 +1,22 @@
+package qPXE::Error;
+
+=head1 NAME
+
+qPXE::Error - Base class for qPXE exceptions
+
+=head1 SYNOPSIS
+
+    use qPXE::Error;
+
+    qPXE::Error->throw ( "Something bad happened" );
+
+=cut
+
+use qPXE::Moose;
+
+extends "Throwable::Error";
+
+# StackTrace::Auto prevents inlined constructors
+__PACKAGE__->meta->make_immutable ( inline_constructor => 0 );
+
+1;

perl/lib/qPXE/Error/XMPP.pm

@@ -0,0 +1,234 @@
+package qPXE::Error::XMPP;
+
+=head1 NAME
+
+qPXE::Error::XMPP - qPXE XMPP exceptions
+
+=head1 SYNOPSIS
+
+    use qPXE::Error::XMPP;
+
+    qPXE::Error::XMPP::Timeout->throw();
+
+=head1 SUBCLASSES
+
+=cut
+
+use qPXE::Moose;
+extends "qPXE::Error";
+__PACKAGE__->meta->make_immutable ( inline_constructor => 0 );
+
+=head2 C<qPXE::Error::XMPP::CannotConnect>
+
+Cannot connect to XMPP server.
+
+=head3 ATTRIBUTES
+
+=over 
+
+=item C<detail>
+
+Detailed reason for connection failure.
+
+=back
+
+=cut
+
+package qPXE::Error::XMPP::CannotConnect;
+use qPXE::Moose;
+extends "qPXE::Error::XMPP";
+has "+message" => (
+  lazy => 1,
+  builder => "_build_message"
+);
+has "detail" => (
+  is => "ro",
+  isa => "Str",
+  required => 1,
+  default => sub { $! },
+);
+method _build_message () {
+  return "Cannot connect to XMPP server: ".$self->detail;
+}
+__PACKAGE__->meta->make_immutable ( inline_constructor => 0 );
+
+=head2 C<qPXE::Error::XMPP::Unauthorized>
+
+XMPP authorization failed.
+
+=head3 ATTRIBUTES
+
+=over 
+
+=item C<detail>
+
+Detailed reason for authorization failure.
+
+=back
+
+=cut
+
+package qPXE::Error::XMPP::Unauthorized;
+use qPXE::Moose;
+extends "qPXE::Error::XMPP";
+has "+message" => (
+  lazy => 1,
+  builder => "_build_message"
+);
+has "detail" => (
+  is => "ro",
+  isa => "Str",
+  required => 1,
+);
+method _build_message () {
+  return "XMPP authorization failed: ".$self->detail;
+}
+__PACKAGE__->meta->make_immutable ( inline_constructor => 0 );
+
+=head2 C<qPXE::Error::XMPP::Disconnected>
+
+Disconnected from XMPP server.
+
+=cut
+
+package qPXE::Error::XMPP::Disconnected;
+use qPXE::Moose;
+extends "qPXE::Error::XMPP";
+has "+message" => ( default => "Disconnected from XMPP server" );
+__PACKAGE__->meta->make_immutable ( inline_constructor => 0 );
+
+=head2 C<qPXE::Error::XMPP::Timeout>
+
+Timed out while waiting for XMPP server.
+
+=cut
+
+package qPXE::Error::XMPP::Timeout;
+use qPXE::Moose;
+extends "qPXE::Error::XMPP";
+has "+message" => ( default => "Timed out waiting for XMPP message" );
+__PACKAGE__->meta->make_immutable ( inline_constructor => 0 );
+
+=head2 C<qPXE::Error::XMPP::IQMissing>
+
+No response to XMPP InfoQuery.
+
+=head3 ATTRIBUTES
+
+=over
+
+=item C<request>
+
+The C<Net::XMPP::IQ> object representing the IQ request.
+
+=back
+
+=cut
+
+package qPXE::Error::XMPP::IQMissing;
+use qPXE::Moose;
+extends "qPXE::Error::XMPP";
+has "+message" => (
+  lazy => 1,
+  builder => "_build_message"
+);
+has "request" => (
+  is => "ro",
+  isa => "Net::XMPP::IQ",
+  required => 1,
+);
+method _build_message () {
+  return "No response to XMPP InfoQuery:\n".$self->request->GetXML();
+}
+__PACKAGE__->meta->make_immutable ( inline_constructor => 0 );
+
+=head2 C<qPXE::Error::XMPP::IQ>
+
+XMPP InfoQuery failed.
+
+=head3 ATTRIBUTES
+
+=over
+
+=item C<response>
+
+The C<Net::XMPP::IQ> object representing the IQ response.
+
+=back
+
+=cut
+
+package qPXE::Error::XMPP::IQ;
+use qPXE::Moose;
+extends "qPXE::Error::XMPP";
+has "+message" => (
+  lazy => 1,
+  builder => "_build_message"
+);
+has "response" => (
+  is => "ro",
+  isa => "Net::XMPP::IQ",
+  required => 1,
+);
+method _build_message () {
+  return ( "XMPP InfoQuery failed: ".$self->response->GetErrorCode()."\n".
+	   $self->response->GetXML() );
+}
+__PACKAGE__->meta->make_immutable ( inline_constructor => 0 );
+
+=head2 C<qPXE::Error::XMPP::Unexpected>
+
+Unexpected XMPP event message.
+
+=head3 ATTRIBUTES
+
+=over
+
+=item C<node> (optional)
+
+Node ID.
+
+=item C<id> (optional)
+
+Item ID.
+
+=item C<payload> (optional)
+
+Item payload, as an C<XML::LibXML::Document> object.
+
+=back
+
+=cut
+
+package qPXE::Error::XMPP::Unexpected;
+use qPXE::Moose;
+extends "qPXE::Error::XMPP";
+has "+message" => (
+  lazy => 1,
+  builder => "_build_message"
+);
+has "node" => (
+  is => "ro",
+  isa => "Str",
+  predicate => "has_node",
+);
+has "id" => (
+  is => "ro",
+  isa => "Str",
+  predicate => "has_id",
+);
+has "payload" => (
+  is => "ro",
+  isa => "XML::LibXML::Document",
+  predicate => "has_payload",
+);
+method _build_message () {
+  my $message = "Unexpected XMPP message";
+  $message .= " for node \"".$self->node."\"" if $self->has_node;
+  $message .= " with ID \"".$self->id."\"" if $self->has_id;
+  $message .= ":\n".$self->payload->serialize() if $self->has_payload;
+  return $message;
+}
+__PACKAGE__->meta->make_immutable ( inline_constructor => 0 );
+
+1;