Checkpoint

protogeni/lib/GNUmakefile.in

@@ -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

protogeni/lib/Protogeni.pm.in → protogeni/lib/GeniCH.pm.in

 #!/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;

protogeni/lib/GeniCHClient.pm.in

+#!/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;
+}
+

protogeni/lib/GeniCM.pm.in

@@ -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");
+    }