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

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

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

Leigh Stoller's avatar
Leigh Stoller committed
19 20
# Must come after package declaration!
use lib '@prefix@/lib';
Leigh Stoller's avatar
Leigh Stoller committed
21
use GeniDB;
Leigh Stoller's avatar
Leigh Stoller committed
22
use Genixmlrpc;
Leigh Stoller's avatar
Leigh Stoller committed
23
use GeniResponse;
24 25
use User;
use GeniUser;
Leigh Stoller's avatar
Leigh 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 Stoller's avatar
Leigh 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 Stoller's avatar
Leigh Stoller committed
47
sub LookupUser($)
48
{
Leigh Stoller's avatar
Leigh Stoller committed
49 50
    my ($argref) = @_;
    my $uuid = $argref->{'uuid'};
51

Leigh Stoller's avatar
Leigh Stoller committed
52 53
    if (! (defined($uuid) && ($uuid =~ /^[-\w]*$/))) {
	return GeniResponse->MalformedArgsResponse();
54
    }
Leigh Stoller's avatar
Leigh 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 Stoller's avatar
Leigh 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 Stoller's avatar
Leigh Stoller committed
92
#
Leigh Stoller's avatar
Leigh Stoller committed
93
# Register a new Geni user.
Leigh Stoller's avatar
Leigh Stoller committed
94
#
Leigh Stoller's avatar
Leigh Stoller committed
95
sub RegisterUser($)
Leigh Stoller's avatar
Leigh Stoller committed
96
{
Leigh Stoller's avatar
Leigh 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 Stoller's avatar
Leigh Stoller committed
104

Leigh Stoller's avatar
Leigh 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 Stoller's avatar
Leigh Stoller committed
126
    if (! TBcheck_dbslot($uid, "users", "uid", TBDB_CHECKDBSLOT_ERROR)) {
Leigh Stoller's avatar
Leigh 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 Stoller's avatar
Leigh Stoller committed
134
    if (! ($cert =~ /^[\012\015\040-\176]*$/)) {
Leigh Stoller's avatar
Leigh Stoller committed
135
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
Leigh Stoller's avatar
Leigh Stoller committed
136
				    "cert: Invalid characters");
Leigh Stoller's avatar
Leigh Stoller committed
137
    }
Leigh Stoller's avatar
Leigh Stoller committed
138
    
Leigh Stoller's avatar
Leigh Stoller committed
139
    #
Leigh Stoller's avatar
Leigh Stoller committed
140 141
    # The SA UUID comes from the SSL environment (certificate). Verify it
    # and the prefix match for the uuid.
Leigh Stoller's avatar
Leigh Stoller committed
142 143 144
    #
    # Need to verify the UUID is permitted for the SA making the request.
    #
Leigh Stoller's avatar
Leigh 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 Stoller's avatar
Leigh Stoller committed
166

Leigh Stoller's avatar
Leigh Stoller committed
167 168 169 170
    #
    # XXX
    #
    # What kind of uniquess requirements do we need? No one else with this
Leigh Stoller's avatar
Leigh 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 Stoller's avatar
Leigh Stoller committed
173 174
    # lots of confusion?
    #
Leigh Stoller's avatar
Leigh 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 Stoller's avatar
Leigh Stoller committed
185
    }
Leigh Stoller's avatar
Leigh Stoller committed
186 187 188

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

Leigh Stoller's avatar
Leigh Stoller committed
191
#
Leigh Stoller's avatar
Leigh Stoller committed
192
# Register a new Geni slice in the DB. 
Leigh Stoller's avatar
Leigh 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 Stoller's avatar
Leigh Stoller committed
220
    # Make sure the geni user exists. 	
Leigh Stoller's avatar
Leigh Stoller committed
221 222 223
    #
    my $user = GeniUser->Lookup($creator_uuid);
    if (!defined($user)) {
Leigh Stoller's avatar
Leigh Stoller committed
224 225
	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
				    "creator_uuid: No such User");
Leigh Stoller's avatar
Leigh 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 Stoller's avatar
Leigh 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 Stoller's avatar
Leigh 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 Stoller's avatar
Leigh 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 Stoller's avatar
Leigh Stoller committed
277 278 279 280
#
sub DiscoverResources($)
{
    my ($argref) = @_;
Leigh Stoller's avatar
Leigh Stoller committed
281
    my $slice_uuid  = $argref->{'slice_uuid'};
Leigh Stoller's avatar
Leigh Stoller committed
282

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

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

Leigh Stoller's avatar
Leigh 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 Stoller's avatar
Leigh Stoller committed
303
    }
Leigh Stoller's avatar
Leigh Stoller committed
304
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, \@results);
Leigh Stoller's avatar
Leigh Stoller committed
305
}
Leigh Stoller's avatar
Leigh Stoller committed
306