GeniCM.pm.in 5.37 KB
Newer Older
Leigh B. Stoller's avatar
Leigh B. Stoller committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2008 University of Utah and the Flux Group.
# All rights reserved.
#
package GeniCM;

#
# The server side of the CM interface on remote sites. Also communicates
# with the GMC interface at Geni Central as a client.
#
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);

@ISA    = "Exporter";
@EXPORT = qw ( );

# Must come after package declaration!
use lib '@prefix@/lib';
use GeniDB;
use Genixmlrpc;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
24
25
use GeniResponse;
use GeniTicket;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
26
use GeniSliver;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
27
use GeniUser;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
28
use libtestbed;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
29
30
31
# Hate to import all this crap; need a utility library.
use libdb qw(TBGetUniqueIndex TBcheck_dbslot TBDB_CHECKDBSLOT_ERROR);
use User;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
32
33
use English;
use Data::Dumper;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
34
use Experiment;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
35
36
37
38
39
40
41
42
43

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";
my $TBAPPROVAL     = "@TBAPPROVALEMAIL@";
my $TBAUDIT   	   = "@TBAUDITEMAIL@";
my $BOSSNODE       = "@BOSSNODE@";
my $OURDOMAIN      = "@OURDOMAIN@";
my $GENICENTRAL    = "https://boss/protogeni/xmlrpc";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
44
45
my $CREATEEXPT     = "$TB/bin/batchexp";
my $NALLOC	   = "$TB/bin/nalloc";
Leigh B. Stoller's avatar
Leigh B. Stoller committed
46

Leigh B. Stoller's avatar
Leigh B. Stoller committed
47
48
49
50
51
52
53
54
#
# Respond to a GetTicket request. No worries about credentials yet; we
# trust the caller cause it got past the SSL client verify checks in the
# web server.
#
sub GetTicket($)
{
    my ($argref) = @_;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
55
56
    my $owner_uuid = $argref->{'owner_uuid'};
    my $slice_uuid = $argref->{'slice_uuid'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
57
58
59
60
61
    my $rspec      = $argref->{'rspec'};

    if (! (defined($slice_uuid) && ($slice_uuid =~ /^[-\w]+$/))) {
	return GeniResponse->MalformedArgsResponse();
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
62
63
64
65
    # XXX This needs to come from the SSL environment.
    if (! (defined($owner_uuid) && ($owner_uuid =~ /^[-\w]+$/))) {
	return GeniResponse->MalformedArgsResponse();
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
66
67
68
    if (! defined($rspec)) {
	return GeniResponse->MalformedArgsResponse();
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
69
70

    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
71
    # XXX Should we create a local geni_slices record in the DB?
Leigh B. Stoller's avatar
Leigh B. Stoller committed
72
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
73
74
75
76
77
78
if (0) {
    #
    # If the underlying experiment does not exist, need to create
    # a holding experiment. All these are going to go into the same
    # project for now. Generally, users for non-local slices do not
    # have local accounts or directories.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
79
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
    my $experiment = Experiment->Lookup($slice_uuid);
    if (!defined($experiment)) {
	#
	# Form an eid for the experiment. 
	#
	my $eid = "slice" . TBGetUniqueIndex('next_sliceid', 1);

	# Note the -h option; allows experiment with no NS file.
	system("$CREATEEXPT -q -i -w -E 'Geni Slice Experiment' ".
	       "-h '$slice_uuid' -p genislices -e $eid");
	if ($?) {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Internal Error");
	}
	$experiment = Experiment->Lookup($slice_uuid);
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
97
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
98
99
100
    # An rspec is a structure that requests a specific node. If that node
    # is available, then reserve it. Otherwise the ticket cannot be
    # granted.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
101
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
102
103
104
105
106
107
108
109
110
111
112
113
    my $node_id = $rspec->{'node_id'};
    my $pid     = $experiment->pid();
    my $eid     = $experiment->eid();

    if (defined($node_id) && $node_id =~ /^(\w*)$/) {
	$node_id = $1;
    }
    else {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper node id");
    }
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
114
115

    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
116
    # Create the ticket first, before allocating the node.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
117
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
118
    my $ticket = GeniTicket->Create($slice_uuid, $owner_uuid, $rspec);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
119
120
121
122
    if (!defined($ticket)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniTicket object");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
123
124
125
126
127
128
129
130
131
132
133
134
135
136
if (0) {
    # Nalloc might fail if the node gets picked up by someone else.
#    system("$NALLOC $pid $eid $node_id");
    if (($? >> 8) < 0) {
	$ticket->Delete();
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Allocation failure");
    }
    elsif (($? >> 8) > 0) {
	$ticket->Delete();
	return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
				    "Could not allocate node\n");
    }
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
137
    if ($ticket->Sign() != 0) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
138
139
	# Release will free the node.
	$ticket->Release();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
140
141
142
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not sign Ticket");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
    return GeniResponse->Create(GENIRESPONSE_SUCCESS,
				$ticket->asString());
}

#
# Create a sliver.
#
sub CreateSliver($)
{
    my ($argref) = @_;
    my $ticket   = $argref->{'ticket'};

    if (! (defined($ticket) &&
	   !TBcheck_dbslot($ticket, "default", "text",
			   TBDB_CHECKDBSLOT_ERROR))) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "ticket: ". TBFieldErrorString());
    }
    $ticket = GeniTicket->CreateFromSignedTicket($ticket);
    if (!defined($ticket)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniTicket object");
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
167
168
169
170
171
172
    my $experiment = Experiment->Lookup($ticket->slice_uuid());
    if (!defined($experiment)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "No local experiment for slice");
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
173
174
175
176
177
178
179
180
    #
    # XXX TODO: Need to verify the invoking user is the one in the ticket.
    #
    my $sliver = GeniSliver->Create($ticket);
    if (!defined($sliver)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniSliver object");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
181
182
183
184
185
186
187
188
189
190
191
192

    #
    # Provision the slice. Okay, we already allocated the node above,
    # so this should just work, unless the node has been released cause
    # it has been too long.
    #
    if ($sliver->Provision() != 0) {
	$sliver->Delete();
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not provision sliver");
    }
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
193
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, 0, "Wow!");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
194
}