#!/usr/bin/perl -w
#
# GENIPUBLIC-COPYRIGHT
# Copyright (c) 2010-2011 University of Utah and the Flux Group.
# All rights reserved.
#
package GeniXML;

use strict;
use Exporter;
use vars qw(@ISA @EXPORT);

@ISA = "Exporter";
@EXPORT = qw(Parse ParseFile IsVersion0 FindNodes FindNodesNS
FindFirst FindElement FindAttr GetNodeByVirtualId GetLinkByVirtualId
IsLanNode IsLocalNode IsTunnel GetExpires GetBandwidth GetIp GetVnodeId
GetNodeId GetVirtualId GetInterfaceId GetInterfaceNodeId GetSliverId
GetManagerId GetColocate GetSubnodeOf GetStartupCommand GetTarball
GetVirtualizationType SetVirtualizationSubtype GetVirtualizationSubtype
GetExclusive SetExclusive GetLinkManager SetText GetText Serialize
CreateDocument AddElement RemoveChild PolicyExists);

use English;
use XML::LibXML;
use XML::LibXML::XPathContext;
use XML::LibXML::NodeList;
use GeniHRN;
use GeniUtil;
use Carp qw(cluck carp);

use vars qw($RSPEC_0_1 $RSPEC_0_2 $RSPEC_2 $EMULAB_NS);
$RSPEC_0_1 = "0.1";
$RSPEC_0_2 = "0.2";
$RSPEC_2 = "2";

$EMULAB_NS = "http://www.protogeni.net/resources/rspec/ext/emulab/1";

# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";

# Returns the document element by parsing a given string. If the
# string fails to parse, returns undefined.
sub Parse($)
{
    my ($xml) = @_;
    my $parser = XML::LibXML->new;
    my $doc;
    eval {
        $doc = $parser->parse_string($xml);
    };
    if ($@) {
	carp("Failed to parse xml string: $@\nXML: $xml\n\n");
	return undef;
    } else {
	return $doc->documentElement();
    }
}

sub ParseFile($)
{
    my ($file) = @_;
    my $parser = XML::LibXML->new;
    my $doc;
    eval {
        $doc = $parser->parse_file($file);
    };
    if ($@) {
	carp("Failed to parse xml string: $@");
	return undef;
    } else {
	return $doc->documentElement();
    }
}

# Determines the rspec version of a node by examining is namespace URI
sub GetVersion($)
{
    my ($node) = @_;
    my $result = $RSPEC_0_1;
    my $ns = $node->namespaceURI();
    if (defined($ns)) {
	if ($ns =~ /protogeni.net\/resources\/rspec\/0.1$/) {
	    $result = $RSPEC_0_1;
	} elsif ($ns =~ /protogeni.net\/resources\/rspec\/0.2$/) {
	    $result = $RSPEC_0_2;
	} elsif ($ns =~ /protogeni.net\/resources\/rspec\/2$/) {
	    $result = $RSPEC_2;
	} else {
	    carp("Unknown rspec namespace: " . $ns);
	    $result = $RSPEC_0_1;
	}
    }
    return $result;
}

sub IsVersion0($)
{
    my $version = GetVersion($_[0]);
    return $version eq $RSPEC_0_1 || $version eq $RSPEC_0_2;
}

# Returns a NodeList for a given XPath using a given node as
# context. 'n' is defined to be the prefix for the namespace of the
# node.
sub FindNodes($$)
{
    my ($path, $node) = @_;
    my $result = undef;
    my $ns = undef;
    eval {
	my $xc = XML::LibXML::XPathContext->new();
	$ns = $node->namespaceURI();
	if (defined($ns)) {
	    $xc->registerNs('n', $ns);
	} else {
	    $path =~ s/\bn://g;
	}
	$result = $xc->findnodes($path, $node);
    };
    if ($@) {
	if (! defined($ns)) {
	    $ns = "undefined";
	}
        cluck "Failed to find nodes using XPath path='$path', ns='$ns': $@\n";
	return XML::LibXML::NodeList->new();
    } else {
	return $result;
    }
}

# Returns a NodeList for a given XPath using a given namespace as
# context. 'n' is defined to be the prefix for the given namespace.
sub FindNodesNS($$$)
{
    my ($path, $node, $nsURI) = @_;
    my $result = undef;
    return XML::LibXML::NodeList->new()
        if (!defined($node));
    eval { 
  my $xc = XML::LibXML::XPathContext->new();
  if (defined($nsURI)) {
      $xc->registerNs('n', $nsURI);
  } else {
      $path =~ s/\bn://g;
  }
  $result = $xc->findnodes($path, $node);
    };
    if ($@) {
  if (! defined($nsURI)) {
      $nsURI = "undefined";
  }
        cluck "Failed to find nodes using XPath path='$path', nsURI='$nsURI': $@\n";        
  return XML::LibXML::NodeList->new();
    } else { 
  return $result;
    } 
}


# Returns the first Node which matches a given XPath against a given
# node. If that node is not of the specified type, returns
# undefined. Works like FindNodes.
sub FindNodeType($$$)
{
    my ($path, $node, $type) = @_;
    my $result = FindNodes($path, $node)->pop();
    if (defined($result) && $result->nodeType() != $type) {
	$result = undef;
    }
    return $result;
}

# Returns the first Node which matches a given XPath.
sub FindFirst($$)
{
    my ($path, $node) = @_;
    return FindNodes($path, $node)->pop();
}

# Returns the first Element which matches a given XPath.
sub FindElement($$)
{
    my ($path, $node) = @_;
    return FindNodeType($path, $node, XML_ELEMENT_NODE);
}

# Returns the first Attribute which matches a given XPath.
sub FindAttr($$)
{
    my ($path, $node) = @_;
    return FindNodeType($path, $node, XML_ATTRIBUTE_NODE);
}

sub GetElementByVirtualId($$$)
{
    my ($name, $type, $node) = @_;
    my @list = FindNodes('n:'.$type.'[@virtual_id = "'.$name.'"]',
			 $node)->get_nodelist();
    if (scalar(@list) == 0) {
	@list = FindNodes('n:'.$type.'[@nickname = "'.$name.'"]',
			  $node)->get_nodelist();
    }
    if (scalar(@list) == 0) {
	@list = FindNodes('n:'.$type.'[@client_id = "'.$name.'"]',
			  $node)->get_nodelist();
    }
    my $result = undef;
    if (scalar(@list) > 0)
    {
	$result = $list[0];
    }
    if (scalar(@list) > 1)
    {
	cluck("WARNING: Multiple $type with virtual_id $name found");
    }
    return $result;
}

sub GetNodeByVirtualId($$)
{
    my ($name, $node) = @_;
    return GetElementByVirtualId($name, 'node', $node);
}

sub GetLinkByVirtualId($$)
{
    my ($name, $node) = @_;
    return GetElementByVirtualId($name, 'link', $node);    
}

# Returns true if a given XML Node is an RSpec node and is of type lan
sub IsLanNode($)
{
    my ($node) = @_;
    my $result = 0;
    if (defined($node) && $node->localname() eq "node") {
	foreach my $lan (FindNodes("n:hardware_type",
				   $node)->get_nodelist()) {
	    my $typeName = GetFirstText($lan, "type_name", "name");
	    if (defined($typeName) && $typeName eq "lan") {
		$result = 1;
		last;
	    }
	}
    }
    return $result;
}

# Returns true if a given XML Node is an RSpec node and either has
# the current CM as a 'component_manager_urn' or
# 'component_manager_uuid or no component_manager defined.
sub IsLocalNode($)
{
    my ($node) = @_;
    my $result = 0;
    if (defined($node) && $node->localname() eq "node") {
	my $manager_uuid  = GetManagerId($node);
	if (! defined($manager_uuid) ||
	    GeniHRN::Equal($manager_uuid, $ENV{'MYURN'}) ||
	    $manager_uuid eq $ENV{'MYUUID'}) {

	    $result = 1;
	}
    }
    return $result;
}

sub IsTunnel($)
{
    my ($link) = @_;
    my $result = 0;
    if (IsVersion0($link)) {
	my $link_type = GetText("link_type", $link);
	$result = (defined($link_type) && $link_type eq "tunnel");
    } else {
	my @types = FindNodes("n:link_type", $link)->get_nodelist();
	foreach my $current (@types) {
	    my $name = GetText("name", $current);
	    if (defined($name) && $name eq "gre-tunnel") {
		$result = 1;
		last;
	    }
	}
    }
    return $result;
}

sub GetExpires($)
{
    my ($node) = @_;
    return GetFirstText($node, "valid_until", "expires");
}

sub SetExpires($$)
{
    my ($node, $arg) = @_;
    if (IsVersion0($node)) {
	SetText("valid_until", $node, $arg);
    } else {
	SetText("expires", $node, $arg);
    }
}

sub GetBandwidth($)
{
    my ($link) = @_;
    my $result = undef;
    if (IsVersion0($link)) {
	$result = GeniXML::GetText("bandwidth", $link);
    } else {
	my $prop = FindFirst("n:property", $link);
	if (defined($prop)) {
	    $result = GeniXML::GetText("capacity", $prop);
	}
    }
    return $result;
}

sub GetIp($$)
{
    my ($ifaceref, $node) = @_;
    my $result = undef;
    if (IsVersion0($ifaceref)) {
	$result = GetText("tunnel_ip", $ifaceref);
    } else {
	my $id = GetInterfaceId($ifaceref);
	my @ifaces = FindNodes("n:interface", $node)->get_nodelist();
	foreach my $iface (@ifaces) {
	    my $testid = GetInterfaceId($iface);
	    if (defined($id) && defined($testid) && $testid eq $id) {
		my $ip = FindFirst("n:ip", $iface);
		if (defined($ip)) {
		    $result = GetText("address", $ip);
		}
		last;
	    }
	}
    }
    return $result;
}

# Returns the vnode id in the emulab extension or failing that the component_id
sub GetVnodeId($)
{
    my ($node) = @_;
    my $result = undef;
    if (IsVersion0($node)) {
	$result = GetNodeId($node);
    } else {
	my $vnoderef = GeniXML::FindNodesNS("vnode", $node,
					    $EMULAB_NS)->pop();
	if (defined($vnoderef)) {
	    $result = GetText("name", $vnoderef);
	}
	if (! defined($result)) {
	    $result = GetNodeId($node);
	}
    }
    return $result;
}

# Returns the uuid or urn of an RSpec node or undef if it is not a node.
sub GetNodeId($)
{
    my ($node) = @_;
    my $result = GetFirstText($node, "component_urn", "component_id",
			      "component_uuid", "uuid");
    if (defined($result) && $result eq "") {
	$result = undef;
    }
    return $result;
}

sub GetVirtualId($)
{
    my ($node) = @_;
    return GetFirstText($node, "virtual_id", "nickname", "client_id");
}

sub GetInterfaceId($)
{
    my ($node) = @_;
    return GetFirstText($node, "virtual_interface_id", "iface_name",
			"client_id", "virtual_port_id", "virtual_id");
}

sub GetInterfaceNodeId($)
{
    my ($node) = @_;
    return GetFirstText($node, "virtual_node_id", "node_nickname");
}

sub GetSliverId($)
{
    my ($node) = @_;
    return GetFirstText($node, "sliver_urn", "sliver_id");
}

sub GetManagerId($)
{
    my ($node) = @_;
    my $result = GetFirstText($node, "component_manager_urn",
			      "component_manager_id",
			      "component_manager_uuid");
    if (defined($result) && $result eq "") {
	$result = undef;
    }
    return $result;
}

sub GetColocate($)
{
    my ($node) = @_;
    my $result = GetFirstText($node, "colocate", "phys_nickname");
    return $result;
}

sub GetSubnodeOf($)
{
    my ($node) = @_;
    my $result = undef;
    if (IsVersion0($node)) {
	$result = GetText("subnode_of", $node);
    } else {
	my @relations = FindNodes("n:relation", $node)->get_nodelist();
	foreach my $current (@relations) {
	    if (GetText("type", $current) == "subnode_of") {
		$result = GetText("client_id", $current);
		last;
	    }
	}
    }
    return $result;
}

sub GetStartupCommand($)
{
    my ($node) = @_;
    my $result = undef;
    if (IsVersion0($node)) {
        $result = GetText("startup_command", $node);
    } else {
	my $execute = FindFirst("n:services/n:execute", $node);
	if (defined($execute)) {
	    $result = GetText("command", $execute);
	}
    }
    return $result;
}

sub GetTarball($)
{
    my ($node) = @_;
    my $result = undef;
    if (IsVersion0($node)) {
        $result = GetText("tarfiles", $node);
    } else {
	$result = "";
	my @tarlist = FindNodes("n:services/n:install",
				$node)->get_nodelist();
	foreach my $current (@tarlist) {
	    my $url = GetText("url", $current);
	    my $install = GetText("install_path", $current);
	    if (defined($url) && defined($install)) {
		# TODO: Make sure url/install don't have semicolons or spaces
		# TODO: Flag an error if either one is not defined
		if ($result ne "") {
		    $result .= ";";
		}
		$result .= $install . " " . $url;
	    }
	}
	if (defined($result) && $result eq "") {
	    $result = undef;
	}
    }
    return $result;
}

sub GetVirtualizationType($)
{
    my ($node) = @_;
    my $result = "emulab-vnode";
    if (IsVersion0($node)) {
	$result = GetText("virtualization_type", $node);
    }
    return $result;
}

sub SetVirtualizationSubtype($$)
{
    my ($node, $arg) = @_;
    my $result = 1;
    if (IsVersion0($node)) {
	$result = SetText("virtualization_subtype", $node, $arg);
    } else {
	my $type = FindFirst("n:sliver_type", $node);
	if (! defined($type)) {
	    $type = AddElement("sliver_type", $node);
	}
	SetText("name", $type, $arg);
    }
    return $result;
}

sub GetVirtualizationSubtype($)
{
    my ($node) = @_;
    my $result = undef;
    if (IsVersion0($node)) {
	$result = GetText("virtualization_subtype", $node);
    } else {
	my $type = FindFirst("n:sliver_type", $node);
	if (defined($type)) {
	    $result = GetText("name", $type);
	}
    }
    return $result;
}

sub GetExclusive($)
{
    my ($node) = @_;
    my $exclusive = GetText("exclusive", $node);
    my $result = $exclusive;
    if (defined($exclusive) && ! IsVersion0($node)) {
	$result = ($exclusive eq "true");
    }
    return $result;
}

sub SetExclusive($$)
{
    my ($node, $arg) = @_;
    my $result = 1;
    if (IsVersion0($node)) {
	$result = SetText("exclusive", $node, $arg);
    } else {
	my $textArg = "false";
	if ($arg) {
	    $textArg = "true";
	}
	$result = SetText("exclusive", $node, $textArg);
    }
    return $result;
}

sub GetLinkManager($)
{
    my ($link) = @_;
    return GetFirstText($link, "id", "name");
}

# Takes an attribute/element name, *NOT AN XPATH* and a node and sets
# the text of that node to a particular value. If the node is an
# attribute, the value is set. If it is an element with just a text
# node child, that node is replaced.
# Returns 1 on success and 0 on failure.
sub SetText($$$)
{
    my ($name, $node, $text) = @_;
    my $result = 0;
    my $child = FindFirst('@n:'.$name, $node);
    if (! defined($child)) {
	$child = FindFirst('@'.$name, $node);
    }
    if (defined($child)) {
	if ($child->nodeType() == XML_ATTRIBUTE_NODE) {
	    $child->setValue($text);
	    $result = 1;
	}
    } else {
	$child = FindFirst('n:'.$name, $node);
	if (defined($child)) {
	    my @grand = $child->childNodes();
	    if (scalar(@grand) == 1
		&& $grand[0]->nodeType() == XML_TEXT_NODE) {
		$grand[0]->setData($text);
		$result = 1;
	    } elsif (scalar(@grand) == 0
		     && $child->nodeType() == XML_ELEMENT_NODE) {
		$child->appendText($text);
		$result = 1;
	    }
	} elsif ($node->nodeType() == XML_ELEMENT_NODE) {
	    my $ns = $node->namespaceURI();
	    if (defined($ns)) {
# TODO: Submit bug report for the library. This call is bugged.
#		$node->setAttributeNS($ns, "rs:$name", $text);
		$node->setAttribute($name, $text);
	    } else {
		$node->setAttribute($name, $text);
	    }
	    $result = 1;
	}
    }
    return $result;
}

# Get the text contents of a child of a node with a particular
# name. This can be either an attribute or an element.
sub GetText($$)
{
    my ($name, $node) = @_;
    my $result = undef;
    my $child = FindFirst('@n:'.$name, $node);
    if (! defined($child)) {
	$child = FindFirst('@'.$name, $node);
    }
    if (! defined($child)) {
	$child = FindFirst('n:'.$name, $node);
    }
    if (defined($child)) {
	$result = $child->textContent();
    }
    return $result;
}

# Run GetText serially using the initial argument as an XML node
# reference and the remaining arguments as names and return the first
# defined result. Returns undefined if there are no names or if all
# GetText calls return undefined.
sub GetFirstText($@)
{
    my $node = shift(@_);
    my $result = undef;
    foreach my $name (@_) {
	$result = GetText($name, $node);
	if (defined($result)) {
	    last;
	}
    }
    return $result;
}

# Converts the XML representation of a node to a UTF-8 string and
# outputs it as a complete XML document.
sub Serialize($;$)
{
    my ($node, $format) = @_;
    $format = 0 if (!defined($format));
    my $newnode = $node->cloneNode(1);
    return $newnode->toString($format);
}

# Create a new XML document with a given namespace URI and document
# element name.
sub CreateDocument($$)
{
    my ($ns, $name) = @_;
    my $doc = XML::LibXML::Document->createDocument("1.0", "UTF-8");
    my $root = $doc->createElementNS($ns, "rs:$name");
    $doc->setDocumentElement($root);
    return $doc;
}

# Add a new element to a node. The new element will have the given
# name and be otherwise empty.
sub AddElement($$;$)
{
    my ($name, $node, $namespace) = @_;
    my $ns = $namespace;
    if (! defined($namespace)) {
	$ns = $node->namespaceURI();
    }
    my $child = $node->addNewChild($ns, "rs:$name");
    return $child;
}

# Remove a node with a given name from a node. It will be removed
# whether it is an attribute or an element. The name is not an xpath.
sub RemoveChild($$)
{
    my ($name, $node) = @_;
    my $child = FindFirst('@n:'.$name, $node);
    if (! defined($child)) {
	$child = FindFirst('n:'.$name, $node);
    }
    if (defined($child)) {
	$node->removeChild($child);
    }
}

# Replaces a node (oldnode) with a copy of another node (newnode)
sub ReplaceNode($$)
{
    my ($oldnode, $newnode) = @_;
    my $copy = $newnode->cloneNode(1);
    $oldnode->replaceNode($copy);
    return $copy;
}

# checks for the existense of policy in extensions of the given
# credential.
sub PolicyExists($$)
{
    my ($policy, $credential) = @_;
    my $exists = 0;

    return 0
        if (!ref($credential) or !defined($policy));
    my $extensions_elem = $credential->extensions();
    return 0
        if (!defined($extensions_elem));
    my $policies = GeniXML::FindNodesNS("//n:policy_exceptions/*",
          $extensions_elem, $GeniUtil::EXTENSIONS_NS);
    foreach my $epolicy ($policies->get_nodelist) {
        if ($policy eq $epolicy->string_value) {
            $exists = 1;
            last;
        }      
    }       
  
    return $exists;
}

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