#$Id: Central.pm,v 1.13 2010/05/03 18:34:40 kawas Exp $ =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 $WSDL_TEMPLATE $WSDL_POST_TEMPLATE $WSDL_ASYNC_TEMPLATE $WSDL_ASYNC_POST_TEMPLATE); use XML::LibXML; use MOBY::OntologyServer; use MOBY::service_type; use MOBY::authority; use MOBY::service_instance; use MOBY::simple_input; use MOBY::simple_output; use MOBY::collection_input; use MOBY::collection_output; use MOBY::secondary_input; use MOBY::central_db_connection; use MOBY::Config; use MOBY::RDF::Ontologies::Services; use URI; use LWP; use MOBY::CommonSubs; use vars qw /$VERSION/; $VERSION = sprintf "%d.%02d", q$Revision: 1.13 $ =~ /: (\d+)\.(\d+)/; use Encode; use MOBY::MobyXMLConstants; my $debug = 0; my $listener = 1; my %user_agent_args = (agent => "MOBY-Central-Perl"); if ($debug) { open( OUT, ">/tmp/CentralRegistryLogOut.txt" ) || die "cant open logfile\n"; print OUT "created logfile\n"; close OUT; } if ($listener) { eval {open(OUT, ">>/tmp/CentralRegistryListener.txt")}; $listener = 0 if @!; # abort listening if the logging attempt failed } sub listener { return unless $listener; my (%args) = @_; my $authority = $args{authority}; my $servicename = $args{servicename}; my $ip = $ENV{REMOTE_ADDR}; # ="137.82.67.190" open(OUT, ">>/tmp/CentralRegistryListener.txt"); use Time::localtime; my $time = ctime; print OUT "$time\t$ip\t$authority\t$servicename\n"; close OUT; } =head1 SYNOPSIS REQUIRES MYSQL 3.23 or later!!!! 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; # fill in your server path below... $x->dispatch_to('WWW_SERVER_PATH', 'MOBY::Central'); $x->handle; --------------------------------------- CLIENT-SIDE use SOAP::Lite +autodispatch => proxy => 'http://moby.ucalgary.ca/moby/MOBY-Central.pl', # or whatever... on_fault => sub { my($soap, $res) = @_; die ref $res ? $res->faultstring : $soap->transport->status, "\n"; }; my $NAMES_XML = MOBY::Central->retrieveObjectNames; print $NAMES_XML; # ... do something with the XML ---------------------------------------- =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. =cut =head1 CONFIGURATION This depends on a config file to get its database connection information. At a minimum this config file must have the following clause: [mobycentral] url = some.url username = foo password = bar port = portnumber dbname = mobycentral The space before and after the '=' is critical. The end of a clause is indicated by a blank line. Additional identically formatted clauses may be added for each of: [mobyobject] [mobynamespace] [mobyservice] [mobyrelationship] if these ontologies are being served from a local database (via the OntologyServer module). These clauses will be read by the OntologyServer module if they are present, otherwise default connections will be made to the MOBY Central ontology server. The config file must be readable by the webserver, and the webserver environment should include the following ENV variable: $ENV{MOBY_CENTRAL_CONFIG} = /path/to/config/file.name =head1 AUTHORS Mark Wilkinson (markw@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 $success $id 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->{id}; my $success = $details->{success}; my $message = $details->{message}; my $RDF = $details->{RDF}; # return " # $id # $success # # # "; return " $id $success $RDF "; } =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 0; } =head2 registerObjectClass The registerObjectClass call is: =over 3 =item * used to register a new object Class into the Class ontology =item * can envision this as simply registering a new node into the Class ontology graph, and creating the primary connections from that node. =item * MOBY, by default, supports three types of Class Relationships: ISA, HAS, and HASA (these are the relationship ontology terms) =over 3 =item * Foo ISA bar is a straight inheritence, where all attributes of bar are guaranteed to be present in foo. =item * foo HAS bar is a container type, where bar is an object inside of foo in one or more copies. =item * foo HASA bar is a container type, where bar is an object inside of foo in one copy only =back =item * notice that, in a HAS and HASA relationships, it is necessary to indicate an article name for each contained object type. Thus, for example, you could have a sequence object that contained a String object with name "nucleotideSequence" and an Integer object with the name "sequenceLength". =back Input XML : NewObjectType ExistingObjectType ... ... ... ... Your.URI.here You@your.address.com Output XML : ...Registration Object... =cut sub registerObjectClass { # this contacts the ontology server to register # the ontology and writes the resulting URI into # the MOBY Central database my ( $pkg, $payload ) = @_; my ( $success, $message ); my $OntologyServer = &_getOntologyServer( ontology => 'object' ); my $RelOntologyServer = &_getOntologyServer( ontology => 'relationship' ); my ( $term, $desc, $relationships, $email, $auth, $clobber ) = &_registerObjectPayload($payload); unless ( defined $term && defined $desc && defined $auth && defined $email ) { if ( $term =~ /FAILED/ ) { return &_error( "Malformed XML;", "" ); } return &_error("Malformed XML; may be missing required parameters objectType, Description, authURI or contactEmail", "" ); } #print STDERR "$term, $desc, $auth, $email\n"; #check encoding unless ( decode_utf8($term) eq $term && decode_utf8($desc) eq $desc && decode_utf8($auth) eq $auth && decode_utf8($email) eq $email ) { return &_error("Invalid character encoding; one or all of objectType, Description, authURI or contactEmail were not UTF-8 encoded.", "" ); } return &_error( "Malformed authURI - must not have an http:// prefix", "" ) if $auth =~ '[/:]'; return &_error( "Malformed authURI - must take the form NNN.NNN.NNN", "" ) unless $auth =~ /\./; return &_error("Malformed email - must be a valid email address of the form name\@organization.foo", "" ) unless $email =~ /\S\@\S+\.\S+/; return &_error("Object name may not contain spaces or other characters invalid in a URN", "" ) if $term =~ /[\/\'\\\s"\&\<\>\[\]\^\`\{\|\}:\~%\!\@#\$\*\+=]/; if ( $term =~ m"^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\?([^#]*))?(#(.*))?" ) { # matches a URI return &_error( "Object name may not be an URN or URI", "" ) if $1; } my $ISAs; # validate that the final ontology will be valid by testing against existing relationships and such while ( my ( $reltype, $obj ) = each %{$relationships} ) { my ( $success, $message, $URI ) = $RelOntologyServer->relationshipExists( term => $reltype, ontology => 'object' ); # success = 1 if it does ($success == 0) && return &_error( $message, $URI ); foreach ( @{$obj} ) { ++$ISAs if ( $URI =~ /isa$/i ); my ( $objectType, $articleName ) = @{$_}; return &_error("Object contains a child relationship with an invalid articlename. Articlenames name may not contain spaces or other special characters.","") if $articleName =~ /([\+\=\':\s\"\&\<\>\[\]\^\`\{\|\}\~\(\)\\\/\$\#\@\,\|\?\.!\*\;])/; my ( $success, $message, $URI ) = $OntologyServer->objectExists( term => $objectType ) ; # success = 1 if it does ($success == 0) && return &_error( $message, $URI ); } } return &_error( "Object must have exactly one ISA parent in the MOBY Object ontology") unless $ISAs == 1; $clobber = defined($clobber) ? $clobber : 0; $clobber = 0 unless ( $clobber eq 0 || $clobber eq 1 || $clobber eq 2 ); # safety! my ( $exists, $exists_message, $URI ) = $OntologyServer->objectExists( term => $term ); # success = 1 if it does ( ( $exists == 1 && !$clobber ) && return &_error( "Object $term already exists", $URI ) ); $clobber = 0 unless ($exists) ; # it makes no sense to clobber something that doesnt' exist if ($exists) { if ( $clobber == 1 ) { my ( $success, $message ) = $OntologyServer->deprecateObject( term => $term ); ($success == 0) && return &_error( $message, $URI ); } elsif ( $clobber == 2 ) { my ( $success, $message ) = $OntologyServer->deleteObject( term => $term ); ($success == 0) && return &_error( $message, $URI ); } } # now test if the object inherits from primitives... if so, abort if ( keys %{$relationships} ) { while ( my ( $reltype, $obj ) = each %{$relationships} ) { next unless ($reltype =~ /isa/i); # we are only testing isa relationships here. foreach ( @{$obj} ) { my ( $objectType, $articleName ) = @{$_}; if (&_testObjectTypeAgainstPrimitives($objectType)){ return &_error( "Inheritance from Primitive data-types is now deprecated. You shold construct your object using a HASA relationship. for example, text-plain HASA string (as opposed to ISA string)", "" ); } } } } # are the article names unique? if ( keys %{$relationships} ) { my $parent_type; my %art_names = (); while ( my ( $reltype, $obj ) = each %{$relationships} ) { # one isa relationship if ($reltype =~ /isa/i) { foreach ( @{$obj} ) { my ( $objectType, $articleName ) = @{$_}; $parent_type = $objectType; } } else { #has/hasa relationship foreach ( @{$obj} ) { my ( $objectType, $articleName ) = @{$_}; return return &_error( "Article names for HAS/HASA relationships must be unique. Please ensure that names are unique!", "" ) if $art_names{$articleName}; # add name to the hash $art_names{$articleName} = 1; } } } unless (&_extract_terms($parent_type, \%art_names)){ return &_error( "Article names for HAS/HASA relationships (including those inherited) must be unique. Please ensure that names are unique!", "" ); } } # should be good to go now... ( $success, $message, $URI ) = $OntologyServer->createObject( node => $term, description => $desc, authority => $auth, contact_email => $email ); ($success == 0) && return &_error( $message, $URI ); my @failures; my $messages = ""; if ( keys %{$relationships} ) { # need to pull them out with ISA's first foreach my $reltype(qw{ISA HASA HAS}){ my ( $obj ) = $relationships->{$reltype}; foreach ( @{$obj} ) { my ( $objectType, $articleName ) = @{$_}; my ( $success, $message ) = $OntologyServer->addObjectRelationship( subject_node => $term, relationship => $reltype, object_node => $objectType, articleName => $articleName, authority => $auth, contact_email => $email ); unless ($success){ push @failures, $objectType; $messages .= $message."; "; } } } } if ( scalar(@failures) ) { my ( $success, $message, $deleteURI ) = $OntologyServer->deleteObject( term => $term ) ; # hopefully this situation will never happen! ($success == 0) && return &_error( "object failed ISA and/or HASA connections, and subsequently failed deletion. This is a critical error, and may indicate corruption of the MOBY Central registry.", $deleteURI ); return &_error("object failed to register due to failure during registration of ISA/HASA relationships. Message returned was $messages" . ( join ",", (@failures) ) . "\n", "" ); } return &_success( "Object $term registered successfully.", $URI ); } ############################### # ############################### sub _extract_terms { my ( $datatype, $articles ) = @_; my $ont_serv = MOBY::OntologyServer->new( ontology => "object" ); my $stuff = $ont_serv->retrieveObject( type => $datatype ); return 1 unless $stuff; # extract all isa/hasa/has relationships my $rels = $stuff->{Relationships} if defined $stuff->{Relationships}; for my $relation ( keys %{$rels} ) { for my $term ( @{ $rels->{$relation} } ) { # pos 1 has articlename, pos 2 has datatype # if we are in isa, then drill into it if ( $relation =~ m/\:isa$/i ) { return 0 unless &_extract_terms( @{$term}[2], $articles ); } else { # check if we already processed the articlename ... return 0 if defined @{$term}[1] and $articles->{ @{$term}[1] }; $articles->{ @{$term}[1] } = 1 if @{$term}[1]; } } } return 1; } #Eddie - converted sub _registerObjectPayload { my ($payload) = @_; #EDDIE - assuming that payload is a string my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($payload); my $Object = $doc->documentElement(); my $obj = $Object->nodeName; return undef unless ( $obj eq 'registerObjectClass' ); my $term = &_nodeTextContent( $Object, "objectType" ); my $desc = &_nodeCDATAContent( $Object, "Description" ); my $authURI = &_nodeTextContent( $Object, "authURI" ); my $email = &_nodeTextContent( $Object, "contactEmail" ); my $clobber = &_nodeTextContent( $Object, "Clobber" ); #my @ISA = &_nodeArrayContent($Object, "ISA"); #my @HASA = &_nodeArrayExtraContent($Object, "HASA","articleName"); my %att_value; my %relationships; my $x = $doc->getElementsByTagName("Relationship"); my $no_relationships = $x->size; for ( my $n = 1 ; $n <= $no_relationships ; ++$n ) { my $relationshipType = $x->get_node($n)->getAttributeNode('relationshipType') ; # may or may not have a name if ($relationshipType) { $relationshipType = $relationshipType->getValue(); } else { return "FAILED! must include a relationshipType in every relationship\n"; } my @child = $x->get_node($n)->childNodes; foreach (@child) { next unless $_->nodeType == ELEMENT_NODE; my $article = $_->getAttributeNode('articleName'); # may or may not have a name if ($article) { $article = $article->getValue() } my @child2 = $_->childNodes; foreach (@child2) { #print getNodeTypeName($_), "\t", $_->toString,"\n"; next unless $_->nodeType == TEXT_NODE; push @{ $relationships{$relationshipType} }, [ $_->toString, $article ]; } } } return ( $term, $desc, \%relationships, $email, $authURI, $clobber ); } sub _testObjectTypeAgainstPrimitives{ # THIS SUBROUTINE NEEDS TO BE REMOVED AND PLACED INTO THE ONTOLOGY SERVER # one day when MOBY Central and the ontologies are separated properly my ($type) = @_; my $OS = MOBY::OntologyServer->new(ontology => 'object'); # get the inputlsid my ($success, $desc, $inputlsid) = $OS->objectExists(term => $type); my $CONF = MOBY::Config->new; my @primitives = @{$CONF->primitive_datatypes}; # get the list of known primitive datatypes my $x = 0; # set flag down # convert everything to an LSID first my @primitive_lsids = map{my ($s, $d, $l) = $OS->objectExists(term => $_); $l} @primitives; map {($x=1) if ($inputlsid eq $_)} @primitive_lsids; # test primitives against this one my $OSrel = MOBY::OntologyServer->new(ontology => 'relationship'); my ($exists1, $desc2, $isalsid) = $OSrel->relationshipExists(term => 'isa', ontology => 'object'); my $relationships = $OS->Relationships( ontology => 'object', term => $type, relationship => $isalsid, direction => 'root', expand => 1); #relationships{relationship} = [[lsid1,articleNmae], [lsid2, articleName], [lsid3, articleName]] my ($isa) = keys(%$relationships); # can only be one key returned, and must be isa in this case my @ISAlist; (@ISAlist = @{$relationships->{$isa}}) if ($relationships->{$isa}) ; # for each of the inherited parents, check their articleNames foreach my $ISA(@ISAlist){ # $ISA = [lsid, articleName] (but articleName shuld be null anyway in this case) my $what_it_is = $ISA->{lsid}; # my $articleName = $ISA->{articleName} map {($x=1) if ($what_it_is eq $_)} @primitive_lsids; # test primitives against this one } return $x; # return flag state } =head2 deregisterObjectClass =over 3 =item * used to remove an Object Class from the Class ontology =item * this will not be successful until you respond positively to an email sent to the address that you provided when registering that object. =item * you may only deregister Classes that you yourself registered! =item * you may not deregister Object Classes that are being used as input or output by ANY service =item * you may not deregister Object Classes that are in a ISA or HASA relationship to any other Object Class. =back Input XML : ObjectOntologyTerm Ouptut XML : ...Registration Object... =cut sub deregisterObjectClass { $CONFIG ||= MOBY::Config->new; # exported by Config.pm my $adaptor = $CONFIG->getDataAdaptor( datasource => 'mobycentral' ); my ( $pkg, $payload ) = @_; my $OntologyServer = &_getOntologyServer( ontology => 'object' ); return &_error( "Message Format Incorrect", "" ) unless ($payload); my ($class) = &_deregisterObjectPayload($payload); $debug && &_LOG("deregister object type $class\n"); return &_error( "Must include class of object to deregister", "" ) unless ($class); my ( $success, $message, $existingURI ) = $OntologyServer->objectExists( term => $class ); return &_error( "Object class $class does not exist", "" ) unless ($existingURI); my $errormsg = $adaptor->check_object_usage(type => $existingURI); return &_error( "Object class $class is used by a service and may not be deregistered", "" ) if ($errormsg); my ( $success2, $message2, $URI ) = $OntologyServer->deleteObject( term => $class ); ($success2 == 0) && return &_error( $message2, $URI ); return &_success( $message2, $URI ); } #Eddie - converted sub _deregisterObjectPayload { my ($payload) = @_; my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($payload); my $Object = $doc->getDocumentElement(); my $obj = $Object->nodeName; return undef unless ( $obj eq 'deregisterObjectClass' ); return &_nodeTextContent( $Object, "objectType" ); } =head2 registerServiceType =over 3 =item * used to register a new node in the Service Ontology =item * the ISA ontology terms must exist or this registration will fail. =item * all parameters are required. =item * email must be valid for later deregistration or updates =back Input XML : NewServiceType your_name@contact.address.com Your.URI.here ExistingServiceType ExistingServiceType .... Output XML : ...Registration Object... =cut sub registerServiceType { # this contacts the ontology server to register # the ontology and writes the resulting URI into # the MOBY Central database my ( $pkg, $payload ) = @_; my ( $success, $message, $URI ); my $OntologyServer = &_getOntologyServer( ontology => 'service' ); $debug && &_LOG( "\n\npayload\n**********************\n$payload\n***********************\n\n" ); my ( $term, $desc, $relationships, $email, $auth ) = &_registerServiceTypePayload($payload); $debug && &_LOG( "\n\nterm $term\ndesc $desc\nrel $relationships\nemail $email\nauth $auth" ); unless ( defined $term && defined $desc && defined $auth && defined $email ) { if ( $term =~ /FAILED/ ) { return &_error( "Malformed XML\n $term", "" ); } return &_error( "Malformed XML\n may be missing required parameters serviceType, Description, authURI or contactEmail", "" ); } #check character encoding unless ( decode_utf8( $term ) eq $term && decode_utf8( $desc ) eq $desc && decode_utf8( $auth ) eq $auth && decode_utf8( $email ) eq $email ) { return &_error( "Invalid character encoding\n One of serviceType, Description, authURI or contactEmail were not UTF-8 encoded.", "" ); } return &_error( "Malformed authURI - must not have an http:// prefix", "" ) if $auth =~ '[/:]'; return &_error( "Malformed authURI - must take the form NNN.NNN.NNN", "" ) unless $auth =~ /\./; return &_error( "Malformed email - must be a valid email address of the form name\@organization.foo", "" ) unless $email =~ /\S\@\S+\.\S+/; return &_error("serviceType name may not contain spaces or other characters invalid in a URN", "" ) if $term =~ /[\/\'\\\s"\&\<\>\[\]\^\`\{\|\}\~%\!\@#\$\*\+=:]/; # validate that the final ontology will be valid my ( $exists, $exists_message, $existingURI ) = $OntologyServer->serviceExists( term => $term ); # success = 1 if it does ( ( $exists == 1 ) && return &_error( "Service type $term already exists", $existingURI ) ); # is the relationship valid? my $OSrel = MOBY::OntologyServer->new( ontology => 'relationship' ); if ( keys %{$relationships} ) { while ( my ( $reltype, $obj ) = each %{$relationships} ) { my ( $success, $desc, $URI ) = $OSrel->relationshipExists( term => $reltype, ontology => 'service' ); ( !$success ) && return &_error( "Relationship type $reltype does not exist in the relationship ontology", "" ); } } # are the predicate service types valid? my $OSsrv = MOBY::OntologyServer->new( ontology => 'service' ); if ( keys %{$relationships} ) { while ( my ( $srvtype, $svcs ) = each %{$relationships} ) { foreach my $svc ( @{$svcs} ) { my ( $success, $desc, $URI ) = $OSsrv->serviceExists( term => $svc ); ( !$success ) && return &_error( "Service type $srvtype does not exist in the service ontology", "" ); } } } # hunky dorey. Now register! ( $success, $message, $URI ) = $OntologyServer->createServiceType( node => $term, description => $desc, authority => $auth, contact_email => $email ); ($success == 0) && return &_error( $message, $URI ); my @failures; if ( keys %{$relationships} ) { while ( my ( $reltype, $obj ) = each %{$relationships} ) { foreach my $serviceType ( @{$obj} ) { my ( $success, $message ) = $OntologyServer->addServiceRelationship( subject_node => $term, relationship => $reltype, object_node => $serviceType, authority => $auth, contact_email => $email ); ($success == 0) && push @failures, $serviceType; } } } if ( scalar(@failures) ) { my ( $success, $message, $deleteURI ) = $OntologyServer->deleteServiceType( term => $term ) ; # hopefully this situation will never happen! ($success == 0) && return &_error( "Service registration failed ISA connections, and subsequently failed deletion. This is a critical error, and may indicate corruption of the MOBY Central registry", $deleteURI ); return &_error( "Service failed to register due to failure during registration of relationships" . ( join ",", (@failures) ) . "\n", "" ); } return &_success( "Service type $term registered successfully.", $URI ); } #Eddie - converted sub _registerServiceTypePayload { my ($payload) = @_; $debug && &_LOG("_registerServiceTypePayload payload=$payload\n"); my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($payload); my $Object = $doc->getDocumentElement(); my $obj = $Object->nodeName; return undef unless ( $obj eq 'registerServiceType' ); my $type = &_nodeTextContent( $Object, "serviceType" ); my $email = &_nodeTextContent( $Object, "contactEmail" ); my $auth = &_nodeTextContent( $Object, "authURI" ); my $desc = &_nodeCDATAContent( $Object, "Description" ); my %relationships; my $x = $doc->getElementsByTagName("Relationship"); my $no_relationships = $x->size(); for ( my $n = 1 ; $n <= $no_relationships ; ++$n ) { my $relationshipType = $x->get_node($n)->getAttributeNode('relationshipType') ; # may or may not have a name if ($relationshipType) { $relationshipType = $relationshipType->getValue(); } else { return "FAILED! must include a relationshipType in every relationship\n"; } my @child = $x->get_node($n)->childNodes; foreach (@child) { next unless $_->nodeType == ELEMENT_NODE; my @child2 = $_->childNodes; foreach (@child2) { #print getNodeTypeName($_), "\t", $_->toString,"\n"; next unless $_->nodeType == TEXT_NODE; push @{ $relationships{$relationshipType} }, $_->toString; } } } $debug && &_LOG( "got $type, $desc, \%relationships, $email, $auth from registerServiceTypePayload\n" ); return "FAILED! a service type '$type' was found to have no relationships\n" if keys( %relationships ) == 0 ; return ( $type, $desc, \%relationships, $email, $auth ); } =head2 deregisterServiceType =over 3 =item * used to deregister a Service term from the Service ontology =item * will fail if any services are instances of that Service Type =item * will fail if any Service Types inherit from that Service Type. =back Input XML : ServiceOntologyTerm Ouptut XML : ...Registration Object... =cut sub deregisterServiceType { $CONFIG ||= MOBY::Config->new; # exported by Config.pm my $adaptor = $CONFIG->getDataAdaptor( datasource => 'mobycentral' ); my ( $pkg, $payload ) = @_; my $OntologyServer = &_getOntologyServer( ontology => 'service' ); return &_error( "Message Format Incorrect", "" ) unless ($payload); my ($term) = &_deregisterServiceTypePayload($payload); $debug && &_LOG("deregister serviceType accession $term\n"); return &_error( "Must include an accession number to deregister a serviceType", "" ) unless ($term); my ( $success, $message, $existingURI ) = $OntologyServer->serviceExists( term => $term ); # hopefully this situation will never happen! return &_error( "Service Type $term does not exist in the ontology", "" ) unless ($existingURI); my $result = $adaptor->query_service_instance(service_type_uri => $existingURI); my $row = shift(@$result); my $lsid = $row->{lsid}; return &_error( "A registered service depends on this service type", "" ) if ($lsid); my ( $success2, $message2, $deleteURI ) = $OntologyServer->deleteServiceType( term => $term ) ; # hopefully this situation will never happen! (($success2 == 0)) && return &_error( $message2, $deleteURI ); return &_success( "Service type $term deleted.", $deleteURI ); } #Eddie - converted sub _deregisterServiceTypePayload { my ($payload) = @_; my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($payload); my $Object = $doc->getDocumentElement(); my $obj = $Object->nodeName; #Eddie- unsure return undef unless ( $obj eq 'deregisterServiceType' ); return &_nodeTextContent( $Object, "serviceType" ); } =head2 registerNamespace =over 3 =item * used to register a new Namespace in the Namespace controlled vocabulary =item * must provide a valid email address =item * all parameters are required. =back Input XML : NewNamespaceHere your_name@contact.address.com Your.URI.here Output XML : ...Registration Object... =cut sub registerNamespace { # this contacts the ontology server to register # the ontology and writes the resulting URI into # the MOBY Central database my ( $pkg, $payload ) = @_; my ( $success, $message ); my $OntologyServer = &_getOntologyServer( ontology => 'namespace' ); $debug && &_LOG( "\n\npayload\n**********************\n$payload\n***********************\n\n" ); my ( $term, $auth, $desc, $email ) = &_registerNamespacePayload($payload); $debug && &_LOG("\n\nterm $term\ndesc $desc\nemail $email\nauth $auth"); unless ( defined $term && defined $desc && defined $auth && defined $email ) { return &_error( "Malformed XML; may be missing required parameters namespaceType, Description, authURI or contactEmail", "" ); } # check encoding unless ( decode_utf8( $term ) eq $term && decode_utf8( $desc ) eq $desc && decode_utf8( $auth ) eq $auth && decode_utf8( $email ) eq $email ) { return &_error( "Invalid character encoding; one or all of namespaceType, Description, authURI or contactEmail were not UTF-8 encoded.", "" ); } return &_error("Namespace name may not contain spaces or other characters invalid in a URN", "" ) if $term =~ /[\/\'\\\s"\&\<\>\[\]\^\`\{\|\}\~%\!\@#\$\*\+=:]/; return &_error( "Malformed authURI - must not have an http:// prefix", "" ) if $auth =~ '[/:]'; return &_error( "Malformed authURI - must take the form NNN.NNN.NNN", "" ) unless $auth =~ /\./; return &_error( "Malformed email - must be a valid email address of the form name\@organization.foo", "" ) unless $email =~ /\S\@\S+\.\S+/; my ( $exists, $exists_message, $URI ) = $OntologyServer->namespaceExists( term => $term ) ; # success = 1 if it does ( ( $exists == 1 ) && return &_error( "Namespace $term already exists", $URI ) ); ( $success, $message, $URI ) = $OntologyServer->createNamespace( node => $term, description => $desc, authority => $auth, contact_email => $email ); ($success == 0) && return &_error( $message, $URI ); return &_success( "Namespace type $term registered successfully.", $URI ); } #Eddie - converted sub _registerNamespacePayload { my ($payload) = @_; my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($payload); my $Object = $doc->getDocumentElement(); my $obj = $Object->nodeName; return undef unless ( $obj eq 'registerNamespace' ); my $type = &_nodeTextContent( $Object, "namespaceType" ); my $authURI = &_nodeTextContent( $Object, "authURI" ); my $desc = &_nodeCDATAContent( $Object, "Description" ); my $contact = &_nodeTextContent( $Object, "contactEmail" ); return ( $type, $authURI, $desc, $contact ); } =head2 deregisterNamespace =over =item * used to remove a Namespace from the controlled vocabulary =item * will fail if that namespace is being used by any services =item * you will recieve an email for confirmation of the deregistration =back Input XML : MyNamespace Ouptut XML : ...Registration Object... =cut sub deregisterNamespace { $CONFIG ||= MOBY::Config->new; # exported by Config.pm my $adaptor = $CONFIG->getDataAdaptor( datasource => 'mobycentral' ); my ( $pkg, $payload ) = @_; my $OntologyServer = &_getOntologyServer( ontology => 'namespace' ); return &_error( "Message Format Incorrect", "" ) unless ($payload); my ($term) = &_deregisterNamespacePayload($payload); $debug && &_LOG("deregister namespaceType accession $term\n"); return &_error( "Must include a Namespace type to deregister.", "" ) unless ($term); my ( $success, $message, $existingURI ) = $OntologyServer->namespaceExists( term => $term ); return &_error( "Namespace Type $term does not exist", "" ) unless ($existingURI); my ($err, $errstr) = $adaptor->check_namespace_usage(namespace_type_uris => $existingURI, type => $term); return &_error( $errstr, "") if ($err); my ( $success2, $message2, $URI ) = $OntologyServer->deleteNamespace( term => $term ); ($success2 == 0) && return &_error( $message2, $URI ); return &_success( "Namespace type $term deregistered successfully.", $URI ); } #Eddie - converted sub _deregisterNamespacePayload { my ($payload) = @_; my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($payload); my $Object = $doc->getDocumentElement(); my $obj = $Object->nodeName; return undef unless ( $obj eq 'deregisterNamespace' ); return &_nodeTextContent( $Object, "namespaceType" ); } =head2 registerService =over 3 =item * all elements are required =item * a service must have at least one Input OR Output Object Class. Either Input or Output may be blank to represent "PUT" or "GET" services respectively =item * the contactEmail address must be valid, as it is used to authorize deregistrations and changes to the service you registered. =item * the "authoritativeService" tag is used to indicate whether or not the registered service is "authoritative" for that transformation. i.e. if anyone else were to perform the same transformation they would have to have obtained the information to do so from you. This is similar to, but not necessarily identical to, mirroring someone elses data, since the data in question may not exist prior to service invocation. =item * only Input Secondary articles are defined during registration; Output Secondary objects are entirely optional and may or may not be interpreted Client-side using their articleName tags. =item * Service Categories: =over 3 =item * moby - for services that use the MOBY SOAP messaging format and object structure (i.e. the objects used in service transaction inherit from the root 'Object' Class in the MOBY Class ontology). =over 2 =item * authURI - a URI representing your organization (e.g. yourdomain.com); no http-prefix, and no trailing path information is allowed. =item * serviceName - an arbitrary, but unique, name for your service within your authURI namespace =item * URL - the URL to a SOAP CGI server that can invoke a method as described by your serviceName =back =item * wsdl - for other SOAP services that do not use the MOBY messaging format. The other elements in the registration should be interpreted as follows: =over 2 =item * authURI - a URI representing your organization (e.g. yourdomain.com); no http-prefix, and no trailing path information is allowed. =item * serviceName - an arbitrary, but unique, name for your service within your authURI namespace =item * URL - the URL from which a WSDL document describing your service can be retrieved by an HTTP GET call. =back =item * Comments about Input and Output for MOBY and non-MOBY services =over 2 =item * in "moby" services, the input and output messaging structure is defined by the BioMOBY API, and the services use data Objects that are defined in the Class ontology as inheriting from the root "Object" Class. =item * For "wsdl" services, there is additional flexibility: =over 2 =item * Similar to a "moby" service, your "wsdl" service must consume/produce named data types. These are represented as LSID's =item * YOU DO NOT NEED TO REGISTER THESE DATA TYPES in MOBY Central; it is up to you what your LSID's represent, and MOBY Central WILL NOT try to resolve them! =item * You may mix ontologies when describing your service - i.e. you may freely use any MOBY Object as your input or (XOR) your output and use a non-MOBY object (LSID) for the alternate so long as you follow the MOBY message structure for the parameter that uses the MOBY Object =over 2 =item * You may register, for example, a service that consumes a non-MOBY data Class and outputs a MOBY data class, so long as you follow the MOBY Messaging format for the output data =item * You may register, for example, a service that consumes a MOBY data Class and outputs a non-MOBY data class, so long as you follow the MOBY Messaging format for the input data =item * NOTE: Nether of the cases above are considered MOBY services, and are therefore described in the category of "soap" service =back =back =item * secondaryArticles - not applicable; should be left out of message. =back =back =back Input XML : moby YourServiceNameHere TypeOntologyTerm http://path.to/your/signature/RDF.rdf urn:lsid:biomoby.org:serviceinstance:myservice:version your.URI.here http://URL.to.your/Service.script; your_name@contact.address.com 1 | 0 Output XML : ...Registration Object... There are two forms of Primary articles: =over 3 =item * Simple - the article consists of a single MOBY Object =item * Collection - the article consists of a collection ("bag") of MOBY Objects (not necessarily the same object type). =over 3 =item * Their number/order is not relevant, nor predictable =item * If order is important to the service provider, then a collection should not be used, rather the collection should be broken into named Simple parameters. This may impose limitations on the the types of services that can be registered in MOBY Central. If it becomes a serious problem, a new Primary article type will be added in a future revision. =item * The use of more than one Class in a collection is difficult to interpret, though it is equally difficult to envision a service that would require this. It is purposely left losely defined since any given Service Instance can tighten up this definition during the registration process. =item * A collection may contain zero or more Objects of each of the Classes defined in the XML during Service Instance registration. =over 3 =item * Each distinct Object Class only needs to be included once in the XML. Additional entries of that Class within the same Collection definition must be ignored. =back =back =back An example of the use of each of these might be another BLAST service, where you provide the sequences that make up the Blast database as well as the sequence to Blast against it. The sequences used to construct the database might be passed as a Collection input article containing multiple Sequence Objects, while the sequence to Blast against it would be a Simple input article consisting of a single Sequence Object. There is currently only one form of Secondary article: =over 3 =item * Secondary - the article may or may not be specifically configured by the client as Input, and may or may not be returned by the Service as output. =over 3 =item * In the case of inputs, they are generally user-configurable immediately prior to service invocation. =item * During service invocation a Client must send all Secondary articles defined in the Service Instance, even if no value has been provided either as default, or Client-side. =item * Secondary articles that are considered "required" by the Service should be registered with a default value. =item * The Service may fail if an unacceptable value is passed for any Secondary Article. =back =back Articles are, optionally, named using the articleName attribute. This might be used if, for example, the service requires named inputs. The order of non-named articles in a single Input or Output set MUST not be meaningful. The XML structure of these articles is as follows: =over 3 =item * Simple (note that the lsid attribute of the objectType and Namespace element need only be present in the article when it is present in a response document from MOBY Central such as the result of a findService call. These attributes are ignored by MOBY Central when they appear in input messages such as registerService) ObjectOntologyTerm NamespaceTerm ... =item * Collection note that articleName of the contained Simple objects is not required, and is ignored. ...... ...... =item * Secondary Integer|Float|String|DateTime ... ... ... ... ... =back =cut # inputXML (FOR CGI GET SERVICES): # # cgi # YourServiceNameHere # YourServiceTypeHere # your.URI.here # blah@blow.com # http://URL.to.your/CGI.pl # your.URI.here # # # # # # # # # # # sub registerService { my ( $pkg, $payload ) = @_; my ( $serviceName, $serviceType, $AuthURI, $contactEmail, $URL, $authoritativeService, $desc, $Category, $INPUTS, $OUTPUTS, $SECONDARY, $signatureURL, $serviceLSID ) = &_registerServicePayload($payload); #--------RDFagent call---------------------------------------- # THIS IS A CALL TO moby cENTRAL REGISTER SERVICE THAT CONTAINED ONLY A sIGNATUREURL # THE IMPLICATION IS THAT THEY ARE ASKING YOU TO VISIT THEIR urL now!!!! if ( defined $signatureURL ) { my $ch = 0; my $i; # first check if any other parameters were filled-in. If so, then the implication is that they want us to register based on the data they have provided foreach $i ( $serviceName, $serviceType, $AuthURI, $contactEmail, $URL, $desc) { if ( defined $i && $i ne "") { $ch = 1; } } if ( $ch == 0 ) { my $conf = MOBY::Config->new(); my $path = $conf->{mobycentral}->{rdfagent}; #Assumes JAVA_HOME is set!!! my $JAVA_HOME = $ENV{JAVA_HOME} || ""; if ($JAVA_HOME) { $JAVA_HOME .="/bin/java"; } else { $JAVA_HOME ="java"; } $signatureURL =~ s/\s+//g; my $exit = system ("$JAVA_HOME", "-DRDFagent.home=$path", '-jar', $path. '/RDFagent.jar','-url',$signatureURL); my $rez = _how_exit($exit); return &_success( "The RDFagent call was successful.", "","" ) if ( $rez == 0 ); return &_error( "The call to the RDF agent resulted in failure. The agent encountered problems communicating with the registry. Please try again.", "" ) if ( $rez == 10 ); return &_error( "The call to agent failed because the agent is using a bad URL/URI for the registry. Please contact the registry's administrator and let them know.", "" ) if ( $rez == 11 ); return &_error( "The RDF agent call was partially successful, but there was an internal error. Please let the administrator of the registry know about this problem.", "" ) if ( $rez == 12 ); return &_error( "No services in the registry match the given URL and the signatureURL didn't contain any services. The RDF agent was called, but found nothing useful.", "" ) if ( $rez == 13 ); return &_success( "The RDFagent call was successful. All services described by $signatureURL have been removed because the URL was unreachable.", "","" ) if ( $rez == 14 ); return &_error( "The call to the RDF agent resulted in failure and I am not sure why. Please try again and if the error persists, let the administrator of the registry know.", "" ) if ( $rez != 0 ); } } #--------------------------------------------------------------- $authoritativeService = (defined($authoritativeService) && $authoritativeService) ? 1 : 0; my $error; $error .= "missing serviceName \n" unless defined $serviceName; $error .= "missing serviceType \n" unless defined $serviceType; $error .= "invalid character string for serviceName. Must start with a letter followed by [A-Za-z0-9_]\n" if ($serviceName =~ /^[^A-Za-z]/); $error .= "invalid character string for serviceName. Must start with a letter followed by [A-Za-z0-9_]\n" if ($serviceName =~ /^.+?[^A-Za-z0-9_]/); $error .= "service name may not contain spaces or other characters invalid in a URN" if $serviceName =~ /[\/\'\\\s"\&\<\>\[\]\^\`\{\|\}\~%\!\@#\$\*\+=]/; # $error .="missing signatureURL \n" unless defined $signatureURL; $error .= "missing authURI \n" unless defined $AuthURI; $error .= "invalid character encoding; authURI not encoded as UTF-8\n" unless decode_utf8( $AuthURI ) eq $AuthURI; $error .= "missing contactEmail \n" unless defined $contactEmail; $error .= "invalid character encoding; contactEmail not encoded as UTF-8\n" unless decode_utf8( $contactEmail ) eq $contactEmail; return &_error( "Malformed authURI - must not have an http:// prefix", "" ) if $AuthURI =~ '[/:]'; return &_error( "Malformed authURI - must take the form NNN.NNN.NNN", "" ) unless $AuthURI =~ /\./; return &_error("Malformed email - must be a valid email address of the form name\@organization.foo","") unless $contactEmail =~ /\S\@\S+\.\S+/; $error .= "missing URL \n" unless defined $URL; $error .= "invalid character encoding; URL not encoded as UTF-8\n" unless decode_utf8( $URL ) eq $URL; $error .= "missing description \n" unless defined $desc; $error .= "invalid character encoding; description not encoded as UTF-8\n" unless decode_utf8( $desc ) eq $desc; $error .= "missing Category \n" unless defined $Category; $error .= "invalid character encoding; service name not encoded as UTF-8\n" unless decode_utf8( $serviceName ) eq $serviceName; return &_error( "malformed payload $error\n\n", "" ) if ($error); return &_error( "Category may take the (case sensitive) values 'moby', 'moby-async', 'cgi', 'cgi-async', 'doc-literal', and 'doc-literal-async', \n", "" ) unless ( ( $Category eq "wsdl" ) || ( $Category eq "moby" ) || ( $Category eq "moby-async" ) || ( $Category eq "cgi" ) || ( $Category eq "cgi-async" ) || ( $Category eq "doc-literal" ) || ( $Category eq "doc-literal-async")); #test the existence of the service return &_error( "This service already exists", "" ) if (MOBY::service_instance->new( servicename => $serviceName, authority_uri => $AuthURI, test => 1)); my @IN = @{$INPUTS}; my @OUT = @{$OUTPUTS}; my @SECS = @{$SECONDARY}; return &_error( "must include at least one input and/or one output object type", "" ) unless ( scalar @IN || scalar @OUT ); my %objects_to_be_validated; foreach ( @IN, @OUT ) { foreach my $objectName ( &_extractObjectTypes($_) ) { $objects_to_be_validated{$objectName} = 1; } } my $OS = MOBY::OntologyServer->new( ontology => 'object' ); foreach ( keys %objects_to_be_validated ) { my ( $valid, $message, $URI ) = $OS->objectExists( term => $_ ); return &_error( "$message", "$URI" ) unless ( $valid || ( ( $_ =~ /urn:lsid/i ) && !( $_ =~ /urn:lsid:biomoby.org/i ) ) ); # either valid, or a non-moby LSID } $debug && &_LOG( "\n\n\aall objects okay - either valid MOBY objects, or LSID's\n"); $OS = MOBY::OntologyServer->new( ontology => 'service' ); my ( $valid, $message, $URI ) = $OS->serviceExists( term => $serviceType ); #print STDERR "\n\nChecking $URI\n\n"; return &_error( "$message", "$URI" ) unless ( $valid || ( ( $serviceType =~ /urn:lsid/i ) && !( $serviceType =~ /urn:lsid:biomoby.org/i ) ) ); # either valid, or a non-MOBY LSID #print STDERR "\n\nChecking $URI OK!!\n\n"; # right, registration should be successful now! my $SVC = MOBY::service_instance->new( category => $Category, servicename => $serviceName, service_type => $serviceType, authority_uri => $AuthURI, url => $URL, contact_email => $contactEmail, authoritative => $authoritativeService, description => $desc, signatureURL => $signatureURL, lsid => $serviceLSID ); return &_error( "Service registration failed for unknown reasons", "" ) if ( !defined $SVC ); $debug && &_LOG("new service instance created\n"); foreach my $IN (@IN) { my ( $success, $msg ) = &_registerArticles( $SVC, "input", $IN, undef ); unless ( $success == 1 ){ $SVC->DELETE_THYSELF; return &_error("Registration Failed During INPUT Article Registration: $msg", "" ) } } foreach my $OUT (@OUT) { my ( $success, $msg ) = &_registerArticles( $SVC, "output", $OUT, undef ); unless ( $success == 1 ){ $SVC->DELETE_THYSELF; return &_error("Registration Failed During OUTPUT Article Registration: $msg", "" ) } } foreach my $SEC (@SECS) { my ( $success, $msg ) = &_registerArticles( $SVC, "secondary", $SEC, undef ); unless ( $success == 1 ){ $SVC->DELETE_THYSELF; return &_error("Registration Failed During SECONDARY Article Registration: $msg", "" ) } } # we're going to do a findService here to find the service that we just created # and use the resulting XML to create a MOBY::Client::ServiceInstance object # that we can then use to retrieve the RDF for that service signature. # this is roundabout, I agree, but it is the most re-usable way to go at # the moment. my ( $si, $reg ) = &findService( '', " $AuthURI; $serviceName; " ); unless ($si) { $SVC->DELETE_THYSELF; return &_error("Registration Failed - newly registered service could not be discovered",""); } my $RDF = _getServiceInstanceRDF(name=>$serviceName, auth=>$AuthURI); unless ($RDF) { return &_success( "Registration successful but unable to create RDF - please contact your MOBY Central administrator", $SVC->lsid, "" ); } unless ( $RDF =~ /RDF/ ) { return &_success( "Registration successful but RDF is not correctly formatted:\n\n $RDF", $SVC->lsid, "" ); } # wrap RDF in CDATA - moved it here, so that we can return the 'bad' rdf above return &_success( "Registration successful", $SVC->lsid, "" ); } sub _getServiceInstanceRDF { my ( %args ) = @_; my $x = MOBY::RDF::Ontologies::Services->new; my $xml = ""; eval { $xml = $x->findService( { serviceName => $args{name}, authURI => $args{auth}, isAlive => 'no' } ); }; if ($@) { return ""; } print STDERR "$xml\n"; if ($x) { return "$xml" unless ( $xml =~ /title>Service Instance Not FoundnodeType == ELEMENT_NODE; # this is a Simple, Collection, or Parameter object my $simp_coll = $node->nodeName; $debug && &_LOG("TAGNAME in $inout _registerArticle is $simp_coll"); my $article = $node->getAttributeNode("articleName"); if ($article) { $article = $article->getValue(); } return (-1,"Invalid articlename name found. Articlenames may not contain spaces or other special characters.") if $article =~ /([\+\=:\s\&\<\>\[\]\^\`\{\|\}\~\(\)\\\/\$\#\@\,\|\?\.!\*\;\'\"])/; #check encoding for those articles that are not the empty string or a string of whitespace return (-1,"Invalid character encoding; articlename not UTF-8 encoded.") unless decode_utf8( $article ) eq $article; $debug && &_LOG("ARTICLENAME in _registerArticle is $article"); if (lc($inout) eq "input"){ return (-1, "Input Simples and collections are required to have an articleName as of API version 0.86") if (!$article && !$collid); } my ( $object_type, @namespaces ); if ( $simp_coll eq "Collection" ) { $debug && &_LOG("Collection!\n"); my $collection_id; if ( $inout eq 'input' ) { $collection_id = $SVC->add_collection_input( article_name => $article ); } elsif ( $inout eq 'output' ) { $collection_id = $SVC->add_collection_output( article_name => $article ); } else { $SVC->DELETE_THYSELF; return ( -1, "found article that was neither input nor output" ); } my $Simples = $node->getElementsByTagName('Simple'); my $length = $Simples->size(); unless ( $length > 0 ) { return ( -1,"Your collection must be a collection of one Simple type" ); } unless ( $length == 1 ) { return ( -1,"As of API v0.86, Collections must not be of more than one Simple type" ); } for ( my $x = 1 ; $x <= $length ; ++$x ) { my ( $success, $message ) = &_registerArticles( $SVC, $inout, $Simples->get_node($x), $collection_id ); unless ( $success == 1 ) { return ( -1, $message ); } } } elsif ( $simp_coll eq "Simple" ) { my $article = $node->getAttributeNode("articleName"); $article = $article->getValue() if $article; # get object type and its URI from the ontoogy server my $types = $node->getElementsByTagName('objectType'); my $OE = MOBY::OntologyServer->new( ontology => "object" ); foreach ( $types->get_node(1)->childNodes ) { # should only ever be one! ( $_->nodeType == TEXT_NODE ) && ( $object_type = $_->toString ); } my ( $success, $message, $typeURI ) = $OE->objectExists( term => $object_type ); if ( ( !($success) && ( $object_type =~ /urn:lsid:biomoby.org/i ) ) || ( !($success) && !( $object_type =~ /urn:lsid/i ) ) ) { # if the object doesn't exist, and it isn't an LSID $SVC->DELETE_THYSELF; return ( -1, "object: $object_type does not exist, and is not an LSID" ); } # kill it all unless this was successful! my $namespace_string; my $namespaces = $node->getElementsByTagName('Namespace'); my $num_ns = $namespaces->size(); $OE = MOBY::OntologyServer->new( ontology => "namespace" ); for ( my $n = 1 ; $n <= $num_ns ; ++$n ) { foreach my $name ( $namespaces->get_node($n)->childNodes ) { if ( $name->nodeType == TEXT_NODE ) { my $term = $name->toString; my ( $success, $message, $URI ) = $OE->namespaceExists( term => $term ); if ( ( !($success) && ( $term =~ /urn:lsid:biomoby.org/i ) ) || ( !($success) && !( $term =~ /urn:lsid/i ) ) ) { # if the object doesn't exist, and it isn't an LSID $SVC->DELETE_THYSELF; return ( -1, "namespace: $term doesn't exist and is not an LSID" ); } $namespace_string .= $URI . ","; } } } chop($namespace_string); # remove trailing comma my $service_instance_id; unless ($collid) { # this SIMPLE is either alone, or is part of a COLLECTION ($collid > 0) # therefore we want either its service instance ID, or its Collection ID. $service_instance_id = $SVC->service_instance_id; } # one or the other, but not both if ( $inout eq 'input' ) { my $sinput = $SVC->add_simple_input( object_type_uri => $typeURI, namespace_type_uris => $namespace_string, article_name => $article, collection_input_id => $collid, ); unless ($sinput) { $SVC->DELETE_THYSELF; return ( -1, "registration failed during registration of input object $typeURI. Unknown reasons."); } } elsif ( $inout eq 'output' ) { my $soutput = $SVC->add_simple_output( object_type_uri => $typeURI, namespace_type_uris => $namespace_string, article_name => $article, collection_output_id => $collid, ); unless ($soutput) { $SVC->DELETE_THYSELF; return ( -1,"registration failed during registration of output object $typeURI. Unknown reasons." ); } } } elsif ( $simp_coll eq "Parameter" ) { my $parameter = $node; my $article = $parameter->getAttributeNode("articleName"); $article = $article->getValue() if $article; return (-1,"Secondary inputs must be registered with articlenames.") unless $article; # make sure that the articlename is corrects return (-1,"Secondary input had an invalid articlename. Articlenames may not contain spaces or other special characters.") if $article =~ /([\+\=\':\s\"\&\<\>\[\]\^\`\{\|\}\~\(\)\\\/\$\#\@\,\|\?\.!\*\;])/; my ( $datatype, $def, $max, $min, $description, @enums ); my $types = $parameter->getElementsByTagName('datatype'); if ( $types->get_node(1) ) { foreach ( $types->get_node(1)->childNodes ) { # should only ever be one! ( $_->nodeType == TEXT_NODE ) && ( $datatype .= $_->nodeValue ); } } #ensure that thet type is correct (Integer | String | Float | DateTime| Boolean) $datatype =~ s/\s//g; my $secondaries = $CONFIG->{valid_secondary_datatypes}; my $valid; map { $valid = 1 if $datatype eq $_ } @{$secondaries}; unless ($valid) { $SVC->DELETE_THYSELF; return ( -1,"Registration failed. $datatype must be one of type Integer, String, DateTime, Boolean or Float." ); } my $defs = $parameter->getElementsByTagName('default'); if ( $defs->get_node(1) ) { foreach ( $defs->get_node(1)->childNodes ) { # should only ever be one! ( $_->nodeType == TEXT_NODE ) && ( $def .= $_->nodeValue ); } } my $maxs = $parameter->getElementsByTagName('max'); if ( $maxs->get_node(1) ) { foreach ( $maxs->get_node(1)->childNodes ) { # should only ever be one! ( $_->nodeType == TEXT_NODE ) && ( $max .= $_->nodeValue ); } } my $mins = $parameter->getElementsByTagName('min'); if ( $mins->get_node(1) ) { foreach ( $mins->get_node(1)->childNodes ) { # should only ever be one! ( $_->nodeType == TEXT_NODE ) && ( $min .= $_->nodeValue ); } } my $descs = $parameter->getElementsByTagName('description'); if ( $descs->get_node(1) ) { foreach ( $descs->get_node(1)->childNodes ) { # should only ever be one! ( $_->nodeType == TEXT_NODE ) && ( $description .= $_->nodeValue ); } } my $enums = $parameter->getElementsByTagName('enum'); my $numenums = $enums->size(); for ( my $n = 1 ; $n <= $numenums ; ++$n ) { foreach ( $enums->get_node($n)->childNodes ) { # should only ever be one! ( $_->nodeType == TEXT_NODE ) && ( push @enums, $_->nodeValue ); } } my $enum_string = join "", ( map { $_ . "," } @enums ); chop $enum_string; # get rid of trailing comma $datatype =~ s/^\s+//; $datatype =~ s/\s+$//; $def =~ s/^\s+//; $def =~ s/\s+$//; $max =~ s/^\s+//; $max =~ s/\s+$//; $min =~ s/^\s+//; $min =~ s/\s+$//; my $sec = $SVC->add_secondary_input( default_value => $def, maximum_value => $max, minimum_value => $min, enum_value => $enum_string, datatype => $datatype, article_name => $article, description => $description, ); unless ($sec) { $SVC->DELETE_THYSELF; return ( -1, "registration failed during registration of parameter $article. Must be of type Integer, String, DateTime, or Float." ); } } return 1; } #Eddie - converted sub _registerServicePayload { my ($payload) = @_; my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($payload); my $Object = $doc->getDocumentElement(); my $obj = $Object->nodeName; return undef unless ( $obj eq 'registerService' ); my $serviceName = &_nodeTextContent( $Object, "serviceName" ); my $Category = &_nodeTextContent( $Object, "Category" ); my $serviceType = &_nodeTextContent( $Object, "serviceType" ); my $AuthURI = &_nodeTextContent( $Object, "authURI" ); my $contactEmail = &_nodeTextContent( $Object, "contactEmail" ); my $authoritativeService = &_nodeTextContent( $Object, "authoritativeService" ); my $URL = &_nodeTextContent( $Object, "URL" ); my $signatureURL = &_nodeTextContent( $Object, "signatureURL" ); my $serviceLSID = &_nodeTextContent( $Object, "serviceLSID" ); my $desc = &_nodeCDATAContent( $Object, "Description" ); my $INPUTS = &_nodeRawContent( $Object, "Input" ); # returns array ref my $OUTPUTS = &_nodeRawContent( $Object, "Output" ); # returns array ref my $SECONDARIES = &_nodeRawContent( $Object, "secondaryArticles" ); # returns array ref return ( $serviceName, $serviceType, $AuthURI, $contactEmail, $URL, $authoritativeService, $desc, $Category, $INPUTS, $OUTPUTS, $SECONDARIES, $signatureURL, $serviceLSID ); } #Eddie - converted sub _extractObjectTypes { my ($DOM) = @_; # DOM is either a or a article $debug && &_LOG("\n\n\nExtracting object types from \n$DOM \n\n"); unless ( ref($DOM) =~ /^XML/ ) { my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($DOM); $DOM = $doc->getDocumentElement(); } my $x = $DOM->getElementsByTagName("objectType"); my @objectnames; my $l = $x->size(); # might be a Collection object with multiple simples... for ( my $n = 1 ; $n <= $l ; ++$n ) { my @child = $x->get_node($n)->childNodes; foreach (@child) { $debug && &_LOG( getNodeTypeName($_), "\t", $_->toString, "\n" ) ; #hopefully uses MobyXMLConstants.pm next unless ( $_->nodeType == TEXT_NODE ); my $name = $_->toString; chomp $name; push @objectnames, $name; } } return (@objectnames); } =head2 registerServiceWSDL Title : NOT YET IMPLEMENTED Usage : =cut sub registerServiceWSDL { my ( $pkg, $serviceType, $wsdl ) = @_; return &_error( "not yet implemented", "" ); } =head2 deregisterService Title : deregisterService Usage : $REG = $MOBY->deregisterService($inputXML) Function : deregister a Service Returns : $REG object inputXML : biomoby.org MyFirstService ouptutXML : see Registration XML object =cut sub deregisterService { my ( $pkg, $payload ) = @_; $debug && &_LOG("\nstarting deregistration\n"); my ( $authURI, $serviceName ) = &_deregisterServicePayload($payload); return &_error( "must provide an authority and a service name\n", "" ) unless ( $authURI && $serviceName ); return &_error("The service specified by authority=$authURI servicename=$serviceName does not exist in the registry","") unless ( MOBY::service_instance->new( servicename => $serviceName, authority_uri => $authURI, test => 1 )); my $SERVICE = MOBY::service_instance->new( servicename => $serviceName, authority_uri => $authURI ); return &_error("service lookup failed for unknown reasons","") unless ($SERVICE); if ( $SERVICE->signatureURL ) { return &_error( "it is illegal to deregister a service that has a signatureURL. Such services must be deregistered by deleting the RDF at the location identified by the signatureURL", "" ); } my $result = $SERVICE->DELETE_THYSELF; if ($result) { return &_success( "Service Deregistered Successfully", "" ); } else { return &_error( "Service deletion failed for unknown reasons", "" ); } } #Eddie - converted sub _deregisterServicePayload { my ($payload) = @_; $debug && &_LOG( "deregisterService payload: ", ($payload), "\n" ); my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($payload); my $Object = $doc->getDocumentElement(); my $obj = $Object->nodeName; #Eddie - unsure return undef unless ( $obj eq 'deregisterService' ); my $authURI = &_nodeTextContent( $Object, "authURI" ); my $name = &_nodeTextContent( $Object, "serviceName" ); return ( $authURI, $name ); } =head2 findService inputXML: ServiceQueryObject XML: To query MOBY Central, you fill out the relevant elements of a Query Ojbect. These include the input and/or output data Classes (by name from the Class ontology), the Service-type (by name from the Service-type ontology), the authority (service provider URI), or any number of keywords that must appear in the service description. =over 3 =item * MOBY Central finds all services which match the contents of the Query Object. =item * All elements are optional, however at least one must be present. =item * All elements present are considered as increasingly limiting on the search (i.e. "AND"). =item * keywords are: =over 3 =item * comma-delimited =item * sentence-fragments are enclosed in double-quotes =item * wildcard "*" is allowed in combination with keyword fragments and or sentence fragments (lone "*" is meaningless and ignored) =item * multiple keywords are considered joined by "AND". =back =back In addition to the search parameters, there are two "flags" that can be set in the Query object: =over 3 =item * expandServices: this flag will cause MOBY Central to traverse the Service ontology and discover services that are child types (more specific) than the Service-type you requested e.g. you might request "alignment", and it would discover services such as "Blast", "Smith Waterman", "Needleman Wunsch" =item * expandObjects: this flag will cause MOBY Central to traverse the Class ontology to find services that operate not only on the Object Class you are querying, but also any parent types or sub-objects of that Object Class. e.g. if you request services that work on AnnotatedSequence Objects this flag will also return services that work on Sequence objects, since AnnotatedSequence objects inherit from Sequence objects =back The Query object structure is as follows: 1 moby ServiceTypeTerm ServiceName http://desired.service.provider; http://location.of.document/signature.rdf 1|0 1|0 something .... .... outputXML Service_Ontology_Term moby 1 your@email.address http://endpoint.of.service ... ... ... =cut sub findService { $CONFIG ||= MOBY::Config->new; # exported by Config.pm my $adaptor = $CONFIG->getDataAdaptor( datasource => 'mobycentral' ); my ( $pkg, $payload ) = @_; $debug && &_LOG("\nLOOKING FOR SERVICES\n"); my %findme = &_findServicePayload($payload); $debug && &_LOG( "'serviceType' => $findme{serviceType}, 'authURI' => $findme{authURI}, 'servicename' => $findme{servicename}, 'expandObjects' => $findme{expandObjects}, 'expandServices' => $findme{expandServices}, 'authoritative' => $findme{authoritative}, 'category' => $findme{category}, 'signatureurl' => $findme{signatureURL}, 'keywords' => $findme{keywords}, " ); my %valid_service_ids; my $criterion_count = 0; # we want to avoid joins, since they slow things down, so... # the logic is that we keep a hash of valid id's # and the number of times they are discovered # we also count the number of criterion # we only want the service_id's that appear as many times as the criterion we have # since they will have matched every criterion. if ( $findme{authoritative} ) { ++$criterion_count; $debug && _LOG( "authoritative added; criterion count is now $criterion_count\n"); my $ids = _extract_ids($adaptor->query_service_instance(authoritative => $findme{authoritative})); ### MARK - we need to extract ids at each step... unless ( scalar @{$ids} ) { return &_serviceListResponse(undef ); } $debug && _LOG( "services " . ( join ',', @{$ids} ) . " incrememted\n" ); foreach ( @{$ids} ) { $debug && &_LOG("found service_instance_id $_\n"); ++$valid_service_ids{$_}; # increment that particular id's count by one } } if ( $findme{serviceType} ) { # must have something more than empty content my $OS = MOBY::OntologyServer->new( ontology => 'service' ); $findme{serviceType} =~ s/^moby\://; my ( $exists, $message, $URI ) = $OS->serviceExists( term => $findme{serviceType} ); unless ($exists) { return &_serviceListResponse(undef ); } ++$criterion_count; $debug && _LOG( "serviceType added; criterion count is now $criterion_count\n"); my $children_string = "'$URI',"; if ( $findme{'expandServices'} ) { $debug && _LOG("Expanding Services\n"); my $OS = MOBY::OntologyServer->new( ontology => 'service' ); my %relationships = %{ $OS->traverseDAG( $URI, "leaves" ) }; my (@children) = @{ $relationships{'urn:lsid:biomoby.org:servicerelation:isa'} }; $children_string .= ( join ',', map { "\'$_\'" } @children ); #*******FIX this isn't very perlish... sending a comma-delimited string to a subroutine instead of an array # need to change that one day soon! } $children_string =~ s/\,$//; my $ids = _extract_ids($adaptor->match_service_type_uri(service_type_uri => $children_string)); $debug && _LOG( "services " . ( join ',', @{$ids} ) . " incrememted\n" ); foreach ( @{$ids} ) { $debug && &_LOG("found service_instance_id $_\n"); ++$valid_service_ids{$_}; # increment that particular id's count by one } } if ( $findme{authURI} ) { ++$criterion_count; $debug && _LOG("authURI added; criterion count is now $criterion_count\n"); my $ids = _extract_ids($adaptor->query_service_instance(authority_uri => $findme{'authURI'})); unless ( scalar @{$ids} ) { return &_serviceListResponse(undef ); } $debug && _LOG( "services " . ( join ',', @{$ids} ) . " incrememted\n" ); foreach ( @{$ids} ) { $debug && &_LOG("found service_instance_id $_\n"); ++$valid_service_ids{$_}; # increment that particular id's count by one } } if ( $findme{signatureurl} ) { ++$criterion_count; $debug && _LOG("sigurl added; criterion count is now $criterion_count\n"); my $ids = _extract_ids($adaptor->query_service_instance(signatureURL => $findme{'signatureurl'})); unless ( scalar @{$ids} ) { return &_serviceListResponse(undef ); } $debug && _LOG( "services " . ( join ',', @{$ids} ) . " incrememted\n" ); foreach ( @{$ids} ) { $debug && &_LOG("found service_instance_id $_\n"); ++$valid_service_ids{$_}; # increment that particular id's count by one } } if ( $findme{servicename} ) { ++$criterion_count; $debug && _LOG( "servicename added; criterion count is now $criterion_count\n"); my $ids = _extract_ids($adaptor->query_service_instance(servicename => $findme{servicename})); unless ( scalar @{$ids} ) { return &_serviceListResponse( undef ); } $debug && _LOG( "services " . ( join ',', @{$ids} ) . " incrememted\n" ); foreach ( @{$ids} ) { $debug && &_LOG("found service_instance_id $_\n"); ++$valid_service_ids{$_}; # increment that particular id's count by one } } if ( $findme{category} ) { ++$criterion_count; $debug && _LOG("category added; criterion count is now $criterion_count\n"); my $ids = _extract_ids($adaptor->query_service_instance(category => lc( $findme{category}) )); unless ( scalar @{$ids} ) { return &_serviceListResponse( undef ); } $debug && _LOG( "services " . ( join ',', @{$ids} ) . " incrememted\n" ); foreach ( @{$ids} ) { $debug && &_LOG("found service_instance_id $_\n"); ++$valid_service_ids{$_}; # increment that particular id's count by one } } if ( $findme{keywords} && ( scalar @{ $findme{keywords} } ) ) { ++$criterion_count; $debug && _LOG("Keywords added; criterion count is now $criterion_count\n"); my ($ids) = $adaptor->check_keywords(keywords => \@{$findme{keywords}}); $ids = _extract_ids($ids); # this is the hash-list that comes back from do_query unless ( scalar @{$ids} ) { return &_serviceListResponse( undef ); } $debug && _LOG( "services " . ( join ',', @{$ids} ) . " incrememted\n" ); foreach ( @{$ids} ) { $debug && &_LOG("found service_instance_id $_\n"); ++$valid_service_ids{$_}; # increment that particular id's count by one } } if ( $findme{inputObjects} && ( scalar @{ $findme{inputObjects} } ) ) { ++$criterion_count; $debug && _LOG( "inputObject added; criterion count is now $criterion_count\n"); my $obj = ( shift @{ $findme{inputObjects} } ); my @si_ids; @si_ids = &_searchForServicesWithArticle( "input", $obj,$findme{'expandObjects'}, '' ) if defined $obj; $debug && _LOG("Initial Search For Services with INPUT Article found @si_ids\n"); my %instances; # we need to do a join, without doing a join... if ( scalar @si_ids ) { map { $instances{$_} = 1 } @si_ids; # get an id of the good services from the first object while ( my $obj = shift( @{ $findme{inputObjects} } ) ) { # iterate through the rest of the objects next unless $obj; $debug && _LOG( "FIRST: ", "input", $obj, $findme{'expandObjects'}, '' ); my @new_ids = &_searchForServicesWithArticle("input", $obj,$findme{'expandObjects'}, '' ); # get their service ids $debug && _LOG("Subsequent Search For Services with INPUT Article found @new_ids\n"); my @good_ids; my %good_ids; foreach my $id (@new_ids) { # check the new id set against the set we know is already valid next unless defined $id; if ( $instances{$id} ) { push @good_ids, $id; } # if they are in common, then that id is still good } map { $good_ids{$_} = 1 } @good_ids; # make a hash of the new good id's %instances = %good_ids ; # and replace the original list with this more limited one } } # now %instances contains only valid ID numbers $debug && _LOG( "Final results incremented of search for INPUT: " . ( join ',', ( keys %instances ) ) . "\n" ); foreach ( keys %instances ) { $debug && &_LOG("found id $_\n"); ++$valid_service_ids{$_}; } } if ( $findme{outputObjects} && ( scalar @{ $findme{outputObjects} } ) ) { ++$criterion_count; $debug && _LOG( "outputObject added; criterion count is now $criterion_count\n"); my $obj = ( shift @{ $findme{outputObjects} } ); my @si_ids; @si_ids = &_searchForServicesWithArticle("output", $obj, '' )if defined $obj; $debug && _LOG( "Initial Search For Services with OUTPUT Article found @si_ids\n"); my %instances; # we need to do a join, without doing a join... if ( scalar @si_ids ) { map { $instances{$_} = 1 } @si_ids; # get an id of the good services from the first object while ( my $obj = shift( @{ $findme{outputObjects} } ) ) { # iterate through the rest of the objects next unless $obj; my @new_ids = &_searchForServicesWithArticle("output", $obj, '' ) ; # get their service ids $debug && _LOG("Subsequent Search For Services with OUTPUT Article found @new_ids\n" ); my @good_ids; my %good_ids; foreach my $id (@new_ids) { # check the new id set against the set we know is already valid next unless defined $id; if ( $instances{$id} ) { push @good_ids, $id; } # if they are in common, then that id is still good } map { $good_ids{$_} = 1 } @good_ids; # make a hash of the new good id's %instances = %good_ids ; # and replace the original list with this more limited one } } # now %instances contains only valid ID numbers $debug && _LOG( "Final results incremented of search for OUTPUT: " . ( join ',', ( keys %instances ) ) . "\n" ); foreach ( keys %instances ) { $debug && &_LOG("found id $_\n"); ++$valid_service_ids{$_}; } } unless ($criterion_count){ # in case all criterion are null, find everything ++$criterion_count; # this is an AWFUL hack. We need to add a criterion in order for teh next while loop to be successful in finding each of these services. This is really really terrible, but it works until someone tries to "fix" something... my $ids = _extract_ids($adaptor->query_service_instance(category => "IS NOT NULL" )); unless ( scalar @{$ids} ) { return &_serviceListResponse( undef ); } foreach ( @{$ids} ) { $debug && &_LOG("found service_instance_id $_\n"); ++$valid_service_ids{$_}; # increment that particular id's count by one } } my @final; while ( my ( $id, $freq ) = each %valid_service_ids ) { $debug && _LOG( "TALLY IS ID: $id FREQ:$freq\n CRITERION COUNT $criterion_count\n" ); next unless $freq == $criterion_count; # has to have matched every criterion push @final, $id; } return &_serviceListResponse(@final ); } sub _extract_ids { my ($linehash) = @_; # ths data comes from the do_query of the mysql call # --> [{...}] my @lines = @$linehash; return [] unless scalar(@lines); my @ids; foreach (@lines){ my $id = $_->{service_instance_id}; push @ids, $id; } return \@ids } sub _how_exit { my ($exit) = @_; my ($status) = $exit >> 8; my ($signal) = $exit & 255; return $status unless $signal; return $signal; } #Eddie - converted sub _searchForServicesWithArticle { my ($inout, $node, $expand, $coll ) = @_; return () unless $node->nodeType == ELEMENT_NODE; # this will erase all current successful service instances! $debug && _LOG( "searchServWthArticle ", $inout, $node, $expand, $coll ); # this element node may be a Simple or a Collection object my $simp_coll = $node->nodeName; $debug && &_LOG("TAGNAME in _searchForArticle is $simp_coll"); my @valid_ids; if ( $simp_coll eq "Collection" ) { @valid_ids = &_searchForCollection( $node, $expand, $inout ); } elsif ( $simp_coll eq "Simple" ) { @valid_ids = &_searchForSimple( $node, $expand, $inout ); } return @valid_ids; } sub _searchForSimple { $CONFIG ||= MOBY::Config->new; # exported by Config.pm my $adaptor = $CONFIG->getDataAdaptor( datasource => 'mobycentral' ); # returns list of service_instance ID's # that match this simple my ( $node, $expand, $inout ) = @_; $debug && _LOG( $node, $expand, $inout ); my ( $objectURI, $namespaceURIs ) = &_extractObjectTypesAndNamespaces($node); # (objectType, [ns1, ns2, ns3]) unless ($objectURI) { return () } my $ancestor_string = "'$objectURI',"; if ($expand) { $debug && _LOG("Expanding Objects\n"); my $OS = MOBY::OntologyServer->new( ontology => 'object' ); my %relationships = %{ $OS->traverseDAG( $objectURI, "root" ) }; my (@ancestors) = @{ $relationships{'urn:lsid:biomoby.org:objectrelation:isa'} }; $ancestor_string .= ( join ',', map { "\'$_\'" } @ancestors ); } $ancestor_string =~ s/\,$//; my $result = $adaptor->find_by_simple(inout => $inout, ancestor_string => $ancestor_string, namespaceURIs => $namespaceURIs); my @valid_services; foreach my $row (@$result) { # get the service instance ID and the namespaces that matched my $id = $row->{service_instance_id}; my $nss = $row->{namespace_type_uris}; if ( $nss && scalar @{$namespaceURIs} ) { # if this service cares about namespaces at all, # and if namespaces were specified in the query, # then validate the discovered service against this list my @ns = split ",", $nss ; # because of the database structure we have to re-test for *identity*, not just like%% similarity my %nshash = map { ( $_, 1 ) } @ns, @{ $namespaceURIs }; #we're going to test identity by building a hash of namespaces as keys if ( scalar( keys %nshash ) < scalar(@ns) + scalar( @{$namespaceURIs} ) ) { # if the number of keys is less than the sum of the number of keys goign into the hash, then one of them was identical push @valid_services, $id; # and therefore it really is a match, and is valid } } else { # if no namespace was specified, then all of them are valid push @valid_services, $id; } } $debug && _LOG( "Resulting IDs were " . ( join ',', @valid_services ) . "\n" ); return @valid_services; } #Eddie - converted sub _searchForCollection { $CONFIG ||= MOBY::Config->new; # exported by Config.pm my $adaptor = $CONFIG->getDataAdaptor( datasource => 'mobycentral' ); my ( $node, $expand, $inout ) = @_; # $node in this case is a Collection object # luckily, we can return a redundant list of service id's and # this will be cleaned up in the caller my @validservices; foreach my $simple ( $node->childNodes() ) { next unless ( $simple->nodeType == ELEMENT_NODE ); next unless ( $simple->nodeName =~ /simple/i ); my ( $objectURI, $namespaceURIs ) = &_extractObjectTypesAndNamespaces($simple); my $result = $adaptor->find_by_collection(inout => $inout, objectURI => $objectURI, namespaceURIs => $namespaceURIs); foreach my $row (@$result ) { # get the service instance ID and the namespaces that matched my $id = $row->{service_instance_id}; my $nss = $row->{namespace_type_uris}; if ( $nss && scalar @{$namespaceURIs} ) { # if this service cares about namespaces at all, # and if namespaces were specified in the query, # then validate the discovered service against this list my @ns = split ",", $nss ; # because of the database structure we have to re-test for *identity*, not just like%% similarity my %nshash = map { ( $_, 1 ) } @ns, @{ $namespaceURIs }; #we're going to test identity by building a hash of namespaces as keys if ( scalar( keys %nshash ) < scalar(@ns) + scalar( @{$namespaceURIs} ) ) { # if the number of keys is less than the sum of the number of keys goign into the hash, then one of them was identical push @validservices, $id; # and therefore it really is a match, and is valid } } else { # if no namespace was specified, then all of them are valid push @validservices, $id; } } } return @validservices; } #Eddie - converted sub _findServicePayload { my ($payload) = @_; my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($payload); my $Object = $doc->getDocumentElement(); my $obj = $Object->nodeName; return undef unless ( $obj eq 'findService' ); my $serviceType = &_nodeTextContent( $Object, "serviceType" ); $serviceType && ( $serviceType =~ s/\s+//g ); my $servicename = &_nodeTextContent( $Object, "serviceName" ); $servicename && ( $servicename =~ s/\s+//g ); my $authoritative = &_nodeTextContent( $Object, "authoritative" ); $authoritative && ( $authoritative =~ s/\s+//g ); my $Category = &_nodeTextContent( $Object, "Category" ); $Category && ( $Category =~ s/\s+//g ); my $AuthURI = &_nodeTextContent( $Object, "authURI" ); $AuthURI && ( $AuthURI =~ s/\s+//g ); # add signatureURL to the list of things to find my $signatureURL = &_nodeTextContent( $Object, "signatureURL" ); $signatureURL && ( $signatureURL =~ s/\s+//g ); my $expandObjects = &_nodeTextContent( $Object, "expandObjects" ); $expandObjects && ( $expandObjects =~ s/\s+//g ); my $expandServices = &_nodeTextContent( $Object, "expandServices" ); $expandServices && ( $expandServices =~ s/\s+//g ); my @kw = &_nodeArrayContent( $Object, "keywords" ); my $INPUTS = &_nodeRawContent( $Object, "Input" ); # returns array ref my $OUTPUTS = &_nodeRawContent( $Object, "Output" ); # returns array ref return ( 'serviceType' => $serviceType, 'authURI' => $AuthURI, 'signatureurl' => $signatureURL, 'servicename' => $servicename, 'expandObjects' => $expandObjects, 'expandServices' => $expandServices, 'authoritative' => $authoritative, 'category' => $Category, 'inputObjects' => $INPUTS, 'outputObjects' => $OUTPUTS, 'keywords' => \@kw ); } #Eddie - converted sub _extractObjectTypesAndNamespaces { # takes a SINGLE simple article and return regular list ($objectURI, [nsURI1, nsURI2, nsURI3]) my ($DOM) = @_; $debug && &_LOG( "\n\n_extractObjectTypesAndNamespaces\nExtracting object types from \n$DOM \n\n" ); unless ( ref($DOM) =~ /^XML/ ) { my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($DOM); $DOM = $doc->getDocumentElement(); } my $x = $DOM->getElementsByTagName("objectType"); my $objectname; my @child = $x->get_node(1)->childNodes; foreach (@child) { $debug && &_LOG( getNodeTypeName($_), "\t", $_->toString, "\n" ); next unless ( $_->nodeType == TEXT_NODE ); my $name = $_->toString; chomp $name; $objectname = $name; } $objectname =~ s/^moby\:// ; # damn XML DOM can't deal with namespaces... so get rid of it if it exists, though this is going to limit us to only MOBY objects again :-( my $OS = MOBY::OntologyServer->new( ontology => 'object' ); my ( $exists, $message, $objectURI ) = $OS->objectExists( term => $objectname ); return ( undef, [] ) unless $objectURI; my $ns = $DOM->getElementsByTagName("Namespace"); my @namespaces; my $nonamespaces = $ns->size(); $OS = MOBY::OntologyServer->new( ontology => 'namespace' ); for ( my $n = 1 ; $n <= $nonamespaces ; ++$n ) { my @child = $ns->get_node($n)->childNodes; foreach (@child) { $debug && &_LOG( getNodeTypeName($_), "\t", $_->toString, "\n" ); next unless ( $_->nodeType == TEXT_NODE ); my $name = $_->toString; chomp $name; my ( $success, $message, $URI ) = $OS->namespaceExists( term => $name ); $URI ? ( push @namespaces, $URI ) : ( push @namespaces, "__MOBY__INVALID__NAMESPACE__" ); } } return ( $objectURI, \@namespaces ); } =head2 retrieveService Title : retrieveService Usage : $WSDL = $MOBY->retrieveService($inputXML) Function : get the WSDL descriptions for services with this service name Returns : XML (see below) Comment : the WSDL that you get back is invalid w.r.t. the object structure It will always be so. It should be used only to create stubs for the connection to the service. inputXML : outputXML (by category): moby: =cut sub retrieveService { my ( $pkg, $payload ) = @_; my ( $AuthURI, $serviceName, $InputXML, $OutputXML, $SecondaryXML ) = &_retrieveServicePayload($payload); unless ( $AuthURI && $serviceName ) { return "" } my $SI = MOBY::service_instance->new( authority_uri => $AuthURI, servicename => $serviceName ); my $servlsid = $SI->lsid; my $wsdls; return "" unless ($SI); &listener(authority => $AuthURI, servicename => $serviceName); # log the requst for research purposes my $wsdl = &_getServiceWSDL( $SI, $InputXML, $OutputXML, $SecondaryXML ); if ($wsdl) { if ( $wsdl =~ /[^\]]+))\]\]>/ ) { $wsdl = $1; } $wsdls .= "\n"; } #$debug && &_LOG("WSDL_________________$wsdls\n____________________"); return $wsdls; } #Eddie - converted sub _retrieveServicePayload { my ($payload) = @_; my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($payload); my $x = $doc->getElementsByTagName("Service"); my $authURI = ""; my $serviceName = ""; my $l = $x->size(); # might be a Collection object with multiple simples... for ( my $n = 1 ; $n <= $l ; ++$n ) { $authURI = $x->get_node($n)->getAttributeNode("authURI") ; # may or may not have a name if ($authURI) { $authURI = $authURI->getValue() } $serviceName = $x->get_node($n)->getAttributeNode("serviceName") ; # may or may not have a name if ($serviceName) { $serviceName = $serviceName->getValue() } } my $INPUT = $doc->getElementsByTagName("Input"); my $InputXML = ""; if ( $INPUT->get_node(1) ) { $InputXML = $INPUT->get_node(1)->toString; } my $OUTPUT = $doc->getElementsByTagName("Output"); my $OutputXML = ""; if ( $OUTPUT->get_node(1) ) { $OutputXML = $OUTPUT->get_node(1)->toString; } my $SECONDARY = $doc->getElementsByTagName("Output"); my $SecondaryXML = ""; if ( $SECONDARY->get_node(1) ) { $SecondaryXML = $SECONDARY->get_node(1)->toString; } return ( $authURI, $serviceName, $InputXML, $OutputXML, $SecondaryXML ); } =head2 retrieveResourceURLs Title : retrieveResourceURLs Usage : $urls = $MOBY->retrieveResourceURLs Function : to retrieve the location(s) of the RDF versions of the various MOBY-S Ontologies Args : none Returns : XML (see below). The "name" attribute indicates which ontology is described by the URL (Service, Object, Namespace, ServiceInstance, Full), and the "url" attribute provides a URL that, when called with an HTTP GET, will return RDF-XML describing that ontology. XML : =cut sub retrieveResourceURLs { $CONFIG ||= MOBY::Config->new; # exported by Config.pm my $central = $CONFIG->{mobycentral}->{resourceURL}; my $service = $CONFIG->{mobyservice}->{resourceURL}; my $namespace = $CONFIG->{mobynamespace}->{resourceURL}; my $object = $CONFIG->{mobyobject}->{resourceURL}; my $all = $CONFIG->{mobycentral}->{allResources}; my $message =""; $message .="" if $central; $message .="" if $object; $message .="" if $service; $message .="" if $namespace; $message .="" if $all; $message .=""; return $message; } =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 : ... ... =cut sub retrieveServiceProviders { $CONFIG ||= MOBY::Config->new; # exported by Config.pm my $adaptor = $CONFIG->getDataAdaptor( datasource => 'mobycentral' ); my ($pkg) = @_; my $result = $adaptor->get_all_authorities(); my $providers = "\n"; foreach my $prov (@$result) { $providers .= "\n"; } $providers .= "\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 : ... ... =cut sub retrieveServiceNames { $CONFIG ||= MOBY::Config->new; # exported by Config.pm my $adaptor = $CONFIG->getDataAdaptor( datasource => 'mobycentral' ); my ($pkg) = shift; my $result = $adaptor->get_service_names(); my $names = "\n"; foreach my $row (@$result) { my $name = $row->{servicename}; my $auth = $row->{authority_uri}; my $lsid = $row->{lsid}; $names .= "\n"; } $names .= "\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 : your@email.here authority.uri.here parentTypeName ... ... =cut sub retrieveServiceTypes { my ($pkg) = @_; my $OS = MOBY::OntologyServer->new( ontology => 'service' ); my %types = %{ $OS->retrieveAllServiceTypes() }; my $types = "\n"; while ( my ( $serv, $descr ) = each %types ) { #UNCOMMENT my ($desc, $lsid, $contact, $auth, $isa_type, $isa_lsid) = @$descr; if ( $desc =~ /[^\]]+))\]\]>/ ) { $desc = $1; } $isa_type ||=""; $isa_lsid ||=""; $types .=" $contact $auth $isa_type \n"; #UNCOMMENT } $types .= "\n"; return $types; } =head2 retrieveRelationshipTypes Title : retrieveRelationshipTypes Usage : $types = $MOBY->retrieveRelationshipTypes($xml) Function : get the list of all registered relationship types in the given ontology Returns : XML (see below) Args : input XML (ontologies are 'object', 'service', 'namespace', 'relationship') Input XML : OntologyName Output XML: ... ... =cut #Eddie - converted sub retrieveRelationshipTypes { my ( $pkg, $payload ) = @_; my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($payload); my $ontology = &_nodeTextContent( $doc, "Ontology" ); my $OS = MOBY::OntologyServer->new( ontology => 'relationship' ); my %types = %{ $OS->getRelationshipTypes( ontology => $ontology ) }; my $types = "\n"; while ( my ( $lsid, $authdesc ) = each %types ) { my $name = $authdesc->[0]; my $auth = $authdesc->[1]; my $desc = $authdesc->[2]; if ( $desc =~ /[^\]]+))\]\]>/ ) { $desc = $1; } $types .="\n\n\n"; } $types .= "\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 : ... ... =cut sub retrieveObjectNames { my ($pkg) = @_; my $OS = MOBY::OntologyServer->new( ontology => 'object' ); my %types = %{ $OS->retrieveAllObjectTypes() }; my $obj = "\n"; while ( my ( $name, $descr ) = each %types ) { my ($desc, $lsid) = @$descr; if ( $desc =~ /[^\]]+))\]\]>/ ) { $desc = $1; } $obj .="\n\n\n"; } $obj .= "\n"; return $obj; } =head2 retrieveObjectDefinition Title : retrieveObjectDefinition Usage : $registerObjectXML = $MOBY->retrieveObjectDefinition($inputXML) Function : get the full description of an object, as registered Returns : see input XML for registerObjectClass Input XML : ExistingObjectClassname Ouptut XML : NewObjectType ExistingObjectType ... ... owner.URI.here owner@their.address.com =cut #Eddie - converted sub retrieveObjectDefinition { my ( $pkg, $payload ) = @_; my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($payload); my $term = &_nodeTextContent( $doc, "objectType" ); return "" unless $term; my $OS = MOBY::OntologyServer->new( ontology => 'object' ); my $def = $OS->retrieveObject( node => $term ) ; # will return undef if this term does not exist, and does not look like an LSID return "" unless $def; my %def = %{ $OS->retrieveObject( type => $term ) }; if ( $def{description} =~ /[^\]]+))\]\]>/ ) { $def{description} = $1; } my $response; $response = " $def{objectType} $def{authURI} $def{contactEmail}\n"; my %relationships = %{ $def{Relationships} }; while ( my ( $rel, $objdefs ) = each %relationships ) { $response .= "\n"; foreach my $def ( @{$objdefs} ) { my ( $lsid, $articlename,$type, $def, $auth, $contac ) = @{$def}; $articlename = "" unless defined $articlename; $response .= "$type\n"; } $response .= "\n"; } $response .= "\n"; return $response; } =head2 retrieveNamespaces Title : retrieveNamespaces Usage : $ns = $MOBY->retrieveNamespaces() Function : get the list of all registered Object types Returns : XML (see below) Args : none XML : email@address.here authority.uri.here ... ... =cut sub retrieveNamespaces { my ($pkg) = @_; my $OS = MOBY::OntologyServer->new( ontology => 'namespace' ); my %types = %{ $OS->retrieveAllNamespaceTypes() }; my $ns = "\n"; while ( my ( $namespace, $descr ) = each %types ) { my ($desc, $lsid, $auth, $contact) = @$descr; if ( $desc =~ /[^\]]+))\]\]>/ ) { $desc = $1; } # $ns .= "\n\n\n"; #COMMENT/REMOVE $ns .= "\n\n$contact\n$auth\n\n";#UNCOMMENT } $ns .= ""; return $ns; } =head2 retrieveObject NOT YET IMPLEMENTED Title : retrieveObject Usage : $objects = $MOBY->retrieveObject($inputXML) Function : get the object xsd Returns : XML (see below) Args : $name - object name (from ontology) or "all" to get all objects inputXML : ObjectType | all outputXML : ... ... =cut sub retrieveObject { my ( $pkg, $payload ) = @_; my $response = "\n"; $response .= "\n"; $response .= "\n"; return $response; } #Eddie - converted sub _retrieveObjectPayload { my ($payload) = @_; my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($payload); my $Object = $doc->getDocumentElement(); my $obj = $Object->nodeName; return undef unless ( $obj eq 'retrieveObject' ); my $type = &_nodeTextContent( $Object, "objectType" ); return ($type); } =head2 Relationships Title : Relationships Usage : $ns = $MOBY->Relationships() Function : get the fist level of relationships for the given term Returns : output XML (see below) Args : Input XML (see below). Notes : expandRelationships behaviour - for ISA relationships means traverse to root/leaves - for HAS and HASA means traverse ISA to root/leaves and for each node in the ISA hierarchy return the HAS/HASA relationship partners, where 'root' matches container objects and 'leaves' matches contained objects. Example: suppose a relationship "objA HAS objB", a) if query is objectType=>objA, direction=>'root', relationship=>'HAS', then objB is in result set b) if query is objectType=>objB, direction=>'leaves', relationship=>'HAS', then objA is in result set input XML : $term 1|0 root|leaves $relationship_term ... more relationship types ... OR $term 1|0 root|leaves $relationship_term ... more relationship types ... outputXML : ExistingObjectType ExistingObjectType .... OR ExistingServiceType ExistingServiceType .... =cut sub Relationships { my ( $pkg, $payload ) = @_; my $ontology; my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($payload); my $x = $doc->getElementsByTagName("relationshipType"); my $l = $x->size(); my $exp = $doc->getElementsByTagName("expandRelationship"); my $expl = $exp->size(); my $expand_relationship = &_nodeTextContent( $doc, 'expandRelationship' ); $expand_relationship =~ s/\s//g; $expand_relationship ||= 0; # find out direction: my $direction = &_nodeTextContent( $doc, "direction" ); $direction = 'root' unless $direction; # make root default to stay compatible # it has to be either 'leaves' or 'root' $direction = ($direction eq 'leaves') ? 'leaves' : 'root'; my %reltypes; my $relationship; for ( my $n = 1 ; $n <= $l ; ++$n ) { my @child = $x->get_node($n)->childNodes; foreach (@child) { next unless ( $_->nodeType == TEXT_NODE ); my $name .= $_->toString; $name =~ s/\s//g; $reltypes{$name} = 1; # make a hash of desired relationship types $reltypes{isa}=1; $reltypes{hasa}=1, etc } } # are we working on a service or an object? my $term = &_nodeTextContent( $doc, "objectType" ); $ontology = "object" if $term; # pick up the ontology "object" that we used here if we got an object term $term ||= &_nodeTextContent( $doc, "serviceType" ); # if we didn't get anything using objectType try serviceType return undef unless $term; # and bail out if we didn't succeed $ontology ||= "service"; # if we have now succeeded and haven't already taken the ontology then it must be the service ontology $debug && &_LOG("Ontology was $ontology; Term was $term\n"); ## replace $reltypes{isa}=1 with $reltypes{urn:lsid:...:isa}= 1 #foreach ( keys %reltypes ) { # for each of our desired types # my $rellsid = $OSrel->getRelationshipURI( $ontology, $_ ); # get the LSID # delete $reltypes{$_}; # remove the non-LSID version from the hash # $reltypes{$rellsid} = 1; # set the LSID as valid #} my $response = "\n"; # outermost tag containing individual relationship blocks my %relationships_found; # the final list of discovered relationships my $OS = MOBY::OntologyServer->new( ontology => $ontology ); foreach $relationship(keys %reltypes){ # we are going to concatenate the hashes here; keys are "ISA", "HASA", etc %relationships_found =(%relationships_found, %{ $OS->Relationships( # concatentate (%a,%b) --> %rels = $rels{relationship_lsid} = [lsid, lsid,lsid] term => $term, expand => $expand_relationship, relationship => $relationship, direction => $direction, )}); # %relationships_found = $rels{relationship_lsid} = [lsid, lsid,lsid] } my $OSrel = MOBY::OntologyServer->new( ontology => 'relationship' ); # now for each of the relationship types that we were returned foreach my $this_rel( keys %reltypes ) { # keys are "isa" or "hasa"... my $rellsid = $OSrel->getRelationshipURI( $ontology, $this_rel ); # convert ISA to urn:lsid...:isa next unless $rellsid; next unless $relationships_found{$rellsid}; # e.g. $rels{urn:lsid...isa}=["urn:lsid...:Object","urn:lsid...:VirtSeq"] my @lsids_articles = @{$relationships_found{$rellsid}}; next unless scalar @lsids_articles; $response .= "\n"; foreach my $lsid_article ( @lsids_articles ) { my $lsid = $lsid_article->{lsid}; my $term = $lsid_article->{term}; if ($this_rel =~ /isa/i){ $response .= "<${ontology}Type lsid='$lsid' "; $response .= ">$term\n"; } else { my @articleNames = keys %{$lsid_article->{'articleName'}}; foreach my $articleName(@articleNames){ $response .= "<${ontology}Type lsid='$lsid' "; $response .= "articleName='$articleName'" if $articleName; # wont be there for Service type ontology $response .= ">$term\n"; } } } $response .= "\n"; } $response .= "\n"; return $response; } =head2 DUMP_MySQL Title : DUMP_MySQL Usage : $SQL = $MOBY->DUMP_MySQL; ($central,$object,$service,$namespace,$relat) = @{$SQL}; Function : return a mysql dump of each of the current MOBY Central databases Returns : an array of SQL strings that can be used to recreate the database locally Args : none =cut sub DUMP_MySQL { my ($pkg) = @_; my $config = MOBY::Config->new(); my @dbsections = ( 'mobycentral', 'mobyobject', 'mobyservice', 'mobynamespace', 'mobyrelationship' ); my @response; foreach my $dbsection (@dbsections) { my $dbname = ${ ${$config}{$dbsection} }{'dbname'}; my $username = ${ ${$config}{$dbsection} }{'username'}; my $password = ${ ${$config}{$dbsection} }{'password'}; my $host = ${ ${$config}{$dbsection} }{'url'}; my $port = ${ ${$config}{$dbsection} }{'port'}; open( IN, "mysqldump -h $host -P $port -u $username --password=$password $dbname|" ) || die "can't open $dbname for dumping"; my @dbdump; while () { push @dbdump, $_; } my $dbdump = ( join "", @dbdump ); push @response, $dbdump; } return [@response]; } *DUMP = \&DUMP_MySQL; # alias it for backward compatibility #sub _flatten { # $CONFIG ||= MOBY::Config->new; # exported by Config.pm # my $adaptor = $CONFIG->getDataAdaptor( datasource => 'mobycentral' ); # # # from a given term, traverse the ontology # # and flatten it into a list of parent terms # my ( $dbh, $type, $term, $seen ) = @_; # # my $result = $adaptor->get_parent_terms(relationship_type_id => $type, # term => $term); # # foreach my $row (@$result) { # my $term = $row->{term}; # next if ${$seen}{$term}; # &_flatten( $dbh, $type, $term, $seen ); # ${$seen}{$term} = 1; # } #} #Eddie - Converted sub _ISAPayload { my ($payload) = @_; my $Parser = XML::LibXML->new(); my $doc = $Parser->parse_string($payload); my $Object = $doc->getDocumentElement(); my $obj = $Object->nodeName; return undef unless ( $obj eq 'ISA' ); my $type = &_nodeTextContent( $Object, "objectType" ); return ($type); } =cut =head1 Internal Object Methods =cut =head2 _getValidServices Title : _getValidServices Usage : %valid = $MOBY->_getValidServices($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 ($sth_hash, $query, $max_return ) = @_; # my %sth = %{$sth_hash}; # $debug && &_LOG("QUERY: \n$query\n\n"); # my $this_query = $dbh->prepare($query); # $this_query->execute; # my $response; # my %seen; # $response = "\n"; # # while ( my ( $serviceName, $objectOUT, $AuthURI, $desc, $type, $cat ) = # $this_query->fetchrow_array() ) # { # $debug # && &_LOG("$serviceName, $objectOUT, $AuthURI,$desc, $type, $cat\n"); # next # if $seen{ "$AuthURI" . "||" # . "$serviceName" }; # non-redundant list please # $seen{ "$AuthURI" . "||" . "$serviceName" } = 1; # $response .= # "\n"; # $response .= "$cat\n"; # $response .= "$type\n"; # $response .= "$objectOUT\n"; # if ( $desc =~ /[^\]]+))\]\]>/ ) { # $desc = $1; # } # $response .= "\n"; # $response .= "\n"; # if ($max_return) { --$max_return; last unless $max_return } # } # $response .= "\n"; # $debug && &_LOG("\nFINAL RESPONSE IS \n$response\n\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 ( $SI, $InputXML, $OutputXML, $SecondaryXML ) = @_; # the lines below causes no end of grief. It is now in a variable. #open (WSDL, "./MOBY/Central_WSDL_SandR.wsdl") || die "can't open WSDL file for search and replace\n"; #my $wsdl = join "", (); #close WSDL; # do substitutions my $serviceType = $SI->category; my $wsdl; if ($serviceType eq "cgi"){ $wsdl = &_doPostWSDLReplacement(@_) } elsif ($serviceType eq "moby"){ $wsdl = &_doMobyWSDLReplacement(@_) } elsif ($serviceType eq "moby-async"){ $wsdl = &_doAsyncWSDLReplacement(@_) } elsif ($serviceType eq "cgi-async"){ $wsdl = &_doAsyncPostWSDLReplacement(@_) } return $wsdl; } sub _doAsyncWSDLReplacement { # this routine does not work at the moment # we're just waiting for an example of an async # wsdl document from IMB my ( $SI, $InputXML, $OutputXML, $SecondaryXML ) = @_; my $wsdl = $WSDL_ASYNC_TEMPLATE; $wsdl =~ s/^\n//gs; my $serviceName = $SI->servicename; my $AuthURI = $SI->authority_uri; my $desc = $SI->description; if ( $desc =~ /[^\]]+))\]\]>/ ) { $desc = $1; } $desc =~ s"\<"<"g; # XMl encode now that it is not CDATAd $desc =~ s"\>">"g; # XML encode now that it is not CDATAd my $URL = $SI->url; my $IN = "NOT_YET_DEFINED_INPUTS"; my $OUT = "NOT_YET_DEFINED_OUTPUTS"; my $INxsd = &_getInputXSD( $InputXML, $SecondaryXML ); my $OUTxsd = &_getOutputXSD($OutputXML); $INxsd ||= ""; $OUTxsd ||= ""; $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 $wsdl =~ s/MOBY__SERVICE__NAME/$serviceName/g; # finally replace the actual subroutine call return $wsdl; } sub _doAsyncPostWSDLReplacement { my ( $SI, $InputXML, $OutputXML, $SecondaryXML ) = @_; my $wsdl = $WSDL_ASYNC_POST_TEMPLATE; $wsdl =~ s/^\n//gs; my $serviceName = $SI->servicename; my $AuthURI = $SI->authority_uri; my $desc = $SI->description; if ( $desc =~ /[^\]]+))\]\]>/ ) { $desc = $1; } $desc =~ s"\<"<"g; # XMl encode now that it is not CDATAd $desc =~ s"\>">"g; # XML encode now that it is not CDATAd my $URL = $SI->url; $URL =~ "(http://[^/]+)(/.*)"; my $baseURL = $1; my $relativeURL = $2; my $IN = "NOT_YET_DEFINED_INPUTS"; my $OUT = "NOT_YET_DEFINED_OUTPUTS"; my $INxsd = &_getInputXSD( $InputXML, $SecondaryXML ); my $OUTxsd = &_getOutputXSD($OutputXML); $INxsd ||= ""; $OUTxsd ||= ""; $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/$baseURL/g; # the URL to the service $wsdl =~ s/MOBY__SERVICE__POST/$relativeURL/g; # the URL to the service $wsdl =~ s/MOBY__SERVICE__NAME/$serviceName/g; # finally replace the actual subroutine call return $wsdl; } sub _doPostWSDLReplacement { my ( $SI, $InputXML, $OutputXML, $SecondaryXML ) = @_; my $wsdl = $WSDL_POST_TEMPLATE; $wsdl =~ s/^\n//gs; my $serviceName = $SI->servicename; my $AuthURI = $SI->authority_uri; my $desc = $SI->description; if ( $desc =~ /[^\]]+))\]\]>/ ) { $desc = $1; } $desc =~ s"\<"<"g; # XMl encode now that it is not CDATAd $desc =~ s"\>">"g; # XML encode now that it is not CDATAd my $URL = $SI->url; $URL =~ "(http://[^/]+)(/.*)"; my $baseURL = $1; my $relativeURL = $2; my $IN = "NOT_YET_DEFINED_INPUTS"; my $OUT = "NOT_YET_DEFINED_OUTPUTS"; my $INxsd = &_getInputXSD( $InputXML, $SecondaryXML ); my $OUTxsd = &_getOutputXSD($OutputXML); $INxsd ||= ""; $OUTxsd ||= ""; $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/$baseURL/g; # the URL to the service $wsdl =~ s/MOBY__SERVICE__POST/$relativeURL/g; # the URL to the service $wsdl =~ s/MOBY__SERVICE__NAME/$serviceName/g; # finally replace the actual subroutine call return $wsdl; } sub _doMobyWSDLReplacement { my ( $SI, $InputXML, $OutputXML, $SecondaryXML ) = @_; my $wsdl = $WSDL_TEMPLATE; $wsdl =~ s/^\n//gs; my $serviceName = $SI->servicename; my $AuthURI = $SI->authority_uri; my $desc = $SI->description; if ( $desc =~ /[^\]]+))\]\]>/ ) { $desc = $1; } $desc =~ s"\<"<"g; # XMl encode now that it is not CDATAd $desc =~ s"\>">"g; # XML encode now that it is not CDATAd my $URL = $SI->url; my $IN = "NOT_YET_DEFINED_INPUTS"; my $OUT = "NOT_YET_DEFINED_OUTPUTS"; my $INxsd = &_getInputXSD( $InputXML, $SecondaryXML ); my $OUTxsd = &_getOutputXSD($OutputXML); $INxsd ||= ""; $OUTxsd ||= ""; $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 $wsdl =~ s/MOBY__SERVICE__NAME/$serviceName/g; # finally replace the actual subroutine call return $wsdl } #sub _getCGIService { # my ( $dbh, $sth_hash, $id, $serviceName, $AuthURI, $URL, $desc, $category ) # = @_; # my %sth = %{$sth_hash}; # # # "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 = ? # my $sth = $dbh->prepare( $sth{get_server_parameters} ); # $sth->execute($id); # my ( $Object, $sprintf, $in ) = $sth->fetchrow_array(); # if ( $sprintf =~ /[^\]]+))\]\]>/ ) { # $sprintf = $1; # } # return ""; #} #Eddie - converted sub _nodeTextContent { # will get text of **all** child $node from the given $DOM # regardless of their depth!! my ( $DOM, $node ) = @_; $debug && &_LOG( "_nodeTextContent received DOM: ", $DOM->toString, "\nsearching for node $node\n" ); my $x = $DOM->getElementsByTagName($node); return undef unless $x->get_node(1); my @child = $x->get_node(1)->childNodes; my $content; foreach (@child) { $debug && &_LOG( $_->nodeType, "\t", $_->toString, "\n" ); #next unless $_->nodeType == TEXT_NODE; $content .= $_->textContent; } return $content; } sub _nodeCDATAContent { # will get text of **all** child $node from the given $DOM # regardless of their depth!! my ( $DOM, $node ) = @_; $debug && &_LOG( "_nodeTextContent received DOM: ", $DOM->toString, "\nsearching for node $node\n" ); my $x = $DOM->getElementsByTagName($node); return undef unless $x->get_node(1); my @child = $x->get_node(1)->childNodes; my $content; foreach (@child) { $debug && &_LOG( $_->nodeType, "\t", $_->toString, "\n" ); #next unless $_->nodeType == TEXT_NODE; if ( $_->toString =~ /[^\]]+))\]\]>/ ) { $content .= $1; } else { $content .= $_->textContent; } } return $content; } #Eddie - converted sub _nodeRawContent { # will get raw child nodes of $node from the given $DOM my ( $DOM, $nodename ) = @_; my @content; $debug && &_LOG( "_nodeRawContent received DOM: ", $DOM->toString, "\nsearching for node $nodename\n" ); my $x = $DOM->getElementsByTagName($nodename); my $node = $x->get_node(1); return [] unless $node; foreach my $child ( $node->childNodes ) { next unless $child->nodeType == ELEMENT_NODE; push @content, $child; } return \@content; } #Eddie - converted sub _nodeArrayContent { # will get array content of all child $node from given $DOM # regardless of depth! # e.g. the following XML: # # first # second # #will return the list "first", "second" my ( $DOM, $node ) = @_; $debug && &_LOG( "_nodeArrayContext received DOM: ", $DOM->toString, "\nsearching for node $node\n" ); my @result; my $x = $DOM->getElementsByTagName($node); return @result unless $x->get_node(1); my @child = $x->get_node(1)->childNodes; foreach (@child) { next unless $_->nodeType == ELEMENT_NODE; my @child2 = $_->childNodes; foreach (@child2) { #print getNodeTypeName($_), "\t", $_->toString,"\n"; next unless $_->nodeType == TEXT_NODE; next unless ( length( $_->toString ) > 0 ); push @result, $_->toString; } } $debug && _LOG("_nodeArrayContent resulted in @result\n"); return @result; } #Eddie - converted sub _nodeArrayExtraContent { # will get array content of all child $node from given $DOM # regardless of depth! # e.g. the following XML: # # first # second # #will return the list # ['first',{'articleName' => 'thisone'}], # ['second',{'articleName' => 'otherone'},... my ( $DOM, $node, @attrs ) = @_; $debug && &_LOG( "_nodeArrayExtraContext received DOM: ", $DOM->toString, "\nsearching for node $node\n" ); my @result; my %att_value; my $x = $DOM->getElementsByTagName($node); my @child = $x->get_node(1)->childNodes; foreach (@child) { next unless $_->nodeType == ELEMENT_NODE; foreach my $attr (@attrs) { $debug && &_LOG( "_nodeArrayExtraContext received DOM: ", $DOM->toString, "\nsearching for attributre $attr\n" ); my $article = $_->getAttributeNode($attr); # may or may not have a name if ($article) { $article = $article->getValue() } $att_value{$attr} = $article; } my @child2 = $_->childNodes; foreach (@child2) { #print getNodeTypeName($_), "\t", $_->toString,"\n"; next unless $_->nodeType == TEXT_NODE; push @result, [ $_->toString, \%att_value ]; } } $debug && &_LOG(@result); return @result; } sub _serviceListResponse { $CONFIG ||= MOBY::Config->new; # exported by Config.pm my $adaptor = $CONFIG->getDataAdaptor( datasource => 'mobycentral' ); my (@ids ) = @_; my $output = ""; my $OSobj = MOBY::OntologyServer->new( ontology => 'object' ); my $OSns = MOBY::OntologyServer->new( ontology => 'namespace' ); my $OSserv = MOBY::OntologyServer->new( ontology => 'service' ); my $root = new XML::LibXML::Element("Services"); foreach (@ids) { my $result = $adaptor->query_service_instance(service_instance_id => $_); my $row = shift(@$result); my $category = $row->{category}; my $url = $row->{url}; my $servicename = $row->{servicename}; my $service_type_uri = $row->{service_type_uri}; my $authority_uri = $row->{authority_uri}; my $desc = $row->{description}; my $authoritative = $row->{authoritative}; my $email = $row->{contact_email}; my $signatureURL = $row->{signatureURL}; my $lsid = $row->{lsid}; if ( $desc =~ /[^\]]+))\]\]>/ ) { $desc = $1; } $signatureURL ||= ""; next unless ( $servicename && $authority_uri ); my $service_type = $OSserv->getServiceCommonName($service_type_uri); my $serviceNode = new XML::LibXML::Element("Service"); $serviceNode->setAttribute("authURI",$authority_uri); $serviceNode->setAttribute("serviceName",$servicename); $serviceNode->setAttribute("lsid",$lsid); my $subElement = new XML::LibXML::Element("serviceType"); $subElement->setAttribute("lsid",$service_type_uri); $subElement->appendText($service_type); $serviceNode->appendChild($subElement); $subElement = new XML::LibXML::Element("authoritative"); $subElement->appendText($authoritative); $serviceNode->appendChild($subElement); $subElement = new XML::LibXML::Element("Category"); $subElement->appendText($category); $serviceNode->appendChild($subElement); $subElement = new XML::LibXML::Element("Description"); $subElement->appendChild(XML::LibXML::CDATASection->new($desc)); $serviceNode->appendChild($subElement); $subElement = new XML::LibXML::Element("contactEmail"); $subElement->appendText($email); $serviceNode->appendChild($subElement); $subElement = new XML::LibXML::Element("signatureURL"); $subElement->appendText($signatureURL); $serviceNode->appendChild($subElement); $subElement = new XML::LibXML::Element("URL"); $subElement->appendText($url); $serviceNode->appendChild($subElement); $subElement = new XML::LibXML::Element("Input"); #$output .= "\t\n"; #$output .= "\t$service_type\n"; #$output .= "\t$authoritative\n"; #$output .= "\t$category\n"; #$output .= "\t\n"; #$output .= "\t$email\n"; #$output .= "\t$signatureURL\n"; #$output .= "\t$url\n"; #$output .= "\t\n"; $result = $adaptor->query_simple_input(service_instance_lsid => $lsid); foreach my $row (@$result) { my $objURI = $row->{object_type_uri}; my $nsURI = $row->{namespace_type_uris}; my $article = $row->{article_name}; my $objName = $OSobj->getObjectCommonName($objURI); $nsURI ||= ""; my @nsURIs = split ",", $nsURI; $article ||= ""; my $simpleElement = new XML::LibXML::Element("Simple"); $simpleElement->setAttribute("articleName",$article); my $typeElement = new XML::LibXML::Element("objectType"); $typeElement->setAttribute("lsid", $objURI); $typeElement->appendText($objName); $simpleElement->appendChild($typeElement); #$output .= "\t\t\n"; #$output .= "\t\t\t$objName\n"; foreach my $ns (@nsURIs) { my $NSname = $OSns->getNamespaceCommonName($ns); #$output .= "\t\t\t$NSname\n" if $NSname; my $nsElement = new XML::LibXML::Element("Namespace"); $nsElement->setAttribute("lsid", $ns) if $NSname; $nsElement->appendText($NSname) if $NSname; $simpleElement->appendChild($nsElement) if $NSname; } #$output .= "\t\t\n"; $subElement->appendChild($simpleElement); } $result = $adaptor->query_collection_input(service_instance_lsid => $lsid); foreach my $row (@$result) { my $collid = $row->{collection_input_id}; my $articlename = $row->{article_name}; #$output .= "\t\t\n"; my $collectionElement = new XML::LibXML::Element("Collection"); $collectionElement->setAttribute("articleName",$articlename); my $result2 = $adaptor->query_simple_input(service_instance_lsid => undef, collection_input_id => $collid); foreach my $row2 (@$result2) { my $objURI = $row2->{object_type_uri}; my $nsURI = $row2->{namespace_type_uris}; my $article = $row2->{article_name}; my $objName = $OSobj->getObjectCommonName($objURI); $nsURI ||= ""; my @nsURIs = split ",", $nsURI; $article ||= ""; #$output .= "\t\t\t\n"; #$output .= "\t\t\t\t$objName\n"; my $simpleElement = new XML::LibXML::Element("Simple"); $simpleElement->setAttribute("articleName",$article); my $typeElement = new XML::LibXML::Element("objectType"); $typeElement->setAttribute("lsid", $objURI); $typeElement->appendText($objName); $simpleElement->appendChild($typeElement); foreach my $ns (@nsURIs) { my $NSname = $OSns->getNamespaceCommonName($ns); #$output .= "\t\t\t\t$NSname\n" if $NSname; my $nsElement = new XML::LibXML::Element("Namespace"); $nsElement->setAttribute("lsid", $ns) if $NSname; $nsElement->appendText($NSname) if $NSname; $simpleElement->appendChild($nsElement) if $NSname; } #$output .= "\t\t\t\n"; $collectionElement->appendChild($simpleElement); } $subElement->appendChild($collectionElement); #$output .= "\t\t\n"; } #$output .= "\t\n"; $serviceNode->appendChild($subElement); #$output .= "\t\n"; $subElement = new XML::LibXML::Element("Output"); $result = $adaptor->query_simple_output(service_instance_lsid => $lsid, collection_output_id => undef); foreach my $row (@$result) { my $objURI = $row->{object_type_uri}; my $nsURI = $row->{namespace_type_uris}; my $article = $row->{article_name}; my $objName = $OSobj->getObjectCommonName($objURI); $nsURI ||= ""; my @nsURIs = split ",", $nsURI; $article ||= ""; my $simpleElement = new XML::LibXML::Element("Simple"); $simpleElement->setAttribute("articleName",$article); my $typeElement = new XML::LibXML::Element("objectType"); $typeElement->setAttribute("lsid", $objURI); $typeElement->appendText($objName); $simpleElement->appendChild($typeElement); #$output .= "\t\t\n"; #$output .= "\t\t\t$objName\n"; foreach my $ns (@nsURIs) { my $NSname = $OSns->getNamespaceCommonName($ns); #$output .= "\t\t\t$NSname\n" if $NSname; my $nsElement = new XML::LibXML::Element("Namespace"); $nsElement->setAttribute("lsid", $ns) if $NSname; $nsElement->appendText($NSname) if $NSname; $simpleElement->appendChild($nsElement) if $NSname; } #$output .= "\t\t\n"; $subElement->appendChild($simpleElement); } $result = $adaptor->query_collection_output(service_instance_lsid => $lsid); foreach my $row (@$result) { my $collid = $row->{collection_output_id}; my $articlename = $row->{article_name}; #$output .= "\t\t\n"; my $collectionElement = new XML::LibXML::Element("Collection"); $collectionElement->setAttribute("articleName",$articlename); my $result2 = $adaptor->query_simple_output(service_instance_lsid => undef, collection_output_id => $collid); foreach my $row2 (@$result2 ) { my $objURI = $row2->{object_type_uri}; my $nsURI = $row2->{namespace_type_uris}; my $article = $row2->{article_name}; my $objName = $OSobj->getObjectCommonName($objURI); $nsURI ||= ""; my @nsURIs = split ",", $nsURI; $article ||= ""; #$output .= "\t\t\t\n"; #$output .= "\t\t\t\t$objName\n"; my $simpleElement = new XML::LibXML::Element("Simple"); $simpleElement->setAttribute("articleName",$article); my $typeElement = new XML::LibXML::Element("objectType"); $typeElement->setAttribute("lsid", $objURI); $typeElement->appendText($objName); $simpleElement->appendChild($typeElement); foreach my $ns (@nsURIs) { my $NSname = $OSns->getNamespaceCommonName($ns); #$output .= "\t\t\t\t$NSname\n" if $NSname; my $nsElement = new XML::LibXML::Element("Namespace"); $nsElement->setAttribute("lsid", $ns) if $NSname; $nsElement->appendText($NSname) if $NSname; $simpleElement->appendChild($nsElement) if $NSname; } #$output .= "\t\t\t\n"; $collectionElement->appendChild($simpleElement); } #$output .= "\t\t\n"; $subElement->appendChild($collectionElement); } #$output .= "\t\n"; $serviceNode->appendChild($subElement); #$output .= "\t\n"; $subElement = new XML::LibXML::Element("secondaryArticles"); $result = $adaptor->query_secondary_input(service_instance_lsid => $lsid); foreach my $row (@$result) { my($default_value, $maximum_value, $minimum_value, $enum_value, $datatype, $description,$article_name) = ("","","","","",""); $default_value = $row->{default_value}; $maximum_value = $row->{maximum_value}; $minimum_value = $row->{minimum_value}; $enum_value = $row->{enum_value}; $datatype = $row->{datatype}; $description = $row->{description}; $article_name = $row->{article_name}; my $parElement = new XML::LibXML::Element("Parameter"); $parElement->setAttribute("articleName",$article_name); $parElement->appendTextChild( "datatype" , $datatype); # TODO should this description be wrapped in CDATA?? $parElement->appendTextChild( "description" , $description); $parElement->appendTextChild( "default" , $default_value); $parElement->appendTextChild( "max" , $maximum_value); $parElement->appendTextChild( "min" , $minimum_value); #$output .= "\t\t\t\n"; #$output .= "\t\t\t\t$datatype\n"; #$output .= "\t\t\t\t$description\n"; #$output .= "\t\t\t\t$default_value\n"; #$output .= "\t\t\t\t$maximum_value\n"; #$output .= "\t\t\t\t$minimum_value\n"; my @enums = split ",", $enum_value; if ( scalar(@enums) ) { foreach my $enum (@enums) { #$output .= "\t\t\t\t$enum\n"; $parElement->appendTextChild( "enum" , $enum); } } else { #$output .= "\t\t\t\t\n"; $parElement->appendChild( new XML::LibXML::Element("enum") ); } #$output .= "\t\t\t\n"; $subElement->appendChild($parElement); } #$output .= "\t\t\n"; $serviceNode->appendChild($subElement); #$output .= "\t\n"; $root->appendChild($serviceNode); } return $root->toString(1); #return "\n$output\n\n"; } sub _error { my ( $message, $id ) = @_; $id ||=""; $message ||=""; my $reg = &Registration( { success => 0, message => "$message", id => "$id", } ); return $reg; } sub _success { my ( $message, $id, $RDF ) = @_; my $reg = &Registration( { success => 1, message => "$message", id => "$id", RDF => $RDF, } ); return $reg; } sub _getOntologyServer { # may want to make this more complex my (%args) = @_; my $OS = MOBY::OntologyServer->new(%args); return $OS; } sub DESTROY { } sub _LOG { return unless $debug; #print join "\n", @_; #print "\n---\n"; #return; open LOG, ">>/tmp/CentralRegistryLogOut.txt" or die "can't open mobycentral error logfile $!\n"; print LOG join "\n", @_; print LOG "\n---\n"; close LOG; } # # # -------------------------------------------------------------------------------------------------------- # ## ## =head2 _getInputXSD name : _getInputXSD($InputXML, $SecondaryXML) function: to get an XSD describing the input to a MOBY Service, e.g. to use in a WSDL document args : (see _serviceListResponse code above for full details of XML) $InputXML - the ... block of a findService response message $SecondaryXML - the ... fragment of a findService response message returns : XSD fragment of XML (should not return an XML header!) notes : the structure of an Input block is as follows: the structure of a secondaryArticle block is as follows: =over =item * Simple ObjectOntologyTerm NamespaceTerm ... =item * Collection note that articleName of the contained Simple objects is not required, and is ignored. ...... ...... =item * Secondary INT|FLOAT|STRING ... ... ... ... ... =back =cut sub _getInputXSD { my ( $Input, $Secondary ) = @_; my $XSD; return $XSD; } =head2 _getOuputXSD name : _getOutputXSD($OutputXML) function: to get an XSD describing the output from a MOBY Service e.g. to use in a WSDL document args : (see _serviceListResponse code above for full details) $InputXML - the ... block of a findService response message $SecondaryXML - the ... fragment of a findService response message returns : XSD fragment of XML (should not return an XML header!) notes : the structure of an Output block is as follows: =over =item * Simple ObjectOntologyTerm NamespaceTerm ... =item * Collection note that articleName of the contained Simple objects is not required, and is ignored. ...... ...... =back =cut sub _getOutputXSD { my ($Output) = @_; my $XSD; return $XSD; } =head2 WSDL_Templates =cut #=============================================== #=============================================== #=============================================== # Standard MOBY WSDL Template $WSDL_TEMPLATE = < END # MOBY CGI service template $WSDL_POST_TEMPLATE = < END2 $WSDL_ASYNC_POST_TEMPLATE =< END # for MOBY Asynchronous services. This WSDL is not correct YET! $WSDL_ASYNC_TEMPLATE = < END 1;