Checkpoint

protogeni/lib/GNUmakefile.in

@@ -13,7 +13,7 @@ include $(OBJDIR)/Makeconf
 
 LIB_SCRIPTS     = Protogeni.pm GeniDB.pm GeniUser.pm GeniSAClient.pm \
 		  GeniSlice.pm GeniSA.pm GeniCM.pm GeniCMClient.pm \
-		  test.pl GeniTicket.pm GeniSliver.pm
+		  test.pl GeniTicket.pm GeniSliver.pm GeniCredential.pm
 
 #
 # Force dependencies on the scripts so that they will be rerun through

protogeni/lib/GeniCM.pm.in

@@ -23,6 +23,7 @@ use GeniDB;
 use Genixmlrpc;
 use GeniResponse;
 use GeniTicket;
+use GeniCredential;
 use GeniSliver;
 use GeniUser;
 use libtestbed;
@@ -52,26 +53,39 @@ my $NALLOC	   = "$TB/bin/nalloc";
 sub GetTicket($)
 {
     my ($argref) = @_;
-    my $owner_uuid = $argref->{'owner_uuid'};
     my $slice_uuid = $argref->{'slice_uuid'};
     my $rspec      = $argref->{'rspec'};
+    my $impotent   = $argref->{'impotent'};
+    my $credstring = $argref->{'credential_string'};
+    my $owner_uuid = $ENV{'GENIUSER'};
 
     if (! (defined($slice_uuid) && ($slice_uuid =~ /^[-\w]+$/))) {
 	return GeniResponse->MalformedArgsResponse();
     }
-    # XXX This needs to come from the SSL environment.
     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);
+    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 (! ($owner_uuid eq $credential->owner_uuid() &&
+	   $slice_uuid eq $credential->this_uuid())) {
+	return GeniResponse->Create(GENIRESPONSE_FORBIDDEN, undef,
+				    "Invalid credentials for operation");
+    }
 
     #
     # XXX Should we create a local geni_slices record in the DB?
     #
-if (0) {
-    #
     # If the underlying experiment does not exist, need to create
     # a holding experiment. All these are going to go into the same
     # project for now. Generally, users for non-local slices do not
@@ -110,7 +124,6 @@ if (0) {
 	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
 				    "Improper node id");
     }
-}
 
     #
     # Create the ticket first, before allocating the node.
@@ -120,20 +133,20 @@ if (0) {
 	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
 				    "Could not create GeniTicket object");
     }
-if (0) {
     # Nalloc might fail if the node gets picked up by someone else.
-#    system("$NALLOC $pid $eid $node_id");
-    if (($? >> 8) < 0) {
-	$ticket->Delete();
-	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
-				    "Allocation failure");
-    }
-    elsif (($? >> 8) > 0) {
-	$ticket->Delete();
-	return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
-				    "Could not allocate node\n");
+    if (!$impotent) {
+	system("$NALLOC $pid $eid $node_id");
+	if (($? >> 8) < 0) {
+	    $ticket->Delete();
+	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
+					"Allocation failure");
+	}
+	elsif (($? >> 8) > 0) {
+	    $ticket->Delete();
+	    return GeniResponse->Create(GENIRESPONSE_UNAVAILABLE, undef,
+					"Could not allocate node\n");
+	}
     }
-}
     if ($ticket->Sign() != 0) {
 	# Release will free the node.
 	$ticket->Release();
@@ -147,6 +160,8 @@ if (0) {
 #
 # Create a sliver.
 #
+# XXX Credentials stuff.
+#
 sub CreateSliver($)
 {
     my ($argref) = @_;
@@ -190,5 +205,74 @@ sub CreateSliver($)
 				    "Could not provision sliver");
     }
     
-    return GeniResponse->Create(GENIRESPONSE_SUCCESS, 0, "Wow!");
+    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $sliver->uuid(), "Wow!");
+}
+
+
+#
+# Start a sliver. I take this to mean, reboot the node. Currently, using
+# the ticket as the credential.
+#
+# XXX Credentials stuff.
+#
+sub StartSliver($)
+{
+    my ($argref) = @_;
+    my $ticket      = $argref->{'ticket'};
+    my $sliver_uuid = $argref->{'uuid'};
+
+    if (!defined($sliver_uuid)) {
+	return GeniResponse->Create(GENIRESPONSE_BADARGS);
+    }
+    my $sliver = GeniSliver->Lookup($sliver_uuid);
+    if (!defined($sliver)) {
+	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
+				    "No such sliver $sliver_uuid");
+    }
+
+    if (! (defined($ticket) &&
+	   !TBcheck_dbslot($ticket, "default", "text",
+			   TBDB_CHECKDBSLOT_ERROR))) {
+	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
+				    "ticket: ". TBFieldErrorString());
+    }
+    $ticket = GeniTicket->CreateFromSignedTicket($ticket);
+    if (!defined($ticket)) {
+	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
+				    "Could not create GeniTicket object");
+    }
+
+    $sliver->Start() == 0 or
+	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
+				    "Could not start $sliver");
+	
+    return GeniResponse->Create(GENIRESPONSE_SUCCESS);
+}
+
+#
+# Destroy a sliver.
+#
+# XXX Credential stuff ...
+#
+sub DestroySliver($)
+{
+    my ($argref) = @_;
+    my $sliver_uuid = $argref->{'uuid'};
+
+    if (!defined($sliver_uuid)) {
+	return GeniResponse->Create(GENIRESPONSE_BADARGS);
+    }
+    my $sliver = GeniSliver->Lookup($sliver_uuid);
+    if (!defined($sliver)) {
+	return GeniResponse->Create(GENIRESPONSE_BADARGS, undef,
+				    "No such sliver $sliver_uuid");
+    }
+    $sliver->UnProvision() == 0 or
+	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
+				    "Could not unprovision sliver");
+    $sliver->Delete() == 0 or
+	return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
+				    "Could not delete sliver");
+    
+    return GeniResponse->Create(GENIRESPONSE_SUCCESS);
 }

protogeni/lib/GeniCMClient.pm.in

@@ -23,6 +23,7 @@ use GeniDB;
 use Genixmlrpc;
 use GeniResponse;
 use GeniTicket;
+use GeniCredential;
 use GeniSliver;
 use User;
 use libtestbed;
@@ -50,7 +51,8 @@ sub DiscoverResources($$)
     my ($experiment, $pref) = @_;
 
     my $response =
-	Genixmlrpc::CallMethodHTTP($GENICENTRAL, "SA::DiscoverResources",
+	Genixmlrpc::CallMethodHTTP($GENICENTRAL, User->LookupByUnixId($UID),
+				   "SA::DiscoverResources",
 				   { "uuid"  => $experiment->uuid() });
 
     return -1
@@ -87,11 +89,28 @@ sub GetTicket($$$$)
 	return -1;
     }
 
+    # Need to construct a credential.
+    my $credential = GeniCredential->Create($experiment->uuid(),
+					    $this_user->uuid());
+    if (!defined($credential)) {
+	print STDERR "Could not create a slice credential for $experiment!\n";
+	return -1;
+    }
+    if ($credential->AddCapability("createslice", 0)) {
+	print STDERR "Could not add capability to slice credential!\n";
+	return -1;
+    }
+    if ($credential->Sign()) {
+	print STDERR "Could not sign slice credential!\n";
+	return -1;
+    }
+
     my $response =
-	Genixmlrpc::CallMethodHTTP($component, "CM::GetTicket",
-				   { "slice_uuid"  => $experiment->uuid(),
-				     "owner_uuid"  => $this_user->uuid(),
-				     "rspec" => $rspec });
+	Genixmlrpc::CallMethodHTTP($component, $this_user, "CM::GetTicket",
+			{ "slice_uuid"        => $experiment->uuid(),
+			  "credential_string" => $credential->asString(),
+			  "impotent"          => 1,
+			  "rspec"             => $rspec });
     
     return -1
 	if (!defined($response));
@@ -120,15 +139,35 @@ sub CreateSliver($$$)
     return -1
 	if (!defined($response));
 
-    print Dumper($response);
-
     return -1
 	if ($response->code() != GENIRESPONSE_SUCCESS);
 
-    my $sliver = undef;
-
+    my $sliver = GeniSliver->Create($ticket, $response->value());
+    if (!defined($sliver)) {
+	print STDERR "Could not create local sliver object\n";
+	return undef;
+    }
     $$pref = $sliver;
     return 0;
+}
+		 
+sub DestroySliver($$)
+{
+    my ($experiment, $sliver) = @_;
+    my $ticket = $sliver->GetTicket();
 
+    my $response =
+	Genixmlrpc::CallMethodHTTP($ticket->component(),
+				   "CM::DestroySliver",
+				   { "uuid" => $sliver->uuid() });
+    
+    if ($response->code() != GENIRESPONSE_SUCCESS) {
+	print STDERR "Could not destroy sliver $sliver\n";
+	return -1;
+    }
+    $sliver->Delete() == 0
+	or return -1;
+
+    return 0;
 }
 		 

protogeni/lib/GeniCredential.pm.in

+#!/usr/bin/perl -wT
+#
+# EMULAB-COPYRIGHT
+# Copyright (c) 2008 University of Utah and the Flux Group.
+# All rights reserved.
+#
+package GeniCredential;
+
+#
+# Some simple credential stuff.
+#
+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;
+use Experiment;
+use libdb qw(TBGetUniqueIndex);
+use English;
+use XML::Simple;
+use XML::LibXML;
+use Data::Dumper;
+use File::Temp qw(tempfile);
+
+# 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";
+my $SIGNCRED	   = "$TB/sbin/signgenicred";
+my $VERIFYCRED	   = "$TB/sbin/verifygenicred";
+my $NFREE	   = "$TB/bin/nfree";
+
+#
+# Create an empty credential object.
+#
+sub Create($$$$)
+{
+    my ($class, $this_uuid, $owner_uuid) = @_;
+
+    my $self = {};
+    $self->{'this_uuid'}     = $this_uuid;
+    $self->{'owner_uuid'}    = $owner_uuid;
+    $self->{'string'}        = undef;
+    $self->{'capabilities'}  = undef;
+    bless($self, $class);
+
+    return $self;
+}
+# accessors
+sub field($$)           { return ($_[0]->{$_[1]}); }
+sub this_uuid($)	{ return field($_[0], "this_uuid"); }
+sub owner_uuid($)	{ return field($_[0], "owner_uuid"); }
+sub asString($)		{ return field($_[0], "string"); }
+sub capabilities($)	{ return field($_[0], "capabilities"); }
+
+#
+# Add a capability to the array.
+#
+sub AddCapability($$$)
+{
+    my ($self, $name, $delegate) = @_;
+
+    return -1
+	if (!ref($self));
+
+    if (!defined($self->capabilities())) {
+	$self->{'capabilities'} = {};
+    }
+    $self->{'capabilities'}->{$name} = {"can_delegate" => $delegate};
+    return 0;
+}
+
+#
+# Create a credential object from a signed credential string.
+#
+sub CreateFromSigned($$)
+{
+    my ($class, $string) = @_;
+
+    # First verify the credential
+    my ($fh, $filename) = tempfile(UNLINK => 0);
+    return undef
+	if (!defined($fh));
+    print $fh $string;
+    close($fh);
+    system("$VERIFYCRED $filename");
+    if ($?) {
+	print STDERR "Credential in $filename did not verify\n";
+	return undef;
+    }
+    unlink($filename);
+
+    # Use XML::Simple to convert to something we can mess with.
+    my $parser = XML::LibXML->new;
+    my $doc    = $parser->parse_string($string);
+
+    # Dig out the capabilities
+    my ($cap_node) = $doc->getElementsByTagName("capabilities");
+    return undef
+	if (!defined($cap_node));
+    my $capabilities = XMLin($cap_node->toString(), ForceArray => 0);
+
+    # Dig out the slice uuid. Locally, I am not sure if we bother to
+    # keep slices in the DB (they are in the DB at geni central).
+    my ($uuid_node) = $doc->getElementsByTagName("this_uuid");
+    return undef
+	if (!defined($uuid_node));
+    my $this_uuid = $uuid_node->to_literal();
+
+    if (! ($this_uuid =~ /^\w+\-\w+\-\w+\-\w+\-\w+$/)) {
+	print STDERR "Invalid this_uuid in credential\n";
+	return undef;
+    }
+
+    # Dig out the owner uuid. Locally, I am not sure if we bother to
+    # keep users in the DB (they are in the DB at geni central).
+    ($uuid_node) = $doc->getElementsByTagName("owner_uuid");
+    return undef
+	if (!defined($uuid_node));
+    my $owner_uuid = $uuid_node->to_literal();
+
+    if (! ($owner_uuid =~ /^\w+\-\w+\-\w+\-\w+\-\w+$/)) {
+	print STDERR "Invalid owner_uuid in credential\n";
+	return undef;
+    }
+
+    my $self = {};
+    $self->{'capabilities'}  = $capabilities;
+    $self->{'this_uuid'}     = $this_uuid;
+    $self->{'owner_uuid'}    = $owner_uuid;
+    $self->{'string'}        = $string;
+    $self->{'xmlref'}        = $doc;
+    bless($self, $class);
+
+    return $self;
+}
+
+#
+# Might have to delete this from the DB.
+#
+sub Delete($)
+{
+    my ($self) = @_;
+
+    return -1
+	if (! ref($self));
+
+    return 0;
+}
+
+#
+# Sign the credential.
+#
+sub Sign($)
+{
+    my ($self) = @_;
+
+    return -1
+	if (!ref($self));
+
+    # If no capabilities, then allow all rights, no delegation.
+    if (!defined($self->capabilities())) {
+	$self->AddCapability("*", 0);
+    }
+    # This little wrapup is for xmlout.
+    my $capabilities = {"capability" => $self->capabilities()};
+
+    # Every one gets a new unique index, which is used in the xml:id below.
+    my $idx = TBGetUniqueIndex('next_ticket', 1);
+    
+    my $this_uuid  = $self->this_uuid();
+    my $owner_uuid = $self->owner_uuid();
+    my $cap_xml    = XMLout($capabilities, "NoAttr" => 1);
+    $cap_xml =~ s/opt\>/capabilities\>/g;
+
+    #
+    # Create a template xml file to sign.
+    #
+    my $template =
+	"<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>\n".
+	"<credential xml:id=\"ref1\">\n".
+	" <type>capability</type>\n".
+	" <serial>$idx</serial>\n".
+	" <owner_uuid>$owner_uuid</owner_uuid>\n".
+	" <this_uuid>$this_uuid</this_uuid>\n".
+	"  $cap_xml\n".
+        "</credential>\n";
+
+    my ($fh, $filename) = tempfile(UNLINK => 0);
+    return -1
+	if (!defined($fh));
+
+    print $fh $template;
+    close($fh);
+
+    #
+    # Fire up the signer and capture the output. This is the signed credential
+    # that is returned. 
+    #
+    if (! open(SIGNER, "$SIGNCRED $filename |")) {
+	print STDERR "Could not start $SIGNCRED on $filename\n";
+	return -1;
+    }
+    my $credential = "";
+    while (<SIGNER>) {
+	$credential .= $_;
+    }
+    if (!close(SIGNER)) {
+	print STDERR "Could not sign $filename\n";
+	return -1;
+    }
+    $self->{'string'} = $credential;
+    unlink($filename);
+    return 0;
+}
+
+# _Always_ make sure that this 1 is at the end of the file...
+1;

protogeni/lib/GeniSliver.pm.in

@@ -25,6 +25,7 @@ use Node;
 use English;
 use Data::Dumper;
 use File::Temp qw(tempfile);
+use overload ('""' => 'Stringify');
 
 # Configure variables
 my $TB		   = "@prefix@";
@@ -96,20 +97,22 @@ sub Stringify($)
 }
 
 #
-# Create a sliver. Not much to it yet.
+# Create a sliver. 
 #
-sub Create($$)
+sub Create($$;$)
 {
-    my ($class, $ticket) = @_;
+    my ($class, $ticket, $uuid) = @_;
     my @insert_data = ();
 
     # Every sliver gets a new unique index.
     my $idx = TBGetUniqueIndex('next_sliver', 1);
-    # And a new uuid. 
-    my $uuid = NewUUID();
     if (!defined($uuid)) {
-	print "*** WARNING: Could not generate a UUID!\n";
-	return undef;
+	# And a new uuid for a local sliver.
+	$uuid = NewUUID();
+	if (!defined($uuid)) {
+	    print "*** WARNING: Could not generate a UUID!\n";
+	    return undef;
+	}
     }
     my $slice_uuid = $ticket->slice_uuid();
     my $owner_uuid = $ticket->owner_uuid();
@@ -127,7 +130,12 @@ sub Create($$)
     DBQueryWarn("insert into geni_slivers set " . join(",", @insert_data))
 	or return undef;
 
-    return GeniSlice->Lookup($idx);
+    my $sliver = GeniSliver->Lookup($idx);
+    return undef
+	if (!defined($sliver));
+    $sliver->{'TICKET'} = $ticket;
+
+    return $sliver;
 }
 # accessors
 sub field($$) { return ((! ref($_[0])) ? -1 : $_[0]->{'SLIVER'}->{$_[1]}); }
@@ -170,11 +178,67 @@ sub GetExperiment($)
     return Experiment->Lookup($self->slice_uuid());
 }
 
+#
+# Get the ticket for the sliver.
+#
+sub GetTicket($)
+{
+    my ($self) = @_;
+
+    return undef
+	if (! ref($self));
+
+    if (!exists($self->{'TICKET'})) {
+	print STDERR "No ticket object associated with $self\n";
+	return undef;
+    }
+    return $self->{'TICKET'};
+}
+
 #
 # Provision a slice. We actually did this when the ticket was requested.
 #
 sub Provision($)
 {
+    my ($self) = @_;
+
+    return -1
+	if (! ref($self));
+
+    #
+    # the node is already allocated to the sliver, but still need to enter
+    # a virt_nodes entry, and possibly more virt table entries, so that the
+    # node will boot properly, and is otherwie controllable.
+    #
+    my $experiment = Experiment->Lookup($self->slice_uuid());
+    if (!defined($experiment)) {
+	print STDERR "Could not map $self to its experiment\n";
+	return -1;
+    }
+    my $node_id    = $self->node_id();
+    return 0
+	if (!defined($node_id));
+    my $node       = Node->Lookup($node_id);
+    if (!defined($node)) {
+	print STDERR "Could not map node $node_id to its object\n";
+	return -1;
+    }
+    my $reservation = $node->Reservation();
+    if (!defined($reservation)) {
+	print STDERR "$node was already released from $self\n";
+	return -1;
+    }
+    if ($reservation->SameExperiment($experiment)) {
+	if ($experiment->InsertVirtNode($node) != 0) {
+	    print STDERR "Could not add virtnode entry for $node to $self\n";
+	    return -1;