File Coverage

blib/lib/Net/DRI/Transport/Socket.pm
Criterion Covered Total %
statement 30 236 12.7
branch 0 94 0.0
condition 0 68 0.0
subroutine 10 28 35.7
pod 1 13 7.6
total 41 439 9.3


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, TCP/SSL Socket Transport
2             ##
3             ## Copyright (c) 2005-2013,2016 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::Socket;
16              
17 1     1   908 use base qw(Net::DRI::Transport);
  1         1  
  1         60  
18              
19 1     1   4 use strict;
  1         1  
  1         14  
20 1     1   3 use warnings;
  1         1  
  1         16  
21              
22 1     1   3 use Time::HiRes ();
  1         1  
  1         9  
23 1     1   3 use IO::Socket::INET;
  1         1  
  1         12  
24             ## At least this version is needed, to have getline()
25 1     1   1137 use IO::Socket::SSL 0.90;
  1         32078  
  1         4  
26 1     1   124 use Scalar::Util ();
  1         2  
  1         12  
27              
28 1     1   4 use Net::DRI::Exception;
  1         1  
  1         15  
29 1     1   3 use Net::DRI::Util;
  1         1  
  1         15  
30 1     1   3 use Net::DRI::Data::Raw;
  1         1  
  1         6  
31              
32              
33             =pod
34              
35             =head1 NAME
36              
37             Net::DRI::Transport::Socket - TCP/TLS Socket connection for Net::DRI
38              
39             =head1 DESCRIPTION
40              
41             This module implements a socket (tcp or tls) for establishing connections in Net::DRI
42              
43             =head1 METHODS
44              
45             At creation (see Net::DRI C) you pass a reference to an hash, with the following available keys:
46              
47             =head2 socktype
48              
49             ssl, tcp or udp
50              
51             =head2 ssl_key_file ssl_cert_file ssl_ca_file ssl_ca_path ssl_cipher_list ssl_version ssl_passwd_cb ssl_hostname
52              
53             if C is 'ssl', all key materials, see IO::Socket::SSL documentation for corresponding options
54              
55             =head2 ssl_verify
56              
57             see IO::Socket::SSL documentation about verify_mode (by default 0x00 here)
58              
59             =head2 ssl_verify_callback
60              
61             see IO::Socket::SSL documentation about verify_callback, it gets here as first parameter the transport object
62             then all parameter given by IO::Socket::SSL; it is explicitly verified that the subroutine returns a true value,
63             and if not the connection is aborted.
64              
65             =head2 remote_host remote_port
66              
67             hostname (or IP address) & port number of endpoint
68              
69             =head2 client_login client_password
70              
71             protocol login & password
72              
73             =head2 client_newpassword
74              
75             (optional) new password if you want to change password on login for registries handling that at connection
76              
77             =head2 protocol_connection
78              
79             Net::DRI class handling protocol connection details. (Ex: C or C)
80              
81             =head2 protocol_data
82              
83             (optional) opaque data given to protocol_connection class.
84             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
85             similar array; it can be used to filter out some services from those given by the registry.
86              
87             =head2 close_after
88              
89             number of protocol commands to send to server (we will automatically close and re-open connection if needed)
90              
91             =head2 local_host
92              
93             (optional) the local address (hostname or IP) you want to use to connect
94              
95             =head1 SUPPORT
96              
97             For now, support questions should be sent to:
98              
99             Enetdri@dotandco.comE
100              
101             Please also see the SUPPORT file in the distribution.
102              
103             =head1 SEE ALSO
104              
105             http://www.dotandco.com/services/software/Net-DRI/
106              
107             =head1 AUTHOR
108              
109             Patrick Mevzek, Enetdri@dotandco.comE
110              
111             =head1 COPYRIGHT
112              
113             Copyright (c) 2005-2013,2016 Patrick Mevzek .
114             All rights reserved.
115              
116             This program is free software; you can redistribute it and/or modify
117             it under the terms of the GNU General Public License as published by
118             the Free Software Foundation; either version 2 of the License, or
119             (at your option) any later version.
120              
121             See the LICENSE file that comes with this distribution for more details.
122              
123             =cut
124              
125             ####################################################################################################
126              
127             sub new
128             {
129 0     0 1   my ($class,$ctx,$rp)=@_;
130 0           my %opts=%$rp;
131 0           my $po=$ctx->{protocol};
132              
133 0           my %t=(message_factory => $po->factories()->{message});
134 0 0 0       Net::DRI::Exception::usererr_insufficient_parameters('protocol_connection') unless (exists($opts{protocol_connection}) && $opts{protocol_connection});
135 0           $t{pc}=$opts{protocol_connection};
136 0           Net::DRI::Util::load_module($t{pc},'transport/socket');
137 0 0         if ($t{pc}->can('transport_default'))
138             {
139 0           %opts=($t{pc}->transport_default('socket_inet'),%opts);
140             }
141              
142 0           my $self=$class->SUPER::new($ctx,\%opts); ## We are now officially a Net::DRI::Transport instance
143 0 0         $self->has_state(exists $opts{has_state}? $opts{has_state} : 1);
144 0           $self->is_sync(1);
145 0           $self->name('socket_inet');
146 0           $self->version('0.8');
147             ##delete($ctx->{protocol}); ## TODO : double check it is ok
148 0           delete($ctx->{registry});
149 0           delete($ctx->{profile});
150              
151 0 0         Net::DRI::Exception::usererr_insufficient_parameters('socktype must be defined') unless (exists($opts{socktype}));
152 0 0         Net::DRI::Exception::usererr_invalid_parameters('socktype must be ssl, tcp or udp') unless ($opts{socktype}=~m/^(ssl|tcp|udp)$/);
153 0           $t{socktype}=$opts{socktype};
154 0           $t{client_login}=$opts{client_login};
155 0           $t{client_password}=$opts{client_password};
156 0 0 0       $t{client_newpassword}=$opts{client_newpassword} if (exists($opts{client_newpassword}) && $opts{client_newpassword});
157              
158 0 0 0       $t{protocol_data}=$opts{protocol_data} if (exists($opts{protocol_data}) && $opts{protocol_data});
159 0           my @need=qw/read_data write_message/;
160 0 0         Net::DRI::Exception::usererr_invalid_parameters('protocol_connection class ('.$t{pc}.') must have: '.join(' ',@need)) if (grep { ! $t{pc}->can($_) } @need);
  0            
161              
162 0 0 0       if (exists($opts{find_remote_server}) && defined($opts{find_remote_server}) && $t{pc}->can('find_remote_server'))
      0        
163             {
164 0           ($opts{remote_host},$opts{remote_port})=$t{pc}->find_remote_server($self,$opts{find_remote_server});
165 0           $self->log_output('notice','transport',$ctx,{phase=>'opening',message=>'Found the following remote_host:remote_port = '.$opts{remote_host}.':'.$opts{remote_port}});
166             }
167 0           foreach my $p ('remote_host','remote_port','protocol_version')
168             {
169 0 0 0       Net::DRI::Exception::usererr_insufficient_parameters($p.' must be defined') unless (exists($opts{$p}) && $opts{$p});
170 0           $t{$p}=$opts{$p};
171             }
172              
173 0 0 0       Net::DRI::Exception::usererr_invalid_parameters('close_after must be an integer') if ($opts{close_after} && !Net::DRI::Util::isint($opts{close_after}));
174 0   0       $t{close_after}=$opts{close_after} || 0;
175              
176 0 0         if ($t{socktype} eq 'ssl')
177             {
178 0           $t{ssl_context}=$self->parse_ssl_options(\%opts);
179             }
180              
181 0 0 0       $t{local_host}=$opts{local_host} if (exists($opts{local_host}) && $opts{local_host});
182 0           $t{remote_uri}=sprintf('%s://%s:%d',$t{socktype},$t{remote_host},$t{remote_port}); ## handy shortcut only used for error messages
183 0           $self->{transport}=\%t;
184              
185 0           my $rc;
186 0 0         if ($self->defer()) ## we will open, but later
187             {
188 0           $self->current_state(0);
189             } else ## we will open NOW
190             {
191 0           $rc=$self->open_connection($ctx);
192 0           $self->current_state(1);
193             }
194              
195 0           return ($self,$rc);
196             }
197              
198 0 0   0 0   sub sock { my ($self,$v)=@_; $self->transport_data()->{sock}=$v if defined($v); return $self->transport_data()->{sock}; }
  0            
  0            
199              
200             ## TODO (for IRIS DCHK1 + NAPTR/SRV)
201             ## Wrap in an eval to handle timeout (see if outer eval already for that ?)
202             ## Handle remote_host/port being ref array of ordered strings to try (in which case defer should be 0 probably as the list of things to try have been determined now, not later)
203             ## Or specify a callback to call when doing socket open to find the correct host+ports to use at that time
204             sub open_socket
205             {
206 0     0 0   my ($self,$ctx)=@_;
207 0           my $t=$self->transport_data();
208 0           my $type=$t->{socktype};
209 0           my $sock;
210              
211             my %n=( PeerAddr => $t->{remote_host},
212             PeerPort => $t->{remote_port},
213 0 0         Proto => $t->{socktype} eq 'udp'? 'udp' : 'tcp',
214             Blocking => 1,
215             MultiHomed => 1,
216             );
217 0 0         $n{LocalAddr}=$t->{local_host} if exists($t->{local_host});
218              
219 0 0 0       if ($type eq 'ssl')
    0          
220             {
221 0           $sock=IO::Socket::SSL->new(%{$t->{ssl_context}},
  0            
222             %n,
223             );
224             } elsif ($type eq 'tcp' || $type eq 'udp')
225             {
226 0           $sock=IO::Socket::INET->new(%n);
227             }
228              
229 0 0         Net::DRI::Exception->die(1,'transport/socket',6,'Unable to setup the socket for '.$t->{remote_uri}.' with error: "'.$!.($type eq 'ssl'? '" and SSL error: "'.IO::Socket::SSL::errstr().'"' : '"')) unless defined $sock;
    0          
230 0           $sock->autoflush(1);
231 0           $self->sock($sock);
232 0           $self->log_output('notice','transport',$ctx,{phase=>'opening',message=>'Successfully opened socket to '.$t->{remote_uri}});
233 0           return;
234             }
235              
236             sub send_login
237             {
238 0     0 0   my ($self,$ctx)=@_;
239 0           my $t=$self->transport_data();
240 0           my $sock=$self->sock();
241 0           my $pc=$t->{pc};
242 0           my $dr;
243 0           my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry});
244 0           my @rs;
245              
246             ## Get server greeting, if needed
247 0 0         if ($ctx->{protocol}->has_action('session','connect'))
248             {
249 0           my $t1=Time::HiRes::time();
250 0           $dr=$pc->read_data($self,$sock);
251 0           my $t2=Time::HiRes::time();
252 0           $self->log_output('notice','transport',$ctx,{trid=>$cltrid,phase=>'opening',direction=>'in',message=>$dr});
253 0           push @rs,$self->protocol_parse($ctx->{protocol},'session','connect',$dr,$cltrid,$t2-$t1);
254 0 0         return Net::DRI::Util::link_rs(@rs) unless $rs[-1]->is_success();
255             }
256              
257 0 0         return unless $ctx->{protocol}->has_action('session','login');
258              
259 0           foreach my $p (qw/client_login client_password/)
260             {
261 0 0 0       Net::DRI::Exception::usererr_insufficient_parameters($p.' must be defined') unless (exists($t->{$p}) && $t->{$p});
262             }
263              
264 0           $cltrid=$self->generate_trid($self->{logging_ctx}->{registry});
265              
266 0 0         my $login=$ctx->{protocol}->action('session','login',$cltrid,$t->{client_login},$t->{client_password},{ client_newpassword => $t->{client_newpassword}, %{$t->{protocol_data} || {}}}); ## TODO: fix last hash ref
  0            
267 0           $self->log_output('notice','transport',$ctx,{otype=>'session',oaction=>'login',trid=>$cltrid,phase=>'opening',direction=>'out',message=>$login});
268 0           my $t1=Time::HiRes::time();
269 0 0 0       Net::DRI::Exception->die(0,'transport/socket',4,'Unable to send login message to '.$t->{remote_uri}) unless ($sock->connected() && $sock->print($pc->write_message($self,$login)));
270              
271             ## Verify login successful
272 0           $dr=$pc->read_data($self,$sock);
273 0           my $t2=Time::HiRes::time();
274 0           $self->log_output('notice','transport',$ctx,{otype=>'session',oaction=>'login',trid=>$cltrid,phase=>'opening',direction=>'in',message=>$dr});
275 0           push @rs,$self->protocol_parse($ctx->{protocol},'session','login',$dr,$cltrid,$t2-$t1,$login);
276              
277 0           return Net::DRI::Util::link_rs(@rs);
278             }
279              
280             sub send_logout
281             {
282 0     0 0   my ($self,$ctx)=@_;
283 0           my $t=$self->transport_data();
284 0           my $sock=$self->sock();
285 0           my $pc=$t->{pc};
286              
287 0 0         return unless $ctx->{protocol}->has_action('session','logout');
288              
289 0           my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry});
290 0           my $logout=$ctx->{protocol}->action('session','logout',$cltrid);
291 0           $self->log_output('notice','transport',$ctx,{otype=>'session',oaction=>'logout',trid=>$cltrid,phase=>'closing',direction=>'out',message=>$logout});
292 0           my $t1=Time::HiRes::time();
293 0 0 0       Net::DRI::Exception->die(0,'transport/socket',4,'Unable to send logout message to '.$t->{remote_uri}) unless ($sock->connected() && $sock->print($pc->write_message($self,$logout)));
294 0           my $dr=$pc->read_data($self,$sock); ## We expect this to throw an exception, since the server will probably cut the connection
295 0           my $t2=Time::HiRes::time();
296 0           $self->time_used(time());
297 0           $t->{exchanges_done}++;
298 0           $self->log_output('notice','transport',$ctx,{otype=>'session',oaction=>'logout',trid=>$cltrid,phase=>'closing',direction=>'in',message=>$dr});
299 0           my $rc1=$self->protocol_parse($ctx->{protocol},'session','logout',$dr,$cltrid,$t2-$t1,$logout);
300 0 0         die $rc1 unless $rc1->is_success();
301 0           return $rc1;
302             }
303              
304             sub open_connection
305             {
306 0     0 0   my ($self,$ctx)=@_;
307 0           $self->open_socket($ctx);
308 0           my $rc=$self->send_login($ctx);
309 0           $self->current_state(1);
310 0           $self->time_open(time());
311 0           $self->time_used(time());
312 0           $self->transport_data()->{exchanges_done}=0;
313 0           return $rc;
314             }
315              
316             sub ping
317             {
318 0     0 0   my ($self,$ctx,$autorecon)=@_;
319 0 0         $autorecon=0 unless defined $autorecon;
320 0           my $t=$self->transport_data();
321 0           my $pc=$t->{pc};
322 0           my $sock=$self->sock();
323              
324 0 0         return 0 unless $self->has_state();
325 0 0         return 0 unless $ctx->{protocol}->has_action('session','noop');
326              
327 0           my $rc1;
328 0           my $cltrid=$self->generate_trid($self->{logging_ctx}->{registry});
329             my $ok=eval
330 0           {
331 0     0     local $SIG{ALRM}=sub { die 'timeout' };
  0            
332 0           alarm 10;
333 0           my $noop=$ctx->{protocol}->action('session','noop',$cltrid);
334 0           $self->log_output('notice','transport',$ctx,{otype=>'session',oaction=>'keepalive',trid=>$cltrid,phase=>'keepalive',direction=>'out',message=>$noop});
335 0           my $t1=Time::HiRes::time();
336 0 0 0       Net::DRI::Exception->die(0,'transport/socket',4,'Unable to send keepalive message to '.$t->{remote_uri}) unless ($sock->connected() && $sock->print($pc->write_message($self,$noop)));
337 0           my $dr=$pc->read_data($self,$sock);
338 0           my $t2=Time::HiRes::time();
339 0           $self->time_used(time());
340 0           $t->{exchanges_done}++;
341 0           $self->log_output('notice','transport',$ctx,{otype=>'session',oaction=>'keepalive',trid=>$cltrid,phase=>'keepalive',direction=>'in',message=>$dr});
342 0           $rc1=$self->protocol_parse($ctx->{protocol},'session','noop',$dr,$cltrid,$t2-$t1,$noop);
343 0 0         die $rc1 unless $rc1->is_success();
344 0           1;
345             };
346 0           my $err=$@;
347              
348 0           alarm 0;
349 0 0 0       if (defined $ok && $ok==1)
350             {
351 0           $self->current_state(1);
352             } else
353             {
354 0           $self->current_state(0);
355 0 0 0       $rc1=$err if defined $err && Net::DRI::Util::is_class($err,'Net::DRI::Protocol::ResultStatus');
356 0 0         if ($autorecon)
357             {
358 0           $self->log_output('notice','transport',{},{phase=>'keepalive',message=>'Reopening connection to '.$t->{remote_uri}.' because ping failed and asked to auto-reconnect'});
359 0           my $rc2=$self->open_connection($ctx);
360 0 0         $rc1=defined $rc1 ? Net::DRI::Util::link_rs($rc1,$rc2) : $rc2;
361             }
362             }
363              
364 0 0         return defined $rc1 ? $rc1 : Net::DRI::Protocol::ResultStatus->new_error('COMMAND_FAILED_CLOSING','ping failed, no auto-reconnect');
365             }
366              
367             sub close_socket
368             {
369 0     0 0   my ($self)=@_;
370 0           my $t=$self->transport_data();
371 0 0 0       if (defined $self->sock() && Scalar::Util::openhandle($self->sock()))
372             {
373 0           $self->sock()->close();
374 0           $self->log_output('notice','transport',{},{phase=>'closing',message=>'Successfully closed socket for '.$t->{remote_uri}});
375             }
376 0           $self->sock(undef);
377 0           return;
378             }
379              
380             sub close_connection
381             {
382 0     0 0   my ($self,$ctx)=@_;
383 0           $self->send_logout($ctx);
384 0           $self->close_socket();
385 0           $self->current_state(0);
386 0           return;
387             }
388              
389             sub end
390             {
391 0     0 0   my ($self,$ctx)=@_;
392 0 0         if ($self->current_state())
393             {
394             eval
395 0           {
396 0     0     local $SIG{ALRM}=sub { die 'timeout' };
  0            
397 0           alarm 10;
398 0           $self->close_connection($ctx);
399             };
400 0           alarm 0; ## since close_connection may die, this must be outside of eval to be executed in all cases
401             }
402 0           return;
403             }
404              
405             ####################################################################################################
406              
407             sub send ## no critic (Subroutines::ProhibitBuiltinHomonyms)
408             {
409 0     0 0   my ($self,$ctx,$tosend,$count)=@_;
410             ## We do a very crude error handling : if first send fails, we reset connection.
411             ## Thus if you put retry=>2 when creating this object, the connection will be re-established and the message resent
412 0     0     return $self->SUPER::send($ctx,$tosend,\&_print,sub { shift->current_state(0) },$count);
  0            
413             }
414              
415             sub _print ## here we are sure open_connection() was called before
416             {
417 0     0     my ($self,$count,$tosend,$ctx)=@_;
418 0           my $pc=$self->transport_data('pc');
419 0           my $sock=$self->sock();
420 0 0         my $m=($self->transport_data('socktype') eq 'udp')? 'send' : 'print';
421 0 0 0       Net::DRI::Exception->die(0,'transport/socket',4,'Unable to send message to '.$self->transport_data('remote_uri').' because of error: '.$!) unless (($m ne 'print' || $sock->connected()) && $sock->$m($pc->write_message($self,$tosend)));
      0        
422 0           return 1; ## very important
423             }
424              
425             sub receive
426             {
427 0     0 0   my ($self,$ctx,$count)=@_;
428 0           return $self->SUPER::receive($ctx,\&_get,undef,$count);
429             }
430              
431             sub _get
432             {
433 0     0     my ($self,$count,$ctx)=@_;
434 0           my $t=$self->transport_data();
435 0           my $sock=$self->sock();
436 0           my $pc=$t->{pc};
437              
438             ## Answer
439 0           my $dr=$pc->read_data($self,$sock);
440 0           $t->{exchanges_done}++;
441 0 0 0       if ($t->{exchanges_done}==$t->{close_after} && $self->has_state() && $self->current_state())
      0        
442             {
443 0           $self->log_output('notice','transport',$ctx,{phase=>'closing',message=>'Due to maximum number of exchanges reached, closing connection to '.$t->{remote_uri}});
444 0           $self->close_connection($ctx);
445             }
446 0           return $dr;
447             }
448              
449             sub try_again
450             {
451 0     0 0   my ($self,$ctx,$po,$err,$count,$istimeout,$step,$rpause,$rtimeout)=@_;
452 0 0         if ($step==0) ## sending not already done, hence error during send
453             {
454 0           $self->current_state(0);
455 0           return 1;
456             }
457              
458             ## We do a more agressive retry procedure in case of udp (that is IRIS basically)
459             ## See RFC4993 section 4
460 0 0 0       if ($step==1 && $istimeout==1 && $self->transport_data()->{socktype} eq 'udp')
      0        
461             {
462 0           $self->log_output('debug','transport',$ctx,{phase=>'active',message=>sprintf('In try_again, currently: pause=%f timeout=%f',$$rpause,$$rtimeout)});
463 0           $$rtimeout=2*$$rtimeout;
464 0           $$rpause+=rand(1+int($$rpause/2));
465 0           $self->log_output('debug','transport',$ctx,{phase=>'active',message=>sprintf('In try_again, new values: pause=%f timeout=%f',$$rpause,$$rtimeout)});
466 0           return 1; ## we will retry
467             }
468              
469 0           return 0; ## we do not handle other cases, hence no retry and fatal error
470             }
471              
472              
473             ####################################################################################################
474             1;