File Coverage

blib/lib/VMOMI/SoapBase.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package VMOMI::SoapBase;
2              
3 1     1   1818 use strict;
  1         2  
  1         28  
4 1     1   5 use warnings;
  1         2  
  1         21  
5              
6 1     1   419 use URI;
  1         3409  
  1         9  
7 1     1   231 use XML::LibXML;
  0            
  0            
8             use XML::LibXML::Reader;
9             use HTTP::Cookies;
10             use HTTP::Request;
11             use LWP::ConnCache;
12             use LWP::UserAgent;
13             use IO::Socket::SSL;
14              
15             use constant P5NS => 'VMOMI';
16              
17             sub AUTOLOAD {
18             my $self = shift;
19             my $name = our $AUTOLOAD;
20            
21             return if $name =~ /::DESTROY$/;
22             $name =~ s/.*:://;
23            
24             if (not exists $self->{$name}) {
25             Exception::Autoload->throw(message => "unknown accessor '$name' in " . ref $self);
26             }
27            
28             $self->{$name} = shift if @_;
29             return $self->{$name};
30             }
31              
32             sub new {
33             my ($class, %args) = @_;
34             my ($self, $scheme, $host, $port, $path, $sslKey, $sslCrt, $service_uri, $user_agent,
35             $cookie_jar, $conn_cache, $ssl_opts, $version, $namespace);
36            
37             $scheme = delete($args{'scheme'}) || 'https';
38             $host = delete($args{'host'}) || 'localhost';
39             $port = delete($args{'port'}) || '443';
40             $path = delete($args{'path'}) || '/sdk';
41             $sslKey = delete($args{'sslKey'}) || 'ssl/client.key';
42             $sslCrt = delete($args{'sslCrt'}) || 'ssl/client.crt';
43             #$tunnelPort = delete($args{'sdkTunnelPort'}) || '8089';
44             #$tunnelHost = delete($args{'sdkTunnelHost'}) || 'sdkTunnel';
45            
46             $service_uri = new URI();
47             $service_uri->scheme($scheme);
48             $service_uri->host($host);
49             $service_uri->port($port);
50             $service_uri->path($path);
51            
52             #$tunnel_uri = new URI();
53             #$tunnel_uri->scheme($scheme);
54             #$tunnel_uri->host($tunnelHost);
55             #$tunnel_uri->port($tunnelPort);
56             #$tunnel_uri->path($path);
57            
58             $self = bless {
59             'user_agent' => undef,
60             'soap_action' => '""',
61             'service_uri' => $service_uri,
62             }, $class;
63            
64             $ssl_opts = {
65             verify_hostname => 0,
66             SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE,
67             #SSL_key_file => $sslKey,
68             #SSL_cert_file => $sslCrt,
69             };
70            
71             $user_agent = new LWP::UserAgent(
72             agent => $self->agent_string,
73             ssl_opts => $ssl_opts,
74             );
75            
76             $conn_cache = new LWP::ConnCache();
77             $cookie_jar = new HTTP::Cookies(ignore_discard => 1);
78            
79             $user_agent->cookie_jar($cookie_jar);
80             $user_agent->protocols_allowed(['http', 'https']);
81             $user_agent->conn_cache($conn_cache);
82            
83             $self->user_agent($user_agent);
84            
85             # Query service namespace and version; generate soap_action
86             $version = $self->service_version;
87             $namespace = $self->service_namespace;
88            
89             if (defined $namespace and defined $version) {
90             $self->soap_action($namespace . "/" . $version);
91             } else {
92             return undef;
93             }
94            
95             return $self;
96             }
97              
98             sub agent_string {
99             return "Perl/VMOMI";
100             }
101              
102             sub service_version {
103             my $self = shift;
104            
105             return $self->{'service_version'} if defined $self->{'service_version'};
106            
107             my ($req, $res, $uri, $xml, $doc, $namespaces, $version);
108            
109             $uri = $self->service_uri->clone;
110             $uri->path($uri->path . "/vimServiceVersions.xml");
111            
112             $req = new HTTP::Request();
113             $req->uri($uri);
114             $req->method('GET');
115             $req->content_type('text/xml');
116            
117             $res = $self->user_agent->request($req);
118             $xml = new XML::LibXML();
119            
120             # TODO: verify is_error will not have false positives for non 200 codes from the API
121             if ($res->is_error) {
122             Exception::Protocol->throw(
123             message => "Failed to retrieve server version at '" . $uri->as_string . "' (" .
124             $res->status_line . ")\n"
125             );
126             }
127            
128             eval {
129             $doc = $xml->parse_string($res->content)
130             };
131            
132             # If parse_string() does not parse clean, there must be a connection or protocol error.
133             # Set error to the response status line as the XML error will be non-descriptive.
134             if ($@) {
135             Exception::Protocol->throw(
136             message => $res->status_line,
137             );
138             }
139            
140             $namespaces = $doc->documentElement->getChildrenByTagName('namespace');
141             foreach my $ns (@{ $namespaces || [ ] }) {
142             my ($name);
143             $name = $ns->getChildrenByTagName('name')->shift;
144             if ($name->textContent eq 'urn:vim25') {
145             $version = $ns->getChildrenByTagName('version')->shift->textContent;
146             }
147             }
148             return $self->{'service_version'} = $version;
149             }
150              
151             sub service_namespace {
152             my $self = shift;
153            
154             return $self->{'service_namespace'} if defined $self->{'service_namespace'};
155            
156             my ($req, $res, $uri, $xml, $doc, $target, $namespace);
157            
158             $uri = $self->service_uri->clone;
159             $uri->path($uri->path . "/vimService.wsdl");
160            
161             $req = new HTTP::Request();
162             $req->uri($uri);
163             $req->method('GET');
164             $req->content_type('text/xml');
165            
166             $res = $self->user_agent->request($req);
167             $xml = new XML::LibXML();
168              
169             # Verify is_error will not have false positives for non 200 codes from the vSphere API
170             if ($res->is_error) {
171             Exception::Protocol->throw(
172             message => "Failed to retrieve server namespace at '" . $uri->as_string .
173             "' (" . $res->status_line . ")\n"
174             );
175             }
176            
177            
178            
179             # If parse_string() does not parse clean, there must have been a connection or other
180             # protocol error. Set error to the response status line as the XML error should be
181             # non-descriptive.
182             eval { $doc = $xml->parse_string($res->content) };
183             if ($@) {
184             Exception::Protocol->throw(message => $res->status_line);
185             }
186            
187             $target = $doc->documentElement->getAttribute('targetNamespace');
188             if (defined $target) {
189             ($namespace) = $target =~ /^(urn:vim[0-9a-zA-Z]+)(?:Service)/;
190             } else {
191             Exception::Protocol->throw(
192             message => "Service target namespace (" . $uri->path . ") unavailable: $@",
193             );
194             }
195             return $self->{'service_namespace'} = $namespace;
196             }
197              
198             sub soap_call {
199             my ($self, $operation, $ret_type, $is_array, $x_args, $v_args) = @_;
200             my ($xmldoc, $envelope, $body, $namespace, $soap_action, $uri, $request, $response,
201             $reader, @returnval, $result, $fault );
202            
203             # SOAP Envelope
204             $xmldoc = new XML::LibXML::Document("1.0", "UTF-8");
205             $envelope = $xmldoc->createElement("soapenv:Envelope");
206             $envelope->setAttributeNS(
207             "http://www.w3.org/2000/xmlns/",
208             "xmlns:soapenv",
209             "http://schemas.xmlsoap.org/soap/envelope/" );
210             $envelope->setAttributeNS(
211             "http://www.w3.org/2000/xmlns/",
212             "xmlns:xsd",
213             "http://www.w3.org/2001/XMLSchema" );
214             $envelope->setAttributeNS(
215             "http://www.w3.org/2000/xmlns/",
216             "xmlns:xsi",
217             "http://www.w3.org/2001/XMLSchema-instance" );
218             $body = new XML::LibXML::Element("soapenv:Body");
219             $envelope->addChild($body);
220            
221             $operation = new XML::LibXML::Element($operation);
222             $namespace = $self->service_namespace;
223             $operation->setAttribute("xmlns", $namespace);
224            
225             # Enumerate expected arguments
226             foreach (@$x_args) {
227             my ($x_name, $x_type, $v_value, $v_type, $node);
228            
229             ($x_name, $x_type) = @$_;
230             if (exists $v_args->{$x_name}) {
231             my $v_value = delete($v_args->{$x_name});
232             my $v_type = ref $v_value;
233            
234             if ($v_type eq 'ARRAY') {
235             foreach (@$v_value) {
236             my $c_type = ref $_;
237             $c_type =~ s/.*:://;
238             $node = $self->soap_node($_, $c_type, $x_name, $x_type);
239             $operation->addChild($node);
240             }
241             } elsif (defined $v_value) {
242             $v_type =~ s/.*:://;
243             $node = $self->soap_node($v_value, $v_type, $x_name, $x_type);
244             $operation->addChild($node);
245             } else {
246             $node = new XML::LibXML::Element($x_name);
247             $operation->addChild($node);
248             }
249             }
250             }
251             $body->addChild($operation);
252             $xmldoc->addChild($envelope);
253            
254             # SOAP Action
255             $soap_action = $self->service_namespace . "/" . $self->service_version;
256            
257             # SOAP Request
258             $uri = $self->service_uri;
259             $request = new HTTP::Request();
260             $request->method('POST');
261             $request->uri($uri);
262             $request->content_type('text/xml');
263             $request->content($xmldoc->toString);
264             $request->header(SOAPAction => $soap_action);
265              
266             # SOAP Response
267             $response = $self->user_agent->request($request);
268            
269             # Review error handling for the reader interface; return to status code evaluation?
270             $reader = new XML::LibXML::Reader(string => $response->content);
271            
272             # Parse for soapenv:Fault and soapenv:Body
273             while ($reader->read) {
274             my ($name, $type, $depth, $class, $content, $value);
275            
276             $name = $reader->name;
277             $type = $reader->nodeType;
278             $depth = $reader->depth;
279            
280             if ($name =~ m/returnval/ and $type == 1 and $depth == 3) {
281             # Would there be a need to check type attribute and call an emit_type?
282             # TODO: Create a base boolean type to simplify deserialization!
283             if (defined $ret_type) {
284             if ($ret_type eq 'boolean') {
285             $content = $reader->readInnerXml;
286             if ($content =~ m/(true|1)/i) {
287             $value = 1;
288             } elsif ($content =~ m/(false|0)/i) {
289             $value = 0;
290             } else {
291             Exception::Deserialize(
292             message => "deserialization error: server returned '$value' as a boolean"
293             );
294             }
295             push @returnval, $value;
296             } else {
297             $class = P5NS . "::$ret_type";
298             $value = $class->deserialize($reader, $self);
299             push @returnval, $value;
300             }
301             } else {
302             $value = $reader->readInnerXml;
303             push @returnval, $value;
304             }
305             }
306             if ($name =~ m/soapenv:Fault/ and $type == 1 and $depth == 2) {
307             $fault = $self->soap_fault($reader);
308             }
309             }
310            
311             if ($is_array) {
312             $result = \@returnval;
313             } else {
314             $result = pop @returnval;
315             }
316            
317             Exception::SoapFault->throw(
318             message => $fault->{'faultstring'},
319             detail => $fault->{'detail'},
320             faultcode => $fault->{'faultcode'}
321             ) if $fault;
322              
323             return $result;
324             }
325              
326              
327             sub soap_node {
328             my ($self, $value, $type, $x_name, $x_type) = @_;
329             my ($node);
330            
331            
332             if (defined $x_type) {
333             if (defined $value) {
334             # boolean
335             if ($x_type eq 'boolean') {
336             if ($value =~ m/(true|1)/i) {
337             $value = 'true';
338             } elsif ($value =~ m/(false|0)/i) {
339             $value = 'false';
340             } else {
341             Exception::Serialize->throw(
342             message => "serialization error: cannot convert '$value' to" .
343             " boolean for member '$x_name'"
344             );
345             }
346             $node = new XML::LibXML::Element($x_name);
347             $node->appendText($value);
348             return $node
349             }
350            
351             # ManagedObjectReference
352             if ($x_type eq 'ManagedObjectReference') {
353             if ($value->isa(P5NS . "::ManagedObject")) {
354             if (exists $value->{'_moref'}) {
355             $value = $value->{'_moref'};
356             }
357             } elsif (not $type eq 'ManagedObjectReference') {
358             Exception::Serialize->throw(
359             message => "serialization error: expected $x_type, not $type for" .
360             " member '$x_name'"
361             );
362             }
363             }
364            
365             if ($type ne $x_type) {
366             $node = $value->serialize($x_name, $type);
367             } else {
368             $node = $value->serialize($x_name);
369             }
370             }
371             } else {
372             # xsi type (string, int, double, etc)
373             if (defined $value) {
374             $node = new XML::LibXML::Element($x_name);
375             $node->appendText($value);
376             }
377             }
378             return $node;
379             }
380              
381             sub soap_fault {
382             my ($self, $reader) = @_;
383             my ($node_name, $node_depth, $node_type, $name, $depth, $type, $fault);
384            
385             $fault = { };
386            
387             $node_name = $reader->name;
388             $node_depth = $reader->depth;
389             $node_type = $reader->nodeType;
390            
391             do {
392             $reader->read;
393            
394             my ($class, $xsi_type);
395            
396             $name = $reader->name;
397             $depth = $reader->depth;
398             $type = $reader->nodeType;
399            
400             if ($name =~ m/faultcode/ and $type == 1 and $depth == 3) {
401             $fault->{faultcode} = $reader->readInnerXml;
402             }
403             if ($name =~ m/faultstring/ and $type == 1 and $depth == 3) {
404             $fault->{faultstring} = $reader->readInnerXml;
405             }
406             if ($name =~ m/detail/ and $type == 1 and $depth == 3) {
407             $reader->read;
408            
409             $name = $reader->name;
410             $name =~ m/(.*)Fault/;
411             $class = P5NS . "::$1";
412             $fault->{detail} = $class->deserialize($reader);
413             }
414             } until ($name eq $node_name and $type != $node_type and $depth == $node_depth);
415            
416             return $fault;
417             }
418              
419             1;