GeniResponse.pm

#!/usr/bin/perl -w
#
# Copyright (c) 2008-2014 University of Utah and the Flux Group.
# 
# {{{GENIPUBLIC-LICENSE
# 
# GENI Public License
# 
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and/or hardware specification (the "Work") to
# deal in the Work without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense,
# and/or sell copies of the Work, and to permit persons to whom the Work
# is furnished to do so, subject to the following conditions:
# 
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Work.
# 
# THE WORK IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE WORK OR THE USE OR OTHER DEALINGS
# IN THE WORK.
# 
# }}}
#
# Perl code to access an XMLRPC server using http. Derived from the
# Emulab library (pretty sure Dave wrote the http code in that file,
# and I'm just stealing it).
#
package GeniResponse;
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);
@ISA    = "Exporter";
@EXPORT = qw (GENIRESPONSE_SUCCESS GENIRESPONSE_BADARGS GENIRESPONSE_ERROR
	      GENIRESPONSE_FORBIDDEN GENIRESPONSE_BADVERSION
	      GENIRESPONSE_SERVERERROR
	      GENIRESPONSE_TOOBIG GENIRESPONSE_REFUSED
	      GENIRESPONSE_TIMEDOUT GENIRESPONSE_DBERROR
	      GENIRESPONSE_RPCERROR GENIRESPONSE_UNAVAILABLE
	      GENIRESPONSE_SEARCHFAILED GENIRESPONSE_UNSUPPORTED
	      GENIRESPONSE_BUSY GENIRESPONSE_EXPIRED GENIRESPONSE_INPROGRESS
	      GENIRESPONSE_ALREADYEXISTS GENIRESPONSE_STRING
              GENIRESPONSE_NOT_IMPLEMENTED
	      GENIRESPONSE_VLAN_UNAVAILABLE GENIRESPONSE_INSUFFICIENT_BANDWIDTH
	      GENIRESPONSE_INSUFFICIENT_NODES
	      XMLRPC_PARSE_ERROR XMLRPC_SERVER_ERROR XMLRPC_APPLICATION_ERROR
	      XMLRPC_SYSTEM_ERROR XMLRPC_TRANSPORT_ERROR);

use overload ('""' => 'Stringify');
my $current_response = undef;

#
# GENI XMLRPC defs. Also see ../lib/Protogeni.pm.in if you change this.
#
sub GENIRESPONSE_SUCCESS()        { 0; }
sub GENIRESPONSE_BADARGS()        { 1; }
sub GENIRESPONSE_ERROR()          { 2; }
sub GENIRESPONSE_FORBIDDEN()      { 3; }
sub GENIRESPONSE_BADVERSION()     { 4; }
sub GENIRESPONSE_SERVERERROR()    { 5; }
sub GENIRESPONSE_TOOBIG()         { 6; }
sub GENIRESPONSE_REFUSED()        { 7; }
sub GENIRESPONSE_TIMEDOUT()       { 8; }
sub GENIRESPONSE_DBERROR()        { 9; }
sub GENIRESPONSE_RPCERROR()       {10; }
sub GENIRESPONSE_UNAVAILABLE()    {11; }
sub GENIRESPONSE_SEARCHFAILED()   {12; }
sub GENIRESPONSE_UNSUPPORTED()    {13; }
sub GENIRESPONSE_BUSY()           {14; }
sub GENIRESPONSE_EXPIRED()        {15; }
sub GENIRESPONSE_INPROGRESS()     {16; }
sub GENIRESPONSE_ALREADYEXISTS()  {17; }
sub GENIRESPONSE_VLAN_UNAVAILABLE(){24; }
sub GENIRESPONSE_INSUFFICIENT_BANDWIDTH(){25; }
sub GENIRESPONSE_INSUFFICIENT_NODES(){26; }
sub GENIRESPONSE_NOT_IMPLEMENTED(){100; }
sub GENIRESPONSE()		  { return $current_response; }

my @GENIRESPONSE_STRINGS =
    (
     "Success",
     "Bad Arguments",
     "Error",
     "Operation Forbidden",
     "Bad Version",
     "Server Error",
     "Too Big",
     "Operation Refused",
     "Operation Times Out",
     "Database Error",
     "RPC Error",
     "Unavailable",
     "Search Failed",
     "Operation Unsupported",
     "Busy",
     "Expired",
     "In Progress",
     "Already Exists",
    );
$GENIRESPONSE_STRINGS[GENIRESPONSE_NOT_IMPLEMENTED] = "Not Implemented";
sub GENIRESPONSE_STRING($)
{
    my ($code) = @_;

    return "Unknown Error $code"
	if ($code < 0 || $code > scalar(@GENIRESPONSE_STRINGS));

    return $GENIRESPONSE_STRINGS[$code];
}

#
# These are the real XMLRPC errors as defined by the RFC
#
sub XMLRPC_PARSE_ERROR()	{ -32700; }
sub XMLRPC_SERVER_ERROR()       { -32600; }
sub XMLRPC_APPLICATION_ERROR()  { -32500; }
sub XMLRPC_SYSTEM_ERROR()       { -32400; }
sub XMLRPC_TRANSPORT_ERROR()    { -32300; }

#
# This is the (python-style) "structure" we want to return.
#
# class Response:
#    def __init__(self, code, value=0, output=""):
#        self.code     = code            # A RESPONSE code
#        self.value    = value           # A return value; any valid XML type.
#        self.output   = output          # Pithy output to print
#        return
#
# For debugging, stash the method and arguments in case we want to
# print things out.
#
sub new($$;$$)
{
    my ($class, $code, $value, $output) = @_;

    if (!defined($output)) {
	$output = "";
	# Unless its an error, then return standard error string.
	if ($code != GENIRESPONSE_SUCCESS()) {
	    $output = GENIRESPONSE_STRING($code);
	}
    }
    $value = 0
	if (!defined($value));

    my $self = {"code"      => $code,
		"value"     => $value,
		"output"    => $output};
    bless($self, $class);
    return $self;
}

sub Create($$;$$)
{
    my ($class, $code, $value, $output) = @_;

    if (!defined($output)) {
	$output = "";
	# Unless its an error, then return standard error string.
	if ($code != GENIRESPONSE_SUCCESS()) {
	    $output = GENIRESPONSE_STRING($code);
	}
    }
    $value = 0
	if (!defined($value));

    my $self = {"code"   => $code,
		"value"  => $value,
		"output" => $output};

    $current_response = $self;
    return $self;
}

# accessors
sub field($$)           { return ($_[0]->{$_[1]}); }
sub code($)		{ return field($_[0], "code"); }
sub value($)		{ return field($_[0], "value"); }
sub output($)		{ return field($_[0], "output"); }

# Check for response object. Very bad, but the XML encoder does not
# allow me to intercept the encoding operation on a blessed object.
sub IsResponse($)
{
    my ($arg) = @_;
    
    return (ref($arg) eq "HASH" &&
	    exists($arg->{'code'}) && exists($arg->{'value'}));
}
sub IsError($)
{
    my ($arg) = @_;

    if (ref($arg) eq "GeniResponse") {
	return $arg->code() ne GENIRESPONSE_SUCCESS;
    }
    return (ref($arg) eq "HASH" &&
	    exists($arg->{'code'}) && exists($arg->{'value'}) &&
	    $arg->{'code'} ne GENIRESPONSE_SUCCESS);
}

sub Dump($)
{
    my ($self) = @_;
    
    my $code   = $self->code();
    my $value  = $self->value();
    my $string = $GENIRESPONSE_STRINGS[$code] || "Unknown";
    my $output;

    $output = $self->output()
	if (defined($self->output()) && $self->output() ne "");

    return "code:$code ($string), value:$value" .
	(defined($output) ? ", output:$output" : "");
}

#
# Stringify for output.
#
sub Stringify($)
{
    my ($self) = @_;
    
    my $code   = $self->code();
    my $value  = $self->value();
    my $string = $GENIRESPONSE_STRINGS[$code] || "Unknown";

    return "[GeniResponse: code:$code ($string), value:$value]";
}

sub MalformedArgsResponse($;$)
{
    my (undef,$msg) = @_;
    my $saywhat = "Malformed arguments";
    
    $saywhat .= ": $msg"
	if (defined($msg));

    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef, $saywhat);
}

sub BusyResponse($;$)
{
    my (undef,$resource) = @_;

    $resource = "resource"
	if (!defined($resource));
    
    return GeniResponse->Create(GENIRESPONSE_BUSY,
				undef, "$resource is busy; try again later");
}

sub MonitorResponse($)
{
    my (undef) = @_;

    return GeniResponse->Create(GENIRESPONSE_BUSY,
			undef, "start/restart in progress; try again later");
}

sub BadArgsResponse(;$)
{
    my ($msg) = @_;

    $msg = "Bad arguments to method"
	if (!defined($msg));
    
    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef, $msg);
}

# _Always_ make sure that this 1 is at the end of the file...
1;