1## Domain Registry Interface, OpenSRS XCP Domain commands 2## 3## Copyright (c) 2008,2009 Patrick Mevzek <netdri@dotandco.com>. 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::OpenSRS::XCP::Domain; 19 20use strict; 21use warnings; 22 23use Net::DRI::Exception; 24use Net::DRI::Util; 25 26our $VERSION=do { my @r=(q$Revision: 1.2 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; 27 28=pod 29 30=head1 NAME 31 32Net::DRI::Protocol::OpenSRS::XCP::Domain - OpenSRS XCP Domain commands for Net::DRI 33 34=head1 DESCRIPTION 35 36Please see the README file for details. 37 38=head1 SUPPORT 39 40For now, support questions should be sent to: 41 42E<lt>netdri@dotandco.comE<gt> 43 44Please also see the SUPPORT file in the distribution. 45 46=head1 SEE ALSO 47 48E<lt>http://www.dotandco.com/services/software/Net-DRI/E<gt> 49 50=head1 AUTHOR 51 52Patrick Mevzek, E<lt>netdri@dotandco.comE<gt> 53 54=head1 COPYRIGHT 55 56Copyright (c) 2008,2009 Patrick Mevzek <netdri@dotandco.com>. 57All rights reserved. 58 59This program is free software; you can redistribute it and/or modify 60it under the terms of the GNU General Public License as published by 61the Free Software Foundation; either version 2 of the License, or 62(at your option) any later version. 63 64See the LICENSE file that comes with this distribution for more details. 65 66=cut 67 68#################################################################################################### 69 70sub register_commands 71{ 72 my ($class,$version)=@_; 73 my %tmp=( 74 info => [\&info, \&info_parse ], 75 check => [\&check, \&check_parse ], 76 create => [ \&create, \&create_parse ], ## TODO : parsing of return messages 77 delete => [ \&delete, \&delete_parse ], 78 renew => [ \&renew, \&renew_parse ], 79 transfer_request => [ \&transfer_request, \&transfer_request_parse ], 80 transfer_query => [ \&transfer_query, \&transfer_query_parse ], 81 transfer_cancel => [ \&transfer_cancel, \&transfer_cancel_parse ], 82 ); 83 84 return { 'domain' => \%tmp }; 85} 86 87sub build_msg_cookie 88{ 89 my ($msg,$action,$cookie,$regip)=@_; 90 my %r=(action=>$action,object=>'domain',cookie=>$cookie); 91 $r{registrant_ip}=$regip if defined($regip); 92 $msg->command(\%r); 93} 94 95sub info 96{ 97 my ($xcp,$domain,$rd)=@_; 98 my $msg=$xcp->message(); 99 Net::DRI::Exception::usererr_insufficient_parameters('A cookie is needed for domain_info') unless Net::DRI::Util::has_key($rd,'cookie'); 100 build_msg_cookie($msg,'get',$rd->{cookie},$rd->{registrant_ip}); 101 $msg->command_attributes({type => 'all_info'}); 102 103} 104 105sub info_parse 106{ 107 my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; 108 my $mes=$xcp->message(); 109 return unless $mes->is_success(); 110 111 $rinfo->{domain}->{$oname}->{action}='info'; 112 $rinfo->{domain}->{$oname}->{exist}=1; 113 my $ra=$mes->response_attributes(); ## Not parsed: dns_errors, descr 114 115 my %d=(registry_createdate => 'crDate', registry_expiredate => 'exDate', registry_updatedate => 'upDate', registry_transferdate => 'trDate', expiredate => 'exDateLocal'); 116 while (my ($k,$v)=each(%d)) 117 { 118 next unless exists($ra->{$k}); 119 $ra->{$k}=~s/\s+/T/; ## with a little effort we become ISO8601 120 $rinfo->{domain}->{$oname}->{$v}=$xcp->parse_iso8601($ra->{$k}); 121 } 122 123 my $ns=$ra->{nameserver_list}; 124 if (defined($ns) && ref($ns) && @$ns) 125 { 126 my $nso=$xcp->create_local_object('hosts'); 127 foreach my $h (@$ns) 128 { 129 $nso->add($h->{name},[$h->{ipaddress}]); 130 } 131 $rinfo->{domain}->{$oname}->{ns}=$nso; 132 } 133 134 foreach my $bool (qw/sponsoring_rsp auto_renew let_expire/) 135 { 136 next unless exists($ra->{$bool}); 137 $rinfo->{domain}->{$oname}->{$bool}=$ra->{$bool}; 138 } 139 140 my $c=$ra->{contact_set}; 141 if (defined($c) && ref($c) && keys(%$c)) 142 { 143 my $cs=$xcp->create_local_object('contactset'); 144 while (my ($type,$v)=each(%$c)) 145 { 146 my $c=parse_contact($xcp,$v); 147 $cs->add($c,$type eq 'owner'? 'registrant' : $type); 148 } 149 $rinfo->{domain}->{$oname}->{contact}=$cs; 150 } 151 152 ## No data about status ? 153} 154 155sub parse_contact 156{ 157 my ($xcp,$rh)=@_; 158 my $c=$xcp->create_local_object('contact'); 159 ## No ID given back ! Waouh that is great... not ! 160 $c->firstname($rh->{first_name}); 161 $c->name($rh->{last_name}); 162 $c->org($rh->{org_name}) if exists($rh->{org_name}); 163 $c->street([map { $rh->{'address'.$_} } grep {exists($rh->{'address'.$_}) && defined($rh->{'address'.$_}) } (1,2,3)]); 164 $c->city($rh->{city}) if exists($rh->{city}); 165 $c->sp($rh->{state}) if exists($rh->{state}); 166 $c->pc($rh->{postal_code}) if exists($rh->{postal_code}); 167 $c->cc($rh->{country}) if exists($rh->{country}); 168 $c->voice($rh->{phone}) if exists($rh->{voice}); 169 $c->fax($rh->{fax}) if exists($rh->{fax}); 170 $c->email($rh->{email}) if exists($rh->{email}); 171 $c->url($rh->{url}) if exists($rh->{url}); 172 return $c; 173} 174 175sub check 176{ 177 my ($xcp,$domain,$rd)=@_; 178 my $msg=$xcp->message(); 179 my %r=(action=>'lookup',object=>'domain'); 180 $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; 181 $msg->command(\%r); 182 $msg->command_attributes({domain => $domain}); 183} 184 185sub check_parse 186{ 187 my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; 188 my $mes=$xcp->message(); 189 return unless $mes->is_success(); 190 191 $rinfo->{domain}->{$oname}->{action}='check'; 192 my $ra=$mes->response_attributes(); 193 $rinfo->{domain}->{$oname}->{exist}=(exists $ra->{status} && defined($ra->{status}) && $ra->{status} eq 'available' && $mes->response_code()==210)? 0 : 1; 194 $rinfo->{domain}->{$oname}->{exist_reason}=$mes->response_text(); 195} 196 197sub create 198{ 199 my ($xcp,$domain,$rd)=@_; 200 201 sw_register($xcp, $domain, $rd, 'new'); # TBD: premium, sunrise, whois_privacy 202} 203 204sub create_parse 205{ 206 my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; 207 my $mes=$xcp->message(); 208 return unless $mes->is_success(); 209 210 $rinfo->{domain}->{$oname}->{action}='create'; 211 my $ra=$mes->response_attributes(); 212 foreach (qw/admin_email cancelled_orders error id queue_request_id forced_pending whois_privacy/) { 213 $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; 214 } 215} 216 217sub sw_register 218{ 219 my ($xcp,$domain,$rd,$reg_type)=@_; 220 221 my $msg=$xcp->message(); 222 223 my %r=(action => 'sw_register', object => 'domain'); 224 $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; 225 226 $msg->command(\%r); 227 228 Net::DRI::Exception::usererr_insufficient_parameters('Username+Password are required for sw_register') if grep { ! Net::DRI::Util::has_key($rd,$_) } qw/username password/; 229 230 Net::DRI::Exception::usererr_insufficient_parameters('contacts are mandatory') unless Net::DRI::Util::has_contact($rd); 231 my $cs=$rd->{contact}; 232 foreach my $t (qw/registrant admin billing/) 233 { 234 my @t=$cs->get($t); 235 Net::DRI::Exception::usererr_invalid_parameters('one ' . $t . ' contact is mandatory') unless @t==1; 236 my $co=$cs->get($t); 237 Net::DRI::Exception::usererr_insufficient_parameters($t . 'contact is mandatory') unless Net::DRI::Util::isa_contact($co); 238 $co->validate(); 239 } 240 241 my %contact_set = (); 242 my $attr = {reg_type => $reg_type, domain => $domain, contact_set => \%contact_set}; 243 $contact_set{owner} = add_owner_contact($msg,$cs); 244 $contact_set{admin} = add_admin_contact($msg,$cs); 245 $contact_set{billing} = add_billing_contact($msg,$cs); 246 if ($cs->get('tech')) { 247 $contact_set{tech} = add_tech_contact($msg,$cs); ## optional 248 $attr->{custom_tech_contact} = 1; 249 } else { 250 $attr->{custom_tech_contact} = 0; # Use default tech contact 251 } 252 253 # These are all the OpenSRS names for optional parameters. Might need to map generic names to OpenSRS namespace later. 254 foreach (qw/auto_renew affiliate_id f_lock_domain f_parkp f_whois_privacy/) { 255 $attr->{$_} = ($rd->{$_} ? 1 : 0 ) if Net::DRI::Util::has_key($rd, $_); 256 } 257 foreach (qw/affiliate_id reg_domain/) { 258 $attr->{$_} = ($rd->{$_}) if Net::DRI::Util::has_key($rd, $_); 259 } 260 261 # TBD: ccTLD-specific flags including domain encoding. 262 # TBD: handle, link_domains, etc. 263 264 if ($reg_type eq 'new') { 265 Net::DRI::Exception::usererr_insufficient_parameters('duration is mandatory') unless Net::DRI::Util::has_duration($rd); 266 $attr->{period} = $rd->{duration}->years(); 267 } 268 269 $attr->{reg_username} = $rd->{username}; 270 $attr->{reg_password} = $rd->{password}; 271 272 $msg->command_attributes($attr); 273 274 add_all_ns($domain,$msg,$rd->{ns}); 275} 276 277sub add_contact_info 278{ 279 my ($msg,$co)=@_; 280 my %contact = (); 281 282 $contact{first_name} = $co->firstname(); 283 $contact{last_name} = $co->name(); 284 285 $contact{org_name} = $co->org() if $co->org(); 286 287 my $s=$co->street(); 288 Net::DRI::Exception::usererr_insufficient_parameters('1 line of address at least needed') unless ($s && (ref($s) eq 'ARRAY') && @$s && $s->[0]); 289 290 $contact{address1} = $s->[0]; 291 $contact{address2} = $s->[1] if $s->[1]; 292 $contact{address3} = $s->[2] if $s->[2]; 293 Net::DRI::Exception::usererr_insufficient_parameters('city, sp, pc & cc mandatory') unless ($co->city() && $co->sp() && $co->pc() && $co->cc()); 294 $contact{city} = $co->city(); 295 $contact{state} = $co->sp(); 296 $contact{postal_code} = $co->pc(); 297 $contact{country} = uc($co->cc()); 298 Net::DRI::Exception::usererr_insufficient_parameters('voice & email mandatory') unless ($co->voice() && $co->email()); 299 $contact{phone} = $co->voice(); 300 $contact{fax} = $co->fax() if $co->fax(); 301 $contact{email} = $co->email(); 302 $contact{url} = $co->url() if $co->url(); 303 return \%contact; 304} 305 306sub add_owner_contact 307{ 308 my ($msg,$cs)=@_; 309 my $co=$cs->get('registrant'); 310 return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); 311} 312 313sub add_admin_contact 314{ 315 my ($msg,$cs)=@_; 316 my $co=$cs->get('admin'); 317 return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); 318} 319 320sub add_billing_contact 321{ 322 my ($msg,$cs)=@_; 323 my $co=$cs->get('billing'); 324 return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); 325} 326 327sub add_tech_contact 328{ 329 my ($msg,$cs)=@_; 330 my $co=$cs->get('tech'); 331 return add_contact_info($msg,$co) if Net::DRI::Util::isa_contact($co); 332} 333 334sub add_all_ns 335{ 336 my ($domain,$msg,$ns)=@_; 337 my @nslist = (); 338 339 my $attr = $msg->command_attributes(); 340 $attr->{custom_nameservers} = 0; 341 342 if (defined($ns)) { 343 Net::DRI::Exception::usererr_insufficient_parameters('at least 2 nameservers are mandatory') unless (Net::DRI::Util::isa_hosts($ns) && $ns->count()>=2); # Name servers are optional; if present must be >=2 344 345 for (my $i = 1; $i <= $ns->count(); $i++) { # Net:DRI name server list starts at 1. 346 my $name = $ns->get_details($i); # get_details in scalar returns name 347 push @nslist, { sortorder => $i, name => $name }; 348 } 349 $attr->{custom_nameservers} = 1; 350 $attr->{nameserver_list} = \@nslist; 351 } 352 $msg->command_attributes($attr); 353} 354 355sub delete 356{ 357 my ($xcp,$domain,$rd)=@_; 358 my $msg=$xcp->message(); 359 360 Net::DRI::Exception::usererr_insufficient_parameters('Reseller ID is mandatory') unless (Net::DRI::Util::has_key($rd, 'reseller_id')); 361 362 my %r=(action => 'revoke', object => 'domain'); 363 $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; 364 365 $msg->command(\%r); 366 my $attr = {domain => $domain, reseller => $rd->{reseller_id}}; 367 $attr->{notes} = $rd->{notes} if Net::DRI::Util::has_key($rd, 'notes'); 368 $msg->command_attributes({domain => $domain, reseller => $rd->{reseller_id}}); 369} 370 371sub delete_parse 372{ 373 my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; 374 my $mes=$xcp->message(); 375 return unless $mes->is_success(); 376 377 $rinfo->{domain}->{$oname}->{action}='delete'; 378 my $ra=$mes->response_attributes(); 379 foreach (qw/charge price/) { 380 $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; 381 } 382} 383 384sub renew 385{ 386 my ($xcp,$domain,$rd)=@_; 387 my $msg=$xcp->message(); 388 389 my %r=(action => 'renew', object => 'domain'); 390 $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; 391 392 Net::DRI::Exception::usererr_insufficient_parameters('auto_renew setting is mandatory') unless (Net::DRI::Util::has_key($rd, 'auto_renew')); 393 394 Net::DRI::Exception::usererr_insufficient_parameters('duration is mandatory') unless Net::DRI::Util::has_duration($rd); 395 Net::DRI::Exception::usererr_insufficient_parameters('current expiration is mandatory') unless (Net::DRI::Util::has_key($rd, 'current_expiration') && Net::DRI::Util::check_isa($rd->{current_expiration}, 'DateTime')); # Can get this from set_cookie response. 396 397 my $attr = {domain => $domain, period => $rd->{duration}->years(), currentexpirationyear => $rd->{current_expiration}->year()}; 398 399 # These are all the OpenSRS names for optional parameters. Might need to map generic names to OpenSRS namespace later. 400 foreach (qw/auto_renew f_parkp/) { 401 $attr->{$_} = ($rd->{$_} ? 1 : 0 ) if Net::DRI::Util::has_key($rd, $_); 402 } 403 foreach (qw/affiliate_id notes/) { 404 $attr->{$_} = ($rd->{$_}) if Net::DRI::Util::has_key($rd, $_); 405 } 406 407 # TBD: handle, etc. 408 409 $msg->command(\%r); 410 $msg->command_attributes($attr); 411} 412 413sub renew_parse 414{ 415 my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; 416 my $mes=$xcp->message(); 417 return unless $mes->is_success(); 418 419 $rinfo->{domain}->{$oname}->{action}='renew'; 420 my $ra=$mes->response_attributes(); 421 foreach (qw/auto_renew admin_email order_id id queue_request_id/) { 422 $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; 423 } 424 my ($k,$v)=('registration expiration date', 'exDate'); 425 $ra->{$k}=~s/\s+/T/; ## with a little effort we become ISO8601 426 $rinfo->{domain}->{$oname}->{$v}=$xcp->parse_iso8601($ra->{$k}); 427} 428 429sub transfer_request 430{ 431 my ($xcp,$domain,$rd)=@_; 432 433 sw_register($xcp, $domain, $rd, 'transfer'); 434} 435 436sub transfer_request_parse 437{ 438 my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; 439 my $mes=$xcp->message(); 440 return unless $mes->is_success(); 441 442 $rinfo->{domain}->{$oname}->{action}='transfer_start'; 443 my $ra=$mes->response_attributes(); 444 foreach (qw/admin_email cancelled_orders error id queue_request_id forced_pending whois_privacy/) { 445 $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; 446 } 447} 448 449sub transfer_query 450{ 451 my ($xcp,$domain,$rd)=@_; 452 my $msg=$xcp->message(); 453 454 my %r=(action => 'check_transfer', object => 'domain'); 455 $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; 456 457 $msg->command(\%r); 458 $msg->command_attributes({domain => $domain, check_status => 1, get_request_address => 1}); # TBD: usable for checking transferability 459} 460 461sub transfer_query_parse 462{ 463 my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; 464 my $mes=$xcp->message(); 465 return unless $mes->is_success(); 466 467 $rinfo->{domain}->{$oname}->{action}='check_transfer'; 468 my $ra=$mes->response_attributes(); 469 foreach (qw/transferrable status request_address timestamp unixtime reason type noservice/) { 470 $rinfo->{domain}->{$oname}->{$_} = $ra->{$_} if exists $ra->{$_}; 471 } 472} 473 474sub transfer_cancel 475{ 476 my ($xcp,$domain,$rd)=@_; 477 my $msg=$xcp->message(); 478 479 Net::DRI::Exception::usererr_insufficient_parameters('Reseller ID is mandatory') unless (Net::DRI::Util::has_key($rd, 'reseller_id')); 480 481 my %r=(action => 'cancel_transfer', object => 'transfer'); 482 $r{registrant_ip}=$rd->{registrant_ip} if exists $rd->{registrant_ip}; 483 484 $msg->command(\%r); 485 $msg->command_attributes({domain => $domain, reseller => $rd->{reseller_id}}); # TBD: optional order ID 486} 487 488sub transfer_cancel_parse 489{ 490 my ($xcp,$otype,$oaction,$oname,$rinfo)=@_; 491 my $mes=$xcp->message(); 492 return unless $mes->is_success(); 493 494 $rinfo->{domain}->{$oname}->{action}='cancel_transfer'; 495 # This response has no attributes to capture 496} 497 498#################################################################################################### 4991; 500