File Coverage

lib/XML/Compile/SOAP/WSS.pm
Criterion Covered Total %
statement 27 101 26.7
branch 0 32 0.0
condition 0 22 0.0
subroutine 9 23 39.1
pod 9 12 75.0
total 45 190 23.6


line stmt bran cond sub pod time code
1             # Copyrights 2011-2015 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.01.
5 1     1   1554 use warnings;
  1         2  
  1         56  
6 1     1   7 use strict;
  1         3  
  1         43  
7              
8             package XML::Compile::SOAP::WSS;
9 1     1   7 use vars '$VERSION';
  1         1  
  1         89  
10             $VERSION = '1.13';
11              
12 1     1   7 use base 'XML::Compile::SOAP::Extension';
  1         1  
  1         724  
13              
14 1     1   831 use Log::Report 'xml-compile-wss';
  1         2  
  1         4  
15              
16 1     1   182 use XML::Compile::WSS::Util qw/:wss11 :utp11/;
  1         2  
  1         164  
17 1     1   8 use XML::Compile::WSS ();
  1         2  
  1         28  
18 1     1   1673 use XML::Compile::SOAP::Util qw/SOAP11ENV/;
  1         1012  
  1         78  
19              
20 1     1   6 use Scalar::Util qw/weaken/;
  1         2  
  1         1149  
21              
22              
23             sub init($)
24 0     0 0   { my ($self, $args) = @_;
25 0           $self->SUPER::init($args);
26 0           $self->{XCSW_wss} = [];
27              
28 0           my $schema = $self->{XCSW_schema} = $args->{schema};
29 0           weaken $self->{XCSW_schema};
30              
31             # [1.0] to support backwards compat
32 0 0         XML::Compile::WSS->loadSchemas($schema, '1.1') if $schema;
33 0           $self;
34             }
35              
36             sub wsdl11Init($$)
37 0     0 1   { my ($self, $wsdl, $args) = @_;
38 0           $self->SUPER::wsdl11Init($wsdl, $args);
39              
40 0           $self->{XCSW_schema} = $wsdl;
41 0           weaken $self->{XCSW_schema};
42              
43 0           XML::Compile::WSS->loadSchemas($wsdl, '1.1');
44 0           $wsdl->addPrefixes('SOAP-ENV' => SOAP11ENV);
45              
46 0           $self;
47             }
48              
49             sub soap11OperationInit($$)
50 0     0 1   { my ($self, $op, $args) = @_;
51              
52 0 0         my $schema = $self->schema
53             or error __x"WSS not connected to the WSDL: WSS needs to be instantiated
54             before the WSDL because it influences its interpretation";
55              
56             # this is not a nice hack for apps where multiple ::WSDL or ::Schema
57             # objects are active https://rt.cpan.org/Ticket/Display.html?id=99735
58 0 0         $schema eq $op->schemas or return;
59              
60 0           trace "adding wss header logic"; # get full type from any schema
61 0           my $sec = $schema->findName('wsse:Security');
62 0           $op->addHeader(INPUT => "wsse_Security" => $sec, mustUnderstand => 1);
63 0           $op->addHeader(OUTPUT => "wsse_Security" => $sec, mustUnderstand => 1);
64             }
65             *soap12OperationInit = \&soap11OperationInit;
66              
67             sub soap11ClientWrapper($$$)
68 0     0 1   { my ($self, $op, $call, $args) = @_;
69              
70 0 0         $self->schema eq $op->schemas or return;
71              
72             sub {
73 0 0   0     my $data = @_==1 ? shift : {@_};
74 0           my $sec = $data->{wsse_Security};
75              
76             # Support pre-1.0 interface
77 0 0         return $call->($data)
78             if ref $sec eq 'HASH';
79              
80             # select plugins
81 0   0       my $wss = $sec || $self->{XCSW_wss};
82 0 0         my @wss = ref $wss eq 'ARRAY' ? @$wss : $wss;
83              
84             # Adding WSS headers to $secw
85 0           my $secw = $data->{wsse_Security} = {};
86 0   0       my $doc = $data->{_doc} ||= XML::LibXML::Document->new('1.0','UTF-8');
87 0           $_->create($doc, $secw) for @wss;
88            
89             # The real work: SOAP message formatting and exchange
90 0           my ($answer, $trace) = $call->($data);
91              
92 0 0         if(defined $answer)
93 0   0       { my $secr = $answer->{wsse_Security} ||= {};
94 0           $_->check($secr) for @wss;
95             }
96            
97 0 0         wantarray ? ($answer, $trace) : $answer;
98 0           };
99             }
100             *soap12ClientWrapper = \&soap11ClientWrapper;
101              
102             #---------------------------
103              
104 0     0 1   sub schema() { shift->{XCSW_schema} }
105 0     0 1   sub features() { @{shift->{XCSW_wss}} }
  0            
106              
107             sub addFeature($)
108 0     0 1   { my ($self, $n) = @_;
109 0 0         my $schema = $n->schema
110             or error __x"no schema yet. Instantiate ::WSS before ::WSDL";
111              
112 0           push @{$self->{XCSW_wss}}, $n;
  0            
113 0           $n;
114             }
115              
116             #---------------------------
117              
118             sub _start($$)
119 0     0     { my ($self, $plugin, $args) = @_;
120              
121 0           eval "require $plugin";
122 0 0         panic $@ if $@;
123              
124 0 0 0       my $schema = $args->{schema} ||= $self->schema
125             or error __x"instantiate {pkg} before the wsdl, plugins after"
126             , pkg => __PACKAGE__;
127              
128 0           $self->addFeature($plugin->new($args));
129             }
130              
131              
132             sub basicAuth(%)
133 0     0 1   { my ($self, %args) = @_;
134 0           $self->_start('XML::Compile::WSS::BasicAuth', \%args);
135             }
136              
137              
138             sub timestamp(%)
139 0     0 1   { my ($self, %args) = @_;
140 0           $self->_start('XML::Compile::WSS::Timestamp', \%args);
141             }
142              
143              
144             sub signature(%)
145 0     0 1   { my ($self, %args) = @_;
146 0   0       my $schema = $args{schema} || $self->schema;
147              
148 0           my $has12 = defined $schema->prefix('env12');
149 0 0 0       $args{sign_types} ||= ['SOAP-ENV:Body', ($has12 ? 'env12:Body' : ())];
150 0   0       $args{sign_put} ||= 'wsse:SecurityHeaderType';
151 0 0 0       $args{sign_when} ||= ['SOAP-ENV:Envelope', ($has12 ? 'env12:Envelope':())];
152              
153 0           my $sig = $self->_start('XML::Compile::WSS::Signature', \%args);
154 0           $sig;
155             }
156              
157             #--------------------------------------
158             # [1.0] Expired interface
159             sub wsseBasicAuth($$$@)
160 0     0 0   { my ($self, $username, $password, $pwtype, %args) = @_;
161             # use XML::Compile::WSS::BasicAuth!!! This method will be removed!
162              
163 0           eval "require XML::Compile::WSS::BasicAuth";
164 0 0         panic $@ if $@;
165              
166 0   0       my $auth = XML::Compile::WSS::BasicAuth->new
167             ( username => $username
168             , password => $password
169             , pwformat => $pwtype || UTP11_PTEXT
170             , %args
171             , schema => $self->schema
172             );
173              
174 0           my $doc = XML::LibXML::Document->new('1.0', 'UTF-8');
175 0           $auth->create($doc, {});
176             }
177              
178             # [1.0] Expired interface
179             sub wsseTimestamp($$$@)
180 0     0 0   { my ($self, $created, $expires, %args) = @_;
181             # use XML::Compile::WSS::Timestamp!!! This method will be removed!
182              
183 0           eval "require XML::Compile::WSS::Timestamp";
184 0 0         panic $@ if $@;
185              
186 0           my $ts = XML::Compile::WSS::Timestamp->new
187             ( created => $created
188             , expires => $expires
189             , %args
190             , schema => $self->schema
191             );
192              
193 0           my $doc = XML::LibXML::Document->new('1.0', 'UTF-8');
194 0           $ts->create($doc, {});
195             }
196              
197             1;