use Frontier::RPC2;

use FIG;

use strict;


package FrontierXMLRPCWrapper;

#
# We'll make a class to hold the fig instance and the
# XMLRPC server instance; this will make it easier to invoke the
# wrapping functions (since each one will need these values).
#


#
# Constructor.
#
sub new
{
    my($class, $fig, $xmlrpc) = @_;

    my $self = {
	fig => $fig,
	xmlrpc => $xmlrpc,
    };

    return bless $self, $class;
}


#
# Return a value properly coerced to a string for passing
# as an XMLRPC return. Use the string() method on the
# xmlrpc instance variable.
#
sub coerce_to_string
{
    my($self, $value) = @_;

    return $self->{xmlrpc}->string($value);
}

#
# Wrap a FIG method that returns a scalar.
#

sub wrap_scalar_return
{
    my($self, $func) = @_;

    #
    # We return a new anonymous subroutine that invokes the
    # routine thru the $fig instance saved in our instance variables.
    #

    return sub {
	my $ret;

	$ret = $self->{fig}->$func(@_);

	#
	# Coerce to string if we need to.
	#
	
	if (!ref($ret))
	{
	    $ret = $self->coerce_to_string($ret);
	}
	
	return $ret;
    }
}

#
# Wrap a FIG method that returns a list. The list needs to be
# converted into a list reference instead of a plain list.
#

sub wrap_array_return
{
    my($self, $func) = @_;

    #
    # We return a new anonymous subroutine that invokes the
    # routine thru the $fig instance saved in our instance variables.
    #

    return sub {
	my $ret;
	my @func_ret;

	$ret = [];

	#
	# Invoke the function.
	#
	@func_ret = $self->{fig}->$func(@_);

	#
	# For each value returned, if it isn't a reference (to a list, for instance),
	# coerce it to a string.
	#
	# Push each value to the list we're creating.
	#
	for $_ (@func_ret)
	{
	    if (ref($_))
	    {
		push(@$ret, $_);
	    }
	    else
	    {
		push(@$ret, $self->coerce_to_string($_));
	    }
	}
	return $ret;
    }
}

#
# back in the main package, finished with class definition.
#

package main;

$| = 1;  # Perl magic to use unbuffered output on standard output

my $xml_rpc_server = Frontier::RPC2->new;

my $fig = new FIG;

#
# Create a wrapper-helper object.
#

my $wrapper = new FrontierXMLRPCWrapper($fig, $xml_rpc_server);

#
# Create a list of the methods to be served
#

my $methods = {
    'abbrev' => $wrapper->wrap_scalar_return("abbrev"),
    'add_chromosomal_clusters' => $wrapper->wrap_scalar_return("add_chromosomal_clusters"),
    'add_genome' => $wrapper->wrap_scalar_return("add_genome"),
    'add_pch_pins' => $wrapper->wrap_scalar_return("add_pch_pins"), 
    'all_compounds'   => $wrapper->wrap_array_return("all_compounds"),
    'all_constructs'   => $wrapper->wrap_array_return("all_constructs"),
    'all_exchangable_subsystems'   => $wrapper->wrap_array_return("all_exchangable_subsystems"),
    'all_features'   => $wrapper->wrap_array_return("all_features"),
    'all_for_genome'   => $wrapper->wrap_array_return("all_for_genome"),
    'all_maps'   => $wrapper->wrap_array_return("all_maps"),
    'all_protein_families'   => $wrapper->wrap_array_return("all_protein_families"),
    'all_reactions'   => $wrapper->wrap_array_return("all_reactions"),
    'all_roles'   => $wrapper->wrap_array_return("all_roles"),
    'all_sets'   => $wrapper->wrap_array_return("all_sets"),
    'all_subsystems'   => $wrapper->wrap_array_return("all_subsystems"),
    'assign_function' => $wrapper->wrap_scalar_return("assign_function"), 
    'assign_functionF' => $wrapper->wrap_scalar_return("assign_functionF"),
    'assignments_made'   => $wrapper->wrap_array_return("assignments_made"),
    'auto_assign' => $wrapper->wrap_scalar_return("auto_assign"),
    'auto_assignF' => $wrapper->wrap_scalar_return("auto_assignF"),
    'auto_assignG' => $wrapper->wrap_scalar_return("auto_assignG"),
    'between'   => $wrapper->wrap_scalar_return("between"),
    'blast'   => $wrapper->wrap_array_return("blast"),
    'blastit'   => $wrapper->wrap_array_return("blastit"),
    'boundaries_of' => $wrapper->wrap_scalar_return("boundaries_of"),
    'build_tree_of_complete' => $wrapper->wrap_array_return("build_tree_of_complete"),
    'by_alias'   => $wrapper->wrap_scalar_return("by_alias"),
    'by_fig_id'   => $wrapper->wrap_scalar_return("by_fig_id"),
    'cas'   => $wrapper->wrap_scalar_return("cas"),
    'cas_to_cid'   => $wrapper->wrap_scalar_return("cas_to_cid"),
    'catalyzed_by'   => $wrapper->wrap_array_return("catalyzed_by"),
    'catalyzes'   => $wrapper->wrap_array_return("catalyzes"),
    'cgi_url'   => $wrapper->wrap_scalar_return("cgi_url"),
    'clean_tmp' => $wrapper->wrap_scalar_return("clean_tmp"),
    'close_genes'   => $wrapper->wrap_array_return("close_genes"),
    'comp2react'   => $wrapper->wrap_scalar_return("comp2react"),
    'contig_ln' => $wrapper->wrap_scalar_return("contig_ln"),
    'coupling_and_evidence'   => $wrapper->wrap_array_return("coupling_and_evidence"),
    'crude_estimate_of_distance'   => $wrapper->wrap_scalar_return("crude_estimate_of_distance"),
    'delete_genomes' => $wrapper->wrap_scalar_return("delete_genomes"),
    'displayable_reaction' => $wrapper->wrap_scalar_return("displayable_reaction"),
    'dna_seq'   => $wrapper->wrap_scalar_return("dna_seq"),
    'dsims'   => $wrapper->wrap_array_return("dsims"),
    'ec_to_maps'   => $wrapper->wrap_array_return("ec_to_maps"),
    'ec_name'   => $wrapper->wrap_scalar_return("ec_name"),
    'expand_ec'   => $wrapper->wrap_scalar_return("expand_ec"),
    'epoch_to_readable'   => $wrapper->wrap_scalar_return("epoch_to_readable"),
    'export_chromosomal_clusters' => $wrapper->wrap_scalar_return("export_chromosomal_clusters"), 
    'export_pch_pins' => $wrapper->wrap_scalar_return("export_pch_pins"),
    'export_set' => $wrapper->wrap_scalar_return("export_set"),
    'exportable_subsystem'   => $wrapper->wrap_scalar_return("exportable_subsystem"),
    'extract_seq'   => $wrapper->wrap_scalar_return("extract_seq"),
    'family_function'   => $wrapper->wrap_scalar_return("family_function"),
    'fast_coupling'   => $wrapper->wrap_array_return("fast_coupling"),
    'feature_aliases'   => $wrapper->wrap_array_return("feature_aliases"),
    'feature_annotations'   => $wrapper->wrap_array_return("feature_annotations"),
    'feature_location'   => $wrapper->wrap_scalar_return("feature_location"),
    'file2N'   => $wrapper->wrap_scalar_return("file_2N"),
    'ftype'   => $wrapper->wrap_scalar_return("ftype"),
    'function_of'   => $wrapper->wrap_scalar_return("function_of"),   
    'genes_in_region'   => $wrapper->wrap_array_return("genes_in_region"),
    'genome_of'   => $wrapper->wrap_scalar_return("genome_of"),
    'genomes'   => $wrapper->wrap_array_return("genomes"),
    'genome_counts'   => $wrapper->wrap_scalar_return("genome_counts"),
    'genome_version'   => $wrapper->wrap_scalar_return("genome_version"),
    'genus_species'   => $wrapper->wrap_scalar_return("genus_species"),
    'get_translation'   => $wrapper->wrap_scalar_return("get_translation"),
    'get_translations'   => $wrapper->wrap_array_return("get_translations"),
    'hypo'   => $wrapper->wrap_scalar_return("hypo"),
    'ids_in_family' => $wrapper->wrap_array_return("ids_in_family"),
    'ids_in_set' => $wrapper->wrap_array_return("ids_in_set"),
    'in_cluster_with'   => $wrapper->wrap_array_return("in_cluster_with"),
    'in_family'   => $wrapper->wrap_scalar_return("in_family"),
    'in_pch_pin_with'   => $wrapper->wrap_array_return("in_pch_pin_with"),
    'in_sets' => $wrapper->wrap_array_return("in_sets"),
    'is_archaeal'   => $wrapper->wrap_scalar_return("is_archaeal"),
    'is_bacterial'   => $wrapper->wrap_scalar_return("is_bacterial"),
    'is_eukaryotic'   => $wrapper->wrap_scalar_return("is_eukaryotic"),
    'is_prokaryotic'   => $wrapper->wrap_scalar_return("is_prokaryotic"),
    'is_exchangable_subsytem'   => $wrapper->wrap_scalar_return("is_exchangable_subsystem"),
    'is_real_feature'   => $wrapper->wrap_scalar_return("is_real_feature"),
    'largest_clusters' => $wrapper->wrap_array_return("largest_clusters"),
    'load_all' => $wrapper->wrap_scalar_return("load_all"),
    'map_to_ecs'   => $wrapper->wrap_array_return("map_to_ecs"),
    'map_name'   => $wrapper->wrap_scalar_return("map_name"),
    'mapped_prot_ids'   => $wrapper->wrap_array_return("mapped_prot_ids"),
    'maps_to_id'   => $wrapper->wrap_array_return("maps_to_id"),
    'max'   => $wrapper->wrap_scalar_return("max"),
    'merged_related_annotations'   => $wrapper->wrap_scalar_return("merged_related_annotations"),
    'min'   => $wrapper->wrap_scalar_return("min"),
    'names_of_compound'   => $wrapper->wrap_array_return("names_of_compund"),
    'neighborhood_of_role'   => $wrapper->wrap_scalar_return("neighborhood_of_role"),
    'org_of'   => $wrapper->wrap_scalar_return("org_of"),
    'pegs_not_in_ss'   => $wrapper->wrap_array_return("pegs_not_in_ss"), 
    'pegs_of'   => $wrapper->wrap_array_return("pegs_of"), 
    'possibly_truncated'   => $wrapper->wrap_scalar_return("possibly_truncated"),
    'reaction2comp'   => $wrapper->wrap_scalar_return("reaction2comp"),
    'related_by_func_sim'   => $wrapper->wrap_array_return("related_by_func_sim"),
    'reversible'   => $wrapper->wrap_scalar_return("reversible"),
    'rnas_of'   => $wrapper->wrap_array_return("rnas_of"),
    'roles_of_function'   => $wrapper->wrap_array_return("roles_of_function"),
    'search_index'   => $wrapper->wrap_array_return("search_index"),
    'seqs_with_role'   => $wrapper->wrap_array_return("seqs_with_role"),
    'seqs_with_roles_in_genome'   => $wrapper->wrap_scalar_return("seqs_with_roles_in_genomes"), 
    'sims'   => $wrapper->wrap_array_return("sims"),
    'sort_fids_by_taxonomy'   => $wrapper->wrap_array_return("sort_fids_by_taxonomy"),
    'sort_genomes_by_taxonomy'   => $wrapper->wrap_array_return("sort_genomes_by_taxonomy"),
    'subsystem_info' => $wrapper->wrap_array_return("subsystem_info"),
    'subsystems_for_peg' => $wrapper->wrap_array_return("subsystems_for_peg"), 
    'subsystems_for_genome' => $wrapper->wrap_array_return("subsystems_for_genome"), 
    'sz_family'   => $wrapper->wrap_scalar_return("sz_family"),
    'taxonomic_groups_of_complete'   => $wrapper->wrap_array_return("taxonomic_groups_of_complete"),
    'taxonomy_of'   => $wrapper->wrap_scalar_return("taxonomy_of"),
    'translatable'   => $wrapper->wrap_scalar_return("translatable"),
    'translate_function'   => $wrapper->wrap_scalar_return("translate_function"),
    'translated_function_of'   => $wrapper->wrap_scalar_return("translated_function_of"),
    'translation_length'   => $wrapper->wrap_scalar_return("translation_length"), 
    'unique_functions'   => $wrapper->wrap_array_return("unique_functions"),
    'verify_directory'   => $wrapper->wrap_scalar_return("verify_directory"),

};

process_cgi_call($methods);

#==========================================================================
#  CGI Support
#==========================================================================
#  Simple CGI support for Frontier::RPC2. You can copy this into your CGI
#  scripts verbatim, or you can package it into a library.
#  (Based on xmlrpc_cgi.c by Eric Kidd <http://xmlrpc-c.sourceforge.net/>.)

# Process a CGI call.
sub process_cgi_call ($) {
    my ($methods) = @_;

    # Get our CGI request information.
    my $method = $ENV{'REQUEST_METHOD'};
    my $type = $ENV{'CONTENT_TYPE'};
    my $length = $ENV{'CONTENT_LENGTH'};

    # Perform some sanity checks.
    http_error(405, "Method Not Allowed") unless $method eq "POST";
    http_error(400, "Bad Request") unless $type eq "text/xml";
    http_error(411, "Length Required") unless $length > 0;

    # Fetch our body.
    my $body;
    my $count = read STDIN, $body, $length;
    http_error(400, "Bad Request") unless $count == $length; 

    # Serve our request.
    my $coder = Frontier::RPC2->new;
    send_xml($coder->serve($body, $methods));
}

# Send an HTTP error and exit.
sub http_error ($$) {
    my ($code, $message) = @_;
    print <<"EOD";
Status: $code $message
Content-type: text/html

<title>$code $message</title>
<h1>$code $message</h1>
<p>Unexpected error processing XML-RPC request.</p>
EOD
    exit 0;
}

# Send an XML document (but don't exit).
sub send_xml ($) {
    my ($xml_string) = @_;
    my $length = length($xml_string);
    print <<"EOD";
Status: 200 OK
Content-type: text/xml
Content-length: $length

EOD
    # We want precise control over whitespace here.
    print $xml_string;
}