File Coverage

blib/lib/Net/DRI/Transport.pm
Criterion Covered Total %
statement 43 82 52.4
branch 16 58 27.5
condition 4 24 16.6
subroutine 9 16 56.2
pod 1 11 9.0
total 73 191 38.2


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, Superclass of all Transport/* modules (hence virtual class, never used directly)
2             ##
3             ## Copyright (c) 2005-2011,2013 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;
16              
17 68     68   3318 use strict;
  68         79  
  68         1527  
18 68     68   198 use warnings;
  68         67  
  68         1463  
19              
20 68     68   198 use base qw(Class::Accessor::Chained::Fast Net::DRI::BaseClass);
  68         103  
  68         6972  
21             __PACKAGE__->mk_accessors(qw/name version retry pause trace timeout defer current_state has_state is_sync time_creation time_open time_used trid_factory logging/);
22              
23 68     68   525 use Net::DRI::Exception;
  68         141  
  68         60519  
24              
25             =pod
26              
27             =head1 NAME
28              
29             Net::DRI::Transport - Superclass of all Transport Modules in Net::DRI
30              
31             =head1 DESCRIPTION
32              
33             Please see the README file for details.
34              
35             This is a superclass that should never be used directly, but only through its subclasses.
36              
37             =head1 METHODS
38              
39             During the new() call, subclasses will call this new() method, which expects a ref hash with some
40             keys (other are handled by the subclasses), among which:
41              
42             =head2 defer
43              
44             do we open the connection right now (0) or later (1)
45              
46             =head2 timeout
47              
48             time to wait (in seconds) for server reply (default 60)
49              
50             =head2 retry
51              
52             number of times we try to send the message to the registry (default 2)
53              
54             =head2 trid
55              
56             (optional) code reference of a subroutine generating a transaction id when passed a name ;
57             if not defined, $dri->trid_factory() is used, which is Net::DRI::Util::create_trid_1 by default
58              
59             =head1 SUPPORT
60              
61             For now, support questions should be sent to:
62              
63             Enetdri@dotandco.comE
64              
65             Please also see the SUPPORT file in the distribution.
66              
67             =head1 SEE ALSO
68              
69             Ehttp://www.dotandco.com/services/software/Net-DRI/E
70              
71             =head1 AUTHOR
72              
73             Patrick Mevzek, Enetdri@dotandco.comE
74              
75             =head1 COPYRIGHT
76              
77             Copyright (c) 2005-2011,2013 Patrick Mevzek .
78             All rights reserved.
79              
80             This program is free software; you can redistribute it and/or modify
81             it under the terms of the GNU General Public License as published by
82             the Free Software Foundation; either version 2 of the License, or
83             (at your option) any later version.
84              
85             See the LICENSE file that comes with this distribution for more details.
86              
87             =cut
88              
89             ####################################################################################################
90             sub new
91             {
92 1     1 1 2 my ($class,$ctx,$ropts)=@_;
93 1         2 my $ndr=$ctx->{registry};
94 1         1 my $pname=$ctx->{profile};
95              
96             my $self={
97             is_sync => exists($ropts->{is_sync})? $ropts->{is_sync} : 1, ## do we need to wait for reply as soon as command sent ?
98             retry => exists($ropts->{retry})? $ropts->{retry} : 2, ## by default, we will try once only
99             pause => exists($ropts->{pause})? $ropts->{pause} : 10, ## time in seconds to wait between two retries
100             timeout => exists($ropts->{timeout})? $ropts->{timeout} : 60,
101             defer => exists($ropts->{defer})? $ropts->{defer} : 0, ## defer opening connection as long as possible (irrelevant if stateless) ## XX maybe not here, too low
102             logging => $ndr->logging(),
103             trid_factory => (exists($ropts->{trid}) && (ref($ropts->{trid}) eq 'CODE'))? $ropts->{trid} : $ndr->trid_factory(),
104             current_state => undef, ## for stateless transport, otherwise 0=close, 1=open
105             has_state => undef, ## do we need to open a session before sending commands ?
106             transport => undef, ## will be defined in subclasses
107             time_creation => time(),
108 1 50 33     12 logging_ctx => { registry => $ndr->name(), profile => $pname, protocol => $ctx->{protocol}->name() },
    50          
    50          
    50          
    50          
    50          
109             };
110              
111 1         28 bless $self,$class;
112 1         10 $self->log_setup_channel($class,'transport',$self->{logging_ctx}); ## if we need the transport name here, we will have to put that further below, in another method called after new() ; otherwise we derive it from $class
113 1         3 $self->log_output('debug','core',sprintf('Added transport %s for registry %s',$class,$ndr->name()));
114 1         3 return $self;
115             }
116              
117 0 0   0 0 0 sub transport_data { my ($self,$data)=@_; return defined $data ? $self->{transport}->{$data} : $self->{transport}; }
  0         0  
118              
119             sub log_output
120             {
121 21     21 0 33 my ($self,$level,$type,$data1,$data2)=@_;
122 21 100       36 return $self->logging()->output($level,$type,$data1) unless defined $data2;
123 20 100       31 $self->{logging_ctx}->{transport}=$self->name().'/'.$self->version() unless exists $self->{logging_ctx}->{transport};
124 20         41 return $self->logging()->output($level,$type,{ %{$self->{logging_ctx}}, %$data1, %$data2 });
  20         192  
125             }
126              
127             sub parse_ssl_options
128             {
129 0     0 0 0 my ($self,$ropts)=@_;
130              
131 0         0 require IO::Socket::SSL;
132 0 0       0 $IO::Socket::SSL::DEBUG=$ropts->{ssl_debug} if exists $ropts->{ssl_debug};
133              
134 0         0 my %s=();
135 0 0       0 $s{SSL_verify_mode}=exists $ropts->{ssl_verify} ? $ropts->{ssl_verify} : 0x00; ## by default, no authentication whatsoever
136 0 0 0 0   0 $s{SSL_verify_callback}=sub { my $r=$ropts->{ssl_verify_callback}->($self,@_); Net::DRI::Exception->die(1,'transport',6,'SSL certificate user verification failed, aborting connection') unless $r; 1; } if (exists $ropts->{ssl_verify_callback} && defined $ropts->{ssl_verify_callback});
  0 0       0  
  0         0  
  0         0  
137              
138 0         0 foreach my $s (qw/key_file cert_file ca_file ca_path version passwd_cb/)
139             {
140 0 0       0 next unless exists $ropts->{'ssl_'.$s};
141 0 0 0     0 Net::DRI::Exception::usererr_invalid_parameters('File "'.$ropts->{'ssl_'.$s}.'" does not exist or is unreadable by current UID') if ($s=~m/_file$/ && ! -r $ropts->{'ssl_'.$s});
142 0 0 0     0 Net::DRI::Exception::usererr_invalid_parameters('Directory "'.$ropts->{'ssl_'.$s}.'" does not exist') if ($s=~m/_path$/ && ! -d $ropts->{'ssl_'.$s});
143 0         0 $s{'SSL_'.$s}=$ropts->{'ssl_'.$s};
144             }
145              
146 0 0       0 $s{SSL_cipher_list}=exists $ropts->{ssl_cipher_list} ? $ropts->{ssl_cipher_list} : 'SSLv3:TLSv1:!aNULL:!eNULL';
147 0 0       0 $s{SSL_hostname}=$ropts->{ssl_hostname} if exists $ropts->{ssl_hostname}; # defaults to servers hostname, set blank to disable SNI
148              
149 0         0 return \%s;
150             }
151              
152             ## WARNING : this is a preliminary implementation of this new feature, it WILL change
153             ## Should it be in Registry.pm ? + tweaking of process_back
154             sub protocol_parse
155             {
156 0     0 0 0 my ($to,$po,$otype,$oaction,$dr,$trid,$dur,$sent)=@_;
157 0         0 my ($rc,$rinfo)=$po->reaction($otype,$oaction,$dr);
158              
159 0         0 $rinfo->{session}->{exchange}->{transport}=$to->name().'/'.$to->version();
160              
161 0         0 foreach my $v1 (values(%$rinfo))
162             {
163 0         0 foreach my $v2 (values(%{$v1}))
  0         0  
164             {
165 0 0       0 delete($v2->{result_status}) if exists $v2->{result_status};
166             }
167             }
168              
169 0 0       0 $rinfo->{session}->{exchange}={ %{$rinfo->{session}->{exchange}}, duration_seconds => $dur, raw_command => defined $sent ? $sent->as_string() : undef, raw_reply => $dr->as_string(), object_type => $otype, object_action => $oaction };
  0         0  
170 0         0 $rc->_set_data($rinfo);
171             ## die($rc) unless $rc->is_success(); ## was done just after reaction before ## TODO maybe not necessary ? Tweak Registry::add_profile + search for other die in Transport/
172 0         0 return $rc;
173             }
174              
175             sub send ## no critic (Subroutines::ProhibitBuiltinHomonyms)
176             {
177 10     10 0 16 my ($self,$ctx,$tosend,$cb1,$cb2,$count)=@_; ## $cb1=how to send, $cb2=how to test if fatal (to break loop) or not (retry once more)
178 10 50 33     37 Net::DRI::Exception::err_insufficient_parameters() unless ($cb1 && (ref($cb1) eq 'CODE'));
179 10         7 my $ok=0;
180              
181             ## Try to reconnect if needed
182 10 50 33     17 $self->open_connection($ctx) if ($self->has_state() && !$self->current_state()); ## TODO : grab result !
183             ## Here $tosend is a Net::DRI::Protocol::Message object (in fact, a subclass of that), in perl internal encoding, no transport related data (such as EPP 4 bytes header)
184 10         64 $self->log_output('notice','transport',$ctx,{phase=>'active',direction=>'out',message=>$tosend});
185 10         41 $ok=$self->$cb1($count,$tosend,$ctx);
186 10         39 $self->time_used(time());
187              
188 10 50       49 Net::DRI::Exception->die(0,'transport',4,'Unable to send message to registry') unless $ok;
189 10         21 return;
190             }
191              
192             sub receive
193             {
194 10     10 0 7 my ($self,$ctx,$cb1,$cb2,$count)=@_;
195 10 50 33     59 Net::DRI::Exception::err_insufficient_parameters() unless ($cb1 && (ref($cb1) eq 'CODE'));
196              
197 10         7 my $ans;
198 10         20 $ans=$self->$cb1($count,$ctx); ## a Net::DRI::Data::Raw object
199 10 50       15 Net::DRI::Exception->die(0,'transport',5,'Unable to receive message from registry') unless defined $ans;
200             ## $ans should have been properly decoded into a native Perl string
201 10         24 $self->log_output('notice','transport',$ctx,{phase=>'active',direction=>'in',message=>$ans});
202 10         37 return $ans;
203             }
204              
205             sub try_again ## TO BE SUBCLASSED
206             {
207 0     0 0 0 my ($self,$ctx,$po,$err,$count,$istimeout,$step,$rpause,$rtimeout)=@_; ## $step is 0 before send, 1 after, and 2 after receive successful
208             ## Should return 1 if we try again, or 0 if we should stop processing now
209 0 0 0     0 return ($istimeout && ($count <= $self->{retry}))? 1 : 0;
210             }
211              
212             sub open_connection ## no critic (Subroutines::RequireFinalReturn)
213             {
214 0     0 0 0 my ($self,$ctx)=@_;
215 0 0       0 return unless $self->has_state();
216 0         0 Net::DRI::Exception::method_not_implemented('open_connection',$self);
217             }
218              
219             sub end ## no critic (Subroutines::RequireFinalReturn)
220             {
221 1     1 0 2 my ($self,$ctx)=@_;
222 1 50       4 return unless $self->has_state();
223 0           Net::DRI::Exception::method_not_implemented('end',$self);
224             }
225              
226             ####################################################################################################
227             ## Pass a true value if you want the connection to be automatically redone if the ping failed
228             sub ping ## no critic (Subroutines::RequireFinalReturn)
229             {
230 0     0 0   my ($self,$autorecon)=@_;
231 0 0         return unless $self->has_state();
232 0           Net::DRI::Exception::method_not_implemented('ping',$self);
233             }
234              
235             ####################################################################################################
236             1;