Commit bce3d5d8 authored by Leigh Stoller's avatar Leigh 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"); }
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.
......
......@@ -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.
#
return Protogeni::MakeResponse(0, 2);
# A local Emulab user. Return the pubkey for the user.
#
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;
......@@ -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 $<"
......
#!/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'};
# 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,
},
);
......
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