File Coverage

lib/XML/Compile/Transport/SOAPHTTP.pm
Criterion Covered Total %
statement 145 180 80.5
branch 24 66 36.3
condition 17 41 41.4
subroutine 25 30 83.3
pod 3 5 60.0
total 214 322 66.4


line stmt bran cond sub pod time code
1             # Copyrights 2007-2022 by [Mark Overmeer ].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.03.
5             # This code is part of distribution XML-Compile-SOAP. Meta-POD processed
6             # with OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package XML::Compile::Transport::SOAPHTTP;
10 3     3   5992 use vars '$VERSION';
  3         7  
  3         137  
11             $VERSION = '3.28';
12              
13 3     3   15 use base 'XML::Compile::Transport';
  3         6  
  3         782  
14              
15 3     3   17 use warnings;
  3         9  
  3         61  
16 3     3   12 use strict;
  3         6  
  3         67  
17              
18 3     3   13 use Log::Report 'xml-compile-soap';
  3         4  
  3         13  
19              
20 3     3   659 use XML::Compile::SOAP::Util qw/SOAP11ENV SOAP11HTTP/;
  3         16  
  3         151  
21 3     3   18 use XML::Compile ();
  3         7  
  3         32  
22              
23 3     3   1379 use LWP ();
  3         101821  
  3         70  
24 3     3   25 use LWP::UserAgent ();
  3         6  
  3         35  
25 3     3   13 use HTTP::Request ();
  3         7  
  3         32  
26 3     3   13 use HTTP::Headers ();
  3         4  
  3         36  
27 3     3   13 use Encode;
  3         6  
  3         2923  
28              
29             # (Microsofts HTTP Extension Framework)
30             my $http_ext_id = SOAP11ENV;
31              
32             my $mime_xop = 'application/xop+xml';
33              
34             __PACKAGE__->register(SOAP11HTTP);
35              
36              
37             sub init($)
38 2     2 0 7 { my ($self, $args) = @_;
39 2         16 $self->SUPER::init($args);
40              
41             $self->userAgent
42             ( $args->{user_agent}
43             , keep_alive => (exists $args->{keep_alive} ? $args->{keep_alive} : 1)
44             , timeout => ($args->{timeout} || 180)
45             , ssl_opts => $args->{ssl_opts}
46 2 50 50     25 );
47              
48 2         3772 $self;
49             }
50              
51             sub initWSDL11($)
52 0     0 0 0 { my ($class, $wsdl) = @_;
53 0         0 trace "initialize SOAPHTTP transporter for WSDL11";
54             }
55              
56             #-------------------------------------------
57              
58              
59             my $default_ua;
60             sub userAgent(;$)
61 4     4 1 11 { my ($self, $agent) = (shift, shift);
62 4 50       12 return $self->{user_agent} = $agent
63             if defined $agent;
64              
65 4   33     61 $self->{user_agent} ||= $default_ua ||= LWP::UserAgent->new
      66        
66             ( requests_redirectable => [ qw/GET HEAD POST M-POST/ ]
67             , protocols_allowed => [ qw/http https/ ]
68             , parse_head => 0
69             , @_
70             );
71             }
72              
73              
74 0     0 1 0 sub defaultUserAgent() { $default_ua }
75              
76             #-------------------------------------------
77              
78              
79             # SUPER::compileClient() calls this method to do the real work
80             sub _prepare_call($)
81 2     2   6 { my ($self, $args) = @_;
82 2   50     13 my $method = $args->{method} || 'POST';
83 2   50     8 my $soap = $args->{soap} || 'SOAP11';
84 2 50       8 my $version = ref $soap ? $soap->version : $soap;
85 2   50     10 my $mpost_id = $args->{mpost_id} || 42;
86 2         4 my $action = $args->{action};
87 2         4 my $mime = $args->{mime};
88 2   50     7 my $kind = $args->{kind} || 'request-response';
89 2   33     10 my $expect = $kind ne 'one-way' && $kind ne 'notification-operation';
90              
91 2         10 my $charset = $self->charset;
92 2         5 my $ua = $self->userAgent;
93              
94             # Prepare header
95 2   33     16 my $header = $args->{header} || HTTP::Headers->new;
96 2         23 $self->headerAddVersions($header);
97              
98             # There is probably never a real HTTP server on the other side, but
99             # HTTP/1.1 requires this.
100             $header->header(Host => $1)
101 2 50 50     88 if +($args->{endpoint} // '') =~ m!^\w+\://([^/:]+)!;
102              
103 2         3 my $content_type;
104 2 50       7 if($version eq 'SOAP11')
    0          
105 2   50     9 { $mime ||= 'text/xml';
106 2         7 $content_type = qq{$mime; charset=$charset};
107             }
108             elsif($version eq 'SOAP12')
109 0   0     0 { $mime ||= 'application/soap+xml';
110 0 0       0 my $sa = defined $action ? qq{; action="$action"} : '';
111 0         0 $content_type = qq{$mime; charset=$charset$sa};
112 0         0 $header->header(Accept => $mime); # not the HTML answer
113             }
114             else
115 0         0 { error "SOAP version {version} not implemented", version => $version;
116             }
117              
118 2 50       8 if($method eq 'POST')
    0          
119             { # should only be used by SOAP11, but you never know. So, SOAP12
120             # will have the action both ways.
121 2 50       7 $header->header(SOAPAction => qq{"$action"})
122             if defined $action;
123             }
124             elsif($method eq 'M-POST')
125 0         0 { $header->header(Man => qq{"$http_ext_id"; ns=$mpost_id});
126 0 0       0 $header->header("$mpost_id-SOAPAction", qq{"$action"})
127             if $version eq 'SOAP11';
128             }
129             else
130 0         0 { error "SOAP method must be POST or M-POST, not {method}"
131             , method => $method;
132             }
133              
134             # Prepare request
135              
136             # Ideally, we should change server when one fails, and stick to that
137             # one as long as possible.
138 2         13 my $server = $self->address;
139              
140             # Create handler
141              
142             my ($create_message, $parse_message)
143 2 100       12 = exists $INC{'XML/Compile/XOP.pm'}
144             ? $self->_prepare_xop_call($content_type)
145             : $self->_prepare_simple_call($content_type);
146              
147 2 50       6 $parse_message = $self->_prepare_for_no_answer($parse_message)
148             unless $expect;
149              
150 2         11 my $hook = $args->{hook};
151              
152             $hook
153             ? sub # hooked code
154 2     2   5 { my $trace = $_[1];
155              
156 2         14 my $request = HTTP::Request->new($method => $server, $header);
157 2         13033 $request->protocol('HTTP/1.1');
158 2         26 $create_message->($request, $_[0], $_[2]);
159            
160 2         51 $trace->{http_request} = $request;
161 2         4 $trace->{action} = $action;
162 2         4 $trace->{soap_version} = $version;
163 2         5 $trace->{server} = $server;
164 2         5 $trace->{user_agent} = $ua;
165 2         6 $trace->{hooked} = 1;
166              
167 2 50       7 my $response = $hook->($request, $trace, $self)
168             or return undef;
169              
170 2 50       6388 UNIVERSAL::isa($response, 'HTTP::Response')
171             or error __x"transport_hook must produce a HTTP::Response, got {resp}"
172             , resp => $response;
173              
174 2         5 $trace->{http_response} = $response;
175 2 50       9 if($response->is_error)
176 0 0       0 { error $response->message
177             if $response->header('Client-Warning');
178              
179 0         0 warning $response->message;
180             # still try to parse the response for Fault blocks
181             }
182              
183 2         22 $parse_message->($response);
184             }
185              
186             : sub # real call
187 0     0   0 { my $trace = $_[1];
188              
189 0         0 my $request = HTTP::Request->new($method => $server, $header);
190 0         0 $request->protocol('HTTP/1.1');
191 0         0 $create_message->($request, $_[0], $_[2]);
192              
193 0         0 $trace->{http_request} = $request;
194              
195 0 0       0 my $response = $ua->request($request)
196             or return undef;
197              
198 0         0 $trace->{http_response} = $response;
199              
200 0 0       0 if($response->is_error)
201 0 0       0 { error $response->message
202             if $response->header('Client-Warning');
203              
204 0         0 warning $response->message;
205             # still try to parse the response for Fault blocks
206             }
207              
208 0         0 $parse_message->($response);
209 2 50       15 };
210             }
211              
212             sub _prepare_simple_call($)
213 2     2   16 { my ($self, $content_type) = @_;
214              
215             my $create = sub
216 1     1   4 { my ($request, $content) = @_;
217 1         10 $request->header(Content_Type => $content_type);
218 1         110 $request->content_ref($content); # already bytes (not utf-8)
219 3     3   22 use bytes; $request->header('Content-Length' => length $$content);
  3         3  
  3         35  
  1         22  
220 2         13 };
221              
222             my $parse = sub
223 1     1   2 { my $response = shift;
224 1 50       4 UNIVERSAL::isa($response, 'HTTP::Response')
225             or error __x"no response object received";
226              
227 1   50     8 my $ct = $response->content_type || '';
228 1 50       80 lc($ct) ne 'multipart/related'
229             or error __x"remote system uses XOP, use XML::Compile::XOP";
230            
231 1         5 trace "received ".$response->status_line;
232              
233 1 50       82 $ct =~ m,[/+]xml$,i
234             or error __x"answer is not xml but `{type}'", type => $ct;
235              
236             # HTTP::Message::decoded_content() does not work for old Perls
237 1   33     8 my $content = $response->decoded_content(ref => 1)
238             || $response->content(ref => 1);
239              
240 1         210 ($content, {});
241 2         9 };
242              
243 2         7 ($create, $parse);
244             }
245              
246             sub _prepare_xop_call($)
247 1     1   4 { my ($self, $content_type) = @_;
248              
249 1         4 my ($simple_create, $simple_parse)
250             = $self->_prepare_simple_call($content_type);
251              
252 1         4 my $charset = $self->charset;
253             my $create = sub
254 1     1   2 { my ($request, $content, $mtom) = @_;
255 1   50     3 $mtom ||= [];
256 1 50       3 @$mtom or return $simple_create->($request, $content);
257              
258 1         38 my $bound = "MIME-boundary-".int rand 10000;
259 1         7 (my $start_cid = $mtom->[0]->cid) =~ s/^.*\@/xml@/;
260              
261 1         3 my $si = "$content_type";
262 1         2 $si =~ s/\"/\\"/g;
263 1         22 $request->header(Content_Type => <<__CT);
264             multipart/related;
265             boundary="$bound";
266             type="$mime_xop";
267             start="<$start_cid>";
268             start-info="$si"
269             __CT
270              
271 1         62 my $base = HTTP::Message->new
272             ( [ Content_Type => qq{$mime_xop; charset="$charset"; type="$si"}
273             , Content_Transfer_Encoding => '8bit'
274             , Content_ID => "<$start_cid>"
275             ] );
276 1         125 $base->content_ref($content); # already bytes (not utf-8)
277              
278 1         18 my @parts = ($base, map $_->mimePart, @$mtom);
279 1         7 $request->parts(@parts); #$base, map $_->mimePart, @$mtom);
280 1         120 $request;
281 1         4 };
282              
283             my $parse = sub
284 1     1   4 { my ($response, $mtom) = @_;
285 1   50     5 my $ct = $response->header('Content-Type') || '';
286 1 50       412 $ct =~ m!^\s*multipart/related\s*\;!i
287             or return $simple_parse->($response);
288              
289 1         2 my (@parts, %parts);
290 1         4 foreach my $part ($response->parts)
291 2 50       15 { my $include = XML::Compile::XOP::Include->fromMime($part)
292             or next;
293 2         6 $parts{$include->cid} = $include;
294 2         5 push @parts, $include;
295             }
296              
297             @parts
298 1 50       3 or error "no parts in response multi-part for XOP";
299              
300 1         2 my $root;
301 1 50       6 if($ct =~ m!start\=(["']?)\<([^"']*)\>\1!)
302 1         2 { my $startid = $2;
303 1         3 $root = delete $parts{$startid};
304 1 50       24 defined $root
305             or warning __x"cannot find root node id in parts `{id}'"
306             , id => $startid;
307             }
308 1 50       5 unless($root)
309 0         0 { $root = shift @parts;
310 0         0 delete $parts{$root->cid};
311             }
312              
313 1         3 ($root->content(1), \%parts);
314 1         4 };
315              
316 1         3 ($create, $parse);
317             }
318              
319             sub _prepare_for_no_answer($)
320 0     0   0 { my $self = shift;
321             sub
322 0     0   0 { my $response = shift;
323 0   0     0 my $ct = $response->content_type || '';
324              
325 0         0 trace "received ".$response->status_line;
326              
327 0         0 my $content = '';
328 0 0       0 if($ct =~ m,[/+]xml$,i)
329             { # HTTP::Message::decoded_content() does not work for old Perls
330 0 0       0 $content = $] >= 5.008 ? $response->decoded_content(ref => 1)
331             : $response->content(ref => 1);
332             }
333              
334 0         0 ($content, {});
335 0         0 };
336             }
337              
338              
339             sub headerAddVersions($)
340 2     2 1 5 { my ($thing, $h) = @_;
341 2         5 foreach my $pkg (qw/XML::Compile XML::Compile::Cache
342             XML::Compile::SOAP XML::LibXML LWP/)
343 3     3   2476 { no strict 'refs';
  3         14  
  3         372  
344 10   50     360 my $version = ${"${pkg}::VERSION"} || 'undef';
345 10         36 (my $field = "X-$pkg-Version") =~ s/\:\:/-/g;
346 10         22 $h->header($field => $version);
347             }
348             }
349              
350             1;