1## Domain Registry Interface, SOAP Transport
2##
3## Copyright (c) 2008-2010 Patrick Mevzek <netdri@dotandco.com>. All rights reserved.
4##
5## This file is part of Net::DRI
6##
7## Net::DRI is free software; you can redistribute it and/or modify
8## it under the terms of the GNU General Public License as published by
9## the Free Software Foundation; either version 2 of the License, or
10## (at your option) any later version.
11##
12## See the LICENSE file that comes with this distribution for more details.
13#
14#
15#
16####################################################################################################
17
18package Net::DRI::Transport::HTTP::SOAPLite;
19
20use strict;
21use warnings;
22
23use base qw(Net::DRI::Transport);
24
25use Net::DRI::Exception;
26use Net::DRI::Data::Raw;
27use Net::DRI::Util;
28use SOAP::Lite;
29
30our $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); };
31
32=pod
33
34=head1 NAME
35
36Net::DRI::Transport::HTTP::SOAPLite - SOAP Transport for Net::DRI
37
38=head1 DESCRIPTION
39
40Please see the README file for details.
41
42=head1 SUPPORT
43
44For now, support questions should be sent to:
45
46E<lt>netdri@dotandco.comE<gt>
47
48Please also see the SUPPORT file in the distribution.
49
50=head1 SEE ALSO
51
52E<lt>http://www.dotandco.com/services/software/Net-DRI/E<gt>
53
54=head1 AUTHOR
55
56Patrick Mevzek, E<lt>netdri@dotandco.comE<gt>
57
58=head1 COPYRIGHT
59
60Copyright (c) 2008-2010 Patrick Mevzek <netdri@dotandco.com>.
61All rights reserved.
62
63This program is free software; you can redistribute it and/or modify
64it under the terms of the GNU General Public License as published by
65the Free Software Foundation; either version 2 of the License, or
66(at your option) any later version.
67
68See the LICENSE file that comes with this distribution for more details.
69
70=cut
71
72####################################################################################################
73
74sub new
75{
76 my ($class,$ctx,$rp)=@_;
77 my %opts=%$rp;
78 my $po=$ctx->{protocol};
79
80 my %t=(message_factory => $po->factories()->{message});
81 if (exists($opts{protocol_connection}) && $opts{protocol_connection})
82 {
83  $t{protocol_connection}=$opts{protocol_connection};
84  $t{protocol_connection}->require or Net::DRI::Exception::err_failed_load_module('transport/socket',$t{protocol_connection},$@);
85  if ($t{protocol_connection}->can('transport_default'))
86  {
87   %opts=($t{protocol_connection}->transport_default('soaplite'),%opts);
88  }
89 }
90
91 my $self=$class->SUPER::new($ctx,\%opts); ## We are now officially a Net::DRI::Transport instance
92 $self->is_sync(1);
93 $self->name('soaplite');
94 $self->version($VERSION);
95
96 $t{has_login}=(exists($opts{has_login}) && defined($opts{has_login}))? $opts{has_login} : 0;
97 $t{has_logout}=(exists($opts{has_logout}) && defined($opts{has_logout}))? $opts{has_logout} : 0;
98 $self->has_state($t{has_login});
99
100 foreach my $p (qw/client_login client_password/)
101 {
102  Net::DRI::Exception::usererr_insufficient_parameters($p.' must be provided') unless (exists($opts{$p}) && defined($opts{$p}));
103  $t{$p}=$opts{$p};
104 }
105
106 $t{session_data}=$t{has_login}? {} : { id => $t{client_login}, pass => $t{client_password} };
107
108 foreach my $p (qw/uri proxy_uri/)
109 {
110  Net::DRI::Exception::usererr_insufficient_parameters($p.' must be provided') unless (exists($opts{$p}) && defined($opts{$p}));
111  $t{$p}=$opts{$p};
112 }
113 Net::DRI::Exception::usererr_invalid_parameters('proxy_uri must be http:// or https://') unless ($t{proxy_uri}=~m!^https?://!);
114
115 my $pc=$opts{protocol_connection};
116 if ($t{has_login} || $t{has_logout})
117 {
118  Net::DRI::Exception::usererr_insufficient_parameters('protocol_connection must be provided') unless (defined($pc));
119 }
120 if ($t{has_login})
121 {
122  foreach my $m (qw/login parse_login extract_session/)
123  {
124   Net::DRI::Exception::usererr_invalid_parameters('Protocol connection class '.$pc.' must have a '.$m.'() method, since has_login=1') unless ($pc->can($m));
125  }
126 }
127 if ($t{has_logout})
128 {
129  foreach my $m (qw/logout parse_logout/)
130  {
131   Net::DRI::Exception::usererr_invalid_parameters('Protocol connection class '.$pc.' must have a '.$m.'() method, since has_logout=1') unless ($pc->can($m));
132  }
133 }
134
135 $self->{transport}=\%t;
136 bless($self,$class);
137
138 if ($self->has_state())
139 {
140  if ($self->defer()) ## we will open, but later
141  {
142   $self->current_state(0);
143  } else ## we will open NOW
144  {
145   $self->open_connection($ctx);
146  }
147 } else
148 {
149  $self->init();
150  $self->time_open(time());
151 }
152
153 return $self;
154}
155
156sub soap { my ($self,$v)=@_; $self->{transport}->{soap}=$v if @_==2; return $self->{transport}->{soap}; }
157sub session_data { my ($self,$v)=@_; $self->{transport}->{session_data}=$v if @_==2; return $self->{transport}->{session_data}; }
158
159sub init
160{
161 my ($self)=@_;
162 return if defined($self->soap());
163 my $soap=SOAP::Lite->new()->uri($self->{transport}->{uri})->proxy($self->{transport}->{proxy_uri});
164 $soap->transport()->agent(sprintf('Net::DRI/%s Net::DRI::Transport::HTTP::SOAPLite/%s ',$Net::DRI::VERSION,$VERSION).$soap->transport()->agent());
165 $self->soap($soap);
166}
167
168sub send_login
169{
170 my ($self,$ctx)=@_;
171 my $t=$self->{transport};
172 return unless $t->{has_login};
173 foreach my $p (qw/client_login client_password/)
174 {
175  Net::DRI::Exception::usererr_insufficient_parameters($p.' must be defined') unless (exists($t->{$p}) && $t->{$p});
176 }
177
178 my $pc=$t->{protocol_connection};
179 my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry});
180 my $login=$pc->login($t->{message_factory},$t->{client_login},$t->{client_password},$cltrid);
181 my $res=$self->_send_receive({otype=>'session',oaction=>'login',trid=>$cltrid,phase=>'opening'},$login);
182 my $msg=$t->{message_factory}->();
183 $msg->parse(Net::DRI::Data::Raw->new(1,[$res->result()]));
184 my $rc=$pc->parse_login($msg);
185 die($rc) unless $rc->is_success();
186
187 $self->session_data($pc->extract_session($msg));
188}
189
190sub send_logout
191{
192 my ($self)=@_;
193 my $t=$self->{transport};
194 return unless $t->{has_logout};
195
196 my $pc=$t->{protocol_connection};
197 my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry});
198 my $logout=$pc->logout($t->{message_factory},$cltrid,$t->{session_data});
199 my $res=$self->_send_receive({otype=>'session',oaction=>'logout',trid=>$cltrid,phase=>'closing'},$logout);
200 my $msg=$t->{message_factory}->();
201 $msg->parse(Net::DRI::Data::Raw->new(1,[$res->result()]));
202 my $rc=$pc->parse_logout($msg);
203 die($rc) unless $rc->is_success();
204
205 $self->session_data({});
206}
207
208sub _send_receive
209{
210 my ($self,$ctx,$msg)=@_;
211 my $soap=$self->soap();
212 my $err;
213 my $res=$soap->on_fault(sub { (undef,$err)=@_; return; })->call($msg->method(),@{$msg->params()});
214 if (my $httpres=$soap->transport()->http_response())
215 {
216  $self->log_output('notice','transport',$ctx,{direction=>'out',message=>$httpres->request()});
217  $self->log_output('notice','transport',$ctx,{direction=>'in', message=>$httpres});
218 } else
219 {
220  $self->log_output('error','transport',$ctx,{direction=>'out',message=>'No response for message '.$soap->serializer()->envelope(method => $msg->method(), @{$msg->params()})});
221 }
222 return $res if defined $res && ref $res && ! $res->fault() && ! defined $err;
223
224 Net::DRI::Exception->die(1,'transport/soaplite',4,'Unable to send message due to SOAP fault: '.$err->faultcode().' '.$err->faultstring()) if defined $err && ref $err;
225 Net::DRI::Exception->die(1,'transport/soaplite',4,'Unable to send message due to SOAP transport error: '.$soap->transport()->status()) unless $soap->transport()->is_success();
226 Net::DRI::Exception->die(1,'transport/soaplite',4,'Unable to send message due to SOAP deserialization error: '.$err);
227}
228
229sub open_connection
230{
231 my ($self,$ctx)=@_;
232 $self->init();
233 $self->send_login($ctx);
234 $self->current_state(1);
235 $self->time_open(time());
236 $self->time_used(time());
237}
238
239sub close_connection
240{
241 my ($self)=@_;
242 $self->send_logout();
243 $self->soap(undef);
244 $self->current_state(0);
245}
246
247sub end
248{
249 my ($self)=@_;
250 if ($self->has_state() && $self->current_state())
251 {
252  eval
253  {
254   local $SIG{ALRM}=sub { die 'timeout' };
255   alarm(10);
256   $self->close_connection();
257  };
258  alarm(0); ## since close_connection may die, this must be outside of eval to be executed in all cases
259 }
260}
261
262####################################################################################################
263
264sub send
265{
266 my ($self,$ctx,$tosend)=@_;
267 $self->SUPER::send($ctx,$tosend,\&_soap_send,sub {});
268}
269
270sub _soap_send
271{
272 my ($self,$count,$tosend,$ctx)=@_;
273 my $t=$self->{transport};
274 $tosend->add_session($self->session_data());
275 my $res=$self->_send_receive($ctx,$tosend);
276 $t->{last_reply}=$res;
277 return 1; ## very important
278}
279
280sub receive
281{
282 my ($self,$ctx,$count)=@_;
283 return $self->SUPER::receive($ctx,\&_soap_receive);
284}
285
286sub _soap_receive
287{
288 my ($self,$count)=@_;
289 my $t=$self->{transport};
290 my $r=$t->{last_reply};
291 $t->{last_reply}=undef;
292 return Net::DRI::Data::Raw->new(6,[$r->result()]);
293}
294
295####################################################################################################
2961;
297