GeniAM.pm.in

#!/usr/bin/perl -wT
#
# GENIPUBLIC-COPYRIGHT
# Copyright (c) 2008-2012 University of Utah and the Flux Group.
# All rights reserved.
#
package GeniAM;

#
# The server side of the CM interface on remote sites. Also communicates
# with the GMC interface at Geni Central as a client.
#
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);

@ISA    = "Exporter";
@EXPORT = qw ( );

use GeniCMV2;
use GeniResponse;
use GeniCredential;
use GeniRegistry;
use emutil;

use Compress::Zlib;
use MIME::Base64;
use XML::LibXML;
use URI;
use Date::Parse;
use Data::Dumper;
use Frontier::RPC2;
use POSIX qw(strftime);

# Disable UUID checks in GeniCredential.
$GeniCredential::CHECK_UUID = 0;

my $API_VERSION = 2;
my $MAINSITE    = @TBMAINSITE@;

sub SetGeniVersion($)
{
    my ($new_version) = @_;
    if ($new_version eq "1.0") {
	$API_VERSION = 1;
    }
    print STDERR "Api version: " . $API_VERSION . "\n";
}

#
# Tell the client what API revision we support.  The correspondence
# between revision numbers and API features is to be specified elsewhere.
# No credentials are required.
#
sub GetVersion()
{
    # $options is optional here for all versions
    my ($options) = @_;
    my $me = GeniAuthority->Lookup($ENV{'MYURN'});
    if (!defined($me)) {
	print STDERR "Could not find local authority object\n";
	return GeniResponse->Create(GENIRESPONSE_ERROR);
    }
    my $commithash = VersionInfo("commithash") || "";
    my $hostname   = `hostname`;
    chomp($hostname);
    my $peers      = {};

    #
    # Ask the Clearinghouse for the peers info.
    #
    if ($MAINSITE) {
	my $clearinghouse = GeniRegistry::ClearingHouse->Create();
	if (!defined($clearinghouse)) {
	    print STDERR "Could not create clearinghouse object.\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR);
	}
	my $versioninfo;
	if ($clearinghouse->GetVersion(\$versioninfo)) {
	    print STDERR "Could not get peers from clearinghouse.\n";
	    return GeniResponse->Create(GENIRESPONSE_ERROR);
	}
	$peers = $versioninfo->{"peers"};

	foreach my $urn (keys(%{ $peers })) {
	    my $url = $peers->{$urn};
	    $url =~ s/cm$/am/;
	    $peers->{$urn} = $url;
	}
    }

    #
    # We have some confusion here. This is the AM interface, and the
    # URL is different, but the URN and HRN are that of the CM.
    #
    my $url = $me->url();
    $url =~ s/cm$/am/;

    my $coder = Frontier::RPC2->new('use_objects' => 1);

    my $default_ad = {
	"type" => "ProtoGENI",
	"version" => $coder->string("2") };
    my $request_0_1 = {
	"type" => "ProtoGENI",
	"version" => $coder->string("0.1"),
	"schema" => "http://www.protogeni.net/resources/rspec/0.1/request.xsd",
	"namespace" => "http://www.protogeni.net/resources/rspec/0.1",
	"extensions" => []
    };
    my $request_0_2 = {
	"type" => "ProtoGENI",
	"version" => $coder->string("0.2"),
	"schema" => "http://www.protogeni.net/resources/rspec/0.2/request.xsd",
	"namespace" => "http://www.protogeni.net/resources/rspec/0.2",
	"extensions" => []
    };
    my $request_2 = {
	"type" => "ProtoGENI",
	"version" => $coder->string("2"),
	"schema" => "http://www.protogeni.net/resources/rspec/2/request.xsd",
	"namespace" => "http://www.protogeni.net/resources/rspec/2",
	"extensions" => ["http://www.protogeni.net/resources/rspec/ext/emulab/1"]
    };
    my $request_3 = {
	"type" => "GENI",
	"version" => $coder->string("3"),
	"schema" => "http://www.geni.net/resources/rspec/3/request.xsd",
        "namespace" => "http://www.geni.net/resources/rspec/3",
        "extensions" => ["http://www.protogeni.net/resources/rspec/ext/emulab/1"]
    };
    my $ad_0_1 = {
        "type" => "ProtoGENI",
        "version" => $coder->string("0.1"),
        "schema" => "http://www.protogeni.net/resources/rspec/0.1/ad.xsd",
        "namespace" => "http://www.protogeni.net/resources/rspec/0.1",
        "extensions" => []
    };
    my $ad_0_2 = {
        "type" => "ProtoGENI",
        "version" => $coder->string("0.2"),
        "schema" => "http://www.protogeni.net/resources/rspec/0.2/ad.xsd",
        "namespace" => "http://www.protogeni.net/resources/rspec/0.2",
        "extensions" => []
    };
    my $ad_2 = {
        "type" => "ProtoGENI",
        "version" => $coder->string("2"),
        "schema" => "http://www.protogeni.net/resources/rspec/2/ad.xsd",
        "namespace" => "http://www.protogeni.net/resources/rspec/2",
        "extensions" => ["http://www.protogeni.net/resources/rspec/ext/emulab/1"]
    };
    my $ad_3 = {
	"type" => "GENI",
	"version" => $coder->string("3"),
	"schema" => "http://www.geni.net/resources/rspec/3/ad.xsd",
        "namespace" => "http://www.geni.net/resources/rspec/3",
        "extensions" => ["http://www.protogeni.net/resources/rspec/ext/emulab/1"]
    };

    my $request_name = "request_rspec_versions";
    my $ad_name = "ad_rspec_versions";
    if ($API_VERSION > 1) {
	$request_name = "geni_request_rspec_versions";
	$ad_name = "geni_ad_rspec_versions";
    }

    my $blob = {
	"geni_api"   => $API_VERSION,
	"urn"        => $me->urn(),
	"hrn"        => $me->hrn(),
	"url"        => $url,
	"interface"  => "aggregate",
	"code_tag"   => $commithash,
	# XXX
	"hostname"   => $hostname,
	$request_name => [$request_0_1, $request_0_2, $request_2,
			   $request_3],
	$ad_name => [$ad_0_1, $ad_0_2, $ad_2, $ad_3],
	"geni_api_versions" => {
	    "1" => "$url/1.0",
	    "2" => "$url/2.0"
	}
    };
    $blob->{"peers"} = $peers
	if ($MAINSITE);
    $blob->{"default_ad_rspec"} = $default_ad
	if ($API_VERSION == 1);

    my $response = GeniResponse->Create(GENIRESPONSE_SUCCESS, $blob);
    if ($API_VERSION > 1) {
	$response->{"geni_api"} = $API_VERSION;
    }
    return $response;
}

# List this aggregates resources. Invokes GeniCMV2::Resolve or
# GeniCMV2::DiscoverResources.
sub ListResources()
{
    my ($credentials, $options) = @_;
    if (! defined($credentials) || ! defined($options)
	|| ($API_VERSION > 1 && ! defined($options->{'geni_rspec_version'}))) {
	return GeniResponse->MalformedArgsResponse("Missing arguments");
    }
    my $available = $options->{'geni_available'};
    my $compress = $options->{'geni_compressed'};
    my $slice_urn = $options->{'geni_slice_urn'};
    my $version;
    if ($API_VERSION == 1) {
	$version    = $options->{'rspec_version'} || undef;
    } else {
	$version    = $options->{'geni_rspec_version'};
    }

    my $xml = undef;
    if ($slice_urn) {

        # If $slice_urn is defined, this turns into a Resolve call.  We
        # need to resolve twice: once to get the sliver urn from the
        # slice, then to get the resources associated with the sliver (a
        # manifest rspec).
        my $resolve_args = {
            'urn' => $slice_urn,
            'credentials' => $credentials
        };
        my $response = GeniCMV2::Resolve($resolve_args);
        if (GeniResponse::IsError($response)) {
            return $response;
        }
        # Get the hash out of the response
        my $slice_hash = GeniResponse::value($response);
        my $sliver = $slice_hash->{'sliver_urn'};
        # Resolve the sliver to get the manifest RSpec
        $resolve_args->{'urn'} = $sliver;
        $response = GeniCMV2::Resolve($resolve_args);
        if (GeniResponse::IsError($response)) {
            return $response;
        }
        $xml = GeniResponse::value($response)->{'manifest'};

    } else {
	my $pgversion = undef;
	if (! defined($version)) {
	    $pgversion = "2";
	} elsif (defined($version->{'type'}) &&
		 (lc($version->{'type'}) eq "protogeni"
		  || lc($version->{'type'}) eq "geni")) {
	    $pgversion = $version->{'version'};
	} else {
	    return GeniResponse->Create(GENIRESPONSE_ERROR, undef,
					"Only ProtoGENI RSpec advertisements are supported");
	}
        # No slice was specified, so get the advertisement RSpec.
        my $discover_args = {
            'credentials' => $credentials,
            'available' => $available,
	    'rspec_version' => $pgversion,
        };
        my $response = GeniCMV2::DiscoverResources($discover_args);
        if (GeniResponse::IsError($response)) {
            return $response;
        } else {
            $xml = GeniResponse::value($response)
        }

    }

    # Was compression requested?
    if (defined($compress) && ref($compress) eq 'Frontier::RPC2::Boolean') {
	$compress = $compress->value;
    }
    # If compression was requested, do it. The result is a String
    # whose contents are a base64 encoding of a zlib compressed RSpec.
    if ($compress) {
        my $coder = Frontier::RPC2->new();
        $xml = encode_base64( compress( $xml ) );
    }
    # Finally, return the RSpec
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $xml);
}

sub auto_add_sa($)
{
    my ($cred_str) = @_;
    my $verify_sig = 1;
    my $cred = GeniCredential->CreateFromSigned($cred_str, $verify_sig);
    my $signers = $cred->signer_certs();

    # The credential has been verified, so the signer derives from a
    # trusted root.
    my $sa_cert = @$signers[0];

    # These are borrowed from protogeni/scripts/addauthority
    my $certificate = GeniCertificate->LoadFromString($sa_cert);
    if (!defined($certificate)) {
        print STDERR "auto_add_sa: could not get certificate from $sa_cert\n";
        return;
    }
    if (! ($certificate->uuid() =~ /\w*-(\w*)$/)) {
        print STDERR "auto_add_sa: could not get prefix from uuid\n";
        return;
    }
    my $url = $certificate->URL();
    if (!defined($url)) {
        print STDERR "auto_add_sa: certificate does not have a URL extension\n";
    }
    my $urn = $certificate->urn();
    if (!defined($urn)) {
        print STDERR "auto_add_sa: certificate does not have a URN extension\n";
        return;
    }
    # Look to see if already registered.
    my $authority = GeniAuthority->Lookup($urn);
    if (defined($authority)) {
	#
	# See if the certificate has changed. If so we want to replace it.
	#
	return
	    if ($certificate->SameCert($authority->GetCertificate()));

	#
	# Want to reuse the old uuid since we use it as a table cross
	# reference index. Eventually need to use the URN. Anyway, change
	# the uuid in the new certificate so that it goes into the DB
	# with the original one. Then update the Authority record with
	# the new certificate.
	#
	print STDERR "Updating $authority with new certificate: $certificate\n";
	
	$certificate->setuuid($authority->uuid());
	if ($authority->UpdateCertificate($certificate)) {
	    print STDERR "Failed to update $authority with $certificate\n";
	    return;
	}
	return;
    }
    #
    # We want the URL! 
    #
    goto goturl
	if (defined($url));
    
    # First get the list of registries from PLC.
    my $registry = GeniRegistry::PLC->Create();
    if (!defined($registry)) {
	print STDERR "Cannot create a PLC registry object\n";
	return;
    }
    my $blob;
    if ($registry->GetRegistries(\$blob)) {
	print STDERR "Cannot get PLC registry listing\n";
	return;
    }
    print STDERR Dumper($blob);

    #
    # Now look at the last signer certificate; this is the actual authority.
    #
    my $authcertstr = @$signers[scalar(@$signers) - 1];
    my $authcert = GeniCertificate->LoadFromString($authcertstr);
    if (!defined($authcert)) {
        print STDERR
	    "auto_add_sa: could not get certificate from $authcertstr\n";
        return;
    }
    my $authurn = $authcert->urn();
    if (!defined($authurn)) {
        print STDERR "auto_add_sa: $authcert does not have a URN extension\n";
        return;
    }

    #
    # Now search ...
    #
    foreach my $ref (@$blob) {
	if ($ref->{'urn'} eq $authurn) {
	    $url = $ref->{'url'};
	    last;
	}
    }
    if (!defined($url)) {
        print STDERR "auto_add_sa: could not get a URL for $authcert\n";
	return;
    }
    #
    # Gack. Replace the URL with a modified URL which says https.
    # Why does PLC set the scheme to http?
    #
  goturl:
    my $uri = URI->new($url);
    $uri->scheme("https");
    $url = "$uri";
    
    if (!GeniAuthority->Create($certificate, $url, "sa")) {
        print STDERR "auto_add_sa: unable to add authority\n";
        return;
    }
    return $certificate;
}

# Create a sliver by allocating and starting resources.
sub CreateSliver()
{
    my ($slice_urn, $credentials, $rspec, $users, $options) = @_;
    if (! defined($slice_urn) || ! defined($credentials)
	|| ! defined($rspec) || ! defined($users)
	|| (! defined($options) && $API_VERSION > 1)) {
	return GeniResponse->MalformedArgsResponse("Missing arguments");
    }

    foreach my $cred (@$credentials) {
        # If we want to remove the SA(s) after this call, push them
        # onto a list here and remove them at the end of this
        # function. The other AM calls do not need the dynamically
        # added SA.
        auto_add_sa($cred);
    }

    # Package the caller_keys in a list of hashes the way the CM wants
    # it. Each hash has two keys ('type' and 'key'). 'type' is always
    # 'ssh' for us, and 'key' is the key.
    my $sliver_keys = undef;
    if (@$users) {
	$sliver_keys = [];
	foreach my $user (@$users) {
	    my $user_urn  = $user->{'urn'};
	    my @user_keys = ();

	    foreach my $key (@{ $user->{keys} }) {
		# The CMV2 does not like newlines at the end of the keys.
		chomp($key);
		push(@user_keys, {'type' => 'ssh', 'key' => $key});
	    }
	    push(@{$sliver_keys}, {'urn'  => $user_urn,
				   'keys' => \@user_keys});
	}
    }
    # Invoke CreateSliver
    my $create_args = {
        'slice_urn' => $slice_urn,
        'rspec' => $rspec,
        'credentials' => $credentials,
        'keys' => $sliver_keys
    };
    my $response = GeniCMV2::CreateSliver($create_args);
    if (!ref($response)) {
	# This is cause GeniCMV2::CreateSliver does a fork, and the child
	# returns plain status code, which should go to our caller. 
	return $response;
    }
    if (GeniResponse::IsError($response)) {
        # The create failed, so return the response.
        return $response
    }

    # The create succeeded so gather the response info
    my $listref = GeniResponse::value($response);
    my ($sliver_credential, $manifest_rspec) = @{$listref};
    return GeniResponse->Create( GENIRESPONSE_SUCCESS, $manifest_rspec );
}

# Just delegate to CMV2::DeleteSlice. If we ever change to sliver_urns
# for this call, we'll probably want to call CMV2::DeleteSliver
# instead.
sub DeleteSliver()
{
    my ($slice_urn, $credentials, $options) = @_;
    if (! defined($slice_urn) || ! defined($credentials)
	|| (! defined($options) && $API_VERSION > 1)) {
	return GeniResponse->MalformedArgsResponse("Missing arguments");
    }

    my $delete_args = {
        'slice_urn' => $slice_urn,
        'credentials' => $credentials
    };
    my $response = GeniCMV2::DeleteSlice($delete_args);
    if (GeniResponse::IsError($response)) {
        return $response;
    } else {
        # Return an XML-RPC boolean
        my $coder = Frontier::RPC2->new();
        return GeniResponse->Create(GENIRESPONSE_SUCCESS, $coder->boolean(1));
    }
}

# No prototype because it is recursive and as such, the prototype
# causes a warning.
#
# Return a hash containing a JSONish representation of the given node.
sub XmlToJson
{
    my ($node) = @_;
 
    my $attrs = {};
    foreach my $attr ($node->attributes) {
        $attrs->{$attr->nodeName()} = $attr->nodeValue();
    }

    my $children = [];
    foreach my $child ($node->childNodes) {
        if ($child->nodeType() == XML_ELEMENT_NODE) {
            push(@$children, XmlToJson($child));
        }
    }

    my $result = {
        "name" => $node->nodeName(),
        "attributes" => $attrs,
        "children" => $children
    };
    return $result;
}

# Get the status of the sliver associated with the given slice. This
# just passes on to the CM SliverStatus operation.
sub SliverStatus()
{
    my ($slice_urn, $credentials, $options) = @_;
    if (! defined($slice_urn) || ! defined($credentials)
	|| (! defined($options) && $API_VERSION > 1)) {
	return GeniResponse->MalformedArgsResponse("Missing arguments");
    }

    my $status_args = {
        'slice_urn' => $slice_urn,
        'credentials' => $credentials,
    };
    my $response = GeniCMV2::SliverStatus($status_args);
    if (GeniResponse::IsError($response)) {
        return $response
    }
    # $status is a hash ref
    my $pgstatus = GeniResponse::value($response);
    my $status = {};

    $status->{'geni_urn'} = $slice_urn;

    # Determine geni_status. XXX how to determine 'configuring'?
    if ($pgstatus->{'status'} eq 'ready') {
        $status->{'geni_status'} = 'ready';
    } elsif ($pgstatus->{'status'} eq 'failed') {
        $status->{'geni_status'} = 'failed';
    } else {
        $status->{'geni_status'} = 'unknown';
    }

    # include the pg status
    $status->{'pg_status'} = $pgstatus->{'status'};

    # include the expiration, converting to UTC
    my $slice = GeniSlice->Lookup($slice_urn);
    my @expires = gmtime(str2time($slice->expires()));
    my $expires_str = POSIX::strftime("%Y-%m-%dT%H:%M:%S", @expires);
    $status->{'pg_expires'} = $expires_str;

    # Grab the keys (logins) for inclusion.
    my $slice_experiment = $slice->GetExperiment();
    if (!defined($slice_experiment)) {
	print STDERR "*** No Experiment for $slice\n";
    }
    else {
	my $bindings;
	if ($slice_experiment->NonLocalUsers(\$bindings)) {
	    print STDERR "*** No bindings for $slice_experiment\n";
	}
	elsif (@{ $bindings }) {
	    $status->{'users'} = $bindings;
	}
    }

    my $details = $pgstatus->{'details'};
    my @children = ();
    while ( my ($pgurn, $pgrstat) = each(%$details) ) {
        my $child = {
            'geni_urn' => $pgurn,
            # XXX Need to massage status to one of the AM status values
            'geni_status' => $pgrstat->{'status'},
            'geni_error' => $pgrstat->{'error'},
            'pg_status' => $pgrstat->{'status'},
        };
        # Look up the sliver so we can extract info from the manifest.
        my $sliver = GeniSliver->Lookup($pgurn);
	if (!defined($sliver)) {
	    $sliver = GeniAggregate->Lookup($pgurn);
	}
	# Signal an error?
	next
	    if (!defined($sliver));

        # Put manifest info in...
        my $manifest = $sliver->GetManifest(0);
        if (0) {
            # An example of how to include a single element from the
            # manifest. Abondoned this approach and went to XmlToJson
            # instead. Finds the "login", then the "hostname" inside
            # the rspec
            my $login = GeniXML::FindNodes(".//n:services//n:login", $manifest);
            if (defined($login)) {
                my $login = @$login[0];
                my $host = GeniXML::GetText("hostname", $login);
                if (defined($host)) {
                    $child->{'pg_hostname'} = $host;
                }
            }
        }
        $child->{'pg_manifest'} = XmlToJson($manifest);
        #$child->{'pg_xml_manifest'} = GeniXML::Serialize($manifest);
        push @children, $child;
    }
    $status->{'geni_resources'} = \@children;

    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $status);
}

sub RenewSliver()
{
    my ($slice_urn, $credentials, $expiration_time, $options) = @_;
    if (! defined($slice_urn) || ! defined($credentials)
	|| ! defined($expiration_time)
	|| (! defined($options) && $API_VERSION > 1)) {
	return GeniResponse->MalformedArgsResponse("Missing arguments");
    }

    my $renew_args = {
        'slice_urn' => $slice_urn,
        'expiration' => $expiration_time,
        'credentials' => $credentials
    };
    my $response = GeniCMV2::RenewSlice($renew_args);
    if (GeniResponse::IsError($response)) {
        return $response;
    }

    # Return an XML-RPC boolean
    my $coder = Frontier::RPC2->new();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $coder->boolean(1));
}

sub Shutdown()
{
    my ($slice_urn, $credentials, $options) = @_;
    if (! defined($slice_urn) || ! defined($credentials)
	|| (! defined($options) && $API_VERSION > 1)) {
	return GeniResponse->MalformedArgsResponse("Missing arguments");
    }

    my $shutdown_args = {
        'slice_urn' => $slice_urn,
        'credentials' => $credentials
    };
    my $response = GeniCMV2::Shutdown($shutdown_args);
    if (GeniResponse::IsError($response)) {
        return $response;
    }

    # Return an XML-RPC boolean
    my $coder = Frontier::RPC2->new();
    return GeniResponse->Create(GENIRESPONSE_SUCCESS, $coder->boolean(1));
}

# _Always_ make sure that this 1 is at the end of the file...
1;