File Coverage

blib/lib/Net/DRI/Protocol/EPP/Core/Session.pm
Criterion Covered Total %
statement 12 153 7.8
branch 0 76 0.0
condition 0 12 0.0
subroutine 4 9 44.4
pod 0 5 0.0
total 16 255 6.2


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, EPP Session commands (RFC5730)
2             ##
3             ## Copyright (c) 2005-2007,2010-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::Protocol::EPP::Core::Session;
16              
17 1     1   1065 use strict;
  1         2  
  1         35  
18 1     1   5 use warnings;
  1         1  
  1         26  
19              
20 1     1   3 use Net::DRI::Exception;
  1         2  
  1         16  
21 1     1   4 use Net::DRI::Util;
  1         1  
  1         1479  
22              
23             =pod
24              
25             =head1 NAME
26              
27             Net::DRI::Protocol::EPP::Core::Session - EPP Session commands (RFC5730) for Net::DRI
28              
29             =head1 DESCRIPTION
30              
31             Please see the README file for details.
32              
33             =head1 SUPPORT
34              
35             For now, support questions should be sent to:
36              
37             Enetdri@dotandco.comE
38              
39             Please also see the SUPPORT file in the distribution.
40              
41             =head1 SEE ALSO
42              
43             Ehttp://www.dotandco.com/services/software/Net-DRI/E
44              
45             =head1 AUTHOR
46              
47             Patrick Mevzek, Enetdri@dotandco.comE
48              
49             =head1 COPYRIGHT
50              
51             Copyright (c) 2005-2007,2010-2013 Patrick Mevzek .
52             All rights reserved.
53              
54             This program is free software; you can redistribute it and/or modify
55             it under the terms of the GNU General Public License as published by
56             the Free Software Foundation; either version 2 of the License, or
57             (at your option) any later version.
58              
59             See the LICENSE file that comes with this distribution for more details.
60              
61             =cut
62              
63             ####################################################################################################
64              
65             sub register_commands
66             {
67 0     0 0   my ($class,$version)=@_;
68 0           my %tmp=(
69             'connect' => [ undef , \&parse_greeting ],
70             login => [ \&login ],
71             logout => [ \&logout ],
72             noop => [ \&hello, \&parse_greeting ], ## for keepalives
73             );
74              
75 0           return { 'session' => \%tmp };
76             }
77              
78             sub hello ## should trigger a greeting from server, allowed at any time
79             {
80 0     0 0   my ($epp)=@_;
81 0           my $mes=$epp->message();
82 0           $mes->command(['hello']);
83 0           return;
84             }
85              
86             ## Most of this was previously in EPP/Message
87             sub parse_greeting
88             {
89 0     0 0   my ($po,$otype,$oaction,$oname,$rinfo)=@_;
90 0           my $mes=$po->message();
91 0           my $g=$mes->node_greeting();
92 0 0 0       return unless $mes->is_success() && defined $g; ## make sure we are not called for all parsing operations (after poll), just after true greeting
93              
94 0           my %tmp=(extensions_announced => []);
95 0           foreach my $el (Net::DRI::Util::xml_list_children($g))
96             {
97 0           my ($n,$c)=@$el;
98 0 0         if ($n eq 'svID')
    0          
    0          
    0          
99             {
100 0           $tmp{server_id}=$c->textContent();
101             } elsif ($n eq 'svDate')
102             {
103 0           $tmp{date}=$po->parse_iso8601($c->textContent());
104             } elsif ($n eq 'svcMenu')
105             {
106 0           foreach my $sel (Net::DRI::Util::xml_list_children($c))
107             {
108 0           my ($nn,$cc)=@$sel;
109 0 0         if ($nn=~m/^(?:version|lang)$/)
    0          
    0          
110             {
111 0           push @{$tmp{$nn}},$cc->textContent();
  0            
112             } elsif ($nn eq 'objURI')
113             {
114 0           push @{$tmp{objects}},$cc->textContent();
  0            
115             } elsif ($nn eq 'svcExtension')
116             {
117 0           push @{$tmp{extensions_announced}},map { $_->textContent() } grep { $_->getName() eq 'extURI' } $cc->getChildNodes();
  0            
  0            
  0            
118             }
119             }
120             } elsif ($n eq 'dcp') ## Does anyone really use this data ??
121             {
122 0           $tmp{dcp}=$c->cloneNode(1);
123 0           my $s=substr(substr($c->toString(),5),0,-6); ## we remove and
124 0           $s=~s/\s+//g;
125 0           $tmp{dcp_string}=$s;
126             }
127             }
128              
129 0           my %ctxlog=(action=>'greeting',direction=>'in',trid=>$mes->cltrid());
130              
131 0           $po->log_output('info','protocol',{%ctxlog,message=>'EPP lang announced by server: '.join(' ',@{$tmp{lang}})});
  0            
132 0 0         if (exists $tmp{version})
133             {
134 0 0         $po->log_output('warning','procotol',{%ctxlog,message=>'Server announced more than one EPP version: '.join(' ',@{$tmp{version}})}) if @{$tmp{version}} > 1;
  0            
  0            
135 0 0         $po->log_output('error','protocol',{%ctxlog,message=>sprintf('Mismatch between EPP server version(s) announced ("%s") and locally supported version "%s"',join(' ',@{$tmp{version}}),$po->version())}) unless grep { $po->version() eq $_ } @{$tmp{version}};
  0            
  0            
  0            
136             } else ## .PRO server does not seem to send a version info
137             {
138 0           $po->log_output('warning','protocol',{%ctxlog,message=>'Server did not announce any EPP version contrary to specifications; switching to default local version value of '.$po->version()});
139 0           $tmp{version}=[$po->version()];
140             }
141              
142             ## By default, we will use all extensions announced by server;
143             ## EPP extension modules are expected to tweak that depending on their own needs
144             ## and users can do so too, with the extensions and extensions_filter attributes
145 0           $tmp{extensions_selected}=$tmp{extensions_announced};
146              
147 0           $po->log_output('info','protocol',{%ctxlog,message=>'EPP extensions announced by server: '.join(' ',@{$tmp{extensions_announced}})});
  0            
148 0           my %ext=map { $_ => 1 } (@{$tmp{extensions_announced}},@{$tmp{objects}});
  0            
  0            
  0            
149 0           my %ns=map { $_->[0] => 1 } values %{$mes->ns()};
  0            
  0            
150 0           delete $ns{$mes->ns('_main')};
151 0           foreach my $ns (keys %ext)
152             {
153 0 0         next if exists $ns{$ns};
154 0           $po->log_output('warning','protocol',{%ctxlog,message=>sprintf('EPP extension "%s" is announced by server but not locally enabled (extension module not loaded or lack of support?)',$ns)});
155             }
156 0           foreach my $ns (keys %ns)
157             {
158 0 0         next if exists $ext{$ns};
159 0           $po->log_output('warning','protocol',{%ctxlog,message=>sprintf('EPP extension "%s" is locally enabled but not announced by server (registry policy change?)',$ns)});
160             }
161              
162 0           $po->default_parameters()->{server}=\%tmp;
163 0           $rinfo->{session}->{server}=\%tmp;
164 0           return;
165             }
166              
167             sub logout
168             {
169 0     0 0   my ($epp)=@_;
170 0           my $mes=$epp->message();
171 0           $mes->command(['logout']);
172 0           return;
173             }
174              
175             sub login
176             {
177 0     0 0   my ($po,$login,$password,$rdata)=@_;
178 0 0 0       Net::DRI::Exception::usererr_insufficient_parameters('login') unless defined $login && length $login;
179 0 0 0       Net::DRI::Exception::usererr_insufficient_parameters('password') unless defined $password && length $password;
180 0 0         Net::DRI::Exception::usererr_invalid_parameters('login') unless Net::DRI::Util::xml_is_token($login,3,16);
181 0 0         Net::DRI::Exception::usererr_invalid_parameters('password') unless Net::DRI::Util::xml_is_token($password,6,16);
182              
183 0           my $mes=$po->message();
184 0           $mes->command(['login']);
185 0           my @d;
186 0           push @d,['clID',$login];
187 0           push @d,['pw',$password];
188              
189 0 0         if (Net::DRI::Util::has_key($rdata,'client_newpassword'))
190             {
191 0 0         Net::DRI::Exception::usererr_invalid_parameters('client_newpassword') unless Net::DRI::Util::xml_is_token($rdata->{client_newpassword},6,16);
192 0           push @d,['newPW',$rdata->{client_newpassword}];
193             }
194              
195 0           my (@o,$tmp,@tmp);
196 0           my $sdata=$po->default_parameters()->{server};
197              
198 0 0         $tmp=Net::DRI::Util::has_key($rdata,'version') ? $rdata->{version} : $sdata->{version};
199 0 0         Net::DRI::Exception::usererr_insufficient_parameters('version') unless defined $tmp;
200 0 0         @tmp=ref $tmp eq 'ARRAY' ? @$tmp : ($tmp);
201 0 0         ($tmp)=(grep { defined && $_ eq $po->version() } @tmp)[0];
  0            
202 0 0         Net::DRI::Exception::usererr_insufficient_parameters(sprintf('No compatible EPP version found: local version "%s" vs user or server provided "%s"',$po->version(),join(' ',@tmp))) unless defined $tmp;
203 0 0         Net::DRI::Exception::usererr_invalid_parameters('version') unless $tmp=~m/^[1-9]+\.[0-9]+$/;
204 0           push @o,['version',$tmp];
205              
206             ## TODO: allow choice of language if multiple choices (like fr+en in .CA) ?
207 0 0         $tmp=Net::DRI::Util::has_key($rdata,'lang') ? $rdata->{lang} : $sdata->{lang};
208 0 0         Net::DRI::Exception::usererr_insufficient_parameters('lang') unless defined $tmp;
209 0 0         $tmp=$tmp->[0] if ref $tmp eq 'ARRAY';
210 0 0         Net::DRI::Exception::usererr_invalid_parameters('lang') unless Net::DRI::Util::xml_is_language($tmp);
211 0           push @o,['lang',$tmp];
212              
213 0           push @d,['options',@o];
214              
215 0           my @s;
216 0           push @s,map { ['objURI',$_] } @{$sdata->{objects}}; ## this part is not optional
  0            
  0            
217              
218 0           my @exts=@{$sdata->{extensions_selected}}; ## we start with what we have computed, and then tweak the list depending on user instructions
  0            
219              
220             ## TODO : doing all the following do change what we send during login, but does not change really what modules are enabled or not,
221             ## which may later kick in during some build/parse phases !
222 0 0 0       if (Net::DRI::Util::has_key($rdata,'only_local_extensions') && $rdata->{only_local_extensions})
223             {
224 0           $po->log_output('info','protocol',{action=>'login',direction=>'out',trid=>$mes->cltrid(),message=>'Before using only local extensions, EPP extensions selected during login: '.join(' ',@exts)});
225 0           my $rns=$po->ns();
226 0           @exts=sort { $a cmp $b } grep { ! /^urn:ietf:params:xml:ns:(?:epp|domain|contact|host)-1\.0$/ } map { $_->[0] } values %$rns;
  0            
  0            
  0            
227 0           $po->log_output('info','protocol',{action=>'login',direction=>'out',trid=>$mes->cltrid(),message=>'After using only local extensions, EPP extensions selected during login: '.join(' ',@exts)});
228             }
229 0 0         if (Net::DRI::Util::has_key($rdata,'extensions'))
230             {
231 0           $tmp=$rdata->{extensions};
232 0 0         Net::DRI::Exception::usererr_invalid_parameters('extensions') unless ref $tmp eq 'ARRAY';
233 0           $po->log_output('info','protocol',{action=>'login',direction=>'out',trid=>$mes->cltrid(),message=>'Before user setting, EPP extensions selected during login: '.join(' ',@exts)});
234 0 0         if (grep { /^[-+]/ } @$tmp) ## add or substract from current list
  0            
235             {
236 0           foreach (@$tmp)
237             {
238 0           my $ext=$_; ## make a copy because we will change it
239 0 0         if ($ext=~s/^-//)
240             {
241 0           @exts=grep { $ext ne $_ } @exts;
  0            
242             } else
243             {
244 0           $ext=~s/^\+//;
245 0 0         push @exts,$ext unless grep { $ext eq $_ } @exts;
  0            
246             }
247             }
248             } else ## just set the list absolutely
249             {
250 0           @exts=@$tmp;
251             }
252 0           $po->log_output('info','protocol',{action=>'login',direction=>'out',trid=>$mes->cltrid(),message=>'After user setting, EPP extensions selected during login: '.join(' ',@exts)});
253             }
254              
255 0 0         if (Net::DRI::Util::has_key($rdata,'extensions_filter'))
256             {
257 0 0         Net::DRI::Exception::usererr_invalid_parameters('extensions_filter') unless ref $rdata->{extensions_filter} eq 'CODE';
258 0           $po->log_output('info','protocol',{action=>'login',direction=>'out',trid=>$mes->cltrid(),message=>'Before user filtering, EPP extensions selected during login: '.join(' ',@exts)});
259 0           @exts=$rdata->{extensions_filter}->(@exts);
260 0           $po->log_output('info','protocol',{action=>'login',direction=>'out',trid=>$mes->cltrid(),message=>'After user filtering, EPP extensions selected during login: '.join(' ',@exts)});
261             }
262              
263 0 0         if (@exts)
264             {
265 0           push @s,['svcExtension',map {['extURI',$_]} @exts];
  0            
266 0           $po->log_output('notice','protocol',{action=>'login',direction=>'out',trid=>$mes->cltrid(),message=>'EPP extensions selected during login: '.join(' ',@exts)});
267             } else
268             {
269 0           $po->log_output('notice','protocol',{action=>'login',direction=>'out',trid=>$mes->cltrid(),message=>'No EPP extensions selected during login'});
270             }
271              
272 0           push @d,['svcs',@s];
273              
274 0           $mes->command_body(\@d);
275 0           return;
276             }
277              
278             ####################################################################################################
279             1;