GeniResponse.pm 7.65 KB
Newer Older
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1
2
#!/usr/bin/perl -w
#
3
# Copyright (c) 2008-2014 University of Utah and the Flux Group.
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
# 
# {{{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.
# 
# }}}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
#
# 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
Leigh B. Stoller's avatar
Leigh B. Stoller committed
44
	      GENIRESPONSE_RPCERROR GENIRESPONSE_UNAVAILABLE
Leigh B. Stoller's avatar
Leigh B. Stoller committed
45
	      GENIRESPONSE_SEARCHFAILED GENIRESPONSE_UNSUPPORTED
46
	      GENIRESPONSE_BUSY GENIRESPONSE_EXPIRED GENIRESPONSE_INPROGRESS
Leigh B Stoller's avatar
Leigh B Stoller committed
47
	      GENIRESPONSE_ALREADYEXISTS GENIRESPONSE_STRING
48
              GENIRESPONSE_NOT_IMPLEMENTED
49
50
	      GENIRESPONSE_VLAN_UNAVAILABLE GENIRESPONSE_INSUFFICIENT_BANDWIDTH
	      GENIRESPONSE_INSUFFICIENT_NODES
51
52
	      XMLRPC_PARSE_ERROR XMLRPC_SERVER_ERROR XMLRPC_APPLICATION_ERROR
	      XMLRPC_SYSTEM_ERROR XMLRPC_TRANSPORT_ERROR);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
53
54

use overload ('""' => 'Stringify');
55
my $current_response = undef;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70

#
# 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; }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
71
sub GENIRESPONSE_UNAVAILABLE()    {11; }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
72
sub GENIRESPONSE_SEARCHFAILED()   {12; }
73
sub GENIRESPONSE_UNSUPPORTED()    {13; }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
74
75
sub GENIRESPONSE_BUSY()           {14; }
sub GENIRESPONSE_EXPIRED()        {15; }
76
sub GENIRESPONSE_INPROGRESS()     {16; }
Leigh B Stoller's avatar
Leigh B Stoller committed
77
sub GENIRESPONSE_ALREADYEXISTS()  {17; }
78
79
80
sub GENIRESPONSE_VLAN_UNAVAILABLE(){24; }
sub GENIRESPONSE_INSUFFICIENT_BANDWIDTH(){25; }
sub GENIRESPONSE_INSUFFICIENT_NODES(){26; }
81
sub GENIRESPONSE_NOT_IMPLEMENTED(){100; }
82
sub GENIRESPONSE()		  { return $current_response; }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
83

84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
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",
Leigh B Stoller's avatar
Leigh B Stoller committed
103
     "Already Exists",
104
    );
105
$GENIRESPONSE_STRINGS[GENIRESPONSE_NOT_IMPLEMENTED] = "Not Implemented";
106
107
sub GENIRESPONSE_STRING($)
{
108
    my ($code) = @_;
109

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

    return $GENIRESPONSE_STRINGS[$code];
114
}
115

116
117
118
119
120
121
122
123
124
#
# 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; }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
125
126
127
128
129
130
131
132
133
134
#
# 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
#
135
136
137
# For debugging, stash the method and arguments in case we want to
# print things out.
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
138
139
140
141
sub new($$;$$)
{
    my ($class, $code, $value, $output) = @_;

142
143
144
145
146
147
148
    if (!defined($output)) {
	$output = "";
	# Unless its an error, then return standard error string.
	if ($code != GENIRESPONSE_SUCCESS()) {
	    $output = GENIRESPONSE_STRING($code);
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
149
150
151
    $value = 0
	if (!defined($value));

152
153
154
    my $self = {"code"      => $code,
		"value"     => $value,
		"output"    => $output};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
155
156
157
158
159
160
161
162
    bless($self, $class);
    return $self;
}

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

163
164
165
166
167
168
169
    if (!defined($output)) {
	$output = "";
	# Unless its an error, then return standard error string.
	if ($code != GENIRESPONSE_SUCCESS()) {
	    $output = GENIRESPONSE_STRING($code);
	}
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
170
171
172
173
174
175
    $value = 0
	if (!defined($value));

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

    $current_response = $self;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
178
179
180
181
182
183
184
185
186
    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"); }

187
188
189
190
191
192
193
194
195
196
197
198
# 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) = @_;
199
200
201
202

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

208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
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" : "");
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
224
225
226
227
228
229
230
#
# Stringify for output.
#
sub Stringify($)
{
    my ($self) = @_;
    
231
232
233
    my $code   = $self->code();
    my $value  = $self->value();
    my $string = $GENIRESPONSE_STRINGS[$code] || "Unknown";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
234

235
    return "[GeniResponse: code:$code ($string), value:$value]";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
236
237
}

238
sub MalformedArgsResponse($;$)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
239
{
240
241
242
243
244
245
246
    my (undef,$msg) = @_;
    my $saywhat = "Malformed arguments";
    
    $saywhat .= ": $msg"
	if (defined($msg));

    return GeniResponse->Create(GENIRESPONSE_BADARGS, undef, $saywhat);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
247
248
}

249
sub BusyResponse($;$)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
250
{
251
252
253
254
255
    my (undef,$resource) = @_;

    $resource = "resource"
	if (!defined($resource));
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
256
    return GeniResponse->Create(GENIRESPONSE_BUSY,
257
				undef, "$resource is busy; try again later");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
258
259
}

260
261
262
263
264
265
266
267
sub MonitorResponse($)
{
    my (undef) = @_;

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
268
269
270
271
272
273
274
275
276
277
278
279
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;