GeniCH.pm.in 8.89 KB
Newer Older
1 2 3
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
Leigh B. Stoller's avatar
Leigh B. Stoller committed
4
# Copyright (c) 2008 University of Utah and the Flux Group.
5 6
# All rights reserved.
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
7
package GeniCH;
8

Leigh B. Stoller's avatar
Leigh B. Stoller committed
9
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
10
# The server side of the Geni ClearingHouse API. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
11
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
12 13 14
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);
15

Leigh B. Stoller's avatar
Leigh B. Stoller committed
16 17
@ISA    = "Exporter";
@EXPORT = qw ( );
18

Leigh B. Stoller's avatar
Leigh B. Stoller committed
19 20
# Must come after package declaration!
use lib '@prefix@/lib';
Leigh B. Stoller's avatar
Leigh B. Stoller committed
21
use GeniDB;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
22
use Genixmlrpc;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
23
use GeniResponse;
24 25
use User;
use GeniUser;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
26
use GeniSlice;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
27
use GeniComponent;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
28 29 30 31 32 33 34 35 36 37 38 39
use libtestbed;
use emutil;
use English;
use Data::Dumper;

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";
my $TBAPPROVAL     = "@TBAPPROVALEMAIL@";
my $TBAUDIT   	   = "@TBAUDITEMAIL@";
my $BOSSNODE       = "@BOSSNODE@";
my $OURDOMAIN      = "@OURDOMAIN@";
40 41

##
Leigh B. Stoller's avatar
Leigh B. Stoller committed
42 43 44 45 46
# Lookup a UUID and return a blob of stuff. We allow lookups of both
# users and slices, which is what we allow clients to register.
#
# XXX Not looking at credentials yet, although I think that anyone should
# be able to lookup uuids if they have a valid certificate signed by an SA.
47
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
48
sub LookupUser($)
49
{
Leigh B. Stoller's avatar
Leigh B. Stoller committed
50 51
    my ($argref) = @_;
    my $uuid = $argref->{'uuid'};
52

Leigh B. Stoller's avatar
Leigh B. Stoller committed
53 54
    if (! (defined($uuid) && ($uuid =~ /^[-\w]*$/))) {
	return GeniResponse->MalformedArgsResponse();
55
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
56 57 58 59
    my $user = GeniUser->Lookup($uuid);
    if (!defined($user)) {
	return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED, undef,
				    "No such user $uuid");
60 61
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87
    # Return a blob.
    my $blob = { "uid"    => $user->uid(),
		 "hrn"    => $user->hrn(),
		 "uuid"   => $user->uuid(),
		 "email"  => $user->email(),
		 "name"   => $user->name() };

    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $blob);
}
sub LookupSlice($)
{
    my ($argref) = @_;
    my $uuid = $argref->{'uuid'};

    if (! (defined($uuid) && ($uuid =~ /^[-\w]*$/))) {
	return GeniResponse->MalformedArgsResponse();
    }
    my $slice = GeniSlice->Lookup($uuid);
    if (!defined($slice)) {
	return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED, undef,
				    "No such user $uuid");
    }

    # Return a blob.
    my $blob = { "hrn"          => $slice->hrn(),
		 "uuid"         => $slice->uuid(),
Leigh B. Stoller's avatar
Leigh B. Stoller committed
88 89
		 "creator_uuid" => $slice->creator_uuid(),
		 "cert"         => $slice->cert() };
Leigh B. Stoller's avatar
Leigh B. Stoller committed
90 91

    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $blob);
92 93
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
94
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
95
# Register a new Geni user.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
96
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
97
sub RegisterUser($)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
98
{
Leigh B. Stoller's avatar
Leigh B. Stoller committed
99 100 101 102 103 104 105
    my ($argref) = @_;
    my $hrn   = $argref->{'hrn'};
    my $uid   = $argref->{'uid'};
    my $uuid  = $argref->{'uuid'};
    my $name  = $argref->{'name'};
    my $email = $argref->{'email'};
    my $cert  = $argref->{'cert'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
106

Leigh B. Stoller's avatar
Leigh B. Stoller committed
107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
    if (! (defined($hrn) && defined($uid) && defined($name) &&
	   defined($email) &&
	   defined($cert) && defined($uuid))) {
	return GeniResponse->MalformedArgsResponse();
    }

    #
    # Use the Emulab checkslot routines.
    #
    if (! ($hrn =~ /^[-\w\.]*$/)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "hrn: Invalid characters");
    }
    if (! ($uuid =~ /^[-\w]*$/)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "uuid: Invalid characters");
    }
    if (! TBcheck_dbslot($name, "users", "usr_name", TBDB_CHECKDBSLOT_ERROR)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "name: ". TBFieldErrorString());
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
128
    if (! TBcheck_dbslot($uid, "users", "uid", TBDB_CHECKDBSLOT_ERROR)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
129 130 131 132 133 134 135
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "uid: ". TBFieldErrorString());
    }
    if (! TBcheck_dbslot($email, "users", "usr_email",TBDB_CHECKDBSLOT_ERROR)){
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "email: ". TBFieldErrorString());
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
136
    if (! ($cert =~ /^[\012\015\040-\176]*$/)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
137
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
138
				    "cert: Invalid characters");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
139
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
140
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
141
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
142 143
    # The SA UUID comes from the SSL environment (certificate). Verify it
    # and the prefix match for the uuid.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
144 145 146
    #
    # Need to verify the UUID is permitted for the SA making the request.
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167
    my $sa_uuid = $ENV{'GENIUUID'};
    my $query_result =
	DBQueryWarn("select idx, uuid_prefix from geni_sliceauthorities ".
		    "where uuid='$sa_uuid'");
    return GeniResponse->Create(GENIRESPONSE_DBERROR)
	if (!defined($query_result));
    
    return GeniResponse->Create(GENIRESPONSE_REFUSED, undef, "Who are You?")
	if (!$query_result->numrows);

    my ($sa_idx, $uuid_prefix)= $query_result->fetchrow_array();

    if ($uuid =~ /^\w+\-\w+\-\w+\-\w+\-(\w+)$/) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "uuid: Prefix mismatch")
	    if ("$uuid_prefix" ne "$1");
    }
    else {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper format for uuid");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
168

Leigh B. Stoller's avatar
Leigh B. Stoller committed
169 170 171 172
    #
    # XXX
    #
    # What kind of uniquess requirements do we need? No one else with this
Leigh B. Stoller's avatar
Leigh B. Stoller committed
173 174
    # email address? Of course, we have to allow hrn reuse, but should we
    # require that for a given SA, that hrn is unique, at least to avoid
Leigh B. Stoller's avatar
Leigh B. Stoller committed
175 176
    # lots of confusion?
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
177 178 179 180 181 182 183 184 185 186
    if (GeniUser->CheckExisting($hrn, $email)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "$hrn/$email already registered");
    }

    my $newuser = GeniUser->Create($hrn, $uid, $uuid,
				   $name, $email, $cert, $sa_idx);
    if (!defined($newuser)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "$hrn/$email could not be registered");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
187
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
188 189 190

    return GeniResponse->Create(GENIRESPONSE_SUCCESS, undef,
				"$hrn/$email has been registered");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
191 192
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
193
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
194
# Register a new Geni slice in the DB. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
195 196 197 198 199 200 201
#
sub RegisterSlice($)
{
    my ($argref) = @_;
    my $hrn   = $argref->{'hrn'};
    my $uuid  = $argref->{'uuid'};
    my $creator_uuid  = $argref->{'creator_uuid'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
202
    my $cert  = $argref->{'cert'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219

    if (! (defined($hrn) && defined($uuid) && defined($creator_uuid))) {
	return Protogeni::MalformedArgsResponse();
    }

    if (! ($hrn =~ /^[-\w\.]*$/)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "hrn: Invalid characters");
    }
    if (! ($uuid =~ /^[-\w]*$/)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "uuid: Invalid characters");
    }
    if (! ($creator_uuid =~ /^[-\w]*$/)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "creator_uuid: Invalid characters");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
220 221 222 223
    if (! ($cert =~ /^[\012\015\040-\176]*$/)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "cert: Invalid characters");
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
224 225

    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
226
    # Make sure the geni user exists. 	
Leigh B. Stoller's avatar
Leigh B. Stoller committed
227 228 229
    #
    my $user = GeniUser->Lookup($creator_uuid);
    if (!defined($user)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
230 231
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "creator_uuid: No such User");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
232 233 234 235 236 237 238 239 240 241
    }

    #
    # Make sure slice hrn and uuid are unique.
    #
    if (GeniSlice->CheckExisting($hrn, $uuid)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "$hrn or $uuid already registered");
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269
    #
    # The SA UUID comes from the SSL environment (certificate). Verify it
    # and the prefix match for the uuid.
    #
    # Need to verify the UUID is permitted for the SA making the request.
    #
    my $sa_uuid = $ENV{'GENIUUID'};
    my $query_result =
	DBQueryWarn("select idx, uuid_prefix from geni_sliceauthorities ".
		    "where uuid='$sa_uuid'");
    return GeniResponse->Create(GENIRESPONSE_DBERROR)
	if (!defined($query_result));
    
    return GeniResponse->Create(GENIRESPONSE_REFUSED, undef, "Who are You?")
	if (!$query_result->numrows);

    my ($sa_idx, $uuid_prefix)= $query_result->fetchrow_array();

    if ($uuid =~ /^\w+\-\w+\-\w+\-\w+\-(\w+)$/) {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "uuid: Prefix mismatch")
	    if ("$uuid_prefix" ne "$1");
    }
    else {
	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
				    "Improper format for uuid");
    }

Leigh B. Stoller's avatar
Leigh B. Stoller committed
270 271
    my $newslice = GeniSlice->Create($hrn, $uuid, $creator_uuid, $cert,
				     $sa_idx);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
272 273 274 275 276 277 278 279 280 281
    if (!defined($newslice)) {
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "$hrn/$uuid could not be registered");
    }

    return GeniResponse->Create(GENIRESPONSE_SUCCESS, undef,
				"$hrn/$uuid has been registered");
}

#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
282 283
# This is just a placeholder; return a list of all components. Eventually
# takes an rspec and we do a resource mapping. 
Leigh B. Stoller's avatar
Leigh B. Stoller committed
284 285 286 287
#
sub DiscoverResources($)
{
    my ($argref) = @_;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
288
    my $slice  = $argref->{'slice'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
289

Leigh B. Stoller's avatar
Leigh B. Stoller committed
290 291
    # This is a certificate. Ignored for now. 
    if (!defined($slice)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
292 293 294 295
	return Protogeni::MalformedArgsResponse();
    }

    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
296
    # Return simple list of components (hashes).
Leigh B. Stoller's avatar
Leigh B. Stoller committed
297 298
    #
    my @results = ();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
299
    my $query_result = DBQueryWarn("select uuid from geni_components");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
300 301 302
    return GeniResponse->Create(GENIRESPONSE_DBERROR)
	if (!defined($query_result));

Leigh B. Stoller's avatar
Leigh B. Stoller committed
303 304 305 306 307
    while (my ($component_uuid) = $query_result->fetchrow_array()) {
	my $component = GeniComponent->Lookup($component_uuid);
	return GeniResponse->Create(GENIRESPONSE_DBERROR)
	    if (!defined($component));
	    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
308
	push(@results, { "uuid" => $component_uuid,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
309 310 311
			 "hrn"  => $component->hrn(),
			 "url"  => $component->url(),
			 "cert" => $component->cert() });
Leigh B. Stoller's avatar
Leigh B. Stoller committed
312
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
313
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, \@results);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
314
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
315