File Coverage

lib/Mojolicious/Plugin/SOAP/Server.pm
Criterion Covered Total %
statement 68 75 90.6
branch 11 16 68.7
condition 1 2 50.0
subroutine 11 12 91.6
pod 1 1 100.0
total 92 106 86.7


line stmt bran cond sub pod time code
1             package Mojolicious::Plugin::SOAP::Server;
2              
3             =pod
4              
5             =begin markdown
6              
7             ![](https://github.com/oposs/mojolicious-plugin-soap-server/workflows/Unit%20Tests/badge.svg?branch=master)
8              
9             =end markdown
10              
11             =head1 NAME
12              
13             Mojolicious::Plugin::SOAP::Server - implement a SOAP service
14              
15             =head1 SYNOPSIS
16              
17             use Mojolicious::Lite;
18             use Mojo::File 'curfile';
19              
20             plugin 'SOAP::Server' => {
21             wsdl => curfile->sibling('nameservice.wsdl'),
22             xsds => [curfile->sibling('nameservice.xsd')],
23             controller => SoapCtrl->new(x => '1'),
24             endPoint => '/SOAP'
25             };
26              
27             app->start;
28              
29             package SoapCtrl;
30              
31             use Mojo::Base -base,-signatures;
32              
33             has 'x' => 2;
34              
35             sub getCountries ($self,$server,$params,$controller) {
36             return {
37             country => [qw(Switzerland Germany), $self->x]
38             };
39             }
40              
41             sub getNamesInCountry ($self,$server,$params,$controller) {
42             my $name = $params->{parameters}{country};
43             $controller->log->debug("Test Message");
44             if ($name eq 'Die') {
45             die {
46             status => 401,
47             text => 'Unauthorized'
48             };
49             }
50             return {
51             name => [qw(A B C),$name]
52             };
53             }
54              
55             =head1 DESCRIPTION
56              
57             The L is a thin wrapper around L which makes it pretty simple to implement SOAP services in perl.
58              
59             The plugin supports the following configuration options:
60              
61             =over
62              
63             =item wsdl
64              
65             A wsdl filename with definitions for the services provided
66              
67             =item xsds
68              
69             An array pointer with xsd files for the data types used in the wsdl.
70              
71             =item controller
72              
73             A mojo Object whose methods match the service names defined in the wsdl file.
74              
75             sub methodName ($self,$server,$params,$controller) {
76              
77             see example folder for inspiration.
78              
79             =item default_cb
80              
81             A default callback to be called if the requested method does not exist in the controller.
82              
83             =item endPoint
84              
85             Where to 'mount' the SOAP service.
86              
87             =back
88              
89             =cut
90              
91 1     1   573 use Mojo::Base 'Mojolicious::Plugin', -signatures;
  1         2  
  1         5  
92              
93 1     1   175 use XML::Compile::WSDL11;
  1         1  
  1         27  
94 1     1   5 use XML::Compile::SOAP11;
  1         1  
  1         22  
95 1     1   4 use XML::Compile::SOAP12;
  1         2  
  1         37  
96 1     1   468 use XML::Compile::SOAP::Daemon::CGI;
  1         32309  
  1         39  
97 1     1   9 use Mojo::Util qw(dumper);
  1         2  
  1         68  
98             our $VERSION = '0.1.5';
99 1     1   6 use Carp qw(carp croak);
  1         2  
  1         122  
100              
101             has wsdl => sub ($self) {
102             XML::Compile::WSDL11->new;
103             };
104              
105             has daemon => sub ($self) {
106             XML::Compile::SOAP::Daemon::CGI->new;
107             };
108              
109             # do not depend on LWP
110             use constant {
111 1         757 RC_OK => 200,
112             RC_METHOD_NOT_ALLOWED => 405,
113             RC_NOT_ACCEPTABLE => 406,
114 1     1   17 };
  1         2  
115              
116 1     1 1 49 sub register ($self,$app,$conf={}) {
  1         2  
  1         2  
  1         1  
  1         2  
117 1         9 my $log = $app->log;
118 1         183 my $wsdl = XML::Compile::WSDL11->new($conf->{wsdl});
119             $wsdl->importDefinitions(
120             $conf->{xsds}
121 1 50       135748 ) if $conf->{xsds};
122              
123 1         1462 my $controller = $conf->{controller};
124 1         6 for my $op ($wsdl->operations()){
125 4         1862 my $code;
126 4         14 my $method = $op->name;
127 4 100       45 if ($controller->can($method)){
128 2         10 $app->log->debug(__PACKAGE__ . " Register handler for $method");
129             $code = $op->compileHandler(
130             callback => sub {
131 3     3   5300 my ($ctrl,$param,$c) = @_;
132 3         8 my $ret = eval {
133 3         8 local $ENV{__DIE__};
134 3         128 $controller->$method(@_);
135             };
136 3 100       20 if ($@) {
137 1 50       6 if (ref $@ eq 'HASH') {
138 1         4 $c->log->error("$method - $@->{status} $@->{text}");
139             return {
140             _RETURN_CODE => $@->{status},
141             _RETURN_TEXT => $@->{text},
142             }
143 1         29 }
144 0         0 $log->error("$method - $@");
145             return {
146 0         0 _RETURN_CODE => 500,
147             _RETURN_TEXT => 'Internal Error'
148             }
149             }
150 2         7 return $ret;
151             }
152 2         46 );
153             }
154             else {
155 2         10 $app->log->debug(__PACKAGE__ . " Adding stub handler $method");
156             $code = $op->compileHandler(
157             callback => $conf->{default_cb} || sub {
158 0     0   0 warn "No handler for $method";
159             return {
160 0         0 _RETURN_CODE => 404,
161             _RETURN_TEXT => 'No handler found',
162             };
163             }
164 2   50     51 );
165             }
166 4         114272 $self->daemon->addHandler($op->name,$op,$code);
167             }
168 1         53 my $r = $app->routes;
169 1         14 $app->types->type(
170             soapxml => 'text/xml; charset="utf-8"'
171             );
172             $r->any($conf->{endPoint})
173 3     3   6 ->to(cb => sub ($c) {
  3         227172  
  3         7  
174 3 50       10 if ( $c->req->method !~ /^(M-)?POST$/ ) {
175 0         0 return $c->render(
176             status => RC_METHOD_NOT_ALLOWED . " Expected POST",
177             text => 'SOAP wants you to POST!'
178             );
179             }
180 3         67 my $format = 'txt';
181 3         8 my $body = $c->req->body;
182 3         101 my ($rc,$msg,$xml) = $self->daemon->process(
183             \$body,
184             $c,
185             $c->req->headers->header('soapaction')
186             );
187 3         2063 my $bytes = $xml;
188 3         4 my $err;
189 3 50       14 if(UNIVERSAL::isa($bytes, 'XML::LibXML::Document')) {
190 3 100       11 $bytes = $bytes->toString($rc == RC_OK ? 0 : 1);
191 3         106 $format = 'soapxml';
192             }
193             else {
194 0         0 $err = $bytes;
195             }
196 3 50       9 if (not $bytes) {
197 0         0 $bytes = "[$rc] $err";
198             }
199            
200             $c->render(
201 3         16 status => $rc,
202             format => $format,
203             data => $bytes,
204             );
205 1         87 });
206             }
207              
208             1;
209              
210             =head1 ACKNOWLEDGEMENT
211              
212             This is really just a very thin layer on top of Mark Overmeers great L module. Thanks Mark!
213              
214             =head1 AUTHOR
215              
216             Stobi@oetiker.chE>
217              
218             =head1 COPYRIGHT
219              
220             Copyright OETIKER+PARTNER AG 2019
221              
222             =head1 LICENSE
223              
224             This library is free software; you can redistribute it and/or modify
225             it under the same terms as Perl itself, either Perl version 5.10 or,
226             at your option, any later version of Perl 5 you may have available.
227              
228             =cut