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