1## Domain Registry Interface, RRI Domain commands (DENIC-11)
2##
3## Copyright (c) 2007,2008 Tonnerre Lombard <tonnerre.lombard@sygroup.ch>. 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#
16####################################################################################################
17
18package Net::DRI::Protocol::RRI::Domain;
19
20use strict;
21
22##use IDNA::Punycode;
23use DateTime::Format::ISO8601 ();
24
25use Net::DRI::Util;
26use Net::DRI::Exception;
27use Net::DRI::Data::Hosts;
28use Net::DRI::Data::ContactSet;
29
30our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); };
31
32=pod
33
34=head1 NAME
35
36Net::DRI::Protocol::RRI::Domain - RRI Domain commands (DENIC-11) for Net::DRI
37
38=head1 DESCRIPTION
39
40Please see the README file for details.
41
42=head1 SUPPORT
43
44For now, support questions should be sent to:
45
46E<lt>tonnerre.lombard@sygroup.chE<gt>
47
48Please also see the SUPPORT file in the distribution.
49
50=head1 SEE ALSO
51
52E<lt>http://oss.bsdprojects.net/projects/netdri/E<gt>
53
54=head1 AUTHOR
55
56Tonnerre Lombard, E<lt>tonnerre.lombard@sygroup.chE<gt>
57
58=head1 COPYRIGHT
59
60Copyright (c) 2007,2008 Tonnerre Lombard <tonnerre.lombard@sygroup.ch>.
61All rights reserved.
62
63This program is free software; you can redistribute it and/or modify
64it under the terms of the GNU General Public License as published by
65the Free Software Foundation; either version 2 of the License, or
66(at your option) any later version.
67
68See the LICENSE file that comes with this distribution for more details.
69
70=cut
71
72####################################################################################################
73
74sub register_commands
75{
76 my ($class,$version)=@_;
77 my %tmp=(
78           check  => [ \&check, \&check_parse ],
79           info   => [ \&info, \&info_parse ],
80           transfer_query  => [ \&transfer_query, \&transfer_parse ],
81           create => [ \&create, \&create_parse ],
82           delete => [ \&delete ],
83           transfer_request => [ \&transfer_request ],
84           transfer_answer  => [ \&transfer_answer ],
85           trade => [ \&trade ],
86           update => [ \&update],
87         );
88
89 ##$tmp{check_multi} = $tmp{check};
90 return { 'domain' => \%tmp };
91}
92
93sub build_command
94{
95 my ($msg, $command, $domain, $domainattr, $dns) = @_;
96 my @dom = (ref($domain))? @$domain : ($domain);
97 Net::DRI::Exception->die(1,'protocol/RRI', 2, 'Domain name needed')
98	unless @dom;
99 foreach my $d (@dom)
100 {
101  Net::DRI::Exception->die(1, 'protocol/RRI', 2, 'Domain name needed')
102	unless defined($d) && $d;
103  Net::DRI::Exception->die(1, 'protocol/RRI', 10, 'Invalid domain name: ' . $d)
104	unless Net::DRI::Util::is_hostname($d);
105 }
106
107 my $tcommand = (ref($command)) ? $command->[0] : $command;
108 my @ns = @{$msg->ns->{domain}};
109 $msg->command(['domain', $tcommand, (defined($dns) ? $dns : $ns[0]), $domainattr]);
110
111 my @d;
112
113 foreach my $domain (@dom)
114 {
115  ##my $ace = join('.', map { decode_punycode($_) } split(/\./, $domain));
116  push @d, ['domain:handle', $domain];
117  push @d, ['domain:ace', $domain];
118 }
119 return @d;
120}
121
122####################################################################################################
123########### Query commands
124
125sub check
126{
127 my ($rri, $domain, $rd)=@_;
128 my $mes = $rri->message();
129 my @d = build_command($mes, 'check', $domain);
130 $mes->command_body(\@d);
131 $mes->cltrid(undef);
132}
133
134
135sub check_parse
136{
137 my ($po,$otype,$oaction,$oname,$rinfo)=@_;
138 my $mes = $po->message();
139 return unless $mes->is_success();
140
141 my $chkdata = $mes->get_content('checkData',$mes->ns('domain'));
142 return unless $chkdata;
143 my @d = $chkdata->getElementsByTagNameNS($mes->ns('domain'),'handle');
144 my @s = $chkdata->getElementsByTagNameNS($mes->ns('domain'),'status');
145 return unless (@d && @s);
146
147 my $dom = $d[0]->getFirstChild()->getData();
148 $rinfo->{domain}->{$dom}->{action} = 'check';
149 $rinfo->{domain}->{$dom}->{exist} =  ($s[0]->getFirstChild()->getData() eq 'free')? 0 : 1;
150}
151
152sub info
153{
154 my ($rri, $domain, $rd)=@_;
155 my $mes = $rri->message();
156 my @d = build_command($mes, 'info', $domain,
157	{recursive => 'false', withProvider => 'true'});
158 $mes->command_body(\@d);
159 $mes->cltrid(undef);
160}
161
162sub info_parse
163{
164 my ($po, $otype, $oaction, $oname, $rinfo) = @_;
165 my $mes = $po->message();
166 return unless $mes->is_success();
167 my $infdata = $mes->get_content('infoData', $mes->ns('domain'));
168 return unless $infdata;
169 my $cs = Net::DRI::Data::ContactSet->new();
170 my $ns = Net::DRI::Data::Hosts->new();
171 my $c = $infdata->getFirstChild();
172
173 while ($c)
174 {
175  next unless ($c->nodeType() == 1); ## only for element nodes
176  my $name = $c->localname() || $c->nodeName();
177  next unless $name;
178
179  if ($name eq 'handle')
180  {
181   $oname = lc($c->getFirstChild()->getData());
182   $rinfo->{domain}->{$oname}->{action} = 'info';
183   $rinfo->{domain}->{$oname}->{exist} = 1;
184  }
185  elsif ($name eq 'status')
186  {
187   my $val = $c->getFirstChild()->getData();
188   $rinfo->{domain}->{$oname}->{exist} = ($val eq 'connect')? 1 : 0;
189  }
190  elsif ($name eq 'contact')
191  {
192   my $role = $c->getAttribute('role');
193   my %rmap = ('holder' => 'registrant', 'admin-c' => 'admin',
194	'tech-c' => 'tech', 'zone-c' => 'zone');
195   my @hndl_tags = $c->getElementsByTagNameNS($mes->ns('contact'),'handle');
196   my $hndl_tag = $hndl_tags[0];
197   $role = $rmap{$role} if (defined($rmap{$role}));
198   $cs->add($po->create_local_object('contact')->srid($hndl_tag->getFirstChild()->getData()), $role)
199	if (defined($hndl_tag));
200  }
201  elsif ($name eq 'dnsentry')
202  {
203   $ns->add(parse_ns($mes,$c));
204  }
205  elsif ($name eq 'regAccId')
206  {
207   $rinfo->{domain}->{$oname}->{clID} =
208   $rinfo->{domain}->{$oname}->{crID} =
209   $rinfo->{domain}->{$oname}->{upID} = $c->getFirstChild()->getData();
210  }
211  elsif ($name eq 'changed')
212  {
213   $rinfo->{domain}->{$oname}->{crDate} =
214   $rinfo->{domain}->{$oname}->{upDate} =
215	DateTime::Format::ISO8601->new()->
216		parse_datetime($c->getFirstChild()->getData());
217  }
218  elsif ($name eq 'chprovData')
219  {
220   # FIXME: Implement this one as well
221  }
222 } continue { $c = $c->getNextSibling(); }
223
224 $rinfo->{domain}->{$oname}->{contact} = $cs;
225 $rinfo->{domain}->{$oname}->{status} = $po->create_local_object('status');
226 $rinfo->{domain}->{$oname}->{ns} = $ns;
227}
228
229sub parse_ns
230{
231 my $mes = shift;
232 my $node = shift;
233 my $n = $node->getFirstChild();
234 my $hostname = '';
235 my @ip4 = ();
236 my @ip6 = ();
237
238 while ($n)
239 {
240  next unless ($n->nodeType() == 1); ## only for element nodes
241  my $name = $n->localname() || $n->nodeName();
242  next unless $name;
243
244  if ($name eq 'rdata')
245  {
246   my $nn = $n->getFirstChild();
247   while ($nn)
248   {
249    next unless ($nn->nodeType() == 1); ## only for element nodes
250    my $name2 = $nn->localname() || $nn->nodeName();
251    next unless $name2;
252    if ($name2 eq 'nameserver')
253    {
254     $hostname = $nn->getFirstChild()->getData();
255     $hostname =~ s/\.$// if ($hostname =~ /\.$/);
256    }
257    elsif ($name2 eq 'address')
258    {
259     my $ip = $nn->getFirstChild()->getData();
260     if ($ip=~m/:/)
261     {
262      push @ip6, $ip;
263     }
264     else
265     {
266      push @ip4, $ip;
267     }
268    }
269   } continue { $nn = $nn->getNextSibling(); }
270  }
271 } continue { $n = $n->getNextSibling(); }
272
273 return ($hostname, \@ip4, \@ip6);
274}
275
276sub transfer_query
277{
278 my ($rri, $domain, $rd)=@_;
279 my $mes = $rri->message();
280 my @d = build_command($mes, 'info', $domain,
281	{recursive => 'true', withProvider => 'false'});
282 $mes->command_body(\@d);
283}
284
285sub transfer_parse
286{
287 my ($po, $otype, $oaction, $oname, $rinfo) = @_;
288 my $mes = $po->message();
289 return unless $mes->is_success();
290
291 my $infodata = $mes->get_content('infoData', $mes->ns('domain'));
292 return unless $infodata;
293 my $namedata = ($infodata->getElementsByTagNameNS($mes->ns('domain'),
294	'handle'))[0];
295 return unless $namedata;
296 my $trndata = ($infodata->getElementsByTagNameNS($mes->ns('domain'),
297	'chprovData'))[0];
298 return unless $trndata;
299
300 $oname = lc($namedata->getFirstChild()->getData());
301 $rinfo->{domain}->{$oname}->{action} = 'transfer';
302 $rinfo->{domain}->{$oname}->{exist} = 1;
303 $rinfo->{domain}->{$oname}->{trStatus} = undef;
304
305 my $c = $trndata->getFirstChild();
306 while ($c)
307 {
308  next unless ($c->nodeType() == 1); ## only for element nodes
309  my $name = $c->localname() || $c->nodeName();
310  next unless $name;
311
312  if ($name eq 'chprovTo')
313  {
314   $rinfo->{domain}->{$oname}->{reID} = $c->getFirstChild()->getData();
315  }
316  elsif ($name eq 'chprovStatus')
317  {
318   my %stmap = (ACTIVE => 'pending', REMINDED => 'pending');
319   my $val = $c->getFirstChild()->getData();
320   $rinfo->{domain}->{$oname}->{trStatus} =
321	(defined($stmap{$val}) ? $stmap{$val} : $val);
322  }
323  elsif ($name =~ m/^(chprovStart|chprovReminder|chprovEnd)$/)
324  {
325   my %tmmap = (chprovStart => 'reDate', chprovReminder => 'acDate',
326	chprovEnd => 'exDate');
327   $rinfo->{domain}->{$oname}->{$tmmap{$1}} = DateTime::Format::ISO8601->
328	new()->parse_datetime($c->getFirstChild()->getData());
329  }
330 } continue { $c = $c->getNextSibling(); }
331}
332
333############ Transform commands
334
335sub create
336{
337 my ($rri, $domain, $rd) = @_;
338 my $mes = $rri->message();
339 my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi);
340 my @d = build_command($mes, 'create', $domain, undef, \%ns);
341
342 my $def = $rri->default_parameters();
343 if ($def && (ref($def) eq 'HASH') && exists($def->{domain_create}) &&
344	(ref($def->{domain_create}) eq 'HASH'))
345 {
346  $rd = {} unless ($rd && (ref($rd) eq 'HASH') && keys(%$rd));
347  while (my ($k, $v) = each(%{$def->{domain_create}}))
348  {
349   next if exists($rd->{$k});
350   $rd->{$k} = $v;
351  }
352 }
353
354 ## Contacts, all OPTIONAL
355 push @d,build_contact($rd->{contact}) if Net::DRI::Util::has_contact($rd);
356
357 ## Nameservers, OPTIONAL
358 push @d,build_ns($rri,$rd->{ns},$domain) if Net::DRI::Util::has_ns($rd);
359
360 $mes->command_body(\@d);
361}
362
363sub build_contact
364{
365 my $cs = shift;
366 my @d;
367
368 my %trans = ('registrant' => 'holder', 'admin' => 'admin-c',
369	'tech' => 'tech-c', 'zone' => 'zone-c');
370
371 # All nonstandard contacts go into the extension section
372 foreach my $t (sort($cs->types()))
373 {
374  my @o = $cs->get($t);
375  my $c = (defined($trans{$t}) ? $trans{$t} : $t);
376  push @d, map { ['domain:contact', $_->srid(), {'role' => $c}] } @o;
377 }
378 return @d;
379}
380
381sub build_ns
382{
383 my ($rri,$ns,$domain,$xmlns)=@_;
384 my @d;
385
386 foreach my $i (1..$ns->count())
387 {
388  my ($n, $v4, $v6) = $ns->get_details($i);
389  my @h = map { ['dnsentry:address', $_] } (@{$v4}, @{$v6});
390  push @d, ['dnsentry:dnsentry', {'xsi:type' => 'dnsentry:NS'},
391	['dnsentry:owner', $domain . '.'],
392	['dnsentry:rdata', ['dnsentry:nameserver', $n . '.' ], @h ] ];
393 }
394
395 $xmlns='dnsentry' unless defined($xmlns);
396 return @d;
397}
398
399sub create_parse
400{
401 my ($po, $otype, $oaction, $oname, $rinfo) = @_;
402 my $mes = $po->message();
403 return unless $mes->is_success();
404
405 my $credata = $mes->get_content('creData', $mes->ns('domain'));
406 return unless $credata;
407
408 my $c = $credata->getFirstChild();
409 while ($c)
410 {
411  next unless ($c->nodeType() == 1); ## only for element nodes
412  my $name = $c->localname() || $c->nodeName();
413  next unless $name;
414
415  if ($name eq 'name')
416  {
417   $oname = lc($c->getFirstChild()->getData());
418   $rinfo->{domain}->{$oname}->{action} = 'create';
419   $rinfo->{domain}->{$oname}->{exist} = 1;
420  }
421  elsif ($name =~ m/^(crDate|exDate)$/)
422  {
423   $rinfo->{domain}->{$oname}->{$1} = DateTime::Format::ISO8601->new()->
424	parse_datetime($c->getFirstChild()->getData());
425  }
426 } continue { $c = $c->getNextSibling(); }
427}
428
429sub delete
430{
431 my ($rri, $domain, $rd) = @_;
432 my $mes = $rri->message();
433 my @d = build_command($mes, 'delete', $domain);
434
435 ## Holder contact
436 if (Net::DRI::Util::has_contact($rd))
437 {
438  my $ocs = $rd->{contact};
439  my $cs = Net::DRI::Data::ContactSet->new();
440  foreach my $c ($ocs->get('registrant'))
441  {
442   $cs->add($c, 'registrant');
443  }
444
445  push @d, build_contact($cs);
446 }
447
448 $mes->command_body(\@d);
449}
450
451sub transfer_request
452{
453 my ($rri, $domain, $rd) = @_;
454 my $mes = $rri->message();
455 my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi);
456 my @d = build_command($mes, 'chprov', $domain, undef, \%ns);
457
458 ## Contacts, all OPTIONAL
459 push @d,build_contact($rd->{contact}) if Net::DRI::Util::has_contact($rd);
460
461 ## Nameservers, OPTIONAL
462 push @d, build_ns($rri, $rd->{ns}, $domain) if Net::DRI::Util::has_ns($rd);
463
464 $mes->command_body(\@d);
465}
466
467sub transfer_answer
468{
469 my ($rri, $domain, $rd) = @_;
470 my $mes = $rri->message();
471 my @d = build_command($mes, (Net::DRI::Util::has_key($rd,'approve') && $rd->{approve}) ?
472	'chprovAck' : 'chprovNack', $domain);
473 $mes->command_body(\@d);
474}
475
476sub trade
477{
478 my ($rri, $domain, $rd) = @_;
479 my $mes = $rri->message();
480 my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi);
481 my @d = build_command($mes, 'chholder', $domain, undef, \%ns);
482
483 my $def = $rri->default_parameters();
484 if ($def && (ref($def) eq 'HASH') && exists($def->{domain_create}) &&
485	(ref($def->{domain_create}) eq 'HASH'))
486 {
487  $rd = {} unless ($rd && (ref($rd) eq 'HASH') && keys(%$rd));
488  while (my ($k, $v) = each(%{$def->{domain_create}}))
489  {
490   next if exists($rd->{$k});
491   $rd->{$k} = $v;
492  }
493 }
494
495 ## Contacts, all OPTIONAL
496 push @d,build_contact($rd->{contact}) if Net::DRI::Util::has_contact($rd);
497
498 ## Nameservers, OPTIONAL
499 push @d, build_ns($rri, $rd->{ns}, $domain) if Net::DRI::Util::has_ns($rd);
500
501 $mes->command_body(\@d);
502}
503
504sub update
505{
506 my ($rri, $domain, $todo, $rd)=@_;
507 my $mes = $rri->message();
508 my %ns = map { $_ => $mes->ns->{$_}->[0] } qw(domain dnsentry xsi);
509 my $ns = $rd->{ns};
510 my $cs = $rd->{contact};
511
512 Net::DRI::Exception::usererr_invalid_parameters($todo.' must be a Net::DRI::Data::Changes object') unless Net::DRI::Util::isa_changes($todo);
513
514 Net::DRI::Exception::usererr_invalid_parameters('Must specify contact set and name servers with update command (or use the proper API)') unless (Net::DRI::Util::isa_contactset($cs) && Net::DRI::Util::isa_hosts($ns));
515
516 if ((grep { ! /^(?:add|del)$/ } $todo->types('ns')) ||
517     (grep { ! /^(?:add|del)$/ } $todo->types('contact')))
518 {
519  Net::DRI::Exception->die(0, 'protocol/RRI', 11, 'Only ns/status/contact add/del or registrant/authinfo set available for domain');
520 }
521
522 my @d = build_command($mes, 'update', $domain, undef, \%ns);
523
524 my $nsadd = $todo->add('ns');
525 my $nsdel = $todo->del('ns');
526 my $cadd = $todo->add('contact');
527 my $cdel = $todo->del('contact');
528
529 if (defined($nsadd)) { foreach my $hostname ($nsadd->get_names())
530 {
531   $ns->add($nsadd->get_details($hostname));
532 } }
533
534 if (defined($nsdel))
535 {
536  my $newns =Net::DRI::Data::Hosts->new();
537
538  foreach my $hostname ($ns->get_names())
539  {
540   if (!grep { $_ eq $hostname } $nsdel->get_names())
541   {
542    $newns->add($ns->get_details($hostname));
543   }
544  }
545
546  $ns = $newns;
547 }
548
549 if (defined($cadd)) { foreach my $type ($cadd->types()) {
550  foreach my $c ($cadd->get($type))
551  {
552   $cs->add($c, $type);
553  }
554 } }
555
556 if (defined($cdel)) { foreach my $type ($cdel->types()) {
557  foreach my $c ($cdel->get($type))
558  {
559   $cs->del($c, $type);
560  }
561 } }
562
563 push @d, build_contact($cs);
564 push @d, build_ns($rri, $ns, $domain);
565
566 $mes->command_body(\@d);
567}
568
569####################################################################################################
5701;
571