WSRF-Lite
view release on metacpan or search on metacpan
lib/WSRF/Lite.pm view on Meta::CPAN
# in any SOAP message we return from the service. The user can use the
# prefixs wsrl, wsrp and wsa and not have to worry about defining the
# namespaces
#
# WSRF::WSRFSerializer is were the message is signed - signing is tricky
# because we have to create the XML before we sign it, so the process of
# signing a SOAP message requires two passes through the serializer. The
# first pass (std_envelope) creates the SOAP message, the second actually
# signs it. THIS IS NOT EFFICIENT BUT WHO CARES?!
package WSRF::WSRFSerializer;
=pod
=head1 WSRF::WSRFSerializer
Overrides SOAP::Serializer. This class extends the SOAP::Serializer class which creates
the XML SOAP Enevlope. WSRF::WSRFSerializer overrides the "envelope" method so that it
adds the WSRF, WS-Addressing and WS-Security namespaces to the SOAP Envelope, it also
where the message signing happens. The XML SOAP message has to be created before it
can be signed.
=head2 METHODS
The methods are the same as SOAP::Serializer, the "envelope" method is overridden to
include the extra namespaces and to digitally sign the SOAP message if required.
=cut
use vars qw(@ISA);
@ISA = qw(SOAP::Serializer);
# This function is the same as SOAP::Serializer::envelope except that
# it adds an extra attribute (wsu:Id="myBody") into the Body element -
# this is used by WS-Security to identify the bits of a message that
# have been signed.
#
# We also add extra namespaces for WSRF and WSA into the SOAP Envelope
# element so we do not need to declare them in the message itself
# Copyright (C) 2000-2005 Paul Kulchenko (paulclinger@yahoo.com)
sub old_envelope {
SOAP::Trace::trace('()');
my $self = shift->new;
$self->autotype(0);
$self->attr(
{
'xmlns:wsa' => $WSRF::Constants::WSA,
'xmlns:wsrl' => $WSRF::Constants::WSRL,
'xmlns:wsrp' => $WSRF::Constants::WSRP,
'xmlns:wsu' => $WSRF::Constants::WSU,
'xmlns:wsse' => $WSRF::Constants::WSSE
}
);
my $type = shift;
my ( @parameters, @header );
for (@_) {
# Find all the SOAP Headers
if ( defined($_) && ref($_) && UNIVERSAL::isa( $_ => 'SOAP::Header' ) )
{
push( @header, $_ );
# Find all the SOAP Message Parts (attachments)
} elsif ( defined($_)
&& ref($_)
&& $self->context
&& $self->context->packager->is_supported_part($_) )
{
$self->context->packager->push_part($_);
# Find all the SOAP Body elements
} else {
push( @parameters, $_ );
}
}
my $header = @header ? SOAP::Data->set_value(@header) : undef;
my ( $body, $parameters );
if ( $type eq 'method' || $type eq 'response' ) {
SOAP::Trace::method(@parameters);
my $method = shift(@parameters);
# or die "Unspecified method for SOAP call\n";
$parameters = @parameters ? SOAP::Data->set_value(@parameters) : undef;
if ( !defined($method) ) {
} elsif ( UNIVERSAL::isa( $method => 'SOAP::Data' ) ) {
$body = $method;
} elsif ( $self->use_prefix ) {
$body = SOAP::Data->name($method)->uri( $self->uri );
} else {
$body =
SOAP::Data->name($method)->attr( { 'xmlns' => $self->uri } );
#$body = SOAP::Data->name($method)->uri($self->uri); # original return before use_prefix
}
# This is breaking a unit test right now...
$body->set_value(
SOAP::Utils::encode_data( $parameters ? \$parameters : () ) )
if $body;
} elsif ( $type eq 'fault' ) {
SOAP::Trace::fault(@parameters);
$body =
SOAP::Data->name(
SOAP::Utils::qualify( $self->envprefix => 'Fault' ) )
# parameters[1] needs to be escaped - thanks to aka_hct at gmx dot de
# commented on 2001/03/28 because of failing in ApacheSOAP
# need to find out more about it
# -> attr({'xmlns' => ''})
->value(
\SOAP::Data->set_value(
SOAP::Data->name(
faultcode => SOAP::Utils::qualify(
$self->envprefix => $parameters[0]
)
)->type(""),
SOAP::Data->name(
lib/WSRF/Lite.pm view on Meta::CPAN
SOAP::Utils::qualify( $self->envprefix => 'Header' ) =>
\$header
) : ()
),
(
$body
? SOAP::Data->name(
SOAP::Utils::qualify( $self->envprefix => 'Body' ) =>
\$body
)->attr( { 'wsu:Id' => $WSRF::WSS::ID{myBody} } )
: SOAP::Data->name(
SOAP::Utils::qualify( $self->envprefix => 'Body' )
)->attr( { 'wsu:Id' => $WSRF::WSS::ID{myBody} } )
),
)
)->attr( $self->attr )
);
$self->signature( $parameters->signature ) if ref $parameters;
# IMHO multirefs should be encoded after Body, but only some
# toolkits understand this encoding, so we'll keep them for now (04/15/2001)
# as the last element inside the Body
# v -------------- subelements of Envelope
# vv -------- last of them (Body)
# v --- subelements
push( @{ $encoded->[2]->[-1]->[2] }, $self->encode_multirefs )
if ref $encoded->[2]->[-1]->[2];
# Sometimes SOAP::Serializer is invoked statically when there is no context.
# So first check to see if a context exists.
# TODO - a context needs to be initialized by a constructor?
if ( $self->context && $self->context->packager->parts ) {
# TODO - this needs to be called! Calling it though wraps the payload twice!
# return $self->context->packager->package($self->xmlize($encoded));
}
return $self->xmlize($encoded);
}
sub std_envelope {
SOAP::Trace::trace('()');
my $self = shift->new;
my $type = shift;
$self->autotype(0);
$self->attr(
{
'xmlns:wsa' => $WSRF::Constants::WSA,
'xmlns:wsrl' => $WSRF::Constants::WSRL,
'xmlns:wsrp' => $WSRF::Constants::WSRP,
'xmlns:wsu' => $WSRF::Constants::WSU,
'xmlns:ds' => $WSRF::Constants::DS,
'xmlns:wsse' => $WSRF::Constants::WSSE
}
);
my ( @parameters, @header );
for (@_) {
# Find all the SOAP Headers
if ( defined($_) && ref($_) && UNIVERSAL::isa( $_ => 'SOAP::Header' ) )
{
push( @header, $_ );
# Find all the SOAP Message Parts (attachments)
} elsif ( defined($_)
&& ref($_)
&& $self->context
&& $self->context->packager->is_supported_part($_) )
{
$self->context->packager->push_part($_);
# Find all the SOAP Body elements
} else {
push( @parameters, SOAP::Utils::encode_data($_) );
}
}
my $header = @header ? SOAP::Data->set_value(@header) : undef;
my ( $body, $parameters );
if ( $type eq 'method' || $type eq 'response' ) {
SOAP::Trace::method(@parameters);
my $method = shift(@parameters);
# or die "Unspecified method for SOAP call\n";
$parameters = @parameters ? SOAP::Data->set_value(@parameters) : undef;
if ( !defined($method) ) {
} elsif ( UNIVERSAL::isa( $method => 'SOAP::Data' ) ) {
$body = $method;
} elsif ( $self->use_default_ns ) {
if ( $self->{'_ns_uri'} ) {
$body =
SOAP::Data->name($method)
->attr( { 'xmlns' => $self->{'_ns_uri'}, } );
} else {
$body = SOAP::Data->name($method);
}
} else {
# Commented out by Byrne on 1/4/2006 - to address default namespace problems
# $body = SOAP::Data->name($method)->uri($self->{'_ns_uri'});
# $body = $body->prefix($self->{'_ns_prefix'}) if ($self->{'_ns_prefix'});
# Added by Byrne on 1/4/2006 - to avoid the unnecessary creation of a new
# namespace
# Begin New Code (replaces code commented out above)
$body = SOAP::Data->name($method);
my $pre = $self->find_prefix( $self->{'_ns_uri'} );
$body = $body->prefix($pre) if ( $self->{'_ns_prefix'} );
# End new code
}
# This is breaking a unit test right now...
#$body->set_value(SOAP::Utils::encode_data($parameters ? \$parameters : ())) if $body;
$body->set_value( $parameters ? \$parameters : () ) if $body;
} elsif ( $type eq 'fault' ) {
SOAP::Trace::fault(@parameters);
$body =
lib/WSRF/Lite.pm view on Meta::CPAN
sub WSRFHandler {
my $request = shift @_;
#Only Handle GET and POST
return HTTP::Response->new(RC_FORBIDDEN)
if ( $request->method ne 'POST'
&& $request->method ne 'GET'
&& $request->method ne 'DELETE'
&& $request->method ne 'PUT' );
print STDERR "$$ WSRFHandler called\n";
my $Path = $request->uri->path;
#strip extra '/' at start of URL
$Path =~ s/^\/+//o;
#remeber the Path - we will put this in our responses so clients
#will know who sent them the message - part of WS-Addressing
$ENV{FROM} = $ENV{URL} . $Path;
#split up Path part of URL - we multiplex on the first part (the base)
#the module name is the last part
my @PathArray = split( /\//, $Path );
my $ID = pop @PathArray;
my $base = $PathArray[0];
my $ModuleName = pop @PathArray;
print "$$ ModuleName= $ModuleName\n";
my $Directory = join '/', @PathArray;
#this is the absolute path now
$Directory = $ENV{WSRF_MODULES} . "/" . $Directory;
print STDERR "Directory= $Directory\n";
$Path = $ENV{WSRF_MODULES} . "/" . $Path;
#check the ID is safe - we do not accept dots,
#all paths will be relative to $ENV{WRF_MODULES}
#only allow alphanumeric, underscore and hyphen
if ( $ID !~ m/^([-\w]+)$/ && $ID !~ m/^$ModuleName\.(xsl|js|css|svg)$/ ) {
print STDERR "$$ Bad ID $ID\n";
my $fail = new HTTP::Response(RC_BAD_REQUEST);
$fail->header( 'Content-Type' => 'text/xml' );
$fail->content(
SOAP::Serializer->fault(
'Bad WS-Resource Identifier',
"WS-Resource identifier contains bad charactors"
)
);
return $fail;
}
my ($PUT);
if ( $request->method eq 'PUT' ) {
$PUT = 1;
my $To = $ENV{URL};
chop $To;
$To .= $request->uri;
my $header =
SOAP::Header->value( "<wsa:To>" . $To . "</wsa:To>" )->type('xml');
my $xml = $request->content;
print STDERR "$$ Attempt to PUT\n";
$xml =~ s/^<\?xml[\s\w\.\-].*\?>\n?//o;
print STDERR "$$ >>>xml>>>\n$xml\n<<<xml<<<\n";
my $data =
SOAP::Data->name('PutResourcePropertyDocument')->prefix('wsrp')
->attr( { 'xmlns:wsrp' => $WSRF::Constants::WSRP } )
->value( \SOAP::Data->value($xml)->type('xml') );
my $envelope = WSRF::WSRFSerializer->new()->freeform( $header, $data );
print "$$ >>>envelope>>>\n$envelope\n<<<envelope<<<\n";
$request = HTTP::Request->new();
$request->method('POST');
$request->header( "SOAPAction" =>
"$WSRF::Constants::WSRP/PutResourcePropertyDocument" );
$request->header( "Content-Length" => length $envelope );
$request->content($envelope);
}
print "$$ ID= $ID\n";
my ($GET);
if ( $request->method eq 'GET' ) {
#does the client just want the WSDL/XSL/CSS for service
if ( $request->uri->query eq 'WSDL' ) {
my $resp = GetWSDL($request);
return $resp;
} elsif ( $ID =~ m/^$ModuleName\.(xsl|css|js|svg)$/ )
#looking for xsl or css or js
{
print "$$ Getting $ID file\n";
my $resp = HTTP::Response->new();
my $file = $Directory . "/" . $ID;
print "$$ File to open is $file\n";
if ( !( -f $file ) || !( -r $file ) ) {
$resp->code(404);
return $resp;
}
open FILE, "< $file" or die "$$ Could not open $file";
my $xsl = join "", <FILE>;
close FILE or die "Could not close $file file";
$resp->header( 'Content-Type' => 'text/xml' )
if ( $ID =~ m/\.xsl$/ );
$resp->header( 'Content-Type' => 'text/css' )
if ( $ID =~ m/\.css$/ );
$resp->header( 'Content-Type' => 'text/javascript' )
if ( $ID =~ m/\.js$/ );
$resp->header( 'Content-Type' => 'text/xml' )
if ( $ID =~ m/\.svg$/ );
$resp->content($xsl);
return $resp;
}
#wants ResourceProperties
$GET = 1;
my $data =
SOAP::Data->name('GetResourcePropertyDocument')->prefix('wsrp')
->attr( { 'xmlns:wsrp' => $WSRF::Constants::WSRP } );
my $To = $ENV{URL};
chop $To;
$To .= $request->uri;
my $header =
SOAP::Header->value( "<wsa:To>" . $To . "</wsa:To>" )->type('xml');
my $envelope = WSRF::WSRFSerializer->new()->freeform( $header, $data );
$request = HTTP::Request->new();
$request->method('POST');
$request->header( "SOAPAction" =>
"$WSRF::Constants::WSRP/GetResourcePropertyDocument" );
$request->header( "Content-Length" => length $envelope );
$request->content($envelope);
}
if ( $request->method eq 'DELETE' ) {
my $data =
SOAP::Data->name('Destroy')->prefix('wsrl')
->attr( { 'xmlns:wsrl' => $WSRF::Constants::WSRL } );
my $To = $ENV{URL};
chop $To;
$To .= $request->uri;
my $header =
SOAP::Header->value( "<wsa:To>" . $To . "</wsa:To>" )->type('xml');
my $envelope = WSRF::WSRFSerializer->new()->freeform( $header, $data );
$request = HTTP::Request->new();
$request->method('POST');
$request->header( "SOAPAction" => "$WSRF::Constants::WSRL/Destroy" );
$request->header( "Content-Length" => length $envelope );
$request->content($envelope);
}
my $rend = $WSRF::Constants::SOCKETS_DIRECTORY . "/" . $ID;
#check that the Socket exists for the requested Grid Service
if ( !-S $rend ) {
print STDERR "$$ UNIX Socket $rend does not exist\n";
my $fail = new HTTP::Response(RC_NOT_FOUND);
$fail->header( 'Content-Type' => 'text/xml' );
$fail->content(
SOAP::Serializer->fault(
'No such WS-Resource type',
"Check Endpoint of service"
)
);
return $fail;
}
print STDERR "$$ $Path Child $$ Starting Processing\n";
print STDERR "$$ Client Rendezvous $rend\n";
#open a socket to the GS
my $MyFH = IO::Socket::UNIX->new(
Peer => "$rend",
Type => SOCK_STREAM,
Timeout => 10
)
or die SOAP::Fault->faultcode("Container Fault")
->faultstring("Container Failure - Socket problem $!");
print STDERR "$$ Client Socket $MyFH\n";
#if using SSL add the extra information to the HTTP request
# we stick it into the HTTP Header
if ( defined( $ENV{SSL_CLIENT_DN} ) ) {
$request->header( 'Client-SSL-Cert-Subject' => "$ENV{SSL_CLIENT_DN}" );
$request->header(
'Client-SSL-Cert-Issuer' => "$ENV{SSL_CLIENT_ISSUER}" );
}
#send down socket and wait for response
my $out = print $MyFH ( $request->as_string() );
if ( !defined($out) ) { print STDERR "$$ Could not write to $MyFH\n" }
#read the response from the Socket and turn it into a
#HTTP::Response
my $resp = WSRF::Daemon::ResponseHandler($MyFH);
$MyFH->close;
print STDERR "$$ $Path Processing Finished\n";
# print STDERR "$$ >>>out>>>\n".$resp->content."\n<<<out<<<\n";
if ( $GET || $PUT ) #Original Request was a GET
lib/WSRF/Lite.pm view on Meta::CPAN
if ( $request->method ne 'POST'
&& $request->method ne 'GET'
&& $request->method ne 'DELETE'
&& $request->method ne 'PUT' );
my $Path = $request->uri->path;
#strip extra '/' at start of URL
$Path =~ s/^\/+//o;
#remeber the Path - we will put this in our responses so clients
#will know who sent them the message - part of WS-Addressing
$ENV{FROM} = $ENV{URL} . $Path;
#split up Path part of URL - we multiplex on the first part (the base)
#the module name is the last part
my @PathArray = split( /\//, $Path );
my $ID = pop @PathArray;
my ($module);
if ( $ID =~ /\d+-?d*/o
|| $ID =~ /^\w+\.(js|xsl|css|svg)$/ ) #a resource identifier
{
$module = pop @PathArray;
} else {
$module = $ID;
}
$ENV{ID} = $ID;
my $base = $PathArray[0];
my $RelativeDirectory = join '/', @PathArray;
#this is the absolute path now
my $Directory = $ENV{WSRF_MODULES} . "/" . $RelativeDirectory;
print STDERR "$$ Directory to modules $Directory\n";
my $tmpPath = $Directory . '/' . $module . ".pm";
print STDERR "$$ Path to module $tmpPath\n";
if ( !-f $tmpPath ) {
print STDERR "$$ ERROR $tmpPath no such file\n";
my $fail = new HTTP::Response(RC_OK);
$fail->header( 'Content-Type' => 'text/xml' );
#$fail->content("GS::$Path No Such service\n");
$fail->content(
SOAP::Serializer->fault(
'No Service', "Check Endpoint of Service"
)
);
return $fail;
}
my ($PUT);
if ( $request->method eq 'PUT' ) {
$PUT = 1;
my $To = $ENV{URL};
chop $To;
$To .= $request->uri;
my $header =
SOAP::Header->value( "<wsa:To>" . $To . "</wsa:To>" )->type('xml');
my $xml = $request->content;
print STDERR "$$ Attempt to PUT\n";
$xml =~ s/^<\?xml[\s\w\.\-].*\?>\n?//o;
print STDERR "$$ >>>xml>>>\n$xml\n<<<xml<<<\n";
my $data =
SOAP::Data->name('PutResourcePropertyDocument')->prefix('wsrp')
->attr( { 'xmlns:wsrp' => $WSRF::Constants::WSRP } )
->value( \SOAP::Data->value($xml)->type('xml') );
my $envelope = WSRF::WSRFSerializer->new()->freeform( $header, $data );
print "$$ >>>envelope>>>\n$envelope\n<<<envelope<<<\n";
$request = HTTP::Request->new();
$request->method('POST');
$request->header( "SOAPAction" =>
"$WSRF::Constants::WSRP/PutResourcePropertyDocument" );
$request->header( "Content-Length" => length $envelope );
$request->content($envelope);
}
my ($GET);
if ( $request->method eq 'GET' ) {
#does the client just want the WSDL for service
if ( $request->uri->query eq 'WSDL' ) {
my $resp = GetWSDL($request);
return $resp;
} elsif ( $ID =~ m/^$module\.(xsl|css|js|svg)$/ )
#looking for xsl or css or js
{
print "$$ Getting $ID file\n";
my $resp = HTTP::Response->new();
my $file = $Directory . "/" . $ID;
print "$$ File to open is $file\n";
if ( !( -f $file ) || !( -r $file ) ) {
$resp->code(404);
return $resp;
}
print "$$ File to open is $file\n";
open FILE, "< $file" or die "$$ Could not open $file";
my $xsl = join "", <FILE>;
close FILE or die "Could not close WSDL file";
$resp->header( 'Content-Type' => 'text/xml' )
if ( $ID =~ m/\.xsl$/ );
$resp->header( 'Content-Type' => 'text/css' )
if ( $ID =~ m/\.css$/ );
$resp->header( 'Content-Type' => 'text/javascript' )
if ( $ID =~ m/\.js$/ );
$resp->header( 'Content-Type' => 'text/xml' )
if ( $ID =~ m/\.svg$/ );
$resp->content($xsl);
return $resp;
}
$GET = 1;
my $data =
SOAP::Data->name('GetResourcePropertyDocument')->prefix('wsrp')
->attr( { 'xmlns:wsrp' => $WSRF::Constants::WSRP } );
my $To = $ENV{URL};
chop $To;
$To .= $request->uri;
my $header =
SOAP::Header->value( "<wsa:To>" . $To . "</wsa:To>" )->type('xml');
my $envelope = WSRF::WSRFSerializer->new()->freeform( $header, $data );
$request = HTTP::Request->new();
$request->method('POST');
$request->header( "SOAPAction" =>
"$WSRF::Constants::WSRP/GetResourcePropertyDocument" );
$request->header( "Content-Length" => length $envelope );
$request->content($envelope);
}
if ( $request->method eq 'DELETE' ) {
my $data =
SOAP::Data->name('Destroy')->prefix('wsrl')
->attr( { 'xmlns:wsrl' => $WSRF::Constants::WSRL } );
my $To = $ENV{URL};
chop $To;
$To .= $request->uri;
my $header =
SOAP::Header->value( "<wsa:To>" . $To . "</wsa:To>" )->type('xml');
my $envelope = WSRF::WSRFSerializer->new()->freeform( $header, $data );
$request = HTTP::Request->new();
$request->method('POST');
$request->header( "SOAPAction" => "$WSRF::Constants::WSRL/Destroy" );
$request->header( "Content-Length" => length $envelope );
$request->content($envelope);
}
print STDERR "$$ Dispatch path $Directory\n";
my %namespacemap = (
$WSRF::Constants::WSRL => "$module",
$WSRF::Constants::WSRP => "$module",
$WSRF::Constants::WSSG => "$module"
);
%namespacemap = ( %namespacemap, %WSRF::Constants::ModuleNamespaceMap );
#this loads the module to handle this function, the module
#will retrieve the state for the WS-Resource from a DB or
#some other stable storage, process the message and return the
#state to the stable storage
my $resp =
WSRF::Session->dispatch_to($Directory)->dispatch_with( \%namespacemap )
->serializer( WSRF::WSRFSerializer->new )
->deserializer( WSRF::Deserializer->new )->handle($request);
print STDERR "$$ >>>out>>>\n" . $resp->content . "\n<<<out<<<\n";
if ( $GET || $PUT ) #Original Request was a GET
{
$resp = WSRF::Container::getProperties( $resp, $Directory, $module );
}
return $resp;
}
sub getProperties {
my $resp = shift @_;
my $Dir = shift @_;
my $Module = shift @_;
my $xml = $resp->content;
eval { require XML::LibXML };
if ( !$@ ) #we have XML::LibXML, so we can strip the SOAP stuff
{
#my $xpath = '<XPath xmlns:wsrp="'
# . $WSRF::Constants::WSRP
# . '">(//. | //@* | //namespace::*)[ancestor-or-self::wsrp:ResourceProperties]</XPath>';
my $xpath = '(//. | //@* | //namespace::*)[ancestor-or-self::wsrp:ResourceProperties]';
my $canon = '<?xml version="1.0" encoding="ISO-8859-1"?>' . "\n";
$canon = $canon
. '<?xml-stylesheet type="text/xsl" href="'
. $Module
. '.xsl"?>' . "\n"
if ( -f $Dir . "/$Module.xsl" && -r $Dir . "/$Module.xsl" );
my $parser = XML::LibXML->new();
my $doc = $parser->parse_string($xml);
$canon .= $doc->toStringEC14N( 0, $xpath, [''] );
$resp->header( "Content-Length" => length $canon );
$resp->content($canon);
}
return $resp;
lib/WSRF/Lite.pm view on Meta::CPAN
#Only Handle GET and POST
return HTTP::Response->new(RC_FORBIDDEN)
if ( $request->method ne 'POST'
&& $request->method ne 'GET'
&& $request->method ne 'DELETE'
&& $request->method ne 'PUT' );
my $Path = $request->uri->path;
#strip extra '/' at start of URL
$Path =~ s/^\/+//o;
#remeber the Path - we will put this in our responses so clients
#will know who sent them the message - part of WS-Addressing
$ENV{FROM} = $ENV{URL} . $Path;
#split up Path part of URL - we multiplex on the first part (the base)
#the module name is the last part
my @PathArray = split( /\//, $Path );
my $ID = pop @PathArray;
my ($module);
if ( $ID =~ /\d+-?d*/o
|| $ID =~ /^\w+\.(xsl|js|css|svg)$/o ) #a resource identifier
{
$module = pop @PathArray;
} else {
$module = $ID;
}
$ENV{ID} = $ID;
my $base = $PathArray[0];
my $RelativeDirectory = join '/', @PathArray;
#this is the absolute path now
my $Directory = $ENV{WSRF_MODULES} . "/" . $RelativeDirectory;
#check the message actually maps to a module
my $tmpPath = $Directory . '/' . $module . ".pm";
print STDERR "$$ Path to module $tmpPath\n";
if ( !-f $tmpPath ) {
print STDERR "$$ ERROR:: $tmpPath No Such File\n";
my $fail = new HTTP::Response(RC_OK);
$fail->header( 'Content-Type' => 'text/xml' );
$fail->content(
SOAP::Serializer->fault(
'No Service', "Check Endpoint of Service"
)
);
return $fail;
}
my ($PUT);
if ( $request->method eq 'PUT' ) {
$PUT = 1;
my $To = $ENV{URL};
chop $To;
$To .= $request->uri;
my $header =
SOAP::Header->value( "<wsa:To>" . $To . "</wsa:To>" )->type('xml');
my $xml = $request->content;
print STDERR "$$ Attempt to PUT\n";
$xml =~ s/^<\?xml[\s\w\.\-].*\?>\n?//o;
print STDERR "$$ >>>xml>>>\n$xml\n<<<xml<<<\n";
my $data =
SOAP::Data->name('PutResourcePropertyDocument')->prefix('wsrp')
->attr( { 'xmlns:wsrp' => $WSRF::Constants::WSRP } )
->value( \SOAP::Data->value($xml)->type('xml') );
my $envelope = WSRF::WSRFSerializer->new()->freeform( $header, $data );
print "$$ >>>envelope>>>\n$envelope\n<<<envelope<<<\n";
$request = HTTP::Request->new();
$request->method('POST');
$request->header( "SOAPAction" =>
"$WSRF::Constants::WSRP/PutResourcePropertyDocument" );
$request->header( "Content-Length" => length $envelope );
$request->content($envelope);
}
my ($GET);
if ( $request->method eq 'GET' ) {
#does the client just want the WSDL for service
if ( $request->uri->query eq 'WSDL' ) {
my $resp = GetWSDL($request);
return $resp;
} elsif ( $ID =~ m/^$module\.(xsl|css|js|svg)$/ )
#looking for xsl or css or js
{
print "$$ Getting $ID file\n";
my $resp = HTTP::Response->new();
my $file = $Directory . "/" . $ID;
print "$$ File to open is $file\n";
if ( !( -f $file ) || !( -r $file ) ) {
$resp->code(404);
return $resp;
}
open FILE, "< $file" or die "$$ Could not open $file";
my $xsl = join "", <FILE>;
close FILE or die "Could not close $file file";
$resp->header( 'Content-Type' => 'text/xml' )
if ( $ID =~ m/\.xsl$/ );
$resp->header( 'Content-Type' => 'text/css' )
if ( $ID =~ m/\.css$/ );
$resp->header( 'Content-Type' => 'text/javascript' )
if ( $ID =~ m/\.js$/ );
$resp->header( 'Content-Type' => 'text/xml' )
if ( $ID =~ m/\.svg$/ );
$resp->content($xsl);
return $resp;
}
$GET = 1;
my $data =
SOAP::Data->name('GetResourcePropertyDocument')->prefix('wsrp')
->attr( { 'xmlns:wsrp' => $WSRF::Constants::WSRP } );
my $To = $ENV{URL};
chop $To;
$To .= $request->uri;
my $header =
SOAP::Header->value( "<wsa:To>" . $To . "</wsa:To>" )->type('xml');
my $envelope = WSRF::WSRFSerializer->new()->freeform( $header, $data );
$request = HTTP::Request->new();
$request->method('POST');
$request->header( "SOAPAction" =>
"$WSRF::Constants::WSRP/GetResourcePropertyDocument" );
$request->header( "Content-Length" => length $envelope );
$request->content($envelope);
}
if ( $request->method eq 'DELETE' ) {
my $data =
SOAP::Data->name('Destroy')->prefix('wsrl')
->attr( { 'xmlns:wsrl' => $WSRF::Constants::WSRL } );
my $To = $ENV{URL};
chop $To;
$To .= $request->uri;
my $header =
SOAP::Header->value( "<wsa:To>" . $To . "</wsa:To>" )->type('xml');
my $envelope = WSRF::WSRFSerializer->new()->freeform( $header, $data );
$request = HTTP::Request->new();
$request->method('POST');
$request->header( "SOAPAction" => "$WSRF::Constants::WSRL/Destroy" );
$request->header( "Content-Length" => length $envelope );
$request->content($envelope);
}
#check if a process to handle this message has been created
my $SockPath = $WSRF::Constants::SOCKETS_DIRECTORY . '/' . $module;
my ($resp);
if ( !-S $SockPath ) {
#create the file and fork the process
print STDERR "$$ Creating a new Service $module\n";
my $service = WSRF::Resource->new(
module => $module,
path => $RelativeDirectory,
ID => $module
);
print STDERR "$$ Calling handle() on service\n";
$service->handle("");
print STDERR "$$ Connecting to Socket $SockPath\n";
my $MyFH = IO::Socket::UNIX->new(
Peer => $SockPath,
Type => SOCK_STREAM,
Timeout => 10
)
or die SOAP::Fault->faultcode("Container Fault")
->faultstring("Container Failure - Socket problem $!");
#if using SSL add the extra information to the HTTP request
if ( defined( $ENV{SSL_CLIENT_DN} ) ) {
$request->header(
'Client-SSL-Cert-Subject' => "$ENV{SSL_CLIENT_DN}" );
$request->header(
'Client-SSL-Cert-Issuer' => "$ENV{SSL_CLIENT_ISSUER}" );
}
#print "Ingoing HTTP>>>\n".$r->as_string()."\n<<<HTTP\n";
my $out = print $MyFH ( $request->as_string() );
if ( !defined($out) ) {
print STDERR "$$ ERROR could not write to $MyFH\n";
}
#read the response from the Socket and turn it into a
#HTTP::Response
$resp = WSRF::Daemon::ResponseHandler($MyFH);
$MyFH->close;
print STDERR "$$ $Path Processing Finished\n";
} else #no process to handle this message - we need to create one
{
#check the socket is up - send SOAP to socket
my $MyFH = IO::Socket::UNIX->new(
Peer => $SockPath,
Type => SOCK_STREAM,
Timeout => 10
);
if ( !$MyFH ) {
lib/WSRF/Lite.pm view on Meta::CPAN
sub path {
my ($self) = @_;
return $self->{_path};
}
# Send the ResourceProperties to a file
sub toFile {
my $class = shift;
my $filename =
ref($class)
? $class->{_path}
: $WSRF::Constants::Data . $class;
# open FILE, ">$filename" or die SOAP::Fault->faultcode("Container Failure")
# ->faultstring("Container Failure: Could open file");
# print ">>>>AFTER>>>>\n".WSRF::WSRP::xmlizeProperties()."\n<<<<<<<<<<<<\n\n";
# print FILE WSRF::WSRP::xmlizeProperties();
# close FILE or die SOAP::Fault->faultcode("Container Failure")
# ->faultstring("Container Failure: Could close file");
# my $safe = new Safe;
# $safe->permit(qw(:default require));
# local $Storable::Eval = sub { $safe->reval($_[0]) };
# local $Storable::Deparse = 1;
my %tmpPrivate = (%WSRF::WSRP::Private);
#should use map?
foreach my $key ( keys %tmpPrivate ) {
if ( ref( $tmpPrivate{$key} ) eq "CODE" ) {
delete $tmpPrivate{$key};
}
}
#take a copy of the ResourceProperties to copy to file
my %tmphash = (%WSRF::WSRP::ResourceProperties);
foreach my $key ( keys %tmphash ) {
if ( ref( $tmphash{$key} ) eq "CODE" ) {
delete $tmphash{$key};
}
}
my %tmpStore = ( Properties => \%tmphash, Private => \%tmpPrivate );
local $Storable::forgive_me = "TRUE";
lock_store \%tmpStore, $filename;
return;
}
sub unlock {
my ($self) = @_;
my $Lock = $self->{_lock};
$Lock->DESTROY();
}
#===============================================================================
# header function creates a SOAP::Header that should be included
# in the response to the client. Handles the WS-Address stuff.
# Takes the original envelope and creates a Header from it -
# the second paramter will be stuffed into the Header so must
# be XML
#
# BUG This should be better automated - probably in the SOAP serializer,
# not sure how because we need to remember the MessageID
package WSRF::Header;
=pod
=head1 WSRF::Header
WSRF::Header provides one helper routine B<header>
=head2 METHODS
=over
=item header
This subroutine takes a WSRF::SOM envelope and creates the appropriate
SOAP Headers for the response including the required WS-Addressing SOAP
headers.
sub foo {
my $envelope = pop @_;
return WSRF::Header::header($envelope);
}
=back
=cut
sub header {
my ( $envelope, $anythingelse ) = @_;
#To create the wsa:Action we must find the operation name
#and its namespace
my $data = $envelope->match('/Envelope/Body/[1]')->dataof;
my $method = $data->name;
my $uri = $data->uri;
my $Action = $uri . "/" . $method . "Response";
my $myHeader = "<wsa:Action wsu:Id=\"Action\">" . $Action . "</wsa:Action>";
#We only use "anonoymous" for wsa:To
$myHeader .= "<wsa:To wsu:Id=\"To\">$WSRF::Constants::WSA_ANON</wsa:To>";
#We use our endpoint to create the wsa:From - the endpoint
#is an ENV variable
if ( $envelope->match("/Envelope/Header/{$WSRF::Constants::WSA}To") ) {
my $from =
$envelope->valueof("/Envelope/Header/{$WSRF::Constants::WSA}To");
$myHeader .=
"<wsa:From wsu:Id=\"From\"><wsa:EndPointReference><wsa:Address>$from</wsa:Address></wsa:EndPointReference></wsa:From>";
}
$myHeader .=
"<wsa:MessageID wsu:Id=\"MessageID\">"
. WSRF::WS_Address::MessageID()
. "</wsa:MessageID>";
#check for wsa:MessageID in envelope - if it is set use it to
#create a wsa:RelatesTo element
my $messageID = $envelope->headerof("//{$WSRF::Constants::WSA}MessageID");
if ( defined $messageID ) {
$messageID =
$envelope->headerof("//{$WSRF::Constants::WSA}MessageID")->value;
$myHeader .=
"<wsa:RelatesTo wsu:Id=\"RelatesTo\">"
. $messageID
. "</wsa:RelatesTo>";
}
#append anything else the user has given us
$myHeader .= $anythingelse;
#create the SOAP::Header object and return to client
return SOAP::Header->value($myHeader)->type('xml');
}
#===============================================================================
# Base class for the process based WSRF services - a Service can inherit from
# this class to pick up GetResourceProperty, GetMultiResourceProperties and
# SetResourceProperty operations.
package WSRF::WSRP;
=pod
=head1 WSRF::WSRP
Provides support for WSRF ResourceProperties, the properties of the WS-Resource
are stored in a hash called %WSRF::WSRP::ResourceProperties.
=head2 METHODS
=over
=item xmlizeProperties
=item GetResourcePropertyDocument
=item GetResourceProperty
=item GetMultipleResourceProperties
=item SetResourceProperties
=item InsertResourceProperties
=item UpdateResourceProperties
=item DeleteResourceProperties
=back
=cut
use vars qw(@ISA);
# we inherit this to gain access to the envelope - see SOAP::Lite
@ISA = qw(SOAP::Server::Parameters);
# Hash to store resource properties - we make this effectively
# a globe variable
%WSRF::WSRP::ResourceProperties = ();
# Hash stores the prefix for the resource property
# eg CurrentTime will use the prefix wsrl, the
# map between tthe prefix and the namespace is
# elsewhere
%WSRF::WSRP::PropertyNamespaceMap = ();
# Hash that maps a property and the fuction that
# should be called when aan attempt is made to
# insert that property. Simple properties are
# handled by default.
%WSRF::WSRP::InsertMap = ();
lib/WSRF/Lite.pm view on Meta::CPAN
or Carp::croak qq!Can\'t locate class method "$method" via package \"!
. __PACKAGE__ . '\"';
no strict 'refs';
*$AUTOLOAD = sub {
my $self = shift;
my $som = $self->call( $method => @_ );
return $self->autoresult
&& UNIVERSAL::isa( $som => 'SOAP::SOM' )
? wantarray ? $som->paramsall : $som->result
: $som;
};
goto &$AUTOLOAD;
}
sub call {
SOAP::Trace::trace('()');
my $self = shift;
if (
!(
defined $self->proxy
&& UNIVERSAL::isa( $self->proxy => 'SOAP::Client' )
)
&& defined( $self->wsaddress )
&& UNIVERSAL::isa( $self->wsaddress => 'WSRF::WS_Address' )
)
{
$self->proxy( $self->wsaddress->Address() );
}
# Why is this here? Can't call be null? Indicating that there are no input arguments?
#return $self->{_call} unless @_;
die
"A service address has not been specified either by using SOAP::Lite->proxy() or a service description)\n"
unless defined $self->proxy
&& UNIVERSAL::isa( $self->proxy => 'SOAP::Client' );
$self->init_context();
my $serializer = $self->serializer;
$serializer->on_nonserialized( $self->on_nonserialized );
if ( defined $self->wsaddress ) {
my $header =
"<wsa:Action wsu:Id=\"Action\">"
. scalar( $self->on_action->( $serializer->uriformethod( $_[0] ) ) )
. "</wsa:Action>";
$header .=
"<wsa:To wsu:Id=\"To\">" . $self->wsaddress->Address() . "</wsa:To>";
$header .=
"<wsa:MessageID wsu:Id=\"MessageID\">"
. $self->wsaddress->MessageID()
. "</wsa:MessageID>";
$header .=
$self->wsaddress->serializeReferenceParameters()
? $self->wsaddress->serializeReferenceParameters()
: '';
#bug fix - John Newman
$header .=
"<wsa:ReplyTo wsu:Id=\"ReplyTo\"><wsa:Address>$WSRF::Constants::WSA_ANON</wsa:Address></wsa:ReplyTo>";
@_ = ( @_, SOAP::Header->value($header)->type('xml') );
}
my $response = $self->transport->send_receive(
context => $self, # this is provided for context
endpoint => $self->endpoint,
action =>
scalar( $self->on_action->( $serializer->uriformethod( $_[0] ) ) ),
# leave only parameters so we can later update them if required
envelope => $serializer->envelope( method => shift, @_ ),
# envelope => $serializer->envelope(method => shift, @_),
encoding => $serializer->encoding,
parts => @{ $self->packager->parts } ? $self->packager->parts : undef,
);
#BUG fix by Luke AT yahoo.com
#return $response if $self->outputxml;
# if ( $self->outputxml ) { $self->destroy_context(); return $response; }
# deserialize and store result
my $result = $self->{'_call'} =
eval { $self->deserializer->deserialize($response) }
if $response;
if (
!$self->transport->is_success || # transport fault
$@ || # not deserializible
# fault message even if transport OK
# or no transport error (for example, fo TCP, POP3, IO implementations)
UNIVERSAL::isa( $result => 'SOAP::SOM' ) && $result->fault
)
{
return $self->{'_call'} =
( $self->on_fault->( $self, $@ ? $@ . ( $response || '' ) : $result )
|| $result );
}
return unless $response; # nothing to do for one-ways
# little bit tricky part that binds in/out parameters
if ( UNIVERSAL::isa( $result => 'SOAPSOM' )
&& ( $result->paramsout || $result->headers )
&& $serializer->signature )
{
my $num = 0;
my %signatures = map { $_ => $num++ } @{ $serializer->signature };
for ( $result->dataof(SOAP::SOM::paramsout),
$result->dataof(SOAP::SOM::headers) )
{
my $signature = join $;, $_->name, $_->type || '';
if ( exists $signatures{$signature} ) {
my $param = $signatures{$signature};
my ($value) = $_->value; # take first value
UNIVERSAL::isa( $_[$param] => 'SOAP::Data' )
? $_[$param]->SOAP::Data::value($value)
: UNIVERSAL::isa( $_[$param] => 'ARRAY' )
? ( @{ $_[$param] } = @$value )
: UNIVERSAL::isa( $_[$param] => 'HASH' )
? ( %{ $_[$param] } = %$value )
( run in 2.918 seconds using v1.01-cache-2.11-cpan-0bb4e1dffa6 )