File Coverage

blib/lib/IO/EPP/HosterKZ.pm
Criterion Covered Total %
statement 21 123 17.0
branch 0 32 0.0
condition 0 19 0.0
subroutine 7 19 36.8
pod 9 10 90.0
total 37 203 18.2


line stmt bran cond sub pod time code
1             package IO::EPP::HosterKZ;
2              
3             =encoding utf8
4              
5             =head1 NAME
6              
7             IO::EPP::HosterKZ
8              
9             =head1 SYNOPSIS
10              
11             use IO::EPP::HosterKZ;
12              
13             # All queries are atomic, creating an object doesn't make sense
14             sub make_request {
15             my ( $action, $params ) = @_;
16              
17             $params->{user} = 'login';
18             $params->{pass} = 'xxxxx';
19              
20             # Parameters for LWP
21             my %sock_params = (
22             PeerHost => 'https://billing.hoster.kz/api/',
23             PeerPort => 443,
24             Timeout => 30,
25             );
26              
27             $params->{sock_params} = \%sock_params;
28              
29             return IO::EPP::HosterKZ::make_request( $action, $params );
30             }
31              
32             # Check domain
33             my ( $answ, $msg ) = make_request( 'check_domains', { domains => [ 'hoster.kz' ] } );
34              
35             =head1 DESCRIPTION
36              
37             Work with reseller hoster.kz epp api
38              
39             The module works via LWP
40              
41             Features:
42              
43             =over 3
44              
45             =item *
46              
47             not the full epp protocol
48              
49             =item *
50              
51             works over https
52              
53             =item *
54              
55             there are no login and logout commands
56              
57             =item *
58              
59             no session
60              
61             =item *
62              
63             no epp header in request, but has in answer
64              
65             =item *
66              
67             need name in update_contact
68              
69             =item *
70              
71             not has epp poll
72              
73             =item *
74              
75             transfer without renew
76              
77             =item *
78              
79             many features at prolongation and autorenew
80              
81             =back
82              
83             Documentation:
84             L
85              
86             =cut
87              
88 1     1   2066 use HTTP::Request::Common qw(POST);
  1         22898  
  1         65  
89 1     1   673 use LWP::UserAgent;
  1         24592  
  1         36  
90 1     1   553 use Time::HiRes qw(time);
  1         1348  
  1         4  
91              
92 1     1   1008 use IO::EPP::Base;
  1         4  
  1         60  
93 1     1   9 use parent qw( IO::EPP::Base );
  1         2  
  1         8  
94              
95 1     1   75 use strict;
  1         2  
  1         20  
96 1     1   5 use warnings;
  1         2  
  1         1407  
97              
98              
99             sub make_request {
100 0     0 1   my ( $action, $params ) = @_;
101              
102 0           $params = IO::EPP::Base::recursive_utf8_unflaged( $params ); # LWP does not support utf8 flag
103              
104 0           my ( $self, $code, $msg, $answ );
105              
106 0 0         unless ( $params->{conn} ) {
107             # Default:
108 0   0       $params->{sock_params}{PeerHost} ||= 'https://billing.hoster.kz/api/';
109 0   0       $params->{sock_params}{PeerPort} ||= 443;
110              
111 0           ( $self, $code, $msg ) = __PACKAGE__->new( $params );
112              
113 0 0 0       unless ( $code and $code == 1000 ) {
114 0           goto END_MR;
115             }
116             }
117             else {
118 0           $self = $params->{conn};
119             }
120              
121 0           $self->{critical_error} = '';
122              
123 0 0         if ( $self->can( $action ) ) {
124 0           ( $answ, $code, $msg ) = $self->$action( $params );
125             }
126             else {
127 0           $msg = "undefined command <$action>, request cancelled";
128 0           $code = 0;
129             }
130              
131              
132             END_MR:
133              
134 0 0         $msg .= '; ' . $self->{critical_error} if $self->{critical_error};
135              
136 0           my $full_answ = "code: $code\nmsg: $msg";
137              
138 0 0 0       $answ = {} unless $answ && ref $answ;
139              
140 0           $answ->{code} = $code;
141 0           $answ->{msg} = $msg;
142              
143 0 0         return wantarray ? ( $answ, $full_answ, $self ) : $answ;
144             }
145              
146              
147             =head1 METHODS
148              
149             =head2 req
150              
151             Completely replaces IO::EPP::Base::req because it works via LWP
152              
153             =cut
154              
155              
156             sub req {
157 0     0 1   my ( $self, $out_data, $info ) = @_;
158              
159 0           $out_data =~ s/^\n//s;
160 0           $out_data =~ s/\n<\/epp>//; # !!!
161              
162 0   0       $info ||= '';
163              
164 0 0         if ( $out_data ) {
165 0           my $d = $out_data;
166             # remove password, authinfo from log
167 0           $d =~ s/[^<>]+<\/pw>/xxxxx<\/pw>/;
168              
169 0           $self->epp_log( "$info request:\n$d" );
170             }
171              
172 0           my $THRESHOLD = 100000000;
173              
174 0           my $start_time = time;
175              
176             #my $cookie = HTTP::Cookies->new;
177              
178 0           my $ua = LWP::UserAgent->new(
179             agent => 'EppBot/7.02 (Perl; Linux i686; ru, en_US)',
180             parse_head => 0,
181             #keep_alive => 30,
182             #cookie_jar => $cookie,
183             #%ua_params,
184             );
185              
186 0           my $in_data;
187              
188             eval {
189 0     0     local $SIG{ALRM} = sub { die "connection timeout\n" };
  0            
190              
191 0           alarm 120;
192              
193             my $req = POST $self->{url}, [
194             login => $self->{user},
195             psw => $self->{pass},
196 0           xml => $out_data,
197             ];
198              
199 0           my $res = $ua->request( $req );
200              
201 0           alarm 0;
202              
203 0 0         if ( $res->is_success ) {
204 0           $in_data = $res->content;
205              
206 0 0         die "data length is zero\n" unless $in_data;
207              
208 0           my $data_size = length $in_data;
209              
210 0 0         die "data length is $data_size which exceeds $THRESHOLD\n" if $data_size > $THRESHOLD;
211             }
212             else {
213 0           die "fail answer: " . $res->as_string . "\n";
214             }
215              
216 0           1;
217             }
218 0 0         or do {
219 0           my $err = $@;
220              
221 0           alarm 0;
222              
223 0           my $req_time = sprintf( '%0.4f', time - $start_time );
224 0           $self->epp_log( "req_time: $req_time\n$info req error: $err" );
225              
226 0           $self->{critical_error} = "req error: $err";
227              
228 0           return;
229             };
230              
231 0           my $req_time = sprintf( '%0.4f', time - $start_time );
232              
233             # "Authentication error" - work with normal code & msg
234             # "User regikz_user already has more than.*active connections" - we did not see yet
235              
236 0           $self->epp_log( "req_time: $req_time\n$info answer:\n$in_data\n" );
237              
238 0           return $in_data;
239             }
240              
241              
242             sub new {
243 0     0 1   my ( $package, $params ) = @_;
244              
245 0           my ( $self, $code, $msg );
246              
247 0           my $sock_params = delete $params->{sock_params};
248              
249 0           my $test = delete $params->{test_mode};
250              
251             $self = bless {
252             sock => 'https', # no session
253             user => delete $params->{user},
254             pass => delete $params->{pass}, # !!! Send login and password with each request
255             url => $sock_params->{PeerHost},
256             local_ip => $sock_params->{LocalAddr},
257             timeout => $sock_params->{Timeout},
258             tld => $params->{tld} || '',
259             server => delete $params->{server},
260             log_name => delete $params->{log_name},
261             log_fn => delete $params->{log_fn},
262 0   0       no_log => delete $params->{no_log} || 0,
      0        
263             test => $test,
264             critical_error => undef,
265             }, $package;
266              
267 0           $self->set_urn();
268              
269 0           $self->set_log_vars( $params );
270              
271 0           $self->epp_log( "Connect to $$sock_params{PeerHost}\n" );
272              
273 0 0         return wantarray ? ( $self, '1000', 'ok' ) : $self;
274             }
275              
276              
277             sub set_urn {
278             $_[0]->{urn} = {
279 0     0 0   head => '', # !!!
280             cont => $IO::EPP::Base::epp_cont_urn,
281             host => $IO::EPP::Base::epp_host_urn,
282             dom => $IO::EPP::Base::epp_dom_urn,
283             };
284             }
285              
286              
287             sub create_contact {
288 0     0 1   my ( $self, $params ) = @_;
289              
290 0           $params->{cont_id} = IO::EPP::Base::gen_id( 16 );
291              
292 0           $params->{authinfo} = IO::EPP::Base::gen_pw( 16 );
293              
294 0           return $self->SUPER::create_contact( $params );
295             }
296              
297              
298             sub update_contact {
299 0     0 1   my ( $self, $params ) = @_;
300              
301             $params->{company} =~ s/&/&/g
302 0 0         if $params->{company};
303              
304 0           $params->{need_name} = 1;
305              
306 0           return $self->SUPER::update_contact( $params );
307             }
308              
309             =head2 create_domain
310              
311             Since September 7, 2010, for Kazakhstan domains, you need to fill in data on the location of the server equipment
312             on which the site is located, accessible by this domain name.
313             The server equipment should be located on the territory of Kazakhstan.
314              
315             C -- hashref with parameters:
316              
317             C -- server location area or region;
318             C -- city;
319             C -- address in the city.
320              
321             =cut
322              
323             sub create_domain {
324 0     0 1   my ( $self, $params ) = @_;
325              
326 0   0       $params->{authinfo} ||= IO::EPP::Base::gen_pw( 16 );
327              
328 0 0         if ( $params->{server_loc} ) {
329 0           my $server_loc = delete $params->{server_loc};
330              
331             $params->{extension} =
332             '
333             '.$server_loc->{srvloc_street}.'
334             '.$server_loc->{srvloc_city}.'
335 0           '.$server_loc->{srvloc_state}.'
336             ';
337             }
338              
339 0           return $self->SUPER::create_domain( $params );
340             }
341              
342              
343             sub transfer {
344 0     0 1   my ( $self, $params ) = @_;
345              
346 0           $params->{authinfo} =~ s/&/&/g;
347 0           $params->{authinfo} =~ s/
348 0           $params->{authinfo} =~ s/>/>/g;
349              
350 0           return $self->SUPER::request_transfer( $params );
351             }
352              
353             =head2 update_domain
354              
355             See L for C parameters.
356              
357             =cut
358              
359             sub update_domain {
360 0     0 1   my ( $self, $params ) = @_;
361              
362 0 0         if ( $params->{server_loc} ) {
363 0           my $server_loc = delete $params->{server_loc};
364              
365             $params->{extension} =
366             '
367             '.$server_loc->{srvloc_street}.'
368             '.$server_loc->{srvloc_city}.'
369 0           '.$server_loc->{srvloc_state}.'
370             ';
371             }
372              
373 0           return $self->SUPER::update_domain( $params );
374             }
375              
376             =head2 logout
377              
378             For replace IO::EPP::Base::logout.
379              
380             Do nothing.
381              
382             =cut
383              
384             sub logout {
385 0     0 1   my ( $self ) = @_;
386              
387 0           $self->epp_log( "" );
388              
389 0           delete $self->{sock};
390 0           delete $self->{user};
391 0           delete $self->{pass};
392              
393 0           return ( undef, '1500', 'ok' );
394             }
395              
396              
397             sub DESTROY {
398 0     0     my ( $self ) = @_;
399              
400 0           local ($!, $@, $^E, $?); # Protection against action-at-distance
401              
402 0           $self->logout();
403              
404 0 0         if ( $self->{log_fh} ) {
405 0           close $self->{log_fh};
406              
407 0           delete $self->{log_fh};
408             }
409             }
410              
411             1;
412              
413             __END__