package NSDL::Request;

# Copyright 2005 Norman Walsh. This work is licensed under a
# Creative Commons License: http://creativecommons.org/licenses/by-nc/2.0/

use XML::LibXML;
use XML::LibXML::XPathContext;
use IO::Scalar;
use NSDL::Response;
use NSDL::UA;

sub new {
    my $type = shift;
    my $self = {};
    $self->{'methods'} = {};
    $self->{'parser'} = XML::LibXML->new();
    $self->{'credentials'} = undef;
    return bless $self, $type;
}

sub auth {
    my $self = shift;
    my $userid = shift;
    my $passwd = shift;

    $self->{'credentials'} = [ $userid, $passwd ];
}

sub load {
    my $self = shift;
    my $nsdl = shift;
    my $types = "";

    my $nsdlns = 'http://nwalsh.com/xmlns/nsdl#';
    my $rngns = 'http://relaxng.org/ns/structure/1.0';

    my $xmldoc = $self->{'parser'}->parse_file($nsdl);
    my $doc = XML::LibXML::XPathContext->new($xmldoc);
    $doc->registerNs('nsdl', $nsdlns);
    $doc->registerNs('rng', $rngns);

    # find the real root
    my $root = $xmldoc->getFirstChild();
    while ($root && $root->nodeType() != XML_ELEMENT_NODE) {
	$root = $root->getNextSibling();
    }

    # find the RELAX NG types
    my @nodes = $doc->findnodes("nsdl:types", $root);
    if (@nodes) {
	# Make sure we get the right namespaces in context...
	my %nsdecl = ();
	my %nscontext = $self->findNsContext($nodes[0]);
	foreach my $prefix (keys %nscontext) {
	    my $ncprefix = $prefix;
	    chop $ncprefix;
	    my $decl = "xmlns:$ncprefix";
	    $decl = "xmlns" if $ncprefix eq '';
	    $nsdecl{$decl} = $nscontext{$prefix};
	}

	my $divprefix = "rng";
	while (exists $nsdecl{"xmlns:$divprefix"}) {
	    $divprefix .= "_";
	}

	$types = "<$divprefix:div xmlns:$divprefix='$rngns'";
	foreach my $decl (keys %nsdecl) {
	    $types .= "\n\t$decl='" . $nsdecl{$decl} . "'";
	}
	$types .= ">\n";

	@nodes = $doc->findnodes("rng:*", $nodes[0]);
	foreach my $node (@nodes) {
	    $types .= $node->toString();
	}

	$types .= "</$divprefix:div>";
    }

    # now process all the services
    @nodes = $doc->findnodes("nsdl:service", $root);
    foreach my $svc (@nodes) {
	my $name = $svc->getAttribute('name');
	my $action = $svc->getAttribute('action');
	my $uri = $svc->getAttribute('uri');

	my @reqargs = ();
	my @optargs = ();

	my ($reqnode) = $doc->findnodes("nsdl:request", $svc);
	my @params = $doc->findnodes("nsdl:parameter", $reqnode);
	foreach my $param (@params) {
	    my $name = $param->getAttribute('name');
	    my $type = $param->getAttribute('type');
	    my $def = $param->getAttribute('default');
	    my $opt = $param->getAttribute('optional') || "no";

	    if ($opt eq 'yes') {
		push (@optargs, $name, $type, $def);
	    } else {
		push (@reqargs, $name, $type, $def);
	    }
	}

	my ($body) = $doc->findnodes("nsdl:body/*", $reqnode);

	my $schema = "";
	my $SH = new IO::Scalar \$schema;
	print $SH "<grammar xmlns='$rngns'\n\tdatatypeLibrary=";
	print $SH "'http://www.w3.org/2001/XMLSchema-datatypes'>\n";
	print $SH "<start><ref name='parameters'/></start>\n";
	print $SH "$types\n\n";
	print $SH "<define name='parameters'>\n";
	print $SH "  <element name='parameters'>\n";
	for (my $count = 0; $count < $#reqargs; $count += 3) {
	    print $SH "    <ref name='", $reqargs[$count], "'/>\n";
	}
	for (my $count = 0; $count < $#optargs; $count += 3) {
	    print $SH "    <optional>\n";
	    print $SH "      <ref name='", $optargs[$count], "'/>\n";
	    print $SH "    </optional>\n";
	}
	print $SH "  </element>\n";
	print $SH "</define>\n\n";

	my @args = (@reqargs, @optargs);
	while (@args) {
	    my $name = shift @args;
	    my $type = shift @args;
	    my $def  = shift @args;
	    print $SH "<define name='$name'>\n";
	    print $SH "  <element name='$name'>\n";

	    if ($type =~ /^xsd:(.*)/) {
		print $SH "    <data type='$1'/>\n";
	    } elsif ($type eq 'text') {
		print $SH "    <text/>\n";
	    } else {
		print $SH "    <ref name='$type'/>\n";
	    }
	    print $SH "  </element>\n";
	    print $SH "</define>\n\n";
	}

	print $SH "</grammar>\n";

	my %faults = ();
	my ($respnode) = $doc->findnodes("nsdl:response", $svc);
	my @faultnodes = $doc->findnodes("nsdl:fault", $respnode);
	foreach my $fault (@faultnodes) {
	    my %nsdecl = $self->findNsContext($fault);
	    my $name = $fault->getAttribute('name');
	    my $select = $fault->getAttribute('select');
	    $faults{$name} = { 'select' => $select,
			       'nsdecl' => \%nsdecl };
	}

	my @results = ();
	my @resultnodes = $doc->findnodes("nsdl:result", $respnode);
	foreach my $result (@resultnodes) {
	    my %nsdecl = $self->findNsContext($result);
	    my $select = $result->getAttribute('select');
	    my $name = $result->getAttribute('name');

	    if ($#resultnodes > 0 && !defined($name)) {
		die "All results must be named if there are multiple\n";
	    }

	    my %reshash = ( 'name' => $name,
			    'select' => $select,
			    'nsdecl' => \%nsdecl );

	    push (@results, \%reshash);
	}


	$self->{'methods'}->{$name} = { 'uri' => $uri,
					'action' => $action,
					'schema' => $schema,
					'faults' => \%faults,
					'results' => \@results };

	$self->{'methods'}->{$name}->{'body'} = $body
	    if $body && $action eq 'post';

	$self->addMethod(\@reqargs, \@optargs, $name);
    }
}

sub findNsContext {
    my $self = shift;
    my $node = shift;

    my %nsmap = ();

    while ($node) {
	my @nslist = $node->getNamespaces();
	foreach my $ns (@nslist) {
	    my $prefix = $ns->getLocalName();
	    my $uri = $ns->getData();

	    $prefix = "" if ! defined $prefix;

	    if (!exists($nsmap{"$prefix:"})) {
		$nsmap{"$prefix:"} = $uri;
	    }
	}
	$node = $node->parentNode();
    }

    return %nsmap;
}


sub addMethod {
    my $self = shift;
    my $reqargs = shift;
    my $optargs = shift;
    my $subname = shift;

    no strict 'refs';

    my @reqargs = @{$reqargs};
    my @optargs = @{$optargs};

    *$subname = sub {
	my $self = shift;
	my %param = ();
	my $args = $self->check_args($subname, \@reqargs, \@optargs, @_);
	if (!ref $args) {
	    print "Failed: $args\n";
	    die;
	} else {
	    %param = %{$args};
	    $self->invoke($subname, %param);
	}
    };
}

sub check_args {
    my $self = shift;
    my $name = shift;
    my $reqargs = shift;
    my $optargs = shift;
    my @reqarg = ();
    my @optarg = ();
    my %params = ();

    @reqarg = @{$reqargs} if defined($reqargs);
    @optarg = @{$optargs} if defined($optargs);

    my $schema = $self->{'methods'}->{$name}->{'schema'};
    my $document = "";
    my $SH = new IO::Scalar \$document;
    print $SH "<parameters>\n";

    my $argnum = 0;
    for (my $count = 0; $count < $#reqarg; $count += 3) {
	my $arg = $reqarg[$count+2];
	$arg = $_[$argnum] if $argnum <= $#_;
	return "too few args" if !defined($arg);
	my $name = $reqarg[$count];
	print $SH "<$name>$arg</$name>\n";
	$params{$name} = $arg;
	$argnum++;
    }

    my $count = 0;
    while ($argnum <= $#_) {
	return "too many args" if !defined($optarg[$count]);
	my $arg = $optarg[$count+2];
	$arg = $_[$argnum] if $argnum <= $#_;
	my $name = $optarg[$count];
	print $SH "<$name>$arg</$name>\n";
	$params{$name} = $arg;
	$count += 2;
	$argnum++;
    }

    print $SH "</parameters>\n";

    open (F, ">/tmp/p-schema.rng"); print F $schema; close (F);
    open (F, ">/tmp/p-schema.xml"); print F $document; close (F);

    $schema = XML::LibXML::RelaxNG->new( 'string' => $schema);

    my $xmldoc = $self->{'parser'}->parse_string($document);

    eval { $schema->validate( $xmldoc ); };
    return $@ if $@ ne '';

    return \%params;
}

sub invoke {
    my $self = shift;
    my $name = shift;
    my %param = @_;
    my $results = undef;

    my $action = $self->{'methods'}->{$name}->{'action'};

    if ($action eq 'get') {
	my $requri = $self->{'methods'}->{$name}->{'uri'};
	my $sep = "";
	foreach my $p (sort keys %param) {
	    $requri .= $sep;
	    $requri .= "$p=";
	    $requri .= $param{$p};
	    $sep = "&";
	}

	my $response = $self->{'methods'}->{$name}->{'response'};
	$results = $self->get($requri, $name, $userid, $password);
    } elsif ($action eq 'post') {
	my $requri = $self->{'methods'}->{$name}->{'uri'};
	my $body = $self->{'methods'}->{$name}->{'body'};
	my $bodytext = $self->expand($body, %param);

	$results = $self->post($requri, $bodytext, $name, $userid, $password);
    } else {
	die "Don't know how to do $action for $name!\n";
    }

    if (ref $results eq 'ARRAY') {
	my @values = @{$results};
	my $results = new NSDL::Response($self->{'content'});
	foreach my $reshash (@{$self->{'methods'}->{$name}->{'results'}}) {
	    my $name = $reshash->{'name'};
	    my $value = shift @values;
	    $name = "" if !defined($name);
	    $results->addValue($name, $value);
	}
	return $results;
    } else {
	die "$results\n";
    }
}

sub expand {
    my $self = shift;
    my $node = shift;
    my %param = @_;
    my $result = "";

    if ($node->nodeType() == XML_ELEMENT_NODE) {
	$result .=  "<" . $node->tagName();
	my $attrs = $node->attributes();
	for (my $count = 0; $count < $attrs->length(); $count++) {
	    my $attr = $attrs->item($count);

	    if (ref $attr eq 'XML::LibXML::Namespace') {
		my $prefix = $attr->name();
		my $aname = "xmlns";
		$aname = "xmlns:$prefix" if defined($prefix);
		my $value = $self->subst($attr->value(), %param);
		$result .= " $aname='$value'";
	    } else {
		my $name = $attr->name();
		my $value = $self->subst($attr->value(), %param);
		$result .= " $name='$value'";
	    }
	}
	my $child = $node->getFirstChild();
	if ($child) {
	    $result .= ">";
	    while ($child) {
		$result .= $self->expand($child, %param);
		$child = $child->getNextSibling();
	    }
	    $result .= "</" . $node->tagName() . ">";
	} else {
	    $result .= "/>";
	}
    } elsif ($node->nodeType() == XML_TEXT_NODE) {
	$result .= $self->subst($node->getData(), %param);
    } elsif ($node->nodeType() == XML_PI_NODE) {
	my $value = $self->subst($node->getData(), %param);
	$result .= "<?" . $node->nodeName();
	$result .= " $value" if $value ne '';
	$result .= "?>";
    } elsif ($node->nodeType() == XML_COMMENT_NODE) {
	$result .= "<!--" . $self->subst($node->data(), %param) . "-->";
    } else {
	die "Unexpected node type!?\n";
    }
}

sub subst {
    my $self = shift;
    local $_ = shift;
    my %param = @_;
    my $data = "";

    while (/\{\$(\S+)\}/) {
	$data .= $main::PREMATCH;
	my $name = $1;
	$_ = $main::POSTMATCH;
	$data .= $param{$name} if exists $param{$name};
    }

    return $data . $_;
}

sub get {
    my $self = shift;
    my $requri = shift;
    my $name = shift;

    my $ua = NSDL::UA->new();
    $ua->agent("NSDL Dispatcher/0.1");
    $ua->env_proxy;

    # setup credentials
    $ua->credentials(@{$self->{'credentials'}})
	if defined $self->{'credentials'};

    # Create a request
    my $req = HTTP::Request->new('GET' => $requri);

    # Pass request to the user agent and get a response back
    my $res = $ua->request($req);

    # Check the outcome of the response
    if ($res->is_success()) {
	# FIXME: Danger Will Robinson, this is not thread safe!
	$self->{'content'} = $res->content();
	return $self->reply($res->content(), $name);
    } else {
	return "GET failed: " . $res->status_line();
    }
}

sub post {
    my $self = shift;
    my $requri = shift;
    my $bodytext = shift;
    my $name = shift;
    my $userid = shift;
    my $password = shift;

    open (F, "/tmp/out");
    read (F, $_, -s "/tmp/out");
    close (F);

    return $self->reply($_, $name);

    my $ua = NSDL::UA->new();
    $ua->agent("NSDL Dispatcher/0.1");
    $ua->env_proxy;

    # setup credentials
    $ua->credentials(@{$self->{'credentials'}})
	if defined $self->{'credentials'};

    my $res = $ua->request(POST $requri,
			   Content_Type => 'text/xml',
			   Content => $bodytext);

    # Check the outcome of the response
    if ($res->is_success()) {
	# FIXME: Danger Will Robinson, this is not thread safe!
	$self->{'content'} = $res->content();
	return $self->reply($res->content(), $name);
    } else {
	return "POST failed: " . $res->status_line();
    }
}

sub reply {
    my $self = shift;
    my $content = shift;
    my $name = shift;
    my $msgdoc = $self->{'parser'}->parse_string($content);

    #open (F, ">/tmp/out");
    #print F $msgdoc->toString();
    #close (F);

    my %faults = %{$self->{'methods'}->{$name}->{'faults'}};

    foreach my $name (keys %faults) {
	my $select = $faults{$name}->{'select'};
	my %nsdecl = %{$faults{$name}->{'nsdecl'}};
	my $doc = XML::LibXML::XPathContext->new($msgdoc);
	foreach my $prefix (keys %nsdecl) {
	    my $ncprefix = $prefix;
	    chop $ncprefix;
	    $doc->registerNs($ncprefix, $nsdecl{$prefix});
	}

	my @nodes = $doc->findnodes($select);
	if (@nodes) {
	    return $name;
	}
    }

    my @results = ();
    foreach my $reshash (@{$self->{'methods'}->{$name}->{'results'}}) {
	my $name   = $reshash->{'name'};
	my $select = $reshash->{'select'};
	my %nsdecl = %{$reshash->{'nsdecl'}};
	my $doc = XML::LibXML::XPathContext->new($msgdoc);
	foreach my $prefix (keys %nsdecl) {
	    my $ncprefix = $prefix;
	    chop $ncprefix;
	    $doc->registerNs($ncprefix, $nsdecl{$prefix});
	}

	my @res = $doc->findnodes($select);
	my @val = ();
	foreach my $node (@res) {
	    push (@val, $self->string_value($node));
	}

	if (@val) {
	    if ($#val > 0) {
		push (@results, \@val);
	    } else {
		push (@results, $val[0]);
	    }
	} else {
	    push (@results, '');
	}
    }

    return \@results;
}

sub string_value {
    my $self = shift;
    my $node = shift;
    my $result = "";

    if ($node->nodeType == XML_ELEMENT_NODE) {
	my $child = $node->getFirstChild();
	while ($child) {
	    $result .= $self->string_value($child);
	    $child = $child->getNextSibling();
	}
    } elsif ($node->nodeType == XML_TEXT_NODE) {
	$result .= $node->getData();
    } elsif ($node->nodeType == XML_ATTRIBUTE_NODE) {
	$result .= $node->value();
    } else {
	# nop;
    }

    return $result;
}

1;