File Coverage

blib/lib/Net/DRI/Transport/HTTP.pm
Criterion Covered Total %
statement 18 143 12.5
branch 0 50 0.0
condition 0 30 0.0
subroutine 6 18 33.3
pod 1 8 12.5
total 25 249 10.0


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, HTTP/HTTPS Transport
2             ##
3             ## Copyright (c) 2008-2011,2013,2015 Patrick Mevzek . 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             package Net::DRI::Transport::HTTP;
16              
17 1     1   30777 use strict;
  1         1  
  1         23  
18 1     1   5 use warnings;
  1         1  
  1         24  
19              
20 1     1   3 use base qw(Net::DRI::Transport);
  1         0  
  1         327  
21              
22 1     1   4 use Net::DRI::Exception;
  1         1  
  1         12  
23 1     1   357 use Net::DRI::Util;
  1         2  
  1         33  
24              
25 1     1   5 use LWP::UserAgent 6.02;
  1         19  
  1         957  
26              
27             =pod
28              
29             =head1 NAME
30              
31             Net::DRI::Transport::HTTP - HTTP/HTTPS Transport for Net::DRI
32              
33             =head1 DESCRIPTION
34              
35             This module implements an HTTP/HTTPS transport for establishing connections in Net::DRI
36              
37             =head1 METHODS
38              
39             At creation (see Net::DRI C) you pass a reference to an hash, with the following available keys:
40              
41             =head2 timeout
42              
43             time to wait (in seconds) for server reply
44              
45             =head2 ssl_key_file ssl_cert_file ssl_ca_file ssl_ca_path ssl_cipher_list ssl_version ssl_passwd_cb
46              
47             if C begins with https://, all key materials, see IO::Socket::SSL documentation for corresponding options
48              
49             =head2 ssl_verify
50              
51             see IO::Socket::SSL documentation about verify_mode (by default 0x00 here)
52              
53             =head2 ssl_verify_callback
54              
55             see IO::Socket::SSL documentation about verify_callback, it gets here as first parameter the transport object
56             then all parameter given by IO::Socket::SSL; it is explicitly verified that the subroutine returns a true value,
57             and if not the connection is aborted.
58              
59             =head2 remote_url
60              
61             URL to access
62              
63             =head2 client_login client_password
64              
65             protocol login & password
66              
67             =head2 client_newpassword
68              
69             (optional) new password if you want to change password on login for registries handling that at connection
70              
71             =head2 protocol_connection
72              
73             Net::DRI class handling protocol connection details. Specifying it should not be needed, as the registry driver should have correct default values.
74              
75             =head2 protocol_data
76              
77             (optional) opaque data given to protocol_connection class.
78             For EPP, a key login_service_filter may exist, whose value is a code ref. It will be given an array of services, and should give back a
79             similar array; it can be used to filter out some services from those given by the registry.
80              
81             =head2 verify_response
82              
83             (optional) a callback (code ref) executed after each exchange with the registry, being called with the following parameters: the transport object,
84             the phase (1 for greeting+login, 2 for all normal operations, 3 for logout), the count (if we retried multiple times to send the same message),
85             the message sent (HTTP::Request object) and the response received (HTTP::Response object). This can be used to verify/diagnose SSL details,
86             see example in file t/live/opensrs_xcp.t
87              
88             =head2 local_host
89              
90             (optional) the local address (hostname or IP) you want to use to connect (if you are multihomed)
91              
92             =head1 SUPPORT
93              
94             For now, support questions should be sent to:
95              
96             Enetdri@dotandco.comE
97              
98             Please also see the SUPPORT file in the distribution.
99              
100             =head1 SEE ALSO
101              
102             Ehttp://www.dotandco.com/services/software/Net-DRI/E
103              
104             =head1 AUTHOR
105              
106             Patrick Mevzek, Enetdri@dotandco.comE
107              
108             =head1 COPYRIGHT
109              
110             Copyright (c) 2008-2011,2013,2015 Patrick Mevzek .
111             All rights reserved.
112              
113             This program is free software; you can redistribute it and/or modify
114             it under the terms of the GNU General Public License as published by
115             the Free Software Foundation; either version 2 of the License, or
116             (at your option) any later version.
117              
118             See the LICENSE file that comes with this distribution for more details.
119              
120             =cut
121              
122             ####################################################################################################
123              
124             sub new
125             {
126 0     0 1   my ($class,$ctx,$rp)=@_;
127 0           my %opts=%$rp;
128 0           my $ndr=$ctx->{registry};
129 0           my $pname=$ctx->{profile};
130 0           my $po=$ctx->{protocol};
131              
132 0           my %t=(message_factory => $po->factories()->{message});
133 0 0 0       Net::DRI::Exception::usererr_insufficient_parameters('protocol_connection') unless (exists($opts{protocol_connection}) && $opts{protocol_connection});
134 0           $t{pc}=$opts{protocol_connection};
135 0           Net::DRI::Util::load_module($t{pc},'transport/http');
136 0 0         if ($t{pc}->can('transport_default'))
137             {
138 0           %opts=($t{pc}->transport_default('http'),%opts);
139             }
140              
141 0           my $self=$class->SUPER::new($ctx,\%opts); ## We are now officially a Net::DRI::Transport instance
142 0           $self->has_state(1); ## some registries need login (like .PL) some not (like .ES) ; see end of method & call to open_connection()
143 0           $self->is_sync(1);
144 0           $self->name('http');
145 0           $self->version('0.2');
146              
147 0           foreach my $k (qw/client_login client_password client_newpassword protocol_data/)
148             {
149 0 0         $t{$k}=$opts{$k} if exists($opts{$k});
150             }
151              
152 0           my @need=qw/read_data write_message/;
153 0 0         Net::DRI::Exception::usererr_invalid_parameters('protocol_connection class must have: '.join(' ',@need)) if (grep { ! $t{pc}->can($_) } @need);
  0            
154 0 0 0       $t{protocol_data}=$opts{protocol_data} if (exists($opts{protocol_data}) && $opts{protocol_data});
155 0 0 0       Net::DRI::Exception::usererr_insufficient_parameters('remote_url must be defined') unless (exists $opts{'remote_url'} && defined $opts{'remote_url'});
156 0 0         Net::DRI::Exception::usererr_invalid_parameters('remote_url must be an uri starting with http:// or https:// with a proper path') unless $opts{remote_url}=~m!^https?://\S+/\S*$!;
157 0           $t{remote_url}=$opts{remote_url};
158 0           $t{remote_uri}=$t{remote_url}; ## only used for error messages
159              
160 0           my $ua=LWP::UserAgent->new();
161 0           $ua->agent(sprintf('Net::DRI/%s ',$Net::DRI::VERSION)); ## the final space triggers LWP::UserAgent to add its own string
162 0           $ua->cookie_jar({}); ## Cookies needed by some registries, like .PL (how strange !)
163             ## Now some security settings
164 0           $ua->max_redirect(0);
165 0           $ua->parse_head(0);
166 0           $ua->protocols_allowed(['http','https']);
167 0 0         $ua->timeout($self->timeout()) if $self->timeout(); ## problem with our own alarm ?
168 0 0 0       $ua->local_address($opts{local_host}) if exists $opts{local_host} && defined $opts{local_host};
169              
170 0 0         if ($t{remote_url}=~m!^https://!)
171             {
172 0           my %ssl=%{$self->parse_ssl_options(\%opts)};
  0            
173 0           while(my ($k,$v)=each %ssl)
174             {
175 0           $ua->ssl_opts($k,$v);
176             }
177             }
178              
179 0           $t{ua}=$ua;
180 0 0 0       $t{verify_response}=$opts{verify_response} if (exists($opts{verify_response}) && defined($opts{verify_response}) && (ref($opts{verify_response}) eq 'CODE'));
      0        
181 0           $self->{transport}=\%t;
182 0 0         $t{pc}->init($self) if $t{pc}->can('init');
183              
184 0           $self->open_connection($ctx); ## noop for registries without login, will properly setup has_state()
185 0           return $self;
186             }
187              
188             sub send_login
189             {
190 0     0 0   my ($self,$ctx)=@_;
191 0           my $t=$self->transport_data();
192 0           my $pc=$t->{pc};
193 0           my ($cltrid,$dr);
194              
195             ## Get registry greeting, if available
196 0 0 0       if ($pc->can('greeting') && $pc->can('parse_greeting'))
197             {
198 0           $cltrid=$self->generate_trid($self->{logging_ctx}->{registry}); ## not used for greeting ( has no clTRID), but used in logging
199 0           my $greeting=$pc->greeting($t->{message_factory});
200 0           $self->log_output('notice','transport',$ctx,{trid=>$cltrid,phase=>'opening',direction=>'out',message=>$greeting});
201 0 0         Net::DRI::Exception->die(0,'transport/http',4,'Unable to send greeting message to '.$t->{remote_uri}) unless $self->_http_send(1,$greeting,1);
202 0           $dr=$self->_http_receive(1);
203 0           $self->log_output('notice','transport',$ctx,{trid=>$cltrid,phase=>'opening',direction=>'in',message=>$dr});
204 0           my $rc1=$pc->parse_greeting($dr); ## gives back a Net::DRI::Protocol::ResultStatus
205 0 0         die($rc1) unless $rc1->is_success();
206             }
207              
208 0           my $login=$pc->login($t->{message_factory},$t->{client_login},$t->{client_password},$cltrid,$dr,$t->{client_newpassword},$t->{protocol_data});
209 0           $self->log_output('notice','transport',$ctx,{trid=>$cltrid,phase=>'opening',direction=>'out',message=>$login});
210 0 0         Net::DRI::Exception->die(0,'transport/http',4,'Unable to send login message to '.$t->{remote_uri}) unless $self->_http_send(1,$login,1);
211 0           $dr=$self->_http_receive(1);
212 0           $self->log_output('notice','transport',$ctx,{trid=>$cltrid,phase=>'opening',direction=>'in',message=>$dr});
213 0           my $rc2=$pc->parse_login($dr); ## gives back a Net::DRI::Protocol::ResultStatus
214 0 0         die($rc2) unless $rc2->is_success();
215 0           return;
216             }
217              
218             sub open_connection
219             {
220 0     0 0   my ($self,$ctx)=@_;
221 0           my $t=$self->transport_data();
222 0           my $pc=$t->{pc};
223 0           $self->has_state(0);
224              
225 0 0 0       if ($pc->can('login') && $pc->can('parse_login'))
226             {
227 0           $self->send_login($ctx);
228 0           $self->has_state(1);
229 0           $self->current_state(1);
230             }
231              
232 0           $self->time_open(time());
233 0           $self->time_used(time());
234 0           $self->transport_data()->{exchanges_done}=0;
235 0           return;
236             }
237              
238             sub send_logout
239             {
240 0     0 0   my ($self)=@_;
241 0           my $t=$self->transport_data();
242 0           my $pc=$t->{pc};
243              
244 0 0 0       return unless ($pc->can('logout') && $pc->can('parse_logout'));
245              
246 0           my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry});
247 0           my $logout=$pc->logout($t->{message_factory},$cltrid);
248 0           $self->log_output('notice','transport',{otype=>'session',oaction=>'logout'},{trid=>$cltrid,phase=>'closing',direction=>'out',message=>$logout});
249 0 0         Net::DRI::Exception->die(0,'transport/http',4,'Unable to send logout message to '.$t->{remote_uri}) unless $self->_http_send(1,$logout,3);
250 0           my $dr=$self->_http_receive(1);
251 0           $self->log_output('notice','transport',{otype=>'session',oaction=>'logout'},{trid=>$cltrid,phase=>'closing',direction=>'in',message=>$dr});
252 0           my $rc1=$pc->parse_logout($dr);
253 0 0         die($rc1) unless $rc1->is_success();
254 0           return;
255             }
256              
257             sub close_connection
258             {
259 0     0 0   my ($self)=@_;
260 0 0 0       $self->send_logout() if ($self->has_state() && $self->current_state());
261 0           $self->transport_data()->{ua}->cookie_jar({});
262 0           $self->current_state(0);
263 0           return;
264             }
265              
266             sub end
267             {
268 0     0 0   my ($self)=@_;
269 0 0         if ($self->current_state())
270             {
271             eval
272 0           {
273 0     0     local $SIG{ALRM}=sub { die 'timeout' };
  0            
274 0           alarm(10);
275 0           $self->close_connection();
276             };
277 0           alarm(0); ## since close_connection may die, this must be outside of eval to be executed in all cases
278             }
279 0           return;
280             }
281              
282             sub send ## no critic (Subroutines::ProhibitBuiltinHomonyms)
283             {
284 0     0 0   my ($self,$ctx,$tosend)=@_;
285 0     0     return $self->SUPER::send($ctx,$tosend,\&_http_send,sub {});
286             }
287              
288             sub _http_send
289             {
290 0     0     my ($self,$count,$tosend,$phase)=@_;
291 0 0         $phase=2 unless defined($phase); ## Phase 2 = normal operations (1=greeting+login, 3=logout)
292 0           my $t=$self->transport_data();
293              
294             ## Content-Length is automatically computed and added during the request() call, no need to do it before
295 0           my $req=$t->{pc}->write_message($self,$tosend); ## gives back an HTTP::Request object
296 0           Net::DRI::Util::check_isa($req,'HTTP::Request');
297 0           my $ans=$t->{ua}->request($req);
298 0 0         $t->{verify_response}->($self,$phase,$count,$req,$ans) if exists($t->{verify_response});
299 0           $t->{last_reply}=$ans;
300 0           return 1; ## very important
301             }
302              
303             sub receive
304             {
305 0     0 0   my ($self,$ctx,$count)=@_;
306 0           return $self->SUPER::receive($ctx,\&_http_receive);
307             }
308              
309             sub _http_receive
310             {
311 0     0     my ($self,$count)=@_;
312 0           my $t=$self->transport_data();
313              
314             ## Convert answer in a Net::DRI::Data::Raw object
315 0           my $dr=$t->{pc}->read_data($self,$t->{last_reply});
316 0           Net::DRI::Util::check_isa($dr,'Net::DRI::Data::Raw');
317 0           $t->{last_reply}=undef;
318 0           $t->{exchanges_done}++;
319 0           return $dr;
320             }
321              
322             #####################################################################################################
323             1;