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
}