File Coverage

blib/lib/Net/DRI/Protocol/EPP/Extensions/CZ/NSSET.pm
Criterion Covered Total %
statement 21 206 10.1
branch 0 96 0.0
condition 0 36 0.0
subroutine 7 25 28.0
pod 0 18 0.0
total 28 381 7.3


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, .CZ EPP NSSET extension commands
2             ##
3             ## Copyright (c) 2008,2009 Tonnerre Lombard .
4             ## (c) 2010,2013 Patrick Mevzek
5             ## All rights reserved.
6             ##
7             ## This file is part of Net::DRI
8             ##
9             ## Net::DRI is free software; you can redistribute it and/or modify
10             ## it under the terms of the GNU General Public License as published by
11             ## the Free Software Foundation; either version 2 of the License, or
12             ## (at your option) any later version.
13             ##
14             ## See the LICENSE file that comes with this distribution for more details.
15             ####################################################################################################
16              
17             package Net::DRI::Protocol::EPP::Extensions::CZ::NSSET;
18              
19 1     1   705 use strict;
  1         1  
  1         24  
20 1     1   3 use warnings;
  1         2  
  1         18  
21              
22 1     1   4 use Net::DRI::Util;
  1         3  
  1         13  
23 1     1   3 use Net::DRI::Exception;
  1         2  
  1         17  
24 1     1   3 use Net::DRI::Data::Hosts;
  1         1  
  1         5  
25 1     1   23 use Net::DRI::Data::ContactSet;
  1         1  
  1         16  
26 1     1   3 use Net::DRI::Protocol::EPP::Util;
  1         2  
  1         1796  
27              
28             =pod
29              
30             =head1 NAME
31              
32             Net::DRI::Protocol::EPP::Extensions::CZ::NSSET - .CZ NSSET extension commands for Net::DRI
33              
34             =head1 DESCRIPTION
35              
36             Please see the README file for details.
37              
38             =head1 SUPPORT
39              
40             For now, support questions should be sent to:
41              
42             Edevelopment@sygroup.chE
43              
44             Please also see the SUPPORT file in the distribution.
45              
46             =head1 SEE ALSO
47              
48             Ehttp://oss.bsdprojects.net/projects/netdri/E
49              
50             =head1 AUTHOR
51              
52             Tonnerre Lombard, Etonnerre.lombard@sygroup.chE
53              
54             =head1 COPYRIGHT
55              
56             Copyright (c) 2008,2009 Tonnerre Lombard .
57             (c) 2010,2013 Patrick Mevzek
58             All rights reserved.
59              
60             This program is free software; you can redistribute it and/or modify
61             it under the terms of the GNU General Public License as published by
62             the Free Software Foundation; either version 2 of the License, or
63             (at your option) any later version.
64              
65             See the LICENSE file that comes with this distribution for more details.
66              
67             =cut
68              
69             ####################################################################################################
70              
71             sub register_commands
72             {
73 0     0 0   my ($class, $version) = @_;
74 0           my %tmp1 = (
75             create => [ \&create ],
76             check => [ \&check, \&check_parse ],
77             info => [ \&info, \&info_parse ],
78             delete => [ \&delete ],
79             update => [ \&update ],
80             transfer_query => [ \&transfer_query ],
81             transfer_request => [ \&transfer_request ],
82             transfer_cancel => [ \&transfer_cancel ],
83             transfer_answer => [ \&transfer_answer ],
84             );
85              
86 0           $tmp1{check_multi} = $tmp1{check};
87            
88 0           return { 'nsset' => \%tmp1 };
89             }
90              
91             sub ns
92             {
93 0     0 0   my ($mes) = @_;
94 0           my $ns=$mes->ns('nsset');
95 0 0         return defined($ns)? $ns : 'http://www.nic.cz/xml/epp/nsset-1.2';
96             }
97              
98             sub build_command
99             {
100 0     0 0   my ($epp, $msg, $command, $hosts) = @_;
101 0 0         my $tcommand = (ref($command) eq 'ARRAY' ? $command->[0] : $command);
102              
103 0           my @gn;
104              
105 0 0         foreach my $h (grep { defined } (ref($hosts) eq 'ARRAY') ?
  0            
106             @$hosts : ($hosts))
107             {
108 0 0         my $gn = Net::DRI::Util::isa_nsgroup($h) ?
109             $h->name() : $h;
110 0 0 0       Net::DRI::Exception->die(1, 'protocol/EPP', 10,
      0        
      0        
111             'Invalid NSgroup name: ' . $gn)
112             unless (defined($gn) && $gn && !ref($gn) && Net::DRI::Util::xml_is_normalizedstring(
113             $gn, 1, 100));
114 0           push(@gn, $gn);
115             }
116              
117 0 0         Net::DRI::Exception->die(1, 'protocol/EPP', 2, 'NSgroup name needed')
118             unless @gn;
119              
120 0           my @ns=$msg->nsattrs('nsset');
121 0 0         @ns=qw(http://www.nic.cz/xml/epp/nsset-1.2 http://www.nic.cz/xml/epp/nsset-1.2 nsset-1.2.xsd) unless @ns;
122 0           $msg->command([$command, 'nsset:' . $tcommand,
123             sprintf('xmlns:nsset="%s" xsi:schemaLocation="%s %s"',@ns)]);
124              
125 0           return map { ['nsset:id', $_] } @gn;
  0            
126             }
127              
128             sub add_nsname
129             {
130 0     0 0   my ($ns) = @_;
131 0 0         return () unless (defined($ns));
132 0           my @a;
133              
134 0 0         if (!ref($ns))
    0          
    0          
135             {
136 0           return ['nsset:ns', ['nsset:name', $ns]];
137             }
138             elsif (ref($ns) eq 'ARRAY')
139             {
140 0           return ['nsset:ns', map { ['nsset:name', $_] } @$ns];
  0            
141             }
142             elsif (Net::DRI::Util::isa_hosts($ns))
143             {
144 0           for (my $i = 1; $i <= $ns->count(); $i++)
145             {
146 0           my ($name, $v4, $v6) = $ns->get_details($i);
147 0           my @b;
148 0           push(@b, ['nsset:name', $name]);
149 0           foreach my $addr (@{$v4}, @{$v6})
  0            
  0            
150             {
151 0           push(@b, ['nsset:addr', $addr]);
152             }
153 0           push(@a, ['nsset:ns', @b]);
154             }
155             }
156              
157 0           return @a;
158             }
159              
160             sub build_contacts
161             {
162 0     0 0   my ($cs) = @_;
163 0 0         return () unless (defined($cs));
164 0           my @a;
165              
166 0           foreach my $type ($cs->types())
167             {
168 0           push(@a, map { ['nsset:' . $type, $_->srid()] }
  0            
169             $cs->get($type));
170             }
171              
172 0           return @a;
173             }
174              
175             sub build_authinfo
176             {
177 0     0 0   my $rauth = shift;
178 0 0 0       return unless (defined($rauth) && ref($rauth) eq 'HASH');
179 0           return ['nsset:authInfo', $rauth->{pw}];
180             }
181              
182             sub build_reportlevel
183             {
184 0     0 0   my $level = int(shift);
185 0 0 0       return unless (defined($level) && $level >= 0 && $level <= 10);
      0        
186 0           return ['nsset:reportlevel', $level];
187             }
188              
189             ####################################################################################################
190             ########### Query commands
191              
192             sub check
193             {
194 0     0 0   my ($epp, @hosts)=@_;
195 0           my $mes = $epp->message();
196 0           my @d = build_command($epp, $mes, 'check', \@hosts);
197              
198 0           $mes->command_body(\@d);
199 0           return;
200             }
201              
202             sub check_parse
203             {
204 0     0 0   my ($po, $otype, $oaction, $oname, $rinfo) = @_;
205 0           my $mes = $po->message();
206 0 0         return unless $mes->is_success();
207              
208 0           my $ns = ns($mes);
209 0           my $chkdata = $mes->get_response($ns,'chkData');
210 0 0         return unless $chkdata;
211              
212 0           foreach my $cd ($chkdata->getElementsByTagNameNS($ns, 'cd'))
213             {
214 0           my $c = $cd->getFirstChild();
215 0           my $nsset;
216 0           while ($c)
217             {
218             ## only for element nodes
219 0 0         next unless ($c->nodeType() == 1);
220 0   0       my $n = $c->localname() || $c->nodeName();
221 0 0         if ($n eq 'id')
222             {
223 0           $nsset = $c->getFirstChild()->getData();
224             $rinfo->{nsset}->{$nsset}->{exist} =
225 0           1 - Net::DRI::Util::xml_parse_boolean
226             ($c->getAttribute('avail'));
227             $rinfo->{nsset}->{$nsset}->{action} =
228 0           'check';
229             }
230 0           } continue { $c = $c->getNextSibling(); }
231             }
232 0           return;
233             }
234              
235             sub info
236             {
237 0     0 0   my ($epp, $hosts) = @_;
238 0           my $mes = $epp->message();
239 0           my @d = build_command($epp, $mes, 'info', $hosts);
240              
241 0           $mes->command_body(\@d);
242 0           return;
243             }
244              
245             sub info_parse
246             {
247 0     0 0   my ($po, $otype, $oaction, $oname, $rinfo) = @_;
248 0           my $mes = $po->message();
249 0 0         return unless $mes->is_success();
250              
251 0           my $infdata = $mes->get_response(ns($mes),'infData');
252 0 0         return unless $infdata;
253              
254 0           my $ns = Net::DRI::Data::Hosts->new();
255 0           my $cs = Net::DRI::Data::ContactSet->new();
256 0           my @s;
257 0           my $c = $infdata->getFirstChild();
258 0           while ($c)
259             {
260 0 0         next unless ($c->nodeType() == 1); ## only for element nodes
261 0   0       my $name = $c->localname() || $c->nodeName();
262 0 0         next unless $name;
263 0 0         if ($name eq 'id')
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
264             {
265 0           $oname = $c->getFirstChild()->getData();
266             $rinfo->{nsset}->{$oname}->{name} =
267 0           $rinfo->{nsset}->{$oname}->{id} = $oname;
268 0           $rinfo->{nsset}->{$oname}->{exist} = 1;
269 0           $rinfo->{nsset}->{$oname}->{action} = 'info';
270             }
271             elsif ($name eq 'roid')
272             {
273 0           $rinfo->{nsset}->{$oname}->{roid} = $c->getFirstChild()
274             ->getData();
275             }
276             elsif ($name eq 'reportlevel')
277             {
278             $rinfo->{nsset}->{$oname}->{reportlevel} =
279 0           int($c->getFirstChild()->getData());
280             }
281             elsif ($name eq 'status')
282             {
283 0           push(@s,Net::DRI::Protocol::EPP::Util::parse_node_status($c));
284             }
285             elsif ($name eq 'authInfo')
286             {
287             $rinfo->{nsset}->{$oname}->{auth} =
288 0           { pw => $c->getFirstChild()->getData() };
289             }
290             elsif ($name =~ /^((?:c[lr]|tr|up)ID)$/)
291             {
292 0           $rinfo->{nsset}->{$oname}->{$1} =
293             $c->getFirstChild()->getData();
294             }
295             elsif ($name =~ /^((?:c[lr]|tr|up)Date)$/)
296             {
297 0           $rinfo->{nsset}->{$oname}->{$1} = $po->parse_iso8601($c->textContent());
298             }
299             elsif ($name eq 'ns')
300             {
301 0           my $hostname;
302             my @v4;
303 0           my @v6;
304 0           foreach my $xname ($c->getElementsByTagNameNS(ns($mes),
305             'name'))
306             {
307 0           $hostname = $xname->getFirstChild()->getData();
308             }
309 0           foreach my $xaddr ($c->getElementsByTagNameNS(ns($mes),
310             'addr'))
311             {
312 0           my $xa = $xaddr->getFirstChild()->getData();
313 0 0         if ($xa =~ /^\d+\.\d+\.\d+\.\d+$/)
314             {
315 0           push(@v4, $xa);
316             }
317             else
318             {
319 0           push(@v6, $xa);
320             }
321             }
322 0           $ns->add($hostname, \@v4, \@v6);
323             }
324             elsif ($name =~ /^(registrant|billing|admin|tech)$/)
325             {
326 0           $cs->add($po->create_local_object('contact')->srid($c->getFirstChild()->getData()),
327             $name);
328             }
329 0           } continue { $c = $c->getNextSibling(); }
330              
331 0           $rinfo->{nsset}->{$oname}->{self} = $ns;
332 0           $rinfo->{nsset}->{$oname}->{contact} = $cs;
333 0           $rinfo->{nsset}->{$oname}->{status} = $po->create_local_object('status')->add(@s);
334 0           return;
335             }
336              
337             sub transfer_query
338             {
339 0     0 0   my ($epp, $name, $rd) = @_;
340 0           my $mes = $epp->message();
341 0           my @d = build_command($epp, $mes, ['transfer', {'op' => 'query'}],
342             $name);
343 0 0         push(@d, build_authinfo($rd->{auth})) if Net::DRI::Util::has_auth($rd);
344 0           $mes->command_body(\@d);
345 0           return;
346             }
347              
348             ############ Transform commands
349              
350             sub create
351             {
352 0     0 0   my ($epp, $name, $rd) = @_;
353 0           my $mes = $epp->message();
354 0           my @d = build_command($epp, $mes, 'create', $name);
355 0           my $hosts = $rd->{ns};
356 0           my $cs = $rd->{contact};
357              
358 0           push(@d, add_nsname($hosts));
359 0           push(@d, build_contacts($cs));
360 0           push(@d, build_authinfo($rd->{auth}));
361 0           push(@d, build_reportlevel($rd->{reportlevel}));
362 0           $mes->command_body(\@d);
363 0           return;
364             }
365              
366             sub delete ## no critic (Subroutines::ProhibitBuiltinHomonyms)
367             {
368 0     0 0   my ($epp, $hosts) = @_;
369 0           my $mes = $epp->message();
370 0           my @d = build_command($epp, $mes, 'delete', $hosts);
371              
372 0           $mes->command_body(\@d);
373 0           return;
374             }
375              
376             sub transfer_request
377             {
378 0     0 0   my ($epp, $name, $rd) = @_;
379 0           my $mes = $epp->message();
380 0           my @d = build_command($epp, $mes, ['transfer', {'op' => 'request'}],
381             $name);
382              
383 0 0         push(@d, build_authinfo($rd->{auth})) if Net::DRI::Util::has_auth($rd);
384 0           $mes->command_body(\@d);
385 0           return;
386             }
387              
388             sub transfer_answer
389             {
390 0     0 0   my ($epp, $name, $rd) = @_;
391 0           my $mes = $epp->message();
392             my @d = build_command($epp, $mes, ['transfer',
393             {'op' => (Net::DRI::Util::has_key($rd, 'approve') && $rd->{approve} ?
394 0 0 0       'approve' : 'reject')}], $name);
395              
396 0 0         push(@d, build_authinfo($rd->{auth})) if Net::DRI::Util::has_auth($rd);
397 0           $mes->command_body(\@d);
398 0           return;
399             }
400              
401             sub transfer_cancel
402             {
403 0     0 0   my ($epp, $name, $rd) = @_;
404 0           my $mes = $epp->message();
405 0           my @d = build_command($epp, $mes, ['transfer', {'op' => 'cancel'}],
406             $name);
407              
408 0 0         push(@d, build_authinfo($rd->{auth})) if Net::DRI::Util::has_auth($rd);
409 0           $mes->command_body(\@d);
410 0           return;
411             }
412              
413             sub update
414             {
415 0     0 0   my ($epp, $hosts, $todo) = @_;
416 0           my $mes = $epp->message();
417              
418 0 0         Net::DRI::Exception::usererr_invalid_parameters($todo .
419             ' must be a Net::DRI::Data::Changes object')
420             unless Net::DRI::Util::isa_changes($todo);
421              
422 0 0         if ((grep { ! /^(?:ns|contact|auth|reportlevel)$/ } $todo->types()))
  0            
423             {
424 0           Net::DRI::Exception->die(0, 'protocol/EPP', 11,
425             'Only ns/contact add/del and auth/reportlevel set ' .
426             'available for nsset');
427             }
428              
429 0           my @d = build_command($epp, $mes, 'update', $hosts);
430              
431 0           my $nsadd = $todo->add('ns');
432 0           my $nsdel = $todo->del('ns');
433 0           my $cadd = $todo->add('contact');
434 0           my $cdel = $todo->del('contact');
435 0           my $auth = $todo->set('auth');
436 0           my $level = $todo->set('reportlevel');
437              
438 0           my (@add, @del, @set);
439 0 0 0       push(@add, add_nsname($nsadd)) if ($nsadd && !$nsadd->is_empty());
440 0 0         push(@add, build_contacts($cadd)) if ($cadd);
441              
442 0 0 0       push(@del, map { ['nsset:name', $_] } $nsdel->get_names())
  0            
443             if ($nsdel && !$nsdel->is_empty());
444 0 0         push(@del, build_contacts($cdel)) if ($cdel);
445              
446 0 0 0       push(@set, ['nsset:authInfo', $auth->{pw}])
447             if (defined($auth) && Net::DRI::Util::has_key($auth, 'pw'));
448 0 0         push(@set, build_reportlevel($level)) if (defined($level));
449              
450 0 0         push(@d, ['nsset:add', @add]) if (@add);
451 0 0         push(@d, ['nsset:rem', @del]) if (@del);
452 0 0         push(@d, ['nsset:chg', @set]) if (@set);
453              
454 0           $mes->command_body(\@d);
455 0           return;
456             }
457              
458             ####################################################################################################
459             1;