GeniCM.pm.in 3.15 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 libtestbed;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
28
use emutil;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
29 30
use English;
use Data::Dumper;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
31
use Experiment;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
32 33 34 35 36 37 38 39 40 41

# 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
42 43 44 45 46 47 48 49
#
# 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
50 51
    my $owner_uuid = $argref->{'owner_uuid'};
    my $slice_uuid = $argref->{'slice_uuid'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
52 53 54 55 56
    my $rspec      = $argref->{'rspec'};

    if (! (defined($slice_uuid) && ($slice_uuid =~ /^[-\w]+$/))) {
	return GeniResponse->MalformedArgsResponse();
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
57 58 59 60
    # 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
61 62 63
    if (! defined($rspec)) {
	return GeniResponse->MalformedArgsResponse();
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
64 65 66 67 68 69

    #
    # If the underlying experiment does not exist, need to create
    # a holding experiment.
    #
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
70 71 72 73 74 75 76 77 78 79
    #
    # An rspec is a structure with a node count. :-)
    #
    # Find out how many nodes are available and grant that many. Silly, eh?
    #
    $rspec->{'granted'} = $rspec->{'requested'};

    #
    # Return a signed ticket.
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
80
    my $ticket = GeniTicket->Create($slice_uuid, $owner_uuid, $rspec);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
81 82 83 84 85 86 87 88
    if (!defined($ticket)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not create GeniTicket object");
    }
    if ($ticket->Sign() != 0) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "Could not sign Ticket");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121
    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");
    }

    #
    # 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");
    }
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, 0, "Wow!");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
122
}