Commit bce3d5d8 authored by Leigh B. Stoller's avatar Leigh B. Stoller

Checkpoint

parent 94d9451a
#!/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()
{
}
...@@ -92,6 +92,19 @@ sub name($) { return field($_[0], "name"); } ...@@ -92,6 +92,19 @@ sub name($) { return field($_[0], "name"); }
sub email($) { return field($_[0], "email"); } sub email($) { return field($_[0], "email"); }
sub sa_idx($) { return field($_[0], "sa_idx"); } 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. # Lookup user given a UUID.
# #
...@@ -112,12 +125,33 @@ sub LookupByUUID($$) ...@@ -112,12 +125,33 @@ sub LookupByUUID($$)
return GeniUser->Lookup($uid_idx); 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. # 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 = (); my @insert_data = ();
# Every user gets a new unique index. # Every user gets a new unique index.
......
...@@ -6,6 +6,12 @@ ...@@ -6,6 +6,12 @@
# #
package Protogeni; 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 strict;
use Exporter; use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK use vars qw(@ISA @EXPORT @EXPORT_OK
...@@ -77,8 +83,10 @@ sub add ($$) ...@@ -77,8 +83,10 @@ sub add ($$)
} }
############################################################################# #############################################################################
package Protogeni::User; # The Slice Authority interface for the Geni Clearinghouse.
use emdbi; #
package Protogeni::SA;
use GeniDB;
use English; use English;
use User; use User;
use GeniUser; use GeniUser;
...@@ -91,7 +99,7 @@ use GeniUser; ...@@ -91,7 +99,7 @@ use GeniUser;
# @param GID the GID of the user to lookup. # @param GID the GID of the user to lookup.
# @return the public key bound to the user GID, or error if no user. # @return the public key bound to the user GID, or error if no user.
# #
sub LookupKey($) sub Lookup($)
{ {
my ($uuid) = @_; my ($uuid) = @_;
...@@ -101,9 +109,13 @@ sub LookupKey($) ...@@ -101,9 +109,13 @@ sub LookupKey($)
my $user = User->LookupByUUID($uuid); my $user = User->LookupByUUID($uuid);
if (defined($user)) { 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") return Protogeni::BadArgsResponse("No such user for GID")
if (!defined($user)); if (!defined($user));
...@@ -114,5 +126,37 @@ sub LookupKey($) ...@@ -114,5 +126,37 @@ sub LookupKey($)
return Protogeni::MakeResponse(0, 1); 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... # _Always_ make sure that this 1 is at the end of the file...
1; 1;
...@@ -20,16 +20,17 @@ SETUID_LIBX_SCRIPTS = ...@@ -20,16 +20,17 @@ SETUID_LIBX_SCRIPTS =
# Force dependencies on the scripts so that they will be rerun through # Force dependencies on the scripts so that they will be rerun through
# configure if the .in file is changed. # 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 include $(TESTBED_SRCDIR)/GNUmakerules
install: $(INSTALL_DIR)/protogeni/xmlrpc/protogeni.pl install: $(INSTALL_DIR)/protogeni/xmlrpc/protogeni.pl \
$(INSTALL_LIBDIR)/Genixmlrpc.pm
control-install: control-install:
clean: clean:
rm -f *.o core rm -f *.o core *.pl *.pm *.py
$(INSTALL_DIR)/protogeni/xmlrpc/%: % $(INSTALL_DIR)/protogeni/xmlrpc/%: %
@echo "Installing $<" @echo "Installing $<"
......
#!/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;
#!/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);
...@@ -32,7 +32,8 @@ delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'}; ...@@ -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. # The UUID of the client certificate is in the env var SSL_CLIENT_S_DN_CN.
# #
my $responder = Frontier::Responder->new( "methods" => { my $responder = Frontier::Responder->new( "methods" => {
"User::Lookup" => \&Protogeni::User::Lookup, "SA::Lookup" => \&Protogeni::SA::Lookup,
"SA::Register" => \&Protogeni::SA::Register,
"add" => \&Protogeni::add, "add" => \&Protogeni::add,
}, },
); );
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment