#!/usr/bin/perl
#### See README
# XXX package MyServer;
# XXX
# XXX use Exporter;
# XXX @ISA = qw(Exporter);
# XXX @EXPORT_OK = qw( $daemon );
use warnings;
use strict;
use CGI;
use lib "/usr/local/www/SOAP";
my $schemas = "/usr/local/www/SOAP";
# constants, change this if needed (also in the client script?)
use constant ERROR_NS => 'http://namesservice.thomas_bayer.com/error';
# This could come from a database...
use MyExampleData qw/$namedb/;
# This module defines my additional (non-WSDL) calls
use MyExampleCalls;
# All the other XML modules should be automatically included.
use XML::Compile::SOAP::Daemon::CGI;
use XML::Compile::WSDL11;
use XML::Compile::SOAP11;
use XML::Compile::Util qw/pack_type/;
# The client and server scripts can be translated easily, using the
# 'example' translation table name-space. trace/info/error come from
# the LogReport error dispatch infra-structure.
# Other useful modules
use Getopt::Long qw/:config no_ignore_case bundling/;
use List::Util qw/first/;
use Data::Dumper; # Data::Dumper is your friend.
$Data::Dumper::Indent = 1;
# Forward declarations allow prototype checking
sub get_countries($$);
sub get_name_info($$);
sub get_names_in_country($$);
sub get_name_count($$);
sub create_get_name_count($);
##
#### MAIN
##
#
# start with this set to DEBUG, then change it later
my $mode = 'DEBUG';
#
# XML::Compile::* uses Log::Report. The 'default' dispatcher for error
# messages is here changed from PERL (die/warn) into using syslog.
#
use Log::Report 'example';
dispatcher FILE => 'log', mode => $mode, to => '/tmp/soap';
#
# Create the daemon set-up
#
our $daemon = XML::Compile::SOAP::Daemon::CGI->new;
my $wsdl = XML::Compile::WSDL11->new("$schemas/namesservice.wsdl");
$wsdl->importDefinitions("$schemas/namesservice.xsd");
# The error namespace I use in this example is not defined in the
# wsdl neither the xsd, so have to add it explicitly.
$wsdl->prefixes(err => ERROR_NS);
# enforce the error name-space declaration to be available in all
# returned messages: at compile-time, it is not known that it may
# be used... but XML::Compile handles namespaces statically.
$wsdl->prefixFor(ERROR_NS);
# This will give you some understanding about what is defined.
#$wsdl->schemas->namespaces->printIndex;
# If you have a WSDL, then most of the infrastructure is auto-generated.
# The only thing you have to do, is provide call-back code references
# for each of the portNames in the WSDL.
my %callbacks =
( getCountries => \&get_countries
, getNamesInCountry => \&get_names_in_country
, getNameInfo => \&get_name_info
);
$daemon->operationsFromWSDL
( $wsdl
, callbacks => \%callbacks
);
# Add a handler which is not defined in a WSDL
create_get_name_count $daemon;
##########
########## NPH START
##########
my $query = CGI->new;
$daemon->runCgiRequest( query => $query);;
exit 0;
##########
########## NPH END
##########
###
### nph-server2.cgi START
###
### #!/usr/bin/perl
### use lib '/usr/local/www/SOAP';
### use Log::Report 'example', syntax => 'SHORT';
### use CGI;
### use MyServer qw( $daemon );
### my $mode = 'DEBUG';
### dispatcher FILE => 'log', mode => $mode, to => "/tmp/soap";
### my $query = CGI->new;
### $daemon->runCgiRequest( query => $query );
### exit 0;
###
### nph-server2.cgi END
###
##
### Server-side implementations of the operations
##
#
# First example, no incoming data
#
sub get_countries($$)
{ my ($server, $in) = @_;
# We do not have to look at the incoming data ($in) in this case,
# because this message doesn't provide any.
# The output structure needs all names of header and body message
# parts, as defined in the WSDL. This message only contains a
# message part named 'parameters'.
my %parameters; # 'getCountriesResponse' element, see *xsd
my @countries = sort keys %$namedb;
$parameters{country} = \@countries;
# You can use XML::Compile::Schema::template(PERL) to figure-out what
# the getCountryResponse element structure looks like.
{ parameters => \%parameters }
}
#
# Second example, with decoding of incoming data
#
sub find_name($$)
{ my $name = lc shift;
my $names = shift || [];
(first {lc($_) eq $name} @$names) ? 1 : undef;
}
sub get_name_info($$)
{ my ($server, $in) = @_;
# debugging daemons is not easy, but you could do things like:
# (debug mode is enabled by Log::Report dispatchers with
# -vvv on the [server] command-line)
trace join '', 'get_name_info', Dumper $in;
# In the message description, the getNameInfo message has only
# one part, named `parameters'. Its structure is an optional
# name string.
my $name = $in->{parameters}{name} || '';
# It is probably easier for your regression testing to put more
# complex data processing in seperate files; not in the server
# file.
my ($males, $females, @countries) = (0, 0);
foreach my $country (sort keys %$namedb)
{ my $male = find_name $name, $namedb->{$country}{ male};
my $female = find_name $name, $namedb->{$country}{female};
$male or $female or next;
$males = 1 if $male;
$females = 1 if $female;
push @countries, $country;
}
my $gender
= $males && $females ? 'either'
: $males ? 'male'
: $females ? 'female'
: undef;
# The output message is constructed, which has one body element, named
# 'parameters'. It's structure is one optional 'nameinfo' element
my %country_list = (country => \@countries);
my %nameinfo =
( name => $name, countries => \%country_list
, gender => $gender, male => $males, female => $females
);
my %parameters = (nameinfo => \%nameinfo);
{ parameters => \%parameters };
# if you are not afraid for references, you simply write
# { parameters =>
# { nameinfo =>
# { name => $name, countries => {country => \@countries}
# , gender => $gender, male => $males, female => $females }}}
# Perl looks like Lisp, sometimes ;-)
}
##
### The third example
##
sub get_names_in_country($$)
{ my ($server, $in) = @_;
# this should look quite familiar now... a bit more compact!
my $country = $in->{parameters}{country} || '';
my $data = $namedb->{$country};
$data or return
+{ Fault =>
{ faultcode => pack_type(ERROR_NS, 'UnknownCountry')
, faultstring => "No information about country '$country'"
}
# The next two are put in the header of HTTP responses. Can
# also be used in valid responses. Defaults to RC_OK.
, _RETURN_CODE => 404 # use HTTP codes
, _RETURN_TEXT => 'Country not found'
};
my @names = sort @{$data->{male} || []}, @{$data->{female} || []};
{ parameters => { name => \@names } };
}
#
# The last example shows how to add your own non-WSDL calls
# You have to visit each of the levels of the procedure yourself:
# 1 collect the schemas you need
# 2 specify the protocol details
# 3 defined the incoming and outgoing message explicitly.
# (see the client.pl, which requires exactly the same info)
# 4 define how to recognize the message
# 5 add the procedure to the knowledge of the server
# Steps 1 and 2 can be shared of all procedures you add manually.
sub create_get_name_count($)
{ my $daemon = shift;
##### BEGIN only once per script
# I want to base my own methods on the WSDL definitions
$wsdl->importDefinitions(\@my_additional_schemas);
my $soap11 = XML::Compile::SOAP11::Server->new(schemas => $wsdl);
# You could also do
# my $soap11 = XML::Compile::SOAP11::Server->new;
# $soap11->importDefinitions($_) for @my_additional_schemas;
##### END only once per script
##### BEGIN usually in initiation phase of the daemon
# For each of the messages you want to be able to handle, you need to
# implement this block, run before the daemon starts.
# The 'input' and 'output' roles are the reversed in the client.
my $decode = $soap11->compileMessage(RECEIVER => @get_name_count_input);
my $encode = $soap11->compileMessage(SENDER => @get_name_count_output);
##### END in initiation phase of daemon
# How do we know that this message is the one arriving? The selector
# CODE ref is called with the XML::LibXML::Document which has arrived
# and must return true when it feels addressed.
# The ::compileFilter() implementation is quite thorough, because it
# needs to understand messages from the WSDL which look much alike.
# You may implement something else.
# So, either
# my $selector = $soap11->compileFilter(@get_name_count_input);
# or
my $selector = sub
{ my ($xml, $info) = @_;
@{$info->{body}} && $info->{body}[0] =~ m/\}getNameCount$/;
};
# The handler is the client-side plug, default produces an error reply
my $handler = $soap11->compileHandler
( name => 'getNameCount'
, selector => $selector # important!
, decode => $decode
, encode => $encode
, callback => \&get_name_count
);
$daemon->addHandler('getNameCount', $soap11, $handler);
}
sub get_name_count($$)
{ my ($server, $in) = @_;
# Althought the message is not specified in a WSDL, the handler is
# still the same.
my $count = 0;
if(my $country = $in->{request}{country})
{ my $data = $namedb->{$country} || {};
$count = @{$data->{male} || []} + @{$data->{female} || []};
}
{answer => {count => $count}};
}
1;