Commit fd260946 authored by Leigh Stoller's avatar Leigh Stoller

Checkpoint

parent 8faa5cd3
......@@ -11,9 +11,10 @@ SUBDIR = protogeni/lib
include $(OBJDIR)/Makeconf
LIB_SCRIPTS = Protogeni.pm GeniDB.pm GeniUser.pm GeniSAClient.pm \
LIB_SCRIPTS = GeniDB.pm GeniUser.pm GeniSAClient.pm \
GeniSlice.pm GeniSA.pm GeniCM.pm GeniCMClient.pm \
test.pl GeniTicket.pm GeniSliver.pm GeniCredential.pm
test.pl GeniTicket.pm GeniSliver.pm GeniCredential.pm \
GeniComponent.pm GeniCH.pm GeniCHClient.pm
#
# Force dependencies on the scripts so that they will be rerun through
......
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2005, 2006, 2007, 2008 University of Utah and the Flux Group.
# Copyright (c) 2008 University of Utah and the Flux Group.
# All rights reserved.
#
package Protogeni;
use Exporter;
@ISA = "Exporter";
@EXPORT = qw( );
package GeniCH;
#
# 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).
# The server side of the Geni ClearingHouse API.
#
# Must come after package declaration!
use lib '@prefix@/lib';
use GeniResponse;
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);
sub add ($$)
{
return GeniResponse->Create(0, $_[0] + $_[1], "foo");
}
@ISA = "Exporter";
@EXPORT = qw ( );
#############################################################################
# The Slice Authority interface for the Geni Clearinghouse.
#
package Protogeni::SA;
# Must come after package declaration!
use lib '@prefix@/lib';
use GeniDB;
use Genixmlrpc;
use GeniResponse;
use English;
use User;
use emutil;
use GeniUser;
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@";
##
# Lookup a GID (UUID) and return the public key for that user.
# A GID is just a UUID that has been bound to some data, such as a public
# key.
# 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.
#
# @param GID the GID of the user to lookup.
# @return the public key bound to the user GID, or error if no user.
#
sub Lookup($)
sub LookupUser($)
{
my ($argref) = @_;
my $uuid = $argref->{'uuid'};
......@@ -50,28 +52,45 @@ sub Lookup($)
if (! (defined($uuid) && ($uuid =~ /^[-\w]*$/))) {
return GeniResponse->MalformedArgsResponse();
}
my $user = User->LookupByUUID($uuid);
if (defined($user)) {
#
# A local Emulab user. Return the pubkey for the user.
#
my $cert;
if ($user->SSLCert(1, \$cert) != 0) {
return GeniResponse->Create(GENIRESPONSE_ERROR);
}
return GeniResponse->Create(0, $cert);
my $user = GeniUser->Lookup($uuid);
if (!defined($user)) {
return GeniResponse->Create(GENIRESPONSE_SEARCHFAILED, undef,
"No such user $uuid");
}
return GeniResponse->BadArgsResponse("No such user for GID")
if (!defined($user));
#
# We want to return the certificate.
#
return GeniResponse->Create(0, 1);
# 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);
}
#
# Register a new Geni user in the DB. Returns success/failure.
# Register a new Geni user.
#
sub RegisterUser($)
{
......@@ -104,7 +123,7 @@ sub RegisterUser($)
return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
"name: ". TBFieldErrorString());
}
if (! TBcheck_dbslot($name, "users", "uid", TBDB_CHECKDBSLOT_ERROR)) {
if (! TBcheck_dbslot($uid, "users", "uid", TBDB_CHECKDBSLOT_ERROR)) {
return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
"uid: ". TBFieldErrorString());
}
......@@ -112,23 +131,38 @@ sub RegisterUser($)
return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
"email: ". TBFieldErrorString());
}
if (! TBcheck_dbslot($cert, "default", "text", TBDB_CHECKDBSLOT_ERROR)){
if (! ($cert =~ /^[\012\015\040-\176]*$/)) {
return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
"cert: ". TBFieldErrorString());
"cert: Invalid characters");
}
#
# XXX TODO!
#
# Who is the SA? We get this from the SSL environment (certificate).
#
my $sa_idx = 1;
#
# XXX TODO!
# 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");
}
#
# XXX
......@@ -168,9 +202,6 @@ sub RegisterSlice($)
return Protogeni::MalformedArgsResponse();
}
#
# Use the Emulab checkslot routines.
#
if (! ($hrn =~ /^[-\w\.]*$/)) {
return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
"hrn: Invalid characters");
......@@ -186,31 +217,12 @@ sub RegisterSlice($)
}
#
# XXX TODO!
#
# Who is the SA? We get this from the SSL environment (certificate).
#
my $sa_idx = 1;
#
# XXX TODO!
#
# Need to verify the UUID is permitted for the SA making the request.
#
#
# Make sure the geni user exists. It might be a local user though,
# which is not duplicated in the geni_users table, to avoid consistency
# problems. Probably change this later though.
# Make sure the geni user exists.
#
my $user = GeniUser->Lookup($creator_uuid);
if (!defined($user)) {
$user = User->LookupByUUID($creator_uuid);
if (!defined($user)) {
return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
"creator_uuid: No such User");
}
return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
"creator_uuid: No such User");
}
#
......@@ -221,6 +233,34 @@ sub RegisterSlice($)
"$hrn or $uuid already registered");
}
#
# 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");
}
my $newslice = GeniSlice->Create($hrn, $uuid, $creator_uuid, $sa_idx);
if (!defined($newslice)) {
return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
......@@ -232,35 +272,35 @@ sub RegisterSlice($)
}
#
# Brain dead discover resources.
# This is just a placeholder; return a list of all components. Eventually
# takes an rspec and we do a resource mapping.
#
sub DiscoverResources($)
{
my ($argref) = @_;
my $uuid = $argref->{'uuid'};
my $slice_uuid = $argref->{'slice_uuid'};
if (!defined($uuid)) {
if (!defined($slice_uuid)) {
return Protogeni::MalformedArgsResponse();
}
if (! ($uuid =~ /^[-\w]*$/)) {
if (! ($slice_uuid =~ /^[-\w]*$/)) {
return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
"uuid: Invalid characters");
}
#
# Return simple list of URLs.
# Return simple list of components (hashes).
#
my @results = ();
my $query_result = DBQueryWarn("select url from geni_components");
my $query_result = DBQueryWarn("select uuid,hrn,url from geni_components");
return GeniResponse->Create(GENIRESPONSE_DBERROR)
if (!defined($query_result));
while (my ($url) = $query_result->fetchrow_array()) {
push(@results, $url);
while (my ($component_uuid,$hrn,$url) = $query_result->fetchrow_array()) {
push(@results, { "uuid" => $component_uuid,
"hrn" => $hrn,
"url" => $url});
}
return GeniResponse->Create(GENIRESPONSE_SUCCESS, \@results);
}
# _Always_ make sure that this 1 is at the end of the file...
1;
#!/usr/bin/perl -wT
#
# EMULAB-COPYRIGHT
# Copyright (c) 2008 University of Utah and the Flux Group.
# All rights reserved.
#
package GeniCHClient;
#
# The client side of the Emulab to Geni ClearingHouse API. This is where we
# register local users, experiments, etc at the clearinghouse and also how
# we look up things at the clearinghouse.
#
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 GeniResponse;
use User;
use GeniUser;
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 = "myboss.little-emulab-bsd61.testbed.emulab.net";
my $GENICENTRALURL = "https://$GENICENTRAL/protogeni/xmlrpc";
#
# Lookup a user at the clearing house.
#
sub LookupUser($$)
{
my ($user, $pref) = @_;
$$pref = undef;
my $response =
Genixmlrpc::CallMethodHTTP($GENICENTRALURL, undef,
"CH::LookupUser",
{ "uuid" => $user->uuid()});
return -1
if (!defined($response) || $response->code() != GENIRESPONSE_SUCCESS);
$$pref = $response->value();
return 0;
}
#
# Lookup a slice (experiment) at the clearing house.
#
sub LookupSlice($$)
{
my ($experiment, $pref) = @_;
$$pref = undef;
my $response =
Genixmlrpc::CallMethodHTTP($GENICENTRALURL, undef,
"CH::LookupSlice",
{ "uuid" => $experiment->uuid()});
return -1
if (!defined($response) || $response->code() != GENIRESPONSE_SUCCESS);
$$pref = $response->value();
return 0;
}
#
# Register a local Emulab user at the Geni ClearingHouse (which in the
# prototype is Utah Emulab).
#
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($GENICENTRALURL, undef,
"CH::RegisterUser",
{ "hrn" => $hrn,
# Optional, prefered local login id.
"uid" => $user->uid(),
"uuid" => $user->uuid(),
"name" => $user->name(),
"email" => $user->email(),
"cert" => $cert});
return -1
if (!defined($response) || $response->code() != GENIRESPONSE_SUCCESS);
return 0;
}
#
# 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($GENICENTRALURL, undef,
"CH::CreateSliceName",
{ "hrn" => $hrn,
"uuid" => $experiment->uuid(),
"creator_uuid" => $user->uuid()});
return -1
if (!defined($response) || $response->code() != GENIRESPONSE_SUCCESS);
return 0;
}
#
# Delete a slice registration.
#
sub DeleteSlice($)
{
my ($experiment) = @_;
my $response =
Genixmlrpc::CallMethodHTTP($GENICENTRALURL, undef,
"CH::FreeSliceName",
{ "uuid" => $experiment->uuid()});
return -1
if (!defined($response) || $response->code() != GENIRESPONSE_SUCCESS);
return 0;
}
#
# 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, $pref) = @_;
#
# XXX
#
my $this_user = User->LookupByUnixId($UID);
if (! defined($this_user)) {
print STDERR "You ($UID) do not exist!\n";
return -1;
}
my $response =
Genixmlrpc::CallMethodHTTP($GENICENTRALURL, undef,
"CH::DiscoverResources",
{ "slice_uuid" => $experiment->uuid() });
return -1
if (!defined($response));
return -1
if ($response->code() != GENIRESPONSE_SUCCESS);
#
# We get back a list of components right now, whic we cache locally.
#
my @result = ();
foreach my $ref (@{ $response->value() }) {
my $uuid = $ref->{'uuid'};
my $url = $ref->{'url'};
my $hrn = $ref->{'hrn'};
my $component = GeniComponent->Lookup($uuid);
if (!defined($component)) {
$component = GeniComponent->Create($uuid, $hrn, $url);
if (!defined($component)) {
return GeniResponse->Create(GENIRESPONSE_DBERROR);
}
}
elsif ($url ne $component->url() ||
$hrn ne $component->hrn()) {
$component->Update({"url" => $url, "hrn" => $hrn}) == 0 or
return GeniResponse->Create(GENIRESPONSE_DBERROR);
}
push(@result, $component);
}
@$pref = @result;
return 0;
}
......@@ -30,6 +30,7 @@ use libtestbed;
# Hate to import all this crap; need a utility library.
use libdb qw(TBGetUniqueIndex TBcheck_dbslot TBDB_CHECKDBSLOT_ERROR);
use User;
use Node;
use English;
use Data::Dumper;
use Experiment;
......@@ -41,9 +42,66 @@ my $TBAPPROVAL = "@TBAPPROVALEMAIL@";
my $TBAUDIT = "@TBAUDITEMAIL@";
my $BOSSNODE = "@BOSSNODE@";
my $OURDOMAIN = "@OURDOMAIN@";
my $GENICENTRAL = "https://boss/protogeni/xmlrpc";
my $CREATEEXPT = "$TB/bin/batchexp";
my $NALLOC = "$TB/bin/nalloc";
my $AVAIL = "$TB/sbin/avail";
#
# Discover resources on this component, returning a resource availablity spec
#
sub DiscoverResources($)
{
my ($argref) = @_;
my $slice_uuid = $argref->{'slice_uuid'};
my $credential = $argref->{'credential'};
my $user_uuid = $ENV{'GENIUSER'};
if (! (defined($slice_uuid) && ($slice_uuid =~ /^[-\w]+$/))) {
return GeniResponse->MalformedArgsResponse();
}
$credential = GeniCredential->CreateFromSigned($credential);
if (!defined($credential)) {
return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
"Could not create GeniCredential object");
}
# The credential owner/slice has to match what was provided.
if (! ($user_uuid eq $credential->owner_uuid() &&
$slice_uuid eq $credential->this_uuid())) {
return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
"Invalid credentials for operation");
}
#
# Eventually we will take an optional rspec, but for now just return
# a list of free nodes using avail.
#
if (! open(AVAIL, "$AVAIL type=pc aslist |")) {
return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
"Could not start avail");
}
my @nodelist = ();
while (<AVAIL>) {
my $nodeid = $_;
chomp($nodeid);
my $node = Node->Lookup($nodeid);
push(@nodelist, $node)
if (defined($node));
}
close(AVAIL);
my $xml = "<rspec xmlns:\"http://protogeni.net/resources/rspec/0.1\">\n";
foreach my $node (@nodelist) {
my $uuid = $node->uuid();
my $nodeid = $node->node_id();
$xml .= "<node uuid=\"$uuid\" name=\"$nodeid\">".
"<available>true</available></node>\n";
}
$xml .= "</rspec>";
return GeniResponse->Create(GENIRESPONSE_SUCCESS, $xml);
}
#
# Respond to a GetTicket request. No worries about credentials yet; we
......@@ -56,22 +114,19 @@ sub GetTicket($)
my $slice_uuid = $argref->{'slice_uuid'};
my $rspec = $argref->{'rspec'};
my $impotent = $argref->{'impotent'};
my $credstring = $argref->{'credential_string'};
my $credential = $argref->{'credential'};
my $owner_uuid = $ENV{'GENIUSER'};
if (! (defined($slice_uuid) && ($slice_uuid =~ /^[-\w]+$/))) {
return GeniResponse->MalformedArgsResponse();
}
if (! (defined($owner_uuid) && ($owner_uuid =~ /^[-\w]+$/))) {
return GeniResponse->MalformedArgsResponse();
}
if (! defined($rspec)) {
return GeniResponse->MalformedArgsResponse();
}
$impotent = 0
if (!defined($impotent));
my $credential = GeniCredential->CreateFromSigned($credstring);
$credential = GeniCredential->CreateFromSigned($credential);
if (!defined($credential)) {
return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
"Could not create GeniCredential object");
......@@ -165,7 +220,8 @@ sub GetTicket($)
sub CreateSliver($)
{
my ($argref) = @_;
my $ticket = $argref->{'ticket'};
my $owner_uuid = $ENV{'GENIUSER'};
my $ticket = $argref->{'ticket'};
if (! (defined($ticket) &&
!TBcheck_dbslot($ticket, "default", "text",
......@@ -178,6 +234,11 @@ sub CreateSliver($)
return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
"Could not create GeniTicket object");
}
# The credential owner has to match what is in the ticket.
if ($owner_uuid ne $ticket->owner_uuid()) {
return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
"Invalid credentials for operation");
}
my $experiment = Experiment->Lookup($ticket->slice_uuid());
if (!defined($experiment)) {
......@@ -185,9 +246,6 @@ sub CreateSliver($)
"No local experiment for slice");
}
#
# 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,
......@@ -204,22 +262,31 @@ sub CreateSliver($)
return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
"Could not provision sliver");
}
return GeniResponse->Create(GENIRESPONSE_SUCCESS, $sliver->uuid(), "Wow!");
#
# The API states we return a credential to control the sliver.
#
my $credential = GeniCredential->Create($sliver->uuid(),
$owner_uuid);
if (!defined($credential)) {
print STDERR "Could not create a credential for $sliver!\n";
return -1;
}
if ($credential->Sign()) {
print STDERR "Could not sign sliver credential!\n";
return -1;
}
return GeniResponse->Create(GENIRESPONSE_SUCCESS, $credential->asString());
}
#
# Start a sliver. I take this to mean, reboot the node. Currently, using
# the ticket as the credential.
#
# XXX Credentials stuff.
# Destroy a sliver.
#
sub StartSliver($)
sub DestroySliver($)
{
my ($argref) = @_;
my $ticket = $argref->{'ticket'};
my $owner_uuid