Commit 423f2952 authored by Leigh Stoller's avatar Leigh Stoller

Checkpoint

parent e5ece7ac
......@@ -11,7 +11,9 @@ SUBDIR = protogeni/lib
include $(OBJDIR)/Makeconf
LIB_SCRIPTS = Protogeni.pm GeniDB.pm GeniUser.pm test.pl
LIB_SCRIPTS = Protogeni.pm GeniDB.pm GeniUser.pm GeniSAClient.pm \
GeniSlice.pm GeniSA.pm GeniCM.pm GeniCMClient.pm \
test.pl
#
# Force dependencies on the scripts so that they will be rerun through
......
#!/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;
use libtestbed;
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@";
my $GENICENTRAL = "https://boss/protogeni/xmlrpc";
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2008 University of Utah and the Flux Group.
# All rights reserved.
#
package GeniCMClient;
#
# The client side of the CM interface.
#
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;
use libtestbed;
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@";
my $GENICENTRAL = "https://boss/protogeni/xmlrpc";
#
# Discover resources for a slice (local experiment). This contacts Geni
# Central to get a list of components. I think the interface is supposed
# to be that we send an rspec and it sends back a list of components. But
# lets not worry about that; just get a list of all components we can ask
# for resources from.
#
sub DiscoverResources($)
{
my ($experiment) = @_;
my $response =
Genixmlrpc::CallMethodHTTP($GENICENTRAL, "SA::DiscoverResources",
{ "uuid" => $experiment->uuid() });
print Dumper($response);
return $response->code();
}
......@@ -28,7 +28,7 @@ sub DBWarn($;$) { emdbi::DBError($_[0], $_[1]); }
sub DBFatal($;$) { emdbi::DBFatal($_[0], $_[1]); }
sub DBErr() { return emdbi::DBErrN($dbnum); }
$emdbi::DBQUERY_DEBUG = 1;
$emdbi::DBQUERY_DEBUG = 0;
# Default connection.
$dbnum = emdbi::NewTBDBHandle("geni")
......
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2008 University of Utah and the Flux Group.
# All rights reserved.
#
package GeniSA;
#
# The server side of the SA 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;
use libtestbed;
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@";
my $GENICENTRAL = "https://boss/protogeni/xmlrpc";
......@@ -21,9 +21,10 @@ use vars qw(@ISA @EXPORT);
# Must come after package declaration!
use lib '@prefix@/lib';
use GeniDB;
use Genixmlrpc;
use libtestbed;
use English;
use vars qw();
use Data::Dumper;
# Configure variables
my $TB = "@prefix@";
......@@ -31,14 +32,57 @@ my $TBOPS = "@TBOPSEMAIL@";
my $TBAPPROVAL = "@TBAPPROVALEMAIL@";
my $TBAUDIT = "@TBAUDITEMAIL@";
my $BOSSNODE = "@BOSSNODE@";
my $CONTROL = "@USERNODE@";
my $OURDOMAIN = "@OURDOMAIN@";
my $GENICENTRAL = "https://boss/protogeni/xmlrpc";
#
# Register a user at the Geni ClearingHouse (which in the prototype is
# is Utah Emulab).
# Register a local Emulab user at the Geni ClearingHouse (which in the
# prototype is Utah Emulab).
#
sub RegisterUser()
sub RegisterUser($)
{
my ($user) = @_;
my $cert;
if ($user->SSLCert(1, \$cert)) {
print STDERR
"Geni::RegisterUser - No encrypted certificate found for $user\n";
return -1;
}
# XXX Form hrn from the uid and domain. This is backwards.
my $hrn = $OURDOMAIN . "." . $user->uid();
my $response =
Genixmlrpc::CallMethodHTTP($GENICENTRAL, "SA::RegisterUser",
{ "hrn" => $hrn,
"uuid" => $user->uuid(),
"name" => $user->name(),
"email" => $user->email(),
"cert" => $cert});
print Dumper($response);
return $response->code();
}
#
# Register a local Emulab experiment at the Clearinghouse, as a slice.
#
sub RegisterSlice($)
{
my ($experiment) = @_;
my $user = $experiment->GetCreator();
# XXX Form hrn from the uid and domain. This is backwards.
my $hrn = $OURDOMAIN . "." . $experiment->pid() . "." . $experiment->eid();
my $response =
Genixmlrpc::CallMethodHTTP($GENICENTRAL, "SA::RegisterSlice",
{ "hrn" => $hrn,
"uuid" => $experiment->uuid(),
"creator_uuid" => $user->uuid()});
print Dumper($response);
return $response->code();
}
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2008 University of Utah and the Flux Group.
# All rights reserved.
#
package GeniSlice;
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 libtestbed;
# Hate to import all this crap; need a utility library.
use libdb qw(TBGetUniqueIndex);
use English;
use overload ('""' => 'Stringify');
use vars qw();
# Configure variables
my $TB = "@prefix@";
my $TBOPS = "@TBOPSEMAIL@";
my $TBAPPROVAL = "@TBAPPROVALEMAIL@";
my $TBAUDIT = "@TBAUDITEMAIL@";
my $BOSSNODE = "@BOSSNODE@";
my $CONTROL = "@USERNODE@";
my $OURDOMAIN = "@OURDOMAIN@";
# Cache of instances to avoid regenerating them.
my %slices = ();
my $debug = 0;
# Little helper and debug function.
sub mysystem($)
{
my ($command) = @_;
print STDERR "Running '$command'\n"
if ($debug);
return system($command);
}
#
# Lookup by idx or uuid.
#
sub Lookup($$)
{
my ($class, $token) = @_;
my $query_result;
# Look in cache first
return $slices{"$token"}
if (exists($slices{"$token"}));
if ($token =~ /^\d+$/) {
$query_result =
DBQueryWarn("select * from geni_slices ".
"where idx='$token' and status='active'");
}
elsif ($token =~ /^\w+\-\w+\-\w+\-\w+\-\w+$/) {
$query_result =
DBQueryWarn("select * from geni_slices ".
"where uuid='$token'");
}
else {
return undef;
}
return undef
if (!$query_result || !$query_result->numrows);
my $self = {};
$self->{'SLICE'} = $query_result->fetchrow_hashref();
bless($self, $class);
# Add to cache.
$slices{$self->{'SLICE'}->{'idx'}} = $self;
return $self;
}
# accessors
sub field($$) { return ((! ref($_[0])) ? -1 : $_[0]->{'USER'}->{$_[1]}); }
sub idx($) { return field($_[0], "idx"); }
sub hrn($) { return field($_[0], "hrn"); }
sub uuid($) { return field($_[0], "uuid"); }
sub creator_uuid($) { return field($_[0], "creator_uuid"); }
sub created($) { return field($_[0], "created"); }
sub sa_idx($) { return field($_[0], "sa_idx"); }
#
# Stringify for output.
#
sub Stringify($)
{
my ($self) = @_;
my $hrn = $self->hrn();
my $idx = $self->idx();
return "[GeniSlice: $hrn, IDX: $idx]";
}
#
# Class method to check for an existing user that has the same
# uid/email. Lets not allow this for now. Return the number of
# users that match or -1 if an error.
#
sub CheckExisting($$$)
{
my ($class, $hrn, $uuid) = @_;
my $safe_hrn = DBQuoteSpecial($hrn);
my $safe_uuid = DBQuoteSpecial($uuid);
my $query_result =
DBQueryFatal("select idx from geni_slices ".
"where hrn=$safe_hrn or uuid=$safe_uuid");
return -1
if (!defined($query_result));
return $query_result->numrows;
}
#
# Class function to create new Geni slice and return object.
#
sub Create($$$$)
{
my ($class, $hrn, $uuid, $creator_uuid, $sa_idx) = @_;
my @insert_data = ();
# Every slice gets a new unique index.
my $idx = TBGetUniqueIndex('next_exptidx', 1);
# Now tack on other stuff we need.
push(@insert_data, "created=now()");
push(@insert_data, "idx='$idx'");
my $safe_hrn = DBQuoteSpecial($hrn);
my $safe_uuid = DBQuoteSpecial($uuid);
my $safe_cuuid = DBQuoteSpecial($creator_uuid);
push(@insert_data, "hrn=$safe_hrn");
push(@insert_data, "uuid=$safe_uuid");
push(@insert_data, "creator_uuid=$safe_cuuid");
# Insert into DB.
DBQueryWarn("insert into geni_slices set " . join(",", @insert_data))
or return undef;
return GeniSlice->Lookup($idx);
}
#
# Delete the slice, as for registration errors.
#
sub Delete($)
{
my ($self) = @_;
return 0
if (! ref($self));
my $idx = $self->idx();
DBQueryWarn("delete from geni_slices where idx='$idx'")
or return -1;
return 0;
}
......@@ -47,7 +47,7 @@ sub mysystem($)
}
#
# Lookup by idx.
# Lookup by idx, or uuid.
#
sub Lookup($$)
{
......@@ -61,7 +61,12 @@ sub Lookup($$)
if ($token =~ /^\d+$/) {
$query_result =
DBQueryWarn("select * from geni_users ".
"where uid_idx='$token' and status='active'");
"where idx='$token' and status='active'");
}
elsif ($token =~ /^\w+\-\w+\-\w+\-\w+\-\w+$/) {
$query_result =
DBQueryWarn("select * from geni_users ".
"where uuid='$token' and status='active'");
}
else {
return undef;
......@@ -76,20 +81,22 @@ sub Lookup($$)
bless($self, $class);
# Add to cache.
$users{$self->{'USER'}->{'uid_idx'}} = $self;
$users{$self->{'USER'}->{'idx'}} = $self;
return $self;
}
# accessors
sub field($$) { return ((! ref($_[0])) ? -1 : $_[0]->{'USER'}->{$_[1]}); }
sub uid_idx($) { return field($_[0], "uid_idx"); }
sub idx($) { return field($_[0], "idx"); }
sub uid($) { return field($_[0], "uid"); }
sub hrn($) { return field($_[0], "hrn"); }
sub uuid($) { return field($_[0], "uuid"); }
sub status($) { return field($_[0], "status"); }
sub created($) { return field($_[0], "created"); }
sub archived($) { return field($_[0], "archived"); }
sub name($) { return field($_[0], "name"); }
sub email($) { return field($_[0], "email"); }
sub cert($) { return field($_[0], "cert"); }
sub sa_idx($) { return field($_[0], "sa_idx"); }
#
......@@ -99,30 +106,10 @@ sub Stringify($)
{
my ($self) = @_;
my $uid = $self->uid();
my $uid_idx = $self->uid_idx();
return "[GeniUser: $uid, IDX: $uid_idx]";
}
#
# Lookup user given a UUID.
#
sub LookupByUUID($$)
{
my ($class, $uuid) = @_;
my $safe_uuid = DBQuoteSpecial($uuid);
my $query_result =
DBQueryFatal("select uid_idx from geni_users ".
"where uuid=$safe_uuid");
return undef
if (! $query_result || !$query_result->numrows);
my ($uid_idx) = $query_result->fetchrow_array();
my $hrn = $self->hrn();
my $idx = $self->idx();
return GeniUser->Lookup($uid_idx);
return "[GeniUser: $hrn, IDX: $idx]";
}
#
......@@ -132,14 +119,14 @@ sub LookupByUUID($$)
#
sub CheckExisting($$$)
{
my ($class, $uid, $email) = @_;
my ($class, $hrn, $email) = @_;
my $safe_uid = DBQuoteSpecial($uid);
my $safe_hrn = DBQuoteSpecial($hrn);
my $safe_email = DBQuoteSpecial($email);
my $query_result =
DBQueryFatal("select uid_idx from geni_users ".
"where uid=$safe_uid and email=$safe_email");
DBQueryFatal("select idx from geni_users ".
"where hrn=$safe_hrn and email=$safe_email");
return -1
if (!defined($query_result));
......@@ -149,40 +136,41 @@ sub CheckExisting($$$)
#
# Class function to create new Geni user and return object.
#
sub Create($$$$$)
sub Create($$$$$$$$)
{
my ($class, $uid, $name, $email, $sa_idx) = @_;
my ($class, $hrn, $uid, $uuid, $name, $email, $cert, $sa_idx) = @_;
my @insert_data = ();
# Every user gets a new unique index.
my $uid_idx = TBGetUniqueIndex('next_uid', 1);
my $idx = TBGetUniqueIndex('next_uid', 1);
# And a UUID (universally unique identifier).
$uuid = NewUUID();
if (!defined($uuid)) {
print "*** WARNING: Could not generate a UUID!\n";
return undef;
}
push(@insert_data, "uid_uuid='$uuid'");
push(@insert_data, "status='active'");
# Now tack on other stuff we need.
push(@insert_data, "created=now()");
push(@insert_data, "uid_idx='$uid_idx'");
push(@insert_data, "sa_idx=$sa_idx");
push(@insert_data, "idx='$idx'");
my $safe_hrn = DBQuoteSpecial($hrn);
my $safe_uid = DBQuoteSpecial($uid);
my $safe_name = DBQuoteSpecial($name);
my $safe_email = DBQuoteSpecial($email);
my $safe_cert = DBQuoteSpecial($cert);
my $safe_uuid = DBQuoteSpecial($uuid);
my $safe_sa = DBQuoteSpecial($sa_idx);
push(@insert_data, "hrn=$safe_hrn");
push(@insert_data, "uid=$safe_uid");
push(@insert_data, "name=$safe_name");
push(@insert_data, "email=$safe_email");
push(@insert_data, "cert=$safe_cert");
push(@insert_data, "uuid=$safe_uuid");
push(@insert_data, "sa_idx=$safe_sa");
# Insert into DB.
DBQueryWarn("insert into geni_users set " . join(",", @insert_data))
or return undef;
return GeniUser->Lookup($uid_idx);
return GeniUser->Lookup($idx);
}
#
......@@ -195,9 +183,9 @@ sub Delete($)
return 0
if (! ref($self));
my $uid_idx = $self->uid_idx();
my $idx = $self->idx();
DBQueryWarn("delete from geni_users where uid_idx='$uid_idx'")
DBQueryWarn("delete from geni_users where idx='$idx'")
or return -1;
return 0;
......@@ -213,10 +201,10 @@ sub Archive($)
return 0
if (! ref($self));
my $uid_idx = $self->uid_idx();
my $idx = $self->idx();
DBQueryWarn("update geni_users set status='archived' ".
"where uid_idx='$uid_idx'")
"where idx='$idx'")
or return -1;
return 0;
......
......@@ -5,81 +5,22 @@
# All rights reserved.
#
package Protogeni;
use Exporter;
@ISA = "Exporter";
@EXPORT = qw( );
#
# XXX: Permissions need to be worked on. Some of these interfaces are
# only valid for SAs and others are available to mere users (geni
# users of course).
#
use strict;
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK
$RESPONSE_SUCCESS $RESPONSE_BADARGS $RESPONSE_ERROR
$RESPONSE_FORBIDDEN $RESPONSE_BADVERSION $RESPONSE_SERVERERROR
$RESPONSE_TOOBIG $RESPONSE_REFUSED $RESPONSE_TIMEDOUT);
@ISA = "Exporter";
@EXPORT = qw ( );
# Must come after package declaration!
use lib '@prefix@/lib';
use libdb;
$RESPONSE_SUCCESS = 0;
$RESPONSE_BADARGS = 1;
$RESPONSE_ERROR = 2;
$RESPONSE_FORBIDDEN = 3;
$RESPONSE_BADVERSION = 4;
$RESPONSE_SERVERERROR = 5;
$RESPONSE_TOOBIG = 6;
$RESPONSE_REFUSED = 7; # Emulab is down, try again later.
$RESPONSE_TIMEDOUT = 8;
@EXPORT_OK = qw($RESPONSE_SUCCESS $RESPONSE_BADARGS $RESPONSE_ERROR
$RESPONSE_FORBIDDEN $RESPONSE_BADVERSION $RESPONSE_SERVERERROR
$RESPONSE_TOOBIG $RESPONSE_REFUSED $RESPONSE_TIMEDOUT);
#
# This is the "structure" we want to return.
#
# class Response:
# def __init__(self, code, value=0, output=""):
# self.code = code # A RESPONSE code
# self.value = value # A return value; any valid XML type.
# self.output = output # Pithy output to print
# return
#
sub MakeResponse($$;$)
{
my ($code, $value, $output) = @_;
$output = ""
if (!defined($output));
return {"code" => $code,
"value" => $value,
"output" => $output};
}
sub MalformedAargsResponse()
{
return MakeResponse($RESPONSE_BADARGS, 0, "Malformed arguments to method");
}
sub BadArgsResponse(;$)
{
my ($msg) = @_;
$msg = "Bad arguments to method"
if (!defined($msg));
return MakeResponse($RESPONSE_BADARGS, 0, $msg);
}
use GeniResponse;
sub add ($$)
{
return MakeResponse(0, $_[0] + $_[1], "foo");
return GeniResponse->Create(0, $_[0] + $_[1], "foo");
}
#############################################################################
......@@ -87,8 +28,10 @@ sub add ($$)
#
package Protogeni::SA;
use GeniDB;
use GeniResponse;
use English;
use User;
use emutil;
use GeniUser;
##
......@@ -101,10 +44,11 @@ use GeniUser;
#
sub Lookup($)
{
my ($uuid) = @_;
my ($argref) = @_;
my $uuid = $argref->{'uuid'};
if (! ($uuid =~ /^[-\w]*$/)) {
return Protogeni::MalformedArgsResponse();
if (! (defined($uuid) && ($uuid =~ /^[-\w]*$/))) {
return GeniResponse->MalformedArgsResponse();
}
my $user = User->LookupByUUID($uuid);
if (defined($user)) {
......@@ -113,28 +57,65 @@ sub Lookup($)
#
my $cert;
if ($user->SSLCert(1, \$cert) != 0) {
return Protogeni::MakeResponse($Protogeni::RESPONSE_ERROR, "");
return GeniResponse->Create(GENIRESPONSE_ERROR);
}
return Protogeni::MakeResponse(0, $cert);
return GeniResponse->Create(0, $cert);
}
return Protogeni::BadArgsResponse("No such user for GID")
return GeniResponse->BadArgsResponse("No such user for GID")
if (!defined($user));
#
# We want to return the encrypted GENI certificate.
# We want to return the certificate.
#
return Protogeni::MakeResponse(0, 1);
return GeniResponse->Create(0, 1);
}
#
# Register a new Geni user in the DB. Returns the UUID (GUD).
# Register a new Geni user in the DB. Returns success/failure.
#
sub Register($$$)
sub RegisterUser($)
{
my ($uid, $name, $email) = @_;