[MOBY-l] attn. Martin Senger - upcoming MOBY::Central API
Mark Wilkinson
markw at illuminae.com
Mon Jan 27 04:02:35 UTC 2003
Hi all,
This is mainly for Martin S., but also for anyone else who has written
interfaces to MOBY::Central so far.
I have done a marathon coding session this weekend and now have
re-written the MOBY::Central API such that it is no longer object
oriented, and sends/recieves *only* XML. This should make life much
easier for the Java people ;-) We might even be able to register
MOBY::Central as a MOBY Service now!
I am attaching the latest version of the code to this message so that
you can perldoc-it and see the new API. This should give you time to
update any interfaces you have written before I commit the new code and
install it on the "live" MOBY Central registry.
in addition, I have 100% re-written the MOBY::Client::Central module
such that it wraps all of the new MOBY::Central functions, uses named
arguments instead of ordered-list-arguments, and still uses sensible
Perl data structures. As such, it takes very little effort to rewrite
any clients you might have (it took only 1/2 hour to re-write Lukas'
administration script, and most of that was spent troubleshooting the
Central API itself).
There are levels of resolution in the API that do not yet exist in the
database schema - for example, the new code associates namespaces to
particular object types, rather than holding them as an independent
parameter. Although this appears to be meaningful in the API, all
meaning is removed when it is interpreted by MOBY::Central as there is
currently no way of representing this in the database. At a later date
I will update the database also such that it really does resolve this
level of detail. For now, use the API as it stands, and we'll work out
these details at a later date.
I'm having strange problems with out-of-memory errors using the new
API. If anyone feels up to the task of assisting me locate this bug
please let me know, as it is doing my head in! (it isn't a particular
call that causes the error... it just happens after a few calls, and the
number of calls depends on the functions that are called...)... it might
be associated with mod_perl...??
Anyway, I'll need a couple more days to troubleshoot the new API before
I commit it. I am also updating all of the client/example programs in
the CVS such that they will work with the new API (Lukas, your admin
script already works :-) )
There are some obvious omissions from this new API - I know... I was
mainly doing this to make it easier for non-Perl coders to access MOBY
Central.
Okay, enough babbling. I need to figure out this memory error :-(
Cheers all!
Mark
--
=======================================================================
|--==\
Mark Wilkinson \==-|
Bioinformatics Consultant \=/ 0010010010100101110010
Illuminae Media /-\
727 6th Ave. N. /-==| 0010100100111101010010
Saskatoon, SK, Canada |==-/
S7K 2S8 \=/ 0100100100010010010101
+1 (306) 373 3841 /\
markw at illuminae.com /=-\ 1101001010100101010101
|--==\
=======================================================================
-------------- next part --------------
=head1 NAME
MOBY::Central.pm - API for communicating with the MOBY Central registry
=cut
package MOBY::Central;
use strict;
use Carp;
use vars qw($AUTOLOAD);
use DBI;
use DBD::mysql;
use XML::DOM;
#use MOBY::Registration;
my $debug = 1;
if ($debug){open (OUT, ">/tmp/CentralRegistryLogOut.txt") || die "cant open logfile\n";print OUT "created logfile\n";close OUT;}
=head1 SYNOPSIS
If you are a Perl user, you should be using the
MOBY::Client:Central module to talk to MOBY-Central
If you need to connect directly, here is how it
is done in perl 5.6 and 5.6.1. It wont work
in Perl 5.8... sorry. Look how MOBY::Client::Cent
does it if you want to use Perl 5.8
--------------------------------------
SERVER-SIDE
use SOAP::Transport::HTTP;
my $x = new SOAP::Transport::HTTP::CGI;
$x->dispatch_to('/usr/local/apache/cgi-bin', 'MOBY::Central', 'MOBY::Central::new');
$x->handle;
---------------------------------------
CLIENT-SIDE
use SOAP::Lite +autodispatch =>
proxy => 'http://192.168.1.9/cgi-bin/MOBY-Central.pl',
on_fault => sub {
my($soap, $res) = @_;
die ref $res ? $res->faultstring : $soap->transport->status, "\n";
};
my $Central = MOBY::Central->new;
my $reg = $Central->registerService("
<registerService>
<serviceName>YourServiceNameHere</serviceName>
<serviceType>YourServiceTypeHere</serviceType>
<authURI>your.URI.here</authURI>
<inputObjects>
<input>
<objectType>ObjectType1</objectType>
<namespaceType>NamespaceType1</namespaceType>
</input>
<input>
<objectType>ObjectType2</objectType>
<namespaceType>NamespaceType2</namespaceType>
</input>
</inputObjects>
<outputObjects>
<objectType>ObjectType1</objectType>
<objectType>ObjectType2</objectType>
</outputObjects>
<URL>http://URL.to.your/Service.pl</URL>
<description><![CDATA[
human readable description of your service]]>
</description>
</registerService>"
);
print "success ", $reg->success;
print "\nerror_message ", $reg->error_message;
print "\nregistration_id ", $reg->registration_id;
print "\n\n";
----------------------------------------
=head1 DESCRIPTION
Used to do various transactions with MOBY-Central registry, including registering
new Object and Service types, querying for these types, registering new
Servers/Services, or queryiong for available services given certain input/output
or service type constraints.
=head1 AUTHORS
Mark Wilkinson (markw at illuminae.com)
BioMOBY Project: http://www.biomoby.org
=cut
=head1 Registration XML Object
This is sent back to you for all registration and
deregistration calls
<MOBYRegistration>
<success>$success</success>
<id>$id</id>
<message><![CDATA[$message]]></message>
</MOBYRegistration>
success is a boolean indicating a
successful or a failed registration
id is the deregistration ID of your registered
object or service to use in a deregister call.
message will contain any additional information
such as the reason for failure.
=cut
sub Registration {
my ( $details) = @_;
my $id = $details->{registration_id};
my $success = $details->{success};
my $message = $details->{error_message};
return "<MOBYRegistration>
<id>$id</id>
<success>$success</success>
<message><![CDATA[$message]]></message>
</MOBYRegistration>";
}
=cut
=head1 METHODS
=head2 new
Title : new
Usage : deprecated
=cut
sub new {
my ($caller, %args) = @_;
print STDERR "\nuse of MOBY::Central->new is deprecated\n";
return 1;
}
sub _dbAccess {
my $filename = "./MOBY/central.cfg";# $self->config;
&_LOG("trying to open file $filename\n");
open (IN, $filename) || die "can't open configuration file $filename: $!";
my $url = <IN>; chomp $url;
my $dbname = <IN>; chomp $dbname;
my $username = <IN>; chomp $username;
my $password = <IN>; chomp $password;
my ($dsn) = "DBI:mysql:$dbname:$url";
&_LOG("connecting to db with params $dsn, $username, $password\n");
my $dbh = DBI->connect($dsn, $username, $password, {RaiseError => 1}) or die "can't connect to database";
&_LOG("CONNECTED!\n");
my %sth;
# queries required for registration
$sth{check_object} = ("select OE.id from OntologyEntry as OE, Ontology as O where term=? and ontology_id = O.id and O.name='MOBY_Object' and OE.is_obselete = 'n'");
$sth{check_namespace} = ("select OE.id from OntologyEntry as OE, Ontology as O where term=? and ontology_id = O.id and O.name='MOBY_Namespace'");
$sth{check_service_type} = ("select OE.id from OntologyEntry as OE, Ontology as O where OE.term = ? and O.id = OE.ontology_id and O.name = 'MOBY_Service'");
$sth{insert_service} = ("insert into Service (service_name, service_type_id, auth_uri, url, description, registration_identifier) values (?,?,?,?,?,?)");
$sth{insert_parameter} = ("insert into ServiceParameter (service_id, ontologyentry_id, type) values (?,?,?)");
# queries required for Deregistration
$sth{service_id} = ("Select id from Service where registration_identifier = ?");
$sth{remove_service} = ("DELETE FROM Service where id = ?");
$sth{remove_service_params} = ("delete from ServiceParameter where service_id = ?");
# queries required for getServiceByType
$sth{get_service_type_id} = ("Select id from OntologyEntry where term = ?");
$sth{get_service_hierarchy_list} = ("Select ontologyentry2_id from Term2Term where ontologyentry1_id = ?");
$sth{get_server_parameters} = ("Select OE.term, O.xsd, SP.type from Object as O, OntologyEntry as OE, ServiceParameter as SP, Service as S where O.ontologyentry_id = OE.id AND SP.ontologyentry_id = OE.id and SP.service_id = ?");
# queries required for _traverseObjectDAG
$sth{get_object_type_id} = ("Select id from OntologyEntry where term = ?");
$sth{get_object_parent_list} = ("Select ontologyentry1_id from Term2Term where ontologyentry2_id = ?");
$sth{get_object_child_list} = ("Select ontologyentry2_id from Term2Term where ontologyentry1_id = ?");
# retrieveServiceProviders
$sth{return_service_providers} = ("Select distinct auth_uri from Service");
#retrieveServiceNames
$sth{return_service_names} = ("select service_name, auth_uri from Service");
#retrieveServiceTypes
$sth{return_service_types} = ("select OE.term, OE.description from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Service'");
#retrieveObjectNames
$sth{retrieve_object_names} = ("select OE.term, OE.description from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Object' and OE.is_obselete = 'n'");
#retrieveNamespaces
$sth{retrieve_namespaces} = ("select OE.term, OE.description from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Namespace'");
#registerObject
$sth{check_object_registration} = ("select OE.accession, OE.id from OntologyEntry as OE, Ontology as O where OE.term = ? and OE.ontology_id = O.id and O.name='MOBY_Object' and OE.is_obselete = 'n'");
$sth{get_last_object_accession} = ("select MAX(accession) from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Object'");
$sth{register_object} = ("insert into OntologyEntry (term, accession, ontology_id, description, authority, is_obselete) values (?,?,?,?,?, 'n')");
$sth{deprecate_object} = ("update OntologyEntry set is_obselete = 'y' where id=?");
$sth{clobber_object} = ("update OntologyEntry set term=?, ontology_id = ?, description = ?, authority=? where id = ?");
$sth{register_object_xsd} = ("insert into Object (ontologyentry_id, name, xsd) values (?,?,?)");
$sth{clobber_object_xsd} = ("update Object set name = ?, xsd = ? where ontologyentry_id = ?");
$sth{register_object_relationship} = ("insert into Term2Term (ontologyentry1_id, ontologyentry2_id, relationship_type_id) values (?,?,?)");
#deregisterObject
$sth{validate_object_deregistration} = ("SELECT COUNT(S.id) FROM Service as S, OntologyEntry as OE, Ontology as O, ServiceParameter as SP where S.id = SP.service_id and SP.ontologyentry_id = OE.id and OE.ontology_id=O.id and O.name='MOBY_Object' and OE.accession=?");
$sth{get_object_id} = ("Select OE.id from OntologyEntry as OE, Ontology as O where OE.accession = ? and OE.ontology_id = O.id and O.name='MOBY_Object'");
$sth{deregister_object_relationships} = ("delete from Term2Term where ontologyentry1_id = ? or ontologyentry2_id = ?");
$sth{deregister_object_xsd} = ("delete from Object where ontologyentry_id=?");
$sth{deregister_object} = ("delete from OntologyEntry where id=?");
#registernamespace
$sth{get_last_namespace_accession} = ("select MAX(accession) from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Namespace'");
$sth{get_existing_namespace_accession} = ("select accession from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Namespace' AND OE.term=? and OE.authority = ?");
$sth{register_namespace} = ("insert into OntologyEntry (term, authority, description, ontology_id, accession) values (?,?,?,?,?)");
$sth{update_namespace} = ("update OntologyEntry set term = ?, authority = ?, description = ? where ontology_id = ? and accession = ?");
#registerServicetype
$sth{check_service_registration} = ("select OE.id from OntologyEntry as OE, Ontology as O where OE.term = ? and OE.ontology_id = O.id and O.name='MOBY_Service'");
$sth{get_last_service_accession} = ("select MAX(accession) from OntologyEntry as OE, Ontology as O where OE.ontology_id = O.id and O.name = 'MOBY_Service'");
$sth{register_service_type} = ("insert into OntologyEntry (term, accession, ontology_id, description) values (?,?,?,?)");
$sth{register_service_relationship} = ("insert into Term2Term (ontologyentry1_id, ontologyentry2_id, relationship_type_id) values (?,?,?)");
#retrieveObject
$sth{retrieve_all_objects} = ("select term, xsd from OntologyEntry as OE, Ontology as O, Object as Ob where Ob.ontologyentry_id = OE.id AND OE.ontology_id = O.id and O.name = 'MOBY_Object' and OE.is_obselete = 'n'");
$sth{retrieve_one_object} = ("select term, xsd from OntologyEntry as OE, Ontology as O, Object as Ob where Ob.ontologyentry_id = OE.id AND OE.ontology_id = O.id and O.name = 'MOBY_Object' AND OE.term =? and OE.is_obselete = 'n'");
return ($dbh, \%sth);
}
=head2 registerObject
Title : registerObject
Usage : $REG = $MOBY->registerObject($InputXML)
Function : register a new Object type, and its relationships, or modify existing
Returns : Registration XML object; registration_id is the new object's accession number
InputXML :
<registerObject>
<objectType>NewObjectType</objectType>
<description><![CDATA[
human readable description
of data type]]></description>
<ISA>
<objectType>ExistingObjectType</objectType>
<objectType>ExistingObjectType</objectType>
</ISA>
<authURI>Your.URI.here</authURI>
<clobber>1 | 0</clobber>
<xsd><![CDATA[
the XSD for the new object goes here]]>
</xsd>
</registerObject>
OutputXML : see registration object XML
=cut
sub registerObject {
my ($pkg, $payload) = @_;
$debug && &_LOG("\n\npayload\n**********************\n$payload\n***********************\n\n");
my ($term, $desc, $xsd, $ISA, $auth, $clobber) = &_registerObjectPayload($payload);
unless (defined $term && defined $desc && defined $xsd && defined $auth){
my $reg = &Registration({
success => 0,
error_message => "Term, Description, authURI and XSD are all required parameters ",
registration_id => "",
});
return $reg;
}
my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
# check that it doesn't already exist
my $sth = $dbh->prepare($sth{check_object_registration});
$sth->execute($term);
my ($existing_acc, $existing_id) = $sth->fetchrow_array;
if ($existing_acc){
if ($clobber == 1){
my $sth = $dbh->prepare($sth{deprecate_object});
$sth->execute($existing_id);
} elsif ($clobber == 2) { # this is a REAL clobber, it overwrites
# do nothing here for the moment
} else {
my $reg = &Registration({
success => 0,
error_message => "Object Type $term already exists",
registration_id => "$existing_acc",
});
return $reg;
}
}
my ($last_acc);
if ($clobber ==2){
$last_acc = $existing_acc;
} else {
my $sth = $dbh->prepare($sth{get_last_object_accession});
$sth->execute;
$last_acc = $sth->fetchrow_array;
}
unless ($last_acc){
my $reg = &Registration({
success => 0,
error_message => "unable to determine last object accession number, or unable to find object you wish to clobber",
registration_id => "",
});
return $reg;
}
my $acc = (($last_acc =~ /0*(\d+)/) && $1);
$acc++;
my $new_acc = sprintf "%06u", $acc;
my $obj_id;
unless ($clobber ==2){
my $sth = $dbh->prepare($sth{register_object});
$sth->execute($term, $new_acc, 1, $desc, $auth);
$obj_id = $dbh->{mysql_insertid};
unless ($obj_id){
my $reg = &Registration({
success => 0,
error_message => "Failed to register object for unknown reason",
registration_id => "",
});
return $reg;
}
} else {
my $sth = $dbh->prepare($sth{clobber_object});
$sth->execute($term, 1, $desc, $auth, $existing_id);
$obj_id = $existing_id;
}
unless ($clobber == 2){
my $sth = $dbh->prepare($sth{register_object_xsd});
$sth->execute($obj_id, $term, $xsd);
} else {
my $sth = $dbh->prepare($sth{clobber_object_xsd});
$sth->execute($term, $xsd, $obj_id);
}
if ($ISA){
my @ISA = @{$ISA};
my @isa_ids;
foreach my $isa(@ISA){
my $sth = $dbh->prepare($sth{check_object_registration});
$sth->execute($isa);
my ($isa_id) = $sth->fetchrow_array;
unless ($isa_id){
$dbh->do("delete from OntologyEntry where id = $obj_id");
$dbh->do("delete from Object where ontologyentry_id = $obj_id");
my $reg = &Registration({
success => 0,
error_message => "ISA Object Type '$isa' was not registered",
registration_id => "",
});
return $reg;
}
push @isa_ids, $isa_id;
}
if ($clobber == 2){
$dbh->do("delete from Term2Term where ontologyentry1_id = $obj_id"); # purge existing relationships
}
foreach (@isa_ids){
my $sth = $dbh->prepare($sth{register_object_relationship});
$sth->execute($_, $obj_id, 1);
}
}
my $reg = &Registration({
success => 1,
error_message => "",
registration_id => $new_acc,
});
return $reg;
}
sub _registerObjectPayload {
my ($payload) = @_;
my $Parser = new XML::DOM::Parser;
my $doc = $Parser->parse($payload);
my $Object = $doc->getDocumentElement();
my $obj = $Object->getTagName;
return undef unless ($obj eq 'registerObject');
my $term = &_nodeTextContent($Object, "objectType");
my $desc = &_nodeTextContent($Object, "description");
my $authURI = &_nodeTextContent($Object, "authURI");
my $clobber = &_nodeTextContent($Object, "clobber");
my $xsd = &_nodeTextContent($Object, "xsd");
my @ISA = &_nodeArrayContent($Object, "ISA");
return ($term, $desc, $xsd, \@ISA, $authURI, $clobber);
}
=head2 deregisterObjectAcc
Title : deregisterObjectAcc
Usage : $REG = $MOBY->deregisterObjectAcc($inputXML)
Function : de-register an Object type, and its relationships
Returns : MOBY Registration XML object; registration_id was the acc of the
now de-registered object.
Notes : THIS WILL FAIL IF ANY SERVICES DEPEND ON THAT OBJECT (IN/OUT)!
Use the accession number returned when you registered that object
inputXML :
<deregisterObjectAcc>
<objectAcc>234</objectAcc>
</deregisterObjectAcc>
ouptutXML : see Registration XML object
=cut
sub deregisterObjectAcc {
my ($pkg, $payload) = @_;
unless ($payload){
my $reg = &Registration({
success => 0,
error_message => "Message Format Incorrect",
registration_id => "",
});
return $reg;
}
my ($acc) = &_deregisterObjectPayload($payload);
&_LOG("object accession $acc\n");
unless ($acc){
my $reg = &Registration({
success => 0,
error_message => "Must include an accession number to deregister an object",
registration_id => "",
});
return $reg;
}
my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
my $sth = $dbh->prepare($sth{validate_object_deregistration});
$sth->execute($acc);
my ($invalid) = $sth->fetchrow_array;
if ($invalid){
my $reg = &Registration({
success => 0,
error_message => "This object has Service dependancies ($invalid) and may not be deregistered",
registration_id => "$acc",
});
return $reg;
}
$sth = $dbh->prepare($sth{get_object_id});
$sth->execute($acc);
my ($id) = $sth->fetchrow_array;
unless (defined $id){
my $reg = &Registration({
success => 0,
error_message => "Object does not exist",
registration_id => "$acc",
});
return $reg;
}
$sth = $dbh->prepare($sth{deregister_object_relationships});
$sth->execute($id, $id);
$sth = $dbh->prepare($sth{deregister_object_xsd});
$sth->execute($id);
$sth = $dbh->prepare($sth{deregister_object});
$sth->execute($id);
my $reg = &Registration({
success => 1,
error_message => "",
registration_id => $acc,
});
return $reg;
}
sub _deregisterObjectPayload {
my ($payload) = @_;
my $Parser = new XML::DOM::Parser;
my $doc = $Parser->parse($payload);
my $Object = $doc->getDocumentElement();
my $obj = $Object->getTagName;
return undef unless ($obj eq 'deregisterObjectAcc');
return &_nodeTextContent($Object, "objectAcc");
}
=head2 registerServiceType
Title : registerServiceType
Usage : $REG = $MOBY->registerServiceType($inputXML)
Function : register a new Service type, and its relationships
Returns : MOBY Registration XML object
inputXML :
<registerServiceType>
<serviceType>NewServiceType</serviceType>
<description>
<![CDATA[ human description of service type here]]>
</description>
<ISA>
<serviceType>ExistingServiceType</serviceType>
<serviceType>ExistingServiceType</serviceType>
</ISA>
</registerServiceType>
outputXML : see Registration XML object
=cut
sub registerServiceType {
my ($pkg, $payload) = @_;
my ($term, $desc, $ISA) = &_registerServiceTypePayload($payload);
unless ($term && $desc){
my $reg = &Registration({
success => 0,
error_message => "Term and Description are both required parameters",
registration_id => "",
});
return $reg;
}
my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
my $sth = $dbh->prepare($sth{check_service_registration});
$sth->execute($term);
my ($existing_id) = $sth->fetchrow_array;
if ($existing_id){
my $reg = &Registration({
success => 0,
error_message => "Service Type $term already exists",
registration_id => "$existing_id",
});
return $reg;
}
$sth = $dbh->prepare($sth{get_last_service_accession});
$sth->execute;
my ($last_acc) = $sth->fetchrow_array;
unless ($last_acc){
my $reg = &Registration({
success => 0,
error_message => "unable to determine last service accession number",
registration_id => "",
});
return $reg;
}
my $acc = (($last_acc =~ /0*(\d+)/) && $1);
$acc++;
my $new_acc = sprintf "%06u", $acc;
$sth = $dbh->prepare($sth{register_service_type});
$sth->execute($term, $new_acc, 2, $desc);
my $obj_id = $dbh->{mysql_insertid};
unless ($obj_id){
my $reg = &Registration({
success => 0,
error_message => "Failed to register service type for unknown reason",
registration_id => "",
});
return $reg;
}
if ($ISA){
my @ISA = @{$ISA};
my @isa_ids;
foreach my $isa(@ISA){
$sth = $dbh->prepare($sth{check_service_registration});
$sth->execute($isa);
my ($isa_id) = $sth->fetchrow_array;
unless ($isa_id){
$dbh->do("delete from OntologyEntry where id = '$obj_id'");
my $reg = &Registration({
success => 0,
error_message => "ISA Service Type '$isa' is not registered",
registration_id => "",
});
return $reg;
}
push @isa_ids, $isa_id;
} # all are valid registered types, so now register them as ISA
foreach (@isa_ids){
my $sth = $dbh->prepare($sth{register_service_relationship});
$sth->execute($_, $obj_id, 1);
}
}
my $reg = &Registration({
success => 1,
error_message => "",
registration_id => $new_acc,
});
return $reg;
}
sub _registerServiceTypePayload {
my ($payload) = @_;
&_LOG("_registerServiceTypePayload payload=$payload\n");
my $Parser = new XML::DOM::Parser;
my $doc = $Parser->parse($payload);
my $Object = $doc->getDocumentElement();
my $obj = $Object->getTagName;
return undef unless ($obj eq 'registerServiceType');
my $type = &_nodeTextContent($Object, "serviceType");
my $desc = &_nodeTextContent($Object, "description");
my @ISA = &_nodeArrayContent($Object, "ISA");
&_LOG("got $type, $desc, @ISA from registerServiceTypePayload\n");
return ($type, $desc, \@ISA);
}
=head2 registerNamespace
Title : registerNamespace
Usage : $REG = $MOBY->registerNamespace($inputXML)
Function : register a new Namespace
Returns : MOBY Registration XML object
inputXML :
<registerNamespace>
<namespaceType>NewNamespaceHere</namespaceType>
<authURI>Your.URI.here</authURI>
<description>
<![CDATA[human readable description]]>
</description>
<clobber>1 | 0</clobber>
</registerNamespace>
outputXML : see Registration XML object
=cut
sub registerNamespace {
my ($pkg, $payload) = @_;
my ($term, $auth, $desc, $clobber) = &_registerNamespacePayload($payload);
unless ($term && $desc){
my $reg = &Registration({
success => 0,
error_message => "Namespace identifier and description are required parameters",
registration_id => "",
});
return $reg;
}
my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
my $sth = $dbh->prepare($sth{get_existing_namespace_accession});
$sth->execute($term, $auth);
my ($existing_acc) = $sth->fetchrow_array;
if ($clobber ne "clobber" && $existing_acc) {
my $reg = &Registration({
success => 0,
error_message => "This namespace already exists",
registration_id => "",
});
return $reg;
}
if ($clobber eq "clobber" && $existing_acc){
# update record
my $sth = $dbh->prepare($sth{update_namespace});
$sth->execute($term, $auth, $desc, 3, $existing_acc);
my $reg = &Registration({
success => 1,
error_message => "",
registration_id => $existing_acc,
});
return $reg;
} else {
# create new record
my $sth = $dbh->prepare($sth{get_last_namespace_accession});
$sth->execute;
my ($last_acc) = $sth->fetchrow_array;
unless ($last_acc){
my $reg = &Registration({
success => 0,
error_message => "unable to determine last service accession number",registration_id => "",
});
return $reg;
}
my $acc = (($last_acc =~ /0*(\d+)/) && $1);
$acc++;
my $new_acc = sprintf "%06u", $acc;
$sth = $dbh->prepare($sth{register_namespace});
$sth->execute($term, $auth, $desc, 3, $new_acc);
my $obj_id = $dbh->{mysql_insertid};
unless ($obj_id){
my $reg = &Registration({
success => 0,
error_message => "Failed to register new namespace for unknown reason",registration_id => "",
});
return $reg;
}
my $reg = &Registration({
success => 1,
error_message => "",
registration_id => $new_acc,
});
return $reg;
}
}
sub _registerNamespacePayload {
my ($payload) = @_;
my $Parser = new XML::DOM::Parser;
my $doc = $Parser->parse($payload);
my $Object = $doc->getDocumentElement();
my $obj = $Object->getTagName;
return undef unless ($obj eq 'registerNamespace');
my $type = &_nodeTextContent($Object, "namespaceType");
my $authURI = &_nodeTextContent($Object, "authURI");
my $desc = &_nodeTextContent($Object, "description");
my $clobber = &_nodeTextContent($Object, "clobber");
return ($type, $authURI, $desc, $clobber);
}
=head2 registerService
Title : registerService
Usage : $REG = $MOBY->registerService($inputXML)
Function : register a new MOBY Service
Returns : MOBY Registration XML object
Notes : 1) serviceName, AuthURI combination must be unique in database
2) @in/@out why lists? Often a MOBY Service will accept a single
MOBY object type as input and provide a single MOBY object
type as output. N.B. MOBY Services should, however, expect
Clients to send multiple such 'singletons' in a single query
(e.g. a list of GenbankID's to get back a list of sequences).
The Service should concatenate the MOBY objects results of such a query
into a single MOBY wrapper. At times, the input to the query is a set
of MOBY objects. e.g. a GO_ID object, and a Species object might be used
to request members of a certain gene function from a certain species. In such
a case, the input and/or output objects should be registered as a list. When
these objects are passed to/from the service they should be wrapped in a
"collection envelope" (described elsewhere) in order to preserve their
relationship to each other; a list of input query-lists must be sent as a
list of collections.
inputXML :
<registerService>
<serviceName>YourServiceNameHere</serviceName>
<serviceType>YourServiceTypeHere</serviceType>
<authURI>your.URI.here</authURI>
<inputObjects>
<input>
<objectType>ObjectType1</objectType>
<namespaceType>NamespaceType1</namespaceType>
</input>
<input>
<objectType>ObjectType2</objectType>
<namespaceType>NamespaceType2</namespaceType>
</input>
</inputObjects>
<outputObjects>
<objectType>ObjectType1</objectType>
<objectType>ObjectType2</objectType>
</outputObjects>
<URL>http://URL.to.your/Service.pl</URL>
<description><![CDATA[
human readable description of your service]]>
</description>
</registerService>
=cut
sub registerService {
my ($pkg, $payload) = @_;
my ($serviceName, $serviceType, $AuthURI, $INS, $OUTS, $NSS, $URL, $desc) = &_registerServicePayload($payload);
unless ($serviceName && $serviceType && $AuthURI && $INS && $OUTS && $URL && $desc){ # throw error if parameter missing
$debug && &_LOG("$serviceName && $serviceType && $AuthURI && $INS && $OUTS && $URL && $desc");
my $reg = &Registration({
success => 0,
error_message => "not all required parameters present",
registration_id => "",
});
return $reg;
}
my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
my @IN = @{$INS};
my @OUT = @{$OUTS};
my @NS = @{$NSS};
unless ((scalar @IN) && (scalar @OUT)){ # throw error if parameter missing
my $reg = &Registration({
success => 0,
error_message => "must include at least one input and one output object type",
registration_id => "",
});
return $reg;
}
unless ((scalar @NS)){ # mark it as "any namespace" if they haven't included one
push @NS, "any";
}
foreach my $IN(@IN){
my $sth = $dbh->prepare($sth{check_object});
$sth->execute($IN);
my ($valid) = $sth->fetchrow_array; # returns the index number, might be zero
unless (defined $valid){
my $reg = &Registration({
success => 0,
error_message => "Input object $IN is not recognized as a valid MOBY_Object in the registry. Object may be deprecated.\n",
registration_id => "",
});
return $reg;
}
}
foreach my $OUT(@OUT){
my $sth = $dbh->prepare($sth{check_object});
$sth->execute($OUT);
my ($valid) = $sth->fetchrow_array; # returns the index number, might be zero
unless (defined $valid){
my $reg = &Registration({
success => 0,
error_message => "Output object $OUT is not recognized as a valid MOBY_Object in the registry. Object may be deprecated.\n",
registration_id => "",
});
return $reg;
}
}
foreach my $NS(@NS){
next if ($NS eq "any");
my $sth = $dbh->prepare($sth{check_namespace});
$sth->execute($NS);
my ($valid) = $sth->fetchrow_array; # returns the index number, might be zero
unless (defined $valid){
my $reg = &Registration({
success => 0,
error_message => "Output object $NS is not recognized as a valid MOBY_Namespace in the registry\n",
registration_id => "",
});
return $reg;
}
}
my $sth = $dbh->prepare($sth{check_service_type});
$sth->execute($serviceType);
my ($service_type_id) = $sth->fetchrow_array; # might return 0 as a valid table id
unless (defined $service_type_id){
my $reg = &Registration({
success => 0,
error_message => "Service Type $serviceType is not recognized as a valid MOBY_Service type in the registry\n",
registration_id => "",
});
return $reg;
}
my $reg_id;
for (my $x = 1; $x <=50; ++$x){
$reg_id .= int((rand) * 8) + 1;
}
$sth = $dbh->prepare($sth{insert_service});
$sth->execute($serviceName,$service_type_id, $AuthURI, $URL, $desc, $reg_id);
my $service_id = $dbh->{mysql_insertid};
foreach my $IN(@IN){
my $sth = $dbh->prepare($sth{check_object});
$sth->execute($IN);
my ($ontologyentry_id) = $sth->fetchrow_array; # returns the index number, might be zero
$sth = $dbh->prepare($sth{insert_parameter});
$sth->execute($service_id, $ontologyentry_id, "in");
}
foreach my $OUT(@OUT){
my $sth = $dbh->prepare($sth{check_object});
$sth->execute($OUT);
my ($ontologyentry_id) = $sth->fetchrow_array; # returns the index number, might be zero
$sth = $dbh->prepare($sth{insert_parameter});
$sth->execute($service_id, $ontologyentry_id, "out");
}
foreach my $NS(@NS){ # may be "any"
my $sth = $dbh->prepare($sth{check_namespace});
$sth->execute($NS);
my ($ontologyentry_id) = $sth->fetchrow_array; # returns the index number, might be zero
$sth = $dbh->prepare($sth{insert_parameter});
$sth->execute($service_id, $ontologyentry_id, "ns");
}
my $reg = &Registration({
success => 1,
error_message => "",
registration_id => $reg_id,
});
return $reg; # and return it.
}
sub _registerServicePayload {
my ($payload) = @_;
my $Parser = new XML::DOM::Parser;
my $doc = $Parser->parse($payload);
my $Object = $doc->getDocumentElement();
my $obj = $Object->getTagName;
return undef unless ($obj eq 'registerService');
my $name = &_nodeTextContent($Object, "serviceName");
my $type = &_nodeTextContent($Object, "serviceType");
my $authURI = &_nodeTextContent($Object, "authURI");
my $inputRoot = $Object->getElementsByTagName("inputObjects")->item(0);
my @OUTS = &_nodeArrayContent($Object, "outputObjects");
my $URL = &_nodeTextContent($Object, "URL");
my $desc = &_nodeTextContent($Object, "description");
# YES, I KNOW! This part throws away the association
# Between objects and their namespace, but we have no
# way to represent that in the database yet anyway
# so poop on it!
my @types = $inputRoot->getElementsByTagName("objectType");
my @namespaces = $inputRoot->getElementsByTagName("namespaceType");
my (@INS, @NSS);
foreach (@types){
my @child2 = $_->getChildNodes;
foreach (@child2){
#print $_->getNodeTypeName, "\t", $_->toString,"\n";
next unless $_->getNodeType == TEXT_NODE;
push @INS, $_->toString;
}
}
foreach (@namespaces){
my @child2 = $_->getChildNodes;
foreach (@child2){
#print $_->getNodeTypeName, "\t", $_->toString,"\n";
next unless $_->getNodeType == TEXT_NODE;
push @NSS, $_->toString;
}
}
return ($name, $type, $authURI, \@INS, \@OUTS, \@NSS, $URL, $desc);
}
=head2 registerServiceWSDL
Title : NOT YET IMPLEMENTED
Usage :
=cut
sub registerServiceWSDL {
my ( $pkg, $serviceType, $wsdl) = @_;
my $reg = &Registration({
success => 0,
error_message => "not yet implemented\n",
registration_id => "",
});
return $reg;
}
=head2 deregisterService
Title : deregisterService
Usage : $REG = $MOBY->deregisterService($inputXML)
Function : deregister a Service
Returns : $REG object
inputXML :
<deregisterService>
<serviceID>234233343233443483784782929710874234</serviceID>
</deregisterService>
ouptutXML : see Registration XML object
=cut
sub deregisterService {
my ($pkg, $payload) = @_;
&_LOG("\nstarting deregistration\n");
my ($reg_id) = &_deregisterServicePayload($payload);
unless ($reg_id){
my $reg = &Registration({
success => 0,
error_message => "must provide a registration id number\n",
registration_id => "",
});
}
my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
my $sth = $dbh->prepare($sth{service_id});
$sth->execute($reg_id);
my ($sid) = $sth->fetchrow_array;
return 0 unless $sid;
$sth = $dbh->prepare($sth{remove_service});
$sth->execute($sid);
$sth = $dbh->prepare($sth{remove_service_params});
$sth->execute($sid);
return &Registration({
success => 1,
error_message => "",
registration_id => "",
});
}
sub _deregisterServicePayload {
my ($payload) = @_;
&_LOG("deregisterService payload: ",($payload),"\n");
my $Parser = new XML::DOM::Parser;
my $doc = $Parser->parse($payload);
my $Object = $doc->getDocumentElement();
my $obj = $Object->getTagName;
return undef unless ($obj eq 'deregisterService');
return &_nodeTextContent($Object, "serviceID");
}
=head2 locateServiceByType
Title : locateServiceByType
Usage : $services = $MOBY->locateServiceByType($inputXML)
Function : get the service names/descriptions for a particular type of Service
(and child-types)
Returns : XML (see below)
inputXML :
<locateServiceByType>
<serviceType>ServiceType</serviceType>
<fullServices>1 | 0</fullServices>
<locateServiceByType>
outputXML :
<Services>
<Service authURI="authority.info.here" serviceName="MyService">
<ServiceType>Service_Ontology_Term</ServiceType>
<OutputObject>Object_Ontology_Term</OutputObject>
<Description><![CDATA[free text description here]]></Description>
</Service>
...
...
</Services>
=cut
sub locateServiceByType {
my ($pkg, $payload) = @_;
my ($serviceType, $full_services) = &_locateServiceByTypePayload($payload);
return undef unless $serviceType;
my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
my @ServiceIDs;
if ($full_services){ # we need this service type and all child types
@ServiceIDs = &_traverseServiceDAG($dbh,$serviceType, $sth_hash);
} else { # we need only the service type of this element
my $sth = $dbh->prepare($sth{get_service_type_id});
$sth->execute($serviceType);
@ServiceIDs = $sth->fetchrow_array;
}
# keys %ServiceIDs now contains the index number of all service types down the hierarchy from where we started (inclusive)
# now we need to find all service providors who which map to those types of services
my $query = "
Select
S.service_name,
OEout.term,
S.auth_uri,
S.description,
OEtype.term
from
Service as S,
OntologyEntry as OEtype,
OntologyEntry as OEout,
ServiceParameter as SPout,
Ontology as O
where
OEtype.is_obselete = 'n'
and OEout.is_obselete = 'n'
and SPout.type = 'out'
and SPout.service_id = S.id
and S.service_type_id = OEtype.id
and OEtype.ontology_id = O.id
and OEout.id = SPout.ontologyentry_id
and O.name='MOBY_Service'
and OEtype.id in (".(join "'", @ServiceIDs).") ";
return &_getValidServices($dbh, $sth_hash, $query);
}
sub _locateServiceByTypePayload {
my ($payload) = @_;
my $Parser = new XML::DOM::Parser;
my $doc = $Parser->parse($payload);
my $Object = $doc->getDocumentElement();
my $obj = $Object->getTagName;
return undef unless ($obj eq 'locateServiceByType');
my $type = &_nodeTextContent($Object, "serviceType");
my $expand = &_nodeTextContent($Object, "fullServices");
return ($type, $expand);
}
=head2 locateServiceByInput
Title : locateServiceByInput
Usage : $services = $MOBY->locateServiceByInput($inputXML)
Function : get the names/descriptions for services that use certain INPUT's
Returns : XML (see below)
inputXML :
<locateServiceByInput>
<inputObjects>
<input>
<objectType>ObjectType1</objectType>
<namespaceType>NamespaceType1</namespaceType>
</input>
<input>
<objectType>ObjectType2</objectType>
<namespaceType>NamespaceType2</namespaceType>
</input>
</inputObjects>
<serviceType>ServiceTypeTerm</serviceType>
<authURI>http://desired.service.provider</authURI>
<fullObjects>1|0</fullObjects>
<fullServices>1|0</fullServices>
<locateServiceByInput>
outputXML :
<Services>
<Service authURI="authority.info.here" serviceName="MyService">
<ServiceType>Service_Ontology_Term</ServiceType>
<OutputObject>Object_Ontology_Term</OutputObject>
<Description><![CDATA[free text description here]]></Description>
</Service>
...
...
</Services>
=cut
sub locateServiceByInput {
my ($pkg, $payload) = @_;
my ($serviceType, $AuthURI, $INs, $NSs, $full_objects, $full_services) = &_locateServiceByInputPayload($payload);
unless (defined $full_objects){$full_objects = 1}
unless (defined $full_services){$full_services = 1}
&_LOG("RECEIVED PARAMS: \n", join "\n", at _);
return undef unless $INs;
my ($dbh, $sth_hash) = &_dbAccess;
my (@ServiceIDs);
my %sth = %{$sth_hash};
if ($serviceType && $full_services){ # we need this service type and all child types
@ServiceIDs = &_traverseServiceDAG($dbh, $serviceType, $sth_hash);
} elsif ($serviceType) { # we need only the service type of this element
my $sth = $dbh->prepare($sth{get_service_type_id});
$sth->execute($serviceType);
@ServiceIDs = $sth->fetchrow_array;
}
my (@ObjectIDs, %ObjectIDs);
if ($full_objects){ # we need this Object type and all parent types
foreach (@{$INs}){
&_LOG("traversing DAG for $_");
foreach (&_traverseObjectDAG($dbh, $_, $sth_hash, 'p')){
&_LOG("found $_ in DAG");
$ObjectIDs{$_}=1;
}
}
@ObjectIDs = keys %ObjectIDs;
} else { # we need only the Object type of the elements we were sent
foreach (@{$INs}){
my $sth = $dbh->prepare($sth{get_object_type_id});
$sth->execute($_);
push @ObjectIDs, $sth->fetchrow_array;
}
}
&_LOG("INs @{$INs} ::: @ObjectIDs\n");
if ($NSs){&_LOG("NSs @{$NSs} \n")};
if ($serviceType){&_LOG("Servicetypes $serviceType, @ServiceIDs\n")};
my $query = "
Select
S.service_name,
OEout.term,
S.auth_uri,
S.description,
OEtype.term
from
Service as S,
OntologyEntry as OEtype,
OntologyEntry as OEin,
OntologyEntry as OEout,
ServiceParameter as SPout,
ServiceParameter as SPin,
OntologyEntry as OEns,
ServiceParameter as SPns
where
OEin.is_obselete = 'n'
and OEout.is_obselete = 'n'
and OEout.id = SPout.ontologyentry_id
and SPout.service_id = S.id
and S.service_type_id = OEtype.id
and SPin.service_id = S.id
and SPin.service_id = SPns.service_id
and SPout.service_id = SPns.service_id
and OEin.id = SPin.ontologyentry_id
and OEns.id = SPns.ontologyentry_id
and SPin.type = 'in'
and SPns.type = 'ns'
and SPout.type = 'out'
and OEin.id in (". join (",", map {"\"".$_."\""} @ObjectIDs).") ";
if ($NSs && ${$NSs}[0]){ # must have at least one element
$query .= "
and OEns.term in (". join (",", map {"\"".$_."\""} (@{$NSs}, "any")).") ";
}
if ($serviceType){ $query .= "and (S.service_type_id in (".(join ',', @ServiceIDs).")) "} # service type is a DAG, so get all relevant types
if ($AuthURI){ $query .= "and (S.auth_uri = '$AuthURI') "}
_LOG("*************************\ Query is: $query\n****************************");
return &_getValidServices($dbh, $sth_hash, $query);
}
sub _locateServiceByInputPayload {
my ($payload) = @_;
my $Parser = new XML::DOM::Parser;
my $doc = $Parser->parse($payload);
my $Object = $doc->getDocumentElement();
my $obj = $Object->getTagName;
return undef unless ($obj eq 'locateServiceByInput');
my $type = &_nodeTextContent($Object, "serviceType");
my $authURI = &_nodeTextContent($Object, "authURI");
my $fullObjects = &_nodeTextContent($Object, "fullObjects");
my $fullServices = &_nodeTextContent($Object, "fullServices");
my $x = $Object->getElementsByTagName("inputObjects");
my @types = $x->item(0)->getElementsByTagName("objectType");
my @namespaces = $x->item(0)->getElementsByTagName("namespaceType");
my (@INS, @NSS);
foreach (@types){
my @child2 = $_->getChildNodes;
foreach (@child2){
#print $_->getNodeTypeName, "\t", $_->toString,"\n";
next unless $_->getNodeType == TEXT_NODE;
push @INS, $_->toString;
}
}
foreach (@namespaces){
my @child2 = $_->getChildNodes;
foreach (@child2){
#print $_->getNodeTypeName, "\t", $_->toString,"\n";
next unless $_->getNodeType == TEXT_NODE;
push @NSS, $_->toString;
}
}
return ($type, $authURI, \@INS, \@NSS, $fullObjects, $fullServices);
}
=head2 locateServiceByOutput
Title : locateServiceByOutput
Usage : $services = $MOBY->locateServiceByOutput($inputXML)
Function : get the names/descriptions for services that use certain INPUT's
Returns : XML (see below)
inputXML :
<locateServiceByOutput>
<objectType>ObjectType</objectType>
<serviceType>ServiceTypeTerm</serviceType>
<authURI>http://desired.service.provider</authURI>
<fullObjects>1|0</fullObjects>
<fullServices>1|0</fullServices>
<locateServiceByOutput>
outputXML :
<Services>
<Service authURI="authority.info.here" serviceName="MyService">
<ServiceType>Service_Ontology_Term</ServiceType>
<OutputObject>Object_Ontology_Term</OutputObject>
<Description><![CDATA[free text description here]]></Description>
</Service>
...
...
</Services>
=cut
sub locateServiceByOutput {
my ($pkg, $payload) = @_;
my ($serviceType, $AuthURI, $OUT, $full_objects, $full_services) = &_locateServiceByOutputPayload($payload);
unless (defined $full_objects){$full_objects = 1}
unless (defined $full_services){$full_services = 1}
&_LOG("RECEIVED PARAMS", @_);
# this one has to be generated dynamically...
return undef unless $OUT;
my ($dbh, $sth_hash) = &_dbAccess;
my (@ServiceIDs);
my %sth = %{$sth_hash};
if ($serviceType && $full_services){ # we need this service type and all child types
&_LOG("Traversing Service DAG");
@ServiceIDs = &_traverseServiceDAG($dbh, $serviceType, $sth_hash);
} elsif ($serviceType) { # we need only the service type of this element
&_LOG("NOT Traversing Service DAG");
my $sth = $dbh->prepare($sth{get_service_type_id});
$sth->execute($serviceType);
@ServiceIDs = $sth->fetchrow_array;
}
&_LOG("FINISHED Traversing Service DAG");
my (@ObjectIDs, %ObjectIDs);
if ($full_objects){ # we need this Object type and all parent types
&_LOG("traversing Object DAG for $OUT");
foreach (&_traverseObjectDAG($dbh, $OUT, $sth_hash, 'c')){
&_LOG("found $_ in Object DAG");
$ObjectIDs{$_}=1;
}
@ObjectIDs = keys %ObjectIDs;
} else { # we need only the Object type of the elements we were sent
my $sth = $dbh->prepare($sth{get_object_type_id});
$sth->execute($OUT);
push @ObjectIDs, $sth->fetchrow_array;
}
&_LOG("OUT $OUT ::: @ObjectIDs\n");
# if ($NSs){&_LOG("NSs @{$NSs} \n")};
if ($serviceType){&_LOG("Servicetypes $serviceType, @ServiceIDs\n")};
my $query = "
Select
S.service_name,
OEout.term,
S.auth_uri,
S.description,
OEtype.term
from
Service as S,
Ontology as O,
OntologyEntry as OEtype,
OntologyEntry as OEout,
ServiceParameter as SPout,
OntologyEntry as OEns,
ServiceParameter as SPns
where
OEout.is_obselete = 'n'
and OEtype.is_obselete = 'n'
and S.service_type_id = OEtype.id
and O.name = 'MOBY_Service'
and O.id = OEtype.ontology_id
and SPout.service_id = SPns.service_id
and SPout.service_id = S.id
and OEout.id = SPout.ontologyentry_id
and OEns.id = SPns.ontologyentry_id
and SPout.type = 'out'
and SPns.type = 'ns'
and OEout.id in (". join (",", map {"\"".$_."\""} @ObjectIDs).") ";
#if ($NSs && ${$NSs}[0]){ # must have at least one element
# $query .= "
# and OEns.term in (". join (",", map {"\"".$_."\""} @{$NSs}).") ";
#}
if ($serviceType){ $query .= "and (S.service_type_id in (".(join ',', @ServiceIDs).")) "} # service type is a DAG, so get all relevant types
if ($AuthURI){ $query .= "and (S.auth_uri = '$AuthURI') "}
_LOG("*************************\ Query is: $query\n****************************");
return &_getValidServices($dbh, $sth_hash, $query);
}
sub _locateServiceByOutputPayload {
my ($payload) = @_;
my $Parser = new XML::DOM::Parser;
my $doc = $Parser->parse($payload);
my $Object = $doc->getDocumentElement();
my $obj = $Object->getTagName;
return undef unless ($obj eq 'locateServiceByOutput');
my $type = &_nodeTextContent($Object, "serviceType");
my $authURI = &_nodeTextContent($Object, "authURI");
my $fullObjects = &_nodeTextContent($Object, "fullObjects");
my $fullServices = &_nodeTextContent($Object, "fullServices");
my $output = &_nodeTextContent($Object, "objectType");
return ($type, $authURI, $output, $fullObjects, $fullServices);
}
=head2 retrieveService
Title : retrieveService
Usage : $WSDL = $MOBY->locateService($inputXML)
Function : get the WSDL descriptions for services with this service name
Returns : XML (see below)
inputXML :
<retrieveService>
<authURI>http://service.provider.URI</authURI>
<serviceName>DesiredServiceName</serviceName>
<retrieveService>
outputXML :
<Service><![CDATA[WSDL document here]]</Service>
=cut
sub retrieveService {
my ($pkg, $payload) = @_;
my ($AuthURI, $serviceName) = &_retrieveServicePayload($payload);
unless ($AuthURI && $serviceName){return "<Services/>"}
my $wsdls;
my ($dbh, $sth_hash) = &_dbAccess;
my (@ServiceIDs);
my %sth = %{$sth_hash};
my $query = "
select
S.id,
S.service_name,
S.auth_uri,
S.url,
S.description
from
Service as S
where
service_name = '$serviceName'
and S.auth_uri = '$AuthURI'";
my $wsdl = &_getServiceWSDL($dbh, $sth_hash, $query);
if ($wsdl){
$wsdls .= "<Service><![CDATA[$wsdl]]></Service>\n";
}
#&_LOG("WSDL_________________$wsdls\n____________________");
return $wsdls;
}
sub _retrieveServicePayload {
my ($payload) = @_;
my $Parser = new XML::DOM::Parser;
my $doc = $Parser->parse($payload);
my $Object = $doc->getDocumentElement();
my $obj = $Object->getTagName;
return undef unless ($obj eq 'retrieveService');
my $authURI = &_nodeTextContent($Object, "authURI");
my $serviceName = &_nodeTextContent($Object, "serviceName");
return ($authURI, $serviceName);
}
=head2 retrieveServiceProviders
Title : retrieveServiceProviders
Usage : $uris = $MOBY->retrieveServiceProviders()
Function : get the list of all provider's AuthURI's
Returns : XML (see below)
Args : none
XML :
<ServiceProviders>
<ServiceProvider name="authority.info.here"/>
...
...
</ServiceProviders>
=cut
sub retrieveServiceProviders {
my ($pkg) = @_;
my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
my $sth = $dbh->prepare($sth{return_service_providers});
$sth->execute;
my $providers = "<ServiceProviders>\n";
while (my ($prov) = $sth->fetchrow_array){
$providers .= "<ServiceProvider name='$prov'/>\n";
}
$providers .= "</ServiceProviders>\n";
return $providers;
}
=head2 retrieveServiceNames
Title : retrieveServiceNames
Usage : $names = $MOBY->retrieveServiceNames()
Function : get a (redundant) list of all registered service names
(N.B. NOT service types!)
Returns : XML (see below)
Args : none
XML :
<ServiceNames>
<ServiceName name="serviceName" authURI='authority.info.here'/>
...
...
</ServiceNames>
=cut
sub retrieveServiceNames {
my ($pkg) = shift;
my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
my $sth = $dbh->prepare($sth{return_service_names});
$sth->execute;
my $names = "<ServiceNames>\n";
while (my ($name, $auth) = $sth->fetchrow_array){
$names .= "<ServiceName name='$name' authURI='$auth'/>\n";
}
$names .= "</ServiceNames>\n";
return $names;
}
=head2 retrieveServiceTypes
Title : retrieveServiceTypes
Usage : $types = $MOBY->retrieveServiceTypes()
Function : get the list of all registered service types
Returns : XML (see below)
Args : none
XML :
<ServiceTypes>
<ServiceType name="serviceName">
<Description><![CDATA[free text description here]]></Description>
</ServiceType>
...
...
</ServiceNames>
=cut
sub retrieveServiceTypes {
my ($pkg) = @_;
my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
my $sth = $dbh->prepare($sth{return_service_types});
$sth->execute;
my $types = "<ServiceTypes>\n";
while (my ($serv, $desc) = $sth->fetchrow_array){
$types .= "<ServiceType name='$serv'>\n<Description><![CDATA[$desc]]></Description>\n</ServiceType>\n";
}
$types .= "</ServiceTypes>\n";
return $types;
}
=head2 retrieveObjectNames
Title : retrieveObjectNames
Usage : $names = $MOBY->retrieveObjectNames()
Function : get the list of all registered Object types
Returns : XML (see below)
Args : none
XML :
<ObjectNames>
<ObjectName name="objectName">
<Description><![CDATA[free text description here]]></Description>
</ObjectName>
...
...
</ObjectNames>
=cut
sub retrieveObjectNames {
my ($pkg) = @_;
my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
my $sth = $dbh->prepare($sth{retrieve_object_names});
$sth->execute;
my $obj = "<ObjectNames>\n";
while (my ($name, $desc) = $sth->fetchrow_array){
$obj .= "<Object name='$name'>\n<Description><![CDATA[$desc]]></Description>\n</Object>\n";
}
$obj .= "</ObjectNames>\n";
return $obj;
}
=head2 retrieveNamespaces
Title : retrieveNamespaces
Usage : $ns = $MOBY->retrieveNamespaces()
Function : get the list of all registered Object types
Returns : XML (see below)
Args : none
XML :
<Namespaces>
<Namespace name="namespace">
<Description><![CDATA[free text description here]]></Description>
</Namespace>
...
...
</Namespaces>
=cut
sub retrieveNamespaces {
my ($pkg) = @_;
my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
my $sth = $dbh->prepare($sth{retrieve_namespaces});
$sth->execute;
my $ns = "<Namespaces>\n";
while (my ($namespace, $desc) = $sth->fetchrow_array){
$ns .= "<Namespace name='$namespace'>\n<Description><![CDATA[$desc]]></Description>\n</Namespace>\n";
}
$ns .="</Namespaces>";
return $ns;
}
=head2 retrieveObject
Title : retrieveObject
Usage : $objects = $MOBY->retrieveObject($name | "all")
Function : get the object xsd
Returns : XML (see below)
Args : $name - object name (from ontology) or "all" to get all objects
inputXML :
<retrieveObject>
<type>ObjectType | all</type>
<retrieveObject>
outputXML :
<Objects>
<Object name="namespace">
<Schema><![CDATA[XSD schema fragment here]]></Schema>
</Object>
...
...
</Objects>
=cut
sub retrieveObject {
my ( $pkg,$param) = @_;
my $response;
my ($dbh, $sth_hash) = &_dbAccess;
my %sth = %{$sth_hash};
$response = "<Objects>\n";
if (lc($param) eq "all"){
my $sth = $dbh->prepare($sth{retrieve_all_objects});
$sth->execute;
while (my ($obj, $xsd) = $sth->fetchrow_array){
$response .= "<Object name='$obj'>\n";
$response .= "<Schema><![CDATA[$xsd]]></Schema>\n";
$response .= "</Object>\n";
}
} else{
my $sth = $dbh->prepare($sth{retrieve_one_object});
$sth->execute($param);
while (my ($obj, $xsd) = $sth->fetchrow_array){
$response .= "<Object name='$obj'>\n";
$response .= "<Schema><![CDATA[$xsd]]></Schema>\n";
$response .= "</Object>\n";
}
}
$response .= "</Objects>\n";
return $response;
}
=cut
=head1 Internal Object Methods
=cut
=head2 _getValidServices
Title : _getValidServices
Usage : %valid = $MOBY->_getValidServices($dbh, $sth_hash, $query, $max_return)
Function : execute the query in $query to return a non-redundant list of matching services
Returns : XML
Args : none
=cut
sub _getValidServices {
my ( $dbh, $sth_hash, $query, $max_return) = @_;
my %sth = %{$sth_hash};
my $this_query = $dbh->prepare($query);
$this_query->execute;
my $response;
$response = "<Services>\n";
while (my ($serviceName, $objectOUT, $AuthURI,$desc, $type) =$this_query->fetchrow_array()){
$response .="<Service authURI='$AuthURI' serviceName='$serviceName'>\n";
$response .="<ServiceType>$type</ServiceType>\n";
$response .="<OutputObject>$objectOUT</OutputObject>\n";
$response .= "<Description><![CDATA[$desc]]></Description>\n";
$response .= "</Service>\n";
if ($max_return){--$max_return;last unless $max_return}
}
$response .= "</Services>\n";
return $response;
}
=head2 _getServiceWSDL
Title : _getServiceWSDL
Usage : @valid = $MOBY->_getValidServices($dbh, $sth_hash, $query)
Function : execute the query in $query to return a non-redundant list of matching services
Returns : list of response strings in wsdl
Args : none
=cut
sub _getServiceWSDL {
my ( $dbh, $sth_hash, $query) = @_;
my %sth = %{$sth_hash};
my $this_query = $dbh->prepare($query);
$this_query->execute;
open (WSDL, "./MOBY/Central_WSDL_SandR.wsdl") || die "can't open WSDL file for search and replace\n";
my $wsdl = join "", (<WSDL>);
$wsdl =~ s/^\n//gs;
close WSDL;
my ($id, $serviceName, $AuthURI, $URL, $desc) =$this_query->fetchrow_array();
my $sth = $dbh->prepare($sth{get_server_parameters});
$sth->execute($id);
my (@in, @out);
while (my ($Object, $xsd, $in_out) = $sth->fetchrow_array()){
if ($in_out eq "in"){push @in, [$Object, $xsd]}
else {push @out, [$Object, $xsd]}
}
# do substitutions
$wsdl =~ s/MOBY__SERVICE__NAME__/$serviceName/g; # replace all of the goofy portbindingpottype crap
$wsdl =~ s/\<\!\-\-\s*MOBY__SERVICE__DESCRIPTION\s*\-\-\>/Authority: $AuthURI - $desc/g; # add a sensible description
$wsdl =~ s/MOBY__SERVICE__URL/$URL/g; # the URL to the service
my ($IN, $INxsd) = @{shift @in};
my ($OUT, $OUTxsd) = @{shift @out};
$wsdl =~ s/MOBY__INPUT__OBJECT__NAME/$IN/g; # SINGLE input object (for now)
$wsdl =~ s/MOBY__OUTPUT__OBJECT__NAME/$OUT/g; # SINGLE output object (for now)
$wsdl =~ s/\<\!\-\-\s*MOBY__INPUT__OBJECT__XSD\s*\-\-\>/$INxsd/g; # XSD stright from the database
$wsdl =~ s/\<\!\-\-\s*MOBY__OUTPUT__OBJECT__XSD\s*\-\-\>/$OUTxsd/g; # XSD straight from the database
$wsdl =~ s/MOBY__SERVICE__NAME/$serviceName/g; # finally replace the actual subroutine call
return $wsdl;
}
=head2 _traverseServiceDAG
Title : _traverseServiceDAG
Usage : @valid = $MOBY->_traverseServiceDAG($dbh, $serviceType, $sth_hash)
Function : starting from $serviceType, find all child services non-redundantly
by traversing the DAG.
Returns : list of Service.id database entries.
Args : none
=cut
sub _traverseServiceDAG {
my ( $dbh, $serviceType, $sth_hash) = @_;
my %sth = %{$sth_hash};
my %ServiceIDs;
my $sth = $dbh->prepare($sth{get_service_type_id});
$sth->execute($serviceType);
my ($root_id) = $sth->fetchrow_array;
return undef unless $root_id;
# we have to do a traversal of the DAG here to get all child nodes...
# this is one UGLY piece of code written in a hurry! Please, someone, shoot it and put it out of its misery...
$ServiceIDs{$root_id} = "untested"; # mark the one in-hand as untested
while (grep /untested/, (values %ServiceIDs)){ # now, while there are untested services in our list...
foreach my $service(keys %ServiceIDs){ # start parsing through the list
next if ($ServiceIDs{$service} eq "tested"); # if it has been tested already then move on
my $sth = $dbh->prepare($sth{get_service_hierarchy_list});
$sth->execute($service); # execute the query for child nodes
$ServiceIDs{$service} = "tested"; # mark it as tested
while (my $new = $sth->fetchrow_array){ # now get each of the child nodes
next if (defined $ServiceIDs{$new}); # if we have already heard about it then move on
$ServiceIDs{$new} = "untested"; #otherwise mark it as untested, and start all over again
}
}
}
return keys %ServiceIDs;
}
=head2 _traverseObjectDAG
Title : _traverseObjectDAG
Usage : @valid = $MOBY->_traverseObjectDAG( $dbh, $objectType, $sth_hash, "p|c")
Function : from $objectType, find all parent/child objects non-redundantly
by traversing the DAG.
Returns : list of Object.id database entries.
Args : objectType (by name), $statement ahngles, "p" parent, or "c" child
=cut
sub _traverseObjectDAG {
my ( $dbh, $objectType, $sth_hash, $dir) = @_;
my %sth = %{$sth_hash};
my %ObjectIDs;
my $sth = $dbh->prepare($sth{get_object_type_id});
$sth->execute($objectType);
my ($root_id) = $sth->fetchrow_array;
return undef unless $root_id;
if ($dir eq "p"){
_LOG("getting parents");
$sth = $dbh->prepare($sth{get_object_parent_list});
}
else {
_LOG("getting children");
$sth = $dbh->prepare($sth{get_object_child_list});
}
# we have to do a traversal of the DAG here to get all child nodes...
# this is one UGLY piece of code written in a hurry! Please, someone, shoot it and put it out of its misery...
$ObjectIDs{$root_id} = "untested"; # mark the one in-hand as untested
while (grep /untested/, (values %ObjectIDs)){ # now, while there are untested services in our list...
foreach my $object(keys %ObjectIDs){ # start parsing through the list
next if ($ObjectIDs{$object} eq "tested"); # if it has been tested already then move on
$sth->execute($object); # execute the query for child nodes
$ObjectIDs{$object} = "tested"; # mark it as tested
while (my $new = $sth->fetchrow_array){ # now get each of the child nodes
next if (defined $ObjectIDs{$new}); # if we have already heard about it then move on
$ObjectIDs{$new} = "untested"; #otherwise mark it as untested, and start all over again
}
}
}
return keys %ObjectIDs;
}
sub _nodeTextContent {
# will get text of **all** child $node from the given $DOM
# regardless of their depth!!
my ($DOM, $node) = @_;
&_LOG("_nodeTextContext received DOM: ", $DOM->toString,"\nsearching for node $node\n");
my $x = $DOM->getElementsByTagName($node);
my @child = $x->item(0)->getChildNodes;
my $content;
foreach (@child){
&_LOG($_->getNodeTypeName, "\t", $_->toString,"\n");
next unless $_->getNodeType == TEXT_NODE;
$content = $_->toString;
}
return $content;
}
sub _nodeArrayContent {
# will get array content of all child $node from given $DOM
# regardless of depth!
my ($DOM, $node) = @_;
&_LOG("_nodeArrayContext received DOM: ", $DOM->toString,"\nsearching for node $node\n");
my @result;
my $x = $DOM->getElementsByTagName($node);
my @child = $x->item(0)->getChildNodes;
foreach (@child){
next unless $_->getNodeType == ELEMENT_NODE;
my @child2 = $_->getChildNodes;
foreach (@child2){
#print $_->getNodeTypeName, "\t", $_->toString,"\n";
next unless $_->getNodeType == TEXT_NODE;
push @result, $_->toString;
}
}
return @result;
}
sub DESTROY {}
sub _LOG {
#return unless $debug;
open LOG, ">>/tmp/CentralRegistryLogOut.txt" or die "can't open logfile $!\n";
print LOG join "\n", @_;
print LOG "\n---\n";
close LOG;
}
#
#
# --------------------------------------------------------------------------------------------------------
#
##
##
1;
More information about the moby-l
mailing list