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
}