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