#!/usr/bin/perl -w
use strict;
use lib '/usr/local/apache/cgi-bin/BIO/moby-live/Perl';
use MOBY::Client::Central;
use MOBY::Client::Service;
use MIME::Base64;
use XML::DOM;
use Data::Dumper;
use CGI qw/:standard/;
use vars qw($debug $ERROR_FLAG);
$debug = 0; # change to '1' to get debugging messages in /tmp
if ($debug) {
# refreshes the debugging log
open (OUT, ">/tmp/Client05LogOut.txt")
|| die "cant open logfile\n";
print OUT "Client Initializing\nINC is @INC\n";
close OUT;
}
if (param('start')) {
# user has already started, but needs to turn namespaces and ID's into
# objects before presenting the "results"
&Begin; &Continue;
} elsif (param('continue')) {
# user has objects in hand, and has chosen a service for them.
# Execute the service and present the results
&Execute; &Continue;
} elsif (param('reinitialize')) {
&Initialize;&Begin;&Continue;
} else {
&Initialize;&SendOpeningPage
}
sub Initialize {
# set this to wherever your MOBY Central is. At the moment, it is @
# mobycentral.cbr.nrc.ca
my $Central = MOBY::Client::Central->new();
my (@ValidNamespaces);
my $NameSpaces = $Central->retrieveNamespaces;
while (my ($k, $v) = each %{$NameSpaces}) {
push @ValidNamespaces, $k."~~~".$v; # name and description
}
# _LOG("INITIALIZING");
@ValidNamespaces = sort @ValidNamespaces;
param('ValidNamespaces', @ValidNamespaces);
# _LOG("GOT MOBY CENTRAL DATA @ValidObjects ::: @ValidServices ::: @ValidNamespaces\n");
}
sub SendOpeningPage {
# send out initialization screen... a bit "flat" at the moment, but we can make it pretty later
my ($NameSpaces) = &extractInitializedParams(); # these are the MOBY-Central reported objects, services and namespaces
print header,
start_html(-title => 'A Simple MOBY Client', -bgcolor => "white"),
"<table BGCOLOR='#AAAAFF' width = '100%'><TR><TD><center>",
"<IMG SRC=http://www.biomoby.org/moby1.gif>",
h1('MOBY Client Initialization'),"(sample values have been selected for you for demonstration purposes)</center></TD></TR></table><p>",
start_form,
"<h2>What namespace do you have? ";
my %nslabels = (%{$NameSpaces});
print popup_menu(-name => 'namespace',
'-values' => ["select", (sort (keys %{$NameSpaces}))],
# '-values' => ["select", (keys %{$NameSpaces})],
'-default' => 'GO',
);
print p,
"Which ID(s) within this namespace? (one per line)</h2>",
p,
textarea(-name => 'id', -rows => 10, -cols => 20, -value =>
"GO:0008303
GO:0001662",);
print p,
&InitializeParams,
submit("Initialize with this seed data"),
end_form,
end_html,
hr;
}
sub Begin {
my $ns = param('namespace'); # get the selected namespace
my @Objects;
foreach (split "\n", param('id')) { # take one ID per line
$_ =~ s/^\s//g; # remove spaces
$_ =~ s/\s$//g; # remove spaces
push @Objects, encode_base64(&constructRootObject($ns, $_)); # Construct the objects from namespace & id
# just in case we have weird characters in the namespace, base64 encode it
}
param('CurrentObjects', @Objects); # fill the CurrentObjects CGI parameter; this is always used to hold the list of "current" objects
}
sub setInitializedParams {
# shortcut to write persistence fields into the CGI form.
hidden(-name => 'continue', value => 1),"\n",
}
sub InitializeParams {
hidden(-name => 'ValidNamespaces'),"\n",
hidden(-name => 'start', -value => 1), # set the "start" flag for the next time the script is called
}
sub extractInitializedParams {
# get's the persistence data out of the CGI form input.
# returns hash of {name}="definition" for each of Object, Service and Namespace
my @ValidNamespaces = param('ValidNamespaces');
my (%NameSpaces);
foreach (@ValidNamespaces) {
my ($key, $value) = split "~~~", $_; # the persistent data is in the form name~~~definition. Use Regexp to split them
$NameSpaces{$key} = $value;
}
return (\%NameSpaces);
}
sub constructRootObject {
# used by the "Begin" subroutine to create root objects from
# namespace and ID
my ($ns, $id) = @_;
return "<Object namespace='$ns' id='$id'/>"; # simple XML root object
}
sub writeCurrentObjects {
# takes list of current objects and generates HTML table, including checkbox form elements
# object name and namespace are extracted from XML by regexp
# they are HTML escaped to ensure that they print properly
# **the entire object itself is passed as the checkbox value!! base64 encoded**
# Subroutine returns HTML string to generate this table
my (@Objects) = @_;
my $response;
$response .= "<table border=0 width = '100%' BGCOLOR='#FFCCFF'><TR><TH align='center'>OBJECT</TH><TH align='center'>CONTENTS</TH></TR>";
foreach (@Objects) {
my $b64Obj = encode_base64($_);
my $Parser = new XML::DOM::Parser;
my $doc = $Parser->parse($_);
my $Object = $doc->getDocumentElement();
my $obj = $Object->getTagName;
my $ns = $Object->getAttributeNode("namespace");
next unless $ns;
$ns = $ns->getValue();
my $id = $Object->getAttributeNode("id");
next unless $id;
$id = $id->getValue();
my $name = $Object->getAttributeNode("articleName");
$name &&=($name->getValue());
$name ||="";
_LOG("writeCurrentObjects: $name Object was $obj namespace was $ns id was $id\n");
$obj = escapeHTML($obj); # escape the name, namespace, and object XML
$ns = escapeHTML($ns);
$id = escapeHTML($id);
$name = escapeHTML($name);
$response .= "<tr><td valign='top' align='left' width = '20%'>";
$response .= checkbox(-name => "CurrentObjects",
-value => "$b64Obj", # the actual object, encoded
-label => "$name ($obj) : $ns",
);
$response .="</td>";
my $CRIB = $Object->getElementsByTagName("CrossReference");
# should be only one CRIB per object, so...
my $XrefString = "";
if ($CRIB->item(0)){
$XrefString .="<b>Cross References:</b> ";
my @XrefsXML;
foreach my $child ($CRIB->item(0)->getChildNodes()){
next unless $child->getNodeType == ELEMENT_NODE;
my $ns = $child->getAttributeNode("namespace")->getValue();
my $id = $child->getAttributeNode("id")->getValue();
if (($ENV{HTTP_HOST} =~ /localhost/) || ($ENV{HTTP_HOST} =~ /192\.168\.1\./)){
$XrefString .= "<a href='http://localhost/cgi-bin/MOBY-Client.cgi?namespace=$ns;id=$id;reinitialize=1' target ='new'>$ns : $id</a>, ";
} else {
$XrefString .= "<a href='http://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}?namespace=$ns;id=$id;reinitialize=1' target ='new'>$ns : $id</a>, ";
}
}
$XrefString .="<br>\n";
}
my $OBJ = "";
$OBJ .= "<b>NameSpace: </b>$ns<br>
<b>ID:$id</b><br>";
my $type = &_what_am_i($Object); # returns b64jpeg, b64gif, TEXT
my $alldata;
foreach ($Object->getChildNodes()){ # this is TERRIBLE parsing of a MOBY Object!! It only goes one level deep, but it is sufficient for a prototype client
my $data;
if (($_->getNodeType == TEXT_NODE) || ($_->getNodeType == CDATA_SECTION_NODE)){
$alldata .= $_->toString; # deal with the text content of this node separately from the object content
} elsif ($_->getNodeType == ELEMENT_NODE){
next if ($_->getTagName =~ /CrossReference/);
my $article = $_->getAttributeNode('articleName');
if ($article){
$article = escapeHTML($article->getValue());
} else {
$article = "";
}
$OBJ .= "<b>$article (".escapeHTML($_->getTagName).")</b> : ";
foreach my $content($_->getChildNodes){
$data .= $content->toString if (($content->getNodeTypeName eq "TEXT_NODE") || ($_->getNodeTypeName eq "CDATA_SECTION_NODE"));
}
}
# $OBJ .= "".escapeHTML($Payload->item($_)->toString)."<br>";
$data && ($OBJ .= "$data<br>");
}
if ($alldata){
use MIME::Base64;
use File::Temp qw/ tempfile /;
if ($type =~ /b64/){
$alldata = decode_base64($alldata);
my ($fh, $filename);
($fh, $filename) = tempfile( DIR => "/usr/local/apache/htdocs/tmp", SUFFIX=> ".jpeg" ) if ($type =~ /b64jpeg/);
($fh, $filename) = tempfile( DIR => "/usr/local/apache/htdocs/tmp", SUFFIX=> ".gif" ) if ($type =~ /b64gif/);
binmode $fh;
print $fh $alldata;
close $fh;
$filename =~ s"^/usr/local/apache/htdocs/tmp/"";
$OBJ .="<br><IMG src=http://mobycentral.cbr.nrc.ca/tmp/$filename><br>";
} else {
$OBJ .= "<pre>$alldata</pre><BR>";
}
}
$response .= "<td BGCOLOR = '#CCCCFF' valign='top' align='left'><SMALL>$XrefString$OBJ</SMALL></td></tr>\n"; # HTML escaped XML of the object
}
$response .="</table>";
#_LOG("\n\n************** HTML TABLE WAS ************\n$response\n\n");
return $response;
}
sub Execute {
# EXECUTE SELECTED SERVICE
my $SelectedService = param('SelectedService');
unless ($SelectedService){$ERROR_FLAG = "You didn't select a service to execute"; return};
my ($URI, $name) = (($SelectedService =~ /(.*?)#(.*)/) && ($1, $2));
_LOG("Executing\n");
my $Central = MOBY::Client::Central->new();
my ($SIs, $REG) = $Central->findService( # should only retrieve one service instance
authURI => $URI,
serviceName => $name,
);
die "Retrieval of service $name from $URI failed for unknown reasons\n" if $REG;
my $wsdl = $Central->retrieveService($SIs->[0]); # get the WSDL for the first (only) serviceInstance
$wsdl || die "Failed to Retrieve WSDL for service $name at $URI\n";
_LOG("WSDL\n\n___________________________________________________$wsdl\n_______________________________________");
my @CurrentObjects = &extractCurrentObjects(); # get the object XML list (in human-readable form if possible for logging purposes)
my @CurrentObjectList = map {[undef, $_]} @CurrentObjects; # the format for $Service->execute is (articleName, "<XML...>) so make the mapping. This script ignores article names entirely... too bad!
_LOG("MOBY_REQUEST_INPUT\n\n___________________________________________________\n@CurrentObjects\n_______________________________________");
my $Service = MOBY::Client::Service->new(service => $wsdl); # create the service
_LOG("Service $Service created from WSDL\n");
# my $data = SOAP::Data->type(base64 => "$MOBY_Request"); # base64 encode the request to speed up the SOAP parsing of the message at the server end
my $result = "";
eval {$result = $Service->execute(XMLinputlist => \@CurrentObjectList)}; # execute the service
if ($@ || !$result){_LOG("!!!!!!!!!!!!!!!! ERROR $! !!!!!!!!!!!!!!!!!!!");$ERROR_FLAG = "Service Unavailable"; return};
_LOG("Service $Service Executed Successfully\nRESULT===================================================
$result\n
===================================================================================================");
my $parser = new XML::DOM::Parser;
my $doc = $parser->parse($result);
my $moby = $doc->getDocumentElement();
my @objects;
my @collections;
my @Xrefs;
my $success = 0;
my $responses = $moby->getElementsByTagName('moby:queryResponse');
$responses ||= $moby->getElementsByTagName('queryResponse');
foreach my $n(0..($responses->getLength - 1)){
my $resp = $responses->item($n);
foreach my $response_component($resp->getChildNodes){
next unless $response_component->getNodeType == ELEMENT_NODE;
if (($response_component->getTagName eq "Simple") || ($response_component->getTagName eq "moby:Simple")){
foreach my $Object($response_component->getChildNodes) {
next unless $Object->getNodeType == ELEMENT_NODE;
$success = 1;
my $Object_text = $Object->toString;
push @objects,$Object_text;
_LOG("Found response object $Object_text .\n");
}
} elsif (($response_component->getTagName eq "Collection") || ($response_component->getTagName eq "moby:Collection")){
my @objects;
foreach my $simple($response_component->getChildNodes){
next unless $simple->getNodeType == ELEMENT_NODE;
next unless (($simple->getTagName eq "Simple") || ($simple->getTagName eq "moby:Simple"));
foreach my $Object($simple->getChildNodes) {
next unless $Object->getNodeType == ELEMENT_NODE;
$success = 1;
my $Object_text = $Object->toString;
push @objects,$Object_text;
_LOG("Found response object $Object_text .\n");
}
}
push @collections, \@objects; #I'm not using collections yet, so we just use Simples.
}
}
}
unless ($success){$ERROR_FLAG = "MOBY Response Contained No Data"; return};
# fill the CurrentObjects CGI parameter; this is always used to hold
# the list of "current" objects as base64 encoded strings
my @all_objects;
push @all_objects, map {encode_base64($_)} @objects;
foreach (@collections){
push @all_objects, map {encode_base64($_)} @{$_};
}
param('CurrentObjects', @all_objects);
}
sub Continue {
# called after the service has been executed
# gets the new current object types, as well as the cached object/service/namespace data
# presents the new possibilities to the client.
my ($NameSpaces) = &extractInitializedParams(); # these are the MOBY-Central reported objects, services and namespaces
my @Objects = extractCurrentObjects(); # simply base64 decodes the CurrentObjects CGI parameter
my @CurrentObjectTypes = extractObjectTypes(@Objects);
my @CurrentNamespaces = extractNamespaceTypes(@Objects);
print header;
my $JS= "
function toggle(checkboxes) {
for (i=0; i<checkboxes.length; ++i) {
alert('i');
checkboxes[i].checked = 0;
}
}";
print start_html(
-script => $JS,
-title => 'A Simple MOBY Client',
-bgcolor => "white"),
"<table BGCOLOR='#AAAAFF' width = '100%'><TR><TD><center>",
"<IMG SRC=http://www.biomoby.org/moby1.gif>",
h1('MOBY Service Search'),"</center></TD></TR></table><p>";
if ($ERROR_FLAG){&_sendError("$ERROR_FLAG");$ERROR_FLAG = 0; }
print h3("Chose a service from the list below...\n"),
start_form(-name => "Objects"),
&getAllServices(\@CurrentObjectTypes, \@CurrentNamespaces), # find the valid services for this object/namespace combination
p,"\n",
h3("Select the Objects below that you wish to send to this service<br>\n"),
p,"\n",
submit("Send Selected Objects to Service")," ",reset," ",
#button(-value=>'All Off', -onClick=>'toggle(form.CurrentObjects);'),
p,
&writeCurrentObjects(@Objects), # allow them to chose which objects to send into this service (checkbox)
p,"\n",
submit("Send Selected Objects to Service")," ",reset," ",
#button(-value=>'All Off', -onClick=>'toggle(form.CurrentObjects);'),
&setInitializedParams, # set the hidden persistence fields
end_form,
end_html;
}
sub extractCurrentObjects {
# objects are passed as base64 encoded, need to decode them back to XML
my @objects = param("CurrentObjects");
&_LOG("CURRENT_OBJECTS__________________\n@objects\n___________________");
return map {decode_base64($_)} @objects;
}
sub extractObjectTypes {
# gets the object names out of the XML
# returns list of object names
my (@Objects) = @_;
my @Types;
foreach (@Objects) {
my $Parser = new XML::DOM::Parser;
my $doc = $Parser->parse($_);
my $Object = $doc->getDocumentElement();
my $object_name = $Object->getTagName;
_LOG("extractObjectTypes: Object was $object_name\n");
my $CRIB = $Object->getElementsByTagName("CrossReference");
$CRIB->item(0) || ($CRIB = $Object->getElementsByTagName("moby:CrossReference"));
# should be only one CRIB per object, so...
if ($CRIB->item(0)){
my @XrefsXML;
my $Xref_list = $CRIB->item(0)->getChildNodes();
foreach (0..$Xref_list->getLength-1){
next unless $Xref_list->item($_)->getNodeType == ELEMENT_NODE;
push @XrefsXML, $Xref_list->item($_)->toString;
}
push @Types, [$object_name, \@XrefsXML];
} else {
push @Types, [$object_name, []];
}
}
return @Types;
}
sub extractNamespaceTypes {
# gets the namespace names out of the XML
# returns list of namespace names
my (@Objects) = @_;
my @namespaces;
foreach (@Objects) {
my $Parser = new XML::DOM::Parser;
my $doc = $Parser->parse($_);
my $Object = $doc->getDocumentElement();
my $ns = $Object->getAttributeNode("namespace");
$ns ||= $Object->getAttributeNode("moby:namespace");
$ns ||="";
if ($ns){_LOG("extractObjectTypes: Namespace was ".$ns->getValue."\n");}
if ($ns){push @namespaces, $ns->getValue;}
else {push @namespaces, undef}
}
return @namespaces;
}
sub getAllServices {
# getAllService that can deal with this type of object in this type
# of namespace. returns HTML - a string to create an *HTML popup
# menu* of valid services!!
my ($objects, $namespace) = @_;
my @objects = @{$objects}; # has the format @([object_type, \@XREF_XML], [...]...)
_LOG("getAllServices: \n\tInitial Object List @objects\n");
my %types;
foreach (@objects){
my ($type, $xrefs) = @{$_};
next unless $type;
$types{$type} = 1;
}
my $response;
my $Central = MOBY::Client::Central->new();
#_LOG("getAllServices: \n\tObjects @types\n\tNamespaces @{$namespace}");
#my @services = $Central->locateServiceByInput(\@types, $namespace);
# I'm not sure why the call commented out above
# used a list ref of types... I'm too tired to think about it.
my %popup_services;
foreach (keys %types){
my ($SI, $Reg) = $Central->findService(input => [[$_, $namespace]], authoritative => 0, expandServices => 1, expandObjects => 1);
if ($Reg){
return "<p><b>".($Reg->message).'<\b><p>';
}
foreach (@{$SI}) {
my ($URI) = $_->authority;
my ($name) = $_->name;
my ($type) = $_->type;
my $objs = $_->output;
my $output = "(";
foreach my $param(@{$objs}){
if ($param->isSimple){
my $type = (($param->objectType =~ /\:(\S+)$/) && $1);
$type = $param->objectType unless $type;
$output .= "Simple: $type ,";
} else {
$output .= "Collection:[";
foreach my $simp(@{$param->Simples}){
my $type = (($simp->objectType =~ /\:(\S+)$/) && $1);
$type = $simp->objectType unless $type;
$output .= "$type,";
}
chop $output;
$output .="],";
}
}
chop $output;
$output .=") ";
my $desc = $_->description;
$URI ||=""; $name ||=""; $type ||=""; $output ||=""; $desc ||=""; # set default for next print statement or we choke!
$popup_services{"$URI#$name"} = "$type returns $output @"."$URI : $desc";
}
}
$response .= popup_menu(-name => 'SelectedService',
-values => [keys %popup_services],
-labels => \%popup_services,
);
return $response;
}
sub _what_am_i {
my ($ObjectDOM) = @_;
return "TEXT" unless $ObjectDOM;
my $OntologyTerm = $ObjectDOM->getTagName;
_LOG("Found type $OntologyTerm\n");
#my $MC = MOBY::Client::Central->new()
#$relationships = $MC->Relationships(objectType => $OntolgyTerm, Relationships => ["ISA"]);
# this SHOULD be done to traverse the ontology to check whether we have derived Image classes
# but to do this for every object would be painfully slow, so I am
# hard-coding the known image object types for now. THIS IS NOT HOW IT SHOULD BE DONE!!!
return "b64gif" if $OntologyTerm =~ /b64_encoded_gif/;
return "b64jpeg" if $OntologyTerm =~ /b64_encoded_jpeg/;
return "TEXT";
}
sub _sendError{
my ($mess) = @_;
print h1('MOBY Error'),
p,"\n",
"The Client encountered an error.<br>Message was <b><i>$mess</i></b>\n",
p,"\n",
"Below is the current data in-hand. Please make another selection based on the message above<hr><br>",
end_html;
}
sub _LOG {
return unless $debug;
open LOG, ">>/tmp/Client05LogOut.txt" or die "can't open logfile $!\n";
print LOG join "\n", @_;
print LOG "\n---\n";
close LOG;
}
sub to_string {
my $object = shift;
my $data_dumper = new Data::Dumper([$object]);
$data_dumper->Purity(1)->Terse(1)->Deepcopy(1);
return $data_dumper->Dump();
}