1#!/usr/bin/perl 2# Example of a SOAP server. 3# Run like this: 4# ./server.pl --verbose=2 (optional, or use -v/-vv/-vvv) 5# # this will start a server in the background 6# 7# ./client.pl --verbose=2 (optional, or use -v/-vv/-vvv) 8# # inter-actively call procedures on the server 9# 10# If you process the four examples in order, you will see increasingly 11# complex examples. The last example demonstrates what to do without 12# WSDL file (or in case of too many bugs in the definition, not uncommon). 13# 14# ./servtempl.pl is an empty base, to start your own server 15 16# Thanks to Thomas Bayer, for providing this example service 17# See http://www.thomas-bayer.com/names-service/ 18 19# Author: Mark Overmeer, January 24, 2009 20# Using: XML::Compile 1.00 21# XML::Compile::SOAP 2.00 22# XML::Compile::SOAP::Daemon 2.00 23# Copyright by the Author, under the terms of Perl itself. 24# Feel invited to contribute your examples! 25 26# Of course, all Perl programs start like this! 27use warnings; 28use strict; 29 30# constants, change this if needed (also in the client script?) 31my $serverhost = 'localhost'; 32my $serverport = '8877'; 33 34# To make Perl find the modules without the package being installed. 35use lib '../../lib' # The server implementation, not installed 36 , '.'; # To access My*.pm helpers 37 38my $wsdl_filename = 'namesservice.wsdl'; 39my @more_schemas = 'namesservice.xsd'; 40 41# useful to make constants (or vars) for namespaces 42use constant ERROR_NS => 'http://namesservice.thomas_bayer.com/error'; 43 44# This could come from a database... 45use MyExampleData qw/$namedb/; 46 47# This module defines my additional (non-WSDL) calls 48use MyExampleCalls; 49 50# Some other XML modules are automatically included. 51use XML::Compile::SOAP::Daemon::NetServer; 52use XML::Compile::WSDL11; 53use XML::Compile::SOAP11; 54use XML::Compile::Util qw/pack_type/; 55 56# The client and server scripts can be translated easily, using the 57# 'example' translation table name-space. trace/info/error come from 58# the LogReport error dispatch infra-structure. 59use Log::Report 'example', syntax => 'SHORT'; 60 61# Other useful modules 62use Getopt::Long qw/:config no_ignore_case bundling/; 63use List::Util qw/first/; 64use IO::File (); 65use Fcntl qw/:flock/; 66 67use Data::Dumper; # Data::Dumper is your friend. 68$Data::Dumper::Indent = 1; 69 70# Forward declarations allow prototype checking 71sub get_countries($$$); 72sub get_name_info($$$); 73sub get_names_in_country($$$); 74sub get_name_count($$$); 75sub create_get_name_count($); 76 77## 78#### MAIN 79## 80 81# 82# I do not like Net::Server to process my command-line options, so 83# process them before Net::Server can get it's hand on them. 84# 85 86my $mode = 0; 87my $pid_file = ($ENV{TMPDIR} || '/tmp') . '/server.pid'; 88 89GetOptions 90 # 3 ways to set the verbosity for Log::Report dispatchers 91 # select (at least one) of these ways. 92 'v+' => \$mode # -v -vv -vvv 93 , 'verbose=i' => \$mode # --verbose=2 (0..3) 94 , 'mode=s' => \$mode # --mode=DEBUG (DEBUG,ASSERT,VERBOSE,NORMAL) 95 , 'pidfn=s' => \$pid_file 96 or die "Deamon is not started"; 97 98# 99# XML::Compile::* uses Log::Report. The 'default' dispatcher for error 100# messages is here changed from PERL (die/warn) into using syslog. 101# 102 103# This is an example of Log::Report translation/exception syntax 104error __x"No filenames expected on the command-line" 105 if @ARGV; 106 107my $lock = IO::File->new($pid_file, 'a') 108 or fault __x"Cannot open lockfile {fn}", fn => $pid_file; 109 110flock $lock, LOCK_EX|LOCK_NB 111 or fault __x"Server already running, lock on {fn}", fn => $pid_file; 112 113# 114# Create the daemon set-up 115# 116 117my $daemon = XML::Compile::SOAP::Daemon::NetServer->new 118 ( 119 # You may wish to use other daemon implementations, for instance 120 # when your platform does not have a fork. You may also provide 121 # a prepared Net::Server daemon object. 122# , based_on => 'Net::Server::PreFork' # is default 123 ); 124 125# 126# Get the WSDL and Schema definitions 127# 128 129# Of course, you find this information in the applicable manual pages of 130# the XML-Compile-SOAP distributions. 131my $wsdl = XML::Compile::WSDL11->new($wsdl_filename); 132 133# Some WSDLs import or include external schemas. In XML::Compile, you 134# have to pass them explicitly. Single SCALAR or ARRAY. 135$wsdl->importDefinitions(\@more_schemas); 136 137# The error namespace I use in this example is not defined in the 138# wsdl neither the xsd, so have to add it explicitly. 139$wsdl->prefixes(err => ERROR_NS); 140 141# enforce the error name-space declaration to be available in all 142# returned messages: at compile-time, it is not known that it may 143# be used... but XML::Compile handles namespaces statically. 144$wsdl->prefixFor(ERROR_NS); 145 146# This will give you some understanding about what is defined. 147#$wsdl->schemas->namespaces->printIndex; 148 149# If you have a WSDL, then most of the infrastructure is auto-generated. 150# The only thing you have to do, is provide call-back code references 151# for each of the portNames in the WSDL. 152my %callbacks = 153 ( getCountries => \&get_countries 154 , getNamesInCountry => \&get_names_in_country 155 , getNameInfo => \&get_name_info 156 ); 157 158$daemon->operationsFromWSDL 159 ( $wsdl 160 , callbacks => \%callbacks 161 ); 162 163$daemon->setWsdlResponse($wsdl_filename); 164 165# Add a handler which is not defined in a WSDL 166create_get_name_count $daemon; 167 168# 169# Start the daemon 170# All (slow) preparations done, let's start the server 171# 172 173# replace the 'default' output backend to PERL with output to syslog 174dispatcher SYSLOG => 'default', mode => $mode; 175 176print "Starting daemon PID=$$ on $serverhost:$serverport\n"; 177 178$daemon->run 179 ( 180 # any Net::Server option. Difference SOAP daemon extensions add extra 181 # configuration options. It also depends on the Net::Server 182 # implementation you base the SOAP daemon on. See new(base_on) 183 name => 'NamesService' 184 , host => $serverhost 185 , port => $serverport 186 187 # Net::Server::PreFork parameters 188 , min_servers => 1 189 , max_servers => 1 190 , min_spare_servers => 0 191 , max_spare_servers => 0 192 ); 193 194info "Daemon stopped\n"; 195exit 0; 196 197## 198### Server-side implementations of the operations 199## 200 201# 202# First example, no incoming data 203# 204 205sub get_countries($$$) 206{ my ($server, $in, $request) = @_; 207 208 # We do not have to look at the incoming data ($in) in this case, 209 # because this message doesn't provide any. 210 211 # The output structure needs all names of header and body message 212 # parts, as defined in the WSDL. This message only contains a 213 # message part named 'parameters'. 214 215 my %parameters; # 'getCountriesResponse' element, see *xsd 216 my @countries = sort keys %$namedb; 217 $parameters{country} = \@countries; 218 # You can use XML::Compile::Schema::template(PERL) to figure-out what 219 # the getCountryResponse element structure looks like. 220 221 { parameters => \%parameters } 222} 223 224# 225# Second example, with decoding of incoming data 226# 227 228sub find_name($$) 229{ my $name = lc shift; 230 my $names = shift || []; 231 (first {lc($_) eq $name} @$names) ? 1 : undef; 232} 233 234sub get_name_info($$$) 235{ my ($server, $in, $request) = @_; 236 237 # debugging daemons is not easy, but you could do things like: 238 # (debug mode is enabled by Log::Report dispatchers with 239 # -vvv on the [server] command-line) 240 trace join '', 'get_name_info', Dumper $in; 241 242 # In the message description, the getNameInfo message has only 243 # one part, named `parameters'. Its structure is an optional 244 # name string. 245 my $name = $in->{parameters}{name} || ''; 246 247 # It is probably easier for your regression testing to put more 248 # complex data processing in seperate files; not in the server 249 # file. 250 my ($males, $females, @countries) = (0, 0); 251 foreach my $country (sort keys %$namedb) 252 { my $male = find_name $name, $namedb->{$country}{ male}; 253 my $female = find_name $name, $namedb->{$country}{female}; 254 $male or $female or next; 255 256 $males = 1 if $male; 257 $females = 1 if $female; 258 push @countries, $country; 259 } 260 261 my $gender 262 = $males && $females ? 'either' 263 : $males ? 'male' 264 : $females ? 'female' 265 : undef; 266 267 # The output message is constructed, which has one body element, named 268 # 'parameters'. It's structure is one optional 'nameinfo' element 269 my %country_list = (country => \@countries); 270 my %nameinfo = 271 ( name => $name, countries => \%country_list 272 , gender => $gender, male => $males, female => $females 273 ); 274 275 my %parameters = (nameinfo => \%nameinfo); 276 { parameters => \%parameters }; 277 278 # if you are not afraid for references, you simply write 279 # { parameters => 280 # { nameinfo => 281 # { name => $name, countries => {country => \@countries} 282 # , gender => $gender, male => $males, female => $females }}} 283 # Perl looks like Lisp, sometimes ;-) 284} 285 286## 287### The third example 288## 289 290sub get_names_in_country($$$) 291{ my ($server, $in, $request) = @_; 292 293 # this should look quite familiar now... a bit more compact! 294 my $country = $in->{parameters}{country} || ''; 295 my $data = $namedb->{$country}; 296 297 $data or return 298 +{ Fault => 299 { faultcode => pack_type(ERROR_NS, 'UnknownCountry') 300 , faultstring => "No information about country '$country'" 301 } 302 303 # The next two are put in the header of HTTP responses. Can 304 # also be used in valid responses. Defaults to RC_OK. 305 , _RETURN_CODE => 404 # use HTTP codes 306 , _RETURN_TEXT => 'Country not found' 307 }; 308 309 my @names = sort @{$data->{male} || []}, @{$data->{female} || []}; 310 { parameters => { name => \@names } }; 311} 312 313# 314# The last example shows how to add your own non-WSDL calls 315# You have to visit each of the levels of the procedure yourself: 316# 1 collect the schemas you need 317# 2 specify the protocol details 318# 3 defined the incoming and outgoing message explicitly. 319# (see the client.pl, which requires exactly the same info) 320# 4 define how to recognize the message 321# 5 add the procedure to the knowledge of the server 322# Steps 1 and 2 can be shared of all procedures you add manually. 323 324sub create_get_name_count($) 325{ my $daemon = shift; 326 327 ##### BEGIN only once per script 328 # I want to base my own methods on the WSDL definitions 329 $wsdl->importDefinitions(\@my_additional_schemas); 330 my $soap11 = XML::Compile::SOAP11::Server->new(schemas => $wsdl); 331 332 # You could also do 333 # my $soap11 = XML::Compile::SOAP11::Server->new; 334 # $soap11->importDefinitions($_) for @my_additional_schemas; 335 ##### END only once per script 336 337 ##### BEGIN usually in initiation phase of the daemon 338 # For each of the messages you want to be able to handle, you need to 339 # implement this block, run before the daemon starts. 340 341 # The 'input' and 'output' roles are the reversed in the client. 342 my $decode = $soap11->compileMessage(RECEIVER => @get_name_count_input); 343 my $encode = $soap11->compileMessage(SENDER => @get_name_count_output); 344 ##### END in initiation phase of daemon 345 346 # How do we know that this message is the one arriving? The selector 347 # CODE ref is called with the XML::LibXML::Document which has arrived 348 # and must return true when it feels addressed. 349 # The ::compileFilter() implementation is quite thorough, because it 350 # needs to understand messages from the WSDL which look much alike. 351 # You may implement something else. 352 # So, either 353 # my $selector = $soap11->compileFilter(@get_name_count_input); 354 # or 355 my $selector = sub 356 { my ($xml, $info) = @_; 357 @{$info->{body}} && $info->{body}[0] =~ m/\}getNameCount$/; 358 }; 359 360 # The handler is the client-side plug, default produces an error reply 361 my $handler = $soap11->compileHandler 362 ( name => 'getNameCount' 363 , selector => $selector # important! 364 , decode => $decode 365 , encode => $encode 366 , callback => \&get_name_count 367 ); 368 369 $daemon->addHandler('getNameCount', $soap11, $handler); 370} 371 372sub get_name_count($$$) 373{ my ($server, $in, $request) = @_; 374 375 # Althought the message is not specified in a WSDL, the handler is 376 # still the same. 377 my $count = 0; 378 if(my $country = $in->{request}{country}) 379 { my $data = $namedb->{$country} || {}; 380 $count = @{$data->{male} || []} + @{$data->{female} || []}; 381 } 382 383 {answer => {count => $count}}; 384} 385