Checkpoint

protogeni/lib/GeniSAClient.pm.in

+#!/usr/bin/perl -wT
+#
+# EMULAB-COPYRIGHT
+# Copyright (c) 2008 University of Utah and the Flux Group.
+# All rights reserved.
+#
+package GeniSAClient;
+
+#
+# The client side of the SA interface, used by Slice Authorities to
+# invoke operations on Geni Central and on Slices (Components).
+#
+
+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 English;
+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@";
+
+#
+# Register a user at the Geni ClearingHouse (which in the prototype is
+# is Utah Emulab).
+#
+sub RegisterUser()
+{
+
+}

protogeni/lib/GeniUser.pm.in

@@ -92,6 +92,19 @@ sub name($)		{ return field($_[0], "name"); }
 sub email($)		{ return field($_[0], "email"); }
 sub sa_idx($)		{ return field($_[0], "sa_idx"); }
 
+#
+# Stringify for output.
+#
+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.  
 #
@@ -112,12 +125,33 @@ sub LookupByUUID($$)
     return GeniUser->Lookup($uid_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, $uid, $email) = @_;
+
+    my $safe_uid   = DBQuoteSpecial($uid);
+    my $safe_email = DBQuoteSpecial($email);
+
+    my $query_result =
+	DBQueryFatal("select uid_idx from geni_users ".
+		     "where uid=$safe_uid and email=$safe_email");
+    return -1
+	if (!defined($query_result));
+
+    return $query_result->numrows;
+}
+
 #
 # Class function to create new Geni user and return object.
 #
-sub Create($$$)
+sub Create($$$$$)
 {
-    my ($class, $uid, $uuid, $name, $email, $sa_idx) = @_;
+    my ($class, $uid, $name, $email, $sa_idx) = @_;
     my @insert_data = ();
 
     # Every user gets a new unique index.

protogeni/lib/Protogeni.pm.in

@@ -6,6 +6,12 @@
 #
 package Protogeni;
 
+#
+# 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
@@ -77,8 +83,10 @@ sub add ($$)
 }
 
 #############################################################################
-package Protogeni::User;
-use emdbi;
+# The Slice Authority interface for the Geni Clearinghouse.
+#
+package Protogeni::SA;
+use GeniDB;
 use English;
 use User;
 use GeniUser;
@@ -91,7 +99,7 @@ use GeniUser;
 # @param GID the GID of the user to lookup.
 # @return the public key bound to the user GID, or error if no user.
 # 
-sub LookupKey($)
+sub Lookup($)
 {
     my ($uuid) = @_;
 
@@ -101,9 +109,13 @@ sub LookupKey($)
     my $user = User->LookupByUUID($uuid);
     if (defined($user)) {
 	#
-	# A local Emulab user. Return that key.
+	# A local Emulab user. Return the pubkey for the user.
 	#
-	return Protogeni::MakeResponse(0, 2);
+	my $cert;
+	if ($user->SSLCert(1, \$cert) != 0) {
+	    return Protogeni::MakeResponse($Protogeni::RESPONSE_ERROR, "");
+	}
+	return Protogeni::MakeResponse(0, $cert);
     }
     return Protogeni::BadArgsResponse("No such user for GID")
 	if (!defined($user));
@@ -114,5 +126,37 @@ sub LookupKey($)
     return Protogeni::MakeResponse(0, 1);
 }
 
+#
+# Register a new Geni user in the DB. Returns the UUID (GUD).
+#
+sub Register($$$)
+{
+    my ($uid, $name, $email) = @_;
+
+    if (! (defined($uid) && defined($name) && defined($email) &&
+	   $uid =~ /^
+
+    #
+    # XXX TODO!
+    #
+    # Who is the SA? We get this from the SSL environment (certificate).
+    #
+    my $sa_idx = 1;
+
+    #
+    # XXX
+    #
+    # What kind of uniquess requirements do we need? No one else with this
+    # email address? Of course, we have to allow uid reuse, but should we
+    # require that for a given SA, that uid is unique, at least to avoid
+    # lots of confusion?
+    #
+    if (GeniUser->CheckExisting($uid, $name)) {
+	return Protogeni::MakeResponse($Protogeni::RESPONSE_ERROR,
+				       "$uid/$email already registered");
+    }
+}
+
+
 # _Always_ make sure that this 1 is at the end of the file...
 1;

protogeni/xmlrpc/GNUmakefile.in

@@ -20,16 +20,17 @@ SETUID_LIBX_SCRIPTS  =
 # Force dependencies on the scripts so that they will be rerun through
 # configure if the .in file is changed.
 # 
-all:	protogeni.py protogeni-client.py protogeni.pl
+all:	protogeni.py protogeni-client.pl protogeni.pl Genixmlrpc.pm
 
 include $(TESTBED_SRCDIR)/GNUmakerules
 
-install: $(INSTALL_DIR)/protogeni/xmlrpc/protogeni.pl
+install: $(INSTALL_DIR)/protogeni/xmlrpc/protogeni.pl \
+         $(INSTALL_LIBDIR)/Genixmlrpc.pm
 
 control-install:
 
 clean:
-	rm -f *.o core
+	rm -f *.o core *.pl *.pm *.py
 
 $(INSTALL_DIR)/protogeni/xmlrpc/%: %
 	@echo "Installing $<"

protogeni/xmlrpc/Genixmlrpc.pm.in

+#!/usr/bin/perl -w
+#
+# EMULAB-COPYRIGHT
+# Copyright (c) 2008 University of Utah and the Flux Group.
+# All rights reserved.
+#
+# Perl code to access an XMLRPC server using http. Derived from the
+# Emulab library (pretty sure Dave wrote the http code in that file,
+# and I'm just stealing it).
+#
+package Genixmlrpc;
+use strict;
+use Exporter;
+use vars qw(@ISA @EXPORT);
+@ISA    = "Exporter";
+@EXPORT = qw (RESPONSE_SUCCESS RESPONSE_BADARGS RESPONSE_ERROR
+	      RESPONSE_FORBIDDEN RESPONSE_BADVERSION RESPONSE_SERVERERROR
+	      RESPONSE_TOOBIG RESPONSE_REFUSED RESPONSE_TIMEDOUT
+);
+
+# Must come after package declaration!
+use lib '@prefix@/lib';
+use English;
+use RPC::XML;
+use RPC::XML::Parser;
+use LWP::UserAgent;
+use HTTP::Request::Common qw(POST);
+use HTTP::Headers;
+
+# Configure variables
+my $TB		= "@prefix@";
+my $TBOPS       = "@TBOPSEMAIL@";
+my $BOSSNODE    = "@BOSSNODE@";
+
+my $debug = 1;
+
+#
+# This is for the Crypt::SSL library, many levels down. It appears to
+# be the only way to specify this.
+#
+$ENV{'HTTPS_CERT_FILE'} = "@prefix@/etc/server.pem";
+$ENV{'HTTPS_KEY_FILE'}  = "@prefix@/etc/server.pem";
+
+#
+# GENI XMLRPC defs. Also see ../lib/Protogeni.pm.in if you change this.
+#
+sub RESPONSE_SUCCESS()        { 0; }
+sub RESPONSE_BADARGS()        { 1; }
+sub RESPONSE_ERROR()          { 2; }
+sub RESPONSE_FORBIDDEN()      { 3; }
+sub RESPONSE_BADVERSION()     { 4; }
+sub RESPONSE_SERVERERROR()    { 5; }
+sub RESPONSE_TOOBIG()         { 6; }
+sub RESPONSE_REFUSED()        { 7; }
+sub RESPONSE_TIMEDOUT()       { 8; }
+
+##
+# The package version number
+#
+my $PACKAGE_VERSION = 0.1;
+
+#
+# This is the "structure" returned by the RPC server. It gets converted into
+# a perl hash by the unmarshaller, and we return that directly to the caller
+# (as a reference).
+#
+# class EmulabResponse:
+#    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
+#
+
+#
+# Call to a non-Emulab xmlrpc server.  
+# If there was an HTTP error, the hash also contains the keys
+# httpcode and httpmsg.
+#
+sub CallMethodHTTP($$@)
+{
+    my ($httpURL,$method,@args) = @_;
+
+    my $request = new RPC::XML::request($method, @args);
+    if ($debug) {
+	print STDERR "xml request: " . $request->as_string();
+	print STDERR "\n";
+    }
+
+    #
+    # Send an http post.
+    #
+    my $reqstr = $request->as_string();
+    my $ua = LWP::UserAgent->new();
+    my $hreq = HTTP::Request->new(POST => $httpURL);
+    $hreq->content_type('text/xml');
+    $hreq->content($reqstr);
+    my $hresp = $ua->request($hreq);
+
+    if ($debug) {
+	print STDERR "xml response: " . $hresp->as_string();
+	print STDERR "\n";
+    }
+    
+    if (!$hresp->is_success()) {
+	return { 'httpcode' => $hresp->code(),
+		 'httpmsg'  => $hresp->message() };
+    }
+
+    #
+    # Read back the xmlgoo from the child.
+    #
+    my $xmlgoo = $hresp->content();
+
+    if ($debug) {
+	print STDERR "xmlgoo: " . $xmlgoo;
+	print STDERR "\n";
+    }
+
+    #
+    # Convert the xmlgoo to Perl and return it.
+    #
+    my $parser   = RPC::XML::Parser->new();
+    my $goo      = $parser->parse($xmlgoo);
+    my ($value,$output,$code);
+    
+    # Python servers seem to return faults in structs, not as <fault> elements.
+    # Sigh.
+    if (!ref($goo)) {
+        print STDERR "Error in XMLRPC parse: $goo\n";
+        return undef;
+    }
+    elsif ($goo->value()->is_fault() 
+	|| (ref($goo->value()) && UNIVERSAL::isa($goo->value(),"HASH") 
+	    && exists($goo->value()->{'faultCode'}))) {
+	$code   = $goo->value()->{"faultCode"}->value;
+	$value  = $code;
+	$output = $goo->value()->{"faultString"}->value;
+    }
+    else {
+	$code   = 0;
+	$value  = $goo->value;
+	if (ref($value)) {
+	    $value = $value->value;
+	}
+	$output = $value;
+    }
+    return {"code"   => $code,
+	    "value"  => $value,
+	    "output" => $output};
+}
+
+# _Always_ make sure that this 1 is at the end of the file...
+
+1;

protogeni/xmlrpc/protogeni-client.pl.in

+#!/usr/bin/perl -w
+#
+# EMULAB-COPYRIGHT
+# Copyright (c) 2008 University of Utah and the Flux Group.
+# All rights reserved.
+#
+use strict;
+use English;
+use Data::Dumper;
+
+#
+# Configure variables
+#
+my $TB       = "@prefix@";
+
+# Geni libraries.
+use lib "@prefix@/lib";
+use Genixmlrpc;
+
+my $server = shift(@ARGV);
+my $method = shift(@ARGV);
+
+my $response = 
+    Genixmlrpc::CallMethodHTTP("https://$server/protogeni/xmlrpc",
+			       $method, @ARGV);
+
+print Dumper($response);
+
+

protogeni/xmlrpc/protogeni-cm.pl.in

@@ -32,7 +32,8 @@ delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
 # The UUID of the client certificate is in the env var SSL_CLIENT_S_DN_CN.
 #
 my $responder = Frontier::Responder->new( "methods" => {
-    "User::Lookup" => \&Protogeni::User::Lookup,
+    "SA::Lookup"   => \&Protogeni::SA::Lookup,
+    "SA::Register" => \&Protogeni::SA::Register,
     "add"          => \&Protogeni::add,
    },
 );