GeniResponse.pm 8.11 KB
Newer Older
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1
2
#!/usr/bin/perl -w
#
Leigh B Stoller's avatar
Leigh B Stoller committed
3
# Copyright (c) 2008-2015 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
	      GENIRESPONSE_VLAN_UNAVAILABLE GENIRESPONSE_INSUFFICIENT_BANDWIDTH
Leigh B Stoller's avatar
Leigh B Stoller committed
50
	      GENIRESPONSE_INSUFFICIENT_NODES GENIRESPONSE_SERVER_UNAVAILABLE
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
83
# This is HTTP_SERVICE_UNAVAILABLE
sub GENIRESPONSE_SERVER_UNAVAILABLE() {503;}
84
sub GENIRESPONSE()		  { return $current_response; }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
85

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
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
105
     "Already Exists",
106
107
108
109
110
111
112
113
114
     "Error 18",
     "Error 19",
     "Error 20",
     "Error 21",
     "Error 22",
     "Error 23",
     "Vlan Unavailable",
     "Insufficient Bandwidth",
     "Insufficient Nodes",
115
    );
116
$GENIRESPONSE_STRINGS[GENIRESPONSE_NOT_IMPLEMENTED] = "Not Implemented";
117
118
sub GENIRESPONSE_STRING($)
{
119
    my ($code) = @_;
120

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

    return $GENIRESPONSE_STRINGS[$code];
125
}
126

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

153
154
155
156
157
158
159
    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
160
161
162
    $value = 0
	if (!defined($value));

163
164
165
    my $self = {"code"      => $code,
		"value"     => $value,
		"output"    => $output};
166
167
168
    $self->{"logurl"} = $logurl
	if (defined($logurl));

Leigh B. Stoller's avatar
Leigh B. Stoller committed
169
170
171
172
173
174
175
176
    bless($self, $class);
    return $self;
}

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

177
178
179
180
181
182
183
    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
184
185
186
187
188
189
    $value = 0
	if (!defined($value));

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

    $current_response = $self;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
192
193
194
195
196
197
198
199
    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"); }
200
201
202
203
# This is very optional.
sub logurl($) {
    return (exists($_[0]->{"logurl"}) ? $_[0]->{"logurl"} : undef);
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
204

205
206
207
208
209
210
211
212
213
214
215
216
# 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) = @_;
217
218
219
220

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

226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
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
242
243
244
245
246
247
248
#
# Stringify for output.
#
sub Stringify($)
{
    my ($self) = @_;
    
249
250
251
    my $code   = $self->code();
    my $value  = $self->value();
    my $string = $GENIRESPONSE_STRINGS[$code] || "Unknown";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
252

253
    return "[GeniResponse: code:$code ($string), value:$value]";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
254
255
}

256
sub MalformedArgsResponse($;$)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
257
{
258
259
260
261
262
263
264
    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
265
266
}

267
sub BusyResponse($;$)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
268
{
269
270
271
272
273
    my (undef,$resource) = @_;

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

278
279
280
281
282
283
284
285
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
286
287
288
289
290
291
292
293
294
295
296
297
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;