GeniCH.pm.in 8.56 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 27 28 29 30 31 32 33 34 35 36 37 38
use GeniSlice;
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@";
39 40

##
Leigh B. Stoller's avatar
Leigh B. Stoller committed
41 42 43 44 45
# 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.
46
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
47
sub LookupUser($)
48
{
Leigh B. Stoller's avatar
Leigh B. Stoller committed
49 50
    my ($argref) = @_;
    my $uuid = $argref->{'uuid'};
51

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

Leigh B. Stoller's avatar
Leigh B. Stoller committed
61 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 88 89
    # 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(),
		 "creator_uuid" => $slice->creator_uuid() };

    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $blob);
90 91
}

Leigh B. Stoller's avatar
Leigh B. Stoller committed
92
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
93
# Register a new Geni user.
Leigh B. Stoller's avatar
Leigh B. Stoller committed
94
#
Leigh B. Stoller's avatar
Leigh B. Stoller committed
95
sub RegisterUser($)
Leigh B. Stoller's avatar
Leigh B. Stoller committed
96
{
Leigh B. Stoller's avatar
Leigh B. Stoller committed
97 98 99 100 101 102 103
    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
104

Leigh B. Stoller's avatar
Leigh B. Stoller committed
105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125
    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
126
    if (! TBcheck_dbslot($uid, "users", "uid", TBDB_CHECKDBSLOT_ERROR)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
127 128 129 130 131 132 133
	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
134
    if (! ($cert =~ /^[\012\015\040-\176]*$/)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
135
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
Leigh B. Stoller's avatar
Leigh B. Stoller committed
136
				    "cert: Invalid characters");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
137
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
138
    
Leigh B. Stoller's avatar
Leigh B. Stoller committed
139
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
140 141
    # 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
142 143 144
    #
    # Need to verify the UUID is permitted for the SA making the request.
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
    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
166

Leigh B. Stoller's avatar
Leigh B. Stoller committed
167 168 169 170
    #
    # XXX
    #
    # What kind of uniquess requirements do we need? No one else with this
Leigh B. Stoller's avatar
Leigh B. Stoller committed
171 172
    # 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
173 174
    # lots of confusion?
    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
175 176 177 178 179 180 181 182 183 184
    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
185
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
186 187 188

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

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

    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
    # Make sure the geni user exists. 	
Leigh B. Stoller's avatar
Leigh B. Stoller committed
221 222 223
    #
    my $user = GeniUser->Lookup($creator_uuid);
    if (!defined($user)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
224 225
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "creator_uuid: No such User");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
226 227 228 229 230 231 232 233 234 235
    }

    #
    # 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
236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263
    #
    # 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
264 265 266 267 268 269 270 271 272 273 274
    my $newslice = GeniSlice->Create($hrn, $uuid, $creator_uuid, $sa_idx);
    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
275 276
# 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
277 278 279 280
#
sub DiscoverResources($)
{
    my ($argref) = @_;
Leigh B. Stoller's avatar
Leigh B. Stoller committed
281
    my $slice_uuid  = $argref->{'slice_uuid'};
Leigh B. Stoller's avatar
Leigh B. Stoller committed
282

Leigh B. Stoller's avatar
Leigh B. Stoller committed
283
    if (!defined($slice_uuid)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
284 285
	return Protogeni::MalformedArgsResponse();
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
286
    if (! ($slice_uuid =~ /^[-\w]*$/)) {
Leigh B. Stoller's avatar
Leigh B. Stoller committed
287 288 289 290 291
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "uuid: Invalid characters");
    }

    #
Leigh B. Stoller's avatar
Leigh B. Stoller committed
292
    # Return simple list of components (hashes).
Leigh B. Stoller's avatar
Leigh B. Stoller committed
293 294
    #
    my @results = ();
Leigh B. Stoller's avatar
Leigh B. Stoller committed
295
    my $query_result = DBQueryWarn("select uuid,hrn,url from geni_components");
Leigh B. Stoller's avatar
Leigh B. Stoller committed
296 297 298
    return GeniResponse->Create(GENIRESPONSE_DBERROR)
	if (!defined($query_result));

Leigh B. Stoller's avatar
Leigh B. Stoller committed
299 300 301 302
    while (my ($component_uuid,$hrn,$url) = $query_result->fetchrow_array()) {
	push(@results, { "uuid" => $component_uuid,
			 "hrn"  => $hrn,
			 "url"  => $url});
Leigh B. Stoller's avatar
Leigh B. Stoller committed
303
    }
Leigh B. Stoller's avatar
Leigh B. Stoller committed
304
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, \@results);
Leigh B. Stoller's avatar
Leigh B. Stoller committed
305
}
Leigh B. Stoller's avatar
Leigh B. Stoller committed
306